$copyright 'COPYRIGHT (C) 1985,1991 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 }

(****************************************************************************)
{ Now in MISC - no reason to declare it at all }
{ As of version 50.2 we don't use it at all }
{ It's been replaced by unit_is_srmux - JWH 11/12/90 }
{ 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.25';
  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;
(****************************************************************************)
{ Added 11/12/90 JWH : }
function unit_is_srmux(un : unitnum):boolean; {quick check, SRM/UX ? JWH }
{ The SRMDAM has been modified to return ibadvalue for a setvolumename
  request if the unit is SRM/UX (instead of ibadrequest, which is what
  the SRMDAM used to return, and still does,  for SRM units.          }
var f : fib;
begin
 unit_is_srmux := FALSE;
 with unitable^[un] do
  begin
   if letter = 'G' then { srm or srm/ux }
    begin
     call(dam,f,un,setvolumename);
     if ioresult = ord(ibadvalue) then
      unit_is_srmux := TRUE; { otherwise SRM }
    end;
  end;
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;
			unum : integer);
begin
  with dircatentry do
  begin
    write(listfile,cname,':','':17-strlen(cname));
    writeln(listfile,' Directory type= ',cinfo);
    if not unit_is_srmux(unum) then
     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) or (unit_is_srmux(unum))) 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
    if not unit_is_srmux(unum) then
    begin
      writeln(listfile,'  start blk ....last change... extension1');
      write(listfile,' ':17,'type  t-code ..directory info...');
      writeln(listfile,' ....create date... extension2');
    end
    else
     begin
      writeln(listfile,'  start blk ....last change... extension1');


      write(listfile,' ':17,'type  t-code ...directory info...');
      writeln(listfile,'  ...create date.. extension2');
     end;
     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;
		       unum            : 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);

      if  unit_is_srmux(unum) then
	write(listfile,'   ');

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

      if  unit_is_srmux(unum) then
	writeln(listfile,cextra1:8)
      else
	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);
      if not unit_is_srmux(unum) then
	write(listfile,' ',cinfo,'':19-strlen(cinfo))
      else
	write(listfile,' ',cinfo,'':22-strlen(cinfo));
      if not unit_is_srmux(unum) then
       begin
	if ccreatedate.year>0 then
	begin
	  writedate(listfile,ccreatedate);
	  writetime(listfile,ccreatetime);
	end   { good create date }
	else write(listfile,' ':19);
      end
	else write(listfile,' ':19); { SRM-UX - no create date available }
      if not unit_is_srmux(unum) then
	write(listfile,cextra2:11)
      else
	write(listfile,cextra2:8);
      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               : integer;
begin
  prev  := nil; count := 0;
  with f, unitable^[funit] do
  begin
    fwindow := addr(passentries);
    fpos    := 0;       fpeof   := catlimit;
    passptr := nil;
    repeat
      call(dam,f,funit,catpasswords);
      goodio;
      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 }
    { OR an SRM-UX unit - JWH 6/25/90 }

    if (unit_is_hfs(funit) or unit_is_srmux(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;
      makepasslist(cfib,passptr,count);
      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);

	  showcatheader(extlist,order,dircatentry,dispfile^,count,funit);
	  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,funit);
	    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,funit);
	      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,funit);
	    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;

{ Note - we don't maintain a umask value for SRM-UX units. }
{ This is for true hfs units only }

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);
	    { Changed for SRM-UX : }
	    if ((str ( dircatentry.cinfo, 1, 4 ) <> 'HFS ' ) and
	       ( str ( dircatentry.cinfo, 1, 6 ) <> 'SRM/UX' ))
	      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
		    if not unit_is_srmux(funit) then
		     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  { not SRM-UX unit }
		  else
		    begin { Try to do it with one call }
			pathid := save_pathid;
			ftitle := nameptr^.element;
			fpos := 0;
			fpeof := 1;
			fwindow := addr(info);
			 { writeln('from the FILER, the info fields contain : ');
			writeln('command : ',info.command);
			writeln('new value : ',info.new_value); }
			call (dam, cfib, funit, setpasswords);
			goodio;
			writeln (cvol+':'+nameptr^.element+cmd + ' changed');
			nameptr := nameptr^.link;
		    end;
		 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,1991');
  writeln('          All rights are reserved.');
  writeln;
  writeln;
  commandlevel;
end.



