High Voltage Shareware/high1.zip/high1/DIR4/PASSCA.ZIP/PASSCAN.PAS

Pascal/Delphi Source File | 1993-12-19 | 19KB | 644 lines

{************************************************}
{   PASSCAN.PAS                                  }
{   Originally:                                  }
{   Turbo Pascal for Windows                     }
{   Demo program  FConvert.pas                   }
{   Copyright (c) 1991 by Borland International  }
{************************************************}
{   Quick and Dirty Modification by              }
{   Mike Carey - 76450,1030   12/19/93           }
{************************************************}
{   This program will scan one or more *.pas     }
{   files for compiler directives, getmems and   }
{   freemems.  It will output the results to     }
{   the screen, and optionally to a disk file    }
{   named PASSCAN.LOG.  If output to file, it    }
{   will launch Notepad so that the results may  }
{   be printed (ok, so I'm lazy).  This code is  }
{   cobbled together and inefficient, but I      }
{   needed something easier to use than GREP     }
{   that would show me the compiler directives   }
{   in each of my units, as well as a safety     }
{   check of memory allocations.  Be forwarned   }
{   that if what you're scanning for stradles    }
{   the read buffer, the results will be         }
{   inaccurate.  Also, memory allocations        }
{   quantified by variables/constants will not   }
{   be totaled.                                  }
{                                                }
{   Feel free to use, modify, improve, or        }
{   discard as you see fit.                      }
{************************************************}


{$X+} {$I-,S-}
program PasScan;


uses WinTypes, WinProcs, WinDos, WObjects, Strings, BWCC;


{$R PasScan}

const

{ Resource IDs }

  id_Dialog = 100;

{ Scan dialog item IDs }

  id_FileName   = 100;
  id_FilePath   = 101;
  id_FileList   = 102;
  id_DirList    = 103;
  id_fileOutput = 105;
  id_Scan       = 106;

{ File specifier maximum length }

  fsFileSpec = fsFileName + fsExtension;

{ Scan Buffer size }

  BufSize = 32768;

var
  Buffer: PChar;

type

{ TScanDialog is the main window of the application. }

  PScanDialog = ^TScanDialog;
  TScanDialog = object(TDlgWindow)
    FileName,TempName: array[0..fsPathName] of Char;
    Extension: array[0..fsExtension] of Char;
    FileSpec: array[0..fsFileSpec] of Char;
    ResultList: pListBox;
    FileCount: word;
    FirstPass: bool;
    OutputFile: file;
    FileOut: bool;

    constructor Init;
    destructor Done; virtual;
    procedure SetupWindow; virtual;
    function GetClassName: PChar; virtual;
    function GetFileName(index: integer): Boolean;
    procedure SelectFileName;
    procedure UpdateFileName;
    function UpdateListBoxes: Boolean;
    function  ScanFile: Boolean;
    procedure DoFileName(var Msg: TMessage);
      virtual id_First + id_FileName;
    procedure DoFileList(var Msg: TMessage);
      virtual id_First + id_FileList;
    procedure DoDirList(var Msg: TMessage);
      virtual id_First + id_DirList;
    procedure DoScan(var Msg: TMessage);
      virtual id_First + id_Scan;
  end;

{ TScanApp is the application object. It creates a main window of
  type TScanDialog. }

  TScanApp = object(TApplication)
    procedure InitMainWindow; virtual;
  end;


{ Return a pointer to the file name part of a file path. }

function GetFileName(FilePath: PChar): PChar;
var
  P: PChar;
begin
  P := StrRScan(FilePath, '\');
  if P = nil then P := StrRScan(FilePath, ':');
  if P = nil then GetFileName := FilePath else GetFileName := P + 1;
end;

{ Return a pointer to the extension part of a file path. }

function GetExtension(FilePath: PChar): PChar;
var
  P: PChar;
begin
  P := StrScan(GetFileName(FilePath), '.');
  if P = nil then GetExtension := StrEnd(FilePath) else GetExtension := P;
end;

{ Return True if the specified file path contains wildcards. }

function HasWildCards(FilePath: PChar): Boolean;
begin
  HasWildCards := (StrScan(FilePath, '*') <> nil) or
    (StrScan(FilePath, '?') <> nil);
end;

{ Copy Source file name to Dest, changing the extension to Ext. }

function MakeFileName(Dest, Source, Ext: PChar): PChar;
begin
  MakeFileName := StrLCat(StrLCopy(Dest, Source,
    GetExtension(Source) - Source), Ext, fsPathName);
end;

{ Delete a file. }

procedure FileDelete(FileName: PChar);
var
  F: file;
begin
  Assign(F, FileName);
  Erase(F);
  InOutRes := 0;
end;

{ Rename a file. }

procedure FileRename(CurName, NewName: PChar);
var
  F: file;
begin
  Assign(F, CurName);
  Rename(F, NewName);
  InOutRes := 0;
end;

{ TScanDialog }

{ Scan dialog constructor. }

constructor TScanDialog.Init;
begin
  TDlgWindow.Init(nil, PChar(id_Dialog));
  StrCopy(FileName, '*.pas');
  Extension[0] := #0;
  FileSpec[0] := #0;
  New(ResultList,InitResource(@self,425));
end;

destructor TScanDialog.Done;
begin
  if ResultList <> nil then dispose(ResultList,done);
  TDlgWindow.Done;
end;

{ SetupWindow is called right after the Scan dialog is created.
  Limit the file name edit control to 79 characters, update the file
  and directory list boxes, and select the file name edit control. }

procedure TScanDialog.SetupWindow;
begin
  TDlgWindow.setupWindow;
  SendDlgItemMessage(HWindow, id_FileName, em_LimitText, fsPathName, 0);
  UpdateListBoxes;
  SelectFileName;
  FirstPass := true;
end;

{ Return window class name. This name corresponds to the class name
  specified for the Scan dialog in the resource file. }

function TScanDialog.GetClassName: PChar;
begin
  GetClassName := 'BorDlgWindow';
end;

{ Return True if the name in the file name edit control is not a
  directory and does not contain wildcards. Otherwise, update the
  file and directory list boxes as required. }

function TScanDialog.GetFileName(index: integer): Boolean;
var
  FileLen: Word;
begin
  GetFileName := False;
  sendmessage(getitemhandle(id_FileList),lb_gettext,word(index),longint(@FileName));
  setdlgitemtext(hWindow,id_FileName,FileName);
  FileExpand(FileName, FileName);
  FileLen := StrLen(FileName);
  if (FileName[FileLen - 1] = '\') or HasWildCards(FileName) or
    (GetFocus = GetDlgItem(HWindow, id_DirList)) then
  begin
    if FileName[FileLen - 1] = '\' then
      StrLCat(FileName, FileSpec, fsPathName);
    if not UpdateListBoxes then
    begin
      MessageBeep(0);
      SelectFileName;
    end;
    Exit;
  end;
  StrLCat(StrLCat(FileName, '\', fsPathName), FileSpec, fsPathName);
  if UpdateListBoxes then Exit;
  FileName[FileLen] := #0;
  if GetExtension(FileName)[0] = #0 then
    StrLCat(FileName, Extension, fsPathName);
  AnsiLower(FileName);
  GetFileName := True;
end;

{ Select the file name edit control. }

procedure TScanDialog.SelectFileName;
begin
  SendDlgItemMessage(HWindow, id_FileName, em_SetSel, 0, $7FFF0000);
  SetFocus(GetDlgItem(HWindow, id_FileName));
end;

{ Update the file name edit control. }

procedure TScanDialog.UpdateFileName;
begin
  if sendmessage(getitemhandle(id_FileList),lb_getselcount,0,0) > 1 then
    SetDlgItemText(HWindow, id_FileName,'* Multiple *')
  else
    begin
      SetDlgItemText(HWindow, id_FileName, AnsiLower(FileName));
      SendDlgItemMessage(HWindow, id_FileName, em_SetSel, 0, $7FFF0000);
    end;
end;

{ Update the file and directory list boxes. }

function TScanDialog.UpdateListBoxes: Boolean;
var
  Result: Integer;
  Path: array[0..fsFileName] of Char;
begin
  UpdateListBoxes := False;
  if DlgDirList(HWindow, FileName, id_FileList, id_FilePath, 0) <> 0 then
  begin
    DlgDirList(HWindow, '*.pas', id_DirList, 0, $C010);
    StrLCopy(FileSpec, FileName, fsFileSpec);
    UpdateFileName;
    UpdateListBoxes := True;
  end;
end;

{ Scan file from Oem to Ansi or from Ansi to Oem. }

function TScanDialog.ScanFile: Boolean;
const
  CRLF: array[0..1] of char = #13#10;
var
  N,R,memval: Word;
  okok,x,y: integer;
  L,GM,FM: Longint;
  TheString: PChar;
  P,P1,P2,P3,P4,PG,PF: PChar;
  BakName: array[0..fsPathName] of Char;
  InputFile: file;
  memch: array[0..50] of char;
  startline,lines,curline: word;
  oldcursor: hCursor;
  memstr: array[0..7] of char;
  memidx: byte;

  function Error(Stop: Boolean; Message: PChar): Boolean;
  begin
    if Stop then
    begin
      if TheString <> nil then freemem(TheString,100);
      if Buffer <> nil then FreeMem(Buffer, BufSize+1);
      if TFileRec(InputFile).Mode <> fmClosed then Close(InputFile);
      if TFileRec(OutputFile).Mode <> fmClosed then
      begin
        Close(OutputFile);
        Erase(OutputFile);
      end;
      InOutRes := 0;
      Setcursor(oldCursor);
      MessageBox(HWindow, Message, 'Error', mb_IconStop + mb_Ok);
    end;
    Error := Stop;
  end;

  procedure GetCurrentLine;
  begin
    {get current line ---------------------------------}
    P3 := strscan(P4,#13);
    while (P3 <> nil) and (P3 <= P1) do
      begin
        inc(CurLine);
        P4 := P3+1;
        P3 := strscan(P4,#13);
      end;
    wvsprintf(@memch,'%03u',FileCount);
    strcat(memch,#9);
    strcopy(TheString,memch);
    wvsprintf(@memch,'%05u',CurLine);
    strcat(memch,#9);
    strcat(TheString,memch);
    {-------------------------------------------------}
  end;

begin
  ScanFile := False;
  oldCursor := setcursor(LoadCursor(0,idc_Wait));
  getmem(TheString,200);
  if Error(Buffer = nil, 'Not enough memory for copy buffer.') then Exit;
  Assign(InputFile, FileName);
  Reset(InputFile,1);
  if Error(IOResult <> 0, 'Cannot open input file.') then Exit;
  if FileOut and FirstPass then
    begin
      MakeFileName(TempName, 'PasScan', '.Log');
      Assign(OutputFile, TempName);
      Rewrite(OutputFile,1);
      FirstPass := false;
      if Error(IOResult <> 0, 'Cannot create output file.') then Exit;
    end;
  L := FileSize(InputFile);
  wvsprintf(TheString,'%03u',FileCount);
  strcat(TheString,#9);
  strcat(TheString,#32#0);
  ResultList^.Addstring(TheString);
  wvsprintf(TheString,'%03u',FileCount);
  strcat(TheString,#9);
  strcat(TheString,#42#9#0);
  strLcat(TheString,strupper(FileName),99);
  ResultList^.Addstring(TheString);
  wvsprintf(TheString,'%03u',FileCount);
  strcat(TheString,#9);
  strcat(TheString,#42#42#9#32#0);
  ResultList^.Addstring(TheString);
  FM := 0; GM := 0; Lines := 0; CurLine := 0; startline := 0;
  while L > 0 do
  begin
    StartLine := Lines;
    if L > BufSize then N := BufSize else N := L;
    BlockRead(InputFile, Buffer^, N, R);
    Buffer[R] := #0;
    if Error(IOResult <> 0, 'Error reading input file.') then Exit;
    if strlen(Buffer) > 0 then
      begin
        {get total lines}
        P1 := Buffer; P := nil;
        P := strscan(P1,#13);
        while (P <> nil) and (P1 <> nil) do
          begin
            inc(Lines);
            P1 := P+1;
            P := strscan(P1,#13);
          end;

        {get compiler directives -----------------------------------------}
        P1 := Buffer; P := nil;
        P4 := Buffer; CurLine := 1 + StartLine;
        P := strscan(P1,'{');
        while (P <> nil) and (P1 <> nil) do
          begin
            P1 := strscan(P,'}');
            if (P[1] = '$') and (P1 <> nil) then
              begin
                GetCurrentLine;
                x := strlen(TheString);
                strmove(@TheString[x],P,(P1-P)+1);
                TheString[x+(P1-P)+1] := #0;
                ResultList^.addstring(TheString);
                updatewindow(ResultList^.hWindow);
              end;
            if P1 <> nil then
              P := strscan(P1,'{');
          end;

        {get getmems/freemems-------------------------------------------------}
        P1 := Buffer; P := nil;
        P4 := Buffer; CurLine := 1 + StartLine;
        PG := strpos(P1,'getmem');
        PF := strpos(P1,'freemem');
        if ((PG <> nil) and (PF = nil)) or ((PG <> nil) and (PG < PF)) then
          begin P := PG; PF := nil; strcopy(memstr,'getmem'); memidx := 6; end
        else
        if ((PF <> nil) and (PG = nil)) or ((PF <> nil) and (PF < PG)) then
          begin P := PF; PG := nil; strcopy(memstr,'freemem'); memidx := 7; end
        else
          P := nil;
        if P <> nil then P := strpos(P1,memstr);
        while (P <> nil) and (P1 <> nil) do
          begin
            P1 := strscan(P,')');
            if (P[memidx] = '(') and (P1 <> nil) then
              begin
                GetCurrentLine;
                x := strlen(TheString);
                strmove(@TheString[x],P,(P1-P)+1);
                TheString[x+(P1-P)+1] := #0;
                ResultList^.addstring(TheString);
                updatewindow(ResultList^.hWindow);
                P2 := strscan(P,',');
                if P2 <> nil then
                  begin
                    strLcopy(memch,@P2[1],(P1-P2)-1);
                    val(memch,memval,okok);
                    if okok = 0 then
                      case memidx of
                      6: inc(GM,memval);
                      7: inc(FM,memval);
                      end;
                  end;
              end;
            if P1 <> nil then
              begin
                PG := strpos(P1,'getmem');
                PF := strpos(P1,'freemem');
                if ((PG <> nil) and (PF = nil)) or ((PG <> nil) and (PG < PF)) then
                  begin P := PG; PF := nil; strcopy(memstr,'getmem'); memidx := 6; end
                else
                if ((PF <> nil) and (PG = nil)) or ((PF <> nil) and (PF < PG)) then
                  begin P := PF; PG := nil; strcopy(memstr,'freemem'); memidx := 7; end
                else
                  P := nil;
                if P <> nil then P := strpos(P1,memstr);
              end;
          end;
      end;
    Dec(L, N);
  end;

  {finish up ------------------------------------------------------------}
  if GM >= 0 then
    begin
      wvsprintf(TheString,'%03u',FileCount);
      strcat(TheString,#9);
      wvsprintf(@memch,'%lu% bytes allocated with GETMEM',GM);
      strcat(TheString,#42#42#42#42#9#0);
      strLcat(TheString,memch,99);
      ResultList^.addstring(TheString);
    end;
  if FM >= 0 then
    begin
      wvsprintf(TheString,'%03u',FileCount);
      strcat(TheString,#9);
      wvsprintf(@memch,'%lu% bytes freed with FREEMEM',FM);
      strcat(TheString,#42#42#42#42#9#0);
      strLcat(TheString,memch,99);
      ResultList^.addstring(TheString);
    end;
  if Lines >= 0 then
    begin
      wvsprintf(TheString,'%03u',FileCount);
      strcat(TheString,#9);
      wvsprintf(@memch,'%u% total lines',Lines);
      strcat(TheString,#42#42#42#42#9#0);
      strLcat(TheString,memch,99);
      ResultList^.addstring(TheString);
    end;
  wvsprintf(TheString,'%03u',FileCount);
  strcat(TheString,#9);
  strcat(TheString,#42#42#42#42#42#9#45#45#45#45#45#0);
  ResultList^.addstring(TheString);

  wvsprintf(TheString,'%03u',FileCount);
  strcat(TheString,#9); strcat(TheString,'99999');
  strcat(TheString,#9); strcat(TheString,'END - - - - - - - -');
  strcat(TheString,#12);
  x := ResultList^.addstring(TheString);
  sendmessage(ResultList^.hWindow,lb_settopindex,word(x),0);
  Close(InputFile);
  strcopy(FileName,#0);

  if FileOut then
    begin
      y := ResultList^.getcount;
      if y > 0 then
        begin
          getdlgitemtext(hWindow,380,Buffer,99);
          strcat(Buffer,#9);
          getdlgitemtext(hWindow,381,TheString,99);
          strcat(Buffer,TheString); strcat(Buffer,#9);
          getdlgitemtext(hWindow,382,TheString,99);
          strcat(Buffer,TheString); strcat(Buffer,#13#10);
        end;
      x := 0;
      TheString[0] := #0;
      while x < y do
        begin
          ResultList^.getstring(TheString,x);
          strLcat(Buffer,TheString,Bufsize);
          strLcat(Buffer,#13#10,Bufsize);
          inc(x);
        end;
      ResultList^.clearlist;
      BlockWrite(OutputFile, Buffer^, strlen(Buffer));
      if Error(IOResult <> 0, 'Error writing output file.') then Exit;
    end;
  freemem(TheString,200);
  ScanFile := FileOut;

  Setcursor(oldCursor);
end;

{ File name edit control response method. }

procedure TScanDialog.DoFileName(var Msg: TMessage);
begin
  if Msg.LParamHi = en_Change then
    EnableWindow(GetDlgItem(HWindow, id_Scan),
      SendMessage(Msg.LParamLo, wm_GetTextLength, 0, 0) <> 0);
end;

{ File list box response method. }

procedure TScanDialog.DoFileList(var Msg: TMessage);
begin
  case Msg.LParamHi of
    lbn_SelChange, lbn_DblClk:
      begin
        DlgDirSelect(HWindow, FileName, id_FileList);
        UpdateFileName;
      end;
    lbn_KillFocus:
      SendMessage(Msg.LParamLo, lb_SetCurSel, Word(-1), 0);
  end;
end;

{ Directory list box response method. }

procedure TScanDialog.DoDirList(var Msg: TMessage);
begin
  case Msg.LParamHi of
    lbn_SelChange, lbn_DblClk:
      begin
        DlgDirSelect(HWindow, FileName, id_DirList);
        StrCat(FileName, FileSpec);
        if Msg.LParamHi = lbn_DblClk then
          UpdateListBoxes else
          UpdateFileName;
      end;
    lbn_KillFocus:
      SendMessage(Msg.LParamLo, lb_SetCurSel, Word(-1), 0);
  end;
end;

{ Scan button response method. }

procedure TScanDialog.DoScan(var Msg: TMessage);
var
  OemToAnsi: Boolean;
  P: array[0..1] of PChar;
  S: array[0..127] of Char;
  InputFile : File;
  x,y: integer;
begin
  FileOut := isdlgbuttonchecked(hWindow,id_FileOutput) > 0;
  ResultList^.clearList;
  FileCount := 1;
  getmem(Buffer,BufSize+1);

  y := sendmessage(getitemhandle(id_FileList),lb_getcount,0,0);
  x := 0;
  while x < y do
    begin
      if sendmessage(getitemhandle(id_FileList),lb_getsel,word(x),0) > 0 then
        begin
          if not GetFileName(x) then Exit;
          sendmessage(getitemhandle(id_FileList),lb_settopindex,word(x),0);
          ScanFile;
          inc(FileCount);
        end;
      inc(x);
    end;
  if y > 0 then sendmessage(ResultList^.hWindow,lb_settopindex,word(0),0);
  messagebeep(0);

  if FileOut then
    Close(OutputFile);
  FileOut := false;
  if Buffer <> nil then FreeMem(Buffer, BufSize+1);

  if isdlgbuttonchecked(hWindow,id_FileOutput) > 0 then
    begin
      strcopy(S,'Notepad.exe ');
      strcat(S,TempName);
      WinExec(@S,sw_shownormal);
    end
  else
    begin
      UpdateListBoxes;
      SelectFileName;
    end;
end;

{ TScanApp }

{ Create a Scan dialog as the application's main window. }

procedure TScanApp.InitMainWindow;
begin
  MainWindow := New(PScanDialog, Init);
end;

var
  ScanApp: TScanApp;

begin
  ScanApp.Init('ScanApp');
  ScanApp.Run;
  ScanApp.Done;
end.