source: cprs/branches/ScanSourceForConstants/SrcScannerU.pas@ 1518

unit SrcScannerU;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ExtCtrls, ComCtrls, Menus;

const
  SIGNIF_LEN = 3;
  MODIFIED_STRING = '//kt -- Modified with SourceScanner on ';

type
  TMainForm = class(TForm)
    Panel1: TPanel;
    Splitter1: TSplitter;
    Panel2: TPanel;
    Panel4: TPanel;
    Panel5: TPanel;
    Panel3: TPanel;
    Panel6: TPanel;
    SaveButton: TBitBtn;
    OpenButton: TBitBtn;
    NextButton: TBitBtn;
    PrevButton: TBitBtn;
    OpenDialog1: TOpenDialog;
    Label1: TLabel;
    Label2: TLabel;
    SaveAsButton: TBitBtn;
    SaveDialog1: TSaveDialog;
    FileNameLabel: TLabel;
    ChangesLabel: TLabel;
    ConstantsButton: TBitBtn;
    DoneBtn: TBitBtn;
    OrigEdit: TMemo;
    NewEdit: TMemo;
    BitBtn1: TBitBtn;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Done1: TMenuItem;
    Report1: TMenuItem;
    ReportSourceChanges1: TMenuItem;
    procedure OpenButtonClick(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SaveButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure NextButtonClick(Sender: TObject);
    procedure PrevButtonClick(Sender: TObject);
    procedure DoneBtnClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure BitBtn1Click(Sender: TObject);
    procedure ReportSourceChanges1Click(Sender: TObject);
  private
    { Private declarations }
    FileModuleName : string;
    FName : string;
    dateStr : string;
    FileList: TStringList;
    FileListIndex :integer;
    NewEditText : AnsiString;
    ChangeNum : integer;
    function OpenInputFile(FName : string) : integer;
    function CloseCurFiles : integer;
    procedure ProcessFile;
    function HasSignifStr(s: string) : boolean;
    procedure ConvertCodeLine(var s:string;var constSName,constStr : string);
    function MakeConstName(Module,s : string) : string;
    function DoSave : integer;
    procedure SetChangesNum(Num: integer);
    function AlreadyEdited : Boolean;
    procedure HandleConstSection;
    procedure ShutDown;
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

function Piece(const S: string; Delim: char; PieceNum: Integer): string;

implementation

{$R *.dfm}

uses StrUtils,ShowConstsU, WorkingSplashU,ReviewChangesU, SearchMissingU;


function Piece(const S: string; Delim: char; PieceNum: Integer): string;
{ returns the Nth piece (PieceNum) of a string delimited by Delim }
var
  i: Integer;
  Strt, Next: PChar;
begin
  i := 1;
  Strt := PChar(S);
  Next := StrScan(Strt, Delim);
  while (i < PieceNum) and (Next <> nil) do
  begin
    Inc(i);
    Strt := Next + 1;
    Next := StrScan(Strt, Delim);
  end;
  if Next = nil then Next := StrEnd(Strt);
  if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt);
end;




procedure TMainForm.OpenButtonClick(Sender: TObject);
begin
  dateStr := DateToStr(Date);
  if OpenDialog1.Execute then begin
    FileList.Assign(OpenDialog1.Files);
    FileListIndex:=-1;
    NextButtonClick(nil);
  end;
end;

procedure TMainForm.NextButtonClick(Sender: TObject);
var Result : integer;
begin
  CloseCurFiles;
  repeat
    FileListIndex:=FileListIndex+1;
    if FileListIndex<FileList.Count then begin
      FName := FileList.Strings[FileListIndex];
      Result := OpenInputFile(FName);
      if Result = mrCancel then FileListIndex:=FileListIndex-1;
    end else begin
      FileListIndex:=FileListIndex-1;
      //Result := MessageDlg('No "Next" file to select.', mtError, [mbOK], 0);
      Result := 0;
    end;
  until Result <> -1;
end;


procedure TMainForm.PrevButtonClick(Sender: TObject);
var Result : integer;
begin
  FileListIndex:=FileListIndex-1;
  if FileListIndex>-1 then begin
    FName := FileList.Strings[FileListIndex];
    Result := OpenInputFile(FName);
    if Result = mrCancel then FileListIndex:=FileListIndex+1;
  end else begin
    FileListIndex:=FileListIndex+1;
    MessageDlg('No "Previous" file to select.', mtError, [mbOK], 0);
  end;
end;

function TMainForm.OpenInputFile(FName : string) : integer;
var BakFName : string;
    UserChoice : integer;
begin
  Result := CloseCurFiles;
  if result <> mrCancel then begin
    FileNameLabel.Caption:= ExtractFileName(FName);
    FileModuleName := AnsiReplaceStr(FileNameLabel.Caption, '.pas', '');
    FileModuleName := AnsiReplaceStr(FileModuleName, ' ', '_');

    OrigEdit.Lines.LoadFromFile(FName);  //does a clear first
    UserChoice := mrYes;
    if AlreadyEdited then Begin
      UserChoice := MessageDlg(FName + #10+#10+#13 + 'File already processed.  Process AGAIN?',mtConfirmation, mbYesNoCancel,0);
    end;
    if UserChoice=mrYes then begin
      BakFName:=FName + '.bak';
      OrigEdit.Lines.SaveToFile(BakFName);  //make an immediate copy
      ProcessFile;
    end else if (UserChoice=mrNo) or (UserChoice=mrCancel) then begin
      if userChoice=mrCancel then Result := -2
      else Result := -1;
      CloseCurFiles;
      //OrigEdit.Lines.Clear;
      Application.ProcessMessages;
    end;
  end;
end;

function TMainForm.AlreadyEdited : Boolean;
begin
  Result := false;
  if OrigEdit.Lines.Count>0 then begin
    Result := (Pos(MODIFIED_STRING,OrigEdit.Lines.Strings[0])>0);
  end;
end;

function TMainForm.CloseCurFiles : integer;
begin
  //check if should be saved.
  Result := DoSave;
  if Result <> mrCancel then begin
    NewEdit.Lines.Clear;
  end;
  SetChangesNum(0);
  OrigEdit.Lines.Clear;
  FileNameLabel.Caption := '';
end;

procedure TMainForm.ProcessFile;
var i,j,tempI : integer;
    tempS,s : string;
    UserChoice: integer;
    constSName,constStr : string;
    FromList,ToList : TStringList;
    Abort : boolean;

begin
  WorkingForm.visible := true;
  Application.ProcessMessages;

  FromList := TStringList.Create;
  ToList := TStringList.Create;

  NewEdit.Visible := False;
  NewEdit.Lines.Add(MODIFIED_STRING+DateStr);

  //collect possible changes. -- finish later
  for i:=0 to OrigEdit.Lines.Count-1 do begin
    s := OrigEdit.Lines.Strings[i];
    if HasSignifStr(s) then begin
      tempS := s;
      ConvertCodeLine(s,constSName,constStr);  //s can be modified
      if tempS<>s then begin
        FromList.Add(tempS);
        ToList.Add(s);
      end
    end;
  end;

  ReviewChangesForm.CheckListBox1.Items.Clear;
  for i := 0 to FromList.Count-1 do begin
      ReviewChangesForm.CheckListBox1.Items.Add(FromList.Strings[i]);
      ReviewChangesForm.CheckListBox1.Checked[i]:= true;
  end;

  Abort := false;
  if FromList.Count > 0 then begin
    Abort := (ReviewChangesForm.ShowModal = mrCancel);    //let user deselect some lines
  end;
  if Abort then exit;

  for i:=0 to OrigEdit.Lines.Count-1 do begin
    s := OrigEdit.Lines.Strings[i];
    if HasSignifStr(s) then begin
      tempS := s;
      ConvertCodeLine(s,constSName,constStr);  //s can be modified
      if tempS<>s then begin
        tempI := FromList.IndexOf(tempS);
        if (tempI > -1) then begin
          if ReviewChangesForm.CheckListBox1.Checked[tempI] = true then begin
            for j:=1 to 2 do if MidStr(tempS,1,1)=' ' then tempS:=MidStr(tempS,2,999);
            tempS := '//'+tempS+ '  <-- original line.  //kt '+ dateStr;
            NewEdit.Lines.Add(tempS);
            ConstantsOutputForm.AddConst(constSName,constStr);
            SetChangesNum(ChangeNum+1);
          end else begin
            s := tempS;
          end;
        end else begin
          s := tempS;
        end;
        (*
        UserChoice := MessageDlg('Convert original line:'+#10+#13#13+
          tempS+#10+#13#13+'To:'+#10+#13#13+s,mtConfirmation,mbYesNoCancel,0);
        if UserChoice=mrYes then begin
          for j:=1 to 2 do if MidStr(tempS,1,1)=' ' then tempS:=MidStr(tempS,2,999);
          tempS := '//'+tempS+ '  <-- original line.  //kt '+ dateStr;
          NewEdit.Lines.Add(tempS);
          ConstantsOutputForm.AddConst(constSName,constStr);
          SetChangesNum(ChangeNum+1);
        end else if UserChoice=mrNo then begin
          s := tempS;
        end;
        *)
      end
    end;
    NewEdit.Lines.Add(s);
  end;
  HandleConstSection;
  WorkingForm.visible := false;
  NewEdit.Visible := True;
  FromList.Free;
  ToList.Free;
end;

procedure TMainForm.SetChangesNum(Num: integer);
begin
  ChangeNum := Num;
  ChangesLabel.Caption := IntToStr(ChangeNum) + ' Changes.';
end;

function TMainForm.HasSignifStr(s: string) : boolean;
var p1,p2 : integer;
    tempS : string;

begin
  Result := false;
  s := AnsiReplaceStr(s, '''''', '');  // convert '' --> null
  //screen for "//" style comments
  if Pos('//',s)>0 then begin  //ignore text after comments
    p1 := Pos('//',s);
    s := MidStr(s,1,p1-1);
  end;
  p1 := 0;
  repeat
    p1 := PosEx('''',s,p1+1);
    if (p1>0) and ((midstr(s,p1,2)<>'\"')) then begin
      p2 := PosEx('''',s,p1+1);
      if (p2-p1-1)>=SIGNIF_LEN then begin
        tempS:=midstr(s,p1,p2-p1);
        if (Pos('mmm',tempS)=0) and (Pos('yyy',tempS)=0) //skip date formatting strings
        and (Pos('ddd',tempS)=0)
        and (tempS<>UpperCase(tempS)) then begin   //skip all string that are COMPLETELY UPPER CASE
          Result:= true;
        end;
      end;
      p1:=p2;
    end;
  until (p1=0) or (Result=true);
end;


procedure TMainForm.ConvertCodeLine(var s:string;var constSName,constStr : string);
var
    origS, tempS : string;
    //constStr,constSName: string;
    p1,p2:integer;
begin
  origS:=s;
  while Pos('''''',s)>0 do begin
    s := AnsiReplaceStr(s, '''''', '\"');  // convert '' --> \"
  end;
  p1 := 0;
  repeat
    p1 := PosEx('''',s,p1+1);
    if (p1>0) and ((midstr(s,p1,2)<>'\"')) then begin
      p2 := PosEx('''',s,p1+1);
      if (p2-p1-1)>=SIGNIF_LEN then begin
        //create dkLang constant name & value
        constStr := AnsiMidStr(s, p1+1, (p2-p1-1));
        constStr := AnsiReplaceStr(constStr, '\"', '''''');  // convert '\"' --> ''
        constSName := MakeConstName(FileModuleName,constStr);
        //ConstantsOutputForm.AddConst(constSName,constStr);
        tempS := AnsiMidStr(s, 1, p1-1)+ 'DKLangConstW(''' + constSName + ''')';
        s := tempS + AnsiMidStr(s, p2+1, 999);
        p1 := length(tempS)+1;
      end else p1:=p2+1
    end;
  until (p1=0);

  s := AnsiReplaceStr(s, '\"', '''''');  // convert '\"' --> ''
  s := s+ ' //kt added ' +dateStr;
end;

function TMainForm.MakeConstName(Module,s : string) : string;
var i : integer;
begin
  s := Trim(s);
  s := AnsiReplaceStr(s, ' ', '_');
  i:=1;
  while not (i>Length(s)) do begin
    if not (s[i] in [' ','0'..'9','A'..'Z','a'..'z','_']) then begin
      //Delete(s, i,1);  //remove illegal characters.
      s[i]:='x'  //convert illegal chars to x.  If just delete, leads to name conflicts
    end;  
    //end else i:=i+1;
    i:=i+1;
  end;
  Result := FileModuleName + '_' + s;
end;

procedure TMainForm.SpeedButton1Click(Sender: TObject);
begin
  ConstantsOutputForm.Show;
end;

procedure TMainForm.SaveButtonClick(Sender: TObject);
begin
  DoSave;
end;

function TMainForm.DoSave : integer;
begin
  ConstantsOutputForm.SaveButtonClick(nil);
  Result := mrYes;
  if (NewEdit.Lines.Count>0) and (NewEdit.Lines.Text<>NewEditText) then begin
    Result := MessageDlg('Save Modified Source Code?' + #10+#13 +
                         '(Original saved as .bak file)',mtConfirmation, [mbYes, mbNo, mbCancel],0);
    if Result = mrYes then begin
      NewEdit.Lines.SaveToFile(FName);
      NewEditText:=NewEdit.Lines.Text;
    end;
  end else begin
    //MessageDlg('Nothing to save!', mtInformation, [mbOK], 0);
  end;
end;


procedure TMainForm.FormCreate(Sender: TObject);
begin
  FileList := TStringList.Create;
  ChangeNum := 0;

end;

procedure TMainForm.DoneBtnClick(Sender: TObject);
var Result : word;
begin
  ShutDown;
  Application.Terminate;
end;


Procedure TMainForm.HandleConstSection;
(* Note this is targeted for CPRS code, and the constants
   section comes after the implementation keyword
*)

var
  i,j,p1,p2 : integer;
  found : boolean;
  tempS : string;
  constStart,constEnd : integer;
  classStartLine,privateStartLine : integer;
  ConstList : TStringList;
  newProcList : TStringList;
  varList : TStringList;
  className :string;
  maxLen : integer;
  startI,endI : integer;
  implementationStartI : integer;

  function IsProcFn(s : string) : boolean;
  //return if line contains a procedure or function declaration
  begin
    Result := false;
    s := UpperCase(s);
    if pos ('//',s)>0 then begin
      s := MidStr(s,1,pos('//',s)-1);
    end;
    if (pos('PROCEDURE',s)>0) or (pos('FUNCTION',s)>0) then result := true;
  end;

  procedure FindProcFn(searchStartI : integer; var startI,endI: integer);
  //start as searchStartI and look for 'procedure' or 'function'
  //If found, then look for next iteration or end of file.
  //results returned in startI and endI (OUT parameters)
  var i : integer;
      startFound: boolean;
      tempS : string;
  begin
    endI := NewEdit.Lines.Count-1;
    startI := endI;
    startFound := false;
    for i:= searchStartI to NewEdit.Lines.Count-1 do begin
      tempS := NewEdit.Lines.Strings[i];
      if IsProcFn(tempS) then begin
        if startFound = false then begin
          startFound := true;
          startI := i;
        end else begin
          endI := i-1;
          break;
        end;
      end;
    end;
  end;

  function ContainsConst(startI,endI : integer) : boolean;
  //scan code and see if any reference is made to new vars (substituted for consts)
  var i,j : integer;
      tempS : string;
  begin
    Result := false;
    for i := startI to endI do begin
      tempS := UpperCase(NewEdit.Lines.Strings[i]);
      for j := 0 to ConstList.Count-1 do begin
        if pos(ConstList.Strings[j],tempS)>0 then begin
          Result := true;
          break;
        end;
      end;
      if Result = true then break;
    end;
  end;

  procedure InsertSetupVars(startI : integer);
  //insert 'SetupVars' into line directly after first 'begin'
  //Note: this will fail if code has imbedded procedures (which I
  //  don't think CPRS programmers used.)
  //   Also will fail if begin is not on a line by itself.
  var i : integer;
      tempS : string;
      found : boolean;
  begin
    found := false;
    for i := startI to NewEdit.Lines.Count-1 do begin
      tempS := UpperCase(NewEdit.Lines.Strings[i]);
      if tempS='BEGIN' then begin
        found := true;
        break;
      end;
    end;
    if found then begin
      temps := '  SetupVars;  //kt added '+DateStr+' to replace constants with vars.';
      NewEdit.Lines.Insert(i+1,tempS);
    end;
  end;

  procedure CheckFixProcFn(startI,endI : integer);
  //Scan procedure or function and add 'SetupVars;' if needed.
  var i : integer;
      tempS : string;
  begin
    tempS := UpperCase(NewEdit.Lines.Strings[startI]);
    if pos('.SETUPVARS',tempS)=0 then begin
      if ContainsConst(startI,endI) then begin
        InsertSetupVars(startI);
      end;
    end;
  end;

  function implementationStart : integer;
  var i : integer;
  begin
    Result := 0;
    //find implementation line
    for i := 0 to NewEdit.Lines.Count-1 do begin
      tempS := NewEdit.Lines.Strings[i];
      tempS := UpperCase(tempS);
      if pos('IMPLEMENTATION',tempS)>0 then begin
        Result := i;
        break;
      end;
    end;
  end;


begin
  ConstList := TStringList.Create;
  newProcList := TStringList.Create;
  varList := TStringList.Create;

  found := false;
  //Find class name
  for i := 0 to NewEdit.Lines.Count-1 do begin
    tempS := NewEdit.Lines.Strings[i];
    tempS := UpperCase(tempS);
    if (pos('CLASS',tempS)>0) and (pos('=',tempS)>0) then begin
      classStartLine := i;
      className := piece(NewEdit.Lines.Strings[i],'=',1);
      className := trim(className);
      found := true;
      newProcList.Add(' ');
      newProcList.Add(' ');
      newProcList.Add('procedure '+className+'.SetupVars;');
      newProcList.Add('//kt Added entire function to replace constant declarations '+DateStr);
      newProcList.Add('begin');
      break;
    end;
  end;
  //next implementation line
  if found = true then begin
    implementationStartI := implementationStart();
    if implementationStartI=0 then found := false;
  end;

  //Next find 'const' starting line
  if found then begin
    found := false;
    for i := i to NewEdit.Lines.Count-1 do begin
      tempS := NewEdit.Lines.Strings[i];
      tempS := Trim(UpperCase(tempS));
      if tempS='CONST' then begin
        found := true;
        constStart:=i+1;
        break;
      end;
    end;
  end;
  //next find end of const section
  if found then begin
    found := false;
    for i := constStart to NewEdit.Lines.Count-1 do begin
      tempS := NewEdit.Lines.Strings[i];
      tempS := MidStr(UpperCase(tempS),1,3);
      if (tempS='VAR') or (tempS='PRO') or (tempS='FUN')
      or (tempS='IMP') then begin
        constEnd := i-1;
        found := true;
        break;
      end;
    end;
  end;
  //Insert function for SetupVars into code
  if found = true then begin
    for i:=constStart to constEnd do begin
      tempS := NewEdit.Lines.Strings[i];
      if (MidStr(tempS,1,2)<>'//') and (Pos('DKLangConstW',tempS)>0) then begin
        p1:=pos('//kt',tempS);
        if p1>0 then begin
          tempS := MidStr(tempS,1,p1-1);
        end;   //chnage here...
        newProcList.Add(tempS);
        if pos('=',tempS)>0 then begin
          tempS := piece(tempS,'=',1);
          tempS := Trim(tempS);
          constList.Add(tempS);
        end;
      end;
    end;
    newProcList.Add('end;');
    newProcList.Add(' ');
    for i := 0 to newProcList.Count-1 do begin
      tempS := newProcList.Strings[i];
      NewEdit.Lines.Insert(constEnd+1+i,tempS);
    end;
    //now remove changes from old const section
    for i := constEnd downto constStart do begin
      tempS := newEdit.Lines.Strings[i];
      if pos('DKLangConstW',tempS)>0 then begin
        newEdit.Lines.Delete(i);
      end;
    end;
    //now add constants names into class def as string vars
    found := false;
    for i := classStartLine to NewEdit.Lines.Count-1 do begin
      tempS := UpperCase(newEdit.Lines.Strings[i]);
      if pos('PRIVATE',tempS)>0 then begin
        privateStartLine := i+1;
        found := true;
        break;
      end;
    end;
    if (found = true) and (ConstList.Count>0) then begin
      //first find length of longest entry to allow better text formatting
      maxLen := 0;
      for i := 0 to ConstList.Count-1 do begin
        if length(ConstList.Strings[i])>maxLen then maxLen := length(ConstList.Strings[i]);
      end;
      newEdit.Lines.Insert(privateStartLine,'    //kt Begin Mod (change Consts to Vars) '+DateStr);
      for i := ConstList.Count-1 downto 0 do begin
        tempS := '    '+ConstList.Strings[i];
        for j := 1 to maxLen-length(ConstList.Strings[i]) do tempS := tempS + ' ';
        tempS := tempS +'  : string;  //kt';
        newEdit.Lines.Insert(privateStartLine+1,tempS);
      end;
      newEdit.Lines.Insert(privateStartLine+ConstList.Count+1,'    //kt End Mod -------------------');
    end;

    //add declaration of procedure SetupVars to END of private section in type def

    // complete...

    //Last step: ensure any proc/function that references one of the entries in ConstList
    //includes a call to SetupVars at the beginning of the code
    i := implementationStart();
    while (i<NewEdit.Lines.Count) do begin
      FindProcFn(i,startI,endI);
      if startI<>endI then begin
        CheckFixProcFn(startI,endI);
        i := endI;
      end else begin
        i := i+1;
      end;
    end;

  end;
  ConstList.Free;
  newProcList.Free;
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ShutDown;
end;

procedure TMainForm.ShutDown;
begin
  CloseCurFiles;
  ConstantsOutputForm.SaveButtonClick(nil);
  FileList.Free;
end;

procedure TMainForm.BitBtn1Click(Sender: TObject);
begin
  SearchConstsForm.Show;
  SearchConstsForm.SearchBtnClick(self);
end;

procedure TMainForm.ReportSourceChanges1Click(Sender: TObject);
begin
  SearchConstsForm.Show;
  SearchConstsForm.cbReportChanges.Checked := true;
  SearchConstsForm.SearchBtnClick(self);
  SearchConstsForm.cbReportChanges.Checked := false;
end;

end.