1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:

var
  fkt: TWildcardFunction;
begin
  fkt := CompileWildcardFunction(eWildcard.Text);
  try
    if fkt(PChar(eText.Text)) then
      lAusgabe.Caption := 'Ja'
    else
      lAusgabe.Caption := 'Nein';
  finally
    FreeWildCardFunction(fkt);
  end;
end;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:
487:
488:
489:
490:
491:
492:
493:
494:
495:
496:
497:
498:
499:
500:
501:
502:
503:
504:
505:
506:
507:
508:
509:
510:
511:
512:
513:
514:
515:
516:
517:
518:
519:
520:
521:
522:
523:
524:
525:
526:
527:
528:
529:
530:
531:
532:
533:
534:
535:
536:
537:
538:
539:
540:
541:
542:
543:
544:
545:
546:
547:
548:
549:
550:
551:
552:
553:
554:
555:
556:
557:
558:
559:
560:
561:
562:
563:
564:
565:
566:
567:
568:
569:
570:
571:
572:
573:
574:
575:
576:
577:
578:
579:
580:
581:
582:
583:
584:
585:
586:
587:
588:
589:
590:
591:
592:
593:
594:
595:
596:
597:
598:
599:
600:
601:
602:
603:
604:
605:
606:
607:
608:
609:
610:
611:
612:
613:
614:
615:
616:
617:
618:
619:
620:
621:
622:
623:
624:
625:
626:
627:
628:
629:
630:
631:
632:
633:
634:

(**
 * fastwild.pas V. 0.4.1 - unit for compiling wildcard matching functions at
 * runtime
 *
 * (C) 2005 I.MacLeod
 *)
{$DEFINE DEBUG}  // check for memory leaks
{$B-}            // use short-circuit boolean evaluation

// just remove the following line if your compiler reports an error
// Upd: everything should work just fine
{/$MESSAGE WARN 'This unit is an unstable version - use not recommended'}
unit fastwild;

interface

uses
  Windows;

type
  TWildcardFunction = function(Str: PChar): boolean; register;

function CompileWildcardFunction(Pattern: AnsiString): TWildcardFunction;
procedure FreeWildCardFunction(WildcardFunction: TWildcardFunction);

implementation

{$IFDEF DEBUG}
var
  WildcardFunctionCount: integer = 0;
{$ENDIF}

(**
 * Compiles a Pattern to an executable function for better performace. Functions
 * created using this function need to be freed using FreeWildcardFunction
 *
 * @param Pattern string containing the pattern to be matched
 * @return Pointer to Adress of Function
 *)
function CompileWildcardFunction(Pattern: AnsiString): TWildcardFunction;
type
  (**
   * Data structure for fixups
   *)
  TFixup = record
             CodeAddr: DWORD;
             IsData: boolean;
             case integer of
               1: (DataAddr: integer);
               2: (Typ: integer);
           end;
  TFixups = array of TFixup;
const
  (**
   * Code
   *)
  DEADBEEF     = #$EF#$BE#$AD#$DE;

  PUSHESI      = #$56;                    // push   esi
  PUSHEDI      = #$57;                    // push   edi
  POPESI       = #$5E;                    // pop    esi
  POPEDI       = #$5F;                    // pop    edi
  MOVESIEAX    = #$89#$C6;                // mov    esi, eax
  COMPAREBYTE  = #$80#$3E;                // cmp    byte ptr [esi], imm8
  INCESI       = #$46;                    // inc    esi
  DECESI       = #$4E;                    // dec    esi
  COMPAREDWORD = #$81#$3E;                // cmp    dword ptr [esi], imm32
  COMPAREWORD  = #$66 + COMPAREDWORD;     // cmp    word ptr [esi], imm16
  ADDESI4      = #$83#$C6#$04;            // add    esi, 4
  ADDESI2      = #$83#$C6#$02;            // add    esi, 2
  MOVEDIDB     = #$BF + DEADBEEF;         // mov    edi, $DEADBEEF (@@data)
  MOVECXIMM32  = #$B9;                    // mov    ecx, imm32
  LEAEAXESI1   = #$8D#$46#$01;            // lea    eax, [esi+1]
  REPZCMPSB    = #$F3#$A6;                // repz   cmpsb
  JNZFALSE     = #$0F#$85 + DEADBEEF;     // jnz    $DEADBEEF (@@false)
  JZFALSE      = #$0F#$84 + DEADBEEF;     // jz     $DEADBEEF (@@false)
  JBFALSE      = #$0F#$82 + DEADBEEF;     // jb     $DEADBEEF (@@false)
  JNBFALSE     = #$0F#$83 + DEADBEEF;     // jnb    $DEADBEEF (@@false)
  CMOVNZEDIEAX = #$0F#$45#$F0;            // cmovnz esi, eax
  JNZE3        = #$75#$E3;                // jnz    -$1D
  JNZF0        = #$75#$F0;                // jnz    -$10
  JNZEE        = #$75#$EE;                // jnz    -$12
  JNZED        = #$75#$ED;                // jnz    -$13
  JBF6         = #$72#$F6;                // jb     -$0a
  JNBF6        = #$73#$F6;                // jnb    -$0a
  CMPESI18     = #$80#$7E#$FF;            // cmp    byte ptr [esi-1], imm8
  CMPESI132    = #$81#$7E#$FF;            // cmp    dword ptr [esi-1], imm32
  CMPESI116    = #$66 + CMPESI132;        // cmp    word ptr [esi-1], imm16
  XOREAXEAX    = #$31#$C0;                // xor    eax, eax
  LODSB        = #$AC;                    // lodsb
  BTRMEAX      = #$0F#$A3#$05 + DEADBEEF; // bt     [$DEADBEEF], eax
  MOVEDXESI    = #$89#$F2;                // mov    edx, esi
  MOVESIEDX    = #$89#$D6;                // mov    esi, edx
  INCEDX       = #$42;                    // inc    edx
  RETTRUE      = #$B0#$01#$C3;            // mov    al, 1
                                          // ret
  RETFALSE     = #$31#$C0#$C3;            // xor    eax, eax
                                          // ret
                                          
  PREFIX       = PUSHESI + PUSHEDI + MOVESIEAX;
  SUFFIX       = POPEDI + POPESI + RETTRUE + POPEDI + POPESI + RETFALSE;

  (**
   * Fixup types
   *)
  RETURNFALSE  = 0;
  FIXUPJUMP    = 1;
var
  Code, Data: AnsiString;
  Fixups: TFixups;
  p: PAnsiChar;
  DataAddress: Pointer;
  RetFalseAddr: integer;
  dummy: dword absolute dataAddress;
  FixupAddr: PDWORD;
  FixupAddrI: PInteger absolute FixupAddr;

  (**
   * Appends a string to "Data"
   *
   * @param s the string to be added
   * @return Offset of s in Data
   *)
  function AddData(const s: string): integer; overload;
  begin
    Result := Length(Data);
    Data := Data + s;
  end;

  (**
   * Appends data to "Data"
   *
   * @param s Variable to be added
   * @param length Length of s in memory
   * @return Offset of s in Data
   *)
   function AddData(const s; length: integer): integer; overload;
   begin
     Result := System.Length(Data);
     SetLength(Data, System.Length(Data) + length);
     Move(s, Data[Result+1], length);
   end;

  (**
   * Adds a Fixup to the list
   *
   * @param ACodeAddr offset where the fixup needs to be applied (relative
   *                  to length of code when called)
   * @param AIsData set to true if fixup refers to an offset in "Data"
   * @param AParam Offset of Data if AIsData is set, otherwise type of fixup
   *)
  procedure AddFixup(ACodeAddr: integer; AIsData: boolean; AParam: DWORD);
  begin
    SetLength(Fixups, Length(Fixups)+1);
    with Fixups[high(Fixups)] do
    begin
      CodeAddr := length(Code) + ACodeAddr;
      IsData := AIsData;
      DataAddr := AParam;
    end;
  end;

  (**
   * Appends a dword to code
   *
   * @param d value to be appended
   *)
  procedure EmitDW(d: dword);
  begin
    SetLength(Code, Length(Code)+4);
    PDWORD(@Code[Length(Code)-3])^ := d;
  end;

  (**
   * Appends a word to code
   *
   * @param w value to be appended
   *)
  procedure EmitW(w: word);
  begin
    SetLength(Code, Length(Code)+2);
    PWORD(@Code[Length(Code)-1])^ := w;
  end;

  (**
   * Creates a fixup for a jump
   *
   * @param codeAddr the address of the offset in the code
   * @param jumpAddr the address to jump to
   *)
  procedure JumpAddress(codeAddr: integer; jumpAddr: integer);
  begin
    PDWord(@Code[Length(Code)+codeAddr+1])^ := jumpAddr;
    AddFixup(codeAddr, false, FIXUPJUMP);
  end;

  (**
   * Creates code for set-matching ([a-z])
   *
   * @param jumpTo [optional] address to jmp to if set doesn't match
   *)
  procedure CreateSetCode(jumpTo: integer = -1);
  var
    // ecx must be preserved

    // 0: one character
    // 1: zero or more characters
    // 2: one or more characters
    mode: byte;
    charAddr: dword;

    chars: set of char;
    char1: char;

    negation: boolean;
  begin
    negation := p^ = '!';
    if negation then
      inc(p);
    mode := 0;
    case p^ of
      '\': if not ((p+1)^ in ['*', '+']) then
             dec(p);
      '*': mode := 1;
      '+': mode := 2;
      else dec(p);
    end;
    inc(p);

    chars := [];
    while not (p^ in [#0, ']']) do
    begin
      // escape next char
      if p^ = '\' then
        inc(p);

      if p^ <> #0 then
      begin
        // get starting char
        char1 := p^;
        // there's a range
        if (p+1)^ = '-' then
        begin
          // go to second char
          inc(p, 2);
          // if we have something like [...A-], add A and - to the set
          if p^ in [#0, ']'] then
            chars := chars + [char1, '-']
          else
          begin
            // escape next char
            if p^ = '\' then
              inc(p);
            if p^ = #0 then
              chars := chars + [char1..'\']
            else
            begin
              // first char > second char, add first char, "-" and second char
              // (z-a)
              // otherwise, add the range
              if char1 > p^ then
                chars := chars + [char1, '-', p^]
              else
                chars := chars + [char1..p^];
              inc(p);
            end;
          end;
        end else
        begin
          chars := chars + [char1];
          inc(p);
        end;
      end;
    end;
    if p^ = ']' then
      inc(p);

    // we could implement negation also by simply inverting the state of each
    // char in the set, but since I've already coded it like this, I don't
    // want to change it anymore :D
    if negation then
      chars := chars + [#0];

    // add the set to the data-block. This takes 32bytes per set
    charAddr := AddData(chars, sizeof(chars));
    // Always check the first char
    //  al => char
    Code := Code + XOREAXEAX + LODSB + BTRMEAX;
    AddFixup(-4, true, charAddr);
    if mode = 1 then
    begin
      // check another one, if the char did[n't] match. Otherwise decrement esi
      if negation then
        Code := Code + JNBF6 + DECESI
      else
        Code := Code + JBF6 + DECESI;
    end
    else
    begin
       // return false if char does[n't] match
      if negation then
        Code := Code + JBFALSE
      else
        Code := Code + JNBFALSE;

      // if there's an address where we should jump if this set doesn't match,
      // add an fixup for it
      if jumpTo > -1 then
        JumpAddress(-4, jumpTo)
      else
        AddFixup(-4, false, RETURNFALSE);

      if mode = 2 then
      begin
        Code := Code + LODSB + BTRMEAX; // check next char / return false if ...
        AddFixup(-4, true, charAddr);
        if negation then                // check another one or decrement esi
          Code := Code + JNBF6 + DECESI
        else
          Code := Code + JBF6 + DECESI;
      end;
    end;

    if (p^ = #0) then
    begin
      // check for end-of-string
      Code := Code + COMPAREBYTE + #00 + JNZFALSE;

      if jumpTo > -1 then
        JumpAddress(-4, jumpTo)
      else
        AddFixup(-4, false, RETURNFALSE);
    end;
  end;

  (**
   * Creates code for set-matching ([a-z])
   *
   * @param Str the string to be checked
   * @param jumpTo [optional] address to jmp to if set doesn't match
   *)
  procedure CreateStringCode(Str: string; jumpTo: integer = -1);
  begin
    // ecx must be preserved
    case Length(Str) of
      1:   begin
             Code := Code + COMPAREBYTE + Str[1] + JNZFALSE;
             if jumpTo > -1 then
               JumpAddress(-4, jumpTo)
             else
               AddFixup(-4, false, RETURNFALSE);
             Code := Code + INCESI;
           end;
      2:   begin
             Code := Code + COMPAREWORD;
             EmitW(pword(@Str[1])^);
             Code := Code + JNZFALSE;
             if jumpTo > -1 then
               JumpAddress(-4, jumpTo)
             else
               AddFixup(-4, false, RETURNFALSE);
             Code := Code + ADDESI2;
           end;
      4:   begin
             Code := Code + COMPAREDWORD;
             EmitDW(pdword(@Str[1])^);
             Code := Code + JNZFALSE;
             if jumpTo > -1 then
               JumpAddress(-4, jumpTo)
             else
               AddFixup(-4, false, RETURNFALSE);
             Code := Code + ADDESI4;
           end;
      else Code := Code + MOVEDIDB + MOVECXIMM32;
           AddFixup(-5, true, AddData(Str));
           EmitDW(Length(Str));
           Code := Code + REPZCMPSB + JNZFALSE;
           if jumpTo > -1 then
             JumpAddress(-4, jumpTo)
           else
             AddFixup(-4, false, RETURNFALSE);
    end;
  end;

  (**
   * Reads the next block
   *
   * @return next block
   *)
  function ReadNextPart: string;
  begin
    result := '';

    // char is escaped
    if p^ = '\' then
    begin
      inc(p);
      if p^ <> #0 then
      begin
        result := result + p^;
        inc(p);
      end;
    end;

    while not (p^ in [#0, '*', '?', '[']) do
    begin
      result := result + p^;
      inc(p);
      // char is escaped
      if p^ = '\' then
      begin
        inc(p);
        if p^ <> #0 then
        begin
          result := result + p^;
          inc(p);
        end;
      end;
    end;
    // make sure that "*o" matches "foo"
    if p^ = #0 then
      Result := Result + p^;
  end;

  (**
   * Creates code for the current string in buffer
   *
   * @param Asterisk may there be other chars in front of the next part?
   * @param Buffer next part
   *)
  procedure FlushBuffer(Asterisk: boolean; const Buffer: string);
  var
    start: integer;
  begin
    if ((Length(Buffer) > 0) and (Buffer[1] <> #0)) or (Asterisk and
      (Buffer <> #0)) then
    begin
      case Asterisk of
        true:  begin
                 start := -1;
                 if p^ in ['[', '?'] then
                 begin
                   // save current strpos in edx
                   Code := Code + MOVEDXESI;
                   // get current position in code
                   start := Length(code);
                   // reset strpos
                   Code := Code + MOVESIEDX;
                   // inc edx
                   Code := Code + INCEDX;

                   // IMPORTANT: edx must be preserved
                 end;

                 Code := Code + COMPAREBYTE + #00 + JZFALSE;
                 AddFixup(-4, false, RETURNFALSE);
                 case Length(Buffer) of
                   0:   ;
                   1:   Code := Code + INCESI + CMPESI18 + Buffer[1] + JNZF0;
                   2:   begin
                          Code := Code + INCESI + CMPESI116;
                          EmitW(PWord(@Buffer[1])^);
                          Code := Code + JNZEE;
                        end;
                   4:   begin
                          Code := Code + INCESI + CMPESI132;
                          EmitDW(PDWord(@Buffer[1])^);
                          Code := Code + JNZED;
                        end;
                   else Code := Code + MOVEDIDB;
                        AddFixup(-4, true, AddData(Buffer));
                        Code := Code + LEAEAXESI1 + MOVECXIMM32;
                        EmitDW(Length(Buffer));
                        Code := Code + REPZCMPSB + CMOVNZEDIEAX + JNZE3;
                 end;

                 if start >= 0 then
                 begin
                   // this is basically the same loop as the main loop, but
                   // without *-matching
                   while not (p^ in [#0, '*']) do
                   begin
                     case p^ of
                       '?': begin
                              inc(p);
                              Code := Code + COMPAREBYTE + #00 + JZFALSE +
                                INCESI;
                              AddFixup(-5, false, RETURNFALSE);
                              if p^ = #0 then
                              begin
                                Code := Code + COMPAREBYTE + #00 + JNZFALSE;
                                JumpAddress(-4, start);
                              end;
                            end;
                       '[': begin
                              Inc(p);
                              CreateSetCode(start);
                            end;
                       '\': CreateStringCode(ReadNextPart, start);
                       else CreateStringCode(ReadNextPart, start);
                     end;
                   end;
                 end;
               end;
        false: CreateStringCode(Buffer);
      end; // case
    end; // if
  end;

var
  i: integer;
  QC: integer;
  Asterisk: boolean;
begin
  // push registers, Str => ESI (for cmpsb and lodsb)
  Code := PREFIX;
  // Write code
  p := PChar(Pattern);

  if p^ = #0 then
  begin
    Code := Code + COMPAREBYTE + #00 + JNZFALSE;
    AddFixup(-4, false, RETURNFALSE);
  end else
    while p^ <> #0 do
    begin
      case p^ of
        '?', // read blocks of * and ? at once for smaller code
        '*': begin
               // there's an asterisk in the current block
               asterisk := p^ = '*';
               inc(p);
               if asterisk then
                 QC := -1
               else
                 QC := 0;
               while p^ in ['?', '*'] do
               begin
                 if p^ = '*' then
                   asterisk := true
                 else
                   inc(QC);
                 inc(p);
               end;
               // create code for ?s
               for i := 0 to QC do
               begin
                 Code := Code + COMPAREBYTE + #00 + JZFALSE + INCESI;
                 AddFixup(-5, false, RETURNFALSE);
               end;
               // create end-of-string code only if there's no asterisk in the
               // current block
               if (p^ = #0) and not asterisk then
               begin
                 Code := Code + COMPAREBYTE + #00 + JNZFALSE;
                 AddFixup(-4, false, RETURNFALSE);
               end;
               if asterisk then
                 FlushBuffer(true, ReadNextPart);
             end;
        '[': begin
               inc(p);
               CreateSetCode;
             end;
        '\': FlushBuffer(false, ReadNextPart);
        else FlushBuffer(false, ReadNextPart);
      end; // case
    end; // while

  Code := Code + SUFFIX;
  // Get space with read and write access
  @Result := VirtualAlloc(nil, Length(Code) + Length(Data), MEM_COMMIT,
    PAGE_READWRITE);

  if @Result <> nil then
  begin
    // Write Code
    Move(Code[1], PDWORD(Result)^, Length(Code));
    // calculate address of data in memory
    DataAddress := Pointer(DWORD(@Result)+DWORD(Length(Code)));
    // calculate address of ret-false-stub in memory
    RetFalseAddr := (DWORD(DataAddress)-9) - DWORD(@Result);
    // Write Data
    Move(Data[1], PDWORD(DataAddress)^, Length(Data));
    // Apply Fixups
    for i := 0 to High(Fixups) do
    begin
      FixupAddr := PDWORD(DWORD(@Result) + Fixups[i].CodeAddr);
      case Fixups[i].IsData of
               // write position of data
        true:  FixupAddr^ := DWORD(DataAddress) + DWORD(Fixups[i].DataAddr);
        false: case Fixups[i].Typ of
                 // write position of ret-false-stub
                 RETURNFALSE: FixupAddrI^ := RetFalseAddr -
                                integer(Fixups[i].CodeAddr);
                 // create address for jump
                 FIXUPJUMP:   FixupAddrI^ := FixupAddrI^ -
                                integer(Fixups[i].CodeAddr) - 4;
               end;
      end;
    end;
   {$IFDEF DEBUG}
    inc(WildcardFunctionCount);
   {$ENDIF}
  end;

  // set function to execute-only
  VirtualProtect(Pointer(Result), Length(Code) + Length(Data), PAGE_EXECUTE,
    dummy);
end;

(**
 * Frees a function created using CompileWildcardFunction
 *
 * @param WildcardFunction the function to be freed
 *)
procedure FreeWildCardFunction(WildcardFunction: TWildcardFunction);
  {$IFDEF D2005}{$IFNDEF DEBUG}inline;{$ENDIF}{$ENDIF}
begin
  VirtualFree(@WildcardFunction, 0, MEM_RELEASE);
 {$IFDEF DEBUG}
  dec(WildcardFunctionCount);
 {$ENDIF}
end;

initialization

finalization
 {$IFDEF DEBUG}
  if WildcardFunctionCount > 0 then
    MessageBox(0, '[fastwild.pas] Memory leak detected', 'Possible memory leak',
      MB_ICONERROR);
 {$ENDIF}
end.