{$nomain}


function wldmat(var qstring: packed array
                  [qlower..qupper: integer] of char;
                var pattern: packed array
                  [plower..pupper: integer] of char): boolean;

  { to provide a wild card matching system for RT-11 filenames }

external;

function wldmat;


var
  qptr: integer;                   { pointers for scanning }

  pptr: integer;

  pstart: integer;                 { start of current segment of pattern }

  qstop: integer;                  { set to last non space char }

  pstop: integer;

  haltscan: boolean;               { stop scanning for match }

  matchfailed: boolean;            { no luck at match }

  afteraster: boolean;             { true if preceding asterisk }


  function chklength(var astring: packed array
                       [lower..upper: integer] of char): integer;

  {  to return the pointer for the last non space position in astring }

    var
      ptr: integer;

      stopscan: boolean;

    begin
    ptr := lower;
    stopscan := false;
    repeat
      if ptr <= upper then
        if astring[ptr] in ['!'..'~'] then
          ptr := ptr + 1
        else
          stopscan := true
      else
        stopscan := true;
    until stopscan;
    chklength := ptr - 1;
    end;                        { of subfunction chklength }
        

  procedure skipaster;

{ to skip pptr over the asterisks in the pattern string (pptr has already
  been set to pstart) }

    var
      continue: boolean;

    begin
    continue := true;
    afteraster := false;
    repeat
      if pptr <= pstop then
        if pattern[pptr] = '*' then
          begin
          afteraster := true;
          pptr := pptr + 1;
          end
        else
          continue := false
      else
        continue := false;
    until not continue;
    end;                   { of procedure skipaster }


  function ucase(byte: char): char;

    begin
    if byte in ['a'..'z'] then
      ucase := chr(ord(byte) + ord('A') - ord('a'))
    else
      ucase := byte;
    end;                   { of function ucase }



  function charsmatch(byte1, byte2: char): boolean;

    { returns true if byte1 matches byte2, with byte1 permitting
       wild card chars % }

    begin
    if ucase(byte1) = ucase(byte2) then
      charsmatch := true
    else
      if byte1 = '%' then
        charsmatch := true
      else
        charsmatch := false;
    end;                     { of function charsmatch }





  function fragmatch: boolean;

  { returns true if the next fragment of pattern (up to next asterisk) can
    be matched to next part of qstring }

    var
    match: boolean;

    stopscan : boolean;

    pbyte: char;

    qbyte: char;

    begin
    match := true;
    stopscan := false;
    repeat
      if pptr > pstop then
        stopscan := true
      else
        if pattern[pptr] = '*' then
          stopscan := true;
      if qptr > qstop then
        stopscan := true;
      if not stopscan then
        begin
        pbyte := pattern[pptr];
        qbyte := qstring[qptr];
        if charsmatch(pbyte,qbyte) then
          begin
          pptr := pptr + 1;
          qptr := qptr + 1;
          afteraster := false;
          end
        else
          if afteraster then
            qptr := qptr + 1
          else
            begin
            stopscan := true;
            match := false;
            end;
        end;
    until stopscan or not match;
    fragmatch := match;
    end;                       { of subfunction fragmatch }


  begin                         { wldmat procedure body }
  pstart := plower;
  haltscan := false;
  qstop := chklength(qstring);
  pstop := chklength(pattern);
  matchfailed := false;
  qptr := qlower;
  pptr := pstart;
  repeat
    skipaster;
    if pptr > pstop then
      haltscan := true
    else
      begin
      if fragmatch then
        begin
        if qptr > qstop then
          begin
          if pptr > pstop then
            haltscan := true
          else
            begin
            skipaster;
            if pptr <= pstop then    { is remainder of pattern = * }
              matchfailed := true;
            end;
          end
        else
          begin
          if pptr > pstop then
            begin
            haltscan := true;
            if not afteraster then
              matchfailed := true;
            end
          else
            pstart := pptr;
          end;
        end
      else
        matchfailed := true;
      end;
    until matchfailed or haltscan;
  wldmat := not matchfailed;
  end;                                { of wldmat }