(***************************************************************************
 :Program.    DLP.mod
 :Author.     Jürgen Weinelt
 :Address.    Zur Kanzel 1, D-8783 Hammelburg
 :History.    v1.10 Jürgen Weinelt 06-Nov-90 initial
 :Copyright.  Public Domain
 :Language.   Modula-II
 :Translator. M2Amiga
 :Contents.   Disk Label Printer
 **************************************************************************)



MODULE DLP;

(**************************************************************************)
(*                                                                        *)
(*  DISK LABEL PRINTER  ***  RELEASE V1.10 (MODULA-2 VERSION)             *)
(*                                                                        *)
(*  Written in 1989 by Jürgen Weinelt                                     *)
(*                                                                        *)
(*  DLP was developed and successfully compiled with M2Amiga              *)
(*  M2Amiga is produced/distributed by A+L AG, Switzerland                *)
(*  Special thanks to A+L for this really fantastic compiler              *)
(*                                                                        *)
(*  Last changed 06-NOV-90                                                *)
(*                                                                        *)
(*  THIS IS PUBLIC DOMAIN. DO WHATEVER YOU LIKE, BUT PLEASE:              *)
(*     (1) keep my name somewhere in here (when will i be famous...?)     *)
(*     (2) comment your changes somewhere                                 *)
(*     (3) if you enhance this significantly, i'd be glad if you sent     *)
(*         me a copy of it.                                               *)
(*                                                                        *)
(*  This is my address:                                                   *)
(*    Jürgen Weinelt                                                      *)
(*    Zur Kanzel 1                                                        *)
(*    D-8783 Hammelburg                                                   *)
(*    Germany                                                             *)
(*                                                                        *)
(*  Sorry, no email.  German "Bundespost" has a monopoly and makes you    *)
(*  pay for it...                                                         *)
(*                                                                        *)
(**************************************************************************)



FROM ASCII      IMPORT  ff,lf,csi,esc,nul;
FROM Arguments  IMPORT  NumArgs, GetArg;
FROM Arts       IMPORT  Assert, TermProcedure;
FROM Conversions IMPORT ValToStr;
FROM Dos        IMPORT  Lock, UnLock, Examine, ExNext, Open, Close,
                        Read, Write, WaitForChar, Delay,
                        FileInfoBlock, FileInfoBlockPtr, FileLockPtr,
                        sharedLock, oldFile, newFile, FileHandlePtr;
FROM Exec       IMPORT  AllocMem, FreeMem, MemReqs, MemReqSet;
FROM InOut      IMPORT  WriteLn, WriteString;
FROM Strings    IMPORT  Compare, Delete, Insert, Length, Occurs, last;
FROM SYSTEM     IMPORT  ADR, ADDRESS;

CONST memSize=SIZE(FileInfoBlock);
      strSize=32;
      outSize=25;
      maxout=12;
      maxnum=255;
      entries=16;
      num=10;
      anRef=" 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZäöüÄÖÜ.,;:-?!+*'§$%&/()=#<>_";

TYPE  name=ARRAY [0..strSize] OF CHAR;
      prname=ARRAY [0..outSize] OF CHAR;
      ftype=LONGINT;
      string=ARRAY [0..80] OF CHAR;

VAR   diskname, dummyn: name;
      filename: ARRAY [0..maxnum] OF name;
      prn: ARRAY [0..maxnum] OF prname;
      dummyt: ftype;
      filetype: ARRAY [0..maxnum] OF ftype;
      cnt0, cnt1, counter, dy, index, len, loop, loop2, intdummy: INTEGER;
      pr: ARRAY [0..maxnum] OF INTEGER;
      fibPtr: FileInfoBlockPtr;
      filelock, ptr: FileLockPtr;
      flag,retcode: BOOLEAN;
      yn, ch: CHAR;
      iofile, prtfile: FileHandlePtr;
      buf, rawname, progname: string;

PROCEDURE CoolDown;
 BEGIN
  IF (fibPtr # NIL) THEN
   FreeMem(fibPtr,memSize);
  END;
  IF (ptr # NIL) THEN
   UnLock(ptr);
  END;
  IF (iofile # NIL) THEN
   Close(iofile);
  END;
  IF (prtfile # NIL) THEN
   Close(prtfile);
  END;
 END CoolDown;

PROCEDURE Print (c: ARRAY OF CHAR; n:INTEGER);
 VAR l,dmy: INTEGER;
     b: string;
 BEGIN
  dmy:=Write(iofile,ADR(c),Length(c));
  IF (n>0) THEN
   FOR l:=0 TO n-1 DO
    b[l]:=lf;
   END;
   dmy:=Write(iofile,ADR(b),n);
  END;
 END Print;

PROCEDURE Prt (c: ARRAY OF CHAR; n:INTEGER);
 VAR l,dmy: INTEGER;
     b: string;
 BEGIN
  dmy:=Write(prtfile,ADR(c),Length(c));
  IF (n>0) THEN
   FOR l:=0 TO n-1 DO
    b[l]:=lf;
   END;
   dmy:=Write(prtfile,ADR(b),n);
  END;
 END Prt;

PROCEDURE PrintINT (x: INTEGER; n:INTEGER);
 VAR l,dmy: INTEGER;
     b: string;
     err,sign: BOOLEAN;
 BEGIN
  sign:=TRUE;
  ValToStr(x,sign,b,10,-5,nul,err);
  dmy:=Write(iofile,ADR(b),Length(b));
  IF (n>0) THEN
   FOR l:=0 TO n-1 DO
    b[l]:=lf;
   END;
   dmy:=Write(iofile,ADR(b),n);
  END;
 END PrintINT;

PROCEDURE PrintC (c: CHAR);
 VAR dmy: INTEGER;
 BEGIN
  dmy:=Write(iofile,ADR(c),1);
 END PrintC;

PROCEDURE Cls;
 BEGIN
  PrintC(ff);
 END Cls;

PROCEDURE RawGet (VAR c: CHAR);
 VAR n: INTEGER;
     booldummy: BOOLEAN;
 BEGIN
  c:=nul;
  WHILE (c=nul) DO
   booldummy:=WaitForChar(iofile,1000000000);   (* wait upto 10000 secs *)
   n:=Read(iofile,ADR(c),1);
   IF (n=0) THEN
    c:=nul;
   END;
  END;
 END RawGet;

PROCEDURE Get (VAR c: CHAR);
 VAR c0,c1: CHAR;
 BEGIN
  RawGet(c0);
  IF (c0=csi) THEN
   RawGet(c0);
   CASE INTEGER(c0) OF
    |65:     c:=CHAR(28);   (* crsr up      *)
    |66:     c:=CHAR(29);   (* crsr down    *)
    |67:     c:=CHAR(30);   (* crsr right   *)
    |68:     c:=CHAR(31);   (* crsr left    *)
    |63:     RawGet(c0);
             c:=CHAR(139);  (* help         *)
    |48..57: RawGet(c1);    (* function key *)
             CASE INTEGER(c1) OF
              |126: c:=CHAR(129+INTEGER(c0)-48);    (* f1..f10      *)
              |48..57:                              (* f11..f20     *)
                    RawGet(c0);
                    c:=CHAR(140+INTEGER(c1)-48);
              |0..47,58..125,127..255:
             END;
    |0..47,58..62,64,69..255:
   END;
  ELSE
   c:=c0;
  END;
 END Get;

PROCEDURE PrintAt(x,y: INTEGER; c: ARRAY OF CHAR; n: INTEGER);
 VAR p,q,r: ARRAY [0..20] OF CHAR;
     err,sign: BOOLEAN;
     l,cnt: INTEGER;
     x0,y0: LONGINT;
 BEGIN
  sign:=TRUE;
  x0:=LONGINT(x);
  y0:=LONGINT(y);
  ValToStr(x0,sign,r,10,-5,nul,err);
  ValToStr(y0,sign,q,10,-5,nul,err);
  cnt:=0;
  p[cnt]:=csi;
  FOR l:=0 TO Length(q)-1 DO
   cnt:=cnt+1;
   p[cnt]:=q[l];
  END;
  cnt:=cnt+1;
  p[cnt]:=CHAR(59);
  FOR l:=0 TO Length(r)-1 DO
   cnt:=cnt+1;
   p[cnt]:=r[l];
  END;
  cnt:=cnt+1;
  p[cnt]:=CHAR(72);
  p[cnt+1]:=nul;
  Print(p,0);
  Print(c,n);
 END PrintAt;

 (* InputLine (x,y,b,a,ref,n)                             *)
 (*  x,y: position in window                              *)
 (*  b  : string to be printed as description             *)
 (*  a  : string to be read                               *)
 (*  ref: reference string contains all legal characters  *)
 (*  n  : number of chars to be read                      *)
PROCEDURE InputLine(    x,y: INTEGER;
                        b:   ARRAY OF CHAR;
                    VAR a:   ARRAY OF CHAR;
                        ref: ARRAY OF CHAR;
                    VAR n:   INTEGER);
 VAR cnt: INTEGER;
     c:   CHAR;
     dmy: ARRAY [0..1] OF CHAR;
 BEGIN
  PrintAt(x,y,b,0);
  x:=x+Length(b);
  dmy[1]:=nul;
  c:=nul;
  cnt:=Length(a);
  PrintAt(x,y,a,0);
  WHILE (c#CHAR(13)) AND (cnt<n) DO
   Get(c);
   dmy[0]:=c;
   IF (Occurs(ref,0,dmy,TRUE)#last) THEN
    IF (cnt<=n) THEN
     a[cnt]:=c;
     cnt:=cnt+1;
     a[cnt]:=nul;
    END;
   ELSE
    CASE INTEGER(c) OF
     |8,31,127: IF (cnt>0) THEN
                 cnt:=cnt-1;
                 a[cnt]:=nul;
                END;
     |27:       cnt:=0;
                a[0]:=nul;
     |0..7,9..26,28..30,32..126,128..255:
    END;
   END;
   PrintAt(x,y,a,0);
   Print(" ",0);
   Print(CHAR(8),0);
  END;
  Print("",1);
 END InputLine;

PROCEDURE Display(a,b: INTEGER);
 VAR x: INTEGER;
 BEGIN
  x:=0;
  IF (a>entries) THEN
   a:=a-entries;
   x:=1;
  END;
  PrintAt(2+40*x,a+2,"",0);
  IF (b#0) THEN
   IF (b<10) THEN
    Print(" ",0);
   END;
   PrintINT(b,0);
  ELSE
   Print("  ",0);
  END;
  PrintAt(1+40*x,a+2,"",0);
 END Display;

PROCEDURE getinfo (x: FileInfoBlockPtr);
 VAR  result: INTEGER;
      tmpname: name;
      l: INTEGER;
 BEGIN
  FOR l:=0 TO strSize-1 DO
   tmpname[l]:=x^.fileName[l];
  END;
  tmpname[strSize]:=nul;
  filename[counter]:=tmpname;
  filetype[counter]:=x^.dirEntryType;
  result:=Occurs(filename[counter],0,".info",FALSE);
  IF (result<0) THEN
   INC(counter);
  ELSE
   filename[counter]:="";
   filetype[counter]:=0;
  END;
 END getinfo;

BEGIN
 TermProcedure(CoolDown);
 IF (NumArgs()=0) THEN
  diskname:="df0:";
 ELSIF (NumArgs()=1) THEN
  GetArg(1,diskname,intdummy);
 ELSIF (NumArgs()>1) THEN
  diskname:="? ";
 END;
 IF (diskname[0]="?") THEN
  GetArg(0,progname,intdummy);
  WriteLn;
  WriteString("Disk Label Printer V1.10 by JOW"); WriteLn;
  WriteLn;
  WriteString("Usage:"); WriteLn;
  WriteString("  "); WriteString(progname); WriteString(" [?|devicename]");
  WriteLn; WriteLn;
 ELSE
  (* ---------------------------------------------------------------- *)
  (* do some preliminary stuff                                        *)
  (* ---------------------------------------------------------------- *)
  rawname:="RAW:0/0/640/200/Disk Label Printer V1.10 by JOW";
  iofile:=Open(ADR(rawname),oldFile);
  Assert(iofile # NIL,ADR("CAN'T OPEN I/O-WINDOW."));

  (* ---------------------------------------------------------------- *)
  (* allocate memory for FileInfoBlock                                *)
  (* ---------------------------------------------------------------- *)
  fibPtr:=AllocMem(memSize,MemReqSet{chip});
  Assert(fibPtr # NIL,ADR("NOT ENOUGH CHIP MEMORY."));

  REPEAT
   counter:=0;
   (* --------------------------------------------------------------- *)
   (* print startup message                                           *)
   (* --------------------------------------------------------------- *)
   Cls;
   Print("**********************************",1);
   Print("*                                *",1);
   Print("*   Disk Label Printer V1.10     *",1);
   Print("*                                *",1);
   Print("*   Written in 1989 by           *",1);
   Print("*                                *",1);
   Print("*   Jürgen Weinelt               *",1);
   Print("*   Zur Kanzel 1                 *",1);
   Print("*   D-8783 Hammelburg            *",1);
   Print("*   Germany                      *",1);
   Print("*                                *",1);
   Print("*   Release date: 06-NOV-90      *",1);
   Print("*                                *",1);
   Print("*   DLP V1.10 is PUBLIC DOMAIN   *",1);
   Print("*                                *",1);
   Print("**********************************",2);
   Delay(50);

   (* --------------------------------------------------------------- *)
   (* get lock for disk to be examined                                *)
   (* --------------------------------------------------------------- *)
   Print("Examining ",0); Print(diskname,0); Print("... please wait! ",0);
   ptr:=Lock(ADR(diskname),sharedLock);

   (* --------------------------------------------------------------- *)
   (* do the initial examine                                          *)
   (* --------------------------------------------------------------- *)
   retcode:=Examine(ptr,fibPtr);

   (* --------------------------------------------------------------- *)
   (* keep on reading fib's until there are no more entries           *)
   (* --------------------------------------------------------------- *)
   WHILE (retcode) DO
    getinfo(fibPtr);
    retcode:=ExNext(ptr,fibPtr);
   END;
   UnLock(ptr);
   ptr:=NIL;

   (* --------------------------------------------------------------- *)
   (* if it's a fish disk, say so... (don't be so humble, fred! :-)   *)
   (* --------------------------------------------------------------- *)
   IF (Occurs(filename[0],0,"AmigaLibDisk",FALSE)#-1) THEN
    Delete(filename[0],0,12);
    Insert(filename[0],0,"Fish-Disk #");
   END;

   (* --------------------------------------------------------------- *)
   (* ask 'em if they'd like to change the disk name                  *)
   (* --------------------------------------------------------------- *)
   yn:=nul;
   WHILE (NOT ((yn="y") OR (yn="n") OR (yn="Y") OR (yn="N"))) DO
    Cls;
    Print("Disk name is: ",0);
    Print(filename[0],2);
    Print("Do you want to use a different disk name for printing (y/n)? ",0);
    Get(yn);
    PrintC(yn);
   END;

   (* --------------------------------------------------------------- *)
   (* get the new disk name                                           *)
   (* --------------------------------------------------------------- *)
   IF (yn="y") OR (yn="Y") THEN
    Cls;
    Print("Old disk name: ",0);
    Print(filename[0],2);
    len:=strSize-1;
    InputLine(1,3,"New disk name: ",filename[0],anRef,len);
   END;

   (* --------------------------------------------------------------- *)
   (* enclose all directory names in [ ]                              *)
   (* --------------------------------------------------------------- *)
   FOR loop:=1 TO counter-1 DO
    IF filetype[loop]>0 THEN
     Insert(filename[loop],0,"[ ");
     Insert(filename[loop],last," ]");
    END;
   END;

   (* --------------------------------------------------------------- *)
   (* blank all unused array elements                                 *)
   (* --------------------------------------------------------------- *)
   FOR loop:=counter TO maxnum DO
    filename[loop]:="";
    filetype[loop]:=0;
   END;

   (* --------------------------------------------------------------- *)
   (* blank output arrays                                             *)
   (* --------------------------------------------------------------- *)
   FOR loop:=0 TO maxnum DO
    pr[loop]:=0;
    prn[loop]:="";
   END;

   (* --------------------------------------------------------------- *)
   (* sort all entries alphabetically                                 *)
   (* this is not a very fast sorting algorithm, but we don't have    *)
   (* too many entries to be sorted, so who cares...                  *)
   (* --------------------------------------------------------------- *)
   REPEAT
    flag:=TRUE;
    FOR loop:=2 TO counter-1 DO
     IF (Compare(filename[loop],0,strSize,filename[loop-1],FALSE)>0) THEN
      dummyn:=filename[loop];
      filename[loop]:=filename[loop-1];
      filename[loop-1]:=dummyn;
      dummyt:=filetype[loop];
      filetype[loop]:=filetype[loop-1];
      filetype[loop-1]:=dummyt;
      flag:=FALSE;
     END;
    END;
   UNTIL flag;

   (* --------------------------------------------------------------- *)
   (* set up selection screen                                         *)
   (* --------------------------------------------------------------- *)
   counter:=counter-1;
   IF (counter>2*entries) THEN
    counter:=2*entries;
    Cls;
    Print("Unable to display all files/directories:",1);
    Print("Max. entries: ",0);
    PrintINT(entries*2,1);
    Print("Act. entries: ",0);
    PrintINT(counter,1);
    Print("Please press any key to go on! ",0);
    Get(yn);
   END;
   Cls;
   PrintAt(1,1,filename[0],0);
   FOR loop:=1 TO entries DO
    PrintAt(5,loop+2,filename[loop],0);
    PrintAt(45,loop+2,filename[loop+entries],0);
   END;

   (* --------------------------------------------------------------- *)
   (* let 'em select what file names to print                         *)
   (* --------------------------------------------------------------- *)
   cnt0:=1;
   cnt1:=0;
   dy:=1;
   ch:=CHAR(" ");
   WHILE (ch#CHAR(27)) DO
    Display(cnt0,pr[cnt0]);
    Get(ch);
    Display(cnt0,pr[cnt0]);
    CASE INTEGER(ch) OF
     |28: cnt0:=cnt0-1;
          dy:=-1;
          IF (cnt0<1) THEN
           cnt0:=counter;
          END;
     |29: cnt0:=cnt0+1;
          IF (cnt0>counter) THEN
           cnt0:=1;
          END;
          dy:=1;
     |13: IF (cnt1<=maxout) THEN
           IF (pr[cnt0]=0) AND (cnt1<maxout) THEN
            cnt1:=cnt1+1;
            pr[cnt0]:=cnt1;
           ELSE
            IF (pr[cnt0]=cnt1) AND (cnt1#0) THEN
             pr[cnt0]:=0;
             cnt1:=cnt1-1;
            END;
           END;
          END;
          Display(cnt0,pr[cnt0]);
          cnt0:=cnt0+dy;
          IF (cnt0<1) THEN
           cnt0:=counter;
          END;
          IF (cnt0>counter) THEN
           cnt0:=1;
          END;
     |0..12,14..27,30..255:
    END;
   END;

   (* --------------------------------------------------------------- *)
   (* copy filenames into i/o-array according to selection            *)
   (* (looks a little clumsy but makes things easier)                 *)
   (* --------------------------------------------------------------- *)
   FOR loop:=1 TO counter DO
    IF (pr[loop]>0) THEN
     FOR loop2:=0 TO outSize-1 DO
      prn[pr[loop],loop2]:=filename[loop,loop2];
     END;
    END;
    prn[pr[loop],outSize]:=nul;
   END;
   flag:=FALSE;
   FOR loop2:=0 TO outSize-1 DO
    prn[0,loop2]:=filename[0,loop2];
    IF (filename[0,loop2]=nul) THEN
     flag:=TRUE;
    END;
    IF (flag) THEN
     prn[0,loop2]:=CHAR(" ");
    END;
   END;
   prn[0,outSize]:=nul;

   (* --------------------------------------------------------------- *)
   (* open prt:                                                       *)
   (* --------------------------------------------------------------- *)
   prtfile:=Open(ADR("PRT:"),newFile);
   Assert(prtfile # NIL,ADR('UNABLE TO OPEN "PRT:"'));

   (* --------------------------------------------------------------- *)
   (* print disk label (gasp! this is the end!!!)                     *)
   (* --------------------------------------------------------------- *)
   Prt("",3);
   Prt(esc,0);
   Prt("[4m",0);
   Prt(esc,0);
   Prt("[1m  ",0);
   Prt(prn[0],0);
   Prt(esc,0);
   Prt("[24m",0);
   Prt(esc,0);
   Prt("[22m",1);
   FOR loop:=1 TO 12 DO
    Prt("  ",0);
    Prt(prn[loop],1);
   END;
   Prt("",1);
   Close(prtfile);
   prtfile:=NIL;

   REPEAT
    Cls;
    Print("Do you want to print another label (y/n)? ",0);
    Get(yn);
   UNTIL ((yn="y") OR (yn="n"));
  UNTIL (yn="n");
 END;
END DLP.