Category : Pascal Source Code
Archive   : PROD30S2.ZIP
Filename : PATTERN.INC

(*
* Copyright 1987, 1989 Samuel H. Smith; All rights reserved
*
* This is a component of the ProDoor System.
* Do not distribute modified versions without my permission.
* Do not remove or alter this notice or any other copyright notice.
* If you use this in your own program you must distribute source code.
* Do not use any of this in a commercial product.
*
*)

(*
* pattern match function - matches a unix-style filename pattern.
* this recursive definition will accept *key* forms.
*
* S.H.Smith, rev. 04-Oct-87 (rev. 12-01-88)
*
*)

{$DEFINE PATTERN_MATCH}

(* these static variables are part of a hack to speed up the recursive
pattern matching operation. *)

var
PAT_pattern: string13;
PAT_pc: integer;
PAT_line: string13;
PAT_lc: integer;


(* matching engine - uses pointers into static pattern and line strings *)

function PAT_match (patpos,
linpos: integer): boolean;
const
QUESTION = 63; {ord('?')}
STAR = 42; {ord('*')}
ENDSTR = 32; {ord(' ')}

label
continue;

begin
PAT_match := false;

(* do a "wildcard" filename scan *)

repeat
continue :
PAT_pc := ord (PAT_pattern [patpos]); {get next pattern character}
PAT_lc := ord (PAT_line [linpos]); {get next line character}

(* end of pattern? we might have a match if so *)

if patpos > length(PAT_pattern) then
begin
PAT_match := PAT_lc = ENDSTR;
exit;
end
else

(* does line match pattern? step forward if so *)

if (PAT_pc = PAT_lc) then
begin
inc(patpos);
inc(linpos);
goto continue;
end
else

(* end of line? we missed a match if so *)

if PAT_lc = ENDSTR then
exit
else

(* ? matches anything *)

if (PAT_pc = QUESTION) then
begin
inc(patpos);
inc(linpos);
goto continue;
end
else

(* '*' matches 0 or more characters, anywhere in string *)

if PAT_pc = STAR then
begin

if patpos = length(PAT_pattern) then
begin
PAT_match := true;
exit;
end;

inc(patpos);

repeat

if PAT_match (patpos, linpos) then
begin
PAT_match := true;
exit;
end;

inc(linpos);
PAT_lc := ord (PAT_line [linpos]);
until PAT_lc = ENDSTR;

exit;
end
else
(* else no match is possible; terminate scan *)
exit;

until false;
end;

function wildcard_match (var pattern,
line: string65): boolean;
{pattern must be upper case; line is not case
sensitive}
begin

(* test for special case that matches all filenames *)

if pattern[1] = '*' then
begin
if (pattern = '*.*') or
((pattern = '*.') and (pos('.',copy(line,1,9)) = 0)) then
begin
wildcard_match := true;
exit;
end;
end;

PAT_pattern := pattern;
PAT_line := line;

(* force a space as end-of-string character to simplify *)

if length(PAT_line) > 12 then
PAT_line[0]:= chr (12);

if PAT_line[length(PAT_line)] <> ' ' then
PAT_line := PAT_line + ' ';

(* perform the match test *)

stoupper(PAT_line);
wildcard_match := PAT_match (1, 1);
end;