{$Y-,W-}
program dirs;

{	Author : C. E. Chew
	Date   : August 1984


 Copyright (C) 1984
 C. E. Chew

	Revisions : Keith Buckley
	Date	  : June 1985
	Mods	  : /NEW for files created on the current system date
		  : /PRI optional, rather than <space>LP:
		  : /FF to append a form feed with /PRI option
		  : /HELP for onscreen help
		  : /BLOCKS for block numbers
		  : /SINGLE search only one directory
		  : /TIME to display creation time!
		  : /BRIEF for brief display (5 columns)

 This software is the property of Earl Chew. It is furnished for use only
 on a single computer system and may be copied only with the inclusion
 of the above copyright notice. This software, or copies thereof, may
 not be used on any other system.

 The author reserves the right to withdraw support without notice and
 assumes no responsibility for the correct operation of this software.


 C. E. Chew	August 1984

}

{  This program searches performs in a manner similar to the RT-11
utilitity DIR.SAV, except that it allows the user to follow the
paths through the subdirectories to search for files.

   The command syntax is :


		.RUN SY:DIRS
		*<template>

where the following definitions hold (BNF) :

  <template>  = <device><file> | <device><file>,<template>
  <device>    = <alphanum>: |
                <alphanum><alphanum>: |
                <alphanum><alphanum><digit>: |
                empty
  <file>      = <filename><extension>
  <filename>  = <wild> |
                <wild><wild> |
                <wild><wild><wild> |
                <wild><wild><wild><wild> |
                <wild><wild><wild><wild><wild> |
                <wild><wild><wild><wild><wild><wild> |
                empty
  <extension> = .<wild> |
                .<wild><wild> |
                .<wild><wild><wild> |
                empty
  <alphanum>  = <letter> | <digit>
  <wild>      = <letter> | <digit> | <asterisk> | <percent>
  <letter>    = A|B|C|D|E|F|G|H|I|J|K|L|M|N|O|P|Q|R|S|T|U|V|W|X|Y|Z
  <digit>     = 0|1|2|3|4|5|6|7|8|9
  <asterisk>  = *
  <percent>   = %


The rules for matching wildcards are the same as those for the standard
RT-11 utilities. }


const
  version = 'May 1986';

  nroptions = 8;
  printeropt = 1;
  formfeedopt = 2;
  newfilesopt = 3;
  helpopt = 4;
  blocksopt = 5;
  singleopt = 6;
  timeopt = 7;
  briefopt = 8;

  stringlength = 80;
  radix50length = 3;
  filenamesize = 10;
  directory_base = 6;
  null = chr(0);
  dirsldname = "DIRS";
  logical_disks = "*.DSK,*.DEV";
  defaultcommand = "DK:";

type
  string = array [1..stringlength+1] of char;
  smstr = array[1..3] of char;
  radix50 = array [1..radix50length] of integer;
  filenamestring = array [1..filenamesize+1] of char;
  relation = (lt,le,eq,ge,gt,ne);
  buffer = array [0..255] of integer;

  queue = @queueelement;

  queueelement = record
                   name : string;
                   start : integer;
                   size : integer;
                   next : queue
                 end;

  dorecord = record
               cursor,
               filecount,
               totalsize,
               freesize : integer
             end;

  header = record
             d_tota,
             d_next,
             d_high,
             d_extr,
             d_strt,
             device_base, device_size : integer;
             pathname : string
           end;

  statusbits = (nop0, nop1, nop2, nop3,
                nop4, nop5, nop6, nop7,
                tent, empty, perm, endblk,
                nop12, nop13, nop14, prot);

  status = set of statusbits;

  entry = record
            state : record
                      case boolean of
                      true : (word : integer);
                      false : (state : status)
                    end;
            e_name : radix50;
            e_leng : integer;
            e_used_chan_jnum : integer;
            e_date : integer;
            block : integer;
            segment : integer;
            offset : integer;
            e_names : filenamestring;
            eod : boolean
          end;


var
  option : array[1..nroptions] of string;
  optbool : array[1..nroptions] of boolean;
  out : text;
  dev : file of buffer;
  freeq, qhead, qtail : queue;
  subdirectory, listfile, device, template, command, today : string;
  nothingatall : boolean;
  columns : integer;


procedure error(p,m:string); external;

procedure inform(p,m:string); external;

procedure fatal(p,m:string); external;

procedure warn(p,m:string); external;

procedure dates(d:integer; var s:string); external;

procedure date(var s:string); external;

procedure r50tos(r:radix50; l:integer; s:string; m:integer); external;

procedure substring(s1:string; var s2:string; st,sp:integer); external;

procedure insert(s1:string; var s2:string; p,m:integer); external;

procedure delete(var s:string; st,sp:integer); external;

function compare(s1:string; r:relation; s2:string):boolean; external;

procedure concatenate(var s1:string; s2:string; m:integer); external;

procedure trimright(var s:string); external;

function position(s1,s2:string; s:integer):integer; external;

function verify(s1,s2:string):integer; external;

procedure uppercase(var ch:char); external;


procedure deletequeue(var n : string; var b, s : integer);

var
  q : queue;

begin
  with qhead@ do begin
    n := name;
    b := start;
    s := size
  end;
  q := qhead;
  qhead := q@.next;
  q@.next := freeq;
  freeq := q;
  if qhead = nil then
    qtail := nil
end;


procedure insertqueue(var n : string; b, s :integer);

var
  q : queue;

begin
  if freeq <> nil then begin
    q := freeq;
    freeq := freeq@.next
  end
  else
    new(q);
  with q@ do begin
    name := n;
    start := b;
    size := s;
    next := nil
  end;
  if qtail = nil then
    qhead := q
  else
    qtail@.next := q;
  qtail := q
end;


function qempty:boolean;

begin
  qempty := qtail = nil
end;


function wildmatch(var s, t : string):boolean;

const
  asterisk = '*';
  percent = '%';
  comma = ',';
  colon = ':';
  period = '.';
  space = ' ';

var
  tx : integer;
  matched : boolean;

function matching(var s, t : string; sx, tx : integer):boolean;

var
  chs, cht : char;
  matched, done : boolean;

begin
  done := false;
  repeat
    while s[sx] = space do
      sx := sx + 1;
    chs := s[sx];
    cht := t[tx];

    if cht = comma then
      cht := null;

    if cht = asterisk then begin
      tx := tx + 1;
      sx := sx - 1;
      repeat
	sx := sx + 1;
	matched := matching(s, t, sx, tx)
      until matched or (s[sx] = null);
      done := true
    end
    else if (chs = null) or (cht = null) then begin
      matched := chs = cht;
      done := true
    end
    else if (chs = cht) or (cht = percent) then begin
      sx := sx + 1;
      tx := tx + 1
    end
    else begin
      matched := false;
      done := true
    end
  until done;
  matching := matched
end;

begin
  tx := 1;

  loop
    matched := matching(s, t, 1, tx);
  exit if matched;
    while (t[tx] <> null) and (t[tx] <> comma) do
      tx := tx + 1;
  exit if t[tx] = null;
    tx := tx + 1
  end;
  wildmatch := matched
end;


function parse(var command, listfile, device, template : string):boolean;

const
  legal_characters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789:.*%,";

var
  colons, periods : integer;
  cinx, f : integer;
  ch : char;
  s : string;

function listingfile(var command, listfile : string):boolean;

const
  inout_separator = "=";
  default_listfile = "TT:";

var
  f : integer;

begin
  listingfile := false;
  f := position(command, inout_separator, 1);
  if f = 1 then
    error(dirsldname, "No output file")
  else begin
    listingfile := true;
    if f = 0 then
      listfile := default_listfile
    else begin
      substring(command, listfile, 1, f-1);
      delete(command, 1, f);
    end
  end
end;

function directory(var command, device : string):boolean;

const
  colon = ':';
  comma = ',';
  period = '.';
  default_device = "DK:";
  default_extension = ".*";
  default_filename = "*";

var
  result : boolean;
  c, f, g, h : integer;
  d : string;

function nextseparator(var c : string; s : integer):integer;

begin
  while not ((c[s] = colon) or (c[s] = comma) or (c[s] = null)) do
    s := s + 1;
  nextseparator := s
end;

begin
  directory := true;
  if command[1] = null then begin
    device := default_device;
    concatenate(command, default_filename, stringlength);
    concatenate(command, default_extension, stringlength);
  end else begin
    f := 1;
    device := "";
    result := false;
    repeat
      g := nextseparator(command, f);
      if command[g] = colon then begin
	substring(command, d, f, g-f+1);
	delete(command, f, g-f+1);
	g := nextseparator(command, f);
	if command[g] = colon then begin
	  error(dirsldname, "Bad device specification");
	  directory := false;
	  result := true
	end
      end
      else if device[1] = null then
	d := default_device
      else
	d := device;
      if not result then begin
	if device[1] = null then
	  device := d
	else if compare(device, ne, d) then begin
	  error(dirsldname, "Too many devices");
	  directory := false;
	  result := true
	end;
	if not result then begin
	  h := f-1;
	  c := 0;
	  repeat
	    h := h + 1;
	    if command[h] = period then
	      c := c + 1
	  until h = g;
	  if c > 1 then begin
	    error(dirsldname, "Bad extension specification");
	    directory := false;
	    result := true
	  end
	  else begin
	    if c = 0 then
	      insert(default_extension, command, g, stringlength);
	    if command[f] = period then
	      insert(default_filename, command, f, stringlength);
	    f := nextseparator(command, f);
	    if command[f] = null then
	      result := true
	    else
	      f := f + 1
	  end
	end
      end
    until result
  end
end;

begin
  parse := false;
  if listingfile(command, listfile) then
    if directory(command, device) then
      if verify(command, legal_characters) = 0 then begin
	template := command;
	parse := true
      end
end;


procedure searchdirectory(var subdirectory, filespecification : string);

var
  ent : entry;
  head : header;
  filedo : dorecord;

function getword(var ent : entry):integer;

begin
  with ent do begin
    if offset = 256 then
      get(dev);
    getword := dev@[offset mod 256];
    offset := offset + 1
  end
end;

procedure nextsegment(var ent : entry; var head : header);

var
  i : integer;

begin
  with ent, head do begin
    if d_next > 0 then begin
      segment := d_next;
      offset := 0;
      seek(dev, device_base + (segment-1)*2);
      i := getword(ent);
      d_next := getword(ent);
      i := getword(ent) + getword(ent);
      d_strt := getword(ent)
    end
    else
      eod := true
  end
end;

procedure getentry(var ent : entry; var head : header);

var
  i, j : integer;

begin
  with ent do begin
    state.word := getword(ent);
    if endblk in state.state then
      with head do begin
	segment := d_next;
	nextsegment(ent, head);
	if not eod then
	  getentry(ent, head)
      end
    else begin
      block := block + e_leng;
      for i := 1 to radix50length do
	e_name[i] := getword(ent);
      r50tos(e_name, 9, e_names, filenamesize);
      insert(".", e_names, 7, filenamesize);
      e_leng := getword(ent);
      e_used_chan_jnum := getword(ent);
      e_date := getword(ent);
      for i := 1 to head.d_extr do
	j := getword(ent)
    end
  end
end;

procedure restoreentry(var head : header; var ent : entry);

begin
  with ent, head do
    seek(dev, device_base + (segment-1)*2 + ord(offset>255))
end;

function resetentry(var ent : entry; var head : header):boolean;

var
  directory_ok : boolean;

begin
  with ent, head do begin
    deletequeue(pathname, device_base, device_size);
    directory_ok := device_size > directory_base + 2;
    if directory_ok then begin
      eod := false;
      segment := 1;
      offset := 0;
      e_leng := 0;
      device_base := device_base + directory_base;
      restoreentry(head, ent);

      d_tota := getword(ent);
      d_next := getword(ent);
      d_high := getword(ent);
      d_extr := getword(ent);
      d_strt := getword(ent);
      directory_ok :=  ((d_tota > 0) and (d_tota < 32)) and
             ((d_next >= 0) and (d_next <= d_high)) and
             ((d_high >= 1) and (d_high <= d_tota)) and
             ((d_extr >= 0) and (d_extr <= 998) and not odd(d_extr)) and
             (d_strt = directory_base + 2*d_tota);
      if directory_ok then begin
	d_extr := d_extr div 2;
	block := d_strt;
	getentry(ent, head)
      end
    end
  end;
  resetentry := directory_ok
end;

procedure dofile(var head : header; var ent : entry; var filedo : dorecord;
                 var subdirectory, filespecification : string);

var
  date : array [1..10] of char;
  time : integer;
  pname, nname : string;

procedure writetime(t : integer);

begin
  if t < 10 then
    write(out, '0');
  write(out, t:1)
end;

begin
  with head, ent, filedo do begin
    if perm in state.state then begin
      if wildmatch(e_names, subdirectory) then begin
	pname := pathname;
	substring(e_names, nname, 1, 6);
	trimright(nname);
	concatenate(pname, "/", stringlength);
	concatenate(pname, nname, stringlength);
	insertqueue(pname, device_base-directory_base+block, e_leng)
      end;
      if wildmatch(e_names, filespecification) then begin
        dates(e_date, date);
	if (optbool[newfilesopt] and compare(date, eq, today)) or
	 not(optbool[newfilesopt]) then begin
	  nothingatall := false;

	  if filecount = 0 then begin
	    writeln(out);
	    if not optbool[singleopt] then
	      writeln(out, pathname);
	    writeln(out, ' ', today)
	  end;

          if cursor > 1 then
	    write(out, ' ':3);
          write(out, e_names);
	  if not(optbool[briefopt]) then begin
	    write(out, e_leng:6);
            if prot in state.state then
	      write(out, 'P')
            else
	      write(out, ' ')
	  end;
          if not(optbool[briefopt]) then
	    write(out, date:10, ' ');
	  if optbool[blocksopt] then
	    write(out, block:5);
	  if optbool[timeopt] then begin
	    time := e_used_chan_jnum;
	    write(out, ' ');
	    writetime(time div (60*20));
	    write(out, ':');
	    time := time mod (60*20);
	    writetime(time div 20);
	    write(out, ':');
	    time := (time mod 20) * 3;
	    writetime(time)
	  end else
	    write(out, ' ':2);
          cursor := cursor + 1;
          if cursor > columns then begin
	    cursor := 1;
	    writeln(out)
          end;
          filecount := filecount + 1;
          totalsize := totalsize + e_leng
	end
      end
    end
    else if [empty, tent] * state.state <> [] then
      freesize := freesize + e_leng
  end
end;

procedure resetdorecord(var filedo : dorecord);

begin
  with filedo do begin
    cursor := 1;
    filecount := 0;
    totalsize := 0;
    freesize := 0
  end
end;

procedure finishfile(var filedo : dorecord);

begin
  with filedo do
    if filecount > 0 then begin
      if (filecount > 0) and (cursor > 1) then
        writeln(out);
      writeln(out, ' ', filecount, ' Files, ', totalsize, ' Blocks');
      writeln(out, ' ', freesize, ' Free blocks');
      writeln(out)
    end
end;

begin
  if resetentry(ent, head) then begin
    resetdorecord(filedo);
    if not optbool[singleopt] then begin
      inform(dirsldname, "");
      writeln('Searching   ', head.pathname)
    end;

    with ent do
      while not eod do begin
	dofile(head, ent, filedo, subdirectory, filespecification);
	getentry(ent, head)
      end;
    finishfile(filedo)
  end
  else begin
    warn(dirsldname, "");
    writeln('Illegal directory   ', head.pathname)
  end
end;


procedure initialise;

var
  i : integer;

begin
  qtail := nil;
  qhead := nil;
  freeq := nil;

  nothingatall := true;
  date(today);

  if argc <= 1 then
    command := defaultcommand
  else begin
    command[1] := null;
    for i := 1 to argc-1 do begin
      if i <> 1 then
	concatenate(command, ",", stringlength);
      concatenate(command, argv[i]@, stringlength)
    end;
    i := 0;
    repeat
      i := i + 1;
      uppercase(command[i])
    until command[i] = null
  end
end;


procedure getoptions;

var
  i, j, p : integer;
  s : array [1..4] of char;

begin
  option[printeropt] := "/PRINTER";
  option[formfeedopt] := "/FF";
  option[newfilesopt] := "/NEWFILES";
  option[helpopt] := "/HELP";
  option[blocksopt] := "/BLOCKS";
  option[singleopt] := "/SINGLE";
  option[timeopt] := "/TIME";
  option[briefopt] := "/BRIEF";

  for i := 1 to nroptions do begin
    optbool[i] := false;
    if (i <> 5) and (i <> 8) then	{/BLOCKS and /BRIEF}
      substring(option[i], s, 1, 2)
    else substring(option[i], s, 1, 3);
    p := position(command, s, 1);
    if p <> 0 then begin
      j := 0;
      repeat
	j := j + 1
      until (command[p+j-1] <> option[i][j]) or (option[i][j] = null);
      delete(command, p, j-1);
      optbool[i] := true
    end
  end;
  if optbool[briefopt] then begin
    optbool[timeopt] := false;
    optbool[blocksopt] := false
  end
end;


procedure setoptions;

begin
  if not optbool[singleopt] then
    subdirectory := logical_disks
  else
    subdirectory := "~"
end;


procedure gethelp;

begin
{ write(chr(27), '[H', chr(27), '[2J'); }
  writeln;
  writeln('DIRS    Version   ', version);
  writeln;
  writeln('   The command syntax is :');
  writeln;
  writeln('		.RUN DEV:DIRS');
  writeln('		$outputfile=filespec/options');
  writeln('or');
  writeln('		.DIRS outputfile=filespec/options');
  writeln('or');
  writeln('		.DIRS filespec/options');
  writeln;
  writeln('Default outputfile is TT:,    default filespec is DK:*.*');
  writeln;
  writeln('Options supported are:');
  writeln('    /BLOCKS lists block numbers instead of creation times');
  writeln('    /P - /PRINTER for output to LP:');
  writeln('    /FF to append a form feed character to LP: listings');
  writeln('    /N - /NEWFILES for files created on the current system date');
  writeln('    /H - /HELP');
  writeln('    /S - /SINGLE search one directory only');
  writeln('    /T - /TIME displays creation time of file');
  writeln('    /BRIEF - no date, 5 column display')
end;


begin
  initialise;
  getoptions;
  setoptions;
  if optbool[briefopt] then
    columns := 5
  else if (optbool[timeopt] and optbool[blocksopt]) then
    columns := 1
  else columns := 2;
  if optbool[helpopt] then gethelp;
  if (command[1] <> null) and not(optbool[helpopt]) then begin
    if parse(command, listfile, device, template) then begin
      reset(dev, device);
      if not eof(dev) then begin
	if optbool[printeropt] then
	  rewrite(out,"LP:")
	else
	  rewrite(out, listfile, "DIR");
	insertqueue(device, 0, maxint);
	repeat
	  searchdirectory(subdirectory, template)
	until qempty;
	if (optbool[printeropt] and optbool[formfeedopt]) then
	  page(out)
      end else
	fatal(dirsldname, "Cannot parse command");
      if nothingatall then
	inform(dirsldname, "No files found")
    end
  end
end.