/jcl/examples/windows/delphitools/peviewer/PeGenDef.pas
Pascal | 365 lines | 303 code | 34 blank | 28 comment | 23 complexity | 4a7eeac24b657c4a5d11af3e7e96f856 MD5 | raw file
Possible License(s): BSD-3-Clause
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.