TURBO-Programm-Lister mit einigen interessanten Eigenschaften 
=============================================================

von W. Riemer

Au de TURBO-Pascal-Diskett befinde sic ei einfache Programm-
Lister Diese wurd u einig positiv Eigenschafte erweitert 
un zwar:

- Seiten- und Zeilennumerierung,
- Kopfzeil a Begin jede Seit mi Dateiname Datei-
  Erstellungsdatu un -zeit sowi Datu un Zei de Ausdrucks,
- di Mglichkeit INCLUDE-Dateie au Wunsc automatisc i di 
  List z bernehmen,
- Abbrechen des Druckvorgangs durch Drcken einer Taste.

Abgesehe vo de obe erwhnte Eigenschafte sin vielleich auc 
di vo Betriebssystemfunktione Gebrauc machende Routine f 
de eine ode andere TURBO-Fa vo Interesse De vo Auto 
stammend Cod is zu leichtere Unterscheidbarkei i Gegensat 
zu Originaltex ausschlielic i Groschrif gehalten.

program TPL;   (* TURBO PROGRAM LISTER *)

(*
   SOURC LISTE  PROGRA  Versio 1.00B ADAPTE b RIEME 86/04/0 
   FO MS-DO (PC-DOS)

   This is a simple program to list your TURBO PASCAL source programs.


   PSEUDO CODE
   1.  Find Pascal source file to be listed
   2.  Initialize program variables
   3.  Open main source file
   4.  Process the file
       a  Rea  characte int lin buffe unti linebuffe ful o 
           eoln;
       b.  Search line buffer for include file.
       c.  If line contains include file command:
             The proces includ fil an extrac comman fro lin 
               buffer
             Else print out the line buffer.
       d.  Repeat step 4.a thru 4.c until eof(main file);

   INSTRUCTIONS
   1.  Compile and run the program using the TURBO.COM compiler.
   2.  Two ways to print a file
       a.  Run from TURBO in memory:
           Type "R" and enter a file name to print when prompted.
       b.  Run the program from DOS
           Type TPL and enter a file name to print when prompted.

*)

Const
      PageWidth = 132;
      PrintLength = 62;
      PathLength  = 72;
      FormFeed = #12;

Type
      WorkString = String(.126.);
      FileName  = String(.PathLength.);
      STR2 = STRING (. 2 .);
      STR6 = STRING (. 6 .);
      DateiNameTyp = STRING (.14.);
      RegRecord = RECORD AX, BX, CX, DX, 
                         BP, SI, DI,DS, ES, FLAGS: INTEGER
                  END;

Var
      CurRow : integer;
      MainFileName: FileName;
      MainFile: text;
      search1,
      search2: STRING(.5.);
      search3,
      search4: string(.6.);
      DATE: STRING (. 10 .);
      TIME: STRING (. 8 .);
      ST: STR6;
      MFNAME: string(.12.);
      OPENOK: BOOLEAN;
      POSPUNKT: INTEGER;
      PASSTR: STRING(.4.);
      INCLUDE: BOOLEAN;
      C: CHAR;
      PAGENR, LINENR: INTEGER;
       R: RegRecord;
       Dateiname: DateiNameTyp;
       Datum, Zeit: STR6;
       OldDrive: Char;
       CurDrive: CHAR;

(* PROZEDUREN FUER ZUGRIFF AUF REAL TIME CLOCK MS-DOS
   AUFRUF: RTC (m,s); m ... MODUS: 'D' FUER DATUM, 'Z' FUER ZEIT.
                      s ... STRING(.6.), ENTHAELT JJMMTT BZW. HHMMSS. *)

PROCEDURE RTC (MODUS: CHAR; VAR S: STR6);
TYPE STR2 = STRING (.2.);
VAR A: BYTE;
    X, Y, Z: STR2;
    Register: RECORD AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: INTEGER
              END;

PROCEDURE ByteToString(A: BYTE; VAR STR: STR2);
VAR S1, S2: STRING(.1.);
BEGIN S1:=CHR(48 + A DIV 10);
      S2:=CHR(48 + A MOD 10);
      STR:=S1+S2
END;

BEGIN WITH Register DO
      CASE MODUS OF
           'Z','z': BEGIN AX:=$2C00;
                          MSDOS(Register);
                          ByteToString(HI(CX),X);
                          ByteToString(LO(CX),Y);
                          ByteToString(HI(DX),Z)
                    END;
           'D','d': BEGIN AX:=$2A00;
                          MSDOS(Register);
                          A:=CX-1900;
                          ByteToString(A,X);
                          ByteToString(HI(DX),Y);
                          ByteToString(LO(DX),Z)
                    END
      END;
      S:=X+Y+Z
END;

FUNCTION CurrentDrive: CHAR;
TYPE RegRecord = RECORD 
                  AX, BX, CX, DX, BP, SI, DI,DS, ES, FLAGS: INTEGER
                 END;
VAR R: RegRecord;
BEGIN R.AX:=$1900;
      MSDOS(R);
      CurrentDrive:=CHAR((R.AX AND $FF) + ORD('A'))
END;

PROCEDURE SelectDrive(Drive: CHAR);
TYPE RegRecord = RECORD 
                   AX, BX, CX, DX, BP, SI, DI,DS, ES, FLAGS: INTEGER
                 END;
VAR R: RegRecord;
BEGIN R.AX:=$0E00;
      R.DX:=ORD(Drive)-ORD('A');
      MSDOS(R)
END;

PROCEDURE CreationDate (DateiName: DateiNameTyp; VAR Datum, Zeit: STR6);
TYPE DateiMaskeTyp = ARRAY (.1..12.) OF CHAR;
VAR DTA: ARRAY (. 1 .. 43 .) OF BYTE;
    DateiMaske: DateiMaskeTyp;
    I: BYTE;

PROCEDURE NameInMaske
   (DateiName: DateiNameTyp; VAR DateiMaske: DateiMaskeTyp);
VAR I, K: BYTE;
    P1, P2: ^BYTE;
BEGIN IF COPY(DateiName,2,1)=':'
         THEN BEGIN OldDrive:=CurrentDrive;
                    SelectDrive(COPY(DateiName,1,1));
                    I:=LENGTH(DateiName);
                    FOR K:=1 TO I-2 DO 
                         DateiName(.K.):=DateiName(.K+2.);
                    FOR K:=I-1 TO SIZEOF(DateiName)-1 DO 
                         DateiName(.K.):=' ';
              END;
      P1 := PTR(SEG(DateiName),OFS(DateiName)+1);
      P2 := PTR(SEG(DateiMaske),OFS(DateiMaske));
      FILLCHAR(DateiMaske,12,32);
      I:=1;
      WHILE (I<=9) AND (P1^<>ORD('.')) DO
            BEGIN P2^ := P1^;
                  P1 := PTR (SEG(P1^),OFS(P1^)+1);
                  P2 := PTR (SEG(P2^),OFS(P2^)+1);
                  I:=I+1
            END;
      IF P1^=ORD('.')
         THEN BEGIN P2 := PTR (SEG(P2^),OFS(P2^)+9-I);
                    MOVE (P1^,P2^,4)
              END;
      P2 := PTR (SEG(DateiMaske),OFS(DateiMaske)+8);
      P2^:=ORD('.')
END;

PROCEDURE ConvertTime (VAR Wert: BYTE; VAR STRG: STR6);
VAR I: ^INTEGER;
    J, K, L: INTEGER;
    Stunden, Minuten, Sekunden: STRING(.2.);

BEGIN I:=PTR(SEG(Wert),OFS(Wert));
      J:=I^ MOD 32 * 2; (* Sekunden *)
      I^:=I^ DIV 32;
      K:=I^ MOD 64;     (* Minuten  *)
      I^:=I^ DIV 64;
      L:=I^;            (* Stunden  *)
      STR(L:2,Stunden);
      STR(K:2,Minuten);
      STR(J:2,Sekunden);
      STRG:=Stunden+Minuten+Sekunden
END;

PROCEDURE ConvertDate (VAR Wert: BYTE; VAR STRG: STR6);
VAR I: ^INTEGER;
    J, K, L: INTEGER;
    Jahr, Monat, Tag: STRING (.2.);

BEGIN I:=PTR(SEG(Wert),OFS(Wert));
      J:=I^ MOD 32;     (* Tag   *)
      I^:=I^ DIV 32;
      K:=I^ MOD 16;     (* Monat *)
      I^:=I^ DIV 16;
      L:=I^ + 1980 ;    (* Jahr  *)
      STR(L - L DIV 100 * 100:2,Jahr);
      STR(K:2,Monat);
      STR(J:2,Tag);
      STRG:=Jahr+Monat+Tag
END;

BEGIN NameInMaske(DateiName,DateiMaske);
      R.AX := $1A00;  (* setze DTA *)
      R.DS := SEG(DTA);
      R.DX := OFS(DTA);
      MSDOS(R);  (* MSDOS erfaehrt DTA-Adresse *)

      FILLCHAR(DTA,43,0);

      R.AX := $4E00;   (* erste uebereinstimmende Datei suchen *)
      R.CX := $0000;   (* Dateiattribut: gewoehnliche Dateien  *)
      R.DS := SEG(DateiMaske);
      R.DX := OFS(DateiMaske);
      MSDOS(R);  (* MSDOS uebertraegt DIR-Eintrag in DTA *)

      IF (R.AX AND $FF) = 0   (* kein Fehler *)
         THEN BEGIN ConvertTime (DTA (.23.),Zeit);
                    ConvertDate (DTA (.25.),Datum)
              END
         ELSE BEGIN Datum := '      ';
                    Zeit  := '      '
              END
END;



  Procedure Initialize;
  begin
    PAGENR:=1;
    LINENR:=1;
    CurRow := 0;
    clrscr;
    search1 := '{$'+'I';
    search2 := '{$'+'i';
    search3 := '(*$'+'I';
    search4 := '(*$'+'i';
  end (* initialize *);

  Function Open(var fp:text; name: Filename): boolean;
  begin
    Assign(fp,Name);
    (*$I-*)
    reset(fp);
    (*$I+*)
    If IOresult <> 0 then
     begin
      Open := False;
      close(fp);
     end
    else
      Open := True;
  end (* Open *);

  Procedure OpenMain;
  begin

    WRITE ('Print Include-Files ? Y/N: ');
    READ (KBD,C);
    IF C IN (.'Y','y'.) THEN INCLUDE:=TRUE ELSE INCLUDE:=FALSE;
    WRITELN;
    OPENOK:=FALSE;
    WHILE NOT OPENOK DO
      BEGIN If ParamCount = 0 then
            begin
               Write('Enter filename: ');
               readln(MainFileName);
               POSPUNKT:=POS('.',MAINFILENAME);
               IF POSPUNKT=0 THEN MAINFILENAME:=MAINFILENAME + '.PAS';
               MFNAME:=COPY(MAINFILENAME,1,12);
               CreationDate(MainFileName,Datum,Zeit);
            end
        else
            begin
              MainFileName := ParamStr(1);
            end;
        OPENOK:=Open(MainFile,MainFileName);
            IF NOT OPENOK THEN 
               Writeln('ERROR -- File not found:  ',MainFileName)
     end
  end (* Open Main *);

  Procedure VerticalTab(VERTICALTABLENGTH: INTEGER);
  var i: integer;
  begin
    for i := 1 to VerticalTabLength do writeln(lst);
  end (* vertical tab *);

PROCEDURE KOPFZEILE;
PROCEDURE BLANKNULL(VAR S: STR6);
VAR I: BYTE;
BEGIN FOR I:=1 TO 6 DO
          IF S(.I.)=' ' THEN S(.I.):='0'
END;
BEGIN BLANKNULL(Zeit);
      BLANKNULL(Datum);
      WRITELN (LST,'TPL-Liste der Datei: ',MAINFILENAME,
                   ', Erstellung: 19',Datum,
                   ', Zeit: ',Zeit,
                   ', Seite ',PAGENR);
      PAGENR:=PAGENR+1
END;

  Procedure ProcessLine(PrintStr: WorkString);
  begin
    CurRow := Succ(CurRow);
    if length(PrintStr) > PageWidth then CurRow := Succ(CurRow);
    if CurRow > PrintLength Then
    begin
      Write(lst,FormFeed);
      KOPFZEILE;
      VerticalTab(1);
      CurRow := 1;
    end;
    Writeln(lst,LINENR:4,'  ',PrintStr);
    LINENR:=LINENR+1
  end (* Process line *);

  Procedure ProcessFile;

  var
    LineBuffer: WorkString;

     Function IncludeIn(VAR CurStr: WorkString): Boolean;
     Var ChkChar: char;
         column: integer;
     begin
       ChkChar := '-';
       column := pos(search1,CurStr);
       if column <> 0 then
         chkchar := CurStr(.column+3.)
       else
       begin
         column := Pos(search3,CurStr);
         if column <> 0 then
           chkchar := CurStr(.column+4.)
         else
         begin
           column := Pos(search2,CurStr);
           if column <> 0 then
             chkchar := CurStr(.column+3.)
           else
           begin
             column := Pos(search4,CurStr);
             if column <> 0 then
               chkchar := CurStr(.column+4.)
           end;
         end;
       end;
       if ChkChar in (.'+','-'.) then IncludeIn := False
       Else IncludeIn := True;
     end (* IncludeIn *);


     Procedure ProcessIncludeFile(VAR IncStr: WorkString);

     var NameStart, NameEnd: integer;
         IncludeFile: text;
         IncludeFileName: Filename;

       Function Parse(IncStr: WorkString): WorkString;
       begin
         NameStart := pos('$I',IncStr)+2;
        while IncStr(.NameStart.) = ' ' do
           NameStart := Succ(NameStart);
         NameEnd := NameStart;
         while (not (IncStr(.NameEnd.) in (.' ','}','*'.)))
              AND ((NameEnd - NameStart) <= PathLength)
              do NameEnd := Succ(NameEnd);
         NameEnd := Pred(NameEnd);
         POSPUNKT:=POS('.',INCSTR);
         IF POSPUNKT=0 THEN PASSTR:='.PAS' ELSE PASSTR:=' ';
         Parse := copy(IncStr,NameStart,(NameEnd-NameStart+1)) + 
                    PASSTR;
       end (* Parse *);

     begin  (* Process include file *)
       IncludeFileName := Parse(IncStr);

       If not Open(IncludeFile,IncludeFileName) then
       begin
         LineBuffer := 'ERROR -- Include file not found:  ' + 
                         IncludeFileName;
         ProcessLine(LineBuffer);
       end
       Else
       begin
         while not eof(IncludeFile) do
         begin
           Readln(IncludeFile,LineBuffer);
           ProcessLine(LineBuffer);
         end;
         close(IncludeFile);
       end;
     end (* Process include file *);

  begin  (* Process File *)
    VerticalTab(1);
    Writeln('Printing . . . , interrupt by pressing any key');
   while not eof(mainfile) do
    begin
     IF KEYPRESSED THEN BEGIN WRITELN (LST,FORMFEED);
                              HALT
                        END;
     Readln(MainFile,LineBuffer);
      if (IncludeIn(LineBuffer) AND INCLUDE) then
         ProcessIncludeFile(LineBuffer)
      else
         ProcessLine(LineBuffer);
    end;
    close(MainFile);
    write(lst,FormFeed);
  end (* Process File *);

PROCEDURE TITELZEILE;
BEGIN RTC('D',ST);
      DATE:='19'+COPY(ST,1,2)+'-'+COPY(ST,3,2)+'-'+COPY(ST,5,2);
      WRITE (LST,'DATUM: ',DATE,',  ');
      RTC('Z',ST);
      TIME:=COPY(ST,1,2)+':'+COPY(ST,3,2)+':'+COPY(ST,5,2);
      WRITELN (LST,'ZEIT: ',TIME);
      KOPFZEILE
END;

Begin

  Initialize;
  OpenMain;
  TITELZEILE;
  ProcessFile;
END.
.pa
