Turbo Toolbox/Turbo_Toolbox.iso/1989/06/praxis/fselect.mod

Modula Implementation | 1989-03-23 | 14.5 KB | 500 lines

(*********************************************************)
(*                      FSELECT.MOD                      *)
(*          Dateiauswahlbox für TopSpeed Modula 2        *)
(*              (C) 1989 Dirk Donath & TOOLBOX           *)
(*********************************************************)

IMPLEMENTATION MODULE FSelect;

FROM SYSTEM  IMPORT Registers;
FROM FIO     IMPORT ReadFirstEntry,PathTail,FileAttr,
                    directory,DirEntry,
                    ReadNextEntry,ChDir,GetDir,
                    IOcheck,IOresult;
FROM IO      IMPORT WrStr,WrStrAdj,RdKey,RdStr;
FROM Str     IMPORT Append,Compare,Pos,Delete,Length,
                    Concat,Caps,Insert,Match,Copy;
FROM Window  IMPORT WinDef,WinType,Color,Open,DoubleFrame,
                    GotoXY,ClrEol,Close,TextColor,
                    TextBackground,Clear,SetTitle,
                    TitleMode,WhereX;
FROM Lib     IMPORT Dos,QSort;

CONST MaxEintraege = 200;

TYPE String12    = ARRAY[0..12] OF CHAR;
     EintragsTyp = ARRAY[1..MaxEintraege] OF String12;

VAR DirectoryGewaehlt,ErstesMal,
    WildCards,SuchwegGefunden      : BOOLEAN;
    LWNummer                       : SHORTCARD;
    AnzEintraege,EintragsIndex,i   : CARDINAL;
    Dir,Maske,DateiMaske           : ARRAY[0..40] OF CHAR;
    AltesLaufwerk,NeuesLaufwerk    : ARRAY[0..3] OF CHAR;
    AlterPfad,NeuerPfad            : ARRAY[0..40] OF CHAR;
    Eintrag                        : EintragsTyp;
    DF                             : WinDef;
    DateiFenster                   : WinType;

(*========================================================*)
(*  Bestimmung des aktuellen Laufwerks  (A=1,B=2,C=3 etc.)*)
(*========================================================*)

PROCEDURE GetDrive() : SHORTCARD ;

VAR r : Registers;

BEGIN
  r.AH := 19H ;
  Dos(r);
  RETURN r.AL+1 ;
END GetDrive ;

(*========================================================*)
(*          Hilfsprozeduren für das Sortieren             *)
(*========================================================*)

PROCEDURE Less(i,j : CARDINAL) : BOOLEAN;

BEGIN
  RETURN Compare(Eintrag[i],Eintrag[j]) < 0;
END Less;

PROCEDURE Swap(i,j : CARDINAL);

VAR temp : String12;

BEGIN
  temp       := Eintrag[i];
  Eintrag[i] := Eintrag[j];
  Eintrag[j] := temp;
END Swap;

(*========================================================*)
(*                 Hauptprozedur                          *)
(*========================================================*)

PROCEDURE GetFName(Frage : FraTyp; Antwort : AntTyp;
                   VAR DateiName : ARRAY OF CHAR) : BOOLEAN;

(*--------------------------------------------------------*)
(*  Erfragen eines Dateinamens bzw. einer Directory-Maske *)
(*--------------------------------------------------------*)

PROCEDURE ErfrageMaske;

VAR  AlteLWNummer : SHORTCARD;
     StartPos,i   : CARDINAL;
     Dummy        : CHAR;
     FF           : WinDef;
     FrageFenster : WinType;

BEGIN
  SuchwegGefunden := TRUE;
  AlteLWNummer    := GetDrive();
  CASE AlteLWNummer OF
  | 1: AltesLaufwerk := 'A:\';
  | 2: AltesLaufwerk := 'B:\';
  | 3: AltesLaufwerk := 'C:\';
  | 4: AltesLaufwerk := 'D:\';
  | 5: AltesLaufwerk := 'E:\';
  | 6: AltesLaufwerk := 'F:\';
  END;
  GetDir(AlteLWNummer,AlterPfad);
  (* Führender \ muß weg, da er schon Bestandteil
     der Laufwerkskennung ist:                    *)
  IF AlterPfad[0] = '\' THEN
    Delete(AlterPfad,0,1);
  END;
  Concat(AlterPfad,AltesLaufwerk,AlterPfad);
  ErstesMal := TRUE;   (* Flag für das Directory-Fenster *)
  WITH FF DO
    X1 := Frage.X1;(* Frage-Fenster definieren u. öffnen *)
    Y1 := Frage.Y1;
    X2 := 2+Frage.Breite;
    Y2 := Y1+2;
    Foreground := LightGray;
    Background := Black;
    CursorOn   := TRUE;
    WrapOn     := FALSE;
    FrameOn    := TRUE;
    FrameDef   := DoubleFrame;
    FrameFore  := LightGray;
    FrameBack  := Black;
    Hidden     := FALSE;
  END;
  FrageFenster := Open(FF);
  GotoXY(2,1);
  WrStr(Frage.Prompt);
  GotoXY(WhereX()+1,1);
  RdStr(Maske);
  IF ((Maske[1] = ':') AND (Maske[2] <> '\')) THEN
    Insert(Maske,'\',2);
  END;
  Dir        := Maske;
  DateiMaske := Maske;
  IF Pos(Maske,'.') < 65000 THEN   (* Der Punkt kommt vor *)
    StartPos := 0;
    FOR i := 0 TO Length(Maske) DO
      IF (Maske[i] = '\') THEN StartPos := i+1; END;
     (* StartPos = Position des letzten \ im String Maske *)
    END;
    IF StartPos > 0 THEN
      IF (((Maske[1] = ':')
           AND (StartPos < 4)) OR (StartPos=1)) THEN
        Delete(Dir,StartPos,12);    (* F. Hauptdirectory \*)
      ELSE                          (* erhalten           *)
        Delete(Dir,StartPos-1,12);  (* sonst muß er weg   *)
      END;
      Delete(DateiMaske,0,StartPos);(* Dateimaske entfernen *)
      IOcheck := FALSE;
      ChDir(Dir);
      IOcheck := TRUE;
      IF IOresult() <> 0 THEN
        SuchwegGefunden := FALSE;
        Clear;
        GotoXY(2,1);
        WrStr('Suchweg nicht gefunden');
        Dummy := RdKey();
      END;
    END;
  END;
  IF ((Pos(DateiMaske,'?') > 65000)
      AND (Pos(DateiMaske,'*') > 65000)) THEN
    WildCards := FALSE;
  ELSE
    WildCards := TRUE;
  END;
  Close(FrageFenster);
END ErfrageMaske;

(*--------------------------------------------------------*)
(*               Lesen des Directorys                     *)
(*--------------------------------------------------------*)

PROCEDURE LeseDirectory;

VAR DE : DirEntry;

(* Verarbeiten eines Directory-Eintrags  *)

PROCEDURE VerarbeiteEintrag;

VAR
  i           : CARDINAL;
  HilfsString : String12;

BEGIN
  Copy(HilfsString,DE.Name);
  (* Eintrag '.' wird nicht aufgenommen. Der Eintrag
     muß in die Maske DateiMaske passen oder ein
     Directory sein:                                     *)
  IF ((Compare(HilfsString,'.') <> 0) AND
      ((Match(HilfsString,DateiMaske))
        OR (directory IN DE.attr))) THEN
    INC(AnzEintraege);
    IF AnzEintraege > MaxEintraege THEN
      AnzEintraege := MaxEintraege;
    END;
    Eintrag[AnzEintraege] := HilfsString;
  END;
  (* Kennzeichnung eines Directorys durch angehängten \ : *)
  IF directory IN DE.attr THEN
    Append(Eintrag[AnzEintraege],'\');
  END;
END VerarbeiteEintrag;

BEGIN  (* LeseDirectory *)
  AnzEintraege := 0;
  IF ReadFirstEntry('*.*',FileAttr{directory},DE) THEN
    VerarbeiteEintrag;
    WHILE ReadNextEntry(DE) DO
      VerarbeiteEintrag;
    END;
    IF AnzEintraege > 1 THEN
      QSort(AnzEintraege,Less,Swap);   (* Alphabet. Sort. *)
    END;
  END;
END LeseDirectory;

(*--------------------------------------------------------*)
(*         Directory-Ausgabe und Menueauswahl             *)
(*--------------------------------------------------------*)

PROCEDURE Menue(VAR Index : CARDINAL);

VAR  FunktionsTaste                         : BOOLEAN;
     x,y,i,ScrollZaehler,AlterScrollZaehler : CARDINAL;
     Taste                                  : CHAR;

PROCEDURE Lesen(VAR Taste : CHAR; VAR Funkcode : BOOLEAN);

VAR  Tas : CHAR;

BEGIN
  Tas:=RdKey();
  IF Tas=0C THEN
    Tas:=RdKey();
    Funkcode:=TRUE;
  ELSE
    Funkcode:=FALSE;
  END;
  Taste:=Tas;
END Lesen;

PROCEDURE XPos(i : CARDINAL) : CARDINAL;

BEGIN
  RETURN ((i-1) MOD Antwort.Spalten) * 14 + 2;
END XPos;

PROCEDURE YPos(i : CARDINAL) : CARDINAL;

BEGIN
  RETURN ((i-1) DIV Antwort.Spalten) + 1;
END YPos;

PROCEDURE EintragsNummer(x,y : CARDINAL) : CARDINAL;

BEGIN
  RETURN x + Antwort.Spalten * (y-1);
END EintragsNummer;

PROCEDURE SchreibeDateiname(x,y : CARDINAL);

VAR i : CARDINAL;

BEGIN
  i := EintragsNummer(x,y);
  GotoXY(XPos(i),YPos(i));
  WrStrAdj(Eintrag[i + Antwort.Spalten
                       * ScrollZaehler],-13);
END SchreibeDateiname;

BEGIN  (* Menue *)
  FOR i := 1 TO AnzEintraege DO
    IF YPos(i) <= Antwort.Zeilen THEN
      GotoXY(XPos(i),YPos(i));
      WrStrAdj(Eintrag[i],-13);
      (* Ausgabe der Einträge, soweit sichtbar *)
    END;
  END;
  ScrollZaehler := 0;   (* Es wurde noch nicht gescrollt *)
  x             := 1;   (* Logische x- und               *)
  y             := 1;   (* y-Positionen                  *)
  TextColor(Black);
  TextBackground(LightGray);
  SchreibeDateiname(x,y);
           (* Hervorgehobene Darstellung des 1. Eintrags *)
  REPEAT  (* UNTIL RETURN OR ESC *)
    REPEAT
      Lesen(Taste,FunktionsTaste);
    UNTIL (((FunktionsTaste) AND ((Taste = CHAR(72)) OR
                                  (Taste = CHAR(80)) OR
                                  (Taste = CHAR(75)) OR
                                  (Taste = CHAR(77)))
           OR (Taste=CHAR(13)) OR (Taste = CHAR(27))));
    AlterScrollZaehler := ScrollZaehler;
    TextColor(LightGray);
    TextBackground(Black);
    SchreibeDateiname(x,y);  (* Hervorhebung Alt aus *)
    CASE Taste OF
    | CHAR(80): (* runter *)
        IF (EintragsNummer(1,y+1)+Antwort.Spalten
            *ScrollZaehler <= AnzEintraege) THEN
          IF (EintragsNummer(x,y+1)+Antwort.Spalten
              *ScrollZaehler > AnzEintraege) THEN
            x := (AnzEintraege-1) MOD Antwort.Spalten + 1;
          END;
          IF y<Antwort.Zeilen THEN
            INC(y)
          ELSE
            INC(ScrollZaehler);
          END;
        END;
    | CHAR(72): (* rauf *)
        IF y > 1 THEN
          DEC(y)
        ELSE
          IF ScrollZaehler > 0 THEN
            DEC(ScrollZaehler);
          END;
        END;
    | CHAR(75): (* links *)
        IF x > 1 THEN
          DEC(x);
        END;
    | CHAR(77): (* rechts *)
        IF ((x < Antwort.Spalten) AND
            (EintragsNummer(x+1,y)+Antwort.Spalten
             *ScrollZaehler <= AnzEintraege)) THEN
          INC(x);
        END;
    END;  (* CASE *)
    IF ScrollZaehler <> AlterScrollZaehler THEN(* Scrollen*)
      FOR i := Antwort.Spalten*ScrollZaehler+1
               TO AnzEintraege DO
        IF (YPos(i) - ScrollZaehler <= Antwort.Zeilen) THEN
          GotoXY(XPos(i),YPos(i) - ScrollZaehler);
          WrStrAdj(Eintrag[i],-13);
        END;
      END;
      ClrEol;
    END;
    TextColor(Black);
    TextBackground(LightGray);
    SchreibeDateiname(x,y);  (* Neuen Eintrag hervorheben *)
  UNTIL ((Taste = CHAR(13)) OR (Taste = CHAR(27)));
  TextColor(LightGray);
  TextBackground(Black);
  IF Taste = CHAR(27) THEN
    Index := 0
  ELSE
    (* Nummer des aktuellen Eintrags wird zurückgegeben: *)
    Index := EintragsNummer(x,y)
             + Antwort.Spalten * ScrollZaehler;
  END;
END Menue;

(*--------------------------------------------------------*)
(*    Definition und Ausgabe des Directory-Fensters       *)
(*--------------------------------------------------------*)

PROCEDURE FensterAusgabe;

VAR  i                    : CARDINAL;
     Dir                  : String12;
     TitelString,PfadName : ARRAY[0..40] OF CHAR;
     Dummy                : CHAR;

BEGIN
  IF ErstesMal THEN   (* Fenster definieren und eröffnen *)
    ErstesMal := FALSE;
    WITH DF DO
      X1         := Antwort.X1;
      Y1         := Antwort.Y1;
      X2         := X1 + 14 * Antwort.Spalten + 2;
      Y2         := Y1 + Antwort.Zeilen + 1;
      Foreground := LightGray;
      Background := Black;
      CursorOn   := FALSE;
      WrapOn     := FALSE;
      FrameOn    := TRUE;
      FrameDef   := DoubleFrame;
      FrameFore  := LightGray;
      FrameBack  := Black;
      Hidden     := FALSE;
    END;
    DateiFenster := Open(DF);
  END;
  (* Laufwerk u. Directory ermitteln: *)
  LWNummer := GetDrive();
  CASE LWNummer OF
  | 1: NeuesLaufwerk := 'A:\';
  | 2: NeuesLaufwerk := 'B:\';
  | 3: NeuesLaufwerk := 'C:\';
  | 4: NeuesLaufwerk := 'D:\';
  | 5: NeuesLaufwerk := 'E:\';
  | 6: NeuesLaufwerk := 'F:\';
  END;
  GetDir(LWNummer,PfadName);
  (* Titel zusammenbasteln: *)
  Concat(TitelString,' ',NeuesLaufwerk);
  IF PfadName[0] = '\' THEN
    Delete(PfadName,0,1);  (* Führenden \ entfernen *)
  END;
  Append(TitelString,PfadName);
  IF TitelString[Length(TitelString)-1] <> '\' THEN
    Append(TitelString,'\');(* String mit \ enden lassen *)
  END;
  Append(TitelString,DateiMaske);
  Append(TitelString,' ');
  Caps(TitelString);
  SetTitle(DateiFenster,TitelString,CenterUpperTitle);
  IF AnzEintraege > 0 THEN
    Menue(EintragsIndex);(* Menüroutine liefert Index *)
  ELSE
    GotoXY(1,1);
    WrStr('Datei nicht gefunden');
    EintragsIndex := 0;
    Dummy := RdKey();
  END;
  Clear;
  IF EintragsIndex > 0 THEN
    (* Das Menü wurde mit RETURN verlassen  *)
    IF Pos(Eintrag[EintragsIndex],'\') < 65000 THEN
      DirectoryGewaehlt := TRUE;
      Dir               := Eintrag[EintragsIndex];
      Delete(Dir,Length(Dir)-1,1);  (*  '\' entfernen    *)
      ChDir(Dir);                   (* Directory wechseln*)
      Clear;
    ELSE
      DirectoryGewaehlt := FALSE;
      Close(DateiFenster);
    END;
  ELSE
    Close(DateiFenster);
  END;
END FensterAusgabe;

(*--------------------------------------------------------*)
(*     Ermittlung des gewählten Laufwerks/Pfades          *)
(*--------------------------------------------------------*)

PROCEDURE ErmittlePfadname;

BEGIN
  LWNummer := GetDrive();
  CASE LWNummer OF
  | 1: NeuesLaufwerk := 'A:\';
  | 2: NeuesLaufwerk := 'B:\';
  | 3: NeuesLaufwerk := 'C:\';
  | 4: NeuesLaufwerk := 'D:\';
  | 5: NeuesLaufwerk := 'E:\';
  | 6: NeuesLaufwerk := 'F:\';
  END;
  GetDir(LWNummer,NeuerPfad);
  IF NeuerPfad[0] = '\' THEN
    Delete(NeuerPfad,0,1);  (* Führenden \ entfernen *)
  END;
  Concat(NeuerPfad,NeuesLaufwerk,NeuerPfad);
  (* Pfadname muß mit \ aufhören, da später
     der Dateiname angehängt wird:             *)
  IF NeuerPfad[Length(NeuerPfad)-1] <> '\' THEN
    Append(NeuerPfad,'\');
  END;
  ChDir(AlterPfad);
  (* Wiederherstellung des alten Pfades vor Prog.ende *)
END ErmittlePfadname;

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

BEGIN  (* GetFName *)
  ErfrageMaske;
  IF SuchwegGefunden THEN
    IF WildCards THEN
      REPEAT
        LeseDirectory;
        FensterAusgabe;
      UNTIL ((EintragsIndex=0) OR (NOT DirectoryGewaehlt));
      ErmittlePfadname;
      IF EintragsIndex=0 THEN
        RETURN FALSE;
      ELSE
        Copy(DateiName,Eintrag[EintragsIndex]);
        Concat(DateiName,NeuerPfad,DateiName);
        RETURN TRUE;
      END;
    ELSE
      ErmittlePfadname;
      Copy(DateiName,DateiMaske);
      Concat(DateiName,NeuerPfad,DateiName);
      RETURN TRUE;
    END;
  ELSE
    RETURN FALSE;
  END;
END GetFName;

END FSelect.