Programmer 7500/MAX_PROGRAMMERS.iso/INFO/PASCAL/KRTOOL.ZIP/TOOLU.PAS

Pascal/Delphi Source File | 1989-10-19 | 15.9 KB | 716 lines

CONST

  Version ='1.9.e';
          { x.x.y    Revisors: Please only renumber y, let McGee renumber x.x }


  { ----------  CONFIGURATION to user's system and preferences ------------- }

  { hardware and OS configuration }

  SystemDrive ='A:';        { SHELL and all .CHN files will be on this disk }
  ShellName   ='SHELL.COM'; { .CMD on CP/M-86, .COM on CP/M-80 and MS-DOS }
  PipePrefix  ='$PIPE';     { prefix with memory disk if available }
  TempEditFile='$EDTEMP';   { same }
                            { (need to move STEMP and ARTEMP here also) }
  TabSpaces   = 8;          { 4 in K&P, but 8 better for most terminals }
  { To configure, also check inclusion of proper OS file in CHAPTER1.PAS  }

  { example configurations:
         1.  AppleII with CP/M card and two floppy disks
         2.  DEC Rainbow running CP/M-86, autobooting to
               Winchester E:, with large memory drive M:
         3.  DEC Rainbow running MS-DOS on two floppies,
               system on B:, memory drive on E:

                     AppleII         Rainbow        Rainbow
                     CP/M-80         CP/M-86        MS-DOS
                     ----------      ----------     ----------
    SystemDrive      'A:'            'E:'           'B:'
    ShellName        'SHELL.COM'     'SHELL.CMD'    'SHELL.COM
    PipePrefix       '$PIPE'         'M:$PIPE'      'E:$PIPE'
    TempEditFile     '$EDTEMP'       'M:$EDTEMP'    'E:$EDTEMP'
  }


  { user preference configurations }

  ShellPrompt ='$ ';
  EditPrompt  =TRUE;      { not in K&P; very hard to use edit without it }
  Debug   = FALSE ;       { prints more info; can be handy while learning }
  ListProcess = TRUE;     { echo second and subsequent processes }
  Abbreviate = false;     { can shorten commands -- uses first match }
  AppendFNamePAS = FALSE; { converts, i.e. filename "TEXT" to "TEXT.PAS" }
  { K&P had AppendFNamePAS=TRUE, but it's confusing for non-program files }

  { --------------------- end of CONFIGURATION section --------------------- }


  MAXCMD=20; { max arguments to one process }
  ENDFILE=255;
  ENDSTR=0;
  MAXSTR=130;
  { ASCII character set in decimal }
  BLANK=32;
  BACKSPACE=8; { backs up cursor one space; may be different from DELETE! }
  DELETE1 = 127; { user types this to delete prior character entered }
  DELETE2 =   8; { user can also delete with this (=DELETE1 to remove) }
  TAB=9;
  NEWLINE=13;   { internal eol flag; also, terminates console input line }
  EXCLAM=33;
  DQUOTE=34;
  SHARP=35;
  DOLLAR=36;
  PERCENT=37;
  AMPER=38;
  SQUOTE=39;
  ACUTE=SQUOTE;
  LPAREN=40;
  RPAREN=41;
  STAR=42;
  PLUS=43;
  COMMA=44;
  MINUS=45;
  DASH=MINUS;
  PERIOD=46;
  SLASH=47;
  COLON=58;
  SEMICOL=59;
  LESS=60;
  EQUALS=61;
  GREATER=62;
  QUESTION=63;
  ATSIGN=64;
  ESCAPE=ATSIGN;
  LBRACK=91;
  BACKSLASH=92;
  RBRACK=93;
  CARET=94;
  GRAVE=96;
  UNDERLINE=95;
  TILDE=126;
  LBRACE=123;
  BAR=124;
  RBRACE=125;

TYPE
  CHARACTER=0..255;
  XSTRING=ARRAY[1..MAXSTR]OF CHARACTER;
  STRING80=string[80];
  FILEDESC=(IOERROR,STDIN,STDOUT,STDERR,F4,F5,F6,F7,F8,F9,F10,MAXOPEN);
       (* add as many Fn numbers as you need files; > F7 needed only by sort *)
  FileModes = (IOREAD,IOWRITE);
  FILTYP=(CLOSED,STDIO,OpenFile);

VAR
   { The process and pipe vars MUST be the first declared in every program }
   { chained to.  Thus, do not declare any variables before $I TOOLU.PAS.  }

   ActiveProcessQ, FromPipe, ToPipe : boolean;
   PipeCount : integer;
   ProcessQueue : XSTRING;

   KBDN,KBDNEXT:INTEGER;
   KBDLINE,CMDLIN:XSTRING;
   CMDARGS:0..MAXCMD;
   CMDIDX:ARRAY[1..MAXCMD] OF 1..MAXSTR;
   GlobalArg1: STRING80;
   CMDFIL:ARRAY[STDIN..MAXOPEN]OF FILTYP;
   CMDText: ARRAY[STDIN..MAXOPEN] OF TEXT;
   ReadingShellCmd : boolean;


PROCEDURE PUTDEC(N,W:INTEGER);FORWARD;
FUNCTION ITOC(N:INTEGER;VAR S:XSTRING;I:INTEGER):INTEGER;FORWARD;
FUNCTION GETARG(N:INTEGER;VAR S:XSTRING; MAXSIZE:INTEGER):BOOLEAN;FORWARD;
  PROCEDURE SCOPY(VAR SRC:XSTRING;I:INTEGER;VAR DEST:XSTRING;J:INTEGER);FORWARD;
PROCEDURE ENDCMD;FORWARD;
PROCEDURE XCLOSE(FD:FILEDESC);FORWARD;
FUNCTION XLENGTH(VAR S:XSTRING):INTEGER;FORWARD;
PROCEDURE ERROR(STR:STRING80);FORWARD;
FUNCTION MAX(X,Y:INTEGER):INTEGER;FORWARD;
PROCEDURE REMOVE(NAME:XSTRING);FORWARD;
FUNCTION NARGS:INTEGER;FORWARD;
FUNCTION ADDSTR(C:CHARACTER;VAR OUTSET:XSTRING;VAR J:INTEGER;MAXSET:INTEGER):
                 BOOLEAN;FORWARD;
PROCEDURE PUTSTR(STR:XSTRING;FD:FILEDESC);FORWARD;
FUNCTION MIN(X,Y:INTEGER):INTEGER;FORWARD;
FUNCTION ISUPPER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION EQUAL(VAR STR1,STR2:XSTRING):BOOLEAN;FORWARD;
FUNCTION INDEX(VAR S:XSTRING;C:CHARACTER):INTEGER;FORWARD;
FUNCTION ISALPHANUM(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ESC(VAR S:XSTRING;VAR I:INTEGER): CHARACTER;FORWARD;
PROCEDURE FCOPY(FIN,FOUT:FILEDESC);FORWARD;
FUNCTION CTOI(VAR S:XSTRING;VAR I:INTEGER):INTEGER;FORWARD;
FUNCTION ISDIGIT(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISLOWER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISLETTER(C:CHARACTER):BOOLEAN;FORWARD;


{ system support }


 PROCEDURE GenPipeName(PipeNumber: integer; var name: XSTRING);
 { Generate a pipe file name }
 var str: STRING80;
     len, i: integer;
 begin
   str := PipePrefix;  len := LENGTH(STR);
   for i := 1 to len do  name[i] := ORD(str[i]);
   name[len+1] := ENDSTR;
   i := ITOC(PipeNumber,name,(len+1)); { append digits }
 end;

procedure AssignPipe0(var f: text);
var s: STRING80; name: XSTRING; i:integer;
begin
  GenPipeName(0,name);
  s := '';  i := 1;
  while name[i] <> ENDSTR do begin
    s := s + chr(name[i]);  i:= i+1;
  end;
  {close(f);} { causes crash on CP/M-86 }
  assign(f,s);
end;



function EntryFromHost: boolean;
{ The routines EntryFromHost and SetEntryFromHost implement a boolean
  variable which is always TRUE when SHELL is first invoked, and which
  remains FALSE across subsequent invocations via Chain/Execute }
{ Implemented via a file name, which is portable across all Turbo systems }
var pipe0: text;
begin
  AssignPipe0(pipe0);
  {$I- } reset(pipe0);;  {$I+ }
  EntryFromHost := (IOResult<>0);  { false if file exists }
  close(pipe0);
  { CP/M-80 allows minor speedup at cost of portability:  }
  { replace all code in this procedure by: EntryFromHost:= (mem[$80]<>255) }
  { and comment-out all code in SetEntryFromHost                           }
end;

procedure SetEntryFromHost(entry: boolean);
  var pipe0: text;
begin
  AssignPipe0(pipe0);
  rewrite(pipe0); close(pipe0);     { access or create (empty) file }
  if entry then erase(pipe0); { remove file }
end;



procedure ExitToHost;
{ Exit program by calling this.  DO NOT CALL HALT DIRECTLY! }
BEGIN
  SetEntryFromHost(TRUE);
  HALT;
END;

procedure ExitToShell;
VAR cmdptr: file;
BEGIN
  assign(cmdptr,SystemDrive+ShellName);
  execute(cmdptr)
END;

procedure RemovePipe(OldPipe: integer);
var name: XSTRING;
begin
    GenPipeName(OldPipe,name);
    REMOVE(name);
end;


FUNCTION ISDIGIT;
BEGIN
  ISDIGIT:=C IN [ORD('0')..ORD('9')]
END;

FUNCTION ISLOWER;
BEGIN
  ISLOWER:=C IN [ORD('a')..ORD('z')]
END;

FUNCTION ISLETTER;
BEGIN
  ISLETTER:=C IN [ORD('A')..ORD('Z'),ORD('a')..ORD('z')]
END;

FUNCTION CTOI;
VAR N,SIGN:INTEGER;
BEGIN
  WHILE (S[I]=BLANK) OR (S[I]=TAB)DO
    I:=I+1;
  IF(S[I]=MINUS) THEN
    SIGN:=-1
  ELSE
    SIGN:=1;
  IF(S[I]=PLUS)OR(S[I]=MINUS)THEN
    I:=I+1;
  N:=0;
  WHILE(ISDIGIT(S[I])) DO BEGIN
    N:=10*N+S[I]-ORD('0');
    I:=I+1
  END;
  CTOI:=SIGN*N
END;


FUNCTION GETKBD(VAR C:CHARACTER):CHARACTER;
VAR DONE:BOOLEAN;
    i:integer;
    ch:char;
BEGIN
  IF (KBDN<=0) THEN BEGIN
    KBDNEXT:=1;
    DONE:=FALSE;
    if (kbdn=-2) then begin kbdn:=0 end
    else if (kbdn<0)then done:=true;
    WHILE(NOT DONE) DO BEGIN
      kbdn:=kbdn+1;
      DONE:=TRUE;
      if (eof(TRM)) then kbdn:=-1
      else if eoln(TRM) then begin
        kbdn:=kbdn-1;kbdline[kbdn]:=NEWLINE
      end
      else if (MAXSTR-1<=kbdn) then begin
        if ReadingShellCmd then
          ERROR(' Line too long - ignored')
        else  begin
          writeln(' Line too long - truncated');
          kbdline[kbdn]:=newline
        end
      END
      ELSE begin
        read(TRM,ch);kbdline[kbdn]:=ord(ch);
        if (ord(ch)in ([0..31]-[DELETE1,DELETE2,NEWLINE])) then
           write('^',chr(ord(ch)+64)) else
        if (kbdline[kbdn]<>DELETE1) and (kbdline[kbdn]<>DELETE2) then
        ELSE begin
          write(chr(BACKSPACE),' ',chr(BACKSPACE));
          if (1<kbdn)then begin
            kbdn:=kbdn-2;
            if kbdline[kbdn+1]in[0..31] then
               write(chr(BACKSPACE),' ',chr(BACKSPACE))
          end
          ELSE kbdn:=kbdn-1
        end;
        done:=false
      end;
    END
  END;
  reset(TRM);
  IF(KBDN<=0)THEN
    C:=ENDFILE
  ELSE BEGIN
    C:=KBDLINE[KBDNEXT];
    KBDNEXT:=KBDNEXT+1;
    if (c=NEWLINE) then kbdn:=-2
    ELSE KBDN:=KBDN-1
  END;
  GETKBD:=C
END;



FUNCTION FGETCF(VAR FIL:TEXT):CHARACTER;
 VAR CH:CHAR;
 BEGIN
   {     -disabled -  $  I- do not hang on I/O error }
   IF(EOF(FIL))THEN
      FGETCF:=ENDFILE
   ELSE IF(EOLN(FIL)) THEN BEGIN
      READLN(FIL);
      FGETCF:=NEWLINE
   END
   ELSE BEGIN
     READ(FIL,CH);
     FGETCF:=ORD(CH);
   END;
   if (IOresult <> 0) then
      ERROR('FGETCF: I/O error');
   {$I+ }
 END;


FUNCTION GETCF(VAR C:CHARACTER;FD:FILEDESC):CHARACTER;
 BEGIN
   IF CMDFIL[FD] = STDIO
     THEN GETCF := GETKBD(C)
     ELSE BEGIN C := FGETCF(CMDText[FD]); GETCF := C; END;
 END;


FUNCTION GETC(VAR C:CHARACTER):CHARACTER;
BEGIN
  GETC:=GETCF(C,STDIN)
END;


PROCEDURE PUTCF(C:CHARACTER;FD:FILEDESC);
BEGIN
  (* assert CMDFIL[FD] <> STDIO *)
  if C=NEWLINE
    THEN WRITELN(CMDText[FD])
    ELSE WRITE(CMDText[FD],chr(C));
END;


PROCEDURE PUTC(C:CHARACTER);
BEGIN
  (* PUTCF(C,STDOUT); *)
  if C=NEWLINE
    then writeln(CMDText[STDOUT])
    else write(CMDText[STDOUT],chr(C));
END;


PROCEDURE FCOPY;
VAR
  C:CHARACTER;
BEGIN
  WHILE(GETCF(C,FIN)<>ENDFILE) DO
    PUTCF(C,FOUT)
END;


FUNCTION INDEX;
VAR I:INTEGER;
BEGIN
  I:=1;
  WHILE(S[I]<>C) AND (S[I]<>ENDSTR)DO
    I:=I+1;
  IF (S[I]=ENDSTR) THEN
    INDEX:=0
  ELSE
    INDEX:=I
END;

FUNCTION ESC;
BEGIN
  IF(S[I]<>ATSIGN) THEN
    ESC:=S[I]
  ELSE IF(S[I+1]=ENDSTR) THEN (*@ NOT SPECIAL AT END*)
    ESC:=ATSIGN
  ELSE BEGIN
    I:=I+1;
    IF(S[I]=ORD('n'))THEN ESC:=NEWLINE
    ELSE IF (S[I]=ORD('t')) THEN
      ESC:=TAB
    ELSE
      ESC:=S[I]
  END
END;

FUNCTION ISALPHANUM;
BEGIN
  ISALPHANUM:=C IN
    [ORD('A')..ORD('Z'),ORD('0')..ORD('9'),
    ORD('a')..ORD('z')]
END;

FUNCTION MAX;
BEGIN
  IF(X>Y)THEN
    MAX:=X
  ELSE
    MAX:=Y
END;


FUNCTION MIN;
BEGIN
  IF X<Y THEN
    MIN:=X
  ELSE
    MIN:=Y
END;


FUNCTION ISUPPER;
  BEGIN
    ISUPPER:=C IN [ORD('A')..ORD('Z')]
  END;


FUNCTION XLENGTH;
VAR
  N:INTEGER;
BEGIN
  N:=1;
  WHILE(S[N]<>ENDSTR)DO
    N:=N+1;
  XLENGTH:=N-1
END;

FUNCTION GETARG;
BEGIN
  IF((N<1)OR(CMDARGS<N))THEN
    GETARG:=FALSE
  ELSE BEGIN
    SCOPY(CMDLIN,CMDIDX[N],S,1);
    GETARG:=TRUE
  END
END;(*GETARG*)


  PROCEDURE SCOPY;
  BEGIN
    SRC[MAXSTR]:=ENDSTR;  { safety }
    WHILE(SRC[I]<>ENDSTR)DO BEGIN
      DEST[J]:=SRC[I];
      I:=I+1;
      J:=J+1
    END;
    DEST[J]:=ENDSTR
  END;


PROCEDURE STRNAME(VAR STR:STRING80;VAR XSTR:XSTRING);
VAR I:INTEGER;
BEGIN
  IF AppendFNamePAS
    THEN STR:='.PAS' else STR := '' ;
  I:=1;
  WHILE(XSTR[I]<>ENDSTR)DO BEGIN
    INSERT('X',STR,I);
    STR[I]:=CHR(XSTR[I]);
    I:=I+1
  END
END;

PROCEDURE NAMESTR(VAR XSTR:XSTRING; STR:STRING80);
VAR I: INTEGER;
BEGIN
  FOR I:= 1 TO length(STR) DO XSTR[I]:=ord(STR[I]);
  XSTR[1+length(STR)] := ENDSTR;
END;

FUNCTION FDALLOC:FILEDESC;
VAR DONE:BOOLEAN;
FD:FILEDESC;
BEGIN
  IF Debug THEN begin write('entry to FDALLOC: ');
            for FD := STDIN TO MAXOPEN DO case CMDFIL[FD] OF
            CLOSED: WRITE(' c'); STDIO:WRITE(' s'); OpenFile:write(' o'); end;
           writeln;
       end;
  FD:=STDIN;
  DONE:=FALSE;
  WHILE(NOT DONE) DO
    IF((CMDFIL[FD]=CLOSED) OR (FD=MAXOPEN))THEN
      DONE:=TRUE
    ELSE FD:=SUCC(FD);
  IF(CMDFIL[FD]<>CLOSED) THEN
    FDALLOC:=IOERROR
  ELSE BEGIN
    CMDFIL[FD]:= OpenFile;
      FDALLOC:=FD
  END
END;(*FDALLOC*)


FUNCTION CREATE(VAR NAME:XSTRING;MODE:FileModes):FILEDESC;
VAR
  FD:FILEDESC;
  SNM:STRING80;
BEGIN
(*$I-*)
  FD:=FDALLOC;
  IF(FD<>IOERROR)THEN BEGIN
  STRNAME(SNM,NAME);
  ASSIGN(CMDText[FD],SNM); REWRITE(CMDText[FD]);
  IF(IORESULT<>0)THEN BEGIN
    XCLOSE(FD);
    FD:=IOERROR
  END
END;
CREATE:=FD;
END;
(*$I+*)


PROCEDURE ERROR;
BEGIN
  WRITELN(STR);
  ActiveProcessQ := FALSE;
  if ToPipe then RemovePipe(PipeCount);
  ENDCMD;
END;


FUNCTION MUSTCREATE(VAR NAME:XSTRING;MODE:FileModes):FILEDESC;
VAR
  FD:FILEDESC;
BEGIN
  FD:=CREATE(NAME,MODE);
  IF(FD=IOERROR)THEN BEGIN
    PUTSTR(NAME,STDERR);
    ERROR(': can''t create file')
  END;
  MUSTCREATE:=FD
END;

FUNCTION NARGS;
BEGIN
  NARGS:=CMDARGS
END;

FUNCTION OPEN(VAR NAME:XSTRING;MODE:FileModes):FILEDESC;
VAR FD:FILEDESC;
SNM:STRING80;
BEGIN
  FD:=FDALLOC;
  IF(FD<>IOERROR) THEN BEGIN
    STRNAME(SNM,NAME);
    ASSIGN(CMDText[FD],SNM);
(*$I-*)
    IF TRUE (* MODE=IOREAD *)
      THEN RESET(CMDText[FD])
      ELSE REWRITE(CMDText[FD]);
    IF(IORESULT<>0) THEN BEGIN
      XCLOSE(FD);
      FD:=IOERROR
    END
(*$I+*)
  END;
  OPEN:=FD
END;


PROCEDURE REMOVE;
VAR
  FD:FILEDESC;
BEGIN
  FD:=OPEN(NAME,IOREAD);
  IF(FD=IOERROR)THEN BEGIN
     PUTSTR(NAME,STDERR);
     WRITELN(': can''t remove file');
  END
  ELSE BEGIN
    IF Debug THEN BEGIN PUTSTR(NAME,STDERR); WRITELN(' being removed'); END;
    (* assert CMDFILE[FD]=OpenFile *)
    CLOSE(CMDText[FD]); ERASE(CMDText[FD]);
  END;
  CMDFIL[FD]:=CLOSED
END;

FUNCTION GETLINE(VAR STR:XSTRING;FD:FILEDESC; SIZE:INTEGER):BOOLEAN;
VAR I:INTEGER;
    DONE:BOOLEAN;
    CH:CHARACTER;
BEGIN
 I:=0;
 REPEAT
   DONE:=TRUE;
   CH:=GETCF(CH,FD);
   IF(CH=ENDFILE) THEN
     I:=0
   ELSE IF (CH=NEWLINE) THEN BEGIN
     I:=I+1;
     STR[I]:=NEWLINE
   END
   ELSE IF (SIZE-2<=I) THEN BEGIN
     WRITELN('LINE TOO LONG');
     I:=I+1;
     STR[I]:=NEWLINE
   END
   ELSE BEGIN
     DONE:=FALSE;
     I:=I+1;
     STR[I]:=CH
   END
 UNTIL(DONE);
 STR[I+1]:=ENDSTR;
 GETLINE:=(0<I)
END;(*GETLINE*)



PROCEDURE ENDCMD;
VAR FD:FILEDESC;
BEGIN
  if FromPipe then RemovePipe(PipeCount-ORD(ToPipe));
  if not ToPipe then PipeCount := 0;
  FOR FD:=STDIN TO MAXOPEN DO  XCLOSE(FD);
  ExitToShell;
END;

PROCEDURE XCLOSE;
BEGIN
  IF CMDFIL[FD] = OpenFile THEN CLOSE(CMDText[FD]);
  CMDFIL[FD]:=CLOSED
END;

FUNCTION ADDSTR;
BEGIN
  IF(J>MAXSET)THEN
    ADDSTR:=FALSE
  ELSE BEGIN
    OUTSET[J]:=C;
    J:=J+1;
    ADDSTR:=TRUE
  END
END;

PROCEDURE PUTSTR;
VAR I:INTEGER;
BEGIN
  I:=1;
  WHILE(STR[I]<>ENDSTR) DO BEGIN
    PUTCF(STR[I],FD);
    I:=I+1
  END
END;

FUNCTION MUSTOPEN(VAR NAME:XSTRING;MODE:FileModes):FILEDESC;
VAR FD:FILEDESC;
BEGIN
  FD:=OPEN(NAME,MODE);
  IF(FD=IOERROR)THEN BEGIN
    PUTSTR(NAME,STDERR);
    ERROR(': can''t open file.')
  END;
  MUSTOPEN:=FD
END;


FUNCTION ITOC;
BEGIN
  IF(N<0)THEN BEGIN
    S[I]:=ORD('-');
    ITOC:=ITOC(-N,S,I+1);
  END
  ELSE BEGIN
    IF (N>=10)THEN
      I:=ITOC(N DIV 10,S, I);
    S[I]:=N MOD 10 + ORD('0');
    S[I+1]:=ENDSTR;
    ITOC:=I+1;
  END
END;

PROCEDURE PUTDEC;
VAR I,ND:INTEGER;
  S:XSTRING;
BEGIN
  ND:=ITOC(N,S,1);
  FOR I:=ND TO W DO
    PUTC(BLANK);
  FOR I:=1 TO ND-1 DO
    PUTC(S[I])
END;

FUNCTION EQUAL;
VAR
  I:INTEGER;
BEGIN
  I:=1;
  WHILE(STR1[I]=STR2[I])AND(STR1[I]<>ENDSTR) DO
    I:=I+1;
  EQUAL:=(STR1[I]=STR2[I])
END;