head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.22.22;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.02.32;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.57.51;  author jwh;  state Exp;
branches ;
next     55.2;

55.2
date     91.11.04.14.24.02;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.33.02;  author jwh;  state Exp;
branches ;
next     54.3;

54.3
date     91.08.21.12.39.36;  author jwh;  state Exp;
branches ;
next     54.2;

54.2
date     91.08.21.09.51.42;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.33.46;  author jwh;  state Exp;
branches ;
next     53.3;

53.3
date     91.03.18.13.32.31;  author jwh;  state Exp;
branches ;
next     53.2;

53.2
date     91.03.15.16.15.02;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.33.39;  author jwh;  state Exp;
branches ;
next     52.2;

52.2
date     91.03.11.16.53.38;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.19.48;  author jwh;  state Exp;
branches ;
next     51.3;

51.3
date     91.02.18.20.51.05;  author jwh;  state Exp;
branches ;
next     51.2;

51.2
date     91.02.08.15.38.56;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.18.14;  author jwh;  state Exp;
branches ;
next     50.5;

50.5
date     91.01.30.09.22.36;  author jwh;  state Exp;
branches ;
next     50.4;

50.4
date     91.01.14.11.25.11;  author jwh;  state Exp;
branches ;
next     50.3;

50.3
date     90.11.28.15.48.39;  author jwh;  state Exp;
branches ;
next     50.2;

50.2
date     90.11.12.15.51.13;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.32.11;  author jwh;  state Exp;
branches ;
next     49.3;

49.3
date     90.10.29.14.14.20;  author jwh;  state Exp;
branches ;
next     49.2;

49.2
date     90.10.24.15.00.05;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.15.56;  author jwh;  state Exp;
branches ;
next     48.4;

48.4
date     90.08.14.09.40.59;  author jwh;  state Exp;
branches ;
next     48.3;

48.3
date     90.08.10.13.50.50;  author jwh;  state Exp;
branches ;
next     48.2;

48.2
date     90.08.10.13.46.04;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.22.27;  author jwh;  state Exp;
branches ;
next     47.6;

47.6
date     90.07.24.14.59.24;  author jwh;  state Exp;
branches ;
next     47.5;

47.5
date     90.07.19.16.11.24;  author jwh;  state Exp;
branches ;
next     47.4;

47.4
date     90.07.10.14.20.26;  author jwh;  state Exp;
branches ;
next     47.3;

47.3
date     90.07.10.14.03.30;  author jwh;  state Exp;
branches ;
next     47.2;

47.2
date     90.07.10.13.44.32;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.11.08.04;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.54.53;  author jwh;  state Exp;
branches ;
next     45.2;

45.2
date     90.05.04.14.56.16;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.16.02.51;  author jwh;  state Exp;
branches ;
next     44.2;

44.2
date     90.04.19.13.25.24;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.20.08;  author jwh;  state Exp;
branches ;
next     43.3;

43.3
date     90.04.01.16.25.22;  author jwh;  state Exp;
branches ;
next     43.2;

43.2
date     90.03.22.11.36.31;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.14.12.56;  author jwh;  state Exp;
branches ;
next     42.2;

42.2
date     90.03.19.16.13.13;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.56.58;  author jwh;  state Exp;
branches ;
next     41.2;

41.2
date     90.01.20.16.44.56;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.39.03;  author jwh;  state Exp;
branches ;
next     40.2;

40.2
date     89.12.21.15.07.54;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.12.00.06;  author jwh;  state Exp;
branches ;
next     39.2;

39.2
date     89.09.28.17.29.05;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.44.57;  author dew;  state Exp;
branches ;
next     38.2;

38.2
date     89.09.26.14.44.58;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.37.15;  author jwh;  state Exp;
branches ;
next     37.2;

37.2
date     89.08.28.12.28.10;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.50.51;  author dew;  state Exp;
branches ;
next     36.2;

36.2
date     89.05.11.11.49.06;  author quist;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.28.17;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.44.34;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.16.19.27;  author jwh;  state Exp;
branches ;
next     33.2;

33.2
date     89.01.20.16.31.23;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.50.31;  author dew;  state Exp;
branches ;
next     32.3;

32.3
date     89.01.13.11.32.27;  author dew;  state Exp;
branches ;
next     32.2;

32.2
date     89.01.11.10.10.01;  author jws;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.12.00.20;  author bayes;  state Exp;
branches ;
next     31.3;

31.3
date     89.01.09.12.05.36;  author dew;  state Exp;
branches ;
next     31.2;

31.2
date     88.12.23.10.50.11;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.18.21.08;  author bayes;  state Exp;
branches ;
next     30.2;

30.2
date     88.12.14.13.38.26;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.57.57;  author dew;  state Exp;
branches ;
next     29.3;

29.3
date     88.12.08.15.46.55;  author bayes;  state Exp;
branches ;
next     29.2;

29.2
date     88.11.28.15.14.38;  author bayes;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.42.38;  author bayes;  state Exp;
branches ;
next     28.2;

28.2
date     88.10.31.10.48.49;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.11.08.30;  author dew;  state Exp;
branches ;
next     27.2;

27.2
date     88.10.05.17.48.13;  author bayes;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.51.53;  author bayes;  state Exp;
branches ;
next     26.7;

26.7
date     88.09.28.14.02.43;  author bayes;  state Exp;
branches ;
next     26.6;

26.6
date     88.09.28.14.02.02;  author bayes;  state Exp;
branches ;
next     26.5;

26.5
date     88.09.28.14.01.18;  author bayes;  state Exp;
branches ;
next     26.4;

26.4
date     88.09.28.14.00.36;  author bayes;  state Exp;
branches ;
next     26.3;

26.3
date     88.09.28.13.59.54;  author bayes;  state Exp;
branches ;
next     26.2;

26.2
date     88.09.28.13.59.23;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.13.58.35;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.10.20.05;  author jws;  state Exp;
branches ;
next     23.3;

23.3
date     87.08.30.16.31.08;  author jws;  state Exp;
branches ;
next     23.2;

23.2
date     87.08.28.12.48.35;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.11.06.47;  author bayes;  state Exp;
branches ;
next     22.2;

22.2
date     87.08.25.20.17.39;  author jws;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.11.46.02;  author bayes;  state Exp;
branches ;
next     21.2;

21.2
date     87.08.15.18.18.59;  author larry;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.14.30.29;  author bayes;  state Exp;
branches ;
next     20.2;

20.2
date     87.08.12.11.53.53;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.11.41.58;  author bayes;  state Exp;
branches ;
next     19.2;

19.2
date     87.07.29.19.28.32;  author larry;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.08.55.53;  author jws;  state Exp;
branches ;
next     18.4;

18.4
date     87.05.31.16.12.21;  author jws;  state Exp;
branches ;
next     18.3;

18.3
date     87.05.29.14.32.51;  author bayes;  state Exp;
branches ;
next     18.2;

18.2
date     87.05.26.09.50.50;  author bayes;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.16.00.45;  author bayes;  state Exp;
branches ;
next     17.2;

17.2
date     87.05.20.12.04.30;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.11.04.28;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.16.14.30;  author jws;  state Exp;
branches ;
next     15.3;

15.3
date     87.04.24.19.23.56;  author jws;  state Exp;
branches ;
next     15.2;

15.2
date     87.04.16.11.33.35;  author bayes;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.09.56.18;  author jws;  state Exp;
branches ;
next     14.4;

14.4
date     87.04.12.18.38.51;  author jws;  state Exp;
branches ;
next     14.3;

14.3
date     87.04.08.09.22.33;  author jws;  state Exp;
branches ;
next     14.2;

14.2
date     87.04.02.15.31.54;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.16.07.15;  author jws;  state Exp;
branches ;
next     13.3;

13.3
date     87.04.01.11.28.22;  author jws;  state Exp;
branches ;
next     13.2;

13.2
date     87.03.24.09.18.01;  author bayes;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.57.20;  author jws;  state Exp;
branches ;
next     12.2;

12.2
date     87.02.28.16.59.20;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.13.51.25;  author jws;  state Exp;
branches ;
next     11.3;

11.3
date     87.02.02.11.35.09;  author jws;  state Exp;
branches ;
next     11.2;

11.2
date     87.01.22.13.17.35;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.10.17.47;  author jws;  state Exp;
branches ;
next     10.4;

10.4
date     87.01.18.20.15.07;  author jws;  state Exp;
branches ;
next     10.3;

10.3
date     87.01.16.09.43.08;  author jws;  state Exp;
branches ;
next     10.2;

10.2
date     87.01.15.22.48.31;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.11.33.14;  author jws;  state Exp;
branches ;
next     9.2;

9.2
date     86.12.23.18.20.27;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.15.17.57;  author bayes;  state Exp;
branches ;
next     8.3;

8.3
date     86.12.12.12.03.15;  author bayes;  state Exp;
branches ;
next     8.2;

8.2
date     86.12.09.10.45.27;  author jws;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.12.26.12;  author jws;  state Exp;
branches ;
next     7.4;

7.4
date     86.11.26.18.36.16;  author jws;  state Exp;
branches ;
next     7.3;

7.3
date     86.11.24.16.38.49;  author geli;  state Exp;
branches ;
next     7.2;

7.2
date     86.11.24.11.14.28;  author geli;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.14.41.35;  author hal;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.18.31.32;  author paws;  state Exp;
branches ;
next     5.3;

5.3
date     86.10.31.15.21.10;  author danm;  state Exp;
branches ;
next     5.2;

5.2
date     86.10.31.14.43.27;  author danm;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.17.21.24;  author hal;  state Exp;
branches ;
next     4.3;

4.3
date     86.10.28.12.55.45;  author hal;  state Exp;
branches ;
next     4.2;

4.2
date     86.10.21.13.29.17;  author danm;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.20.15.17;  author hal;  state Exp;
branches ;
next     3.3;

3.3
date     86.09.30.16.28.58;  author hal;  state Exp;
branches ;
next     3.2;

3.2
date     86.09.25.09.00.02;  author danm;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.12.26.21;  author hal;  state Exp;
branches ;
next     2.6;

2.6
date     86.08.21.15.58.38;  author danm;  state Exp;
branches ;
next     2.5;

2.5
date     86.08.19.15.40.48;  author danm;  state Exp;
branches ;
next     2.4;

2.4
date     86.08.19.14.19.35;  author danm;  state Exp;
branches ;
next     2.3;

2.3
date     86.08.14.16.00.29;  author danm;  state Exp;
branches ;
next     2.2;

2.2
date     86.08.13.08.40.25;  author geli;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.15.15.21;  author hal;  state Exp;
branches ;
next     1.11;

1.11
date     86.07.29.12.33.21;  author geli;  state Exp;
branches ;
next     1.10;

1.10
date     86.07.28.18.03.28;  author hal;  state Exp;
branches ;
next     1.9;

1.9
date     86.07.21.07.38.23;  author geli;  state Exp;
branches ;
next     1.8;

1.8
date     86.07.17.17.52.54;  author hal;  state Exp;
branches ;
next     1.7;

1.7
date     86.07.15.18.22.37;  author geli;  state Exp;
branches ;
next     1.6;

1.6
date     86.07.14.09.33.45;  author hal;  state Exp;
branches ;
next     1.5;

1.5
date     86.07.11.10.49.49;  author danm;  state Exp;
branches ;
next     1.4;

1.4
date     86.07.01.11.09.36;  author danm;  state Exp;
branches ;
next     1.3;

1.3
date     86.06.12.16.15.19;  author danm;  state Exp;
branches ;
next     1.2;

1.2
date     86.06.09.09.51.23;  author danm;  state Exp;
branches ;
next     1.1;

1.1
date     86.04.11.18.25.47;  author paws;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@$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.



@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 4109
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 4109
$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.



@


55.2
log
@
pws2rcs automatic delta on Mon Nov  4 13:45:04 MST 1991
@
text
@@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@d44 1
a44 1
  filerid  = '3.25A';
@


54.3
log
@
pws2rcs automatic delta on Wed Aug 21 12:27:56 MDT 1991
@
text
@@


54.2
log
@
pws2rcs automatic delta on Wed Aug 21 09:35:48 MDT 1991
@
text
@d1 4109
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@a0 4109
$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.24';
  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.



@


53.3
log
@
pws2rcs automatic delta on Mon Mar 18 13:19:08 MST 1991
@
text
@@


53.2
log
@Updated copyright messages.
@
text
@d44 1
a44 1
  filerid  = '3.24B';
@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@d1 1
a1 1
$copyright 'COPYRIGHT (C) 1985,1989 BY HEWLETT-PACKARD CO.'$
d4101 1
a4101 1
  writeln('Copyright Hewlett-Packard Company, 1982,1990');
@


52.2
log
@
pws2rcs automatic delta on Mon Mar 11 16:41:32 MST 1991
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@d44 1
a44 1
  filerid  = '3.24A';
@


51.3
log
@
pws2rcs automatic delta on Mon Feb 18 20:38:36 MST 1991
@
text
@@


51.2
log
@Changed the routine is_srmux_unit slightly to fix a bug. JWH 2/8/91.
@
text
@d44 1
a44 1
  filerid  = '3.24d';
@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@d232 1
a232 1
var f : fibp;
a233 1
 f := NIL;
d239 1
a239 1
     call(dam,f^,un,setvolumename);
@


50.5
log
@
pws2rcs automatic delta on Wed Jan 30 09:08:19 MST 1991
@
text
@@


50.4
log
@Changed a line of code to look for 'SRM/UX' not 'SRM-UX' as that is what
is now displayed in the catalog header.
@
text
@d44 1
a44 1
  filerid  = '3.24c';
@


50.3
log
@Very slight change to the showcatheader routine for SRM/UX volumes.
Makes it look nicer with 50-char display.
@
text
@d3885 1
a3885 1
	       ( str ( dircatentry.cinfo, 1, 6 ) <> 'SRM-UX' ))
@


50.2
log
@Added function unit_is_srmux and changed references to is_srmux_unit
to reference unit_is_srmux instead. JWH.
@
text
@d601 4
a604 2
      write(listfile,' ':17,'type  t-code ...directory info.....');
      writeln(listfile,' ..create date.. extension2');
@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@d31 2
d227 20
d567 1
a567 1
    if not is_srmux_unit(unum) then
d580 1
a580 1
    if ((ccreatedate.year <= 0) or (is_srmux_unit(unum))) then
d592 1
a592 1
    if not is_srmux_unit(unum) then
d642 1
a642 1
      if  is_srmux_unit(unum) then
d648 1
a648 1
      if  is_srmux_unit(unum) then
d669 1
a669 1
      if not is_srmux_unit(unum) then
d673 1
a673 1
      if not is_srmux_unit(unum) then
d683 1
a683 1
      if not is_srmux_unit(unum) then
d1811 1
a1811 1
    if (unit_is_hfs(funit) or is_srmux_unit(funit)) then
d3957 1
a3957 1
		    if not is_srmux_unit(funit) then
@


49.3
log
@
pws2rcs automatic delta on Mon Oct 29 14:00:44 MST 1990
@
text
@@


49.2
log
@Fixed a bug in routine makepasslist I accidently introduced
before ... JWH 10/24/90.
@
text
@d42 1
a42 1
  filerid  = '3.24b';
@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@d1624 2
a1625 4
  i,save_result   : integer;
  fake_fib : fib;
  begin
  fake_fib := f;
d1633 2
a1634 5
      call(dam,fake_fib,funit,catpasswords);
       try
	 goodio;
	 recover
	   escape(escapecode);
a1649 1

@


48.4
log
@
pws2rcs automatic delta on Tue Aug 14 09:29:26 MDT 1990
@
text
@@


48.3
log
@Changed srm_is_srmux_unit to is_srmux_unit, no module name prepend is
necessary now as this function is imported from MISC.
@
text
@d42 1
a42 1
  filerid  = '3.24a';
@


48.2
log
@Commented out an SRM-UX declaration.
@
text
@d545 1
a545 1
    if not srm_is_srmux_unit(unum) then
d558 1
a558 1
    if ((ccreatedate.year <= 0) or (srm_is_srmux_unit(unum))) then
d570 1
a570 1
    if not srm_is_srmux_unit(unum) then
d620 1
a620 1
      if  srm_is_srmux_unit(unum) then
d626 1
a626 1
      if  srm_is_srmux_unit(unum) then
d647 1
a647 1
      if not srm_is_srmux_unit(unum) then
d651 1
a651 1
      if not srm_is_srmux_unit(unum) then
d661 1
a661 1
      if not srm_is_srmux_unit(unum) then
d1795 1
a1795 1
    if (unit_is_hfs(funit) or srm_is_srmux_unit(funit)) then
d3941 1
a3941 1
		    if not srm_is_srmux_unit(funit) then
@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@d30 2
a31 1
function srm_is_srmux_unit(unum : unitnum) : boolean; external;
@


47.6
log
@
pws2rcs automatic delta on Tue Jul 24 14:47:20 MDT 1990
@
text
@@


47.5
log
@messing with create dates for SRM-UX.
@
text
@d41 1
a41 1
  filerid  = '3.23';
@


47.4
log
@Cleanup.
@
text
@d544 8
a551 1
    if ccreatedate.year > 0 then
a552 6
      write(listfile,'created');
      writedate(listfile,ccreatedate); writetime(listfile,ccreatetime);
      writeln(listfile,' block size=',cblocksize:1);
    end;
    if clastdate.year>0 then
    begin
d557 1
a557 1
    if ccreatedate.year <= 0 then
d650 2
d658 2
@


47.3
log
@Cleanup.
@
text
@d41 1
a41 1
  filerid  = '3.23c';
d4078 1
a4078 1
  writeln('Copyright Hewlett-Packard Company, 1982,1989');
@


47.2
log
@Changed to allow hfs command with SRM-UX units.
@
text
@a1632 5
	 begin
	   save_result := ioresult;
	   writeln('goodio caught it ');
	   writeln('ioresult : ',save_result);
	   ioresult := save_result;
a1633 1
	 end;
a1796 1
      { writeln('making pass'); for i := 1 to 1000000 do ; }
a1797 1
      { writeln('made pass'); for i := 1 to 1000000 do ; }
a2632 12

	  { if srm_is_srmux_unit(funit) then
	   begin
	     with dircatentry do
	      begin
	       for my_count := 20 downto 7 do
		 cinfo[my_count] := cinfo[my_count-3];
	       cinfo[1] := 'S'; cinfo[2] := 'R'; cinfo[3] := 'M';
	       cinfo[4] := '-'; cinfo[5] := 'U'; cinfo[6] := 'X';
	      end;
	      setstrlen(dircatentry.cinfo,strlen(dircatentry.cinfo)+3);
	   end; }
@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@d1 1
a1 1
$copyright 'COPYRIGHT (C) 1985,1990 BY HEWLETT-PACKARD CO.'$
d30 2
d41 1
a41 1
  filerid  = '3.23';
d537 2
a538 1
			var count       : integer);
d568 13
a580 4
    writeln(listfile,'  start blk ....last change... extension1');
    write(listfile,' ':17,'type  t-code ..directory info...');
    writeln(listfile,' ....create date... extension2');
    count := count + 2 * (79 DIV SCREENWIDTH + 1);
d595 2
a596 1
		       var count       : integer);
d614 3
a616 3
      if cstart>=0 then
	write(listfile,' ',bytestoblocks(cstart,cblocksize):10)
      else write(listfile,' ':11);
d618 3
d624 5
a628 1
      writeln(listfile,cextra1:11);
d645 4
a648 1
      write(listfile,' ',cinfo,'':19-strlen(cinfo));
d655 4
a658 1
      write(listfile,cextra2:11);
d1618 4
a1621 2
  i               : integer;
begin
d1629 11
a1639 2
      call(dam,f,funit,catpasswords);
      goodio;
d1780 1
d1793 3
a1795 1
    if unit_is_hfs(funit) then
d1803 1
d1805 1
d2569 1
d2641 14
a2654 1
	  showcatheader(extlist,order,dircatentry,dispfile^,count);
d2676 1
a2676 1
	      showcatentry(extlist,catentryptr^,dispfile^,count);
d2683 1
a2683 1
		showcatheader(extlist,order,dircatentry,dispfile^,count);
d2695 1
a2695 1
	      showcatheader(extlist,order,dircatentry,dispfile^,count);
d3692 3
d3879 3
a3881 1
	    if str ( dircatentry.cinfo, 1, 4 ) <> 'HFS '
d3955 2
d3974 17
a3990 1
		    end ; { with }
d4098 1
a4098 1
  writeln('Copyright Hewlett-Packard Company, 1982,1990');
@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.2
log
@
pws2rcs automatic delta on Fri May  4 14:44:01 MDT 1990
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@d39 1
a39 1
  filerid  = '3.23C';
@


44.2
log
@
pws2rcs automatic delta on Thu Apr 19 13:13:04 MDT 1990
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@d39 1
a39 1
  filerid  = '3.23B';
@


43.3
log
@
pws2rcs automatic delta on Sun Apr  1 16:13:30 MDT 1990
@
text
@@


43.2
log
@Fixed copyright date.
@
text
@d39 1
a39 1
  filerid  = '3.23A';
@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@d1 1
a1 1
$copyright 'COPYRIGHT (C) 1985,1989 BY HEWLETT-PACKARD CO.'$
d4019 1
a4019 1
  writeln('Copyright Hewlett-Packard Company, 1982,1989');
@


42.2
log
@
pws2rcs automatic delta on Mon Mar 19 16:00:53 MST 1990
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@d39 1
a39 1
  filerid  = '3.23e';
@


41.2
log
@
pws2rcs automatic delta on Sat Jan 20 16:32:46 MST 1990
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@d39 1
a39 1
  filerid  = '3.23d';
@


40.2
log
@
pws2rcs automatic delta on Thu Dec 21 14:54:59 MST 1989
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@d39 1
a39 1
  filerid  = '3.23c';
@


39.2
log
@
pws2rcs automatic delta on Thu Sep 28 17:16:32 MDT 1989
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@d39 1
a39 1
  filerid  = '3.23b';
@


38.2
log
@
pws2rcs automatic delta on Tue Sep 26 14:31:31 MDT 1989
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@d39 1
a39 1
  filerid  = '3.23a';
@


37.2
log
@
pws2rcs automatic delta on Mon Aug 28 12:16:08 MDT 1989
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@d39 1
a39 1
  filerid  = '3.3a';
@


36.2
log
@
pws2rcs automatic delta on Thu May 11 11:32:36 MDT 1989
@
text
@@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@d39 1
a39 1
  filerid  = '3.22';
@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.2
log
@
pws2rcs automatic delta on Fri Jan 20 16:16:31 MST 1989
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@d39 1
a39 1
  filerid  = '3.22D';
@


32.3
log
@
pws2rcs automatic delta on Fri Jan 13 11:19:22 MST 1989
@
text
@@


32.2
log
@Fix copyright dates

@
text
@d39 1
a39 1
  filerid  = '3.22C';
@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@d1 1
a1 1
$copyright 'COPYRIGHT (C) 1985 BY HEWLETT-PACKARD COMPANY'$
d4019 1
a4019 1
  writeln('Copyright Hewlett-Packard Company, 1982,1987');
@


31.3
log
@
pws2rcs automatic delta on Mon Jan  9 11:50:34 MST 1989
@
text
@@


31.2
log
@Modified Bad-block scan output formatting. Increased field widths to
9 chars to handle bigger disks.

SFB
@
text
@d39 1
a39 1
  filerid  = '3.22X';
@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@d39 1
a39 1
  filerid  = '3.22B';
d1909 2
a1910 2
	  fgotoxy(output,9,3);
	  write(i:5,' ');       { space is a message separation }{24jan83}
d1920 2
a1921 2
	      write(i:5);
	      if dispx<42 then dispx := dispx + 6
@


30.2
log
@
pws2rcs automatic delta on Wed Dec 14 13:22:28 MST 1988
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@d39 1
a39 1
  filerid  = '3.22A';
@


29.3
log
@
pws2rcs automatic delta on Thu Dec  8 15:31:09 MST 1988
@
text
@@


29.2
log
@Fixed FSDdt01111 - FILER leaves SRM dir open after changing filename.
Scott
@
text
@d39 1
a39 1
  filerid  = '3.22b';
@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@d2478 1
@


28.2
log
@
ipws2rcs automatic delta on Mon Oct 31 10:34:17 MST 1988
:w
:q
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@d39 1
a39 1
  filerid  = '3.3a';
@


27.2
log
@pws2rcs automatic delta on Wed Oct  5 17:32:00 MDT 1988

@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@d39 1
a39 1
  filerid  = '3.21b';
@


26.7
log
@
Comment from auto synch of clock fix:
date: 88/04/08 09:41:47;  author: quist;  state: Exp;  lines added/del: 2/0
fixed date display for E command
@
text
@@


26.6
log
@
Comment from auto synch of clock fix:
date: 88/03/18 10:18:36;  author: quist;  state: Exp;  lines added/del: 1/1
Pws2unix automatic delta on Fri Mar 18 09:13:54 MST 1988
@
text
@d514 2
@


26.5
log
@
Comment from auto synch of clock fix:
date: 88/03/09 09:04:37;  author: quist;  state: Exp;  lines added/del: 1/1
Pws2unix automatic delta on Wed Mar 9 08:03:11 MST 1988
@
text
@d39 1
a39 1
  filerid  = '3.21a';
@


26.4
log
@
Comment from auto synch of clock fix:
date: 88/03/02 17:27:47;  author: quist;  state: Exp;  lines added/del: 5/3
SYSDATE fixes, RDQ
@
text
@d39 1
a39 1
  filerid  = '3.2';             { 28 Aug 87 }
@


26.3
log
@
Comment from auto synch of clock fix:
date: 88/03/02 09:47:15;  author: bayes;  state: Exp;  lines added/del: 0/0
Automatic bump of revision number for PWS version 3.2Y
@
text
@d39 1
a39 1
  filerid  = '3.2Y';
d512 4
a515 2
    if year>0 then write(listfile,' ',day:2,'-',months[month],'-',year:2)
	      else write(listfile,' ':10);
@


26.2
log
@
Comment from auto synch of clock fix:
date: 88/03/01 10:06:31;  author: bayes;  state: Exp;  lines added/del: 1/1
Pws2unix automatic delta on Tue Mar 1 09:01:42 MST 1988
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@d39 1
a39 1
  filerid  = '3.2';             { 28 Aug 87 }
@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.3
log
@Pws2unix automatic delta on Sun Aug 30 14:43:47 MDT 1987
@
text
@@


23.2
log
@Fixed initial copyright message.

@
text
@d39 1
a39 1
  filerid  = '3.2P';             { 24 Aug 87 }
@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@d4014 2
a4015 2
  writeln('  Copyright 1986 Hewlett-Packard Company');
  writeln('       All rights are reserved.');
@


22.2
log
@Pws2unix automatic delta on Tue Aug 25 18:23:33 MDT 1987
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@d39 1
a39 1
  filerid  = '3.2N';             { 14 Aug 87 }
@


21.2
log
@Pws2unix automatic delta on Sat Aug 15 16:14:36 MDT 1987
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@d39 1
a39 1
  filerid  = '3.2M';             { 11 Aug 87 }
@


20.2
log
@Pws2unix automatic delta on Wed Aug 12 09:47:30 MDT 1987
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@d39 1
a39 1
  filerid  = '3.2L';             { 28 Jul 87 }
@


19.2
log
@Pws2unix automatic delta on Wed Jul 29 17:29:01 MDT 1987
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@d39 1
a39 1
  filerid  = '3.2K';             { 30 MAY 87 }
@


18.4
log
@Pws2unix automatic delta on Sun May 31 14:33:16 MDT 1987
@
text
@@


18.3
log
@Fixed bug #FSDat01161: With LIF disc in #3, Filecopy file to #43
completes with no warning! Also fixed alternative, where HFS disc with
no boot LIF header is silently destroyed by copy to #3.
@
text
@d39 1
a39 1
  filerid  = '3.2J';             { 18 MAY 87 }
@


18.2
log
@Fixed "Can't translate... to x.UX (type FKIND7)". Now says "(type UX)"
@
text
@d2832 3
a2834 1
  procedure writebdatfunny;
d2926 15
d3162 6
a3167 2
			   if unitable^[funit].uisblkd and (strlen(cvol)>0) then
			   begin  { have existing directory }
@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@d2883 20
d2908 2
a2909 1
      if strlen(cfile)>0 then writeln(' (type ',cfib.fkind,')',cteol)
d2916 2
a2917 1
      if strlen(cfile)>0 then writeln(' (type ',suffix(cfile),')',cteol)
@


17.2
log
@Pws2unix automatic delta on Wed May 20 09:57:02 MDT 1987
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@d39 1
a39 1
  filerid  = '3.2I';             { 24 APR 87 }
@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.3
log
@Pws2unix automatic delta on Fri Apr 24 18:41:36 MDT 1987
@
text
@@


15.2
log
@Fixed: trailers and showholes, superfluous "No HFSDAM installed" message,
added function unit_is_hfs.
@
text
@d39 1
a39 1
  filerid  = '3.2H';             { 11 APR 87 }
@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@d214 8
d277 2
a278 5
    if h_unitable <> NIL
      then
	if h_unitable^.tbl[cfib.funit].is_hfsunit
	  then
	    call(h_unitable^.inval_cache_proc, cfib.funit);
d611 1
a611 5
	badfile     : if ceft = 0
			then
			  write(listfile,'Spec ')
			else
			  write(listfile,'Bad  ');
d1751 2
a1752 5
    if h_unitable <> NIL
      then
	if h_unitable^.tbl[funit].is_hfsunit
	  then
	    badio(ibadrequest);
d2033 2
a2034 5
	if h_unitable <> NIL
	  then
	    if h_unitable^.tbl[funit].is_hfsunit
	      then
		badio(ibadrequest);
d2567 1
a2567 1
	blocks := ((searchname='') or (strpos ('=', searchname) <> 0));
d2643 1
a2643 1
	     if not h_unitable^.tbl[funit].is_hfsunit then
d2647 1
a2647 1
	      {this is HFS, so cextra1 = unallocated inodes, not total inodes SFB}
d3630 8
a3637 10
	   if h_unitable <> NIL
	     then
	       if h_unitable^.tbl[funit].is_hfsunit then
		 begin
		   {check if volume name}
		   if ftitle <> '' then
		     badio(ibadrequest);
		   call(unitable^[funit].dam, cfib, funit, setpasswords);
		   goodio;
		 end
d3639 1
a3639 6
		 badio(ibadrequest)
	     else
	       begin
		 writeln ('HFS_DAM is not installed.');
		 escape (0);
	       end ;
d3650 1
a3650 7
	if h_unitable = NIL
	  then
	    begin
	      writeln ('HFS_DAM is not installed.');
	      escape (0);
	    end ;
	if h_unitable^.tbl[funit].is_hfsunit then
@


14.4
log
@Pws2unix automatic delta on Sun Apr 12 17:10:24 MDT 1987
@
text
@@


14.3
log
@Fixes for revised enumerated hfs passwd commands in MISC
@
text
@d39 1
a39 1
  filerid  = '3.2G';             { 31 MAR 87 }
@


14.2
log
@Remove dependence on ALLREALS library by replacing references to
asm_octal with matchstr_utloctal
@
text
@d39 1
a39 1
  filerid  = '3.2F';             { 27 FEB 87 }
d3625 1
a3625 1
      info.command := umask;
d3711 1
a3711 1
      open_info.command := open;
d3721 1
a3721 1
		info.command := chown;
d3731 1
a3731 1
		info.command := chgrp;
d3756 1
a3756 1
		info.command := chmod;
@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@d39 1
a39 1
  filerid  = '3.2G';             { 31 MAR 87 }
d3613 1
a3613 1
	imode := octal (mode);
d3743 1
a3743 1
		  imode := octal (mode);
@


13.3
log
@Pws2unix automatic delta on Wed Apr  1 08:30:27 MST 1987
@
text
@@


13.2
log
@Added "unallocated" files in List trailer for HFS
@
text
@d39 1
a39 1
  filerid  = '3.2F';             { 27 FEB 87 }
@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@d2647 7
a2653 1
	    if cextra1>0 then write(dispfile^,' unallocated=',cextra1-filecount:1);
@


12.2
log
@Pws2unix automatic delta on Sat Feb 28 15:17:33 MST 1987
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@d39 1
a39 1
  filerid  = '3.2E';             { 29 JAN 87 }
@


11.3
log
@Pws2unix automatic delta on Mon Feb  2 09:47:34 MST 1987
@
text
@@


11.2
log
@Fix to allow chgrp on "/" FSDat00894
@
text
@d39 1
a39 1
  filerid  = '3.2C';             { 22/DEC/86 }
@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@d39 1
a39 1
  filerid  = '3.2D';             { 17 Jan 87 }
a3796 2
		  if strlen(searchname) = 0 then
		    badio(ibadrequest);
d3804 11
a3814 5
	    makenamelist (cfib, searchname, nameptr, false, false, true, segs);
	    goodio;
	    if nameptr = NIL
	      then
		if change_root
a3815 6
		    begin
		      new(nameptr);
		      nameptr^.element := '';
		      nameptr^.link    := NIL;
		    end
		  else
d3817 1
@


10.4
log
@Pws2unix automatic delta on Sun Jan 18 18:33:43 MST 1987
@
text
@@


10.3
log
@Fix for FSDat00869 (Saving workfiles to HFS disc)
@
text
@d39 1
a39 1
  filerid  = '3.2C';             { 22/DEC/86 }
@


10.2
log
@Fix for proper range check on uid/gid in chown/chgrp commands.
@
text
@d1197 2
d1340 2
d1346 2
@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@d2696 2
d2713 7
d3473 1
d3475 1
@


9.2
log
@Pws2unix automatic delta on Tue Dec 23 16:24:27 MST 1986
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@d39 1
a39 1
  filerid  = '3.2B';             { 10/DEC/86 }
@


8.3
log
@Pws2unix automatic delta on Fri Dec 12 09:42:40 MST 1986
@
text
@@


8.2
log
@Fixes for FSDat684, 667, 654, 648, 649, 598, 600, 566
@
text
@d39 1
a39 1
  filerid  = '3.2j';             { 4/Aug/83 }
@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@d532 6
a537 3
    write(listfile,'created');
    writedate(listfile,ccreatedate); writetime(listfile,ccreatetime);
    writeln(listfile,' block size=',cblocksize:1);
d544 4
d2028 7
d2947 1
a2947 1
	      if strlen(searchname)=0 then badio(ibadtitle);
d3109 1
a3109 1
			     promptyorn('WARNING, Destroy EVERYTHING on volume '+cvol,answer);
d3616 3
d3647 3
d3660 3
d3664 1
a3664 1
  { part 1 : get user inputs before doing any work }
d3666 5
a3670 6
  writeln (clearscr);
  showprompt ('HFS Access: Owner, Group, Mode, Umask, Quit ');
  read (keyboard,option);
  readcheck;
  upcchar (option);
  writeln;
d3672 1
a3672 10
  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;
d3674 10
a3683 4
  mark (lheap);
  heapinuse := TRUE;
  open_info.new_value := 0;
  open_info.command := open;
d3685 4
a3688 1
  case option of
d3690 1
a3690 2
    'O' : begin
	    write ('Enter new owner number ');
d3692 2
a3693 7
	    read_ushort(uid);
	    if ( destructive ( paws_uid, uid ))
	      then
		begin
		  ioresult := ord (inoerror);
		  escape (0);
		end ;
d3695 1
a3695 4
	    info.new_value := uid;
	    info.command := chown;
	    cmd := ' owner';
	  end;
d3697 4
a3700 2
    'G' : begin
	    write ('Enter new group number ');
d3702 2
a3703 1
	    read_ushort(gid);
d3705 1
a3705 4
	    info.new_value := gid;
	    info.command := chgrp;
	    cmd := ' group';
	  end;
d3707 3
a3709 18
    'M' : begin
	    write ('Enter new mode ');
	    readln (mode);
	    goodio;
	    if mode = '' then
	      badio(inoerror);

	    try
	      imode := octal (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;
d3712 6
a3717 4
	    info.new_value := imode;
	    info.command := chmod;
	    cmd := ' mode';
	  end;
d3719 12
a3730 4
    'U' : begin
	    do_umask;
	    badio (inoerror);
	  end;
d3732 4
a3735 3
    'Q' : begin
	    badio (inoerror);
	  end;
d3737 2
a3738 3
    otherwise if option <> ' ' then
		badcommand (option)
	      else
d3740 1
d3742 3
a3744 1
  end ;  { option case }
d3746 6
a3751 1
{ part 2 : set up the filename(s) now that the info is in }
d3753 1
a3753 3
  with ininfo, cfib do
    begin
      change_root := false;
d3755 3
a3757 7
      { working on a file not a unit }
      opendir (filename, searchname, '', ininfo, dircatentry);
      if not diropen
	then
	  escape(0);
      if str ( dircatentry.cinfo, 1, 4 ) <> 'HFS '
	then
d3759 27
a3785 6
	    badio(ibadrequest);
	  end;
      if strlen (searchname) = 0
	then
	  { filename is a directory }
	  begin
d3787 17
a3803 27
	    {try open parent directory}
	    opendir(filename,searchname,'',ininfo,dircatentry);
	    if not ininfo.diropen then escape(0);
	    if strlen(searchname) = 0 then
	      badio(ibadrequest);
	    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);
      makenamelist (cfib, searchname, nameptr, false, false, true, segs);
      goodio;
      if nameptr = NIL
	then
	  if change_root
	    then
	      begin
		new(nameptr);
		nameptr^.element := '';
		nameptr^.link    := NIL;
	      end
	    else
	      badmessage('No files changed');
      cfile := '';
    end;  { with ininfo, cfib }
d3805 1
a3805 1
{ Part 3: loop over the non-empty filename list doing the action }
d3807 4
a3810 4
	{
	  Notes: fpeof is the number of items in the list pointed
	  to by fwindow. fpos is always zero for the *password dam calls.
	}
d3812 2
a3813 7
  try
  if wildcard <> ' '
    then
      begin
	writeln(clearscr);
	editnamelist (nameptr,'Change'+cmd+' on ', wildcard);
	if nameptr <> nil
d3815 9
a3823 4
	    promptyorn ('Proceed with change of'+cmd, answer);
      end
    else
      answer := 'Y';
d3825 2
a3826 7
  if answer = 'Y'
    then
      while ( nameptr <> NIL) do
	begin
	  { use setpassword open call to set up the fib }

	  with ininfo, cfib, unitable^[funit] do
d3828 11
a3838 7
	      pathid := save_pathid;
	      ftitle := nameptr^.element;
	      fwindow := addr(open_info);
	      fpos := 0;
	      fpeof := 1;
	      call (dam, cfib, funit, setpasswords);
	      goodio;
d3840 9
a3848 1
	    { now make the change for the file }
d3850 1
a3850 11
	      fwindow := addr(info);
	      fpos := 0;
	      fpeof := 1;
	      call (dam, cfib, funit, setpasswords);
	      goodio;
	      writeln (cvol+':'+nameptr^.element+cmd + ' changed');
	      nameptr := nameptr^.link
	    end ; { with }
	end {while}
    else
      writeln('No files changed');
d3852 12
a3863 3
  release (lheap);
  heapinuse := false;
  closedir (ininfo);
d3865 1
a3865 3
  recover
    begin
      release(lheap);
d3867 7
a3873 1
      printioerrmsg;
d3876 3
a3878 2
	    escape(escapecode);
    end;
d3973 2
@


7.4
log
@Pws2unix automatic delta on Wed Nov 26 16:18:22 MST 1986
@
text
@@


7.3
log
@add check if BDAT file gets copied to or from HFS (as for LIF).
@
text
@d3159 2
a3160 1
			   outfunny := (str(dircatentry.cinfo,1,4)='LIF ') or (str(dircatentry.cinfo,1,4)='HFS ');
@


7.2
log
@take out the check for SRM and HFS disc in the ZERO command.
change the check for HFS disc in the ACCESS command.
fix bug in hfs_access: ch* of "/" (root).
@
text
@d54 1
a54 1
  files in LIF directories.
d2931 1
a2931 1
		infunny := str(dircatentry.cinfo,1,4)='LIF ';
d3159 1
a3159 1
			   outfunny := str(dircatentry.cinfo,1,4)='LIF ';
d3197 1
a3197 1
			     begin      { from ? to LIF }
d3205 1
a3205 1
			     begin      { from LIF to ? }
@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@a1713 1
  filename1     : fid;
d1734 4
a1737 3
    filename1 := filename;
    opendir (filename1, searchname, '', ininfo, dircatentry);
    if ( str (dircatentry.cinfo, 1, 4) <> 'SRM ')
d1739 4
a1742 2
	badio (ibadrequest);
    setupfibforfile(filename,cfib,cpvol);
a1971 1
  filename1     : fid;
a1975 1
  olddiropen    : boolean;
a2013 8
	filename1 := filename;
	olddiropen := ininfo.diropen;
	opendir (filename1, searchname, '', ininfo, dircatentry);
	if not ininfo.diropen then escape(0);
	ininfo.diropen := olddiropen;
	if ((str (dircatentry.cinfo, 1, 4) = 'SRM '))
	  then
	    badio (ibadrequest);
d3551 1
d3738 2
d3754 1
d3760 3
d3771 9
a3779 1
	  badmessage('No files changed');
@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@@


5.3
log
@fixes so that the filer knows about 500 BDAT files and correctly
handled
@
text
@@


5.2
log
@many small error fixes: zero & mounted devices, filecopy & hfs cache
invalidation, hfs_access: lots, filecopy destroy message, access:
proper reaction to RETURN key, zero: hfs test out because dam does it,
dts bug FSDat00487 fixed
@
text
@d50 1
d1044 5
a1048 2
    if feft=bdat then ioresult := ord(ibadrequest)
		 else call(am,ffib,readtoeol,bufrec^,255,fpos);
d3200 1
a3200 1
			 if feft=bdat then
d3239 1
a3239 1
			 if feft=bdat then
d3277 1
a3277 1
			   if feft=bdat then
@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@d39 1
a39 1
  filerid  = '3.1';             { 4/Aug/83 }
d267 7
a1727 5
  filename1 := filename;
  opendir (filename1, searchname, '', ininfo, dircatentry);
  if ( str (dircatentry.cinfo, 1, 4) <> 'SRM ')
    then
      badio (ibadrequest);
d1731 5
d1983 1
a1983 1
    writeln(homechar,'Zero directory (NOT valid for HFS and SRM type units)');
d2013 1
d2015 1
a2015 1
	if ((str (dircatentry.cinfo, 1, 4) = 'SRM ') or (str (dircatentry.cinfo, 1, 4) = 'HFS '))
d2556 1
a2556 1
	blocks := ((searchname='') or (searchname='='));
d2587 1
d3099 1
a3099 1
			     promptyorn('Destroy directory '+cvol,answer);
d3440 1
a3440 1
  ti       : integer;
d3457 3
a3459 1
		     else escape(escapecode);
d3476 1
a3476 5
		       old_gid : ushort;
		       old_per : ushort;
		       new_uid : ushort;
		       new_gid : ushort;
		       new_per : ushort ) : boolean;
a3481 1
    change : boolean;
a3482 1
    per_bits : integer;
d3486 1
a3486 1
    if new_uid <> paws_uid
a3488 2
	  { writeln('in destructive 2');}
	  change := true ;
a3543 2
  prev          : tidelementptr;
  head          : tidelementptr;
d3559 2
a3560 1
  write('For which unit ? ');
d3571 1
a3571 1
  showprompt ('Enter new umask number ');
d3579 2
a3580 1
	imode := imode mod 512;
d3583 1
a3583 1
	  if escapecode = -8
d3600 14
a3613 7
	   if h_unitable^.tbl[funit].is_hfsunit then
	     begin
	       call(unitable^[funit].dam, cfib, funit, setpasswords);
	       goodio;
	     end
	   else
	     badio(ibadrequest);
d3624 6
d3650 13
a3662 1
  writeln (option);
a3667 4
  write('For which file ? ');
  readln (filename);
  goodio;

d3671 1
a3671 1
	    showprompt ('Enter new owner number ');
d3674 6
d3687 1
a3687 1
	    showprompt ('Enter new group number ');
d3697 1
a3697 1
	    showprompt ('Enter new mode ');
d3705 2
a3706 1
	      imode := imode mod 512;
d3709 1
a3709 1
		if escapecode = -8
d3730 4
a3733 1
    otherwise badcommand (option);
a3738 9
  zapspaces(filename);
  if strlen(filename)= 0
    then
     begin
       release (lheap);
       heapinuse := false;
       escape (0);
     end;

a3745 1
      save_pathid := pathid;
d3761 1
d3768 1
a3768 1
	  badmessage('No files found');
d3780 2
a3781 3
    prev := nameptr ;
    head := nameptr ;
    while ( nameptr <> NIL) do
d3783 8
a3790 2
	with ininfo, cfib, unitable^[funit] do
	  begin
a3791 32
	      if wildcard = '?'
		then
		  promptread ( 'Change'+cmd+' on '+nameptr^.element+' ? (Y/N)',
			       answer, 'YN', 'N' )
		else
		  answer := 'Y';


	      if ( answer <> 'Y' )
		then
		  begin
		    if head = nameptr
		      then
			begin
			  head := nameptr^.link;
			  prev := nameptr^.link;
			end
		      else
			begin
			  prev^.link := nameptr^.link;
			end;
		  end
		else
		  begin
		    prev := nameptr ;
		  end;

	  end;    {with ininfo}
	nameptr := nameptr^.link ;
      end; {while}

  promptread ( 'Proceed with change of '+cmd+' ? (Y/N)', answer, 'YN', 'N' );
d3794 1
a3794 1
      while ( head <> NIL) do
d3808 1
a3808 3
	      { call the catpasswd command to get the current uid, gid
		and permissions.
	      }
d3810 4
a3813 2
	      fwindow := addr(cat_info);
	      call ( dam, cfib, funit, catpasswords );
d3815 2
a3816 33

	      old_uid := cat_info.cat_uid;
	      old_gid := cat_info.cat_gid;
	      old_per := cat_info.cat_mode;
	      new_uid := old_uid;
	      new_gid := old_gid;
	      new_per := old_per;

	      case info.command of
		chown : new_uid := info.new_value;
		chgrp : new_gid := info.new_value;
		chmod : new_per := info.new_value;
	      end ;   { case info.command }

	      if ( old_uid <> paws_uid) {may cange with login available}
		then
		  badio(inopermission);

	      if ( not destructive ( old_uid, old_gid, old_per,
				     new_uid, new_gid, new_per ))
		then
		  begin
		  { now make the change for the file }

		    ftitle := nameptr^.element;
		    fwindow := addr(info);
		    fpos := 0;
		    fpeof := 1;
		    call (dam, cfib, funit, setpasswords);
		    goodio;
		    writeln (cvol+':'+nameptr^.element+cmd + ' changed');
		  end;
	      head := head^.link
d3818 3
a3820 1
	end; {while}
@


4.3
log
@Pws2unix automatic delta on Tue Oct 28 10:57:29 MEZ 1986
@
text
@@


4.2
log
@quick ci before build on 20 Oct, some changes to user
interface done
@
text
@d2988 1
a2988 1
			 lefttoxfer   := fleof;   fb1 := true;
d3793 1
a3793 1
  promptread ( 'Proceed with change of '+cmd+' ? (Y/N)', answer, 'YN', 'N' )
d3800 9
a3808 7
	  pathid := save_pathid;
	  ftitle := nameptr^.element;
	  fwindow := addr(open_info);
	  fpos := 0;
	  fpeof := 1;
	  call (dam, cfib, funit, setpasswords);
	  goodio;
d3810 3
a3812 3
	  { call the catpasswd command to get the current uid, gid
	    and permissions.
	  }
d3814 3
a3816 3
	  fwindow := addr(cat_info);
	  call ( dam, cfib, funit, catpasswords );
	  goodio;
d3818 6
a3823 6
	  old_uid := cat_info.cat_uid;
	  old_gid := cat_info.cat_gid;
	  old_per := cat_info.cat_mode;
	  new_uid := old_uid;
	  new_gid := old_gid;
	  new_per := old_per;
d3825 5
a3829 5
	  case info.command of
	    chown : new_uid := info.new_value;
	    chgrp : new_gid := info.new_value;
	    chmod : new_per := info.new_value;
	  end ;   { case info.command }
d3831 3
a3833 3
	  if ( old_uid <> paws_uid) {may cange with login available}
	    then
	      badio(inopermission);
d3835 5
a3839 5
	  if ( not destructive ( old_uid, old_gid, old_per,
				 new_uid, new_gid, new_per ))
	    then
	      begin
	      { now make the change for the file }
d3841 10
a3850 9
		ftitle := nameptr^.element;
		fwindow := addr(info);
		fpos := 0;
		fpeof := 1;
		call (dam, cfib, funit, setpasswords);
		goodio;
		writeln (cvol+':'+nameptr^.element+cmd + ' changed');
	      end;
	  head := head^.link
@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@d2988 1
a2988 1
			 lefttoxfer   := fleof;
d3490 1
a3490 1
	  writeln ('of the file/directory in the future. ');
d3492 1
a3492 1
	  writeln ('depending on the permissions.         ');
d3541 2
d3558 12
a3569 1
  showprompt ('Change umask to what ? ');
a3585 2
      write('For which unit ? ');
      readln (filename);
a3590 9
      zapspaces(filename);
      if strlen(filename) = 0
	then
	  begin
	    release(lheap);
	    heapinuse := false;
	    escape(0);
	  end;

d3607 1
a3607 1
    {no mode given indicates to show the umask of dkvid}
a3609 1
	filename := dkvid;
d3630 1
a3630 1
  showprompt ('HFS Access: Owner, Group, Mode, Umask, Quit ? ');
d3639 5
d3647 1
a3647 1
	    showprompt ('Change owner to what ? ');
a3650 3
	    write('For which file ? ');
	    readln (filename);
	    goodio;
d3657 1
a3657 1
	    showprompt ('Change group to what ? ');
a3660 3
	    write('For which file ? ');
	    readln (filename);
	    goodio;
d3667 1
a3667 1
	    showprompt ('Change mode to what ? ');
a3684 3
	    write('For which file ? ');
	    readln (filename);
	    goodio;
d3755 2
a3760 1
	      { use setpassword open call to set up the fib }
a3761 29
	      pathid := save_pathid;
	      ftitle := nameptr^.element;
	      fwindow := addr(open_info);
	      fpos := 0;
	      fpeof := 1;
	      call (dam, cfib, funit, setpasswords);
	      goodio;

	      { call the catpasswd command to get the current uid, gid
		and permissions.
	      }

	      fwindow := addr(cat_info);
	      call ( dam, cfib, funit, catpasswords );
	      goodio;

	      old_uid := cat_info.cat_uid;
	      old_gid := cat_info.cat_gid;
	      old_per := cat_info.cat_mode;
	      new_uid := old_uid;
	      new_gid := old_gid;
	      new_per := old_per;

	      case info.command of
		chown : new_uid := info.new_value;
		chgrp : new_gid := info.new_value;
		chmod : new_per := info.new_value;
	      end ;   { case info.command }

d3770 18
a3787 4
	      if ( answer = 'Y' )  then
		begin
		  if ( old_uid <> paws_uid) {may cange with login available} then
		      badio(inopermission);
d3789 3
a3791 4
		   if ( not destructive ( old_uid, old_gid, old_per,
					  new_uid, new_gid, new_per )) then
		     begin
		       { now make the change for the file }
d3793 6
a3798 9
		       ftitle := nameptr^.element;
		       fwindow := addr(info);
		       fpos := 0;
		       fpeof := 1;
		       call (dam, cfib, funit, setpasswords);
		       goodio;
		       writeln (cvol+':'+nameptr^.element+cmd + ' changed');
		     end;
		end
d3800 49
a3848 3
	  end;    {with ininfo}
	nameptr := nameptr^.link
      end; {while}
@


3.3
log
@Pws2unix automatic delta on Tue Sep 30 13:50:02 MEZ 1986
@
text
@@


3.2
log
@elimination of some of the hfs checking stuff
@
text
@d3480 1
a3480 1
    destructive := false
@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@d3480 2
a3481 1
    if new_uid = paws_uid
d3484 1
a3484 16
	  writeln('in destructive 1');
	  { group id is a nop because user retains ownership }
	  if old_per = new_per
	    then
	      change := false
	    else
	      begin
		{ permissions change, issue light warning }
		{ extract user bits }
		change := true ;
		per_bits := binasr ( binand (new_per, hex('1C0')), 6);
	      end;
	end
      else
	begin
	  writeln('in destructive 2');
a3487 2
	  writeln ('WARNING Will Robinson, DANGER! DANGER!');
	  writeln;
a3493 19
	  if new_gid = paws_gid {this may change with login available}
	    then
	      begin
		{ retains group permissions check for access }
		{ extract group bits }
		per_bits := binasr ( binand (new_per, hex('38')), 3);
	      end
	    else
	      begin
		{ have no group access issue major warning }
		writeln ('Your access to the file is OTHER.     ');
		writeln ('You may lose ALL access to the file   ');
		writeln ('depending on the permissions.         ');
		writeln;
		{ owner and group are different, check other permissions }
		{ extract other bits }
		per_bits := binand (new_per, hex('7'));
	      end;
	end;
a3494 48
    if change
      then
	begin
	  writeln('in destructive 3');
	  { light warning about what can't be done }
	  case per_bits of
	    0: begin
		 writeln;
		 writeln ('ALL access to the file/directory is lost');
		 writeln;
	       end;
	    1: begin
		 writeln;
		 writeln ('EXECUTE access to the file/directory is retained');
		 writeln;
	       end;
	    2: begin
		 writeln;
		 writeln ('WRITE access to the file/directory is retained');
		 writeln;
	       end;
	    3: begin
		 writeln;
		 writeln ('WRITE and EXECUTE access to the file/directory is retained');
		 writeln;
	       end;
	    4: begin
		 writeln;
		 writeln ('READ access to the file/directory is retained');
		 writeln;
	       end;
	    5: begin
		 writeln;
		 writeln ('READ and EXECUTE access to the file/directory is retained');
		 writeln;
	       end;
	    6: begin
		 writeln;
		 writeln ('READ and WRITE access to the file/directory is retained');
		 writeln;
	       end;
	    7: begin
		 writeln;
		 writeln ('ALL access to the file/directory is retained');
		 writeln;
	       end;
	  end; { case per_bits }

d3502 2
a3503 3
	end
      else
	destructive := false;
@


2.6
log
@2 error fixes, 1- nulls in listing, 2- hfs_access needs to retain the
path id (inode) of the directory before operating on the file
@
text
@@


2.5
log
@error in zero function diropen is a state variable
@
text
@a560 3
const
  null = '#0';

d568 1
a568 1
    nullpos := strpos (cname, null);
d3635 1
d3808 1
d3848 1
@


2.4
log
@Pws2unix automatic delta on Tue Aug 19 10:31:55 MEZ 1986
@
text
@d1967 1
d2007 1
d2009 1
@


2.3
log
@explicit tests for SRM or HFS where command invalid, small touch ups
@
text
@d562 1
a562 1
  null = '#0'
d1726 1
a1726 1
  if ( str (dircatentry, 1, 4) <> 'SRM ')
d2007 1
a2007 1
	if ((str (dircatentry, 1, 4) = 'SRM ') or (str (dircatentry, 1, 4) = 'HFS '))
@


2.2
log
@general changes in procedure hfs_access
@
text
@d561 3
d566 2
d571 4
d604 1
a604 1
	uxfile      : write(listfile,'Unix ');
d731 11
d1706 3
d1724 5
d1962 1
d2005 5
d2557 1
a2557 1
	makenamelist(ininfo.cfib,searchname,nameptr,true,order,not extlist,filecount);
d3480 1
a3480 1
    if new_uid = old_uid
d3520 1
a3520 2
		(************************
		writeln ('The GROUP of the file is changing.    ');
a3523 1
		**************************)
@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@d3394 22
d3417 13
d3438 1
a3438 1
    confirm = 'Continue despite loss of access ? (Y/N) ';
d3446 1
a3446 1
    if new_uid <> paws_uid
d3449 1
d3464 1
d3470 4
a3473 4
	  writeln ('The OWNERSHIP of the file is changing.');
	  writeln ('You will lose the right to change any ');
	  writeln ('attributes of the file in the future. ');
	  writeln ('You may lose ALL access to the file   ');
d3476 1
a3476 1
	  if new_gid = paws_gid
d3479 1
a3479 1
		{ retains group premissions check for access }
d3486 1
d3491 1
d3501 1
d3506 1
a3506 1
		 writeln ('ALL access to the file is lost');
d3511 1
a3511 1
		 writeln ('EXECUTE access to the file is retained');
d3516 1
a3516 1
		 writeln ('WRITE access to the file is retained');
d3521 1
a3521 1
		 writeln ('WRITE and EXECUTE access to the file is retained');
d3526 1
a3526 1
		 writeln ('READ access to the file is retained');
d3531 1
a3531 1
		 writeln ('READ and EXECUTE access to the file is retained');
d3536 1
a3536 1
		 writeln ('READ and WRITE access to the file is retained');
d3541 1
a3541 1
		 writeln ('ALL access to the file is retained');
d3547 1
d3604 2
d3607 3
d3611 66
d3694 1
a3694 8
	    try
	      readln (uid);
	    recover
	      if escapecode = -8
		then
		  begin
		    badmessage ('User id number not in range 0 - 65535');
		  end;
d3696 1
a3696 2
	    goodio;
	    showprompt ('For which file ? ');
d3701 1
a3701 1
	    cmd := 'chown ';
d3707 1
a3707 8
	    try
	      readln (gid);
	    recover
	      if escapecode = -8
		then
		  begin
		    badmessage ('Group id number not in range 0 - 65535');
		  end;
d3709 1
a3709 2
	    goodio;
	    showprompt ('For which file ? ');
d3714 1
a3714 1
	    cmd := 'chgrp ';
d3721 2
d3736 1
a3736 1
	    showprompt ('For which file ? ');
d3741 1
a3741 1
	    cmd := 'chmod ';
d3745 2
a3746 21
	    showprompt ('Change umask to what ? ');
	    readln (mode);
	    goodio;

	    try
	      imode := octal (mode);
	      imode := imode mod 512;
	    recover
	      begin
		if escapecode = -8
		  then
		    begin
		      badmessage ('New mode not in range 0 - 0777 octal');
		    end;
	      end;

	    showprompt ('For which unit ? ');
	    readln (filename);
	    info.new_value := imode;
	    info.command := umask;
	    cmd := 'umask ';
d3770 3
a3772 2
      setupfibforfile (filename, cfib, cpvol);
      if info.command <> umask
d3774 3
d3778 5
a3782 28
	    { working on a file not a unit }
	    opendir (filename, searchname, '', ininfo, dircatentry);
	    if not diropen
	      then
		escape(0);
	    if str ( dircatentry.cinfo, 1, 4 ) <> 'HFS '
	      then
		begin
		  badmessage ('The HFS commands only work on a HFS disc');
		end;
	    if strlen (searchname) = 0
	      then
		badio (ibadtitle);
	    wildcard := getwildcard (searchname);
	    makenamelist (cfib, searchname, nameptr, false, false, true, segs);
	    goodio;
	    if nameptr = NIL
	      then
		begin
		  if wildcard = ' '
		    then
		      badio (inofile);
		  writeln ('no files found', cteol);
		  badio (inoerror);
		end;
	    cfile := '';
	  end
	else
d3784 5
a3788 4
	    { set up dummy filename list so loop won't break }
	    new (nameptr);
	    nameptr^.element := '';
	    nameptr^.link := nil;
d3790 8
a3804 2
	  If pathid is rawinode or noinode then umask comes back from
	  a catpasswords call, otherwise mode is returned.
d3808 1
a3808 2
  repeat
    with ininfo, cfib, unitable^[funit] do
d3810 3
a3812 1
	  { use setpassword open call to set up the fib }
d3814 6
a3819 12
	  ftitle := nameptr^.element;
	  fwindow := addr(open_info);
	  fpos := 0;
	  fpeof := 1;
	  call (dam, cfib, funit, setpasswords);
	  if (ioresult <> ord(inoerror))
	    then
	      if (ioresult = ord(inofile))
		then
		  writeln (cvol,':',nameptr^.element,' does not exist')
		else
		  printioerrmsg;
d3821 3
a3823 3
	  { call the catpasswd command to get the current uid, gid
	    and permissions.
	  }
d3825 3
a3827 5
	  fwindow := addr(cat_info);
	  call ( dam, cfib, funit, catpasswords );
	  if (ioresult <> ord(inoerror))
	    then
	      printioerrmsg;
d3829 6
a3834 6
	  old_uid := cat_info.cat_uid;
	  old_gid := cat_info.cat_gid;
	  old_per := cat_info.cat_mode;
	  new_uid := old_uid;
	  new_gid := old_gid;
	  new_per := old_per;
d3836 5
a3840 5
	  case info.command of
	    chown : new_uid := info.new_value;
	    chgrp : new_gid := info.new_value;
	    chmod : new_per := info.new_value;
	  end ;   { case info.command }
d3842 6
a3847 6
	  if wildcard = '?'
	    then
	      promptread ( cmd+'on '+nameptr^.element+' ? (Y/N)',
			   answer, 'YN', 'N' )
	    else
	      answer := 'Y';
d3850 4
a3853 5
	  if ( answer = 'Y' ) and ( not destructive ( old_uid, old_gid, old_per,
						      new_uid, new_gid, new_per ))
	    then
	      begin
		{ now make the change for the file }
d3855 4
a3858 19
		ftitle := nameptr^.element;
		fwindow := addr(info);
		fpos := 0;
		fpeof := 1;
		call (dam, cfib, funit, setpasswords);
		if (ioresult <> ord(inoerror))
		  then
		    begin
		      if (ioresult = ord(inofile))
			then
			  writeln (cvol,':',nameptr^.element,' does not exist')
			else
			  printioerrmsg;
		    end
		  else
		    begin
		      writeln ( cmd+'completed on file '+nameptr^.element );
		    end;
	      end;
d3860 14
a3873 3
    end;    {with ininfo}
    nameptr := nameptr^.link
  until nameptr = NIL ;
@


1.11
log
@set answer to 'Y' if no wildcard, so setpasswords is actually called.
. 
@
text
@@


1.10
log
@Changed "fkind7" to "uxfile".
@
text
@d3785 3
a3787 1
			   answer, 'YN', 'N' );
@


1.9
log
@new parameter in makenamelist to indicate whether a short or extended
listing should be done. This is for performance improvements with hfs.
@
text
@d595 1
a595 1
	fkind7      : write(listfile,'Unix ');
@


1.8
log
@Move setting of fb0 (tells hfsdam whether to read ws hdrs)
to after fib setup routine, which otherwise resets it to false.
@
text
@d720 1
d779 1
d2254 1
a2254 1
	makenamelist(cfib,searchname,nameptr,false,false,lsegs);
d2382 1
a2382 1
	  makenamelist(cfib,searchname,nameptr,false,false,lsegs);
d2523 1
a2523 3
	{ tell hfsdam not to read ws headers }
	ininfo.cfib.fb0 := not extlist;
	makenamelist(ininfo.cfib,searchname,nameptr,true,order,filecount);
d2668 1
a2668 1
	makenamelist(ininfo.cfib,searchname,nameptr,false,false,filecount);
d2895 1
a2895 1
	      makenamelist(cfib,searchname,nameptr,false,false,segs);
d3709 1
a3709 1
	    makenamelist (cfib, searchname, nameptr, false, false, segs);
@


1.7
log
@Pws2unix automatic delta on Tue Jul 15 16:35:26 MEZ 1986
@
text
@a2492 1
	ininfo.cfib.fb0 := FALSE;
a2496 1
	ininfo.cfib.fb0 := TRUE;
d2521 2
@


1.6
log
@In extended listing, write UX file types left-justified (as the
others are).  Use name 'Unix'; might want 'UX' or 'Ux'?
@
text
@d3 1
a3 1
$ref 49$
d595 1
a595 1
	uxkind      : write(listfile,'Unix ');
@


1.5
log
@hfs access code, has been successfully compiled, using 3.2c library
and special include file.
@
text
@d595 1
@


1.4
log
@new prompt
@
text
@d18 1
d31 1
a3392 1
procedure hfs_access ;
d3394 168
d3563 268
a3830 2
  writeln ('in hfs_access procedure');
end ;    { procedure hfs_access}
@


1.3
log
@setting the fib.fb[01] fields to work with the hfsdam stuff
@
text
@d43 1
a43 1
 'Filer: Hfs Bad-secs Ext-dir Krunch Make Prefix-vol Filecopy Duplicate Zero ? [';
@


1.2
log
@preliminary changes to the filer for the addition of hfs, prompt lines,
messages, command interpreter & stub for new command.
@
text
@d629 18
a646 8
      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;
d2486 11
a2496 1
  if extlist then instring := 'List_ext ' else instring := 'List ';
@


1.1
log
@Initial revision
@
text
@d39 1
a39 1
  sprompt2 =    'Filer: Ac Dup Bad Kch Pfx Vol Wht Sav Zro ? [';
d43 1
a43 1
 'Filer: Bad-secs Ext-dir Krunch Make Prefix-vol Filecopy Duplicate Zero  ? [';
d583 5
a587 1
	badfile     : write(listfile,'Bad  ');
d1929 1
a1929 1
    writeln(homechar,'Make directory (valid only for SRM type units)');
d1934 1
a1934 1
    writeln(homechar,'Zero directory (NOT valid for SRM type units)');
d2216 1
a2216 1
  writeln(homechar,'Duplicate link (valid only for SRM type units)',cteol);
d3283 2
a3284 1
    col := 0; row := 2;
d3292 9
a3300 3
	if uvid = syvid then sym := ' * '
	else
	  if uisblkd then sym := ' # ' else sym := '   ';
d3305 2
a3306 1
	  row := 2; col := col + 26;
d3321 3
a3323 1
  if col<>0 then row := screenheight - 4;
d3338 3
a3340 1
      if scantitle(symfid,lvid,ltitle,lsegs,lkind) then;
d3342 4
a3345 1
      if scantitle(codefid,lvid,ltitle,lsegs,lkind) then;
d3355 13
a3367 7
  read(keyboard,ch);    readcheck;
  if ch=sh_exc then ch := ' ';
  if ch=' ' then write(clearscr)
  else
  begin
    write(homechar,cteol); upcchar(ch);
  end;
d3371 7
d3415 1
d3462 1
a3462 1
  writeln('  Copyright 1985 Hewlett-Packard Company');
@
