$copyright 'COPYRIGHT (C) 1985,1989 BY HEWLETT-PACKARD CO.'$
$def 1$
$ref 65$
$modcal$
$range OFF$
$ovflcheck OFF$
$iocheck off$
$debug OFF$
$list on  $
$ALLOW_PACKED ON$  { JWS 4/10/85 }

program flr(keyboard,input,output);

$search  'MATCHSTR'$

import sysglobals,
       misc,
       iocomasm,
       fs,
       sysdevs,
       ci,
       matchstr,
       asm;

var
  keyboard      : text;
  esckey        : string[6];                { 3.0 ITF fix  4/6/84 }

(****************************************************************************)
function srm_is_srmux_unit(unum : unitnum) : boolean; external;

procedure commandlevel;

type
  prompttype = string80;
  buftype    = packed array[0..maxint] of char;
  bigptr     = ^buftype;
  closecode  = (keepit,purgeit,closeit);

const
  filerid  = '3.23c';
  sprompt1 =    'Filer: Chg Get Lst Mak New Qt Rmv Trns Fcpy Udr ?';
  sprompt2 =    'Filer: Hfs Ac Dup Bad Kch Pfx Vol Wht Sav Zro ? [';
lprompt1 =
 'Filer: Change Get Ldir New Quit Remove Save Translate Vols What Access Udir ?';
lprompt2 =
 'Filer: Hfs Bad-secs Ext-dir Krunch Make Prefix Filecopy Duplicate Zero ? [';

  catlimit      = 200;
  sh_exc        = chr(27);
  bdat          = -5791;        { BDAT WORT #0 }
  bdat_500      = -5663;        { fix bdat 500 file copy }
{ code in the FILER presumes that bdat files will never be created by the
  file system i.e. no AM will ever be written to create them.
  it also presumes that the funny sector in the file will only exist in
  files in LIF/HFS directories.
}
type
  catarray        = array[1..catlimit] of catentry;
  catentryelement = record
                      link      : anyptr;
                      element   : catentry;
                    end;
  catentryelementptr = ^catentryelement;

  tidelement    = record
                    link      : anyptr;
                    element   : tid;
                    eft       : shortint;
                  end;
  tidelementptr = ^tidelement;
  passarray     = array[1..catlimit] of passentry;
  passarrayptr  = ^passarray;
  passentryelt  = record
                    link        : anyptr;
                    pelement    : passentry;
                  end;
  passentryeltptr = ^passentryelt;
  dirstatus       = (dneeded,dwanted,dontcare);
  control      = record
                    cfib      : fib;
                    path      : integer;
                    diropen   : boolean;
                    fileopen  : boolean;
                    useunit   : boolean;
                    mounted   : boolean;
                    cpvol     : vid;
                    cvol      : vid;
                    cfile     : fid;
                    dstatus   : dirstatus;
                    badclose  : closecode;
                    goodclose : closecode;
                  end;

var
  ch            : char;
  ordefault     : char;
  symsaved      : boolean;
  codesaved     : boolean;
  heapinuse     : boolean;

  ininfo        : control;
  outinfo       : control;

  saveio        : integer;
  saveesc       : integer;
  lheap         : anyptr;

  screenwidth   : shortint;
  screenheight  : shortint;
  linecount     : shortint;

(****************************************************************************)
procedure fixlock;
begin
  if locklevel<>0 then
  begin locklevel := 1; lockdown; end;
end;    { fixlock }

(****************************************************************************)
procedure printioerrmsg;
var
  msg   : string[80];
begin
  if ioresult<>ord(inoerror) then
  begin
    getioerrmsg(msg,ioresult);
    writeln('Error: ',msg,cteol);
    if streaming then escape(-1);
  end;
end;    { printioerrmsg }

(****************************************************************************)
procedure showprompt(p : prompttype);
begin write(homechar,p,cteol); end;

(****************************************************************************)
procedure showmove(var v1,f1,v2,f2 : string);
begin
  if screenwidth<73 then
  begin
    writeln('   ',v1,':',f1,cteol); writeln('==>',v2,':',f2,cteol);
  end
  else writeln(v1,':',f1,'':32-strlen(v1)-strlen(f1),' ==> ',v2,':',f2,cteol);
end;    { showmove }

(****************************************************************************)
procedure goodio;
begin if ioresult<>ord(inoerror) then escape(0); end;

(****************************************************************************)
procedure badio(iocode : iorsltwd);
begin ioresult := ord(iocode); escape(0); end;

(****************************************************************************)
procedure badmessage(p : prompttype);
begin
  writeln(p,cteol);
  if streaming then escape(-1) else badio(inoerror);
end;    { badmessage }

(****************************************************************************)
procedure badcommand(c:char);
begin
  writeln('bad command ''',c,'''');
  if streaming then escape(-1) else badio(inoerror);
end;    { badcommand }

(****************************************************************************)
procedure readcheck;
begin
  if ioresult<>ord(inoerror) then
  begin
    saveio := ioresult; writeln; ioresult := saveio;
    escape(0);
  end;
end;    { readcheck }

(****************************************************************************)
procedure readnumber(var int : integer);
var
  i        : integer;
  ti       : integer;
  instring : string[20];
begin
  readln(instring);  goodio;
  i := changestr(instring,1,-1,' ',''); { squash blanks }
  if instring=sh_exc then badio(inoerror);
  if strlen(instring)>0 then
  try
    begin
      ti  := 0;
      for i:=1 to strlen(instring) do
        if (instring[i]<'0') or (instring[i]>'9') then badio(ibadvalue)
        else ti := ti * 10 + (ord(instring[i]) - ord('0'));
      int := ti;
    end;
  recover
    if escapecode=-4 then badio(ibadvalue)
                     else escape(escapecode);
end;    { readnumber }

(****************************************************************************)
function unitnumber(var fvid : vid):boolean;
begin
  unitnumber := false;
  if strlen(fvid) > 1 then
    if fvid[1]='#' then
    begin
      if (fvid[2]>='0') and (fvid[2]<='9') then
        unitnumber := (spanstr(fvid, 2, '0123456789') = strlen(fvid));
    end;
end;
        { unitnumber }
(****************************************************************************)
function unit_is_hfs(un : unitnum):boolean;  {quick check, is unit HFS? SFB}
begin
 unit_is_hfs := FALSE;
 if h_unitable<>nil then
   if h_unitable^.tbl[un].is_hfsunit then
     unit_is_hfs := TRUE;
end;
(****************************************************************************)
procedure upcchar(var ch : char);
begin
  if ('a'<=ch) and (ch<='z') then ch:=chr(ord(ch)-32);
end;    { upcchar }

(****************************************************************************)
procedure promptread(p:prompttype; var answer:char; list:prompttype;
                     default:char);
var
  s1   : string[1];
  done : boolean;
begin
  if (default<>sh_exc) and streaming then answer:=default
  else
  begin
    setstrlen(s1,1);
    write(p,cteol);
    repeat
      read(keyboard,answer); readcheck; upcchar(answer);
      if answer=sh_exc then  begin writeln; badio(inoerror); end;
      s1[1] := answer;
      done  := breakstr(s1,1,list)>0;
      if not done and streaming then badcommand(answer);
    until done;
    writeln(answer);
  end;
end;    { promptread }

(****************************************************************************)
procedure promptyorn(p : prompttype; var answer :char);
begin
  promptread(p+' ? (Y/N) ',answer,'YN','Y');
end;    { promptyorn }

(****************************************************************************)
procedure mountvolume(sd : prompttype ;var finfo : control);
var
  answer        : char;
  unit          : integer;
  tempname      : vid;

begin
  with finfo do
  begin
    if streaming then
    begin
      writeln('Volume ',cpvol,' not online while streaming',cteol);
      escape(-1);
    end;

    tempname := cpvol;
    unit     := findvolume(tempname,false); { check for bad unit # }
    ioresult := ord(inoerror);

    {invalidate cache}
    if unit_is_hfs(cfib.funit) then
        call(h_unitable^.inval_cache_proc, cfib.funit);

    repeat
      { construct the prompt }
      write('Please mount',sd);
      if strlen(cvol)>0 then write(' volume ',cvol);
      if ((strlen(sd)>0) or (strlen(cvol)>0)) and useunit then write(' in');
      if useunit then write(' unit ',cpvol);
      writeln(cteol);
      promptread('''C'' continues, <'+esckey+'> aborts ',answer,'C','C');
                                                  { 3.0 ITF fix 4/6/84 }

      if useunit then tempname := cpvol else tempname := cvol;
      cfib.funit := findvolume(tempname,true);

      if cfib.funit>0 then
      begin
        if ioresult=ord(inodirectory) then
        begin
          if dstatus<>dontcare then writeln('No directory on ',cpvol);
          setstrlen(tempname,0);
          case dstatus of
            dneeded: cfib.funit := 0;
            dwanted: begin
                       promptyorn('Use current media',answer);
                       if answer='N' then cfib.funit := 0
                                     else dstatus    := dontcare;
                     end;
            otherwise
          end;   { case dstatus }
        end
        else
        begin
          if ioresult<>ord(inoerror) then
          begin
            printioerrmsg; cfib.funit := 0;
          end
          else
          begin { found a directory }
            if cvol='' then cvol := tempname
            else
            if cvol<>tempname then cfib.funit := 0;
          end;
        end;
      end;
    until cfib.funit>0;
    cfib.fvid := cvol;
    mounted   := true;
  end;
end;    { mount volume }

(****************************************************************************)
procedure check;
label
  1;
var
  i     : integer;
  j     : integer;
begin
  for i := 1 to maxunit do
    with unitable^[i] do
      if strlen(uvid) > 0 then
        for j := i+1 to maxunit do
          if strlen(unitable^[j].uvid) > 0 then
            if uvid = unitable^[j].uvid then
            begin
              call(dam,uvid,i,getvolumename);
              if strlen(unitable^[i].uvid) > 0 then
              begin
                with unitable^[j] do call(dam,uvid,j,getvolumename);
                if uvid = unitable^[j].uvid then
                begin
                  writeln(cteol);
                  writeln('Warning:  More than one volume named ',uvid,':',cteol);
                  writeln('It is not illegal but can be very dangerous.',cteol);
                  goto 1;
                end;
              end;
            end;
  1:
end;    { check }

(****************************************************************************)
function getwildcard(var pattern : fid) : char;
begin
  if strpos('?',pattern) > 0 then getwildcard := '?'
  else if strpos('=',pattern) > 0 then getwildcard := '='
       else getwildcard := ' ';
end;    { getwildcard }

(****************************************************************************)
procedure compatible(var p1, p2 : fid);
var
  ptr, c1, c2  : integer;
begin
  ptr:=0;     c1:=-1; c2:=-1;
  repeat
    c1:=c1+1;       ptr:=breakstr(p1,ptr+1,'=?');
  until ptr=0;
  repeat
    c2:=c2+1;       ptr:=breakstr(p2,ptr+1,'=?');
  until ptr=0;
  if not ((c1 = c2) or (p2 = '$')) then badmessage('Invalid use of wildcards');
end;    { compatible }

(****************************************************************************)
function match(n1 : fid; var p1 : fid):boolean;
label 1,2;
var
  ptr, ptr1, ptr2 : integer;
  mstring         : fid;
  anchored        : boolean;
begin
  match := true;
  if (p1='=') or (p1='?') or (strlen(p1)=0) then goto 2;
  ptr1 := 1;    ptr2 := 1;      anchored := true;
  repeat
    ptr := breakstr(p1,ptr1,'=?');
    if ptr=0 then ptr := strlen(p1)+1;
    if ptr=ptr1 then
    begin     { begin unanchored matching }
      ptr1 := ptr1+1;
      if ptr1>strlen(p1) then goto 2
                         else anchored := false;
    end
    else
    begin     { match characters }
      mstring := str(p1,ptr1,ptr-ptr1);
      ptr1    := ptr;
      if (ptr1>strlen(p1)) and (not anchored)
        then ptr := afterstr(n1,ptr2,-1,mstring)
        else ptr := afterstr(n1,ptr2,1,mstring);
      if ptr=0 then goto 1;
      if anchored and (ptr<>(ptr2+strlen(mstring))) then goto 1;
      ptr2 := ptr;
      if ptr1>strlen(p1) then
        if ptr2>strlen(n1) then goto 2
                           else goto 1;
    end;
  until false;
1:match:=false;
2:end;  { match }

(****************************************************************************)
procedure makenewname(var p1,p2 : fid;  n1 : fid; var n2:fid);
label 1;
var
  ptr, ptr1, ptr2, ptr3       : integer;
  anchored, haveeq    : boolean;
  mstring     : fid;
begin
  if p2='$' then  begin n2 := n1; goto 1; end;

  { begin name generation }
  n2       := p2;       ptr    := changestr(n2,1,-1,'?','=');
  ptr1     := 1;        ptr2   := 1;
  anchored := true;     haveeq := false;
  repeat
    ptr := breakstr(p1,ptr1,'=?');
    if ptr=0 then ptr := strlen(p1)+1;
    if ptr=ptr1 then
    begin
      ptr1 := ptr1+1;
      if ptr1>strlen(p1) then
      begin
        mstring := str(n1,ptr2,strlen(n1)-ptr2+1);
        ptr     := changestr(n2,1,1,'=',mstring);
        goto 1;
      end
      else anchored := false;
      if haveeq then ptr    := changestr(n2,1,1,'=','')
                else haveeq := true;
    end
    else
    begin
      if anchored then
      begin ptr1 := ptr; ptr2 := ptr; end
      else
      begin
        mstring := str(p1,ptr1,ptr-ptr1);       ptr1 := ptr;
        if (ptr1>strlen(p1)) and (not anchored)
          then ptr3 := beforestr(n1,ptr2,-1,mstring)
          else ptr3 := beforestr(n1,ptr2,1,mstring);
        ptr  := changestr(n2,1,1,'=',str(n1,ptr2,ptr3-ptr2));
        ptr2 := ptr3 + strlen(mstring);
        if ptr1>strlen(p1) then goto 1;
        haveeq := false;
      end;
    end;
  until false;
1:end;  { makenewname }

(****************************************************************************)
procedure spacewait;
var
  answer        : char;
begin
  promptread('<space> continues, <'+esckey+'> aborts ',answer,' ',' ');
                                             { 3.0 ITF fix  4/6/84 }
end;    { spacewait }

(****************************************************************************)
function samedevice(unit1,unit2:unitnum):boolean;
var
  u1p : ^unitentry;
begin
  u1p := addr(unitable^[unit1]);
  with unitable^[unit2] do
  samedevice := (u1p^.sc=sc) and (u1p^.ba=ba) and
                (u1p^.du=du) and (u1p^.dv=dv) and
                (u1p^.letter=letter) and (u1p^.byteoffset=byteoffset);
end;    { samedevice }

(****************************************************************************)
function bytestoblocks( bytes : integer; blocksize : integer):integer;
begin
  bytestoblocks := bytes;
  if blocksize>0 then
  begin
    bytestoblocks := (bytes + blocksize - 1) div blocksize;
  end;
end;    { bytestoblocks }
$IOCHECK ON$            {31JAN83  LOOKOUT FOR PRINTER TIMEOUTS}
(****************************************************************************)
procedure writedate(var listfile : text;
                    var date     : daterec);
type
  string3 = string[3];
  mnths   = array [0..15] of string3;
const
  months  = mnths['???','Jan','Feb','Mar','Apr','May','Jun','Jul',
                  'Aug','Sep','Oct','Nov','Dec','???','???','???'];
begin
  with date do
    {LAF 880101 added "mod 100" and changed test from "year>0"}
    if (1<=month) and (month<=12) and (1<=day) and (day<=31)
    {RDQ 21MAR88 excluded 1Jan70 from valid dates}
       and not ((year=70) and (month=1) and (day=1))
      then write(listfile,' ',day:2,'-',months[month],'-',year mod 100:2)
      else write(listfile,' ':10);
end;    { writedate }

(****************************************************************************)
procedure writetime(var listfile : text;
                    var time     : timerec);
begin
  with time do
    if (hour>0) or (minute>0) or (centisecond>0) then
      write(listfile,' ',hour:2,'.',minute:2,'.',centisecond div 100:2)
    else write(listfile,' ':9);
end;    { writetime }

(****************************************************************************)
procedure showcatheader(    long        : boolean;
                            order       : boolean;
                        var dircatentry : catentry;
                        var listfile    : text;
                        var count       : integer);
begin
  with dircatentry do
  begin
    write(listfile,cname,':','':17-strlen(cname));
    writeln(listfile,' Directory type= ',cinfo);
    if ccreatedate.year > 0 then
    begin
      write(listfile,'created');
      writedate(listfile,ccreatedate); writetime(listfile,ccreatetime);
      writeln(listfile,' block size=',cblocksize:1);
    end;
    if clastdate.year>0 then
    begin
      write(listfile,'changed');
      writedate(listfile,clastdate);
      writetime(listfile,clasttime);
    end;
    if ccreatedate.year <= 0 then
    begin
      writeln(listfile,' block size=',cblocksize:1);
    end;
    if order then write(listfile,' Alphabetic order')
             else write(listfile,' Storage order');
    writeln(listfile);
    count := 3;
  end;
  write(listfile,'...file name....    # blks    # bytes ');
  if long then
  begin
    writeln(listfile,'  start blk ....last change... extension1');
    write(listfile,' ':17,'type  t-code ..directory info...');
    writeln(listfile,' ....create date... extension2');
    count := count + 2 * (79 DIV SCREENWIDTH + 1);
  end
  else
  begin
    writeln(listfile,' last chng');
    count := count + 1;
  end;
  writeln(listfile);    { header separator line }
  count := count + 1;
end;    { showcatheader }

(****************************************************************************)
procedure showcatentry(    long        : boolean;
                       var lcatentry   : catentry;
                       var listfile    : text;
                       var count       : integer);

var
  blocks : integer;
  nullpos : integer;

begin
  with lcatentry do
  begin
    nullpos := strpos (nullchar, cname);
    if nullpos <> 0
      then
        setstrlen (cname, (nullpos - 1));
    write(listfile,cname,'':16-strlen(cname));
    write(listfile,' ',bytestoblocks(cpsize,cblocksize):10);{ physical size }
    write(listfile,' ',clsize:10);    { logical size }
    if long then
    begin     { E type listing }
      if cstart>=0 then
        write(listfile,' ',bytestoblocks(cstart,cblocksize):10)
      else write(listfile,' ':11);

      writedate(listfile,clastdate);
      writetime(listfile,clasttime);

      writeln(listfile,cextra1:11);
      count := count + 1 + (79 div screenwidth);

      { start line two }
      write(listfile,' ':17);
      case ckind of
        untypedfile : write(listfile,'Dir  ');
        badfile     : write(listfile,'Bad  ');
        codefile    : write(listfile,'Code ');
        textfile    : write(listfile,'Text ');
        asciifile   : write(listfile,'Ascii');
        datafile    : write(listfile,'Data ');
        sysfile     : write(listfile,'Systm');
        uxfile      : write(listfile,'Hp-ux');
        otherwise   write(listfile,suffixtable^[ckind]:5);
      end;    { case ckind }
      write(listfile,ceft:7);
      write(listfile,' ',cinfo,'':19-strlen(cinfo));
        if ccreatedate.year>0 then
        begin
          writedate(listfile,ccreatedate);
          writetime(listfile,ccreatetime);
        end   { good create date }
        else write(listfile,' ':19);
      write(listfile,cextra2:11);
      count := count + (79 div screenwidth);
    end       { E type listing }
    else
      writedate(listfile,clastdate);    { L type listing }
    writeln(listfile);
    count := count + 1;
  end; { with lcatentry }
end;    { showcatentry }
$IOCHECK OFF$
(****************************************************************************)
procedure setupfibforfile(filename      : fid;
                      var lfib          : fib;
                      var vname         : vid);
var
  lkind : filekind;
  segs  : integer;

begin
  segs     := 0;
  ioresult := ord(inoerror);
  with lfib do
    if scantitle(filename,fvid,ftitle,segs,lkind) then
    begin
      vname      := fvid;
      funit      := findvolume(fvid,true);
      fkind      := lkind;
      feft := efttable^[lkind];
      foptstring := nil;
      fbuffered  := true;
      fpos       := segs * 512;
      freptcnt   := 0;
      fanonymous := false;
      fmodified  := false;
      fbufchanged:= false;
      fstartaddress := 0;
      flastpos   := -1;
      pathid     := -1;
      fnosrmtemp := true;
      flocked    := true;
      feof       := false;
      feoln      := false;
      fb0        := false;
      fb1        := false;
    end
    else badio(ibadtitle);
end;    { setupfibforfile }

(****************************************************************************)
procedure closedir(var finfo : control);
begin
  with finfo, cfib do
  begin
    if diropen then
    begin
      lockup;       { lock keyboard for this operation }
      pathid := path;   { restore pathid }
      call(unitable^[funit].dam,cfib,funit,closedirectory);
      diropen := false;
      lockdown;
    end;
  end;
end;    { closedir }

(****************************************************************************)
procedure opendir(filename      : fid;
              var searchname    : fid;
                  prompt        : prompttype;
              var finfo         : control;
              var dircatentry   : catentry);
var
  doparent : boolean;
  unit     : integer;

begin   { opendir }
  ioresult := ord(inoerror);
  with finfo, cfib do
  try
    lockup;
    doparent := diropen;
    if doparent then closedir(finfo);
    diropen  := false;
    lockdown;
    setupfibforfile(filename,cfib,cpvol);
    useunit := unitnumber(cpvol);       dstatus := dneeded;
    if useunit then cvol := '' else cvol := cpvol;
    if (funit=0) or unitnumber(fvid) then mountvolume(prompt,finfo)
                                     else mounted := true;
    with unitable^[funit] do
    begin
      lockup;           { lock keyboard }
      fwindow    := addr(dircatentry);
      if doparent then call(dam,cfib,funit,openparentdir)
                  else call(dam,cfib,funit,opendirectory);
      diropen    := (ioresult=ord(inoerror));
      if diropen then
      begin
        path       := pathid;
        searchname := ftitle;
        cvol       := dircatentry.cname;
      end;
      lockdown;         { unlock keyboard }
      if not diropen then escape(0);    { opendirectory failed }
    end
  recover
    if escapecode<>0 then escape(escapecode);
end;    { opendir }

(****************************************************************************)
procedure makenamelist(var f            : fib;
                       var searchname   : fid;
                       var nameptr      : anyptr;
                           bigelement   : boolean;
                           order        : boolean;
                           shortlist    : boolean;
                       var filecount    : integer);

{ The shortlist parameter has reversed and twisted logic.
  A FALSE value means to give a slower, but truthful answer.
  A TRUE value means to give a fast lie.
  The truth is the size of the file without the workstation
  header.
  The list command should always use FALSE.
  Commands using this routine to simply get a list of file names
  should use TRUE.
}

type
  listelement   = record case boolean of
                    true  : (cat : catentryelement);
                    false : (nam : tidelement);
                  end;
  listptr       = ^listelement;

var
  i             : integer;
  catentries    : catarray;
  currelement   : listptr;
  prevelement   : listptr;
  nextelement   : listptr;

  procedure linkorder;
  var
    done : boolean;
  begin
    currelement^.nam.link := nil;
    if nameptr=nil then nameptr := addr(currelement^)
    else
    begin
      prevelement := nil;
      nextelement := nameptr;
      done := false;
      repeat
        if currelement^.nam.element>=nextelement^.nam.element then
        begin
          prevelement := nextelement;   nextelement := nextelement^.nam.link;
          if nextelement=nil then
          begin
            prevelement^.nam.link := currelement; done := true;
          end;
        end
        else
        begin
          if prevelement=nil then
          begin currelement^.nam.link := nameptr; nameptr := currelement; end
          else
          begin
            currelement^.nam.link := prevelement^.nam.link;
            prevelement^.nam.link := currelement;
          end;
          done := true;
        end;
      until done;
    end;
  end;

begin   { makenamelist }
  prevelement := nil;
  nameptr     := nil;
  filecount   := 0;
  with f, unitable^[funit] do
  begin
    fwindow   := addr(catentries);
    fpos      := 0;     fpeof     := catlimit;
    fb0 := shortlist;
    repeat
      call(dam,f,funit,catalog);
      if ioresult = ord(inoerror) then
      begin
        filecount := filecount + fpeof;
        for i := 1 to fpeof do
          if match(catentries[i].cname,searchname) then
          begin
            if bigelement then
            begin
              new(currelement,true);
              currelement^.cat.element := catentries[i];
              if order then linkorder
              else
              begin
                if nameptr=nil then nameptr := addr(currelement^);
                if prevelement<>nil then prevelement^.cat.link := currelement;
                prevelement := currelement;
                currelement^.cat.link := nil;
              end;
            end
            else
            begin
              new(currelement,false);
              currelement^.nam.element := catentries[i].cname;
              currelement^.nam.eft     := catentries[i].ceft;
              if order then linkorder
              else
              begin
                if nameptr=nil then nameptr := addr(currelement^);
                if prevelement<>nil then prevelement^.nam.link := currelement;
                currelement^.nam.link    := nil;
                prevelement := currelement;
              end;
            end;
          end;
        if fpeof=catlimit then fpos := fpos + fpeof;
      end;
    until (fpeof<catlimit) or (ioresult<>ord(inoerror));
    fwindow := nil;
  end;
end;    { makenamelist }

(****************************************************************************)
procedure editnamelist(var nameptr      : tidelementptr;
                           prompt       : string80;
                           wildcard     : char);
var
  currptr : tidelementptr;
  tailptr : tidelementptr;
  answer  : char;
  count   : integer;
begin
  count   := 0;
  currptr := nameptr;
  nameptr := nil;       tailptr := nil;
  while (currptr<>nil) do
  begin
    if not streaming then write(prompt,currptr^.element);
    if wildcard='?' then promptyorn('',answer);
    if (answer='Y') or (wildcard<>'?') then
    begin
      if tailptr=nil then nameptr       := currptr
                     else tailptr^.link := currptr;
      tailptr := currptr;
    end;
    currptr := currptr^.link;
    if tailptr<>nil then tailptr^.link := nil;
    if (wildcard<>'?') and not streaming then writeln;
    if not streaming and (wildcard<>'?') and
       (currptr<>nil) then
    begin
      count := count + 1;
      if count=screenheight - 2 then
      begin spacewait; count := 0; end;
    end;
  end;
end;    { editnamelist }

(****************************************************************************)
procedure inmount(swap : boolean);
begin
  if not ininfo.mounted then
  with ininfo, cfib do
  begin
    mountvolume(' SOURCE',ininfo);
    unitable^[funit].umediavalid := true;
    outinfo.mounted := not swap;
  end;
end;    { inmount }

(****************************************************************************)
procedure outmount(swap : boolean);
begin
  if not outinfo.mounted then
  with outinfo, cfib do
  begin
    mountvolume(' DESTINATION',outinfo);
    unitable^[funit].umediavalid := true;
    ininfo.mounted  := not swap;
  end;
end;    { outmount }

(****************************************************************************)
procedure closeinfile;
begin
  with ininfo ,cfib do
  begin
    if fileopen then
    begin
      lockup;
      fmodified := false;
      call(unitable^[funit].dam,cfib,funit,closefile);
      fileopen := false;
      lockdown;
    end;
  end;
end;    { closeinfile }

(****************************************************************************)
procedure closeoutfile(position : integer; option : closecode);
var
  coption : damrequesttype;
begin
  with outinfo, cfib do
  begin
    if fileopen then
    begin
      case option of
      keepit:  begin
                 fleof := position;     fmodified := true;
                 coption := closefile;
               end;
      purgeit: coption := purgefile;
      closeit: begin
                 coption := closefile; fmodified := false;
               end;
      end;

      lockup;
      call(unitable^[funit].dam,cfib,funit,coption);
      fileopen := false;
      lockdown;
    end;
  end;
end;    { closeoutfile }

(****************************************************************************)
procedure closeall(position : integer);
begin
  closeinfile;
  closeoutfile(position,outinfo.badclose);
  closedir(ininfo);
  closedir(outinfo);
end;    { closeall }

(****************************************************************************)
function outnotthere (var answer : char; allowover : boolean): boolean;
var
  oldopt  : closecode;
  tempfib : fib;
begin
  with outinfo, cfib, unitable^[funit] do
  begin
    outnotthere  := true;
    saveio       := 0;
    lockup;     { lock keyboard except for around prompt }
    try
      tempfib  := cfib;                 { save fib }
      oldopt   := badclose;             { save closeoption }
      call(dam,cfib,funit,openfile);
      fileopen := (ioresult=ord(inoerror));
      if ioresult<>ord(inoerror) then ioresult := ord(inoerror)
      else
      begin     { file exists }
        badclose := closeit;            { set closeoption }
        lockdown;
        if not streaming then
        begin
          writeln(cvol,':',ftid,cteol);
          if allowover then
          promptread('exists ... Remove/Overwrite/Neither ? (R/O/N) ',
                       answer,'RON',ordefault)
          else
          promptyorn('exists ... remove it',answer);
        end
        else answer := 'Y';
        lockup;
        if (answer='Y') or (answer='R') then
        begin
          call(dam,cfib,funit,purgefile);
          saveio := ioresult;
          if ioresult<>ord(inoerror) then answer := 'N';
        end;
        if (answer='N') or (answer='O') then
        begin
          call(dam,cfib,funit,closefile);
          outnotthere := answer='O'; {O or N}
        end;
        fileopen := false;
        badclose := oldopt;     { restore closeoption }
      end;
      cfib := tempfib;          { restore fib }
      lockdown;
    recover
      begin
        saveio   := ioresult;
        saveesc  := escapecode;
        closeoutfile(0,outinfo.badclose);
        ioresult := saveio;
        escape(saveesc);
      end;
    if saveio<>0 then
    begin
      ioresult := saveio; printioerrmsg;
    end;
  end;  { with ... }
end;    { outnotthere }

(****************************************************************************)
procedure anytomem(       ffib   : fibp;
                   anyvar buffer : bigptr;
                          maxbuf : integer);
var
  bufrec    :  ^string255;
  bufptr    :  ^char;
  leftinbuf :  integer;

begin   { anytomem }
  bufptr    := addr(buffer^);
  bufptr^   := chr(0);  { data comming }
  bufrec    := addr(bufptr^,1);
  setstrlen(bufrec^,0); { zero length record }
  bufptr    := addr(bufrec^,1);
  leftinbuf := maxbuf;

  with ffib^, unitable^[funit] do
  begin
                { BDAT WORT #1 stop translate request for bdat files }
    if (feft=bdat) or (feft= bdat_500)  {fix bdat 500 file copy}
       then
         ioresult := ord(ibadrequest)
       else
         call(am,ffib,readtoeol,bufrec^,255,fpos);
    if ioresult=ord(ibadrequest) then buffer^[0] := chr(4)
    else
    begin       { string reads }
      repeat
        goodio; { check ioresult from last readtoeol }
        bufptr := addr(bufptr^,strlen(bufrec^));
        leftinbuf := leftinbuf - strlen(bufrec^) - 2;
        if strlen(bufrec^) = 255 then bufptr := addr(bufptr^,-1)
        else
        begin
          if strlen(bufrec^)=0 then
          begin { discard the length byte }
            bufptr := addr(bufrec^,-1); leftinbuf := leftinbuf + {1} 2;
                                { RQ/SFB 3/15/84  3.0 BUG}
          end;

             { check end of line/file }
          call(am,ffib,readbytes,bufptr^,1,fpos);
          if feoln then
          begin  { end of line }
            bufptr^ := chr(1);  feoln := false; LEFTINBUF := LEFTINBUF -1;
                                { RQ/SFB 3/15/84 3.0 BUG}
            if ioresult = ord(ieof) then bufptr := addr(bufptr^,1);
          end;
          if ioresult=ord(ieof) then
          begin  { end of file }
            bufptr^  := chr(2);
            ioresult := ord(inoerror);
            feof     := true;
          end;
          goodio;       { check ioresult from readbytes }
        end;
        if not ((leftinbuf < 259) or feof) then
        begin { setup for then read the next line }
          bufptr    := addr(bufptr^,1);
          bufptr^   := chr(0);  { data record }
          bufrec    := addr(bufptr^,1);
          setstrlen(bufrec^,0); { zero length record }
          bufptr    := addr(bufrec^,1);
          call(am,ffib,readtoeol,bufrec^,255,fpos);
        end;
      until (leftinbuf < 259) or feof;
    end;        { string reads }
    bufptr := addr(bufptr^,1);    bufptr^ := chr(3); { end buffer }
  end;
end;    { anytomem }

(****************************************************************************)
procedure memtoany(anyvar buffer : bigptr;
                          FFIB   : fibp);
var
  bytes : integer;
  bufptr: ^char;

begin
  bufptr := addr(buffer^);
  with ffib^, unitable^[funit] do
  begin
    bytes := 0;
    repeat
      bufptr := addr(bufptr^,bytes);
      bytes  := ord(bufptr^);
      bufptr := addr(bufptr^,1);
      case bytes of
      0: begin          { data bytes }
           bytes := ord(bufptr^);       { record length }
           bufptr:= addr(bufptr^,1);
           call(am,ffib,writebytes,bufptr^,bytes,fpos);
         end;
      1: begin          { end record }
           call(am,ffib,writeeol,bufptr^,bytes,fpos);   bytes := 0;
           if uisinteractive and (uvid='CONSOLE') then
           begin
             linecount:=linecount+1;
             if linecount=screenheight-1 then
             begin spacewait; write(upchar,cteol,eol); linecount:=0; end;
           end;
         end;
      2: begin          { end file }
           call(am,ffib,flush,bufptr^,bytes,fpos);      bytes := -1;
         end;
      3: bytes := -1;   { end buffer }
      otherwise ioresult := ord(ibadrequest);
      end;
      goodio;
    until bytes<0;
  end;
end;    { memtoany }

(****************************************************************************)
procedure fixsrcfile(var root:string; var result: fid; default : filekind);
var
  tempk : filekind;
begin
  result := root;
  tempk  := suffix(result);
  if tempk=codefile then
  begin
    setstrlen(result,strlen(result)-strlen(suffixtable^[codefile]));
    result := result + suffixtable^[default];
  end
  else
    if tempk<>default then fixname(result,default);
end;    { fixsrcfile }

(****************************************************************************)
procedure fixcodefile(var root:string; var result: fid);
var
  lkind : filekind;
begin
  result := root;
  fixname(result,codefile);
  lkind := suffix(result);
  if lkind = datafile then result := result + '.' + suffixtable^[codefile]
  else
  if lkind <> codefile then
  begin { replace old suffix with CODE file }
    setstrlen(result,strlen(result)-strlen(suffixtable^[lkind]));
    result := result + suffixtable^[codefile];
  end;
end;    { fixcodefile }

(****************************************************************************)
function domove(var inname,outname:string; source:boolean):boolean;
{ file --> file move }
var
  lefttoxfer    : integer;
  bufsize       : integer;
  buf           : ^buftype;
  position      : integer;
  outsize       : integer;
  dumwindow     : windowp;
  overcreate    : damrequesttype;
  answer        : char;
  done          : boolean;
  swap          : boolean;
  docopy        : boolean;
  filename      : fid;
  fixedname     : fid;
  filename2     : fid;
  dircatentry   : catentry;
  save_fkind    : filekind;
  save_feft     : integer;

begin   { domove }
  domove        := false;
  swap          := false;
  mark(lheap);  heapinuse := true;
  ininfo.diropen    := false;
  ininfo.fileopen   := false;
  outinfo.diropen   := false;
  outinfo.fileopen  := false;
  outinfo.badclose  := purgeit;
  outinfo.goodclose := keepit;

  if (strlen(inname)=0) or (strlen(outname)=0) then badio(ibadtitle);
  if inname=outname then domove := true
  else
  try
    with ininfo, cfib do
    begin
        { open the input file }
      opendir(inname,filename,' SOURCE',ininfo,dircatentry);
      if not diropen then escape(0);
      if (strlen(filename)=0) then badio(ibadrequest);
      lockup;
      newwords(dumwindow,1);            { dummy window }
      finitb(cfib,dumwindow,-3);        { setup for translate }
      call(unitable^[funit].dam,cfib,funit,openfile);
      fileopen := (ioresult=ord(inoerror));
      lockdown;
      goodio;
      feof       := false;      feoln     := false;
      cfile      := ftid;       flastpos  := -1;
      lefttoxfer := fleof;      position  := 0;
      outsize    := fleof;      fpos      := 0;
      swap       := not unitable^[funit].uisfixed;

        { try to setup destination fib }
      if source then fixsrcfile(outname,fixedname,fkind)
                else fixcodefile(outname,fixedname);
      with outinfo, cfib do
      begin
        setupfibforfile(fixedname,cfib,cpvol);
        if (funit>0) and unitable^[funit].uisfixed then
        begin
          useunit := false; cpvol := fvid; swap := false;
        end
        else
          useunit := unitnumber(cpvol);
        dstatus := dneeded;
        if useunit then cvol := '' else cvol := cpvol;
      end;
      { unit number may not be known yet }

      if not source then
      begin
        outinfo.cfib.fkind := fkind;  outinfo.cfib.feft := feft;
      end;
      outinfo.cfib.fstartaddress   := fstartaddress;
      { copy or translate ? }
      docopy := ininfo.cfib.feft=outinfo.cfib.feft;

      if docopy then
      begin  { set destination file size }
        if outinfo.cfib.fpos=0 then outinfo.cfib.fpos := fleof
        else
          if (outinfo.cfib.fpos>0) and
             (outinfo.cfib.fpos<fleof) then badio(inoroom);
      end;
      outsize := outinfo.cfib.fpos;     { remember the requested size }
    end;        { with ininfo, cfib }

    bufsize := (memavail div 256) * 256 - 30 * 512 {save some for slop};
    if bufsize<512 then escape(-2);
    newwords(buf,bufsize div 2);

    done   := false;

    if docopy and
       (ininfo.cfib.funit=outinfo.cfib.funit) and
       (ininfo.cfib.funit=sysunit) and not outinfo.useunit and
       (outinfo.cfib.fpos=ininfo.cfib.fleof) and
       (ininfo.cvol=outinfo.cvol) then
    begin     {looks like destination is on sysvol so do changename }
      opendir(fixedname,filename2,' Destination',outinfo,dircatentry);
      if not outinfo.diropen then escape(0);
      if (strlen(filename2)=0) then badio(ibadrequest);
      if getwildcard(filename2)<>' ' then badio(ibadtitle);
      { if still looks like sysvol then continue }
      if  (ininfo.cvol=outinfo.cvol) and (outinfo.cvol=syvid) then
      begin
        if outnotthere(answer,false) then
        with ininfo, cfib do
        begin
          closeinfile;    pathid := path;
          ftitle  := filename;
          fwindow := addr(filename2);
          call(unitable^[funit].dam,cfib,funit,changename);
          goodio;
          showmove(cvol,cfile,cvol,outinfo.cfib.ftitle);
          inname  := fixedname;
          closedir(ininfo);
          done    := true;
        end
        else badio(inoerror);   { file exists & not removed }
      end;
      if done then closedir(outinfo);
    end;      { do changename }

    if not done then
    repeat      { do file move }
      { code files use copy, source files must be translateable }
      { read source file }
      inmount(swap);
      write('Reading ....',chr(13));
      if docopy then
      begin     { do copy move }
        if bufsize>lefttoxfer then bufsize := lefttoxfer;
        with ininfo, cfib do
        begin
          call(unitable^[funit].tm,addr(cfib),readbytes,buf^,bufsize,position);
          lefttoxfer := lefttoxfer - bufsize;
        end;
      end
      else
      begin     { do translate move }
        anytomem(addr(ininfo.cfib),buf,bufsize);
        if ininfo.cfib.feof then lefttoxfer := 0;
      end;
      goodio;
      if lefttoxfer=0 then
        begin closeinfile; closedir(ininfo); end;
      write(cteol);

      { write destination file }
      with outinfo, cfib do
      begin
        if not fileopen then
        begin     { open destination file }
          if useunit and swap then swap := samedevice(funit,ininfo.cfib.funit)
                              else swap := false;
          if not diropen then
          begin
            save_fkind := fkind;
            save_feft  := feft;
            opendir(fixedname,cfile,' DESTINATION',outinfo,dircatentry);
            if not diropen then escape(0);
            if (strlen(cfile)=0) or
               (getwildcard(cfile)<>' ') then badio(ibadtitle);
            fkind := save_fkind;
            feft  := save_feft;
          end;
          if swap then swap := samedevice(funit,ininfo.cfib.funit);
          ininfo.mounted := not swap;
          if outnotthere(answer,true) then
          begin { no file with same name }
            lockup;
            finitb(cfib,dumwindow,-3);
            if answer='O' then overcreate := overwritefile
                          else overcreate := createfile;
            call(unitable^[funit].dam,cfib,funit,overcreate);
            fileopen := (ioresult=ord(inoerror));
            lockdown;
            goodio;
            if (outsize>0) and (outsize>fpeof) then
            begin       { try to stretch the file }
              fpos := outsize;
              call(unitable^[funit].dam,cfib,funit,stretchit);
              if outsize>fpeof then badio(inoroom);
            end;
          end
          else badio(inoerror);    { file exists & not removed }
          fpos := 0;          flastpos := -1;
        end;    { open destination file }

        { write to the destination file }
        outmount(swap);
        write('Writing ....',chr(13));
        if docopy then
        begin   { do copy move }
          call(unitable^[funit].tm,addr(cfib),writebytes,buf^,bufsize,position);
          goodio;
          position := position + bufsize;
        end
        else
        begin   { do translate move }
          memtoany(buf,addr(cfib));
          if lefttoxfer=0 then position := fleof;
        end;
        if lefttoxfer=0 then
        begin   { all done so close it now }
          closeoutfile(position,keepit);
          goodio;
          closedir(outinfo);
          done := true;
          showmove(ininfo.cvol,ininfo.cfile,cvol,cfile);
        end;
      end;      { with outfib }
    until done;

    domove := true;
    release(lheap);     heapinuse := false;
  recover
  begin
    lockup;
    saveio   := ioresult;
    saveesc  := escapecode;
    release(lheap);     heapinuse := false;
    closeall(0);
    ioresult := saveio;
    lockdown;
    printioerrmsg;
    escape(saveesc);
  end;
end;    { domove }

(****************************************************************************)
procedure savework;
var
  symwassaved   : boolean;
  codewassaved  : boolean;
  answer        : char;
  f2vol         : vid;
  Tworkfid      : fid;
begin
  with userinfo^ do
    if symsaved and codesaved then
      if gotsym or gotcode then write('Workfile already saved',cteol)
                           else write('No workfile to save',cteol)
    else
    begin
      try
        writeln(clearscr);
        symwassaved  := false;  codewassaved := false;
        Tworkfid     := workfid;
        if strlen(Tworkfid)>0 then promptyorn('Save as '+Tworkfid,answer)
                              else answer := 'N';
        if answer<>'Y' then
        begin
          write('Save as what file ? ');
          readln(Tworkfid);      goodio;
          zapspaces(Tworkfid);
          if strlen(Tworkfid)=0 then badio(inoerror);
        end;
        if gotsym and not symsaved then
        begin
          if domove(symfid,Tworkfid,true) then
          begin
            symsaved := true; symwassaved := true;
          end
          else badio(inoerror);         { move failed }
        end;
        if gotcode and not codesaved then
        begin
          if domove(codefid,Tworkfid,false) then
          begin
            codesaved := true; codewassaved := true;
          end
          else badio(inoerror);         { move failed }
        end;
        workfid := Tworkfid;
        if symwassaved then write('Source file saved ');
        if codewassaved then
        begin
          if symwassaved then write('& ');
          write('Code file saved ');
        end;
      recover
      begin
        saveesc := escapecode;
        printioerrmsg;
        if saveesc<>0 then escape(saveesc);
      end;
    end;        { save files }
end;    { savework }

(****************************************************************************)
procedure newwork(showmsg       : boolean;
                  var answer    : char);
var
  f             : file of char;
  lvid          : vid;
  lsegs         : integer;
  lkind         : filekind;
  ltitle        : fid;
begin
  answer := 'Y';
  if not (symsaved and codesaved) then
    promptyorn('Throw away current workfile',answer);

  if answer='Y' then
  with userinfo^ do
    begin
      lockup;
      ioresult := ord(inoerror);
      if scantitle(symfid,lvid,ltitle,lsegs,lkind) then
        if (lvid=syvid) and (ltitle='WORK.TEXT') then
        begin
          reset(f,'*WORK.TEXT');
          if ioresult = ord(inoerror) then close(f,'purge');
        end;
      if scantitle(codefid,lvid,ltitle,lsegs,lkind) then
        if (lvid=syvid) and (ltitle='WORK.CODE') then
        begin
          reset(f,'*WORK.CODE');
          if ioresult = ord(inoerror) then close(f,'purge');
        end;
      symsaved  := true;
      codesaved := true;
      gotsym  := false;
      gotcode := false;
      setstrlen(symfid,0);
      setstrlen(codefid,0);
      setstrlen(workfid,0);
      if showmsg then writeln('Workfile cleared',cteol);
      lockdown;
    end;{ if yes with ... }
end;    { newwork }

(****************************************************************************)
procedure getwork;
var
  f      : file of char;
  answer : char;
  Tworkfid, Tsymfid, Tcodefid : fid;
begin
  newwork(false,answer);
  if answer='Y' then
  with userinfo^ do
    if not (gotsym or gotcode) then
    begin
      writeln(clearscr);
      showprompt('Get what file ? ');
      readln(Tworkfid); goodio;
      zapspaces(Tworkfid);
      if strlen(Tworkfid)>0 then
      begin
        lockup;
        fixsrcfile(Tworkfid,Tsymfid,textfile);
        reset(f,Tsymfid);
        if ioresult=ord(inoerror) then
        begin
          gotsym := true;       close(f);
          symfid := Tsymfid;
        end;
        fixcodefile(Tworkfid,Tcodefid);
        reset(f,Tcodefid);
        if ioresult=ord(inoerror) then
        begin
          gotcode := true;      close(f);
          codefid := Tcodefid;
        end;
        if not (gotsym or gotcode) then write('No ')
        else
        begin
          workfid := Tworkfid;
          if gotsym then write('Source ');
          if gotsym and gotcode then write('and ');
          if gotcode then write('Code ');
        end;
        write('file loaded',cteol);
        lockdown;
      end;
    end;
end;    { getwork }

(****************************************************************************)
procedure whatwork;
begin
  with userinfo^ do
  begin
    if not(gotsym or gotcode) then write('No workfile')
    else
    begin
      write('Workfile is ');
      if strlen(workfid) > 0 then write(workfid) else write('not named');
      if not (symsaved and codesaved) then write(' (not saved)');
    end;
    write(cteol);
  end;
end;    { whatwork }

(****************************************************************************)
procedure makepasslist(var       f : fib;
                       var passptr : anyptr;
                       var count   : integer);
var
  passentries     : passarray;
  current         : passentryeltptr;
  prev            : passentryeltptr;
  i,save_result   : integer;
  fake_fib : fib;         
  begin
  fake_fib := f;
  prev  := nil; count := 0;
  with f, unitable^[funit] do
  begin
    fwindow := addr(passentries);
    fpos    := 0;       fpeof   := catlimit;
    passptr := nil;
    repeat
      call(dam,fake_fib,funit,catpasswords);
       try
         goodio;
         recover
         begin
           save_result := ioresult;
           writeln('goodio caught it ');
           writeln('ioresult : ',save_result);
           ioresult := save_result;
           escape(escapecode);
         end;
      for i := 1 to fpeof do
      begin
        count := count + 1;
        new(current);   current^.link := nil;
        if passptr=nil then passptr := current;
        if prev<>nil then prev^.link := current;
        prev := current;
        current^.pelement.pbits := passentries[i].pbits;
        current^.pelement.pword := passentries[i].pword;
      end;
      if fpeof=catlimit then fpos := fpos + fpeof;
    until fpeof<catlimit;
    ininfo.cfile := ftid;
  end;  { with }
end;    { makepasslist }

(****************************************************************************)
function findpass(var src : passentry; var list : passentryeltptr):boolean;
label 1;
begin
  findpass := true;
  while list<>nil do
  with list^.pelement do
  begin
    if (pword=src.pword) and (pbits<>0)  then goto 1;
    list := list^.link;
  end;
  findpass := false;
1:
end;    { findpass }

(****************************************************************************)
procedure getpassdef(var inpass : passentry;
                           opts : passarrayptr);
label 1,2;
var
  instring : string[255];
  name     : passtype;
  i, j     : integer;

begin
  setstrlen(inpass.pword,0);    inpass.pbits := 0;
  write('password:attributes ? ',cteol);
  readln(instring); goodio;
  if instring=sh_exc then badio(inoerror);
  zapspaces(instring);  {remove blanks and control characters}
  if strlen(instring)>0 then
  begin
    { get the password }
    j := beforestr(instring,1,1,':');
    if (j=0) or (j>(passleng + 1)) then
    begin  writeln('bad password',cteol); goto 2; end;
    inpass.pword := str(instring,1,j - 1); j := j + 1;  { skip : }
    { get the attributes }
    while j<=strlen(instring) do
    begin
      i := beforestr(instring,j,1,',');
      if i=0 then i := strlen(instring) + 1;
      name := str(instring,j,i - j); upc(name); { uppercase the attribute }
      j := i + 1;
      if strlen(name)>0 then
      begin
        i := 1;
        while opts^[i].pbits<>0 do
          if name = opts^[i].pword then goto 1
                                   else i := i + 1;
        writeln('bad attribute '''+name+'''',cteol);
        setstrlen(inpass.pword,0); goto 2;

        1:        inpass.pbits := ior(inpass.pbits,opts^[i].pbits);
      end;
    end;        { get attributes }
    if inpass.pbits=0 then
    begin writeln('No attributes'); goto 2; end;
  end;
2:
end;    { getpassdef }

(****************************************************************************)
function matchbits(var isubset,iset :integer):boolean;
begin matchbits := iand(iset,isubset) = isubset; end;

(****************************************************************************)
procedure showpass(var entry:passentry; opts: passarrayptr);
var
  i     : integer;
  first : boolean;
begin
  write(entry.pword,':'); first := true; i := 1;
  while opts^[i].pbits<>0 do
  begin
    if matchbits(opts^[i].pbits,entry.pbits) then
    begin
      if not first then write(',');     first := false;
      write(opts^[i].pword);
    end;
    i := i + 1;
  end;
  writeln;
end;    { showpass }

(****************************************************************************)
function getpword(p :prompttype; var name : passtype):boolean;
var
  i     : integer;
begin
  write(p,' ? ',cteol);
  readln(name); goodio;
  if name=sh_exc then badio(inoerror);
  zapspaces(name);      { remove spaces and control characters }
  getpword := strlen(name)>0;
end;    { getpword }

(****************************************************************************)
procedure putpass(var inpass:passentry; var f:fib);
begin
  with ininfo, cfib, unitable^[funit] do
  begin
    fwindow := addr(inpass);
    fpos    := 0;       fpeof   := 1;
    call(dam,cfib,funit,setpasswords);
    goodio;
  end;
end;    { putpass }

(****************************************************************************)
procedure access;
var
  filename      : fid;
  searchname    : fid;
  dircatentry   : catentry;
  passptr       : passentryeltptr;
  found         : passentryeltptr;
  count         : integer;
  lines         : integer;
  option        : char;
  answer        : char;
  done          : boolean;
  inpass        : passentry;
  optsptr       : passarrayptr;
  i : integer;

begin
  writeln(clearscr);
  showprompt('Access codes for which file ? ');
  readln(filename);     goodio;
  zapspaces(filename);
  if strlen(filename)>0 then
  with ininfo, cfib do
  begin
    setupfibforfile(filename,cfib,cpvol);

    { make sure that this operation is not performed on an HFS disc }
    if unit_is_hfs(funit) then
        badio(ibadrequest);

    useunit := unitnumber(cpvol);  dstatus := dneeded;
    if useunit then cvol := '' else cvol := cpvol;
    if (funit=0) or unitnumber(fvid) then mountvolume('',ininfo);
    try
      mark(lheap);      heapinuse := true;
      writeln('making pass'); for i := 1 to 1000000 do ;
      makepasslist(cfib,passptr,count);
      writeln('made pass'); for i := 1 to 1000000 do ;
      done := false;    optsptr := addr(foptstring^);
      writeln(clearscr);
      repeat
        setupfibforfile(filename,cfib,cpvol); goodio;
        write(homechar,'Access: List, Make, Remove, Attributes, Quit ? ',cteol);
        read(keyboard,option); readcheck; upcchar(option);
        writeln(option);
        if option='L' then
        begin           { List passwords }
          writeln(clearscr);
          found := passptr;     lines := 2;
          while found<>nil do
          begin
            if found^.pelement.pbits<>0 then
            begin
              lines := lines + 1;
              if lines=screenheight - 5 then
              begin
                spacewait;
                writeln(clearscr); writeln; lines := 3;
              end;
              showpass(found^.pelement,optsptr);
            end;
            found := found^.link;
          end;
          writeln(cfile,' has ',count:1,' passwords',cteol);
          option := 'q';
        end;

        if option='M' then
        begin   { Make password }
          write('Make ');
          getpassdef(inpass,optsptr); found := passptr;
          if strlen(inpass.pword)>0 then
          begin
            if findpass(inpass,found) then
            begin
              promptyorn(inpass.pword+' exists ... replace it',answer);
              if answer='Y' then
              begin
                putpass(inpass,cfib); found^.pelement.pbits := inpass.pbits;
              end;
            end
            else
            begin       { add it to the list }
              putpass(inpass,cfib); count := count + 1;
              new(found);
              found^.link     := passptr;
              found^.pelement := inpass;
              passptr         := found;
            end;
          end;
          option := 'q';
        end;

        if option='A' then
        begin   { list possible attributes }
          lines := 1;   writeln(cteol);
          while optsptr^[lines].pbits<>0 do
          begin
            writeln(optsptr^[lines].pword,cteol); lines := lines + 1;
          end;
          option := 'q';
        end;

        if option='R' then
        begin   { Remove password }
          if getpword('Remove password',inpass.pword) then
          begin
            found := passptr;
            if findpass(inpass,found) then
            begin
              found^.pelement.pbits := 0;
              count := count - 1;
              putpass(found^.pelement,cfib);
            end
            else writeln('Password not found',cteol);
          end;
          option := 'q';
        end;

        if option='Q' then
        begin
          done := true; option := 'q';
          writeln(clearscr);
        end;

        if streaming and (option<>'q') then badcommand(option);
      until done;
    recover
    begin
      release(lheap); heapinuse := false;
      printioerrmsg;
      if escapecode<>0 then escape(escapecode);
    end;
  end;
end;    {access}

(****************************************************************************)
procedure bad;
const
  blksize       = 256;
var
  filename      : fid;
  buf           : packed array [1..blksize] of char;
  badcount      : integer;
  dispx         : integer;
  dispy         : integer;
  endblock      : integer;
  i             : integer;

begin
  ininfo.fileopen := false;
  writeln(clearscr);
  showprompt('Bad sector scan of what directory ? ');
  readln(filename);     goodio;
  zapspaces(filename);
  if strlen(filename)>0 then
  with ininfo, cfib do
  begin
    setupfibforfile(filename,cfib,cpvol);
    saveio := ioresult;
    with unitable^[funit] do
    begin
      try
        useunit := unitnumber(cpvol); dstatus := dontcare;
        if useunit then cvol := '' else cvol := cpvol;
        if ((funit=0) or unitnumber(fvid)) and
           (saveio<>ord(inodirectory))     then mountvolume('',ininfo);
        lockup;
        fbuffered := false;
        call(dam,cfib,funit,openvolume);
        fileopen := (ioresult=ord(inoerror));
        lockdown;
        goodio;
        badcount   := 0;
        dispx      := 0;
        dispy      := 5;
        endblock   := (fleof div blksize) - 1;
        fgotoxy(output,0,2);
        writeln('Scanning ',uvid,': from sector 0 to sector ',endblock:1,cteol);
        writeln('Scanning: ',cteol);
        writeln('Bad sectors: ',cteol);
        for i := 0 to endblock do
        begin
          fgotoxy(output,9,3);  {increased from 5. 12/23/88 - SFB}
          write(i:9,' ');       { space is a message separation }{24jan83}  {SFB}
          call(tm,addr(cfib),readbytes,buf,blksize,i*blksize);
          if ioresult <> ord(inoerror) then
          begin   { found error }
            {   24jan83 allow other conditions besides zbadblock }
            if (ioresult = ord(zbadblock)) or (ioresult = ord(ztimeout)) or
               (ioresult = ord(znosuchblk)) or (ioresult = ord(znoblock)) then
            begin { found bad sector }
              badcount := badcount + 1;
              fgotoxy(output,dispx,dispy);
              write(i:9);  {increased from 5. 12/23/88 - SFB}
              if dispx<39 then dispx := dispx + 9  {decreased from 42. 12/23/88 - SFB}
              else
              begin
                dispx := 0;     dispy := dispy + 1;
              end;
            end   { found bad sector }
            else escape(0);
          end;    { found error }
        end;
        fgotoxy(output,dispx,dispy);
        if dispx<>0 then writeln;
        write(badcount:1,' bad sectors found.');
        closeinfile;
      recover
      begin
        lockup;
        saveio  := ioresult;
        saveesc := escapecode;
        closeinfile;
        ioresult := saveio;
        lockdown;
        printioerrmsg;
        if saveesc<>0 then escape(saveesc);
      end;
    end;
  end;
end;    { bad }

(****************************************************************************)
procedure krunch;
var
  filename      : fid;
  mounted       : boolean;
  answer        : char;
begin
  try
    mounted := false;
    writeln(clearscr);
    showprompt('Crunch what directory ? ');
    readln(filename); goodio;
    zapspaces(filename);
    if strlen(filename)>0 then
    with ininfo, cfib do
    begin
      setupfibforfile(filename,cfib,cpvol);
      useunit := unitnumber(cpvol);
      if useunit then cvol := '' else cvol := cpvol; dstatus := dneeded;
      if (funit=0) or unitnumber(fvid) then mountvolume('',ininfo)
                                       else cvol := fvid;
      promptyorn('Crunch directory '+cvol,answer);
      if answer = 'Y' then
      begin
        writeln('Crunch of directory ',cvol,' in progress',cteol);
        writeln(' DO NOT DISTURB !!',cteol);
        call(unitable^[funit].dam,cfib,funit,crunch);   goodio;
        writeln('Crunch completed',cteol);
      end;
    end;
 recover
   printioerrmsg;
end;    { krunch }

(****************************************************************************)
procedure zero(MAKE : boolean);
var
  filename      : fid;
  searchname    : fid;
  dircatentry   : catentry;
  answer        : char;
  vsize         : integer;

begin   { zero }
  ininfo.diropen := false;
  writeln(clearscr);
  if make then
  begin
    writeln(homechar,'Make directory (valid only for HFS and SRM type units)');
    write('Make what directory ? ')
  end
  else
  begin
    writeln(homechar,'Zero directory (NOT valid for HFS or SRM type units)');
    write('Zero what volume ? ');
  end;
  readln(filename);     goodio;
  zapspaces(filename);
  if strlen(filename)>0 then
  with ininfo, cfib, dircatentry do
  begin
    try
      if make then
      begin     { make directory }
        opendir(filename,searchname,'',ininfo,dircatentry);
        if not diropen then escape(0);
        if strlen(searchname)=0 then badmessage('Directory already exists');
        cname := searchname;
        promptyorn('Directory is '''+cname+''' correct',answer);
        if answer = 'Y' then
        begin
          fwindow := addr(dircatentry);
          call(unitable^[funit].dam,cfib,funit,makedirectory);
          goodio;
          writeln('Directory ',cname,' made');
          closedir(ininfo);
        end;
      end       { make directory }
      else
      begin     { zero directory } { allow existing directory }
        setupfibforfile(filename,cfib,cpvol);
        useunit := unitnumber(cpvol);
        if useunit then
          begin  cvol := ''; dstatus := dontcare; end
        else
          begin  cvol := cpvol; dstatus := dneeded; end;

        { make sure that this operation is not performed on an HFS disc }
        if unit_is_hfs(funit) then
          badio(ibadrequest);

        if not useunit and (funit=0) then ioresult := ord(inounit);
        if (funit=0) or (ioresult<>ord(inoerror)) then
        begin
          saveio := ioresult;
          if saveio<>ord(inodirectory) then
          begin printioerrmsg; mountvolume('',ininfo); end;
        end;

        if (funit>0) and not unitnumber(fvid) then
        begin   { open directory to get defaults }
          opendir(filename,searchname,'',ininfo,dircatentry);
          if not diropen then escape(0);
        end;

        if diropen then
        begin
          closedir(ininfo); { directory does exist }
          if (strlen(searchname)>0) or
             (cpsize<=0) then badio(ibadrequest);
        end
        else
        begin           { no directory so setup }
          setstrlen(cname,0);
          cpsize  := maxint;
          cextra1 := 0;
        end;
        unitable^[funit].ureportchange := false;
        vsize := ueovbytes(funit);
        unitable^[funit].ureportchange := true;

        if vsize<cpsize then cpsize := vsize;

        if strlen(cname)>0 then
        begin
          promptyorn('Destroy '+cname+':',answer);
          if answer<>'Y' then badio(inoerror);
        end
        else answer := 'Y';

        if not streaming then
        begin
          write('Number of directory entries ');
          if cextra1>0 then write('(',cextra1:1,')');
          write(' ? ');
        end;
        readnumber(cextra1);

        if not streaming then write('Number of bytes (',cpsize:1,') ? ');
        readnumber(cpsize);
        if cpsize=0 then badio(ibadvalue);

        if not streaming then write('New directory name? ');
        readln(cname); goodio; zapspaces(cname);
        if strlen(cname)=0 then badio(inoerror);
        if cname[strlen(cname)]=':' then setstrlen(cname,strlen(cname)-1);
        promptyorn(cname+': correct',answer);
        if answer = 'Y' then
        begin
          setupfibforfile(filename,cfib,cpvol);
          fwindow     := addr(dircatentry);
          call(unitable^[funit].dam,cfib,funit,makedirectory);
          goodio;
          writeln('Volume ',cname,' zeroed');
        end;
      end;
    recover
    begin
      lockup;
      saveio  := ioresult;
      saveesc := escapecode;
      closedir(ininfo);
      ioresult := saveio;
      lockdown;
      printioerrmsg;
      if saveesc<> 0 then escape(saveesc);
    end;
  end;  { with infib etc. }
end; { zero }

(****************************************************************************)
procedure make;
var
  filename      : fid;
  answer        : char;
  pathname      : fid;

begin
  outinfo.fileopen := false;
  outinfo.badclose := purgeit;

  write(clearscr);
  promptread('Make file or directory (F/D) ? ',answer,'FD ',sh_exc);
  if answer=' ' then
    if streaming then badcommand(answer)
                 else badio(inoerror);
  if answer='D' then zero(true) { 'make' a directory }
  else
  begin
    showprompt('Make what file ? ');
    readln(filename);  goodio;  zapspaces(filename);
    if strlen(filename)>0 then
    with outinfo, cfib do
    begin
      try
        fstripname(filename,cpvol,pathname,cfile);
        setupfibforfile(filename,cfib,cpvol);
        useunit := unitnumber(cpvol); dstatus := dneeded;
        if useunit then cvol := '' else cvol := cpvol;
        if (funit=0) or unitnumber(fvid) then mountvolume('',outinfo)
                                         else cvol := fvid;
        if outnotthere(answer,false) then
        begin
          lockup;
          fstartaddress := 0;
          call(unitable^[funit].dam,cfib,funit,createfile);
          fileopen := (ioresult=ord(inoerror));
          lockdown;
          goodio;
          closeoutfile(fpeof,keepit);
          goodio;
          writeln('File ',cvol,':',pathname,cfile,' made ');
          writeln('size is ',fpeof div 512:1,' blocks(512) or ',fpeof:1,' bytes');
        end;
      recover
      begin
        lockup;
        saveio  := ioresult;
        saveesc := escapecode;
        closeoutfile(0,badclose);
        ioresult := saveio;
        lockdown;
        printioerrmsg;
        if saveesc <> 0 then escape(saveesc);
      end;
    end;  { with }
  end;  { make file }
end;    { make }

(****************************************************************************)
procedure prefix(default:boolean);
var
  dirname       : fid;

begin
  writeln(clearscr);
  if default then showprompt('Prefix to what directory ? ')
             else showprompt('Set unit to what directory ? ');
  readln(dirname); goodio; zapspaces(dirname);
  if strlen(dirname)>0 then
  with ininfo, cfib do
  begin
    lockup;
    try
      setupfibforfile(dirname,cfib,cpvol);
      if (funit=0) or unitnumber(fvid) then
      begin
        if default then
        begin
          if strlen(ftitle)>0 then badio(ibadtitle);
          dkvid := cpvol;          ioresult := ord(inoerror);
        end
        else badmessage('Directory '+cpvol+' not online');
      end
      else
      begin
        call(unitable^[funit].dam,cfib,funit,setunitprefix);
        if ioresult<>ord(inoerror) then escape(0);
        if default then dkvid := unitable^[funit].uvid
        else
          writeln('Unit #',funit:0,' directory is ',unitable^[funit].uvid,cteol);
      end;
      lockdown;
    recover
    begin
      lockdown;
      printioerrmsg;
    end;
  end;  { with }
  if default then writeln('Prefix is ',dkvid,':',cteol);
end;    { prefix }

(****************************************************************************)
procedure getfilenames(var instring     : string255;
                       var filename1    : fid;
                       var filename2    : fid;
                           prompt2      : string80;
                           getname2     : boolean);
var
  p     : integer;
begin
  setstrlen(filename1,0);
  setstrlen(filename2,0);
  p := strpos(',',instring);
  if p=0 then p := strlen(instring) + 1;
  if p>0 then
  begin
    if p>sizeof(filename1) then badio(ibadtitle)
                           else filename1 := str(instring,1,p-1);
    if p>strlen(instring) then setstrlen(instring,0)
                          else strdelete(instring,1,p);
    if getname2 then
    begin
      if (strlen(prompt2)>0) and (strlen(instring)=0) then
      begin
        write(prompt2,cteol);
        readln(instring); goodio;
        zapspaces(instring);
      end;
      if strlen(instring)>0 then
      begin
        p := strpos(',',instring);
        if p=0 then p := strlen(instring) + 1;
        if p>0 then
        begin
          if p>sizeof(filename2) then badio(ibadtitle)
                                 else filename2 := str(instring,1,p-1);
          if p>strlen(instring) then setstrlen(instring,0)
                                else strdelete(instring,1,p);
        end;
      end;
    end;
  end;
end;    { getfilenames }

(****************************************************************************)
procedure duplicate;
var
  instring      : string255;
  cprompt       : prompttype;
  filename1     : fid;
  filename2     : fid;
  searchname    : fid;
  destname      : fid;
  dircatentry   : catentry;
  nameptr       : tidelementptr;
  lsegs         : integer;
  lkind         : filekind;
  wildcard      : char;
  answer        : char;
  purgeold      : boolean;

begin
  heapinuse        := false;
  ininfo.diropen   := false;
  outinfo.diropen  := false;
  outinfo.fileopen := false;
  cprompt := 'Dup_link ';
  writeln(clearscr);
  writeln(homechar,'Duplicate link (valid only for HFS and SRM type units)',cteol);
  promptread('Duplicate or Move ? (D/M) ',answer,'DM ',sh_exc);
  if answer=' ' then
    if streaming then badcommand(answer)
                 else badio(inoerror);
  purgeold := answer='M';
  if purgeold then cprompt := 'Move ';
  write(cprompt+'what file ? ');
  readln(instring);     goodio;
  zapspaces(instring);
  while strlen(instring)>0 do
  begin
    try
      getfilenames(instring,filename1,filename2,CPROMPT+'to what ? ',true);
      if not ((strlen(filename1)>0) and (strlen(filename2)>0)) then badio(inoerror);
      with ininfo, cfib do
      begin
        opendir(filename1,searchname,'',ininfo,dircatentry);
        if not diropen then escape(0);
        if strlen(searchname)=0 then badio(inotondir);

        mark(lheap);  heapinuse := true;
        wildcard  := getwildcard(searchname);
        makenamelist(cfib,searchname,nameptr,false,false,true,lsegs);
        goodio;
        if nameptr=nil then
        begin
          if wildcard=' ' then badio(inofile);
          writeln('no files found',cteol); badio(inoerror);
        end;
        with outinfo, cfib do
        begin
          opendir(filename2,destname,'',outinfo,dircatentry);
          if not diropen then escape(0);
          if strlen(destname)=0 then badio(inotondir);
          if not samedevice(ininfo.cfib.funit,funit) then badio(ibadrequest);
        end;
        compatible(searchname,destname);
        if getwildcard(destname)='?' then wildcard := '?';
        if wildcard<>' ' then writeln(clearscr);
        while nameptr<>nil do
        with nameptr^ do
        begin
          makenewname(searchname,destname,element,filename2);
          ftitle    := element;
          answer    := 'Y';
          if wildcard = '?' then
             promptyorn(cprompt+ininfo.cvol+':'+ftitle,answer);

          if answer = 'Y' then
          begin
            outinfo.cfib.ftitle := filename2;
            if outnotthere(answer,false) then
            begin
              fwindow := addr(outinfo.cfib);
              fpurgeoldlink := purgeold;
              call(unitable^[funit].dam,cfib,funit,duplicatelink);
              goodio;
              showmove(cvol,element,outinfo.cvol,filename2);
            end;
          end;
          if nameptr<>nil then nameptr := link;
        end;    { while with nameptr }
        release(lheap);       heapinuse := false;
      end;      { with ininfo , cfib }
      closeall(0);
    recover
    begin
      lockup;
      saveio       := ioresult;
      saveesc      := escapecode;
      if heapinuse then release(lheap);
      heapinuse    := false;
      closeall(0);
      ioresult     := saveio;
      lockdown;
      printioerrmsg;
      if saveesc<>0 then escape(saveesc);
      setstrlen(instring,0);
    end;
  end;  { while }
end;    { duplicate }

(****************************************************************************)
procedure change;
var
  instring      : string255;
  cprompt       : prompttype;
  filename1     : fid;
  filename2     : fid;
  searchname    : fid;
  destname      : fid;
  dircatentry   : catentry;
  nameptr       : tidelementptr;
  lsegs         : integer;
  lkind         : filekind;
  wildcard      : char;
  answer        : char;

begin
  heapinuse        := false;
  ininfo.diropen   := false;
  outinfo.fileopen := false;
  cprompt := 'Change ';
  writeln(clearscr);
  showprompt(cprompt+'what file ? ');
  readln(instring);     goodio;
  zapspaces(instring);
  while strlen(instring)>0 do
  begin
    try
      getfilenames(instring,filename1,filename2,CPROMPT+'to what ? ',true);
      if not ((strlen(filename1)>0) and (strlen(filename2)>0)) then badio(inoerror);
      with ininfo, cfib do
      begin
        if not scantitle(filename1,fvid,ftitle,lsegs,lkind) then badio(ibadtitle);
        if strlen(ftitle)=0 then
        begin   {change volume name}
          cpvol   := fvid;
          useunit := unitnumber(cpvol); dstatus := dneeded;
          if useunit then cvol := '' else cvol := cpvol;
          funit   := findvolume(fvid,true);
          if (funit=0) or unitnumber(fvid) then mountvolume('',ininfo)
                                           else cvol := fvid;

          if not scantitle(filename2,outinfo.cfib.fvid,
                 outinfo.cfib.ftitle,lsegs,lkind) then badio(ibadtitle);
          if (strlen(outinfo.cfib.ftitle)<>0) or
             unitnumber(outinfo.cfib.fvid)        then badio(ibadtitle);
          outinfo.cvol := outinfo.cfib.fvid;
          call(unitable^[funit].dam,outinfo.cvol,funit,setvolumename);
          goodio;
          writeln(cvol,':','':(vidleng-strlen(cvol)),
                  ' ==> ',outinfo.cvol,':',cteol);
        end     { change volume name }
        else
        begin   { change file name(s) }
          { validate the new name }
          if (filename2[1]='*') or (filename2[1]='#') or
             (breakstr(filename2,1,':[')<>0) then badio(ibadtitle);

          opendir(filename1,searchname,'',ininfo,dircatentry);
          if not diropen then escape(0);
          if strlen(searchname)=0 then
          begin         { may have SRM directory instead of file }
            opendir(filename1,searchname,'',ininfo,dircatentry);
            if not diropen then escape(0);
          end;
          if strlen(searchname)=0 then badio(ibadtitle);
          mark(lheap);  heapinuse := true;
          wildcard  := getwildcard(searchname);
          makenamelist(cfib,searchname,nameptr,false,false,true,lsegs);
          goodio;
          if nameptr=nil then
          begin
            if wildcard = ' ' then badio(inofile);
            writeln('no files found'); badio(inoerror);
          end;
          compatible(searchname,filename2);
          if getwildcard(filename2)='?' then wildcard := '?';
          if wildcard<>' ' then writeln(clearscr);
          while nameptr<>nil do
          with nameptr^ do
          begin
            makenewname(searchname,filename2,element,destname);
            if element<>destname then           {25jan83}
            begin
              ftitle    := element;
              answer    := 'Y';
              if wildcard = '?' then
                 promptyorn(cprompt+ininfo.cvol+':'+ftitle,answer);

              if answer = 'Y' then
              begin
                outinfo.cfib        := cfib;
                outinfo.cfib.ftitle := destname;
                outinfo.cvol        := cvol;
                if outnotthere(answer,false) then
                begin
                  fwindow := addr(destname);
                  call(unitable^[funit].dam,cfib,funit,changename);
                  goodio;
                  showmove(cvol,element,cvol,destname);
                end;
              end;
            end                                                 { 25jan83}
            else showmove(cvol,element,cvol,element); { no change 25jan83}
            if nameptr<>nil then nameptr := link;
          end;  { while with nameptr }
          release(lheap);       heapinuse := false;
          closedir(ininfo);     {bugfix for FSDdt01111 11/28/88 SFB}
        end;    { change file name(s) }
      end;      { with ininfo , cfib }
    recover
    begin
      lockup;
      saveio       := ioresult;
      saveesc      := escapecode;
      if heapinuse then release(lheap);
      heapinuse    := false;
      closeoutfile(0,outinfo.badclose); { outnotthere }
      closedir(ininfo);
      ioresult     := saveio;
      lockdown;
      printioerrmsg;
      if saveesc<>0 then escape(saveesc);
      setstrlen(instring,0);
    end;
  end;  { while }
end;    { change }

(****************************************************************************)
procedure listdir(extlist : boolean);
type
  textptr       = ^text;
var
  listfile      : text;
  dispfile      : textptr;
  instring      : string255;
  filename1     : fid;
  filename2     : fid;
  searchname    : fid;
  dircatentry   : catentry;
  nameptr       : tidelementptr;
  count         : integer;      { line count }
  catentryptr   : ^catentry;
  getname2      : boolean;
  listtofile    : boolean;
  holes         : boolean;
  order         : boolean;
  blocks        : boolean;
  wildcard      : char;
  answer        : char;
  blocksused    : integer;
  holeblock     : integer;
  bighole       : integer;
  totalholes    : integer;
  filecount     : integer;
  showcount     : integer;
  my_count      : integer;

$IOCHECK ON$  {31JAN83  LOOKOUT FOR PRINTER TIMEOUTS}
  procedure showhole(temp : integer);
  begin
    if temp>0 then
    begin
      if extlist then
      begin
        count := count + 1;
        write(dispfile^,'< UNUSED > ');
        write(dispfile^,bytestoblocks(temp,dircatentry.cblocksize):16);
        writeln(dispfile^,bytestoblocks(holeblock,dircatentry.cblocksize):22);
      end;
      if temp>bighole then bighole := temp;
      totalholes := totalholes + temp;
    end;
  end;
$IOCHECK OFF$  {31JAN83  LOOKOUT FOR PRINTER TIMEOUTS}

begin   { listdir }
  ininfo.diropen  := false;
  listtofile      := false;
  if extlist
    then
      begin
        instring := 'List_ext ' ;
      end
    else
      begin
        instring := 'List ';
      end;
  writeln(clearscr);
  showprompt(instring+'what directory ? ');
  readln(instring);     goodio;
  zapspaces(instring);
  while strlen(instring)>0 do
  begin
    getfilenames(instring,filename1,filename2,'',true);
    if strlen(filename1)>0 then
    begin
      mark(lheap);      heapinuse := true;
      try
        opendir(filename1,searchname,'',ininfo,dircatentry);
        if not ininfo.diropen then escape(0);
        order  := ininfo.cfib.fpos<>0;
        blocks := ((searchname='') or (searchname='='));
        holes  := not order and blocks and
                  (dircatentry.cstart>=0) and (dircatentry.cpsize>0);
        holeblock  := dircatentry.cstart;
        totalholes := 0;
        blocksused := 0;
        showcount  := 0;
        bighole    := 0;
        wildcard   := getwildcard(searchname);
        makenamelist(ininfo.cfib,searchname,nameptr,true,order,false,filecount);
        goodio;
        with ininfo, cfib, unitable^[funit] do
        begin
          if strlen(filename2)>0 then
          begin
            lockup;
            rewrite(listfile,filename2);
            listtofile := (ioresult=ord(inoerror));
            lockdown;
            goodio;
            dispfile   := addr(listfile);
          end
          else dispfile   := addr(output);

          if listtofile then writeln(ininfo.cvol,':',cteol)
                        else writeln(clearscr);
                        
          if srm_is_srmux_unit(funit) then
           begin
             with dircatentry do
              begin
               for my_count := 20 downto 7 do
                 cinfo[my_count] := cinfo[my_count-3];
               cinfo[1] := 'S'; cinfo[2] := 'R'; cinfo[3] := 'M';
               cinfo[4] := '-'; cinfo[5] := 'U'; cinfo[6] := 'X';
              end;
              setstrlen(dircatentry.cinfo,strlen(dircatentry.cinfo)+3);
           end;
          
          showcatheader(extlist,order,dircatentry,dispfile^,count);
          while nameptr <> nil do
          with nameptr^ do
          begin
            catentryptr := addr(nameptr^.element);
            answer := 'Y';
            if wildcard = '?' then
            begin
              count := count + 1;
              promptyorn('List '+uvid+':'+catentryptr^.cname,answer);

            end;
            if (wildcard <> '?') or (answer = 'Y') then
            with catentryptr^ do
            begin
              blocksused := blocksused + cpsize;
              if holes and (cstart>=0) then
              begin
                if cstart<>holeblock then showhole(cstart - holeblock);
                holeblock := cstart + cpsize;
              end;
              showcount := showcount + 1;
              showcatentry(extlist,catentryptr^,dispfile^,count);
            end;
            nameptr := link;
            if (nameptr<>nil) and (not listtofile) then
              if count>=screenheight-4 then
              begin
                spacewait; writeln(clearscr);
                showcatheader(extlist,order,dircatentry,dispfile^,count);
              end;
          end;  { while with }
                { show hole after last file }
          if holes then showhole(dircatentry.cpsize - holeblock - 1);

          {write summary info}
          count := count + 2 + (79 div screenwidth)*2;
          if not listtofile then
            if count>=screenheight-4 then
            begin
              spacewait; writeln(clearscr);
              showcatheader(extlist,order,dircatentry,dispfile^,count);
            end;
          if showcount=0 then writeln('...... file(s) not found ......');
          $IOCHECK ON$  {31JAN83 LOOKOUT FOR PRINTER TIMEOUTS}
          write(dispfile^,'FILES shown=',showcount:1);
          with dircatentry do
          begin
            write(dispfile^,' allocated=',filecount:1);
            if cextra1>0 then {mods for hfs "report unallocated" SFB}
             if not unit_is_hfs(funit) then
              {this unit is not an HFS so report unallocated old way SFB}
              write(dispfile^,' unallocated=',cextra1-filecount:1)
             else
             {this is HFS, so cextra1=unallocated inodes, not total inodes SFB}
              write(dispfile^,' unallocated=',cextra1:1);
            writeln(dispfile^);
            if holes or (cextra2>=0) or blocks then
            begin
              write(dispfile^,'BLOCKS (',DIRCATENTRY.CBLOCKSIZE:1,' bytes)');
              if blocks then write(dispfile^,' used=',bytestoblocks(blocksused,cblocksize):1);
              if cextra2>=0 then
                 write(dispfile^,' unused=',bytestoblocks(cextra2,cblocksize):1)
              else
                if holes then
                  write(dispfile^,' unused=',bytestoblocks(totalholes,cblocksize):1);
              if holes then
                write(dispfile^,' largest space=',bytestoblocks(bighole,cblocksize):1);
            end;
          end;  { with dircatentry }
          writeln(dispfile^);
          $IOCHECK OFF$ {31JAN83 LOOKOUT FOR PRINTER TIMEOUTS}
          if listtofile then close(listfile,'lock');
        end; { with ininfo, cfib etc. }
        release(lheap); heapinuse := false;

      recover
      begin
        lockup;
        saveio  := ioresult;
        saveesc := escapecode;
        release(lheap); heapinuse := false;
        closedir(ininfo);
        if listtofile then close(listfile,'lock');
        ioresult := saveio;
        lockdown;
        printioerrmsg;
        if (saveesc <> 0) and (saveesc<>-10) then escape(saveesc) {31jan83}
                                             else ioresult := ord(inoerror);
        setstrlen(instring,0);
      end;
    end;{ if name to list }

    closedir(ininfo);
  end;  { while instring .. }
end;    { listdir }

(****************************************************************************)
procedure remove;
var
  instring      : string255;
  filename1     : fid;
  filename2     : fid;
  searchname    : fid;
  dircatentry   : catentry;
  nameptr       : tidelementptr;
  getname2      : boolean;
  wildcard      : char;
  answer        : char;
  filecount     : integer;
  lkind         : filekind;
  lsegs         : integer;

begin   { remove }
  ininfo.diropen := false;
  heapinuse      := false;
  writeln(clearscr);
  showprompt('Remove what file ? ');
  readln(instring);     goodio;
  zapspaces(instring);
  while strlen(instring)>0 do
  begin
    mark(lheap);        heapinuse := true;
    try
      getfilenames(instring,filename1,filename2,'',false);
      if (strlen(filename1)>0) then
      begin
        { check if only fvid given }
        with ininfo, cfib do
          begin
            if not scantitle(filename1, fvid, ftitle, lsegs, lkind) then
              badio(ibadtitle);
            if strlen(ftitle) = 0 then badio(ibadrequest);
          end;
        opendir(filename1,searchname,'',ininfo,dircatentry);
        if not ininfo.diropen then escape(0);
        if strlen(searchname)=0 then
        begin   { may have SRM directory  try opening parent directory}
          opendir(filename1,searchname,'',ininfo,dircatentry);
          if not ininfo.diropen then escape(0);
          if strlen(searchname)=0 then badio(ibadrequest);
        end;
        ininfo.cvol := dircatentry.cname;
        wildcard    := getwildcard(searchname);
        makenamelist(ininfo.cfib,searchname,nameptr,false,false,true,filecount);
        goodio;
        answer := 'N';
        if nameptr<>nil then
        begin
          if wildcard<>' ' then
          begin
            writeln(clearscr);
            editnamelist(nameptr,'Remove ',wildcard);
            if nameptr<>nil then promptyorn('Proceed with remove',answer);
          end
          else answer := 'Y';
        end;

        if answer='Y' then
        begin
          with ininfo, cfib, unitable^[funit] do
            while nameptr<>nil do
              with  nameptr^ do
                begin
                  ftitle    := element;
                  call(dam,cfib,funit,purgename);
                  if ioresult<>ord(inofile) then
                  begin { don't show missing files }
                    goodio;
                    writeln(cvol,':',element,' removed',cteol);
                  end;
                  nameptr   := link;
                end;    { with nameptr^ while with lfib ...}
        end
        else writeln('No files removed',cteol);
      end;{ namestring <> nil }
    release(lheap);     heapinuse := false;
    closedir(ininfo);

    recover
    begin
      lockup;
      release(lheap); heapinuse := false;
      saveio  := ioresult;
      saveesc := escapecode;
      closedir(ininfo);
      ioresult := saveio;
      lockdown;
      printioerrmsg;
      if saveesc<>0 then escape(saveesc);
      setstrlen(instring,0);
    end;
  end;  { while }
end;    { remove }


(****************************************************************************)
procedure transfer(doformat:boolean);
type
  fullname = string[vidleng+tidleng+1];
  ipointer = ^integer;
var
  tprompt       : string[15];
  instring      : string255;
  filename1     : fid;
  filename2     : fid;
  searchname    : fid;
  destname      : fid;
  dircatentry   : catentry;
  nameptr       : tidelementptr;

  filemoved     : boolean;
  done          : boolean;
  swap          : boolean;
  format        : boolean;
  wildcard      : char;
  answer        : char;
  i             : integer;
  instate       : integer;
  outstate      : integer;
  segs          : integer;
  buf           : bigptr;
  position      : integer;
  movesize      : integer;
  bufsize       : integer;
  lefttoxfer    : integer;
  saveioresult  : integer;
  saveesc       : integer;
  lkind         : filekind;
  dumwindow     : windowp;
  outsize       : integer;
  outfkind      : filekind;
  outeft        : shortint;
  outfstarta    : integer;
  overcreate    : damrequesttype;
  bdatoffset    : integer;      { BDAT WORT #2 offset for funny sector }
  infunny,outfunny : boolean;   { funny record present/not present     }
        { BDAT WORT #3 create and writeout funny sector }
        { this is realy a cancer !! }
  pos           : integer;      {for "destroy EVERYTHING" message.      SFB}

procedure writebdatfunny;
  type
    twowords = record case boolean of
                 true  :(long  : integer);
                 false :(word1 : shortint;
                         word2 : shortint);
               end;
    rec = record
            eofsector : integer;
            eofbyte   : integer;
            nrecs     : integer;
            pad       : array[0..60] of integer;
          end;
  var
    recword : twowords;
    i       : integer;
    funny   : rec;
  begin
    with ininfo.cfib do
    begin
      for i:=0 to 60 do funny.pad[i] := 0;
      funny.eofsector := fleof div 256;
      funny.eofbyte   := fleof mod 256;
      recword.long    := fstartaddress;
      recword.long    := recword.word2 * 2;
      if recword.long<1 then recword.long := 1; { feb83 zero is realy 1 }
      funny.nrecs     := (outinfo.cfib.fpeof-256) div recword.long;
      if ((outinfo.cfib.fpeof-256) mod recword.long)>0 then
         funny.nrecs := funny.nrecs + 1;
    end;
    with outinfo, cfib do
      call(unitable^[funit].tm,addr(cfib),writebytes,funny,256,0);
    goodio;
  end; { write bdat funny }

  procedure permission2(sunit,dunit : integer; var answer: char);
  begin
    answer := 'Y';
    if not format and
       unitable^[sunit].uisblkd {source is blocked device} and
       not unitable^[dunit].uisblkd {destination is unblocked device} then
      if not streaming then
      begin
        writeln('Translate should be used for serial devices');
        promptyorn('continue Filecopy',answer);
      end;
  end;  { permission2 }

  procedure permission(var answer: char);
  var
    tempv : vid;

   {adjustedfkind generates "UX" (or the FKIND7 suffix) instead of "FKIND7"
    for the source file type iff suffixtable^[FKIND7] <> ''.
    It actually generates upc(suffix) for all fkinds >= FKIND7,
    if the suffix is non nil.       SFB}
   function adjustedfkind(fk : filekind) : string255;  {SFB}
   var tmp : string255;
       pos : integer;
   begin
    tmp:='';
    if (fk < fkind7) or (suffixtable^[fk] = '') then
     strwrite(tmp,1,pos,fk)
    else
     begin
      strwrite(tmp,1,pos,suffixtable^[fk]);
      upc(tmp);
     end;
    adjustedfkind := tmp;
   end;

  begin
    with ininfo do
    begin
      if strlen(cvol)=0 then tempv := cpvol else tempv := cvol;
      write('Can''t Translate ',tempv,':',cfile);
     {if strlen(cfile)>0 then writeln(' (type ',cfib.fkind,')',cteol)     SFB}
      if strlen(cfile)>0 then writeln(' (type ',adjustedfkind(cfib.fkind),')',cteol) {SFB}
                         else writeln(' (type unit)',cteol);
    end;
    with outinfo do
    begin
      if strlen(cvol)=0 then tempv := cpvol else tempv := cvol;
      write('             to ',tempv,':',cfile);
     {if strlen(cfile)>0 then writeln(' (type ',suffix(cfile),')',cteol)        {SFB}
      if strlen(cfile)>0 then writeln(' (type ',adjustedfkind(suffix(cfile)),')',cteol)
                         else writeln(' (type unit)',cteol);
    end;
    if streaming then escape(-1);
    promptyorn('Do Filecopy',answer);
  end;  { permission }

  function has_related_hfs_unit(un:unitnum) : integer;    {SFB}
  var i : integer;
      my_base_unum : integer;
   begin
    has_related_hfs_unit:=0;
    if h_unitable<>NIL then
     begin
      my_base_unum:=h_unitable^.tbl[un].base_unum;
      for i:=maxunit downto 1 do
       with h_unitable^.tbl[i] do
        if is_hfsunit and (base_unum=my_base_unum) then
         has_related_hfs_unit:=i;
     end;
   end;

  procedure endearly;
  begin
    done := true; filemoved := true; closeinfile;
  end;

begin   { transfer }
  if doformat then tprompt := 'Translate '
              else tprompt := 'Filecopy ';
  writeln(clearscr);
  showprompt(tprompt+'what file ? ');
  readln(instring);     goodio;
  zapspaces(instring);
  while strlen(instring)>0 do
    begin
      getfilenames(instring,filename1,filename2,tprompt+'to what ? ',true);
      if (strlen(filename1)>0) and (strlen(filename2)>0) then
      begin
        with ininfo do
        begin diropen := false; fileopen := false; mounted := false; end;
        with outinfo do
        begin
          diropen := false; fileopen := false; mounted := false;
          badclose := purgeit;  goodclose := keepit;
        end;
        outstate   := 1;
        mark(lheap);    heapinuse := true;
        newwords(dumwindow,1);  { dummy window for file translate }
        try
          with ininfo, cfib do
          begin { OPEN THE INPUT DIRECTORY/VOLUME }
            setupfibforfile(filename1,cfib,cpvol);
            if strlen(ftitle)=0 then
            begin { volume -> x }
              useunit := unitnumber(cpvol);     dstatus := dwanted;
              if useunit then cvol := '' else cvol := cpvol;
              mounted := (funit>0) and not(unitnumber(fvid));
              if mounted then cvol := fvid else inmount(true);
              lockup;   { lock the keyboard }
              fbuffered := false;
              fkind     := untypedfile;     feft := efttable^[fkind];
              call(unitable^[funit].dam,cfib,funit,openvolume);
              fileopen  := (ioresult=ord(inoerror));
              lockdown; { unlock the keyboard }
              goodio;
              outsize    := fpeof;    lefttoxfer  := fpeof;
              outfkind   := datafile; outeft      := efttable^[outfkind];
              outfstarta := fstartaddress;
              position   := 0;
              searchname := '';
              instate    := 2;  { ready to read }
              wildcard   := ' ';
              nameptr    := nil;        ftid  := '';
            end
            else
            begin { file -> x }
              opendir(filename1,searchname,' SOURCE',ininfo,dircatentry);
              if not diropen then escape(0);
              { BDAT WORT #4 can the funny record exist }
              if strlen(dircatentry.cinfo)>=4 then
                infunny := (str(dircatentry.cinfo,1,4)='LIF ') or (str(dircatentry.cinfo,1,4)='HFS ') ;

              if strlen(searchname)=0 then badio(inotondir);
              makenamelist(cfib,searchname,nameptr,false,false,true,segs);
              goodio;
              wildcard := getwildcard(searchname);
              if nameptr=nil then
              begin
                if wildcard=' ' then badio(inofile);
                writeln('no files found',cteol); badio(inoerror);
              end;
            end;
            cfile := '';
            swap  := not unitable^[funit].uisfixed;
          end;  { with ininfo, cfib }

          bufsize := (memavail div 256) * 256 - 30 * 512; {save some for slop}
          if bufsize<512 then escape(-2);       { not enough room }
          newwords(buf,bufsize div 2);          { allocate buffer space }

          writeln(clearscr);
          repeat
            { find next input file }
            with ininfo do
            begin
              if nameptr<>nil then cfile := nameptr^.element;
              if wildcard='?' then promptyorn(tprompt+cvol+':'+cfile,answer)
              else answer := 'Y';
            end;

            if answer='Y' then
            begin       { try the transfer }
              filemoved := false;
              format    := doformat;
              if ininfo.diropen then instate := 1;   { open the file first }
              repeat    { move the file }
                done := false;
                with ininfo, cfib do
                repeat
                  case instate of
                  1: begin      { open the file }
                       inmount(swap);
                       ftitle := cfile;
                       if doformat then finitb(cfib,dumwindow,-3);
                       pathid := path;
                       lockup;
                       call(unitable^[funit].dam,cfib,funit,openfile);
                       fileopen := ioresult=ord(inoerror);
                       lockdown;
                       if ioresult=ord(inotondir) then
                       begin    { skip this file }
                         writeln('Can''t copy/translate a directory');
                         done := true;  filemoved := true;
                       end
                       else
                       begin
                         goodio;
                         feof         := false;   feoln    := false;
                         instate      := 2;       flastpos := -1;     fpos := 0;
                         outsize      := fpeof;   { same size as input }
                         outfkind     := fkind;   outeft := feft;
                         outfstarta   := fstartaddress;
                         lefttoxfer   := fleof;
                         position     := 0;       linecount:=0;
                       end;
                     end;
                  2: begin      { read the file }
                       inmount(swap);
                       write('Reading ....',chr(13));
                       if format then
                       begin    { formated transfer }
                         anytomem(addr(cfib),buf,bufsize);
                         if buf^[0]=chr(4) then format := false
                         else
                         begin
                           done := true;
                           if feof then lefttoxfer := 0;
                           goodio;
                         end;
                       end
                       else
                       begin    { unformated transfer }
                         if bufsize>lefttoxfer then movesize := lefttoxfer
                                               else movesize := bufsize;
                         call(unitable^[funit].tm,addr(cfib),readbytes,
                                                  buf^,movesize,position);
                         goodio;
                         lefttoxfer := lefttoxfer - movesize;
                         done := true;
                       end;

                       if lefttoxfer = 0 then
                       begin      { close the input file }
                         closeinfile;   goodio;
                       end;
                       write(cteol);
                     end;
                  end;  { case instate }
                until done;
                done := false;
                if not filemoved then
                with outinfo, cfib do
                repeat
                  case outstate of
                  1: begin      { OPEN THE DESTINATION DIRECTORY }
                       if not scantitle(filename2,fvid,ftitle,segs,lkind) then
                         badio(ibadtitle);
                       cpvol := fvid;   cfile := '';
                       if segs<>0 then
                       begin    { check size specification }
                         segs    := segs * 512;
                         if (segs<outsize) and (segs>0) and
                            not format     then badio(inoroom);
                         outsize := segs;
                       end
                       else
                       if format then outsize := 0;

                       useunit := unitnumber(cpvol);
                       if useunit then cvol := '' else cvol := cpvol;

                       funit   := findvolume(fvid,true);
                       if funit>0 then  { always true for unblocked units }
                         swap := not unitable^[funit].uisfixed and swap;


                       if strlen(ftitle)=0 then
                       begin    { setup for x->volume }
                         fkind   := outfkind;     feft := outeft;
                         dstatus := dontcare;
                         { is the volume/device mounted already }
                         if useunit then
                           mounted := ((ioresult=ord(inoerror)) or
                                      (ioresult=ord(inodirectory))) and
                                      ( not swap or
                                      not samedevice(funit,ininfo.cfib.funit))
                         else
                         begin  { volname given }
                           if funit>0 then
                             mounted := not samedevice(funit,ininfo.cfib.funit)
                           else mounted := false;
                         end;
                         if mounted and
                            (ioresult=ord(inoerror)) then cvol := fvid;
                         swap := not mounted and swap;
                         outmount(swap);
                         if swap then
                         begin  { is destination now on the source device ? }
                           swap := samedevice(funit,ininfo.cfib.funit);
                           ininfo.mounted := not swap;
                         end;

                         if format and unitable^[funit].uisblkd then
                           badmessage('Can''t Translate to blocked volume');
                       { don't ask permission for blocked volume to volume }
                         if (format<>doformat) and
                            not (not ininfo.diropen and unitable^[funit].uisblkd)
                            then permission(answer)
                            else answer := 'Y';

                         if answer='Y' then
                         begin  { carry on }
                           if   (unitable^[funit].uisblkd and (strlen(cvol)>0))
                             or (has_related_hfs_unit(funit)<>0) then
                           begin  { have existing directory or HFS
                                    on another unit on same medium. SFB}
                             if cvol='' then    {then create a name.     SFB}
                              strwrite(cvol,1,pos,'#',funit:1,':');
                             promptyorn('Destroy EVERYTHING on volume '+cvol,answer);
                             if answer<>'Y' then badio(inoerror);
                           { can't rely on name for next mount call }
                             cvol := '';
                             if not useunit then
                             begin
                               setstrlen(cpvol,0); strwrite(cpvol,1,i,'#',funit:1);
                               useunit := true;
                             end;
                           end;
                           lockup;
                           badclose  := closeit;        goodclose := closeit;
                           fbuffered := false;
                           call(unitable^[funit].dam,cfib,funit,openvolume);
                           fileopen  := ioresult=ord(inoerror);
                           lockdown;
                           goodio;
                           if fpeof<outsize then badio(inoroom);
                           fpos := 0;   flastpos := -1;
                           outstate    := 2;      { ready to write }
                           destname    := '$';    ftid := '';
                         end
                         else endearly;
                       end      { setup for x->volume }
                       else
                       begin    { setup for x->file }
                         dstatus := dneeded;
                         if not ininfo.diropen then
                         begin  { vol->file}
                           if useunit then
                             mounted := (ioresult=ord(inoerror)) and
                                     (not swap or
                                      not samedevice(funit,ininfo.cfib.funit))
                           else
                           begin  { volname given }
                             if funit>0 then
                               mounted := not samedevice(funit,ininfo.cfib.funit)
                             else mounted := false;
                           end;
                           swap := not mounted and swap;
                         end    { vol->file }
                         else
                         begin  { file->file }
                           if useunit then
                             mounted := (ioresult=ord(inoerror)) and
                                     (not swap or
                                      not samedevice(funit,ininfo.cfib.funit))
                           else mounted := funit>0;

                           if not mounted then
                           begin        { mount then check for swapping }
                             outmount(swap);
                             swap := samedevice(funit,ininfo.cfib.funit);
                           end
                           else swap := false;
                         end;   { file->file }

                         ininfo.mounted := not swap;
                         outmount(swap);

                         opendir(filename2,destname,' DESTINATION',outinfo,dircatentry);
                         if not diropen then escape(0);
                         { BDAT WORT #5 must the funny record exist }
                         if strlen(dircatentry.cinfo)>=4 then
                           outfunny := (str(dircatentry.cinfo,1,4)='LIF ') or
                                       (str(dircatentry.cinfo,1,4)='HFS ');

                         outstate := 3; { need to open the file }
                         cvol := dircatentry.cname;
                       end;     { setup for x->file }

                       compatible(searchname,destname);

                       if getwildcard(destname)='?' then
                       begin
                         if wildcard<>'?' then with ininfo do
                         begin  { no ? in source so prompt now }
                           promptyorn(tprompt+cvol+':'+cfile, answer);
                           if answer='N' then endearly;
                         end;
                         wildcard := '?';
                       end;
                       { check blocked vol to unblocked vol }
                       permission2(ininfo.cfib.funit,funit,answer);
                       if answer<>'Y' then badio(inoerror);
                     end;       { open the directory }

                  2: begin      { write to the file }
                       outmount(swap);
                       write('Writing ....',chr(13));
                       if format then
                       begin    { formated transfer }
                         memtoany(buf,addr(cfib));
                         if lefttoxfer=0 then position := fleof;
                       end
                       else
                       begin    { unformated transfer }
                { BDAT WORT #6 watch out for funny sector }
                         if (feft=bdat) or (feft=bdat_500) then {fix bdat 500 file copy}
                         begin
                           if position=0 then
                           begin        { bdat at first sector }
                             if not infunny and outfunny then
                             begin      { from ? to LIF/HFS }
                               writebdatfunny;  { invent a record }
                               bdatoffset := 256;
                               call(unitable^[funit].tm,addr(cfib),writebytes,
                                        buf^,movesize,position+bdatoffset);
                             end
                             else
                             if infunny and not outfunny then
                             begin      { from LIF/HFS to ? }
                               bdatoffset := -256;      { skip 256 bytes }
                               call(unitable^[funit].tm,addr(cfib),writebytes,
                                   buf^[256],movesize-256,position);
                             end
                             else
                             begin      { directory types are the same maybe }
                               call(unitable^[funit].tm,addr(cfib),writebytes,
                                        buf^,movesize,position);
                               bdatoffset := 0;
                             end;
                           end
                           else { bdat and not at first sector }
                             call(unitable^[funit].tm,addr(cfib),writebytes,
                                      buf^,movesize,position+bdatoffset);
                         end    { end BDAT WORT #6 }
                         else
                         call(unitable^[funit].tm,addr(cfib),writebytes,
                                      buf^,movesize,position);
                         goodio;
                         position := position + movesize;
                       end;
                       done := true;
                       if lefttoxfer=0 then
                       begin      { close the output file }
                         { BDAT WORT #7 adjust eof }
                         if (feft=bdat) or (feft=bdat_500) then {fix bdat 500 file copy}
                           if (bdatoffset=-256) then position := outsize
                                        else position := position + bdatoffset;
                         closeoutfile(position,goodclose);
                         goodio;
                         if ininfo.cvol='' then ininfo.cvol := ininfo.cpvol;
                         if cvol='' then cvol := cpvol;
                         showmove(ininfo.cvol,ininfo.cfile,cvol,cfile);
                         filemoved := true;
                         if diropen then outstate  := 3;
                       end;
                     end;       { write to the file }

                  3: begin      { open the file }
                       makenewname(searchname,destname,nameptr^.element,ftitle);
                       cfile  := ftitle;
                       pathid := path;          { fix the pathid }
                       fkind  := outfkind;             feft := outeft;
                       fpos   := outsize;     fstartaddress := outfstarta;
                       if (format<>doformat) then
                         if (suffix(cfile)<>fkind) and
                            (destname<>'$') and
                            (destname<>'=') and
                            (destname<>'?') then permission(answer)
                                            else answer := 'Y';
                       if answer='Y' then
                       begin
                         outmount(swap);
                         if not outnotthere(answer,true) then endearly
                         else
                         begin    { CONTINUE THE TRANSFER }
                           if format then
                           begin
                             finitb(cfib,dumwindow,-3);
                             fkind := suffix(ftitle); { set destination fkind }
                             feft  := efttable^[fkind];
                           end;
                         { BDAT WORT #8 adjust the file size }
                           if (feft=bdat) or (feft=bdat_500) then {fix bdat 500 file copy}
                           begin
                             if not infunny and outfunny and (fpos>0) then
                                fpos := fpos + 256;
                             if infunny and not outfunny then
                              begin
                                fpos := (ipointer(buf)^)*256+ipointer(addr(buf^,4))^;
                                outsize := fpos;
                              end;
                           end;
                           lockup;
                           if answer='O' then overcreate := overwritefile
                                         else overcreate := createfile;
                           call(unitable^[funit].dam,cfib,funit,overcreate);
                           fileopen := ioresult=ord(inoerror);
                           lockdown;
                           if ioresult=ord(ibadtitle) then
                           begin writeln('Bad filename ',cfile); endearly; end
                           else
                           begin
                             goodio;
                             if (outsize>0) and (outsize>fpeof) then
                             begin      { try to stretch the file }
                               fpos := outsize;
                               call(unitable^[funit].dam,cfib,funit,stretchit);
                               if outsize>fpeof then ioresult := ord(inoroom);
                               goodio;
                             end;
                             fpos :=0;  flastpos := -1; outstate := 2;
                           end;
                         end;
                       end
                       else endearly;
                     end;
                  end; { case outstate }
                until done;
              until filemoved;
            end;
            if nameptr<>nil then nameptr := nameptr^.link;
          until nameptr=nil;
          release(lheap);       heapinuse := false;
          closeall(position);
        recover
        begin
          lockup;
          release(lheap);       heapinuse := false;
          saveioresult  := ioresult;
          saveesc       := escapecode;
          closeall(position);
          ioresult      := saveioresult;
          lockdown;
          printioerrmsg;
          if saveesc<>0 then escape(saveesc);
          setstrlen(instring,0);
        end;
      end;
    end;
end;    { transfer }

(****************************************************************************)
procedure volumes;
label 1;
var
  un    : unitnum;
  col   : shortint;
  row   : shortint;
  base  : integer;
  sym   : string[3];
  done  : boolean;

begin
  done  := false;
  base  := 1;
  repeat
    writeln(clearscr);
    writeln('Volumes on-line:');
    col := 0;
    row := 2;
    for un := base to maxunit do
    with unitable^[un] do
    begin
      call(dam, uvid, un, getvolumename);
      if (ioresult=ord(inoerror)) and (strlen(uvid) > 0) then
      begin
        fgotoxy(output,col,row);
        if uvid = syvid
          then
            sym := ' * '
          else
            if uisblkd
              then
                sym := ' # '
              else
                sym := '   ';
        write(un:3, sym, uvid, ':');
        row := row + 1;
        if row = (screenheight - 4) then
        begin
          row := 2;
          col := col + 26;
          if ((col + 24) > screenwidth) and
             (un < maxunit)    then
          begin
            fgotoxy(output,0,screenheight - 4);
            spacewait;
            base := un + 1;
            goto 1;
          end;
        end;
      end;
    end;
    done := true;
  1:;
  until done;
  if col<>0
    then
      row := screenheight - 4;
  fgotoxy(output,0,row);
  write('Prefix is - ', dkvid, ':');
end;    { volumes }

(****************************************************************************)
procedure fixuserinfo;
var
  lvid          : vid;
  lsegs         : integer;
  lkind         : filekind;
  ltitle        : fid;
begin
  with userinfo^ do
    begin
      if scantitle(symfid,lvid,ltitle,lsegs,lkind)
        then
          { do nothing };
      symsaved  := (ltitle <> 'WORK.TEXT') or not gotsym;

      if scantitle(codefid,lvid,ltitle,lsegs,lkind)
        then
        { do nothing };
      codesaved := (ltitle <> 'WORK.CODE') or not gotcode;
    end;
end;    { fixuserinfo }

(****************************************************************************)
procedure promptforchar(pl      : prompttype;
                    var ch      : char);
begin
  showprompt(pl);
  read(keyboard,ch);
  readcheck;
  if ch=sh_exc
    then
      ch := ' ';
  if ch=' '
    then
      write(clearscr)
    else
      begin
        write(homechar,cteol);
        upcchar(ch);
      end;
end;    { promptforchar }

(****************************************************************************)
procedure read_ushort(var ushort_num : ushort);
var
  i        : integer;
  ti       : ushort;
  instring : string[20];
begin
  readln(instring);  goodio;
  i := changestr(instring,1,-1,' ',''); { squash blanks }
  if instring=sh_exc then badio(inoerror);
  if strlen(instring)>0 then
  try
    begin
      ti  := 0;
      for i:=1 to strlen(instring) do
        if (instring[i]<'0') or (instring[i]>'9') then badio(ibadvalue)
        else ti := ti * 10 + (ord(instring[i]) - ord('0'));
$range on$
      ushort_num := ti;
$range off$
    end;
  recover
    if (escapecode = -4) or (escapecode = -8) then badio(ibadvalue)
                     else escape(escapecode)
  else
    badio(inoerror);
end;    { read_ushort}

(*********************************************************************)

function octalmode(decmode: integer): integer;
{ octalmode converts a decimal number to a 3-digit octal number }

begin
  octalmode := (decmode mod 8) +
               ((decmode div 8) mod 8) * 10 +
               ((decmode div 64) mod 8) *100;
end; {octalmode}

(****************************************************************************)

function destructive ( old_uid : ushort;
                       new_uid : ushort) : boolean;

  const
    confirm = 'Are you SURE you want to proceed? (Y/N) ';

  var
    answer : char;

  begin
    destructive := false;
    if new_uid <> old_uid
      then
        begin
          { ownership is changing issue a major warning }
          writeln;
          writeln ('The OWNERSHIP of the file/directory is changing.');
          writeln ('You will lose the right to change any attributes');
          writeln ('of the file/directory in the future.            ');
          writeln ('You may lose ALL access to the file/directory   ');
          writeln ('depending on the permissions, you have set.     ');
          writeln;

          promptread ( confirm, answer, 'YN', 'N' );
          writeln;
          if answer = 'Y'
            then
              destructive := false
            else
              destructive := true;
        end;

  end ;    { function destructive }


procedure hfs_access;

{
  The error conditions that this routine expects and can handle
  gracefully are :
    inofile : file does not exist
    ifilenotdir : when a path component is not a directory
    inopermission : when access permissions fail on the path or file

  All other errors are unexpected and can not be gracefully handled.
}

const
  max_uid  = 65535;
  max_gid  = 65535;
  max_mode = 511;

var
  filename      : fid;
  count         : integer;
  lines         : integer;
  option        : char;
  answer        : char;
  wildcard      : char;
  done          : boolean;
  quit          : boolean;
  uid           : ushort;
  gid           : ushort;
  mode          : string[5];
  imode         : ushort;
  info          : h_setpasswd_entry;
  open_info     : h_setpasswd_entry;
  cat_info      : h_catpasswd_ids;
  nameptr       : tidelementptr;
  dircatentry   : catentry;
  searchname    : fid;
  segs          : integer;
  old_uid       : ushort;
  old_gid       : ushort;
  old_per       : ushort;
  new_uid       : ushort;
  new_gid       : ushort;
  new_per       : ushort;
  cmd           : string[6];
  save_pathid   : integer;
  change_root   : boolean;

procedure do_umask;

begin
  writeln (clearscr);
  showprompt ('For which unit ? ');
  readln (filename);
  zapspaces(filename);
  if strlen(filename) = 0
    then
      begin
        release(lheap);
        heapinuse := false;
        escape(0);
      end;

  write ('Enter new umask number ');
  readln (mode);
  goodio;

  if mode <> '' then
    begin
      try
        imode := utloctal (mode);
        if (imode > max_mode) then
          escape (-8);
      recover
        begin
          if (escapecode = -4) or (escapecode = -8)
            then
              begin
                badmessage ('New umask not in range 0 - 0777 octal');
              end;
        end;
      info.new_value := imode;
      info.command := hfs_umask;
      cmd := 'umask ';

      {doing the action}
       with ininfo, cfib do
         begin
           setupfibforfile(filename,cfib,cpvol);
           fwindow := addr(info);
           fpos := 0;
           fpeof := 1;
           if unit_is_hfs(funit) then
             begin
                {check if volume name}
                if ftitle <> '' then
                  badio(ibadrequest);
                call(unitable^[funit].dam, cfib, funit, setpasswords);
                goodio;
             end
               else
                 badio(ibadrequest);
         end;
    end
  else
    {no mode given indicates to show the umask of filename}
    with ininfo, cfib do
      begin
        setupfibforfile(filename,cfib,cpvol);
        fwindow := addr(cat_info);
        fpos := 0;
        fpeof := 1;
        if unit_is_hfs(funit) then
          begin
            {check if volume name}
            if ftitle <> '' then
              badio(ibadrequest);
            call(unitable^[funit].dam, cfib,funit, catpasswords);
            goodio;
            writeln('Umask is ', octalmode(cat_info.cat_umask):3);
          end
        else
          badio(ibadrequest);
      end;
end; {do_umask}

begin
  writeln (clearscr);
  repeat
    try

      { part 1 : get user inputs before doing any work }

      {showprompt ('HFS Access: Owner, Group, Mode, Umask, Quit ');
      read (keyboard,option);
      readcheck;
      upcchar (option);
      writeln;}

      promptforchar ('HFS Access: Owner, Group, Mode, Umask, Quit ', option);

      if option in ['G', 'M', 'O'] then
        begin
          writeln (clearscr);
          showprompt ('For which file ? ');
          readln (filename);
          goodio;
          zapspaces(filename);
          if strlen(filename) = 0 then
            badio(inoerror);
        end;

      mark (lheap);
      heapinuse := TRUE;
      open_info.new_value := 0;
      open_info.command := hfs_open;

      case option of

        'O' : begin
                write ('Enter new owner number ');

                read_ushort(uid);

                info.new_value := uid;
                info.command := hfs_chown;
                cmd := ' owner';
              end;

        'G' : begin
                write ('Enter new group number ');

                read_ushort(gid);

                info.new_value := gid;
                info.command := hfs_chgrp;
                cmd := ' group';
              end;

        'M' : begin
                write ('Enter new mode ');
                readln (mode);
                goodio;
                if mode = '' then
                  badio(inoerror);

                try
                  imode := utloctal (mode);
                  if (imode > max_mode) then
                    escape(-8);
                recover
                  begin
                    if (escapecode = -4) or (escapecode = -8)
                      then
                        begin
                          badmessage ('New mode not in range 0 - 0777 octal');
                        end;
                  end;

                info.new_value := imode;
                info.command := hfs_chmod;
                cmd := ' mode';
              end;

        'U' : begin
                do_umask;
                badio(inoerror);
              end;

        'Q' : begin
                badio(inoerror);
              end;

        otherwise begin
                    if option <> ' ' then
                      if streaming then
                        badcommand (option);
                    badio(inoerror);
                  end;

      end ;  { option case }


      { part 2 : set up the filename(s) now that the info is in }
        with ininfo, cfib do
          begin
            change_root := false;
            diropen := false;

            { working on a file not a unit }
            opendir (filename, searchname, '', ininfo, dircatentry);
            if not diropen
              then
                escape(0);
            if str ( dircatentry.cinfo, 1, 4 ) <> 'HFS '
              then
                begin
                  badio(ibadrequest);
                end;
            if strlen (searchname) = 0
              then
                { filename is a directory }
                begin
                  save_pathid := pathid;
                  {try open parent directory}
                  opendir(filename,searchname,'',ininfo,dircatentry);
                  if not ininfo.diropen then escape(0);
                  if save_pathid = pathid then
                    { try to change the id of '/' }
                    change_root := true;
                end;
            save_pathid := pathid;
            ininfo.cvol := dircatentry.cname;
            wildcard := getwildcard (searchname);
            if change_root then
              begin
                new(nameptr);
                nameptr^.element := '';
                nameptr^.link    := NIL;
              end
            else
              begin
                makenamelist (cfib, searchname, nameptr, false, false, true, segs);
                goodio;
                if nameptr = NIL
                  then
                    badmessage('No files changed');
              end;
            cfile := '';
          end;  { with ininfo, cfib }

      { Part 3: loop over the non-empty filename list doing the action }

              {
                Notes: fpeof is the number of items in the list pointed
                to by fwindow. fpos is always zero for the *password dam calls.
              }

        answer := 'N';
        if wildcard <> ' '
          then
            begin
              writeln(clearscr);
              editnamelist (nameptr,'Change'+cmd+' on ', wildcard);
              if nameptr <> nil
                then
                  promptyorn ('Proceed with change of'+cmd, answer);
            end
          else
            answer := 'Y';

        if answer = 'Y'
          then
            begin
              if option = 'O'
                then
                  if ( destructive ( paws_uid, uid ))
                    then
                      begin
                        ioresult := ord (inoerror);
                        escape (0);
                      end ;
              while ( nameptr <> NIL) do
                begin
                  { use setpassword open call to set up the fib }

                  with ininfo, cfib, unitable^[funit] do
                    begin
                      pathid := save_pathid;
                      ftitle := nameptr^.element;
                      fwindow := addr(open_info);
                      fpos := 0;
                      fpeof := 1;
                      call (dam, cfib, funit, setpasswords);
                      goodio;

                    { now make the change for the file }

                      fwindow := addr(info);
                      fpos := 0;
                      fpeof := 1;
                      call (dam, cfib, funit, setpasswords);
                      goodio;
                      writeln (cvol+':'+nameptr^.element+cmd + ' changed');
                      nameptr := nameptr^.link
                    end ; { with }
                end; {while}
            end {answer = 'Y'}
          else
            writeln('No files changed');

      release (lheap);
      heapinuse := false;
      closedir (ininfo);

    recover
      begin
        release(lheap);
        heapinuse := false;
        printioerrmsg;
        if escapecode<>0
          then
              escape(escapecode);
      end;
  until option = 'Q';
end;    {hfs_access}


(****************************************************************************)
begin {commandlevel}

  if kbdtype = itfkbd then                        { 3.0 ITF fix 4/6/84 }
     esckey:='esc'                                { 3.0 ITF fix 4/6/84 }
  else                                            { 3.0 ITF fix 4/6/84 }
     esckey:='sh_exc';                            { 3.0 ITF fix 4/6/84 }

  fixuserinfo;  fixlock;
  with ininfo do
    begin diropen := false;  fileopen := false; end;
  with outinfo do
    begin diropen := false;  fileopen := false; end;
  heapinuse := false;  ioresult := ord(inoerror);
  ordefault := 'R';     { overwrite/replace default }
  with syscom^.crtinfo do
    begin screenwidth:=width; screenheight:=height; end;
 repeat
    try
      check;

      if screenwidth<80 then promptforchar(sprompt1,ch)
                        else promptforchar(lprompt1,ch);

      if ch = '?' then
      begin
        if screenwidth<80 then promptforchar(sprompt2+filerid+']',ch)
                          else promptforchar(lprompt2+filerid+']',ch);
      end;
      writeln;
      case ch of
        'A': access;
        'B': bad;
        'C': change;            { change name }
        'D': duplicate;         { duplicate link }
        'E': listdir(true);
        'F': transfer(false);   { file copy }
        'G': getwork;
        'H': hfs_access;
        'K': krunch;
        'L': listdir(false);
        'M': make;              { make file/directory }
        'N': newwork(true,ch);
        'P': prefix(true);      { default directory }
        'Q': ;
        'R': remove;
        'S': savework;
        'U': prefix(false);     { unit directory }
        'V': volumes;
        'W': whatwork;
        'T': transfer(true);    { translate }
        'Z': zero(false);       { zero a directory }
        otherwise
          if (ch<>' ') and (ch<>'?') then
            if streaming then badcommand(ch);
      end;      { case }
      fixlock;
    recover
    begin
      lockup;
      if heapinuse then release(lheap);
      heapinuse    := false;
      saveio       := ioresult;
      saveesc      := escapecode;
      closeinfile;
      closeoutfile(0,outinfo.badclose);
      closedir(ininfo);
      closedir(outinfo);
      ioresult     :=saveio;
      if (saveesc<>0) and (saveesc<>-10) then ioresult := ord(inoerror);
      lockdown;
      printioerrmsg;
      fixlock;
      if saveesc<>0 then escape(saveesc) else ch := ' ';
    end;
  until ch = 'Q';
end {commandlevel} ;

(****************************************************************************)
begin
  writeln(clearscr);
  writeln;
  writeln;
  writeln;
  writeln;
  writeln('Copyright Hewlett-Packard Company, 1982,1989');
  writeln('          All rights are reserved.');
  writeln;
  writeln;
  commandlevel;
end.



