PROGRAM ltype (cmd, input, output);

(*$n-,d- for no run-time checks nor line numbers *)

(* equivalent to "type", but extracts from library *)
(* Run with:                                       *)
(*   B>runpcd ltype [-libfname] {componentname}    *)
(* where the "-" signals the presence of the       *)
(* optional libfname entry.  libfname defaults to  *)
(* "LIBRARY.LBR".  [] encloses optional entries,   *)
(* {} encloses entries that may be repeated.       *)
(* Initial version 14 Dec. 1980. By C.B. Falconer. *)
(* 1.1 - corrected date calculation.               *)

  CONST
    ver           = ' Ver. 1.1';
    fnmsize       = 28;
    binrcdmax     = 63;
    binrcdsize    = 64;    (* binrcdmax + 1 *)

  TYPE
    byte          = char;   (* packed 0..255 *)
    fname         = PACKED ARRAY[1..fnmsize] OF char;
    binfptr       = 0..binrcdmax;
    binfile       = FILE OF ARRAY[binfptr] OF byte;
    err           = (eoferr, notlib, notfound, libneeded, idneeded);

  VAR
    cmd           : text;
    libfile       : binfile;
    libfname,
    component     : fname;
    i,
    sz,
    crcwd,
    date          : integer;   (* from lib directory for component *)
    delimiters    : SET OF char; (* for file names *)

(*$i'binfiles.inc.pascal'*)
(*$i'skipblks.inc.pascal'*)
(*$i'libentry.inc.pascal'*)
(*$i'drtodate.inc.pascal'*)
(*$i'skipto.inc.pascal'*)
(*$i'skprdrct.inc.pascal'*)
  PROCEDURE help;

    BEGIN (* help *)
    writeln('LTYPE (cmd, input, output);', ver);
    writeln(' equivalent to "type", but extracts from library');
    writeln(' Run with:');
    writeln('   B>runpcd ltype [-libfname] {componentname}');
    writeln(' where the "-" signals the presence of the');
    writeln(' optional libfname entry.  libfname defaults to');
    writeln(' "LIBRARY.LBR".  [] encloses optional entries,');
    writeln(' {} encloses entries that may be repeated.');
    END; (* help *)

  (* 1----------------1 *)

  PROCEDURE signal(x : err);

    BEGIN (* signal *)
    writeln; write('*** ERROR *** ');
    CASE x OF
idneeded:
      write('No component selected');
notlib:
      write('Not a library: ', libfname);
eoferr:
      BEGIN
      write('EOF - library faulty: ', libfname);
      terminate;
      END;
notfound:
      write('Can''t find: ', component);
libneeded:
      write('No library: ', libfname);
      END; (* case *)
    writeln;
    IF x <> notfound THEN help;
    END; (* signal *)

  (* 1----------------1 *)

  PROCEDURE setname(VAR n : fname);
  (* parse the name from the input stream in cmd   *)

    VAR
      i      : integer;

    BEGIN (* setname *)
    i := 1;
    WHILE cmd^ <> ' ' DO
      IF i < fnmsize THEN BEGIN
        read(cmd, n[i]); i := succ(i); END
      ELSE get(cmd);
    FOR i := i TO fnmsize DO n[i] := ' ';
    END; (* setname *)

  (* 1----------------1 *)

  PROCEDURE dumpcomponent(sz : integer);
  (* from the previously positioned libfile.  Note that *)
  (* sz must be used to control the EOF in case no eof  *)
  (* marker is found in the component.                  *)

    CONST
(*$s-*)
      eofmark     = (:26:);
      cr          = (:13:);
      lf          = (:10:);
      nul         = (:0:);
(*$s+*)

    VAR
      lasteoln    : boolean;   (* last output was eoln *)
      sector      : ARRAY[0..128] OF byte;

    (* 2----------------2 *)

    FUNCTION writesector : boolean;
    (* all sorts of nasty garbage to convert to text *)
    (* return false when eofmark found *)

      VAR
        endptr,
        pointer,
        piecesz     : integer;

      (* 3----------------3 *)

      FUNCTION fillsector : boolean;

        BEGIN (* fillsector *)
        IF sz > 0 THEN BEGIN
(*$s-*)   sector[0 FOR binrcdsize] := libfile^;
          IF eof(libfile) THEN signal(eoferr);
          get(libfile);
          sector[binrcdsize FOR binrcdsize] := libfile^;
          IF eof(libfile) THEN signal(eoferr);
(*$s+*)   get(libfile); sz := sz - 1; fillsector := true; END
        ELSE BEGIN
          sector[0] := eofmark; fillsector := false; END;
        END; (* fillsector *)

      (* 3----------------3 *)

      PROCEDURE skiplfs;

        BEGIN (* skiplfs *)
        WHILE (pointer < 128) AND (sector[pointer] = lf) DO
          pointer := succ(pointer);
        END; (* skiplfs *)

      (* 3----------------3 *)

(*$x+,d-,s- illegal addresses (sector[pointer FOR 128])in here *)
      BEGIN (* writesector *)
      IF fillsector THEN BEGIN
        writesector := true; pointer := 0; skiplfs;
        WHILE pointer < 128 DO
          IF sector[pointer] <> eofmark THEN BEGIN
            endptr := scanfor(eofmark, sector[pointer], 128-pointer);
            piecesz := scanfor(cr, sector[pointer], 128 - pointer)-1;
            IF piecesz < 0 THEN piecesz := 128 - pointer
            ELSE lasteoln := false;
            IF (endptr <> 0) THEN (* fix illegal eofs *)
              IF piecesz >= endptr THEN piecesz := endptr - 1;
            write(sector[pointer FOR 128] : piecesz); (* 0 sz works *)
            pointer := pointer + piecesz;
            IF pointer < 128 THEN BEGIN
              writeln; (* found a cr *); lasteoln := true;
              pointer := succ(pointer); skiplfs; END;
            END
          ELSE BEGIN (* force exit *)
            pointer := 128; writesector := false; END;
          END
      ELSE writesector := false;
      END; (* writesector *)
(*$x- restore options *)

    (* 2----------------2 *)

    PROCEDURE writedate(date : integer);
    (* 1 corresponds to 1 Jan 1978 *)

      VAR
        year, month, day  : integer;

      (* 3----------------3 *)

      PROCEDURE leadingzeroes(i : integer); (* 0..99 only *)

        BEGIN (* leadingzeroes *)
        IF i < 10 THEN write('0');
        write(i : 1);
        END; (* leadingzeroes *)

      (* 3----------------3 *)

      BEGIN (* writedate *)
      drtodate(date, year, month, day);
      write(' '); leadingzeroes(year MOD 100);
      write('/'); leadingzeroes(month);
      write('/'); leadingzeroes(day);
      END; (* writedate *)

    (* 2----------------2 *)

    BEGIN (* dumpcomponent *)
    writeln;
    write(sz : 1, ' records in (',
          libfname : scanfor(' ', libfname, fnmsize)-1, ') ',
          component);
    IF date > 0 THEN BEGIN
      write(' Installed'); writedate(date); END;
    writeln; lasteoln := true;
    WHILE writesector DO (* loop *);
    IF NOT lasteoln THEN writeln;
    END; (* dumpcomponent *)

  (* 1----------------1 *)

  BEGIN (* ltype *)
  reset(cmd); skipredirection(cmd);
  IF eoln(cmd) OR eof(cmd) THEN help
  ELSE BEGIN
    FOR i := 1 TO fnmsize DO libfname[i] := ' ';
    component := libfname;
    IF cmd^ = '-' THEN BEGIN
      get(cmd); setname(libfname); END;
    skipredirection(cmd);
(*$s-*)
    IF libfname[1] = ' ' THEN libfname[1 FOR 12] := 'LIBRARY.LBR ';
    IF scanfor('.', libfname, fnmsize) = 0 THEN (* insert .LBR *)
      libfname[scanfor(' ', libfname, fnmsize) FOR 5] := '.LBR ';
    IF exists(libfile, libfname) THEN BEGIN
      filename(libfile, libfname); (* For system name *)
(*$s+*)
      IF libentry(libfile, component, sz, crcwd, date) THEN BEGIN
        (* blank component, found a directory *)
        IF eof(cmd) OR eoln(cmd) THEN signal(idneeded)
        ELSE
          REPEAT
            setname(component);
            IF libentry(libfile, component, sz, crcwd, date) THEN
              dumpcomponent(sz)
            ELSE signal(notfound);
            skipredirection(cmd);
          UNTIL eof(cmd) OR eoln(cmd); END
      ELSE signal(notlib); END
    ELSE signal(libneeded); END;
  END. (* ltype *)