/jcl/examples/windows/delphitools/peviewer/PeGenDef.pas

  1{**************************************************************************************************}
  2{                                                                                                  }
  3{ Project JEDI Code Library (JCL) - Delphi Tools                                                   }
  4{                                                                                                  }
  5{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
  6{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
  7{ License at http://www.mozilla.org/MPL/                                                           }
  8{                                                                                                  }
  9{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
 10{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
 11{ and limitations under the License.                                                               }
 12{                                                                                                  }
 13{ The Original Code is PeGenDef.pas.                                                               }
 14{                                                                                                  }
 15{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are     }
 16{ Copyright (C) of Petr Vones. All Rights Reserved.                                                }
 17{                                                                                                  }
 18{ Contributor(s):                                                                                  }
 19{                                                                                                  }
 20{**************************************************************************************************}
 21{                                                                                                  }
 22{ Last modified: $Date$                                                      }
 23{                                                                                                  }
 24{**************************************************************************************************}
 25
 26unit PeGenDef;
 27
 28{$I JCL.INC}
 29
 30interface
 31
 32uses
 33  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 34  JclPeImage, ComCtrls, StdCtrls, Spin;
 35
 36type
 37  TPeUnitGenFlags = set of (ufDecorated, ufDuplicate, ufVariable);
 38
 39  TPeUnitGenerator = class(TJclPeImage)
 40  private
 41    FUnitGenFlags: array of TPeUnitGenFlags;
 42    function GetUnitGenFlags(Index: Integer): TPeUnitGenFlags;
 43  public
 44    procedure GenerateUnit(Strings: TStrings; const LibConst: string; WrapPos: Integer);
 45    procedure ScanExports;
 46    property UnitGenFlags[Index: Integer]: TPeUnitGenFlags read GetUnitGenFlags;
 47  end;
 48
 49  TPeGenDefChild = class(TForm)
 50    PageControl1: TPageControl;
 51    TabSheet1: TTabSheet;
 52    TabSheet2: TTabSheet;
 53    FunctionsListView: TListView;
 54    UnitRichEdit: TRichEdit;
 55    GroupBox1: TGroupBox;
 56    Label1: TLabel;
 57    LibConstNameEdit: TEdit;
 58    WrapSpinEdit: TSpinEdit;
 59    WrapCheckBox: TCheckBox;
 60    SaveDialog: TSaveDialog;
 61    procedure FormClose(Sender: TObject; var Action: TCloseAction);
 62    procedure FormCreate(Sender: TObject);
 63    procedure FormDestroy(Sender: TObject);
 64    procedure FunctionsListViewData(Sender: TObject; Item: TListItem);
 65    procedure FunctionsListViewCustomDrawItem(Sender: TCustomListView;
 66      Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
 67    procedure PageControl1Change(Sender: TObject);
 68    procedure WrapCheckBoxClick(Sender: TObject);
 69  private
 70    FPeUnitGenerator: TPeUnitGenerator;
 71    procedure SetFileName(const Value: TFileName);
 72    function GetFileName: TFileName;
 73    procedure GenerateUnit;
 74  public
 75    function CanSave: Boolean;
 76    procedure SaveUnit;
 77    property FileName: TFileName read GetFileName write SetFileName;
 78  end;
 79
 80var
 81  PeGenDefChild: TPeGenDefChild;
 82
 83implementation
 84
 85uses PeViewerMain, JclFileUtils, ToolsUtils, JclSysUtils;
 86
 87{$R *.DFM}
 88
 89const
 90  nfDecoratedName   = $01;
 91  nfAnsiUnicodePair = $02;
 92
 93function PascalizeName(const Name: string): string;
 94  function CharIsValidLeadingChar(const C: Char): Boolean;
 95  begin
 96    case C of
 97      'A'..'Z',
 98      'a'..'z':
 99        Result := True;
100    else
101      Result := False;
102    end;
103  end;
104  function CharIsStripLeadingChar(const C: Char): Boolean;
105  begin
106    Result := C = '_';
107  end;
108  function CharIsValid(const C: Char): Boolean;
109  begin
110    case C of
111      'A'..'Z',
112      'a'..'z',
113      '0'..'9':
114        Result := True;
115    else
116      Result := False;
117    end;
118  end;
119const
120  InvalidCharReplacement = '_';
121  StopChar = '@';
122var
123  I: Integer;
124  C: Char;
125begin
126  SetLength(Result, Length(Name));
127  Result := '';
128  for I := 1 to Length(Name) do
129  begin
130    C := Name[I];
131    if I = 1 then
132    begin
133      if CharIsValidLeadingChar(C) then
134        Result := Result + C
135      else
136      if not CharIsStripLeadingChar(C) then
137        Break; // probably MS C++ or Borland name decoration
138    end else
139    begin
140      if CharIsValid(C) then
141        Result := Result + C
142      else
143      if C = StopChar then
144        Break
145      else
146        Result := Result + InvalidCharReplacement;
147    end;
148  end;
149  I := Length(Result);
150  while I > 0 do
151    if Result[I] = InvalidCharReplacement then
152    begin
153      Delete(Result, I, 1);
154      Dec(I);
155    end
156    else
157      Break;
158end;
159
160function PossiblyAnsiUnicodePair(const Name1, Name2: AnsiString): Boolean;
161const
162  AnsiUnicodeSuffixes = ['A', 'W'];
163var
164  L1, L2: Integer;
165  Suffix1, Suffix2: AnsiChar;
166begin
167  Result := False;
168  L1 := Length(Name1);
169  L2 := Length(Name2);
170  if (L1 = L2) and (L1 > 1) then
171  begin
172    Suffix1 := Name1[L1];
173    Suffix2 := Name2[L2];
174    Result := (Suffix1 in AnsiUnicodeSuffixes) and (Suffix2 in AnsiUnicodeSuffixes) and
175      (Suffix1 <> Suffix2) and (Copy(Name1, 1, L1 - 1) = Copy(Name2, 1, L2 - 1));
176  end;
177end;
178
179function IsDecoratedName(const Name: string): Boolean;
180begin
181  Result := (Length(Name) > 1) and (Name[1] = '?') and (Name[1] = '@');
182end;
183
184
185{ TPeUnitGenerator }
186
187procedure TPeUnitGenerator.GenerateUnit(Strings: TStrings; const LibConst: string;
188  WrapPos: Integer);
189var
190  I: Integer;
191  S: string;
192begin
193  Strings.Add('implementation');
194  Strings.Add('');
195  Strings.Add('const');
196  Strings.Add(Format('  %s = ''%s'';', [LibConst, ExtractFileName(FileName)]));
197  Strings.Add('');
198  for I := 0 to ExportList.Count - 1 do
199    with ExportList[I] do
200      if FUnitGenFlags[I] = [] then
201      begin
202        S := Format('function %s; external %s name ''%s'';', [PascalizeName(Name), LibConst, Name]);
203        if WrapPos > 0 then
204          S := WrapText(S, #13#10'  ', [' '], WrapPos);
205        Strings.Add(S);
206      end;
207  Strings.Add('');
208  Strings.Add('end.');
209end;
210
211function TPeUnitGenerator.GetUnitGenFlags(Index: Integer): TPeUnitGenFlags;
212begin
213  Result := FUnitGenFlags[Index];
214end;
215
216procedure TPeUnitGenerator.ScanExports;
217var
218  I: Integer;
219  PascalName, LastName, FirstSectionName: string;
220  LastAddress: DWORD;
221  Flags: TPeUnitGenFlags;
222begin
223  SetLength(FUnitGenFlags, ExportList.Count);
224  ExportList.SortList(esName);
225  LastName := '';
226  LastAddress := 0;
227  FirstSectionName := ImageSectionNames[0]; // The first section is code section
228  for I := 0 to ExportList.Count - 1 do
229    with ExportList[I] do
230    begin
231      Flags := [];
232      if SectionName <> FirstSectionName then
233        Include(Flags, ufVariable)
234      else
235      if IsDecoratedName(Name) then
236        Include(Flags, ufDecorated)
237      else
238      begin
239        PascalName := PascalizeName(Name);
240        if (LastAddress = Address) and (LastName = PascalName) then
241          Include(Flags, ufDuplicate);
242        LastName := PascalName;
243        LastAddress := Address;
244      end;
245      FUnitGenFlags[I] := Flags;
246    end;
247end;
248
249{ TPeGenDefChild }
250
251procedure TPeGenDefChild.FormClose(Sender: TObject; var Action: TCloseAction);
252begin
253  Fix_ListViewBeforeClose(Self);
254  Action := caFree;
255end;
256
257procedure TPeGenDefChild.FormCreate(Sender: TObject);
258begin
259  FPeUnitGenerator := TPeUnitGenerator.Create;
260end;
261
262procedure TPeGenDefChild.FormDestroy(Sender: TObject);
263begin
264  FreeAndNil(FPeUnitGenerator);
265end;
266
267function TPeGenDefChild.GetFileName: TFileName;
268begin
269  Result := FPeUnitGenerator.FileName;
270end;
271
272procedure TPeGenDefChild.SetFileName(const Value: TFileName);
273begin
274  Screen.Cursor := crHourGlass;
275  try
276    FPeUnitGenerator.FileName := Value;
277    FPeUnitGenerator.ScanExports;
278    LibConstNameEdit.Text := PathExtractFileNameNoExt(Value) + 'Lib';
279    FunctionsListView.Items.Count := FPeUnitGenerator.ExportList.Count;
280    FunctionsListView.Invalidate;
281  finally
282    Screen.Cursor := crDefault;
283  end;
284end;
285
286procedure TPeGenDefChild.FunctionsListViewData(Sender: TObject; Item: TListItem);
287var
288  Flags: TPeUnitGenFlags;
289begin
290  Flags := FPeUnitGenerator.UnitGenFlags[Item.Index];
291  with Item, FPeUnitGenerator.ExportList[Item.Index] do
292  begin
293    Caption := Name;
294    SubItems.Add(PascalizeName(Name));
295    SubItems.Add(AddressOrForwardStr);
296    if ufDuplicate in Flags then
297      ImageIndex := icoWarning
298    else
299    if Flags * [ufDecorated, ufVariable] = [] then
300      ImageIndex := icoExports
301    else
302      ImageIndex := -1;
303  end;
304end;
305
306procedure TPeGenDefChild.FunctionsListViewCustomDrawItem(Sender: TCustomListView;
307  Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
308var
309  Flags: TPeUnitGenFlags;
310begin
311  Flags := FPeUnitGenerator.UnitGenFlags[Item.Index];
312  if Flags * [ufDecorated, ufVariable] <> [] then
313    Sender.Canvas.Font.Style := [fsStrikeOut];
314end;
315
316procedure TPeGenDefChild.GenerateUnit;
317var
318  SL: TStringList;
319  WrapColumn: Integer;
320begin
321  Screen.Cursor := crHourGlass;
322  SL := TStringList.Create;
323  try
324    if WrapCheckBox.Checked then
325      WrapColumn := WrapSpinEdit.Value
326    else
327      WrapColumn := 0;
328    FPeUnitGenerator.GenerateUnit(SL, LibConstNameEdit.Text, WrapColumn);
329    UnitRichEdit.Text := SL.Text;
330  finally
331    SL.Free;
332    Screen.Cursor := crDefault;
333  end;
334end;
335
336procedure TPeGenDefChild.PageControl1Change(Sender: TObject);
337begin
338  if PageControl1.ActivePage = TabSheet1 then
339    LibConstNameEdit.SetFocus
340  else
341  if PageControl1.ActivePage = TabSheet2 then
342    GenerateUnit;
343end;
344
345procedure TPeGenDefChild.WrapCheckBoxClick(Sender: TObject);
346begin
347  WrapSpinEdit.Enabled := WrapCheckBox.Checked;
348end;
349
350function TPeGenDefChild.CanSave: Boolean;
351begin
352  Result := PageControl1.ActivePage = TabSheet2;
353end;
354
355procedure TPeGenDefChild.SaveUnit;
356begin
357  with SaveDialog do
358  begin
359    FileName := PathExtractFileNameNoExt(FPeUnitGenerator.FileName);
360    if Execute then
361      UnitRichEdit.Lines.SaveToFile(FileName);
362  end;
363end;
364
365end.