PC World Komputer 1995 November/PCWK1195.iso/inne/podstawy/dos/4dos/4uzytki/tfc22c.exe/TCV.PAS

Pascal/Delphi Source File | 1993-11-03 | 21.2 KB | 736 lines

{$X+}
{
    TCV Tobi's Catalogue Vison  Version 2.2  11-3-93, 9:35 AM

       This BP source is released into the Public Domain
       Feel free to make changes to this program but
       don't remove my name and address ...

       Let me know if you made any enhancements or if
       you find errors ...

       Thanks for Additions and Corrections to:

               . David Frey (no e-Mail)
               . Thomas Ludwig ([e-mail])
               . Maettu Studer (no e-Mail)
               . Robert Juhasz ([e-mail])

       Written by

                 Tobi Oetiker ([e-mail] or 2:301/516.2@fido)
                 Gallusstrasse 25 / CH-4600 Olten / FAX [phone]

      Revisions:

            V2.2 --- . Highlighted Current Search String.
}

Program Tobis_Catalog_Vision;
{$M 16384,16384,655360}
Uses App, Objects, Menus, Drivers, Views, Dialogs, MsgBox, Memory, DOS,
     HistList, fix;

Const VERSION = '2.2';
Type
  TTCV = Object (TApplication)
           DWPresent: Boolean;
           Constructor Init;
           Procedure InitStatusline; Virtual;
           Procedure InitMenuBar; Virtual;
           Procedure InitDesktop; Virtual;
           Procedure DataWindow;
         End;

  PDataWin = ^TDataWin;
  TDataWin = Object (TDialog)
             End;

  PTCVStatLine = ^TTCVStatLine;
  TTCVStatLine = Object (TStatusLine)
                   Function Hint (AHelpCtx: Word): String; Virtual;
                   Procedure Draw; Virtual;

                 End;

  PDiskCol = ^TDiskCol;
  TDiskCol = Object (TStringcollection)
               LineBuf: String;
               LineBufNr: Integer;
               EntryBuf: Array [1..6] Of String [80];
               EntryBufNr: Integer;
               Constructor Init (ALimit, ADelta: Integer);

               Function GetEntry (Zeile: Integer; Nummer: Byte): String;
               Function FindNext (Start: Integer; Key: String): Integer;
               Function FindPrev (Start: Integer; Key: String): Integer;
               Function DirLine (Welche: Integer): String;
             End;

  PDirBox = ^TDirBox;
  TDirBox = Object (TListBox)
              Search: String;
              Constructor Init (Var Bounds: TRect; ANumCols: Word;
              AScrollBar: PScrollBar);
              Destructor Done; Virtual;
              Procedure Draw; Virtual;
              Procedure HandleEvent (Var Event: TEvent); Virtual;
            End;
  PHButton = ^THButton;
  THButton = Object (TButton)
               Constructor Init (Var Bounds: TRect; ATitle: TTitleStr;
               ACommand: Word; AFlags: Word; Hnr: Word);
             End;
Const  hcBrowseMode = 1000;
  hcSearchMode = 1003;
  hcSearching = 1004;
  hcReading = 1005;
  hcAbout = 1006;
  hcInfo = 1007;
  hcExit = 1008;
  cmInfo = 100;
  cmAbout = 101;

Function NoCasePos (a, b: String): Byte;
  Var i: Integer;
  Begin
    If Length (a) > 0 Then
    Begin
      For i := 1 To Length (a) Do a [i] := UpCase (a [i] );
      For i := 1 To Length (b) Do b [i] := UpCase (b [i] );
      NoCasePos := Pos (a, b);
    End
    Else
      NoCasePos := 0;
  End;

Function LineCheck (S: String): Boolean;
Var i, l: Byte;
Begin
  i := 2;
  l := Length (s);
  If s [1] = '"' Then
  Begin
    While (i < l) And Not (s [i] = '"') Do Inc (i);
    If i < l Then
    Begin
      i := i + 3;
      While (i < l) And Not (s [i] = '"') Do Inc (i);
      If i < l Then
      Begin
        i := i + 3;
        While (i < l) And Not (s [i] = '"') Do Inc (i);
        If i < l Then
        Begin
          i := i + 3;
          While (s [i] >= '0') And (s [i] <= '9') And (i < l) Do Inc (i);
          If s [i] = ',' Then
          Begin
            i := i + 2;
            While (i < l) And Not (s [i] = '"') Do Inc (i);
            If i < l Then
            Begin
              i := i + 3;
              While (i < l) And Not (s [i] = '"') Do Inc (i);
              If s [i] = '"' Then
              Begin
                LineCheck := True;
                Exit;
              End;
            End;
          End;
        End;
      End;
    End;
  End;
  LineCheck := False;
End;


Function ToString (STRP: PString): String;
Begin
  If STRP <> Nil Then
    ToString := STRP^
  Else
    ToString := '"#ERROR#","x","x",2,"x","x"';
End;

Constructor THButton. Init (Var Bounds: TRect; ATitle: TTitleStr;
             ACommand: Word; AFlags: Word; Hnr: Word);
Begin
  TButton. Init (Bounds, ATitle, ACommand, AFlags);
  HelpCtx := Hnr;
End;

Function TDiskCol. GetEntry (Zeile: Integer; Nummer: Byte): String;
Var zeiger, i: Byte;
  s: String;
Begin
  If Zeile <> EntryBufNr Then
  Begin
    s := ToString (At (Zeile) );
    EntryBufNr := Zeile;
    i := 2;
    Zeiger := 2;
    While s [Zeiger] <> '"' Do Inc (Zeiger);
    EntryBuf [1] := Copy (s, i, Zeiger - i);

    i := Zeiger + 3;
    Zeiger := i;
    While s [Zeiger] <> '"' Do Inc (Zeiger);
    EntryBuf [2] := Copy (s, i, Zeiger - i);
    i := Zeiger + 3;
    Zeiger := i;
    While s [Zeiger] <> '"' Do Inc (Zeiger);
    EntryBuf [3] := Copy (s, i, Zeiger - i);
    i := Zeiger + 2;
    Zeiger := i;
    While s [Zeiger] <> ',' Do Inc (Zeiger);
    EntryBuf [4] := Copy (s, i, Zeiger - i);
    i := Zeiger + 2;
    Zeiger := i;
    While s [Zeiger] <> '"' Do Inc (Zeiger);
    EntryBuf [5] := Copy (s, i, Zeiger - i);
    i := Zeiger + 3;
    Zeiger := i;
    While s [Zeiger] <> '"' Do Inc (Zeiger);
    EntryBuf [6] := Copy (s, i, Zeiger - i);
  End;
  GetEntry := EntryBuf [Nummer];
End;

Function TDiskCol. DirLine (Welche: Integer): String;
Var LS, DI, Fi, Co: String;
Const Space = '                            ';
Begin;
  If Welche = LineBufNr Then
  Begin
    DirLine := LineBuf;
    Exit;
  End;
  DI := ' ' + Copy (GetEntry (Welche, 1) + Space, 1, 14);
  Fi := Copy (GetEntry (Welche, 3) + Space, 1, 15);
  Co := GetEntry (Welche, 5);
  LineBuf := DI + Fi + Co;
  LineBufNr := Welche;
  DirLine := LineBuf;
End;

Constructor TDiskCol. Init (ALimit, ADelta: Integer);
Begin
  TStringCollection. Init (ALimit, ADelta);
  LineBufNr := - 1;
  EntryBufNr := - 1;
End;

Function TDiskCol. FindNext (Start: Integer; Key: String): Integer;
Var i: Integer;
  p: Byte;
Begin
  If (Start >= 0) And (Start < Count) And (Key <> '') Then
  Begin
    i := Start - 1;
    p := 0;
    While (i < Count - 1) And (p = 0) Do
    Begin
      Inc (i);
      p := NoCasePos (Key, DirLine (i) );
    End;
    If p = 0 Then
      FindNext := Start
    Else
      FindNext := i;
  End
  Else
    FindNext := 0;
End;

Function TDiskCol. FindPrev (Start: Integer; Key: String): Integer;
Var i, p: Integer;
Begin
  If (Start >= 1) And (key <> '') Then
  Begin
    i := Start;
    p := 0;
    While (i >= 1) And (p = 0) Do
    Begin
      Dec (i);
      p := NoCasePos (Key, DirLine (i) );
    End;
    FindPrev := i;
  End
  Else
    FindPrev := Start;
End;


Destructor TDirBox. Done;
Begin
  NewList (Nil);
  TListBox. Done;
End;

Constructor TDirBox. Init (Var Bounds: TRect; ANumCols: Word;
                             AScrollBar: PScrollBar);


Var DataCol: PDiskCol;
  LineCount: LongInt;
  err: Boolean;

Procedure ReadFile;
   Var
     F: Text;
     S: String;
     propah: PathStr;

   Function FiletoRead: PathStr;
     Var
       EXEName: PathStr;
       Dir: DirStr;
       Name: NameStr;
       Ext: ExtStr;
       gefunden: PathStr;
     Begin
       If Lo (DosVersion) >= 3 Then EXEName := ParamStr (0)
       Else EXEName := FSearch ('TCV.EXE', GetEnv ('PATH') );
       FSplit (EXEName, Dir, Name, Ext);
       If Dir [Length (Dir) ] = '\' Then Dec (Dir [0] );
       FiletoRead := FSearch ('PROGS.TFC', Dir);
       blockCursor;
     End;

   Begin
     err := False;
     LineCount := 0;
     DataCol := New (PDiskCol, Init (1000, 10) );
     ProPah := FiletoRead;
     {$I-}
     Assign (f, ProPah);
     Reset (f);
     {$I+}
     If IOResult <> 0 Then err := True Else
       If ProPah = '' Then err := True Else
         If EoF (F) Then err := True;
     If err Then
     Begin
       MessageBox ('Cannot open file ' + ProPah + #13 + 'Read the docs and create an PROGS.TFC file using TFC.BTM',
       Nil, mfError + mfOkButton);
       DataCol^. Insert (NewStr ('"No Data"," "," ",3," "," "') );
     End
     Else
     Begin
       While Not EoF (F) And Not LowMemory Do
       Begin
         ReadLn (F, S);
         Inc (LineCount);
         If LineCheck (S) Then DataCol^. Insert (NewStr (S) )
         Else
         Begin
           MessageBox ('Error in Line %d of Data File', @LineCount, mfError + mfOkButton);
           Statusline^. Update;
         End;
       End;
       If LowMemory Then
         MessageBox ('Couldn''t read all Entries from File due to Memory shortage.', Nil, mfError + mfOkButton);
       Close (F);
     End;
   End;

Begin
  TListbox. Init (Bounds, ANumCols, AScrollBar);
  HelpCtx := hcReading;
  StatusLine^. Update;
  ReadFile;
  EventMask := EventMask Or evCommand;
  options := options Or ofPostProcess;
  Search := '';
  HelpCtx := hcBrowseMode;
  NewList (DataCol);
End;

Procedure TDirBox. HandleEvent (Var Event: TEvent);
Var p: Byte;
  r: TRect;
  Mouse: TPoint;
  ha: Word;
  from, found, f: Integer;

Procedure InfoBox (n: Integer);
  Var Pinfo: PDialog;
    R: TRect;
  Begin
    R. Assign (8, 6, 72, 17);
    Pinfo := New (PDialog, Init (R, 'Info Box') );
    With Pinfo^ Do
    Begin
      GetExtent (R);
      R. Grow ( - 3, - 2);
      R. B. Y := R. A. Y + 1;
      Insert (New (PStaticText, Init (R, 'Disk Label:  ' + PDiskCol (List)^. GetEntry (n, 1) ) ) );
      R. Move (0, 1);
      Insert (New (PStaticText, Init (R, 'File Name:   ' + PDiskCol (List)^. GetEntry (n, 3) ) ) );
      R. Move (0, 1);
      Insert (New (PStaticText, Init (R, 'File Date:   ' + PDiskCol (List)^. GetEntry (n, 2) ) ) );
      R. Move (0, 1);
      Insert (New (PStaticText, Init (R, 'Space Used:  ' + PDiskCol (List)^. GetEntry (n, 4) + ' Bytes') ) );
      R. Move (0, 1);
      Insert (New (PStaticText, Init (R, 'Description: ' + PDiskCol (List)^. GetEntry (n, 5) ) ) );
      R. Move (0, 1);
      Insert (New (PStaticText, Init (R, 'Scan Date:   ' + PDiskCol (List)^. GetEntry (n, 6) ) ) );
      GetExtent (R);
      R. Grow ( - 2, - 1);
      R. A. Y := R. B. Y - 2;
      R. A. X := R. B. X - 10;
      Insert (New (PButton, init (R, '~O~K', cmCancel, bfNormal) ) );
      Desktop^. ExecView (Pinfo);
    End;
  End;

Begin
  If (Event. What = evMouseDown) Then
    If (Event. Double) Then
    Begin
      makelocal (Event. Where, Mouse);
      If Mouse. Y + Topitem < range - 1 Then
      Begin
        If Mouse. Y + TopItem <> Focused Then
        Begin
          Search := '';
          FocusItem (Mouse. Y + Topitem);
        End;
        InfoBox (focused);
        ClearEvent (Event);
      End;
    End;
  If Event. What = evCommand Then
    Case Event. Command Of
      cmInfo:
             Begin
               InfoBox (focused);
               ClearEvent (Event);
             End;
      cmAbout:
              Begin
                Desktop^. Getextent (R);
                R. Grow ( - 15, - 4);
                r. Move (0, - 2);
                MessageBoxRect (R, #3 + 'CREADTED in Nov''93 BY' + #13 + #13 + #3 + 'Tobias Oetiker' + #13 +
                + #3 + 'Gallusstrasse 25' + #13 + #3 + 'CH-4600 Olten'
                + #13 + #3 + 'Switzerland' + #13 + #13 + #3 + 'eMail [e-mail]'
                + #13 + #13 + #3 + 'USING Turbo Pascal 7.0 and Turbo Vision',
                Nil, mfInformation + mfOkButton);
                ClearEvent (Event);
              End;
    End;
  If (Owner^. Phase <> phFocused) Then Exit;
  If (Event. What = evKeyDown) Then
  Begin

    Case Event. CharCode Of
      #32..#255:
                Begin
                  If Length (Search) = 0 Then
                    from := 0
                  Else
                    from := focused;
                  HelpCtx := hcSearching;
                  StatusLine^. Update;
                  found := PDiskCol (List)^. FindNext (from, Search + Event. CharCode);
                  p := NoCasePos (Search + Event. CharCode, PDiskCol (List)^. DirLine (found) );
                  If p > 0 Then
                    search := search + Event. CharCode
                  Else
                    MessageBox ('There is no Line to match "' +
                    search + Event. CharCode + '".',
                    Nil, mfError + mfOkButton);
                  If found = focused Then
                    Draw
                  Else
                    FocusItem (found);
                  ClearEvent (Event);
                End;
      #08:
          Begin
            If Length (Search) > 0 Then
            Begin
              Dec (Search [0] );
              HelpCtx := hcSearching;
              StatusLine^. Update;
              found := PDiskCol (List)^. FindNext (0, Search);
              If found = focused Then draw
              Else FocusItem (found);
            End;
            ClearEvent (Event);
          End;
      Else

        Case ctrlToArrow (Event. KeyCode) Of
          kbUp:
                 If (Length (Search) > 0) And (Focused > 0) Then
                 Begin
                   HelpCtx := hcSearching;
                   StatusLine^. Update;
                   found := PDiskCol (List)^. FindPrev (Focused, Search);
                   p := NoCasePos (Search, PDiskCol (List)^. DirLine (found) );
                   If p = 0 Then
                   Begin
                     If MessageBox ('There is no more Line to match "' +
                        search + '".',
                        Nil, mfError + mfOkCancel) = 10
                     Then
                     Begin
                       Search := '';
                       If Focused > 0 Then found := Focused - 1;
                     End Else found := Focused;
                   End;
                   FocusItem (found);
                   ClearEvent (Event);
                 End;

          kbDown:
                   If (Length (Search) > 0) And (Focused < (Range - 1) ) Then
                   Begin
                     HelpCtx := hcSearching;
                     StatusLine^. Update;
                     found := PDiskCol (List)^. FindNext (Focused + 1, Search);
                     p := NoCasePos (Search, PDiskCol (List)^. DirLine (found) );
                     If p = 0 Then
                     Begin
                       If MessageBox ('There is no more Line to match "' +
                          search + '".',
                          Nil, mfError + mfOKCancel) = 10
                       Then
                       Begin
                         Search := '';
                         If Focused < Range - 1 Then found := Focused + 1;
                       End Else found := Focused;
                     End;
                     FocusItem (found);
                     ClearEvent (Event);
                   End;
          kbEnter:
                  Begin
                    InfoBox (focused);
                    ClearEvent (Event);
                  End;
          Else
            Search := '';
          Draw;
        End;
    End;
    If Search = '' Then  HelpCtx := hcBrowseMode
    Else HelpCtx := hcSearchMode;
  End;
  TListBox. HandleEvent (Event);
End;

Procedure TDirBox. Draw;
Var i, CursorX: Integer;
  Line: TDrawBuffer;
  LCOL, MarkCol: Word;
  p: Integer;
  SelLine: String;
Begin;
  For i := 0 To Size. Y Do
  Begin
    Lcol := GetColor (1);
    MoveChar (Line, ' ', LCol, Size. X);
    If (i + TopItem) < List^. Count Then
    Begin
      If (i + TopItem = Focused) Then
      Begin
        Lcol := GetColor (3);
        Markcol := GetColor (5);
        p := NoCasePos (Search, PDiskCol (List)^. DirLine (focused) );
        If p > 0 Then
        Begin
          CursorX := p + Length (Search) - 1;
          SetCursor (CursorX, i);
          ShowCursor;
          SelLine := PDiskCol (List)^. DirLine (i + TopItem);
          Insert ('~', SelLine, CursorX + 1);
          Insert ('~', SelLine, p);
          MoveCStr (Line, SelLine, 256 * MarkCol + Lcol);
        End
        Else
        Begin
          Search := '';
          HelpCtx := hcBrowseMode;
          HideCursor;
          MoveStr (Line, PDiskCol (List)^. DirLine (i + TopItem), Lcol);
        End
      End
      Else
        MoveStr (Line, PDiskCol (List)^. DirLine (i + TopItem), Lcol);
    End;
    WriteLine (0, i, Size. X, 1, Line);
  End;
End;

Constructor TTCV. Init;
Begin
  InitMemory;
  InitVideo;
  If ParamCount = 1 Then
    If NocasePos ('LCD', ParamStr (1) ) > 0 Then setScreenMode (smBW80);
  InitEvents;
  InitSysError;
  InitHistory;
  TProgram. Init;
  HelpCtx := hcReading;
  StatusLine^. Update;
  DataWindow;
  HelpCtx := hcNoContext;
End;

Procedure TTCV. DataWindow;
Var
  R, S: TRect;
  Window: PDataWin;
  SB: PScrollbar;
  LB: PDirBox;
Begin
  Desktop^. GetExtent (R);
  Window := New (PDataWin, Init (R, 'Tobis Catalog Vision Version ' + VERSION) );
  With Window^ Do
  Begin
    Flags := $00;
    DragMode := $00;
    GrowMode := $00;
    GetExtent (R);
    R. Grow ( - 2, - 1);
    R. A. X := R. B. X - 12;
    R. A. Y := R. B. Y - 2;
    R. Move ( - 30, 0);
    Insert (New (PHButton, init (R, '~I~nfo', cmInfo, bfNormal, hcInfo) ) );
    R. Move (15, 0);
    Insert (New (PHButton, init (R, '~A~bout', cmAbout, bfNormal, hcAbout) ) );
    R. Move (15, 0);
    Insert (New (PHButton, init (R, 'E~x~it', cmQuit, bfNormal, hcExit) ) );
    GetExtent (R);
    R. Grow ( - 2, - 3);
    Inc (R. A. Y);
    R. Move ( - 1, - 1);
    Inc (R. A. X);
    S := R;
    S. A. X := S. B. X - 1;
    S. Move (1, 0);
    SB := New (PscrollBar, Init (S) );
    LB := New (PDirBox, Init (R, 1, SB) );
    GetExtent (R);
    R. Grow ( - 2, - 2);
    R. B. Y := R. A. Y + 1;
    Insert (New (PLabel
    , Init (R,
    '~D~isk          File Name      Comment', LB) ) );
    Insert (LB);
    Insert (SB);
  End;
  Desktop^. Insert (Window);
End;

Procedure TTCV. InitDesktop;
Var R: TRect;
Begin;
  GetExtent (R);
  Dec (R. B. Y);
  Desktop := New (PDeskTop, Init (R) );
End;
Function TTCVStatLine. Hint (AHelpCtx: Word): String;
Begin
  Case HelpCtx Of
    hcBrowseMode:  Hint := 'BROWSE MODE: Use [UP],[DOWN] to Browse or Enter a Word you are looking for.';
    hcSearchMode: Hint := 'SEARCH MODE: [UP],[DOWN] for Next Match; Continue typing; [ESC] to Browse Mode';
    hcSearching:  Hint := 'Searching ...   Please wait!';
    hcReading:    Hint := 'Reading Data File from Disk ...    Please wait!';
    hcInfo:       Hint := 'Press this button to get full information about the selected File';
    hcAbout:      Hint := 'Pressing this button displays the autors address.';
    hcExit:       Hint := 'Press Exit to terminate TCV.'
    Else
      Hint := '';
  End;
End;
Procedure TTCVStatLine. Draw;
Var Line: TDrawBuffer;
Begin
  MoveChar (Line, ' ', GetColor (1), Size. X);
  MoveStr (Line, ' ' + Hint (GetHelpctx), GetColor (1) );
  WriteLine (0, 0, Size. X, 1, Line);
End;


Procedure TTCV. InitStatusline;
Var R: TRect;
Begin
  GetExtent (R);
  R. A. Y := R. B. Y - 1;
  StatusLine := New (PTCVStatLine, Init (R, Nil) );
End;

Procedure TTCV. InitMenuBar;

Var R: TRect;
Begin
End;

Function GREP: Boolean;
Var Line, Disk: String;
  F: Text;
  i: Byte;
Begin
  GREP := False;
  If ParamStr (1) = '/GREP' Then
  Begin
    GREP := True;
    {$I-}
    Assign (F, GetEnv ('target') );
    Reset (F);
    {$I+}
    If (IOResult <> 0) Or EoF (F) Then
    Begin
      WriteLn ('** Error Opening File ', GetEnv ('target') );
      WriteLn ('   Use Format TCV /GREP');
      WriteLn ('   With env vars target and dsklbl set')
    End
    Else
    Begin
      Disk := GetEnv ('dsklbl');
      While Not EoF (F) Do
      Begin
        ReadLn (F, Line);
        If NOCASEPOS (DISK, Line) <> 1 Then WriteLn (Line);
      End;
    End;
  End;
End;

Var
  TCV: TTCV;

Begin
  If Not GREP Then
  Begin
    LowMemSize := 20000 Div 16;
    initFix;
    TCV. Init;
    doneFix;
    TCV. Run;
    TCV. Done;

    WriteLn ('Thanks for using TCV. This software, was created by:');
    WriteLn ('                                                                ');
    WriteLn (' Tobias Oetiker                                                  ');
    WriteLn (' Gallusstr. 25,  CH-4600 Olten, Switzerland                   ');
    WriteLn ('                                                            ');
    WriteLn (' Internet:  [e-mail]              ');
    WriteLn (' Fidonet:   2:301/516.4');
    WriteLn;
    WriteLn ('This is Card-Ware: If you use this Software on a regular basis,');
    Writeln ('                   please send me a Picture Post-Card from where you live.');
    Writeln ('                   If you include your eMail address, I''ll inform you,');
    Writeln ('                   when the next release of TFC gets available.');
    WriteLn;
  End;
End.