{$nomain}

{ this file 'DIRSUB.PAS' contains the routines for scanning rt-11 directories.
  The routine DIRINI attempts to open and initialise the directory, while
  DIRNXT returns the next file name. }


{%include 'chkoff.pas'}

const
%include 'dircon.pas';

type
%include 'dirtyp.pas';

var
%include 'dirvar.pas';



{                                                            }
{                   function checkchar                       }
{                                                            }


function checkchar(var comline: packed array
                   [lower..upper: integer] of char;
                   clength: integer;
                   byte: char): boolean;


{ returns true if byte occurs within the first clength chars of comline }


  var
    iptr: integer;

    limit: integer;

    haltscan: boolean;


  begin
  haltscan := false;
  iptr := lower;
  limit := lower + clength - 1;
  if limit > upper then
    limit := upper;
  repeat
    if comline[iptr] = byte then
      begin
      checkchar := true;
      haltscan := true;
      end
    else
      begin
      iptr := iptr + 1;
      if iptr > limit then
        begin
        haltscan := true;
        checkchar := false;
        end;
      end;
  until haltscan;
  end;                     { of function checkchar }




{                                                            }
{                    procedure getsegment                    }
{                                                            }

procedure getsegment(segno: integer);

{ reads in segment from device }

  var
    rptr: integer;

    sptr: integer;

  begin
  rtptr := dirstart + 2*(segno-1);
  seek(device,rtptr);
  get(device);
  with cursegment do
    begin
    totalsegs := device^[1];
    nextsegno := device^[2];
    highestseg := device^[3];
    extrabytes := device^[4];
    blockstart := device^[5];
    end;
  sptr := 1;
  for rptr := 6 to blocklength do
    begin
    cursegment.segarea[sptr] := device^[rptr];
    sptr := sptr + 1;
    end;
  rtptr := rtptr + 1;
  seek(device,rtptr);
  get(device);
  for rptr := 1 to blocklength do
    begin
    cursegment.segarea[sptr] := device^[rptr];
    sptr := sptr + 1;
    end;
  if segno = 1 then
    maxsegment := cursegment.highestseg;
  entrylen := basiclength + (cursegment.extrabytes div 2);
  cumsize := 0;
  segptr := 1;
  end;                                      { of procedure getsegment }
  
    
{                                                            }
{                  procedure radasc                          }
{                                                            }

procedure radasc(rad50: uword16;
                 var asciistring: threechars);

external;

procedure radasc;
{ converts an integer into 3 ascii chars }

  var
    thisval: uword16;

    aptr: integer;

  begin
  for aptr := 3 downto 1 do
    begin
    thisval := rad50 mod 8#50;
    if thisval in [1..26] then
      asciistring[aptr] := chr(thisval + ord('A') - 1)
    else
      if thisval in [30..39] then
        asciistring[aptr] := chr(thisval + ord('0') - 30)
      else    
        case thisval of
          0: asciistring[aptr] := ' ';
          27: asciistring[aptr] := '.';
          28: asciistring[aptr] := '$';
          29: asciistring[aptr] := '?';
          end;                      { of case body }
    rad50 := rad50 div 8#50;
    end;                        { of for loop }
  end;                          { of procedure radasc }



{                                                            }
{                    function getentry                       }
{                                                            }

function getentry(var entry: basicentry): boolean;

{ to copy a directory entry from the segment buffer to basicentry, 
  leaving the pointer segptr set to the start of the next segment.
  function returns false when there is no more directory to be obtained }

  var
    value: uword16;

    eptr: integer;

    continue: boolean;

    result: boolean;



  procedure killscan;

    begin
    eptr := entrylen + 1;
    continue := false;
    result := false;
    end;                       { of subprocedure killscan }


  procedure trynewseg;

    begin
    segcounter := cursegment.nextsegno;
    if (segcounter <= maxsegment) and
         (segcounter <> 0) then
      begin
      getsegment(segcounter);
      eptr := 1;
      end
    else
      killscan;
    end;                       { of subprocedure trynewseg }



  procedure nextword(var value: uword16);

  { to return the next word in value.  }

    begin
    if segptr <= seglength then
      begin
      value := cursegment.segarea[segptr];
      segptr := segptr + 1;
      end
    else
      trynewseg;
    end;                       { of procedure nextword }

  begin            { getentry function body }
  eptr := 1;
  result := true;
  continue := true;
  nextword(value);
  repeat
    if continue then
      begin
      if eptr <= basiclength then
        with entry do
          case eptr of
            1: if value = endsegment then
                 begin
                 trynewseg;
                 eptr := 0;
                 end
               else
                 status := value;
            2: radname[1] := value;
            3: radname[2] := value;
            4: radname[3] := value;
            5: filelength := value;
            6: tentword := value;
            7: created := value;
            end;           { of case body }
        eptr := eptr + 1;
      if eptr > entrylen then
        continue := false
      else
        nextword(value);
      end;
  until not continue;
  getentry := result;
  end;                  { of function getentry }


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;            { in wldmat.pas }



{                                                            }
{                      function dirnxt                       }
{                                                            }

function dirnxt(var pattern: packed array
                  [plower..pupper: integer] of char;
                var fname: packed array
                  [lower..upper: integer] of char;
                var thisentry: basicentry): integer;

external;

function dirnxt;

{ returns position of next filename which matches pattern, else returns 0 }



  var
    nptr: integer;

    rptr: integer;

    iptr: integer;

    asciistring: threechars;

    stopscan: boolean;

    pname: nametype;

    pext: exttype;

    qname: nametype;

    qext: exttype;

    devspec: boolean;      { device name given }

    haltcopy: boolean;




  procedure carvepattern;

  { split up pattern name into name and type fields in pname and ptext
    respectively }

    var
      pptr: integer;

      optr: integer;

      bptr: integer;

    begin
    pptr := lower;
    devspec := false;
    if checkchar(pattern,4,':') then
      begin
      haltcopy := false;
      devspec := true;
      repeat
        if pattern[pptr] = ':' then
          haltcopy := true;        
        pptr := pptr + 1;
        if pptr > pupper then
           haltcopy := true;
      until haltcopy;
      end;
    optr := 1;
    haltcopy := false;
    repeat
      if optr > namelength then
        haltcopy := true
      else
        if pptr > pupper then
          haltcopy := true
        else
          if pattern[pptr] in ['.',' '] then
            haltcopy := true
          else
            begin
            pname[optr] := pattern[pptr];
            pptr := pptr + 1;
            optr := optr + 1;
            end;
    until haltcopy;
    for bptr := optr to namelength do
      pname[bptr] := ' ';
    if optr <= 1 then
      pname[1] := '*';
    optr := 1;
    haltcopy := false;
    repeat
      if optr > extlength then
        haltcopy := true
      else
        if pptr > pupper then
          haltcopy := true
        else
          if pattern[pptr] = '.' then
            pptr := pptr + 1
          else
            begin
            pext[optr] := pattern[pptr];
            pptr := pptr + 1;
            optr := optr + 1;
            end;
    until haltcopy;
    for bptr := optr to extlength do
      pext[bptr] := ' ';
    if optr <= 1 then
      pext[1] := '*';
    end;               { of subprocedure carvepattern }


  procedure bytetoname(newbyte: char);

{ to build fname after nptr has been inited }

  begin
  if nptr in [lower..upper] then
    begin
    fname[nptr] := newbyte;
    nptr := nptr + 1;
    end;
  end;                   { of bytetoname }




  begin                 { of dirnxt procedure body }
  carvepattern;
  stopscan := false;
  repeat
    if getentry(thisentry) then
      if (thisentry.status and permanent) = 0 then
        begin
        cumsize := cumsize + thisentry.filelength;
        end
      else
        begin
        nptr := 1;
        for iptr := 1 to 2 do
          begin
          radasc(thisentry.radname[iptr],asciistring);
          for rptr := 1 to 3 do
            begin
            if nptr <= upper then
              qname[nptr] := asciistring[rptr];
            nptr := nptr + 1;
            end;
          end;
        radasc(thisentry.radname[3],asciistring);
        qext := asciistring;
        if wldmat(qname,pname) then
          if wldmat(qext,pext) then
            begin
            stopscan := true;
            nptr := lower;
            if devspec then
              begin
              iptr := plower;
              haltcopy := false;
              repeat
                if pattern[iptr] in [' ',':'] then
                  begin
                  bytetoname(':');
                  haltcopy := true;
                  end
                else
                  bytetoname(pattern[iptr]);
                iptr := iptr + 1;
                if iptr > pupper then
                  haltcopy := true;
              until haltcopy;
              end;
            for iptr := 1 to namelength do
              if qname[iptr] <> ' ' then
                bytetoname(qname[iptr]);
            bytetoname('.');
            for iptr := 1 to extlength do
              if qext[iptr] <> ' ' then
                bytetoname(qext[iptr]);
            for iptr := nptr to upper do
              fname[iptr] := ' ';
            dirnxt := cumsize + cursegment.blockstart;
            end;
        cumsize := cumsize + thisentry.filelength;
        end
    else
      begin
      for nptr := lower to upper do
        fname[nptr] := ' ';
      dirnxt := 0;
      stopscan := true;
      end;
  until stopscan;
  end;                        { of procedure dirnxt }
    


{                                                            }
{                     function dirini                        }
{                                                            }

function dirini(var wildspec: packed array
                  [lower..upper: integer] of char): boolean;

external;

function dirini;

{  the device (file) name is given to this routine in a conformant array, and
  if the open is successful then the function returns true, after setting all
  buffer areas and pointers to their initial values }

  const
    devnamelen = 4;             { bytes including : }

  type
    devnametype = packed array [1..devnamelen] of char;


  var
    errstat: integer;

    iptr: integer;

    devname: devnametype;
 
    nptr: integer;

    haltcopy: boolean;

    byte: char;

  begin
  if checkchar(wildspec,devnamelen,':') then
    begin
    nptr := 1;
    iptr := lower;
    haltcopy := false;
    repeat;
      if nptr >= devnamelen then
        haltcopy := true
      else
        if iptr > upper then
          haltcopy := true
        else
          begin
          byte := wildspec[iptr];
          if byte in [' ',':'] then
            haltcopy := true
          else
            begin
            devname[nptr] := byte;
            nptr := nptr + 1;
            iptr := iptr + 1;
            end;
          end;
    until haltcopy;
    for iptr := nptr to devnamelen do
      devname[iptr] := ' ';                 { blank fill name if necessary }
    end
  else
    begin
    devname := 'DK: ';
    nptr := 3;
    end;
  if nptr <= devnamelen then
    begin
    devname[nptr] := ':';
    reset(device,devname,'/nfs/seek',errstat);
    end
  else
    errstat := -1;
  if errstat < 0 then
    begin
    writeln;
    write('?DIRINI-E-Can''t open device ');
    for iptr := 1 to devnamelen do
      if devname[iptr] in ['!'..'~'] then
        write(devname[iptr]);
    writeln;
    dirini := false;
    end
  else
    begin
    rtptr := dirstart;                 { ready for first segment }
    segcounter := 1;                   { first segment }
    getsegment(segcounter);
    dirini := true;
    end;
  end;                                 { of function dirini }