{A program to assist in a systematic purge of malingering files.
Shows first 15 lines, size and date of a file to assist in identifying
it.  Can display entire file, if needed.  Suppresses most control characters
and shows a count of them.  This minimizes the confusion caused by trying to
display a program file or one of its' derivitives. Offers a quick
file delete.
                          Version 1.0
                         Written by: Merlin L. Hanson                  }

PROGRAM KomitetGosudarstvennoyeBezopastnosti;
CONST
  {$I GEMCONST.PAS}
TYPE
  {$I GEMTYPE.PAS}
  {Buffer is big enough for 15 full lines of text. 15x(80+2) = 1230}
  T1 = PACKED ARRAY [1..1230] OF char;
  {Next is big enough for 63 512 byte sectors.}
  T2 = PACKED ARRAY [1..32256] OF char;
  T3 = ARRAY[0..1] OF integer;   {for time and date}
  T4 = ^T3;
VAR
  Printer : text;  {Only used for debug.}

{$I GEMSUBS.PAS}
{$I CURSOR.PAS}

PROCEDURE Buffer;
  {This procedure has no logic.  It simply contains the declaration for
  a large I/O buffer to get around the 32K byte limit imposed by PP version 1.}
  VAR
    BigBuffer : FILE OF T2;

  PROCEDURE DoIt;
    VAR
      MyPath,MyFile : string;
      ThisFile    : FILE OF T1;

    PROCEDURE DisplayCoverSheet;
      CONST
        w = 39;
        h = 16;
      VAR
        s   : ARRAY [1..12] OF string[35];
        Box : dialog_ptr;
        OK  : integer;

      PROCEDURE MakeText
                  (Box : dialog_ptr;
                     X : integer;
                     Y : integer;
                 NChar : integer;
                     S : string);
        VAR  junk : integer;
        BEGIN {maketext}
          junk := Add_DItem(Box,G_String,None,
                            X,Y,NChar,1,    0,384);
          Set_DText(Box,junk,S,System_Font,TE_Left);
        END {maketext};

      PROCEDURE DrawBox;
        VAR
          i, x, y : integer;
        BEGIN
        s[1] := '               KGB       ';
        s[2] := '           Version 1.0   ';
        s[3] := '               by        ';
        s[4] := '         Merlin L. Hanson';
        s[5] := '          Genie Address: ';
        s[6] := '            M.L.HANSON   ';
        s[7] := '                         ';
        s[8] := '                         ';
        s[9] := '  Portions of this product are';
        s[10] := 'Copyright  1986, 1987 OSS and CCD.';
        INSERT    (CHR(189),s[10],11           );
        s[11] := '   Used by Permission of OSS.';
        s[12] :=             ' OK ';
        Box := New_Dialog(12,    0,0,w,h);
        x := 3;  y := 1;
        FOR i := 1 TO 11 DO
          MakeText(Box,x,y + i, 34,    s[i]);
        OK := Add_DItem(Box,G_Button,
                  Selectable | Exit_Btn | Default,
                  17,14,4,1,     0,384);
        Set_DText(Box,OK,s[12],System_Font,TE_Left);
        END {drawbox};

      BEGIN {displaycoversheet}
        DrawBox;
        Center_Dialog(Box);
        OK := Do_Dialog(Box,0);
        End_Dialog(Box);
        ClrScr;
      END {displaycoversheet};

    PROCEDURE GetDriveAndPath(VAR S:string);
      {A procedure that returns a Pascal string containing the current drive,
      current path and all punctuation.  Simply append a raw file name.}
      VAR
        i : integer;
        T : string;
        Path : string;
        DriveString : string;

      FUNCTION CurrentDisk:integer;
        {Returns an integer specifying the current drive. 0 specifies A, etc.}
        GEMDOS($19);

      PROCEDURE GetDir(VAR Ptr:string; DriveID:integer);
        {Puts a C string defining the folders currently open on DriveID
        into S.  DriveID of 0 specifies the current drive.}
        GEMDOS($47);

      BEGIN {getdriveandpath}
        DriveString := CONCAT(CHR(ORD('A')+CurrentDisk),':');
        GetDir(Path,0);
        {Convert from C to Pascal.}
        i := 0;
        WHILE Path[i] <> CHR(0) DO
          BEGIN
            T[i+1] := Path[i];
            i := i+1;
          END;
        {Set the length}
        T[0] := CHR(i);
        S := CONCAT(DriveString,T,'\');
      END {getdriveandpath};

    PROCEDURE ProcessFile;
      {The user has selected a file. Do his/her bidding.}
      VAR
        ControlChar : integer;
        LineCt      : integer;
        i : integer;
        ch : char;
        NbrBytes : long_integer;
        DocExtender : boolean;
        Start : integer;

      PROCEDURE SetUp;

        PROCEDURE GetFileSize(FileName : path_name;
                    VAR NbrBytesInFile : long_integer);
        {Get the length of a file in bytes.  The file name in a standard
        Pascal form is provided as a parameter.}
        TYPE
          pack14 = PACKED ARRAY[1..14] OF char;
          cstring = PACKED ARRAY[1..80] OF char;
          DTA_Type = PACKED RECORD
                       reserved : PACKED ARRAY[0..19] OF byte;
                       resvd    : byte;
                       Attribute: byte;
                       Time     : integer;
                       Date     : integer;
                       FileSize : long_integer;
                       F_Name   : pack14;
                     END {record};
          S80 = string[80];

        VAR
          Addr       : DTA_Type;
          Attributes : byte;
          S2         : s80;
          C_FileName : cstring;
          Status   : integer;

          PROCEDURE StrToC_String(Name1 : Path_Name; VAR Name2 : CString);
            {Convert a Pascal string to a null terminated character array}
            VAR i,l : integer;
            BEGIN
              L := LENGTH(Name1);
              FOR i := 1 TO L DO
                Name2[i] := Name1[i];
              Name2[L+1] := CHR(0);
            END {strtoc_string};

          PROCEDURE SetDTA(VAR Addr : DTA_Type);
            GEMDOS($1A);

          FUNCTION SearchFirst(VAR FileName   : cstring;
                                   Attributes : integer)
                                   : integer;
            GEMDOS($4E);

          BEGIN {getfilesize}
            SetDTA(Addr);
            StrToC_String(FileName,C_FileName);
            Attributes := $07;
            Status := SearchFirst(C_FileName,Attributes);
            IF Status <> 0
              THEN
                WriteLn('Error on getting file size from OS. Status:',Status);
            NbrBytesInFile := Addr.FileSize;
          END {getfilesize};


        BEGIN {setup}
          ControlChar := 0;
          LineCt := 0;
          ClrScr;
          i := 1;
          GetFileSize(MyFile,NbrBytes);
          Start := LENGTH(MyFile)-4;
          IF POS('.DOC',MyFile) > 0
            THEN DocExtender := TRUE
            ELSE DocExtender := FALSE;
        END {setup};

      PROCEDURE AnalyzeAndPrint;
        VAR j:integer;
        BEGIN
          REPEAT
            IF (ThisFile^[i] > CHR(31)) AND (ThisFile^[i] < CHR(127))
              THEN Write(ThisFile^[i])
              ELSE
                BEGIN
                  ControlChar := ControlChar+1;
                  IF (ThisFile^[i] = CHR(13))
                    THEN LineCt := LineCt+1;
                  IF (ThisFile^[i] = CHR(13)) {CR}
                  OR (ThisFile^[i] = CHR(10)) {LF}
                    THEN Write(ThisFile^[i]);
                  {Change Record Separator to blank on 1st Word and
                  Word Writer files.  Might work on other word processors too.}
                  IF DocExtender AND (ThisFile^[i] = CHR($1E))
                    THEN Write(' ');
                END;
            i := i+1;
          UNTIL (LineCt > 15) OR (i >= 1230) OR (i > NbrBytes);
          WriteLn;
          WriteLn;
          Write(' ':21);
          InverseVideo;
          WriteLn('   There were ', ControlChar, ' control characters.  ');
          WriteLn(' ':18,
                  '   ''t''-type the file  ''delete''-delete the file   ',
                  ' ':13);
          NormVideo; Write(' ':19);
          InverseVideo;
          Write('   Any other key-return to file selector   ');
          NormVideo; WriteLn(' ');
        END {analyzeandprint};

      PROCEDURE DisplayFile;
        VAR
          i : integer;
          LineCount : integer;
          MyCh      : char;
          BuffIx    : integer;

        PROCEDURE FillScreen;

          PROCEDURE ShowLine;
            VAR StartIx : integer;
            BEGIN
              StartIx := BuffIx;
              REPEAT
                {Only special handling is this one character for .DOC files.}
                IF DocExtender AND (BigBuffer^[BuffIx] = CHR($1E))
                  THEN Write(' ')
                  ELSE Write(BigBuffer^[BuffIx]);
                BuffIx := BuffIx+1;
              UNTIL (BigBuffer^[BuffIx] = CHR(10))  {Line feed}
              OR (BuffIx > StartIx+80);
            END {showline};

          BEGIN {fillscreen}
            WHILE (BuffIx < NbrBytes) AND (LineCount < 22) DO
              BEGIN
                ShowLine;
                LineCount := LineCount+1;
              END;
          END {fillscreen};

        BEGIN {displayfile}
          {Buffer used so far is too small. Start over with a big one.}
          FOR i := 1 TO 32256 DO
            BigBuffer^[i] := ' ';
          {Handle files up to 32,256 bytes. Read entire file with
          this one call on RESET.}
          {There is a flaw in Personal Pascal in that it doesn't detect
          read past end of file on a RESET.}
          RESET(BigBuffer,MyFile);
          BuffIx := 1;
          REPEAT
            LineCount := 0;
            FillScreen;
            WriteLn;
            Write(' ':13);
            InverseVideo;
            WriteLn
              ('   Press any key.  ''q'' to quit to the file selector.  ');
            NormVideo;
            Read(MyCh);
            ClrScr;
          UNTIL (MyCh = 'q') OR (MyCh = 'Q');
        END {displayfile};

      PROCEDURE ProcessDate;
        {Acquire the date from the OS and display it on the monitor.}
        VAR
          MyHandle : integer;
          Ptr   : T4;
          Month,Day,Year : integer;
          Date : integer;

        PROCEDURE GSDTOF(BufferPtr:T4; Handle,Flag:integer);
          GEMDOS($57);

        BEGIN {processdate}
          MyHandle := HANDLE(ThisFile);
          NEW(Ptr);
          GSDTOF(Ptr,MyHandle,0);
          Date := Ptr^[1];
          Day := Date & $1F;
          Month := SHR(Date,5) & $0F;
          Year  := SHR(Date,9) + 1980;
          {Want to show the date in a familiar format.
          For example, GEM shows 01-06-89}
          Write(' ':23, 'Date:');
          IF Month < 10
            THEN Write('0',Month)
            ELSE Write(Month);
          Write('-');
          IF Day < 10
            THEN Write('0',Day)
            ELSE Write(Day);
          Write('-',Year-1900);
        END {processdate};

      PROCEDURE ProcessDelete;
        {The user has already typed a 'd'. Process the rest of the word
        and delete the file if that is what the user wants.}
        VAR s:string; i:integer;

        FUNCTION UpperCase(ch:char):char;
          BEGIN
            IF (ch >= 'a') AND (ch <= 'z')
              THEN UpperCase := CHR(ORD(ch)-32)
              ELSE UpperCase := ch;
          END {uppercase};

        BEGIN
          ReadLn(S);
          FOR i := 1 TO Length(S) DO
            S[i] := UpperCase(S[i]);
          IF POS('ELETE',S) > 0
            THEN ERASE(ThisFile)
          ELSE {user typed <d> followed by gibberish.
              Return to file selector.};
          ClrScr;
        END {processdelete};

      BEGIN {processfile}
        CLrScr;  {Avoid ugly gray box while file is being read.}
        {Erase the buffer to ' '}
        FOR i := 1 TO 1230 DO
          ThisFile^[i] := ' ';
        RESET(ThisFile,MyFile);
        {First 1230 char have been read.}
        SetUp;
        AnalyzeAndPrint;
        ProcessDate;
        WriteLn(' ':8, 'Bytes:',NbrBytes);
        Read(ch);
        IF (ch = 't') OR (ch = 'T')
          THEN
            BEGIN
              ClrScr;
              DisplayFile;
            END
          ELSE
            IF (ch = 'd') OR (ch = 'D')
              THEN ProcessDelete
              ELSE {next file}
                ClrScr;
      END {processfile};

    BEGIN {doit}
      Init_Mouse;
      DisplayCoverSheet;
      MyFile := '';
      GetDriveAndPath(MyPath);
      REPEAT
        GoToXY(2,21);
        InverseVideo;
        Write('  Select cancel to quit to the desktop.  ');
        NormVideo;
        IF Get_In_File(MyPath,MyFile)
          THEN ProcessFile
          ELSE HALT;  {user cancel}
      UNTIL FALSE;
    END {doit};

  BEGIN {buffer}
    DoIt;
  END {buffer};

BEGIN {main}
  REWRITE(Printer,'PRN:');
  ClrScr;
  IF Init_Gem >= 0
    THEN Buffer;
END {program}.


(*                         TABLE OF CONTENTS
    There may be slight discrpencies in line numbers because of
                            last minute fixes.
   12 PROGRAM KomitetGosudarstvennoyeBezopastnosti;
   14  |{$I GEMCONST.PAS}
   16  |{$I GEMTYPE.PAS}
   26 {$I GEMSUBS.PAS}
   27 {$I CURSOR.PAS}
   29 PROCEDURE Buffer;
   35  |PROCEDURE DoIt;
   40  | |PROCEDURE DisplayCoverSheet;
   49  | | |PROCEDURE MakeText
   56  | | | |BEGIN {maketext}
   62  | | |PROCEDURE DrawBox;
   89  | | |BEGIN {displaycoversheet}
   97  | |PROCEDURE GetDriveAndPath(VAR S:string);
  106  | | |FUNCTION CurrentDisk:integer;
  110  | | |PROCEDURE GetDir(VAR Ptr:string; DriveID:integer);
  115  | | |BEGIN {getdriveandpath}
  130  | |PROCEDURE ProcessFile;
  141  | | |PROCEDURE SetUp;
  143  | | | |PROCEDURE GetFileSize(FileName : path_name;
  168  | | | | |PROCEDURE StrToC_String(Name1 : Path_Name; VAR Name2 : CString)
  178  | | | | |PROCEDURE SetDTA(VAR Addr : DTA_Type);
  181  | | | | |FUNCTION SearchFirst(VAR FileName   : cstring;
  186  | | | | |BEGIN {getfilesize}
  198  | | | |BEGIN {setup}
  210  | | |PROCEDURE AnalyzeAndPrint;
  245  | | |PROCEDURE DisplayFile;
  252  | | | |PROCEDURE FillScreen;
  254  | | | | |PROCEDURE ShowLine;
  268  | | | | |BEGIN {fillscreen}
  276  | | | |BEGIN {displayfile}
  300  | | |PROCEDURE ProcessDate;
  308  | | | |PROCEDURE GSDTOF(BufferPtr:T4; Handle,Flag:integer);
  311  | | | |BEGIN {processdate}
  333  | | |PROCEDURE ProcessDelete;
  338  | | | |FUNCTION UpperCase(ch:char):char;
  356  | | |BEGIN {processfile}
  381  | |BEGIN {doit}
  397  |BEGIN {buffer}
  401 BEGIN {main}
                                 *)