351 lines
11 KiB
ObjectPascal
351 lines
11 KiB
ObjectPascal
{**************************************************************************************************}
|
|
{ }
|
|
{ Project JEDI Code Library (JCL) - Delphi Tools }
|
|
{ }
|
|
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
|
|
{ you may not use this file except in compliance with the License. You may obtain a copy of the }
|
|
{ License at http://www.mozilla.org/MPL/ }
|
|
{ }
|
|
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF }
|
|
{ ANY KIND, either express or implied. See the License for the specific language governing rights }
|
|
{ and limitations under the License. }
|
|
{ }
|
|
{ The Original Code is PeGenDef.pas. }
|
|
{ }
|
|
{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are }
|
|
{ Copyright (C) of Petr Vones. All Rights Reserved. }
|
|
{ }
|
|
{ Contributor(s): }
|
|
{ }
|
|
{**************************************************************************************************}
|
|
{ }
|
|
{ Last modified: $Date: 2005/10/27 01:44:51 $ }
|
|
{ }
|
|
{**************************************************************************************************}
|
|
|
|
unit PeGenDef;
|
|
|
|
{$I JCL.INC}
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
|
JclPeImage, ComCtrls, StdCtrls, Spin;
|
|
|
|
type
|
|
TPeUnitGenFlags = set of (ufDecorated, ufDuplicate, ufVariable);
|
|
|
|
TPeUnitGenerator = class(TJclPeImage)
|
|
private
|
|
FUnitGenFlags: array of TPeUnitGenFlags;
|
|
function GetUnitGenFlags(Index: Integer): TPeUnitGenFlags;
|
|
public
|
|
procedure GenerateUnit(Strings: TStrings; const LibConst: string; WrapPos: Integer);
|
|
procedure ScanExports;
|
|
property UnitGenFlags[Index: Integer]: TPeUnitGenFlags read GetUnitGenFlags;
|
|
end;
|
|
|
|
TPeGenDefChild = class(TForm)
|
|
PageControl1: TPageControl;
|
|
TabSheet1: TTabSheet;
|
|
TabSheet2: TTabSheet;
|
|
FunctionsListView: TListView;
|
|
UnitRichEdit: TRichEdit;
|
|
GroupBox1: TGroupBox;
|
|
Label1: TLabel;
|
|
LibConstNameEdit: TEdit;
|
|
WrapSpinEdit: TSpinEdit;
|
|
WrapCheckBox: TCheckBox;
|
|
SaveDialog: TSaveDialog;
|
|
procedure FormClose(Sender: TObject; var Action: TCloseAction);
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure FormDestroy(Sender: TObject);
|
|
procedure FunctionsListViewData(Sender: TObject; Item: TListItem);
|
|
procedure FunctionsListViewCustomDrawItem(Sender: TCustomListView;
|
|
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
|
|
procedure PageControl1Change(Sender: TObject);
|
|
procedure WrapCheckBoxClick(Sender: TObject);
|
|
private
|
|
FPeUnitGenerator: TPeUnitGenerator;
|
|
procedure SetFileName(const Value: TFileName);
|
|
function GetFileName: TFileName;
|
|
procedure GenerateUnit;
|
|
public
|
|
function CanSave: Boolean;
|
|
procedure SaveUnit;
|
|
property FileName: TFileName read GetFileName write SetFileName;
|
|
end;
|
|
|
|
var
|
|
PeGenDefChild: TPeGenDefChild;
|
|
|
|
implementation
|
|
|
|
uses PeViewerMain, JclFileUtils, ToolsUtils, JclSysUtils;
|
|
|
|
{$R *.DFM}
|
|
|
|
const
|
|
nfDecoratedName = $01;
|
|
nfAnsiUnicodePair = $02;
|
|
|
|
function PascalizeName(const Name: string): string;
|
|
const
|
|
ValidLeadingChars = ['A'..'Z', 'a'..'z'];
|
|
StripLeadingChars = ['_'];
|
|
ValidChars = ValidLeadingChars + ['0'..'9'];
|
|
InvalidCharReplacement = '_';
|
|
StopChar = '@';
|
|
var
|
|
I: Integer;
|
|
C: Char;
|
|
begin
|
|
SetLength(Result, Length(Name));
|
|
Result := '';
|
|
for I := 1 to Length(Name) do
|
|
begin
|
|
C := Name[I];
|
|
if I = 1 then
|
|
begin
|
|
if C in ValidLeadingChars then
|
|
Result := Result + C
|
|
else
|
|
if not (C in StripLeadingChars) then
|
|
Break; // probably MS C++ or Borland name decoration
|
|
end else
|
|
begin
|
|
if C in ValidChars then
|
|
Result := Result + C
|
|
else
|
|
if C = StopChar then
|
|
Break
|
|
else
|
|
Result := Result + InvalidCharReplacement;
|
|
end;
|
|
end;
|
|
I := Length(Result);
|
|
while I > 0 do
|
|
if Result[I] = InvalidCharReplacement then
|
|
begin
|
|
Delete(Result, I, 1);
|
|
Dec(I);
|
|
end
|
|
else
|
|
Break;
|
|
end;
|
|
|
|
function PossiblyAnsiUnicodePair(const Name1, Name2: AnsiString): Boolean;
|
|
const
|
|
AnsiUnicodeSuffixes = ['A', 'W'];
|
|
var
|
|
L1, L2: Integer;
|
|
Suffix1, Suffix2: Char;
|
|
begin
|
|
Result := False;
|
|
L1 := Length(Name1);
|
|
L2 := Length(Name2);
|
|
if (L1 = L2) and (L1 > 1) then
|
|
begin
|
|
Suffix1 := Name1[L1];
|
|
Suffix2 := Name2[L2];
|
|
Result := (Suffix1 in AnsiUnicodeSuffixes) and (Suffix2 in AnsiUnicodeSuffixes) and
|
|
(Suffix1 <> Suffix2) and (Copy(Name1, 1, L1 - 1) = Copy(Name2, 1, L2 - 1));
|
|
end;
|
|
end;
|
|
|
|
function IsDecoratedName(const Name: string): Boolean;
|
|
begin
|
|
Result := (Length(Name) > 1) and (Name[1] in ['?', '@']);
|
|
end;
|
|
|
|
|
|
{ TPeUnitGenerator }
|
|
|
|
procedure TPeUnitGenerator.GenerateUnit(Strings: TStrings; const LibConst: string;
|
|
WrapPos: Integer);
|
|
var
|
|
I: Integer;
|
|
S: string;
|
|
begin
|
|
Strings.Add('implementation');
|
|
Strings.Add('');
|
|
Strings.Add('const');
|
|
Strings.Add(Format(' %s = ''%s'';', [LibConst, ExtractFileName(FileName)]));
|
|
Strings.Add('');
|
|
for I := 0 to ExportList.Count - 1 do
|
|
with ExportList[I] do
|
|
if FUnitGenFlags[I] = [] then
|
|
begin
|
|
S := Format('function %s; external %s name ''%s'';', [PascalizeName(Name), LibConst, Name]);
|
|
if WrapPos > 0 then
|
|
S := WrapText(S, #13#10' ', [' '], WrapPos);
|
|
Strings.Add(S);
|
|
end;
|
|
Strings.Add('');
|
|
Strings.Add('end.');
|
|
end;
|
|
|
|
function TPeUnitGenerator.GetUnitGenFlags(Index: Integer): TPeUnitGenFlags;
|
|
begin
|
|
Result := FUnitGenFlags[Index];
|
|
end;
|
|
|
|
procedure TPeUnitGenerator.ScanExports;
|
|
var
|
|
I: Integer;
|
|
PascalName, LastName, FirstSectionName: string;
|
|
LastAddress: DWORD;
|
|
Flags: TPeUnitGenFlags;
|
|
begin
|
|
SetLength(FUnitGenFlags, ExportList.Count);
|
|
ExportList.SortList(esName);
|
|
LastName := '';
|
|
LastAddress := 0;
|
|
FirstSectionName := ImageSectionNames[0]; // The first section is code section
|
|
for I := 0 to ExportList.Count - 1 do
|
|
with ExportList[I] do
|
|
begin
|
|
Flags := [];
|
|
if SectionName <> FirstSectionName then
|
|
Include(Flags, ufVariable)
|
|
else
|
|
if IsDecoratedName(Name) then
|
|
Include(Flags, ufDecorated)
|
|
else
|
|
begin
|
|
PascalName := PascalizeName(Name);
|
|
if (LastAddress = Address) and (LastName = PascalName) then
|
|
Include(Flags, ufDuplicate);
|
|
LastName := PascalName;
|
|
LastAddress := Address;
|
|
end;
|
|
FUnitGenFlags[I] := Flags;
|
|
end;
|
|
end;
|
|
|
|
{ TPeGenDefChild }
|
|
|
|
procedure TPeGenDefChild.FormClose(Sender: TObject; var Action: TCloseAction);
|
|
begin
|
|
Fix_ListViewBeforeClose(Self);
|
|
Action := caFree;
|
|
end;
|
|
|
|
procedure TPeGenDefChild.FormCreate(Sender: TObject);
|
|
begin
|
|
FPeUnitGenerator := TPeUnitGenerator.Create;
|
|
end;
|
|
|
|
procedure TPeGenDefChild.FormDestroy(Sender: TObject);
|
|
begin
|
|
FreeAndNil(FPeUnitGenerator);
|
|
end;
|
|
|
|
function TPeGenDefChild.GetFileName: TFileName;
|
|
begin
|
|
Result := FPeUnitGenerator.FileName;
|
|
end;
|
|
|
|
procedure TPeGenDefChild.SetFileName(const Value: TFileName);
|
|
begin
|
|
Screen.Cursor := crHourGlass;
|
|
try
|
|
FPeUnitGenerator.FileName := Value;
|
|
FPeUnitGenerator.ScanExports;
|
|
LibConstNameEdit.Text := PathExtractFileNameNoExt(Value) + 'Lib';
|
|
FunctionsListView.Items.Count := FPeUnitGenerator.ExportList.Count;
|
|
FunctionsListView.Invalidate;
|
|
finally
|
|
Screen.Cursor := crDefault;
|
|
end;
|
|
end;
|
|
|
|
procedure TPeGenDefChild.FunctionsListViewData(Sender: TObject; Item: TListItem);
|
|
var
|
|
Flags: TPeUnitGenFlags;
|
|
begin
|
|
Flags := FPeUnitGenerator.UnitGenFlags[Item.Index];
|
|
with Item, FPeUnitGenerator.ExportList[Item.Index] do
|
|
begin
|
|
Caption := Name;
|
|
SubItems.Add(PascalizeName(Name));
|
|
SubItems.Add(AddressOrForwardStr);
|
|
if ufDuplicate in Flags then
|
|
ImageIndex := icoWarning
|
|
else
|
|
if Flags * [ufDecorated, ufVariable] = [] then
|
|
ImageIndex := icoExports
|
|
else
|
|
ImageIndex := -1;
|
|
end;
|
|
end;
|
|
|
|
procedure TPeGenDefChild.FunctionsListViewCustomDrawItem(Sender: TCustomListView;
|
|
Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
|
|
var
|
|
Flags: TPeUnitGenFlags;
|
|
begin
|
|
Flags := FPeUnitGenerator.UnitGenFlags[Item.Index];
|
|
if Flags * [ufDecorated, ufVariable] <> [] then
|
|
Sender.Canvas.Font.Style := [fsStrikeOut];
|
|
end;
|
|
|
|
procedure TPeGenDefChild.GenerateUnit;
|
|
var
|
|
SL: TStringList;
|
|
WrapColumn: Integer;
|
|
begin
|
|
Screen.Cursor := crHourGlass;
|
|
SL := TStringList.Create;
|
|
try
|
|
if WrapCheckBox.Checked then
|
|
WrapColumn := WrapSpinEdit.Value
|
|
else
|
|
WrapColumn := 0;
|
|
FPeUnitGenerator.GenerateUnit(SL, LibConstNameEdit.Text, WrapColumn);
|
|
UnitRichEdit.Text := SL.Text;
|
|
finally
|
|
SL.Free;
|
|
Screen.Cursor := crDefault;
|
|
end;
|
|
end;
|
|
|
|
procedure TPeGenDefChild.PageControl1Change(Sender: TObject);
|
|
begin
|
|
if PageControl1.ActivePage = TabSheet1 then
|
|
LibConstNameEdit.SetFocus
|
|
else
|
|
if PageControl1.ActivePage = TabSheet2 then
|
|
GenerateUnit;
|
|
end;
|
|
|
|
procedure TPeGenDefChild.WrapCheckBoxClick(Sender: TObject);
|
|
begin
|
|
WrapSpinEdit.Enabled := WrapCheckBox.Checked;
|
|
end;
|
|
|
|
function TPeGenDefChild.CanSave: Boolean;
|
|
begin
|
|
Result := PageControl1.ActivePage = TabSheet2;
|
|
end;
|
|
|
|
procedure TPeGenDefChild.SaveUnit;
|
|
begin
|
|
with SaveDialog do
|
|
begin
|
|
FileName := PathExtractFileNameNoExt(FPeUnitGenerator.FileName);
|
|
if Execute then
|
|
UnitRichEdit.Lines.SaveToFile(FileName);
|
|
end;
|
|
end;
|
|
|
|
// History:
|
|
|
|
// $Log: PeGenDef.pas,v $
|
|
// Revision 1.2 2005/10/27 01:44:51 rrossmair
|
|
// - added MPL headers and CVS Log tags
|
|
//
|
|
|
|
end.
|