{ *** SuperDIRectory ***   V: 1.5    Mai 1985    (C) by U.Kern   CP/M-Version }

PROGRAM sdir;
{.pl72}

CONST maxzahl     = 2000;

TYPE diskident    = STRING[4];
     dirname      = STRING[11];
     direintrag   = RECORD
                      name  : dirname;
                      dsknr : diskident;
                      user  : byte
                    END;
     index        = 1..maxzahl;
     info         = STRING[19];

VAR  dirzahl      : index;
     directory    : ARRAY[index] OF direintrag;
     menueauswahl : char;
     befehl       : STRING[127] ABSOLUTE $80;
     mustername   : dirname;
     musterident  : diskident;
     ldrive       : byte;

{=============================================================================}

PROCEDURE qsort (von, bis : index);

{ Modifizeirter, nichtrekursiver Quicksort mit eigenem Stack. }

TYPE lifo      = ^lifoliste;
     lifoliste = RECORD
                   v, b : index;
                   last : lifo
                 END;

VAR  m         : direintrag;
     i, j      : index;
     stack     : lifo;

{-----------------------------------------------------------------------------}

PROCEDURE push (von, bis : index);

VAR  p : lifo;

BEGIN { push }
  new (p);
  p^.v := von;
  p^.b := bis;
  p^.last := stack;
  stack := p
END;  { push }

{-----------------------------------------------------------------------------}
{.pa}
PROCEDURE pop (VAR von, bis : index);

VAR  p : lifo;

BEGIN { pop }
  p := stack;
  von := p^.v;
  bis := p^.b;
  stack := p^.last;
  dispose (p)
END;  { pop }

{-----------------------------------------------------------------------------}

PROCEDURE vertausche (d1, d2 : index);

VAR  temp : direintrag;

BEGIN { vertausche }
  temp := directory[d1];
  directory[d1] := directory[d2];
  directory[d2] := temp
END;  { vertausche }

{-----------------------------------------------------------------------------}

FUNCTION kleiner (x, y : direintrag) : boolean;

VAR  h : boolean;

BEGIN { kleiner }
  h := false;
  IF x.name < y.name
    THEN
      h := true
    ELSE
      IF x.name = y.name
        THEN
          IF x.dsknr < y.dsknr
            THEN
              h := true
            ELSE
              IF x.dsknr = y.dsknr
                THEN
                  h := x.user < y.user;
  kleiner := h
END;  { kleiner }

{-----------------------------------------------------------------------------}
{.pa}
PROCEDURE esort (von, bis : index);
{ Einfuege-Sort fuer kleine Listen. }

VAR  i, j, m : index;

BEGIN { esort }
  FOR i := von TO bis-1 DO
    BEGIN
      m := i;
      FOR j := i+1 TO bis DO
        IF kleiner (directory[j], directory[m])
          THEN
            m := j;
      IF m <> i
        THEN
          vertausche (i, m)
    END
END;  { esort }

{-----------------------------------------------------------------------------}

BEGIN { qsort }
  stack := NIL;
  push (von, bis);
  REPEAT
    pop (von, bis);
    IF bis-von < 7
      THEN
        esort (von, bis)
      ELSE
        BEGIN
          i := von; j := bis;
          m := directory[(i+j) DIV 2];
          REPEAT
            WHILE kleiner (directory[i], m) DO
              i := succ (i);
            WHILE kleiner (m, directory[j]) DO
              j := pred (j);
            IF i <= j
              THEN
                BEGIN
                  vertausche (i, j);
                  i := succ (i);
                  j := pred (j)
                END
          UNTIL i > j;
          IF i < bis
            THEN push (i, bis);
          IF j > von
            THEN push (von, j)
        END
  UNTIL stack = NIL
END;  { qsort }

{=============================================================================}
{.pa}
PROCEDURE schreibliste (eintragzahl : index);

VAR f                               : text;
    i                               : index;
    pl, mb, mt, seitenzahl,
    seite, zeile, zzahl,
    maxzahl, spaltenzahl, spalte    : integer;
    dev                             : (bildschirm, drucker);
    selektor                        : char;

{-----------------------------------------------------------------------------}

PROCEDURE print (VAR f : text; dn : dirname);

VAR i : 1..11;

{.............................................................................}

FUNCTION trans (x:char) : char;

{ Sorgt fuer druckbare Zeichen. }

VAR c : byte;

BEGIN { trans }
  c := ord(x) AND 127;      { achtes Bit loeschen }
  IF c IN [32..126]
    THEN
      trans := chr (c)
    ELSE
      trans := '!'
END;  { trans }

{.............................................................................}

BEGIN { print }
  FOR i := 1 TO 8 DO
    write (f, trans (dn[i]));
  write (f, '.');
  FOR i := 9 TO 11 DO
    write (f, trans (dn[i]));
END;  { print }

{-----------------------------------------------------------------------------}
{.pa}
BEGIN { schreibliste }
  IF eintragzahl = 0
    THEN
      writeln ('Kein Eintrag')
    ELSE
      REPEAT
        clrscr;
        writeln ('Ausgabe der Liste:');
        write ('B)ildschirm oder D)rucker oder E)nde ');
        REPEAT
          read (kbd, selektor)
        UNTIL selektor IN ['b', 'B', 'd', 'D', 'e', 'E'];
        IF NOT (selektor IN ['e', 'E'])
          THEN
            BEGIN
              CASE selektor OF
                'b', 'B' : BEGIN
                             assign (f, 'CON:');
                             pl := 23;
                             mt := 0;
                             mb := 0
                           END;
                'd', 'D' : BEGIN
                             assign (f, 'LST:');
                             pl := 72;
                             mt := 3;
                             mb := 3
                           END
            END;
            writeln (selektor);
            rewrite (f);
            maxzahl := (pl-mt-mb)*3;
            zzahl := pl-mt-mb;
            spaltenzahl := (eintragzahl-1) DIV zzahl;
            IF spaltenzahl > 2
              THEN
                spaltenzahl :=2;
            seitenzahl := (eintragzahl-1) DIV ((spaltenzahl+1)*zzahl);
{.pa}
            FOR seite := 0 TO seitenzahl DO
              BEGIN
                IF selektor IN ['b', 'B']
                  THEN
                    clrscr
                  ELSE
                    writeln ('Ausgabe auf Drucker.');
                FOR zeile := 1 TO mt DO
                  writeln (f);
                FOR zeile := 1 TO pl-mt-mb DO
                  BEGIN
                    writeln (f);
                    FOR spalte := 0 TO spaltenzahl DO
                      BEGIN
                        i := seite*zzahl*(spaltenzahl+1)+spalte*zzahl+zeile;
                        IF i <= eintragzahl
                          THEN
                            WITH directory[i] DO
                              BEGIN
                                write (f, dsknr:7, '/', user:2, ': ');
                                print (f, name);
                                IF ord (name[10]) > 128
                                  THEN
                                    write (f, '/S')
                                  ELSE
                                    write (f, '  ')
                              END
                      END
                  END;
                FOR zeile := 1 TO mb DO
                  writeln (f);
                IF selektor IN ['b', 'B']
                  THEN
                    readln;
              END
        END;
      UNTIL selektor IN ['e', 'E']
END;  { schreibliste }

{=============================================================================}
{.pa}
PROCEDURE liessuperdir (musterident : diskident; mustername : dirname;
                        VAR anzahl : index);

{ Es werden nur  Eintraege in den Speicher geholt, auf die das Muster passt. }

VAR f     : FILE OF direintrag;
    i     : 1..11;
    temp  : direintrag;
    passt : boolean;

BEGIN { liessuperdir }
  assign (f, 'SDIR.DAT');
  {$I-}
  reset (f);
  {$I+}
  anzahl := 0;
  IF ioresult = 0
    THEN
      WHILE NOT eof (f) DO
        BEGIN
          read (f, temp);
          passt := true;
          WITH temp DO
            BEGIN
              FOR i := 1 TO 11 DO
                IF (ord (name[i]) AND 127 <> ord (mustername[i]))
                                  AND (mustername[i] <> '?')
                  THEN
                    passt := false;
              IF passt
                THEN
                IF musterident <> ''
                  THEN
                    passt := musterident = dsknr;
            END;
          IF passt
            THEN
              BEGIN
                directory[anzahl+1] := temp;
                anzahl := succ (anzahl)
              END
        END;
  close (f)
END;  { liessuperdir }

{=============================================================================}
{.pa}
PROCEDURE schreibsuperdir (anzahl : index);
{ Falls eine File mehrere Directory-Eintraege (= Extensions) belegt, werden }
{ diese nicht ins Super-Directory uebernommen.                              }

VAR f : FILE OF direintrag;
    i : index;

{-----------------------------------------------------------------------------}

FUNCTION gleich (x, y : direintrag) : boolean;

BEGIN { gleich }
  gleich := (x.dsknr = y.dsknr) AND (x.name = y.name) AND (x.user = y.user)
END;  { gleich }

{-----------------------------------------------------------------------------}

BEGIN { schreibsuperdir }
  write ('SUPERDIR-Diskette in ', chr (ldrive+65), ': einlegen und dann');
  writeln (' RETURN druecken.');
  readln;
  bdos ($0D);                  { Diskettensystem zuruecksetzen }
  bdos ($0E, ldrive);          { Bezugslaufwerk festlegen      }
  assign (f, 'SDIR.BAK');
  {$I-} reset (f); {$I+}
  IF ioresult = 0
    THEN
      BEGIN
        close (f);
        erase (f)
      END;
  assign (f, 'SDIR.DAT');
  {$I-} reset (f); {$I+}
  IF ioresult = 0
    THEN
      BEGIN
        close (f);
        RENAME (F, 'SDIR.BAK')
      END;
  assign (f, 'SDIR.DAT');
  rewrite (f);
  FOR i := 1 TO anzahl DO
    IF i > 1
      THEN
        IF NOT gleich (directory[i-1], directory[i])
          THEN
            write (f, directory[i])
          ELSE
      ELSE
        write (f, directory[i]);
  close (f)
END;  { schreibsuperdir }

{=============================================================================}
{.pa}
PROCEDURE direingabe;

VAR auswahl, ldrivec : char;

{-----------------------------------------------------------------------------}

PROCEDURE liesdirectory (VAR eintragzahl : index);

{ Liest das gesamte Directory einer Diskette oder eines Festplattenlaufwerkes.}

VAR z      : byte;
    nummer : diskident;
    fcb    : ARRAY [0..31] OF char;
    puffer : ARRAY[0..127] OF char;

{.............................................................................}

PROCEDURE kill (di : diskident; VAR eintragzahl : index);

{ Sorgt fuer ein automatisches Update, indem vot der Neueingabe einer }
{ Diskettennummer eventuell vorhandene Eintraege geloescht werden.    }

VAR i : index;

BEGIN { kill }
  i := 1;
  WHILE i <= eintragzahl DO
    IF directory[i].dsknr = di
      THEN
        BEGIN
          directory[i] := directory[eintragzahl];
          eintragzahl := pred (eintragzahl)
        END
      ELSE
        i := succ (i)
END;  { kill }

{.............................................................................}
{.pa}
BEGIN { liesdirectory }
  write ('Disknummer : ');
  readln (nummer);
  write ('Diskette einlegen und dann RETURN druecken !');
  readln;
  kill (nummer, eintragzahl);
  fcb := '????????????'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0;
  bdos ($0D);                  { Diskettensystem zuruecksetzen }
  bdos ($0E, ldrive);          { Bezugslaufwerk festlegen      }
  bdos ($1A, addr (puffer));   { Datenuebergabe-Adresse festlegen }
  z := bdos ($11, addr (fcb)); { Ersten Eintrag holen          }
  WHILE z <> 255 DO
    BEGIN
      IF puffer[z*32] < #128
        THEN
          BEGIN
            eintragzahl := succ (eintragzahl);
            IF eintragzahl > maxzahl
              THEN
                eintragzahl := maxzahl;
            WITH directory[eintragzahl] DO
              BEGIN
                name := copy (puffer, z*32+2, 11);
                dsknr := nummer;
                user := ord (puffer[z*32]) AND 31
              END
          END;
      Z := BDOS (18)           { Naechsten Eintrag holen }
    END
END;  { liesdirectory }

{-----------------------------------------------------------------------------}
{.pa}
BEGIN { direingabe }
  REPEAT
    writeln ('Bezugslaufwerk : ',chr (ldrive+65));
    writeln (maxzahl-dirzahl, ' Eintraege frei.');
    write ('L)aufwerk wechseln, E)ingabe, Q)uit ');
    REPEAT
      read (kbd, auswahl)
    UNTIL upcase (auswahl) IN ['L', 'E', 'Q'];
    writeln (upcase (auswahl));
    CASE upcase (auswahl) OF
      'L' : BEGIN
              write ('Neues Laufwerk : ');
              REPEAT
                read (kbd, ldrivec);
                ldrivec := upcase (ldrivec)
              UNTIL ldrivec IN [#13, 'A'..'P'];
              IF ldrivec <> #13
                THEN
                  ldrive := ord (ldrivec)-65;
              writeln (chr (ldrive+65))
            END;
      'E' : BEGIN
              liesdirectory (dirzahl);
              IF dirzahl = maxzahl
                THEN
                  writeln ('Directory voll!')
            END
    END;
    writeln;
  UNTIL upcase (auswahl) = 'Q';
  qsort (1, dirzahl);
  schreibsuperdir (dirzahl)
END;  { direingabe }

{=============================================================================}
{.pa}
PROCEDURE machmuster (VAR musterident : diskident; VAR mustername : dirname);

VAR p : 0..127;
    c : char;

BEGIN { machmuster }
  p := pos ('/', befehl);
  IF p > 0
    THEN
      BEGIN
        musterident := copy (befehl, 1, p-1);
        befehl := copy (befehl, p+1, length (befehl)-p)
      END
    ELSE
      musterident := '';
  p := pos ('.', befehl);
  IF p = 0
    THEN
      BEGIN
        befehl := befehl+'. ';
        p := length (befehl)
      END;
  mustername := copy (befehl, 1, p-1);
  IF mustername[length (mustername)] = '*'
    THEN
      BEGIN
        mustername := copy (mustername, 1, length (mustername)-1);
        c := '?'
      END
    ELSE
      c := ' ';
  WHILE length (mustername) < 8 DO
    mustername := mustername+c;
  mustername := mustername+copy (befehl, p+1, length (befehl)-p);
  IF mustername[length (mustername)] = '*'
    THEN
      BEGIN
        mustername := copy (mustername, 1, length (mustername)-1);
        c := '?'
      END
    ELSE
      c := ' ';
  WHILE length (mustername) < 11 DO
    mustername := mustername+c;
END;  { machmuster }

{=============================================================================}
{.pa}
BEGIN { sdir }
  WHILE (befehl <> '') AND (befehl[1] = ' ') DO
    befehl := copy (befehl, 2, length (befehl)-1);
  IF befehl <> ''
    THEN
      BEGIN
        machmuster (musterident, mustername);
        liessuperdir (musterident,mustername, dirzahl);
        schreibliste (dirzahl)
      END
    ELSE
      BEGIN
        ldrive := mem[4] AND 15;
        liessuperdir ('', '???????????', dirzahl);
        REPEAT
          clrscr;
          writeln ('Super-Directory');
          writeln;
          writeln (maxzahl-dirzahl, ' Eintraege frei.');
          writeln;
          writeln ('E)ingabe neuer Disketten');
          writeln ('A)usgabe der Liste');
          writeln ('Q)uit');
          writeln;
          write ('Ihre Wahl? ');
          REPEAT
            read (kbd, menueauswahl)
          UNTIL upcase (menueauswahl) IN ['E', 'A', 'Q'];
          writeln (upcase (menueauswahl));
          writeln;
          CASE upcase (menueauswahl) OF
            'E' : direingabe;
            'A' : schreibliste (dirzahl)
          END
        UNTIL upcase (menueauswahl) = 'Q'
      END
END.  { sdir }