home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TOOL_INC.ZIP / PATTERN.INC < prev    next >
Encoding:
Text File  |  1988-01-29  |  3.3 KB  |  150 lines
  1.  
  2. (*
  3.  * pattern match function - matches a unix-style filename pattern.
  4.  *      this recursive definition will accept *key* forms.
  5.  *
  6.  * S.H.Smith, rev. 04-Oct-87 (rev. 25-oct-87)
  7.  *
  8.  *)
  9.  
  10. {$DEFINE PATTERN_MATCH}
  11.  
  12. (* these static variables are part of a hack to speed up the recursive
  13.    pattern matching operation.  *)
  14.  
  15. var
  16.    PAT_pattern:        string13;
  17.    PAT_pc:             integer;
  18.    PAT_line:           string13;
  19.    PAT_lc:             integer;
  20.  
  21.  
  22. {$r-}
  23.  
  24. (* matching engine - uses pointers into static pattern and line strings *)
  25.  
  26. function PAT_match (patpos,
  27.                     linpos:             integer): boolean;
  28. const
  29.    QUESTION =          63;    {ord('?')}
  30.    STAR =              42;    {ord('*')}
  31.    ENDSTR =            32;    {ord(' ')}
  32.    
  33. label 
  34.    continue;
  35.  
  36. begin
  37.    PAT_match := false;
  38.  
  39. (* do a "wildcard" filename scan *)
  40.    
  41.    repeat
  42. continue :
  43.       PAT_pc := ord (PAT_pattern [patpos]);  {get next pattern character}
  44.       PAT_lc := ord (PAT_line [linpos]);     {get next line character}
  45.  
  46. (* end of pattern?  we might have a match if so *)
  47.       
  48.       if patpos > length(PAT_pattern) then
  49.       begin
  50.          PAT_match := PAT_lc = ENDSTR;
  51.          exit;
  52.       end
  53.       else
  54.  
  55. (* does line match pattern?  step forward if so *)
  56.       
  57.       if (PAT_pc = PAT_lc) then
  58.       begin
  59.          inc(patpos);
  60.          inc(linpos);
  61.          goto continue;
  62.       end
  63.       else
  64.  
  65. (* end of line?  we missed a match if so *)
  66.       
  67.       if PAT_lc = ENDSTR then
  68.          exit
  69.       else
  70.  
  71. (* ? matches anything *)
  72.       
  73.       if (PAT_pc = QUESTION) then
  74.       begin
  75.          inc(patpos);
  76.          inc(linpos);
  77.          goto continue;
  78.       end
  79.       else
  80.  
  81. (* '*' matches 0 or more characters, anywhere in string *)
  82.       
  83.       if PAT_pc = STAR then
  84.       begin
  85.          
  86.          if patpos = length(PAT_pattern) then
  87.          begin
  88.             PAT_match := true;
  89.             exit;
  90.          end;
  91.          
  92.          inc(patpos);
  93.          
  94.          repeat
  95.             
  96.             if PAT_match (patpos, linpos) then
  97.             begin
  98.                PAT_match := true;
  99.                exit;
  100.             end;
  101.             
  102.             inc(linpos);
  103.             PAT_lc := ord (PAT_line [linpos]);
  104.          until PAT_lc = ENDSTR;
  105.          
  106.          exit;
  107.       end
  108.       else
  109. (* else no match is possible; terminate scan *)
  110.          exit;
  111.  
  112.    until false;
  113. end;
  114.  
  115. function wildcard_match (var pattern,
  116.                          line:               anystring): boolean;
  117.                            {pattern must be upper case; line is not case 
  118.                              sensitive}
  119. begin
  120.  
  121. (* test for special case that matches all filenames *)
  122.    
  123.    if pattern[1] = '*' then
  124.    begin
  125.       if (pattern = '*.*') or
  126.         ((pattern = '*.') and (pos('.',copy(line,1,9)) = 0)) then
  127.       begin
  128.          wildcard_match := true;
  129.          exit;
  130.       end;
  131.    end;
  132.  
  133.    PAT_pattern := pattern;
  134.    PAT_line := line;
  135.  
  136. (* force a space as end-of-string character to simplify *)
  137.    
  138.    if length(PAT_line) > 12 then
  139.       PAT_line[0]:= chr (12);
  140.    
  141.    if PAT_line[length(PAT_line)] <> ' ' then
  142.       PAT_line := PAT_line + ' ';
  143.  
  144. (* perform the match test *)
  145.    
  146.    stoupper(PAT_line);
  147.    wildcard_match := PAT_match (1, 1);
  148. end;
  149.  
  150.