Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 7 years ago.
Improve this question
I am trying to compile my program but I am getting this error:
Undeclared indentifier 'StreamLn'
i even tried to download PSock.dcu and put it into the library but it doesnt compile, it looks like its compactible with delphi 5,
unit ResourceInfo;
interface
uses
Classes, SysUtils, Windows;
type
TResourceInfo = class;
TDfmMode = ( dfmData, dfmResource, dfmASCII, dfmBinary);
TDfm = class
private
FOwner: TResourceInfo;
FName: string;
FData: TStream;
procedure SetName(const Value: string);
procedure SetOwner(const Value: TResourceInfo);
public
constructor Create(AOwner: TResourceInfo);
destructor Destroy; override;
function SaveToFile(FileName: TFileName; Mode: TDfmMode): Boolean;
property Data: TStream read FData;
property Name: string read FName write SetName;
property Owner: TResourceInfo read FOwner write FOwner;
end; {TDfm}
TResourceInfo = class(TComponent)
private
FActive: Boolean;
FDfms: TList;
FExeFileName: TFileName;
FModule: THandle;
FOnActivate: TNotifyEvent;
FOnDeactivate: TNotifyEvent;
procedure SetExeFileName(const Value: TFileName);
procedure SetActive(const Value: Boolean);
function GetDfms(Index: Cardinal): TDfm;
function GetDfmCount: Cardinal;
protected
procedure Clear;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function AddDfm(const Name: string; AData: TMemoryStream): Integer;
procedure DeleteDfm(const Name: string);
property DfmCount: Cardinal read GetDfmCount;
property Dfms[Index: Cardinal]: TDfm read GetDfms;
procedure EnumDfmNames;
property Module: THandle read FModule;
published
property Active: Boolean read FActive write SetActive;
property ExeFileName: TFileName read FExeFileName write SetExeFileName;
property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
end; {TResourceInfo}
procedure Register;
implementation
uses
Winsock;
resourcestring
rsErrorLoadingExeFile = 'An error ocurred loading file %s, it may not be an executable module';
procedure Register;
begin
RegisterComponents('+HCU', [TResourceInfo]);
end; {Register}
{ TResourceInfo }
function TResourceInfo.AddDfm(const Name: string; AData: TMemoryStream): Integer;
var
FDfm: TDfm;
begin
FDfm := TDfm.Create(Self);
FDfm.Name := Name;
FDfm.Data.Size := AData.Size;
FDfm.Data.Seek(0, 0);
AData.Seek(0, 0);
FDfm.Data.CopyFrom(AData, AData.Size);
Result := FDfms.Add(FDfm);
end; {TResourceInfo.AddDfm}
constructor TResourceInfo.Create(AOwner: TComponent);
begin
inherited;
FActive := False;
FDfms := TList.Create;
FModule := 0;
end; {TResourceInfo.Create}
destructor TResourceInfo.Destroy;
begin
Clear;
FDfms.Free;
inherited;
end; {TResourceInfo.Destroy}
function CB_EnumDfmNameProc(hModule: THandle; lpszType, lpszName: PChar; lParam: Integer): Boolean; stdcall;
var
ms: TMemoryStream;
rs: TResourceStream;
Buffer: array of Byte;
begin
with TResourceInfo(lParam) do
begin
rs := TResourceStream.Create(TResourceInfo(lParam).Module, lpszname, lpszType);
try
ms := TMemoryStream.Create;
try
try
SetLength(Buffer, 4);
rs.Read(Buffer[0], SizeOf(Buffer));
if string(Buffer) = 'TPF0' then
begin
rs.Seek(0, 0);
ObjectBinaryToText(rs, ms);
ms.Seek(0, 0);
AddDfm(StrPas(lpszName), ms);
end;
except
raise;
end;
finally
ms.Free;
end;
finally
rs.free;
end;
end;
Result := True;
end; {CB_EnumDfmNameProc}
procedure TResourceInfo.EnumDfmNames;
begin
if FModule > 0 then
EnumResourceNames(FModule, RT_RCDATA, #CB_EnumDfmNameProc, Integer(Self));
end; {TResourceInfo.EnumDfmNames}
procedure TResourceInfo.DeleteDfm(const Name: string);
var
i: Cardinal;
begin
if FDfms.Count > 0 then
for i := Pred(FDfms.Count) downto 0 do
if UpperCase(TDfm(FDfms[i]).Name) = UpperCase(Name) then
begin
FDfms.Delete(i);
Break;
end;
end; {TResourceInfo.DeleteDfm}
procedure TResourceInfo.SetActive(const Value: Boolean);
begin
if FActive <> Value then
begin
if Value then
begin
if FModule > 0 then
FreeLibrary(FModule);
(* LOAD_LIBRARY_AS_DATAFILE
If this value is given, the function does a simple mapping of the file into the
address space. Nothing is done relative to executing or preparing to execute the
code in the mapped file. The function loads the module as if it were a data file.
You can use the module handle that the function returns in this case with the Win32
functions that operate on resources. Use this flag when you want to load a DLL in
order to extract messages or resources from it, and have no intention of executing
its code.If this value is not given, the function maps the file into the address
space in the manner that is normal for an executable module. The behavior of the
function is then identical to that of LoadLibrary in this regard. *)
FModule := LoadLibraryEx(PChar(FExeFileName), 0, LOAD_LIBRARY_AS_DATAFILE);
if not (FModule >= 32) then
raise Exception.CreateFmt(rsErrorLoadingExeFile, [FExeFileName]);
if Assigned(FOnActivate) then
FOnActivate(Self);
end
else
begin
Clear;
if FModule > 0 then
begin
FreeLibrary(FModule);
FModule := 0;
end;
if Assigned(FOnDeactivate) then
FOnDeactivate(Self);
end;
FActive := Value;
end;
end; {TResourceInfo.SetActive}
procedure TResourceInfo.SetExeFileName(const Value: TFileName);
begin
if FExeFileName <> Value then
FExeFileName := Value;
end; {TResourceInfo.SetExeFileName}
function TResourceInfo.GetDfms(Index: Cardinal): TDfm;
begin
Result := TDfm(FDfms[Index]);
end; {TResourceInfo.GetDfms}
function TResourceInfo.GetDfmCount: Cardinal;
begin
Result := FDfms.Count;
end; {TResourceInfo.GetDfmCount}
procedure TResourceInfo.Clear;
begin
if FDfms.Count > 0 then
while FDfms.Count > 0 do
FDfms.Delete(0);
end; {TResourceInfo.Clear}
{ TDfm }
constructor TDfm.Create(AOwner: TResourceInfo);
begin
inherited Create;
FData := TMemoryStream.Create;
FName := '';
SetOwner(AOwner);
end; {TDfm.Create}
destructor TDfm.Destroy;
begin
FData.Free;
inherited;
end; {TDfm.Destroy}
function TDfm.SaveToFile(FileName: TFileName; Mode: TDfmMode): Boolean;
function EndOfStream(Stream: TStream): Boolean;
begin
with Stream do
Result := Position = Size;
end; {EndOfStream}
var
fs: TFileStream;
ms: TMemoryStream;
s: string;
i, j: Byte;
begin
fs := TFileStream.Create(FileName, fmCreate or fmShareExclusive);
try
FData.Seek(0, 0);
case Mode of
dfmASCII:
begin
ms := TMemoryStream.Create;
try
s := FName + ' RCDATA' + #13#10 + '{';
StreamLN(fs, s);
ObjectTextToBinary(FData, ms);
ms.Seek(0, 0);
while not EndOfStream(ms) do
begin
s := '''';
for i := 0 to 15 do
begin
if ms.Read(j, SizeOf(j)) = 0 then
Break;
s := Concat(s, Format('%2.2x', [j]));
if (i = 15) or EndOfStream(ms) then
s := Concat(s, '''')
else
s := Concat(s, ' ');
end;
if EndOfStream(ms) then
s := Concat(s, #13#10 + '}');
StreamLN(fs, s);
end;
finally
ms.Free;
end;
end;
dfmBinary:
ObjectTextToBinary(FData, fs);
end;
finally
fs.Free;
end;
end; {TDfm.SaveToFile}
procedure TDfm.SetName(const Value: string);
begin
if FName <> Value then
FName := Value;
end; {TDfm.SetName}
procedure TDfm.SetOwner(const Value: TResourceInfo);
begin
FOwner := Value;
end; {TDfm.SetOwner}
end.
How can I declare it successfully?
Appears to me that WinSock unit does not have an StreamLn function (as PowerSock's PSock.pas unit uses Winsock as imported unit).
The StreamLn function in PSock.pas just adds an CRLF sequence to the string passed as parameter before calling the TStream.WriteBuffer method of the passed TStream parameter.
Here's the google cache snapshot from the Powersock's source code of PSock.pas
You need to either implement this function, or add a unit where this function is declared to your uses section.
Related
I created a unit with my own class to manage my application settings. One of the members of the class is of type TIniFile which should be used to store the settings in the ini file.
In the constructor of the class, I call TIniFile.Create(SettingsFile) but it raises an exception (I tested it with try...except).
Why does TIniFile creation fail?
Here is my code:
unit SettingsUnit;
interface
{$M+}
uses
System.Classes, System.IniFiles, System.SysUtils;
type
TSettingsManager = class(TObject)
private
FSettingsFile: TIniFile;
FSettingsFileName: String;
FSize: Byte;
FBatteryTop: Integer;
FBatteryLeft: Integer;
FTransparentValue: Byte;
FMinBatteryPercent: Byte;
FShowPercentLabel: Boolean;
FShowPercentOnACPower: Boolean;
FStartWithWindows: Boolean;
public
constructor Create(const SettingsFile: String);
destructor Destroy; override;
procedure StartWithWindows(Value: Boolean);
procedure LoadSettings;
procedure RestoreDefaults;
procedure Apply;
published
property Size: Byte read FSize write FSize;
property BatteryTop: Integer read FBatteryTop write FBatteryTop;
property BatteryLeft: Integer read FBatteryLeft write FBatteryLeft;
property Transparent: Byte read FTransparentValue write FTransparentValue;
property MinBatteryPercent: Byte read FMinBatteryPercent write FMinBatteryPercent;
property ShowPercentLabel: Boolean read FShowPercentLabel write FShowPercentLabel;
property ShowPercentOnACPower: Boolean read FShowPercentOnACPower write FShowPercentOnACPower;
property StartingWithWindows: Boolean read FStartWithWindows;
end;
var
Settings: TSettingsManager;
implementation
uses
System.Win.Registry;
const
SettingsSection: String = 'BatteryFormSettings';
constructor TSettingsManager.Create(const SettingsFile: String);
begin
try
FSettingsFile := TIniFile.Create(SettingsFile);
except
RaiseLastOSError;
Exit;
end;
FSettingsFileName := SettingsFile;
LoadSettings;
inherited Create;
end;
procedure TSettingsManager.LoadSettings;
begin
with FSettingsFile do
begin
FSize := ReadInteger('BatteryFormSettings', 'FormSize', 1);
FBatteryTop := ReadInteger(SettingsSection, 'Top', 20);
FBatteryLeft := ReadInteger(SettingsSection, 'Left', 20);
FTransparentValue := ReadInteger(SettingsSection, 'TransparentValue', 255);
FMinBatteryPercent := ReadInteger(SettingsSection, 'MinBatteryPercent', 80);
FShowPercentLabel := ReadBool(SettingsSection, 'ShowPercentLabel', True);
FShowPercentOnACPower := ReadBool(SettingsSection, 'ShowPercentOnACPower', True);
FStartWithWindows := ReadBool(SettingsSection, 'StartWithWindows', False);
end;
end;
procedure TSettingsManager.Apply;
begin
with FSettingsFile do
begin
WriteInteger(SettingsSection, 'FormSize', FSize);
WriteInteger(SettingsSection, 'Top', FBatteryTop);
WriteInteger(SettingsSection, 'Left', FBatteryLeft);
WriteInteger(SettingsSection, 'TransparentValue', FTransparentValue);
WriteInteger(SettingsSection, 'MinBatteryPercent', FMinBatteryPercent);
WriteBool(SettingsSection, 'ShowPercentLabel', FShowPercentLabel);
WriteBool(SettingsSection, 'ShowPercentOnACPower', FShowPercentOnACPower);
end;
end;
procedure TSettingsManager.StartWithWindows(Value: Boolean);
const
KEY_SET_VALUE = $0002;
var
WinReg: TRegistry;
begin
try
WinReg := TRegistry.Create(KEY_SET_VALUE);
WinReg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', True);
if Value then
begin
if not WinReg.KeyExists('BatteryScreen') then
WinReg.WriteString('BatteryScreen', ChangeFileExt(FSettingsFileName, '.exe'));
FStartWithWindows := True;
end
else
begin
if WinReg.KeyExists('BatteryScreen') then
WinReg.DeleteKey('BatteryScreen');
FStartWithWindows := False;
end;
finally
WinReg.CloseKey;
WinReg.Free;
end;
end;
procedure TSettingsManager.RestoreDefaults;
begin
Size := 1;
BatteryTop := 20;
BatteryLeft := 20;
Transparent := 255;
MinBatteryPercent := 80;
ShowPercentLabel := True;
ShowPercentOnACPower := True;
StartWithWindows(False);
end;
destructor TSettingsManager.Destroy;
begin
FSettingsFile.Free;
inherited Destroy;
end;
end.
And I call him in my form unit like this:
implementation
uses SettingsUnit;
...
procedure TMyForm.FormCreate(Sender: TObject);
begin
Settings.Create(ChangeFileExt(Application.ExeName, '.ini'));
...
end;
I am working solo on an employee timekeeping project which uses a database to store time sheet entries. I am using Delphi Pro 10.2.3 Tokyo for the project and have created a library of wrapper classes to facilitate working with datasets like normal classes. For example, to access the FirstName field in the Employee table, I can write LFirstName := FEmployee.FirstName; rather than LFirstName := Dataset.FieldByName('FirstName').AsString;
Some of my classes have a significant number of dependencies (as many as eight) which I am injecting through the class' constructor. I use a domain object to create the required interfaces and inject them into the class being created.
Some of the interfaces being injected themselves are also very complex and it is starting to get difficult to keep track of everything in the domain object.
The dependencies being injected include wrapper interfaces for other tables which provide lookup values for calculated fields, pointers to functions which create create objects used by the class or call back functions which resolve master/detail relationships. These relationships are static and need to be set in the constructor so that any calculated fields will function when the class is created.
Are there any alternatives to constructor injection which might may decrease complexity of the constructor while maintaining decoupled classes. Here is a sample of code from one of my modules for time sheet entries.
unit LevelPay.DbModel.TimesheetEntry;
interface
uses
Data.Db
, FireDAC.Comp.DataSet
, MyLib.Model.Interfaces
, LevelPay.Model.Types
, LevelPay.Model.Constants
, LevelPay.Model.Interfaces
, LevelPay.DbModel.AppModel
;
type
TDbCustomTimesheetEntry = class(
TDbAppModel<ITimesheetEntry>,
ITimesheetEntry
)
strict private
FCopyFunc: TCopyFunc<ITimesheetEntry>;
procedure ClearFilter;
procedure FilterEntries(const ADate: TDate);
strict protected
FTimesheet: ITimesheet;
FID: TField;
FEmployeeID: TField;
FPayPeriodEndDate: TField;
FFiscalYearEndDate: TField;
FFiscalYearStartDate: TField;
FRowNbr: TField;
FEntryTypeID: TField;
FDateIn: TField;
FTimein: TField;
FDateOut: TField;
FTimeOut: TField;
FCreatedBy: TField;
FCreatedTimestamp: TField;
FLastModifiedBy: TField;
FLastModifiedTimestamp: TField;
FNote: TField;
FClockable: TField;
FClockableHours: TField;
FDayOfWeek: TField;
FDifference: TField;
FEmployeeName: TField;
FEntryTypeCaption: TField;
FTimeElapsed: TField;
FDateIndex: TFDIndex;
FTimeScheduled: TField;
FScheduledTimeIn: TField;
FScheduledTimeOut: TField;
FWeekOf: TField;
function GetID: TIdentifier;
function GetModel: ITimesheetEntry; override;
function GetClockable: Boolean;
function GetClockableHours: THours;
function GetDateIn: TDate;
function GetDateOut: TDate;
function GetDifference: THours;
function GetEmployeeID: TIdentifier;
function GetEmployeeName: string;
function GetPayPeriodEndDate: TDate;
function GetFiscalYearStartDate: TDate;
function GetFiscalYearEndDate: TDate;
function GetEntryTypeID: TIdentifier;
function GetEntryTypeCaption: TCaption;
function GetPlaceholder: Boolean;
function GetRowNbr: TRowNbr;
function GetScheduledTimeIn: TTime;
function GetScheduledTimeOut: TTime;
function GetTimeElapsed: THours;
function GetTimein: TTime;
function GetTimeOut: TTime;
function GetTimeScheduled: THours;
function GetWeekOf: TDate;
function GetWeekDay: string;
function GetCreatedBy: TUserName;
function GetCreatedTimestamp: TDateTime;
function GetLastModifiedBy: TUserName;
function GetLastModifiedTimestamp: TDateTime;
function GetNote: AnsiString;
function GetEntry: ITimesheetEntry;
function GetTimesheet: ITimesheet;
function GetHasEntries: Boolean;
function Find(AModel: ITimesheetEntry): Boolean; override;
procedure DoUpdate(AModel: ITimesheetEntry); override;
procedure Load; virtual;
procedure CreateFields; override;
procedure CreateCalcFields; override;
procedure CreateIndexes; override;
procedure FormatFields; override;
procedure OnCalcFields(Dataset: TDataset); override;
procedure OnNewRecord(Dataset: TDataset); override;
public
constructor Create(
ADataset: TFDDataset;
AModelFunc: TModelFunc<ITimesheetEntry>;
ACopyFunc: TCopyFunc<ITimesheetEntry>;
ATimesheet: ITimesheet;
ACreateFields: Boolean
); reintroduce;
property ID: TIdentifier read GetID;
property EmployeeID: TIdentifier read GetEmployeeID;
property PayPeriodEndDate: TDate read GetPayPeriodEndDate;
property FiscalYearEndDate: TDate read GetFiscalYearEndDate;
property FiscalYearStartDate: TDate read GetFiscalYearStartDate;
property EntryTypeID: TIdentifier read GetEntryTypeID;
property EntryTypeCaption: TCaption read GetEntryTypeCaption;
property RowNbr: TRowNbr read GetRowNbr;
property Clockable: Boolean read GetClockable;
property ClockableHours: THours read GetClockableHours;
property DateIn: TDate read GetDateIn;
property EmployeeName: string read GetEmployeeName;
property ScheduledTimeIn: TTime read GetScheduledTimeIn;
property ScheduledTimeOut: TTime read GetScheduledTimeOut;
property TimeIn: TTime read GetTimein;
property DateOut: TDate read GetDateOut;
property TimeOut: TTime read GetTimeOut;
property TimeElapsed: THours read GetTimeElapsed;
property Placeholder: Boolean read GetPlaceholder;
property TimeScheduled: THours read GetTimeScheduled;
property Difference: THours read GetDifference;
property WeekDay: string read GetWeekDay;
property WeekOf: TDate read GetWeekOf;
property CreatedBy: TUserName read GetCreatedBy;
property CreatedTimestamp: TDateTime read GetCreatedTimestamp;
property LastModifiedBy: TUserName read GetLastModifiedBy;
property LastModifiedTimestamp: TDateTime read GetLastModifiedTimestamp;
property Note: AnsiString read GetNote;
property Timesheet: ITimesheet read GetTimesheet;
end;
TDbSourceEntry = class(TDbCustomTimesheetEntry, ISourceEntryList)
strict private
FLoadTimesheetEntries: TLoadTimesheetProc;
FElectionList: ILevelPayElectionList;
FPositionList: IHourlyPositionList;
strict protected
procedure BeforePost(Dataset: TDataset); override;
procedure Load; override;
public
constructor Create(
ADataset: TFDDataset;
AModelFunc: TModelFunc<ITimesheetEntry>;
ATimesheet: ITimesheet;
ACopyFunc: TCopyFunc<ITimesheetEntry>;
AProc: TLoadTimesheetProc;
AElectionList: ILevelPayElectionList;
APositionList: IHourlyPositionList;
ACreateFields: Boolean = True
); reintroduce;
end;
TDbDummyEntry = class(TDbCustomTimesheetEntry, IDummyEntryList)
strict private
FPlaceholderID: TIdentifier;
FClosureList: ISchoolClosureList;
procedure EntryTypeIDOnChange(Sender: TField);
strict protected
procedure AddPlacedholder(ADate: TDate; ARowNbr: TRowNbr);
procedure CreateFields; override;
procedure DoAdd(AModel: ITimesheetEntry); override;
property PlaceholderID: TIdentifier read FPlaceholderID write FPlaceholderID;
public
constructor Create(
ADataset: TFDDataset;
AModelFunc: TModelFunc<ITimesheetEntry>;
ACopyFunc: TCopyFunc<ITimesheetEntry>;
ATimesheet: ITimesheet;
AClosureList: ISchoolClosureList;
ACreateFields: Boolean
); reintroduce;
end;
TDbTimesheetEntry = class(TDbDummyEntry, ITimesheetEntryList)
strict private
FClone: TFDDataset;
FSource: ISourceEntryList;
function GetNextRowNbr: TRowNbr;
strict protected
function WorkweekList: IWorkweekList;
procedure Clear;
procedure Load; override;
public
procedure Add(AModel: ITimesheetEntry); //replaces inherited add
procedure Delete(AModel: ITimesheetEntry); //replace inherited delete
procedure Update(OldModel, NewModel: ITimesheetEntry);
constructor Create(
ADataset: TFDDataset;
AModelFunc: TModelFunc<ITimesheetEntry>;
ACopyFunc: TCopyFunc<ITimesheetEntry>;
ATimesheet: ITimesheet;
ASourceFunc: TSourceListFunc;
AClosureList: ISchoolClosureList;
ACreateFields: Boolean
); reintroduce;
end;
implementation
uses
System.SysUtils
, System.Classes
, System.Variants
, System.DateUtils
, FireDAC.Comp.Client
, DateTimeHelper
, LevelPay.Model.Helpers
;
{ TCustomShift }
procedure TDbCustomTimesheetEntry.ClearFilter;
begin
CancelRange;
end;
constructor TDbCustomTimesheetEntry.Create(ADataset: TFDDataset;
AModelFunc: TModelFunc<ITimesheetEntry>; ACopyFunc: TCopyFunc<ITimesheetEntry>;
ATimesheet: ITimesheet; ACreateFields: Boolean);
begin
inherited Create(ADataset, AModelFunc, ACreateFields);
FCopyFunc := ACopyFunc;
FTimesheet := ATimesheet;
end;
procedure TDbCustomTimesheetEntry.CreateCalcFields;
begin
inherited;
FClockable := CreateCalcBooleanField(k_Clockable);
FClockableHours := CreateCalcFloatField(k_ClockableHours);
FDayOfWeek := CreateCalcStringField(k_WeekDay, 13);
FDifference := CreateCalcFloatField(k_Difference);
FEmployeeName := CreateCalcStringField(k_EmployeeName, 40);
FEntryTypeCaption := CreateCalcStringField(k_EntryTypeCaption, 20);
FFiscalYearEndDate := CreateCalcDateTimeField(k_FiscalYearEndDate);
FFiscalYearStartDate := CreateCalcDateTimeField(k_FiscalYearStartDate);
FScheduledTimeIn := CreateCalcDateTimeField(k_ScheduledTimeIn);
FScheduledTimeOut := CreateCalcDateTimeField(k_ScheduledTimeOut);
FTimeElapsed := CreateCalcFloatField(k_TimeElapsed);
FTimeScheduled := CreateCalcFloatField(k_TimeScheduled);
FWeekOf := CreateCalcDateTimeField(k_WeekOf);
end;
procedure TDbCustomTimesheetEntry.CreateFields;
begin
FID := CreateField(k_Id);
FEmployeeID := CreateField(k_EmployeeID);
FEntryTypeID := CreateField(k_EntryTypeID);
FRowNbr := CreateField(k_RowNbr);
FTimeIn := CreateField(k_TimeIn);
FTimeOut := CreateField(k_TimeOut);
FID := CreateField(k_ID);
FDateIn := CreateField(k_DateIn);
FDateOut := CreateField(k_DateOut);
FCreatedBy := CreateField(k_CreatedBy);
FCreatedTimestamp := CreateField(k_CreatedTimeStamp);
FLastModifiedBy := CreateField(k_LastModifiedBy);
FLastModifiedTimestamp := CreateField(k_LastModifiedTimestamp);
FNote := CreateField(k_Note);
FPayPeriodEndDate := CreateField(k_PayPeriodEndDate);
end;
procedure TDbCustomTimesheetEntry.CreateIndexes;
const
FIELD_LIST = k_DateIn + ';' + k_RowNbr;
begin
inherited;
FDateIndex := CreateIndex('ByDate', FIELD_LIST);
FDateIndex.Selected := True;
Dataset.IndexesActive := True;
end;
function TDbCustomTimesheetEntry.GetClockable: Boolean;
begin
Result := Rules.Clockable;
end;
function TDbCustomTimesheetEntry.GetClockableHours: THours;
begin
Result := Rules.ClockableHours;
end;
function TDbCustomTimesheetEntry.GetCreatedBy: TUserName;
begin
Result := FCreatedBy.AsUserName;
end;
function TDbCustomTimesheetEntry.GetCreatedTimestamp: TDateTime;
begin
Result := FCreatedTimestamp.AsDateTime;
end;
function TDbCustomTimesheetEntry.GetDateIn: TDate;
begin
Result := FDateIn.AsDateTime;
end;
function TDbCustomTimesheetEntry.GetDateOut: TDate;
begin
Result := FDateOut.AsDateTime;
end;
function TDbCustomTimesheetEntry.GetDifference: THours;
begin
Result := Rules.Difference;
end;
function TDbCustomTimesheetEntry.GetEmployeeID: TIdentifier;
begin
Result := FEmployeeID.AsIdentifier;
end;
function TDbCustomTimesheetEntry.GetEmployeeName: string;
begin
Result := Rules.EmployeeName;
end;
function TDbCustomTimesheetEntry.GetEntryTypeID: TIdentifier;
begin
Result := FEntryTypeID.AsIdentifier;
end;
function TDbCustomTimesheetEntry.GetFiscalYearEndDate: TDate;
begin
Result := FFiscalYearEndDate.AsDateTime;
end;
function TDbCustomTimesheetEntry.GetFiscalYearStartDate: TDate;
begin
Result := FFiscalYearStartDate.AsDateTime;
end;
function TDbCustomTimesheetEntry.GetHasEntries: Boolean;
begin
Result := RecordCount > 0;
end;
function TDbCustomTimesheetEntry.GetID: TIdentifier;
begin
Result := FID.AsInteger;
end;
function TDbCustomTimesheetEntry.GetLastModifiedBy: TUserName;
begin
Result := FLastModifiedBy.AsUserName;
end;
function TDbCustomTimesheetEntry.GetLastModifiedTimestamp: TDateTime;
begin
Result := FLastModifiedTimestamp.AsDateTime;
end;
function TDbCustomTimesheetEntry.GetModel: ITimesheetEntry;
var
LResult: ITimesheetEntry;
begin
LResult := FCopyFunc(Self);
Result := LResult;
end;
function TDbCustomTimesheetEntry.GetNote: AnsiString;
begin
Result := FNote.AsAnsiString;
end;
function TDbCustomTimesheetEntry.GetPayPeriodEndDate: TDate;
begin
Result := FPayPeriodEndDate.AsDateTime;
end;
function TDbCustomTimesheetEntry.GetPlaceholder: Boolean;
begin
Result := Rules.Placeholder;
end;
function TDbCustomTimesheetEntry.GetEntry: ITimesheetEntry;
begin
Result := Model;
end;
function TDbCustomTimesheetEntry.GetEntryTypeCaption: TCaption;
begin
Result := Rules.EntryTypeCaption
end;
function TDbCustomTimesheetEntry.GetRowNbr: TRowNbr;
begin
Result := FRowNbr.AsRowNbr;
end;
function TDbCustomTimesheetEntry.GetScheduledTimeIn: TTime;
begin
Result := Rules.ScheduledTimeIn;
end;
function TDbCustomTimesheetEntry.GetScheduledTimeOut: TTime;
begin
Result := Rules.ScheduledTimeOut;
end;
function TDbCustomTimesheetEntry.GetTimeElapsed: THours;
begin
Result := Rules.TimeElapsed;
end;
function TDbCustomTimesheetEntry.GetTimein: TTime;
begin
Result := FTimeIn.AsDateTime;
end;
function TDbCustomTimesheetEntry.GetTimeOut: TTime;
begin
Result := FTimeOut.AsDateTime;
end;
function TDbCustomTimesheetEntry.GetTimeScheduled: THours;
begin
Result := Rules.TimeScheduled;
end;
function TDbCustomTimesheetEntry.GetTimesheet: ITimesheet;
begin
Result := FTimesheet;
end;
function TDbCustomTimesheetEntry.GetWeekDay: string;
begin
Result := Rules.WeekDay;
end;
function TDbCustomTimesheetEntry.GetWeekOf: TDate;
begin
Result := Rules.WeekOf;
end;
procedure TDbCustomTimesheetEntry.Load;
begin
//Stub procedure
end;
procedure TDbCustomTimesheetEntry.OnCalcFields(Dataset: TDataset);
begin
inherited;
if not Assigned(Rules) then Exit;
FClockable.AsBoolean := GetClockable;
FClockableHours.AsHours := GetClockableHours;
FDayOfWeek.AsString := GetWeekDay;
FDifference.AsHours := GetDifference;
FEmployeeName.AsString := GetEmployeeName;
FEntryTypeCaption.AsCaption := GetEntryTypeCaption;
FTimeElapsed.AsHours := GetTimeElapsed;
FTimeScheduled.AsHours := GetTimeScheduled;
FScheduledTimeIn.AsDateTime := GetScheduledTimeIn;
FScheduledTimeOut.AsDateTime := GetScheduledTimeOut;
FWeekOf.AsDateTime := GetWeekOf;
end;
procedure TDbCustomTimesheetEntry.OnNewRecord(Dataset: TDataset);
begin
inherited;
FEmployeeID.AsIdentifier := FTimesheet.EmployeeID;
FFiscalYearEndDate.AsDateTime := FTimesheet.FiscalYearEndDate;
FFiscalYearStartDate.AsDateTime := FTimesheet.FiscalYearStartDate;
FPayPeriodEndDate.AsDateTime := FTimesheet.PayPeriodEndDate;
end;
procedure TDbCustomTimesheetEntry.DoUpdate(AModel: ITimesheetEntry);
begin
inherited;
FEmployeeID.AsIdentifier := AModel.EmployeeID;
FRowNbr.AsRowNbr := AModel.RowNbr;
FEntryTypeID.AsIdentifier := AModel.EntryTypeID;
FDateIn.AsDateTime := AModel.DateIn;
FTimeIn.AsDateTime := AModel.TimeIn;
FDateOut.AsDateTime := AModel.DateOut;
FTimeOut.AsDateTime := AModel.TimeOut;
FNote.AsAnsiString := AModel.Note;
end;
procedure TDbCustomTimesheetEntry.FilterEntries(const ADate: TDate);
begin
FDateIndex.Selected := True;
SetRange([ADate], [ADate]);
end;
function TDbCustomTimesheetEntry.Find(AModel: ITimesheetEntry): Boolean;
begin
Result := Locate(k_ID, AModel.ID);
end;
procedure TDbCustomTimesheetEntry.FormatFields;
begin
inherited;
FTimeElapsed.OnGetText := HoursFieldGetText;
FClockableHours.OnGetText := HoursFieldGetText;
FDifference.OnGetText := HoursFieldGetText;
FTimeScheduled.OnGetText := HoursFieldGetText;
SetTimeFieldDisplayFormat(FTimeIn);
SetTimeFieldDisplayFormat(FTimeOut);
SetDateFieldDisplayFormat(FDateIn);
SetDateFieldDisplayFormat(FDateOut);
SetDateFieldDisplayFormat(FPayPeriodEndDate);
SetSQLTimestampFieldDisplayFormat(FCreatedTimestamp);
SetSQLTimestampFieldDisplayFormat(FLastModifiedTimestamp);
end;
{ TDbDummyEntry }
procedure TDbSourceEntry.BeforePost(Dataset: TDataset);
var
LTimestamp: TDateTime;
begin
inherited;
LTimestamp := Now;
FLastModifiedBy.AsUserName := FTimesheet.User.UserName;
FLastModifiedTimestamp.AsDateTime := LTimestamp;
if State in [dsInsert] then
begin
FCreatedBy.AsUserName := FTimesheet.User.UserName;
FCreatedTimestamp.AsDateTime := LTimestamp;
end;
end;
constructor TDbSourceEntry.Create(ADataset: TFDDataset;
AModelFunc: TModelFunc<ITimesheetEntry>; ATimesheet: ITimesheet;
ACopyFunc: TCopyFunc<ITimesheetEntry>; AProc: TLoadTimesheetProc;
AElectionList: ILevelPayElectionList; APositionList: IHourlyPositionList;
ACreateFields: Boolean);
begin
inherited Create(ADataset, AModelFunc, ACopyFunc, ATimesheet, ACreateFields);
FLoadTimesheetEntries := AProc;
FElectionList := AElectionList;
FPositionList := APositionList;
end;
procedure TDbSourceEntry.Load;
var
LEmployeeID: TIdentifier;
LFirstEntryDate: TDate;
LLastEntryDate: TDate;
begin
LEmployeeID := FTimesheet.EmployeeID;
LFirstEntryDate := FTimesheet.FirstEntryDate;
LLastEntryDate := FTimesheet.LastEntryDate;
FLoadTimesheetEntries(LEmployeeID, LFirstEntryDate, LLastEntryDate);
end;
{ TDbDummyEntry }
procedure TDbDummyEntry.AddPlacedholder(ADate: TDate; ARowNbr: TRowNbr);
var
LEntryTypeID: TIdentifier;
LClosure: ISchoolClosure;
LNote: AnsiString;
LRowNbr: TRowNbr;
begin
Dec(FPlaceholderID);
LNote := '';
LEntryTypeID := 0;
LRowNbr := ARowNbr;
if LRowNbr < 2 then //This is a first entry for the date
begin
if FClosureList.Find(ADate) then
begin
LClosure := FClosureList.Closure;
LEntryTypeID := LClosure.EntryTypeID;
LNote := AnsiString(LClosure.Caption);
end
else
begin
if TDateTime(ADate).DayOfWeek in [MONDAY..FRIDAY] then
LEntryTypeID := k_Regular
else
LEntryTypeID := 0;
end;
end;
Append;
FId.AsIdentifier := FPlaceholderID;
FRowNbr.AsRowNbr := LRowNbr;
FDateIn.AsDateTime := ADate;
FDateOut.AsDateTime := ADate;
FEntryTypeID.AsIdentifier := LEntryTypeID;
FNote.AsAnsiString := LNote;
Post;
end;
constructor TDbDummyEntry.Create(ADataset: TFDDataset;
AModelFunc: TModelFunc<ITimesheetEntry>; ACopyFunc: TCopyFunc<ITimesheetEntry>;
ATimesheet: ITimesheet; AClosureList: ISchoolClosureList; ACreateFields: Boolean);
begin
inherited Create(ADataset, AModelFunc, ACopyFunc, ATimesheet, ACreateFields);
FClosureList := AClosureList;
end;
procedure TDbDummyEntry.CreateFields;
begin
inherited;
FId.ReadOnly := False;
FId.AutoGenerateValue := arNone;
FEntryTypeID.OnChange := EntryTypeIDOnChange;
end;
procedure TDbDummyEntry.DoAdd(AModel: ITimesheetEntry);
begin
inherited;
FId.AsIdentifier := AModel.ID;
end;
procedure TDbDummyEntry.EntryTypeIDOnChange(Sender: TField);
var
LDateIn: TDate;
LDateOut: TDate;
begin
if Sender.AsIdentifier = k_LandSchool then
begin
LDateIn := FDateIn.AsDateTime;
LDateOut := LDateIn + 1;
FDateOut.AsDateTime := LDateOut;
FTimeIn.AsDateTime := GetScheduledTimeOut;
FTimeOut.AsDateTime := GetScheduledTimeIn;
end;
end;
{ TDbTimesheetEntry }
procedure TDbTimesheetEntry.Add(AModel: ITimesheetEntry);
var
LEntry: ITimesheetEntry;
begin
FSource.Add(AModel);
LEntry := FSource.Entry; //Get model with updated ID
FTimesheet.WorkweekList.AddEntry(LEntry);
inherited Add(LEntry);
end;
procedure TDbTimesheetEntry.Clear;
begin
PlaceholderID := 0;
Dataset.CancelUpdates;
DisableControls;
try
First;
while RecordCount > 0 do
Dataset.Delete;
finally
EnableControls;
end;
end;
constructor TDbTimesheetEntry.Create(ADataset: TFDDataset;
AModelFunc: TModelFunc<ITimesheetEntry>;
ACopyFunc: TCopyFunc<ITimesheetEntry>; ATimesheet: ITimesheet;
ASourceFunc: TSourceListFunc; AClosureList: ISchoolClosureList;
ACreateFields: Boolean);
begin
inherited Create(ADataset, AModelFunc, ACopyFunc, ATimesheet, AClosureList, ACreateFields);
FSource := ASourceFunc(FTimesheet);
FClone := TFDMemTable.Create(ADataset);
FClone.CloneCursor(ADataset);
end;
procedure TDbTimesheetEntry.Delete(AModel: ITimesheetEntry);
var
LDate: TDate;
LRowNbr: SmallInt;
LEntry: ITimesheetEntry;
begin
FSource.Delete(AModel);
WorkweekList.DeleteEntry(AModel);
DisableControls;
try
LDate := AModel.DateIn;
LRowNbr := AModel.RowNbr;
inherited Delete(AModel);
if (LRowNbr = 1) then
begin
AddPlacedholder(LDate, 0);
LEntry := Model; //Get placeholder
WorkweekList.AddEntry(LEntry);
end;
finally
EnableControls;
end;
end;
function TDbTimesheetEntry.GetNextRowNbr: TRowNbr;
begin
Result := 0;
FClone.SetRange([GetDateIn], [GetDateIn]);
while not FClone.Eof do
begin
Result := FClone.FieldByName(k_RowNbr).AsRowNbr + 1;
FClone.Next;
end;
FClone.CancelRange;
end;
procedure TDbTimesheetEntry.Load;
var
LDate: TDate;
LFirstEntryDate: TDate;
LCutoffDate: TDate;
LEntry: ITimesheetEntry;
LWeekOf: TDate;
LWorkweekList: IWorkweekList;
begin
LWorkweekList := FTimesheet.WorkweekList;
LFirstEntryDate := FTimesheet.FirstEntryDate;
LCutOffDate := FTimesheet.LastEntryDate;
LWeekOf := TDateTime(LFirstEntryDate).StartOfWeek;
LWorkweekList.Init(LFirstEntryDate, LCutOffDate);
FSource.Load;
DisableControls;
try
Clear;
LDate := LWeekOf;
repeat
FSource.FilterEntries(LDate);
if FSource.HasEntries then
begin
for LEntry in FSource do
begin
if LDate >= LFirstEntryDate then
begin
inherited Add(LEntry); //this must call inherited add to adding to FSource
end;
LWorkweekList.AddEntry(LEntry);
end;
end
else
begin
if LDate >= LFirstEntryDate then
begin
AddPlacedholder(LDate, 0);
LEntry := GetModel; //This retrieves the placeholder
LWorkweekList.AddEntry(LEntry);
end;
end;
LDate := LDate + 1;
until LDate > LCutOffDate;
finally
FSource.ClearFilter;
EnableControls;
First;
end;
end;
procedure TDbTimesheetEntry.Update(OldModel, NewModel: ITimesheetEntry);
var
LEntry: ITimesheetEntry;
begin
DisableControls;
try
if Assigned(OldModel) then
begin
if OldModel.Placeholder then
begin
FSource.Add(NewModel);
end
else
begin
FSource.Update(NewModel);
end;
inherited Delete(OldModel);
WorkweekList.DeleteEntry(OldModel);
end
else
begin
FSource.Add(NewModel);
end;
LEntry := FSource.Entry; //Get entry with new ID
inherited Add(LEntry);
WorkweekList.AddEntry(LEntry);
finally
EnableControls;
end;
end;
function TDbTimesheetEntry.WorkweekList: IWorkweekList;
begin
Result := FTimesheet.WorkweekList;
end;
end.
Generally the saying is that when you have many constructor parameters (that means dependencies) it is a sign that your class might do too much (see single responsible principle).
If certain dependencies most of the time only interact with each other this is a sign that these dependencies might be subject to refactor them into their own component/class which is then injected. This does not only reduce dependencies in the first place but reduces complexity of your components.
I suggest reading the blog of Mark Seemann where he explained many areas that play into properly practicing dependency injection and software design and architecture.
Just two examples that I remember:
http://blog.ploeh.dk/2010/02/02/RefactoringtoAggregateServices/
http://blog.ploeh.dk/2018/08/27/on-constructor-over-injection/
You have default property in root all TDataSet:
property FieldValues[const FieldName: string]: Variant read GetFieldValue write SetFieldValue; default;
and you can use
aTest: TDataSet; //any descant
aValue := aTest['NameField'];
Why complicate this with injections?
Syntax purity?
Like Paradox ObjectPAL from 1994.
I have 2 years old project which I am rebooting back to life. I have debug window which shows different information, and one part of them is that it serializes various google protobuf objects and shows them.
Here is how typical protobuf class looks like:
// Generated by the protocol buffer compiler. DO NOT EDIT!
// Source: message.proto
unit Poker.Protobufs.Objects.PingParams;
interface
uses
System.SysUtils,
{$IFNDEF FPC} System.Generics.Collections {$ELSE} Contnrs {$ENDIF},
pbOutput, Poker.Protobufs.Objects.Base, Poker.Protobufs.Reader, Poker.Types;
type
TPB_PingParams = class(TProtobufBaseObject)
private
const
kUptimeFieldNumber = 1;
var
FUptime: UInt32;
FHasBits: UINT32;
procedure set_has_Uptime;
procedure clear_has_Uptime;
procedure SetUptime(const AValue: UInt32);
public
constructor Create(const AFrom: TPB_PingParams; const ALightweight: Boolean = FALSE); overload;
destructor Destroy; override;
procedure LoadFromProtobufReader(const AProtobufReader: TProtobufReader; const ASize: Integer); override;
procedure MergeFrom(const AFrom: TPB_PingParams);
procedure Clear;
function IsInitialized: Boolean; override;
// required uint32 Uptime = 1;
function has_Uptime: Boolean;
procedure clear_Uptime;
property Uptime: UInt32 read FUptime write SetUptime;
end;
TPB_PingParamsList = class(TObjectList<TPB_PingParams>)
procedure Assign(const APB_PingParamsList: TList<TPB_PingParams>);
end;
implementation
uses
pbPublic;
constructor TPB_PingParams.Create(const AFrom: TPB_PingParams; const ALightweight: Boolean = FALSE);
begin
inherited Create(ALightweight);
MergeFrom(AFrom);
end;
destructor TPB_PingParams.Destroy;
begin
inherited;
end;
procedure TPB_PingParams.LoadFromProtobufReader(const AProtobufReader: TProtobufReader; const ASize: Integer);
var
tag, field_number, wire_type, endpos: Integer;
begin
endpos := AProtobufReader.getPos + ASize;
while (AProtobufReader.getPos < endpos) and
(AProtobufReader.GetNext(tag, wire_type, field_number)) do
case field_number of
kUptimeFieldNumber: begin
Assert(wire_type = WIRETYPE_VARINT);
FUptime := AProtobufReader.readUInt32;
set_has_Uptime;
end;
else
AProtobufReader.skipField(tag);
end;
end;
procedure TPB_PingParams.MergeFrom(const AFrom: TPB_PingParams);
begin
if AFrom.has_Uptime then
SetUptime(AFrom.Uptime);
end;
function TPB_PingParams.IsInitialized: Boolean;
begin
if (FHasBits and $1) <> $1 then
Exit(FALSE);
Exit(TRUE);
end;
procedure TPB_PingParams.clear_Uptime;
begin
FUptime := 0;
clear_has_Uptime;
end;
function TPB_PingParams.has_Uptime: Boolean;
begin
result := (FHasBits and 1) > 0;
end;
procedure TPB_PingParams.set_has_Uptime;
begin
FHasBits := FHasBits or 1;
end;
procedure TPB_PingParams.clear_has_Uptime;
begin
FHasBits := FHasBits and not 1;
end;
procedure TPB_PingParams.SetUptime(const AValue: UInt32);
begin
if not Lightweight then
Assert(not has_Uptime);
FUptime := AValue;
if not Lightweight then
ProtobufOutput.writeUInt32(kUptimeFieldNumber, AValue);
set_has_Uptime;
end;
procedure TPB_PingParams.Clear;
begin
if FHasBits = 0 then
Exit;
clear_Uptime;
end;
procedure TPB_PingParamsList.Assign(const APB_PingParamsList: TList<TPB_PingParams>);
var
pbobj: TPB_PingParams;
begin
Clear;
for pbobj in APB_PingParamsList do
Add(TPB_PingParams.Create(pbobj, TRUE));
end;
end.
And my serialization function:
function SerializeObject(const AObject: TObject): String;
var
t: TRttiType;
p: TRttiProperty;
properties: TArray<TRttiProperty>;
method: TRttiMethod;
begin
result := '';
if not Assigned(AObject) then
Exit;
t := TRttiContext.Create.GetType(AObject.ClassType);
properties := t.GetProperties;
for p in properties do
begin
method := t.GetMethod(Format('has_%s', [p.Name]));
if (Assigned(method)) and
(method.Invoke(AObject, []).AsBoolean) then
result := result + Format('%s: %s; ', [p.Name, ValueToStr(p, p.GetValue(AObject))]);
end;
end;
It is specifically designed to serialize fields that begin with has_ in protobuf objects. Now, I didn't change anything in the code over last 2 years, and this was working before. But now it doesn't. Line properties = t.GetProperties returns empty array for my protobuf classes.
My guess is that I had some globally defined compiler directive which allowed me to serialize public methods in the class. But I cannot figure out which one.
If I put {$M+} in front of my protobuf classes, and move methods to published, it works (kinda). But this worked before just like it is shown in the sources, without any {$M+} directives or similar. So I'm curious what I miss.
Compiler is same as before, XE2.
David Heffernan posted a custom filestream here:
Buffered files (for faster disk access)
It works on files less than 2 GB without problems and is very fast. On files greater than 2GB it fails around 1.90 GB consistently. The error is:
Project1.exe raised exception class EStreamError with message 'SetFilePointerEx failed for C:\Projects\Huge.txt. An Attempt was made to move the file pointer before the beginning of the file'. Process stopped.
`
const
bufsz = 65536; //64K
var
strTmp : AnsiString;
bufStreamIN : TReadOnlyCachedFileStream;
bufStreamOut : TWriteCachedFileStream;
strmsize, BytesRead, M, NumberOfBytes, J : LongWord;
Buffer: PByte;
J := bufStreamIn.Size;
try
while (bufStreamIN.Position < J) do
begin
BytesRead := bfStreamIN.Read(Buffer^, bufsz);
NumberOfBytes := NumberOfBytes + BytesRead;
SetLength(strTmp, BytesRead);
strTmp := Copy(PAnsiChar(Buffer), 1, BytesRead);
bufStreamOut.WriteBuffer(Pointer(strTmp)^, Length(strTmp));
StrTmp := '';
strmsize := j - NumberOfBytes;
if strmsize > BytesRead then
bfStreamIN.Position := bfStreamIN.Seek(BytesRead, soFromCurrent)
else bfStreamIN.Position := bfStreamIN.Seek(strmsize, soFromCurrent);
ProgressBar1.Position := 100*bfStreamIN.Position div J;
Application.ProcessMessages;
end;
finally
Memo1.Lines.Add('Done');
end;
finally
FreeMem(Buffer);
bufStreamIN.Free;
bufStreamOut.Free;
end;`
This works on files less than 2GB without problems and even works without checking size of stream left to read here:
if strmsize > BytesRead then
bfStreamIN.Position := bfStreamIN.Seek(BytesRead, soFromCurrent)
else bfStreamIN.Position := bfStreamIN.Seek(strmsize, soFromCurrent);
such as this which works on files less than 2GB:
bufStreamIN.Position := bufStreamIN.Seek(NumberOfBytes, soFromBeginning);
I use Delphi 7 32bit and my OS is Win 7 64bit with 4GB RAM
I used JCL's TJclBufferedStream and it works very well on that Huge file without problems. Only problem is that it is much much slower.
In my DPR I have used this as was suggested by another post I read in order to use higher memory but here I think it is not memory problem: {$SetPEFlags $0020}
The full unit with some changes that were suggested in the other post:
interface
uses
Classes,
Windows,
SysUtils,
Math;
type
IStreamErrorHandler = interface
['{B2A95D51-DD0D-49C2-9511-638EE4F911C8}']
procedure HandleError(const Msg: string='');
end;
TBaseCachedFileStream = class(TStream, IStreamErrorHandler)
private
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
protected
FHandle: THandle;
FOwnsHandle: Boolean;
FCache: PByte;
FCacheSize: Integer;
FPosition: Int64;//the current position in the file (relative to the beginning of the file)
FCacheStart: Int64;//the postion in the file of the start of the cache (relative to the beginning of the file)
FCacheEnd: Int64;//the postion in the file of the end of the cache (relative to the beginning of the file)
FFileName: string;
FLastError: DWORD;
procedure HandleError(const Msg: string);
procedure RaiseSystemError(const Msg: string; LastError: DWORD); overload;
procedure RaiseSystemError(const Msg: string); overload;
procedure RaiseSystemErrorFmt(const Msg: string; const Args: array of const);
function CreateHandle(FlagsAndAttributes: DWORD): THandle; virtual; abstract;
function GetFileSize: Int64; virtual;
procedure SetSize(NewSize: LongInt); override;
procedure SetSize(const NewSize: Int64); override;
function FileRead(var Buffer; Count: Longword): Integer;
function FileWrite(const Buffer; Count: Longword): Integer;
function FileSeek(const Offset: Int64; Origin: TSeekOrigin): Int64;
public
constructor Create(const FileName: string); overload;
constructor Create(const FileName: string; CacheSize: Integer); overload;
constructor Create(const FileName: string; CacheSize: Integer; Handle: THandle); overload; virtual;
destructor Destroy; override;
property CacheSize: Integer read FCacheSize;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
end;
TBaseCachedFileStreamClass = class of TBaseCachedFileStream;
IDisableStreamReadCache = interface
['{0B6D0004-88D1-42D5-BC0F-447911C0FC21}']
procedure DisableStreamReadCache;
procedure EnableStreamReadCache;
end;
TReadOnlyCachedFileStream = class(TBaseCachedFileStream, IDisableStreamReadCache)
(* This class works by filling the cache each time a call to Read is made and
FPosition is outside the existing cache. By filling the cache we mean
reading from the file into the temporary cache. Calls to Read when
FPosition is in the existing cache are then dealt with by filling the
buffer with bytes from the cache.
*)
private
FUseAlignedCache: Boolean;
FViewStart: Int64;
FViewLength: Int64;
FDisableStreamReadCacheRefCount: Integer;
procedure DisableStreamReadCache;
procedure EnableStreamReadCache;
procedure FlushCache;
protected
function CreateHandle(FlagsAndAttributes: DWORD): THandle; override;
function GetFileSize: Int64; override;
public
constructor Create(const FileName: string; CacheSize: Integer; Handle: THandle); overload; override;
property UseAlignedCache: Boolean read FUseAlignedCache write FUseAlignedCache;
function Read(var Buffer; Count: Longint): Longint; override;
procedure SetViewWindow(const ViewStart, ViewLength: Int64);
end;
TWriteCachedFileStream = class(TBaseCachedFileStream, IDisableStreamReadCache)
(* This class works by caching calls to Write. By this we mean temporarily
storing the bytes to be written in the cache. As each call to Write is
processed the cache grows. The cache is written to file when:
1. A call to Write is made when the cache is full.
2. A call to Write is made and FPosition is outside the cache (this
must be as a result of a call to Seek).
3. The class is destroyed.
Note that data can be read from these streams but the reading is not
cached and in fact a read operation will flush the cache before
attempting to read the data.
*)
private
FFileSize: Int64;
FReadStream: TReadOnlyCachedFileStream;
FReadStreamCacheSize: Integer;
FReadStreamUseAlignedCache: Boolean;
procedure DisableStreamReadCache;
procedure EnableStreamReadCache;
procedure CreateReadStream;
procedure FlushCache;
protected
function CreateHandle(FlagsAndAttributes: DWORD): THandle; override;
function GetFileSize: Int64; override;
public
constructor Create(const FileName: string; CacheSize, ReadStreamCacheSize: Integer; ReadStreamUseAlignedCache: Boolean); overload;
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
end;
function GetFileSizeEx(hFile: THandle; var lpFileSize: Int64): BOOL;
stdcall; external 'kernel32.dll';
function SetFilePointerEx(hFile: THandle; liDistanceToMove: Int64;
lpNewFilePointer: PInt64; dwMoveMethod: DWORD): BOOL;
stdcall; external 'kernel32.dll';
implementation
{ TBaseCachedFileStream }
constructor TBaseCachedFileStream.Create(const FileName: string);
begin
Create(FileName, 0);
end;
constructor TBaseCachedFileStream.Create(const FileName: string; CacheSize: Integer);
begin
Create(FileName, CacheSize, 0);
end;
constructor TBaseCachedFileStream.Create(const FileName: string; CacheSize: Integer; Handle: THandle);
const
DefaultCacheSize = 16*1024;
//16kb - this was chosen empirically - don't make it too large otherwise the progress report is 'jerky'
begin
inherited Create;
FFileName := FileName;
FOwnsHandle := Handle=0;
if FOwnsHandle then begin
FHandle := CreateHandle(FILE_ATTRIBUTE_NORMAL);
end else begin
FHandle := Handle;
end;
FCacheSize := CacheSize;
if FCacheSize<=0 then begin
FCacheSize := DefaultCacheSize;
end;
GetMem(FCache, FCacheSize);
end;
destructor TBaseCachedFileStream.Destroy;
begin
FreeMem(FCache);
if FOwnsHandle and (FHandle<>0) then begin
CloseHandle(FHandle);
end;
inherited;
end;
function TBaseCachedFileStream.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then begin
Result := S_OK;
end else begin
Result := E_NOINTERFACE;
end;
end;
function TBaseCachedFileStream._AddRef: Integer;
begin
Result := -1;
end;
function TBaseCachedFileStream._Release: Integer;
begin
Result := -1;
end;
procedure TBaseCachedFileStream.HandleError(const Msg: string);
begin
if FLastError<>0 then begin
RaiseSystemError(Msg, FLastError);
end;
end;
procedure TBaseCachedFileStream.RaiseSystemError(const Msg: string; LastError: DWORD);
begin
raise EStreamError.Create(Trim(Msg+' '+ SysErrorMessage(GetLastError)));
//raise EStreamError.Create(Trim(Msg+' '+GetSystemErrorString(LastError)));
end;
procedure TBaseCachedFileStream.RaiseSystemError(const Msg: string);
begin
RaiseSystemError(Msg, GetLastError);
end;
procedure TBaseCachedFileStream.RaiseSystemErrorFmt(const Msg: string; const Args: array of const);
begin
RaiseSystemError(Format(Msg, Args));
end;
function TBaseCachedFileStream.GetFileSize: Int64;
begin
if not GetFileSizeEx(FHandle, Result) then begin
RaiseSystemErrorFmt('GetFileSizeEx failed for %s.', [FFileName]);
end;
end;
procedure TBaseCachedFileStream.SetSize(NewSize: LongInt);
begin
SetSize(Int64(NewSize));
end;
procedure TBaseCachedFileStream.SetSize(const NewSize: Int64);
begin
Seek(NewSize, soBeginning);
if not Windows.SetEndOfFile(FHandle) then begin
RaiseSystemErrorFmt('SetEndOfFile for %s.', [FFileName]);
end;
end;
function TBaseCachedFileStream.FileRead(var Buffer; Count: Longword): Integer;
begin
if Windows.ReadFile(FHandle, Buffer, Count, LongWord(Result), nil) then begin
FLastError := 0;
end else begin
FLastError := GetLastError;
Result := -1;
end;
end;
function TBaseCachedFileStream.FileWrite(const Buffer; Count: Longword): Integer;
begin
if Windows.WriteFile(FHandle, Buffer, Count, LongWord(Result), nil) then begin
FLastError := 0;
end else begin
FLastError := GetLastError;
Result := -1;
end;
end;
function TBaseCachedFileStream.FileSeek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
if not SetFilePointerEx(FHandle, Offset, #Result, ord(Origin)) then begin
RaiseSystemErrorFmt('SetFilePointerEx failed for %s.', [FFileName]);
end;
end;
function TBaseCachedFileStream.Read(var Buffer; Count: Integer): Longint;
begin
Assert(False);
//raise EAssertionFailed.create; //RaiseAssertionFailed(Result);
end;
function TBaseCachedFileStream.Write(const Buffer; Count: Integer): Longint;
begin
Assert(False);
//raise EAssertionFailed.Create; //RaiseAssertionFailed(Result);
end;
function TBaseCachedFileStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
//Set FPosition to the value specified - if this has implications for the
//cache then overriden Write and Read methods must deal with those.
begin
case Origin of
soBeginning:
FPosition := Offset;
soEnd:
FPosition := GetFileSize+Offset;
soCurrent:
inc(FPosition, Offset);
else
Assert(False); //RaiseAssertionFailed;
end;
Result := FPosition;
end;
{ TReadOnlyCachedFileStream }
constructor TReadOnlyCachedFileStream.Create(const FileName: string; CacheSize: Integer; Handle: THandle);
begin
inherited;
SetViewWindow(0, inherited GetFileSize);
end;
function TReadOnlyCachedFileStream.CreateHandle(FlagsAndAttributes: DWORD): THandle;
begin
Result := Windows.CreateFile(
PChar(FFileName),
GENERIC_READ,
FILE_SHARE_READ,
nil,
OPEN_EXISTING,
FlagsAndAttributes,
0
);
if Result=INVALID_HANDLE_VALUE then begin
RaiseSystemErrorFmt('Cannot open %s.', [FFileName]);
end;
end;
procedure TReadOnlyCachedFileStream.DisableStreamReadCache;
begin
inc(FDisableStreamReadCacheRefCount);
end;
procedure TReadOnlyCachedFileStream.EnableStreamReadCache;
begin
dec(FDisableStreamReadCacheRefCount);
end;
procedure TReadOnlyCachedFileStream.FlushCache;
begin
FCacheStart := 0;
FCacheEnd := 0;
end;
function TReadOnlyCachedFileStream.GetFileSize: Int64;
begin
Result := FViewLength;
end;
procedure TReadOnlyCachedFileStream.SetViewWindow(const ViewStart, ViewLength: Int64);
begin
if ViewStart<0 then begin
Assert(False); //raise EAssertionFailed.Create(); //RaiseAssertionFailed;
end;
if (ViewStart+ViewLength)>inherited GetFileSize then begin
Assert(False); //raise EAssertionFailed.Create(); //RaiseAssertionFailed;
end;
FViewStart := ViewStart;
FViewLength := ViewLength;
FPosition := 0;
FCacheStart := 0;
FCacheEnd := 0;
end;
function TReadOnlyCachedFileStream.Read(var Buffer; Count: Longint): Longint;
var
NumOfBytesToCopy, NumOfBytesLeft, NumOfBytesRead: Longint;
CachePtr, BufferPtr: PByte;
begin
if FDisableStreamReadCacheRefCount>0 then begin
FileSeek(FPosition+FViewStart, soBeginning);
Result := FileRead(Buffer, Count);
if Result=-1 then begin
Result := 0;//contract is to return number of bytes that were read
end;
inc(FPosition, Result);
end else begin
Result := 0;
NumOfBytesLeft := Count;
BufferPtr := #Buffer;
while NumOfBytesLeft>0 do begin
if (FPosition<FCacheStart) or (FPosition>=FCacheEnd) then begin
//the current position is not available in the cache so we need to re-fill the cache
FCacheStart := FPosition;
if UseAlignedCache then begin
FCacheStart := FCacheStart - (FCacheStart mod CacheSize);
end;
FileSeek(FCacheStart+FViewStart, soBeginning);
NumOfBytesRead := FileRead(FCache^, CacheSize);
if NumOfBytesRead=-1 then begin
exit;
end;
Assert(NumOfBytesRead>=0);
FCacheEnd := FCacheStart+NumOfBytesRead;
if NumOfBytesRead=0 then begin
FLastError := ERROR_HANDLE_EOF;//must be at the end of the file
break;
end;
end;
//read from cache to Buffer
NumOfBytesToCopy := Min(FCacheEnd-FPosition, NumOfBytesLeft);
CachePtr := FCache;
inc(CachePtr, FPosition-FCacheStart);
Move(CachePtr^, BufferPtr^, NumOfBytesToCopy);
inc(Result, NumOfBytesToCopy);
inc(FPosition, NumOfBytesToCopy);
inc(BufferPtr, NumOfBytesToCopy);
dec(NumOfBytesLeft, NumOfBytesToCopy);
end;
end;
end;
{ TWriteCachedFileStream }
constructor TWriteCachedFileStream.Create(const FileName: string; CacheSize, ReadStreamCacheSize: Integer; ReadStreamUseAlignedCache: Boolean);
begin
inherited Create(FileName, CacheSize);
FReadStreamCacheSize := ReadStreamCacheSize;
FReadStreamUseAlignedCache := ReadStreamUseAlignedCache;
end;
destructor TWriteCachedFileStream.Destroy;
begin
FlushCache;//make sure that the final calls to Write get recorded in the file
FreeAndNil(FReadStream);
inherited;
end;
function TWriteCachedFileStream.CreateHandle(FlagsAndAttributes: DWORD): THandle;
begin
Result := Windows.CreateFile(
PChar(FFileName),
GENERIC_READ or GENERIC_WRITE,
0,
nil,
CREATE_ALWAYS,
FlagsAndAttributes,
0
);
if Result=INVALID_HANDLE_VALUE then begin
RaiseSystemErrorFmt('Cannot create %s.', [FFileName]);
end;
end;
procedure TWriteCachedFileStream.DisableStreamReadCache;
begin
CreateReadStream;
FReadStream.DisableStreamReadCache;
end;
procedure TWriteCachedFileStream.EnableStreamReadCache;
begin
Assert(Assigned(FReadStream));
FReadStream.EnableStreamReadCache;
end;
function TWriteCachedFileStream.GetFileSize: Int64;
begin
Result := FFileSize;
end;
procedure TWriteCachedFileStream.CreateReadStream;
begin
if not Assigned(FReadStream) then begin
FReadStream := TReadOnlyCachedFileStream.Create(FFileName, FReadStreamCacheSize, FHandle);
FReadStream.UseAlignedCache := FReadStreamUseAlignedCache;
end;
end;
procedure TWriteCachedFileStream.FlushCache;
var
NumOfBytesToWrite: Longint;
begin
if Assigned(FCache) then begin
NumOfBytesToWrite := FCacheEnd-FCacheStart;
if NumOfBytesToWrite>0 then begin
FileSeek(FCacheStart, soBeginning);
if FileWrite(FCache^, NumOfBytesToWrite)<>NumOfBytesToWrite then begin
RaiseSystemErrorFmt('FileWrite failed for %s.', [FFileName]);
end;
if Assigned(FReadStream) then begin
FReadStream.FlushCache;
end;
end;
FCacheStart := FPosition;
FCacheEnd := FPosition;
end;
end;
function TWriteCachedFileStream.Read(var Buffer; Count: Integer): Longint;
begin
FlushCache;
CreateReadStream;
Assert(FReadStream.FViewStart=0);
if FReadStream.FViewLength<>FFileSize then begin
FReadStream.SetViewWindow(0, FFileSize);
end;
FReadStream.Position := FPosition;
Result := FReadStream.Read(Buffer, Count);
inc(FPosition, Result);
end;
function TWriteCachedFileStream.Write(const Buffer; Count: Longint): Longint;
var
NumOfBytesToCopy, NumOfBytesLeft: Longint;
CachePtr, BufferPtr: PByte;
begin
Result := 0;
NumOfBytesLeft := Count;
BufferPtr := #Buffer;
while NumOfBytesLeft>0 do begin
if ((FPosition<FCacheStart) or (FPosition>FCacheEnd))//the current position is outside the cache
or (FPosition-FCacheStart=FCacheSize)//the cache is full
then begin
FlushCache;
Assert(FCacheStart=FPosition);
end;
//write from Buffer to the cache
NumOfBytesToCopy := Min(FCacheSize-(FPosition-FCacheStart), NumOfBytesLeft);
CachePtr := FCache;
inc(CachePtr, FPosition-FCacheStart);
Move(BufferPtr^, CachePtr^, NumOfBytesToCopy);
inc(Result, NumOfBytesToCopy);
inc(FPosition, NumOfBytesToCopy);
FCacheEnd := Max(FCacheEnd, FPosition);
inc(BufferPtr, NumOfBytesToCopy);
dec(NumOfBytesLeft, NumOfBytesToCopy);
end;
FFileSize := Max(FFileSize, FPosition);
end;
end.
You are using 32-bit Seek overload; try
bfStreamIN.Position := bfStreamIN.Seek(BytesRead, soCurrent)
---------
instead to invoke 64-bit Seek.
I still haven't found a truly satisfactory answer to this question, and am now considering rolling my own. I have ModelMaker and GExperts, and neither seems to load the comprehensive class-hierarchy I am looking for. As well, I don't think the folks at DevExpress will fork over the CDK code which compiles a full class list to inherit from... ;-)
SO...
If ALL I want to do is build a self-referencing table of all registered component classes (or even all classes including non-components, if that's just as easy/possible), what would be the best way to go about doing that?
Note: I don't really need property / method details; JUST a complete list of class names (and parent names) I can store to a table and put in a treeview. Anything beyond that, though, is more than welcome as bonus info. :-)
Update later:
One answer that shows up in my "recent" section on SO, but not here on the question (maybe they erased it?), was this:"u may want to take a look on code of Component Search, it may help you to enumrate all components installed." Is that code available? Is so, where is it hiding? Would be interesting to study.
Unfortunately, the code implementing the RegisterClass mechanism is hidden in Classes implementation section.
If you need this for getting the list of components installed in the IDE, you can write a design package, install it into the IDE and use IOTAPackageServices in ToolsAPI unit. This will give you the list of installed packages and their components.
Note: You'll have to add designide.dcp to your 'requires' clause to be able to use Delphi's internal units like ToolsAPI.
A bit more work but a more generic way would be to enumerate all loaded modules. You can call GetPackageInfo (SysUtils) on a package module to enumerate contained unit names and required packages. However this will not give you a list of classes contained in the package.
You could enumerate the package's list of exported functions (e.g. with TJclPeImage in the JCL) and search for those named like this:
#<unit_name>#<class_name>#
for example: '#System#TObject#'.
By calling GetProcAddress with the function name you get the TClass reference. From there you can walk the hierarchy using ClassParent. This way you can enumerate all classes in all packages loaded in a process running a Delphi executable compiled with runtime packages (Delphi IDE, too).
Another idea is to scan for type information which is on top of the list of exported functions so you can skip enumerating further. The type infos are exported with names starting with prefix '#$xp$'. Here's an example:
unit PackageUtils;
interface
uses
Windows, Classes, SysUtils, Contnrs, TypInfo;
type
TDelphiPackageList = class;
TDelphiPackage = class;
TDelphiProcess = class
private
FPackages: TDelphiPackageList;
function GetPackageCount: Integer;
function GetPackages(Index: Integer): TDelphiPackage;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Clear; virtual;
function FindPackage(Handle: HMODULE): TDelphiPackage;
procedure Reload; virtual;
property PackageCount: Integer read GetPackageCount;
property Packages[Index: Integer]: TDelphiPackage read GetPackages;
end;
TDelphiPackageList = class(TObjectList)
protected
function GetItem(Index: Integer): TDelphiPackage;
procedure SetItem(Index: Integer; APackage: TDelphiPackage);
public
function Add(APackage: TDelphiPackage): Integer;
function Extract(APackage: TDelphiPackage): TDelphiPackage;
function Remove(APackage: TDelphiPackage): Integer;
function IndexOf(APackage: TDelphiPackage): Integer;
procedure Insert(Index: Integer; APackage: TDelphiPackage);
function First: TDelphiPackage;
function Last: TDelphiPackage;
property Items[Index: Integer]: TDelphiPackage read GetItem write SetItem; default;
end;
TDelphiPackage = class
private
FHandle: THandle;
FInfoTable: Pointer;
FTypeInfos: TList;
procedure CheckInfoTable;
procedure CheckTypeInfos;
function GetDescription: string;
function GetFileName: string;
function GetInfoName(NameType: TNameType; Index: Integer): string;
function GetShortName: string;
function GetTypeInfoCount(Kinds: TTypeKinds): Integer;
function GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
public
constructor Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
destructor Destroy; override;
property Description: string read GetDescription;
property FileName: string read GetFileName;
property Handle: THandle read FHandle;
property ShortName: string read GetShortName;
property TypeInfoCount[Kinds: TTypeKinds]: Integer read GetTypeInfoCount;
property TypeInfos[Kinds: TTypeKinds; Index: Integer]: PTypeInfo read GetTypeInfos;
end;
implementation
uses
RTLConsts, SysConst,
PSAPI, ImageHlp;
{ Package info structures copied from SysUtils.pas }
type
PPkgName = ^TPkgName;
TPkgName = packed record
HashCode: Byte;
Name: array[0..255] of Char;
end;
PUnitName = ^TUnitName;
TUnitName = packed record
Flags : Byte;
HashCode: Byte;
Name: array[0..255] of Char;
end;
PPackageInfoHeader = ^TPackageInfoHeader;
TPackageInfoHeader = packed record
Flags: Cardinal;
RequiresCount: Integer;
{Requires: array[0..9999] of TPkgName;
ContainsCount: Integer;
Contains: array[0..9999] of TUnitName;}
end;
TEnumModulesCallback = function (Module: HMODULE; Data: Pointer = nil): Boolean;
TEnumModulesProc = function (Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
const
STypeInfoPrefix = '#$xp$';
var
EnumModules: TEnumModulesProc = nil;
function PackageInfoTable(Module: HMODULE): PPackageInfoHeader; forward;
function AddPackage(Module: HMODULE; Data: {TDelphiPackageList} Pointer): Boolean;
var
InfoTable: Pointer;
begin
Result := False;
if (Module <> HInstance) then
begin
InfoTable := PackageInfoTable(Module);
if Assigned(InfoTable) then
TDelphiPackageList(Data).Add(TDelphiPackage.Create(Module, InfoTable));
end;
end;
function GetPackageDescription(Module: HMODULE): string;
var
ResInfo: HRSRC;
ResData: HGLOBAL;
begin
Result := '';
ResInfo := FindResource(Module, 'DESCRIPTION', RT_RCDATA);
if ResInfo <> 0 then
begin
ResData := LoadResource(Module, ResInfo);
if ResData <> 0 then
try
Result := PWideChar(LockResource(ResData));
UnlockResource(ResData);
finally
FreeResource(ResData);
end;
end;
end;
function EnumModulesPS(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
var
ProcessHandle: THandle;
SizeNeeded: Cardinal;
P, ModuleHandle: PDWORD;
I: Integer;
begin
Result := False;
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, GetCurrentProcessId);
if ProcessHandle = 0 then
RaiseLastOSError;
try
SizeNeeded := 0;
EnumProcessModules(ProcessHandle, nil, 0, SizeNeeded);
if SizeNeeded = 0 then
Exit;
P := AllocMem(SizeNeeded);
try
if EnumProcessModules(ProcessHandle, P, SizeNeeded, SizeNeeded) then
begin
ModuleHandle := P;
for I := 0 to SizeNeeded div SizeOf(DWORD) - 1 do
begin
if Callback(ModuleHandle^, Data) then
Exit;
Inc(ModuleHandle);
end;
Result := True;
end;
finally
FreeMem(P);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
function EnumModulesTH(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
begin
Result := False;
// todo win9x?
end;
function PackageInfoTable(Module: HMODULE): PPackageInfoHeader;
var
ResInfo: HRSRC;
Data: THandle;
begin
Result := nil;
ResInfo := FindResource(Module, 'PACKAGEINFO', RT_RCDATA);
if ResInfo <> 0 then
begin
Data := LoadResource(Module, ResInfo);
if Data <> 0 then
try
Result := LockResource(Data);
UnlockResource(Data);
finally
FreeResource(Data);
end;
end;
end;
{ TDelphiProcess private }
function TDelphiProcess.GetPackageCount: Integer;
begin
Result := FPackages.Count;
end;
function TDelphiProcess.GetPackages(Index: Integer): TDelphiPackage;
begin
Result := FPackages[Index];
end;
{ TDelphiProcess public }
constructor TDelphiProcess.Create;
begin
inherited Create;
FPackages := TDelphiPackageList.Create;
Reload;
end;
destructor TDelphiProcess.Destroy;
begin
FPackages.Free;
inherited Destroy;
end;
procedure TDelphiProcess.Clear;
begin
FPackages.Clear;
end;
function TDelphiProcess.FindPackage(Handle: HMODULE): TDelphiPackage;
var
I: Integer;
begin
Result := nil;
for I := 0 to FPackages.Count - 1 do
if FPackages[I].Handle = Handle then
begin
Result := FPackages[I];
Break;
end;
end;
procedure TDelphiProcess.Reload;
begin
Clear;
if Assigned(EnumModules) then
EnumModules(AddPackage, FPackages);
end;
{ TDelphiPackageList protected }
function TDelphiPackageList.GetItem(Index: Integer): TDelphiPackage;
begin
Result := TDelphiPackage(inherited GetItem(Index));
end;
procedure TDelphiPackageList.SetItem(Index: Integer; APackage: TDelphiPackage);
begin
inherited SetItem(Index, APackage);
end;
{ TDelphiPackageList public }
function TDelphiPackageList.Add(APackage: TDelphiPackage): Integer;
begin
Result := inherited Add(APackage);
end;
function TDelphiPackageList.Extract(APackage: TDelphiPackage): TDelphiPackage;
begin
Result := TDelphiPackage(inherited Extract(APackage));
end;
function TDelphiPackageList.First: TDelphiPackage;
begin
Result := TDelphiPackage(inherited First);
end;
function TDelphiPackageList.IndexOf(APackage: TDelphiPackage): Integer;
begin
Result := inherited IndexOf(APackage);
end;
procedure TDelphiPackageList.Insert(Index: Integer; APackage: TDelphiPackage);
begin
inherited Insert(Index, APackage);
end;
function TDelphiPackageList.Last: TDelphiPackage;
begin
Result := TDelphiPackage(inherited Last);
end;
function TDelphiPackageList.Remove(APackage: TDelphiPackage): Integer;
begin
Result := inherited Remove(APackage);
end;
{ TDelphiPackage private }
procedure TDelphiPackage.CheckInfoTable;
begin
if not Assigned(FInfoTable) then
FInfoTable := PackageInfoTable(Handle);
if not Assigned(FInfoTable) then
raise EPackageError.CreateFmt(SCannotReadPackageInfo, [ExtractFileName(GetModuleName(Handle))]);
end;
procedure TDelphiPackage.CheckTypeInfos;
var
ExportDir: PImageExportDirectory;
Size: DWORD;
Names: PDWORD;
I: Integer;
begin
if not Assigned(FTypeInfos) then
begin
FTypeInfos := TList.Create;
try
Size := 0;
ExportDir := ImageDirectoryEntryToData(Pointer(Handle), True, IMAGE_DIRECTORY_ENTRY_EXPORT, Size);
if not Assigned(ExportDir) then
Exit;
Names := PDWORD(DWORD(Handle) + DWORD(ExportDir^.AddressOfNames));
for I := 0 to ExportDir^.NumberOfNames - 1 do
begin
if StrLIComp(PChar(DWORD(Handle) + Names^), STypeInfoPrefix, StrLen(STypeInfoPrefix)) <> 0 then
Break;
FTypeInfos.Add(GetProcAddress(Handle, PChar(DWORD(Handle) + Names^)));
Inc(Names);
end;
except
FreeAndNil(FTypeInfos);
raise;
end;
end;
end;
function TDelphiPackage.GetDescription: string;
begin
Result := GetPackageDescription(Handle);
end;
function TDelphiPackage.GetFileName: string;
begin
Result := GetModuleName(FHandle);
end;
function TDelphiPackage.GetInfoName(NameType: TNameType; Index: Integer): string;
var
P: Pointer;
Count: Integer;
I: Integer;
begin
Result := '';
CheckInfoTable;
Count := PPackageInfoHeader(FInfoTable)^.RequiresCount;
P := Pointer(Cardinal(FInfoTable) + SizeOf(TPackageInfoHeader));
case NameType of
ntContainsUnit:
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Count := Integer(P^);
P := Pointer(Cardinal(P) + SizeOf(Integer));
if (Index >= 0) and (Index < Count) then
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
Result := PUnitName(P)^.Name;
end;
end;
ntRequiresPackage:
if (Index >= 0) and (Index < Count) then
begin
for I := 0 to Index - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Result := PPkgName(P)^.Name;
end;
ntDcpBpiName:
if PPackageInfoHeader(FInfoTable)^.Flags and pfPackageModule <> 0 then
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Count := Integer(P^);
P := Pointer(Cardinal(P) + SizeOf(Integer));
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
Result := PPkgName(P)^.Name;
end;
end;
end;
function TDelphiPackage.GetShortName: string;
begin
Result := GetInfoName(ntDcpBpiName, 0);
end;
function TDelphiPackage.GetTypeInfoCount(Kinds: TTypeKinds): Integer;
var
I: Integer;
begin
CheckTypeInfos;
Result := 0;
for I := 0 to FTypeInfos.Count - 1 do
if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
Inc(Result);
end;
function TDelphiPackage.GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
var
I, J: Integer;
begin
CheckTypeInfos;
Result := nil;
J := -1;
for I := 0 to FTypeInfos.Count - 1 do
if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
begin
Inc(J);
if J = Index then
begin
Result := FTypeInfos[I];
Break;
end;
end;
end;
{ TDelphiPackage public }
constructor TDelphiPackage.Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
begin
inherited Create;
FHandle := AHandle;
FInfoTable := AInfoTable;
FTypeInfos := nil;
end;
destructor TDelphiPackage.Destroy;
begin
FTypeInfos.Free;
inherited Destroy;
end;
initialization
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
EnumModules := EnumModulesTH;
VER_PLATFORM_WIN32_NT:
EnumModules := EnumModulesPS;
else
EnumModules := nil;
end;
finalization
end.
Unit of the test design package installed in the IDE:
unit Test;
interface
uses
SysUtils, Classes,
ToolsAPI;
type
TTestWizard = class(TNotifierObject, IOTAWizard, IOTAMenuWizard)
private
{ IOTAWizard }
procedure Execute;
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
{ IOTAMenuWizard }
function GetMenuText: string;
end;
implementation
uses
TypInfo,
PackageUtils;
function AncestryStr(AClass: TClass): string;
begin
Result := '';
if not Assigned(AClass) then
Exit;
Result := AncestryStr(AClass.ClassParent);
if Result <> '' then
Result := Result + '\';
Result := Result + AClass.ClassName;
end;
procedure ShowMessage(const S: string);
begin
with BorlandIDEServices as IOTAMessageServices do
AddTitleMessage(S);
end;
{ TTestWizard }
procedure TTestWizard.Execute;
var
Process: TDelphiProcess;
I, J: Integer;
Package: TDelphiPackage;
PInfo: PTypeInfo;
PData: PTypeData;
begin
Process := TDelphiProcess.Create;
for I := 0 to Process.PackageCount - 1 do
begin
Package := Process.Packages[I];
for J := 0 to Package.TypeInfoCount[[tkClass]] - 1 do
begin
PInfo := Package.TypeInfos[[tkClass], J];
PData := GetTypeData(PInfo);
ShowMessage(Format('%s: %s.%s (%s)', [Package.ShortName, PData^.UnitName, PInfo^.Name, AncestryStr(PData^.ClassType)]));
end;
end;
end;
function TTestWizard.GetIDString: string;
begin
Result := 'TOndrej.TestWizard';
end;
function TTestWizard.GetName: string;
begin
Result := 'Test';
end;
function TTestWizard.GetState: TWizardState;
begin
Result := [wsEnabled];
end;
function TTestWizard.GetMenuText: string;
begin
Result := 'Test';
end;
var
Index: Integer = -1;
initialization
with BorlandIDEServices as IOTAWizardServices do
Index := AddWizard(TTestWizard.Create);
finalization
if Index <> -1 then
with BorlandIDEServices as IOTAWizardServices do
RemoveWizard(Index);
end.
You have to add designide to your requires clause. When you install this design package a new menu item Test should appear under Delphi's Help menu. Clicking it should display all loaded classes in the Messages window.
Have you tried Delphi's own class browser?
The browser gets loaded with shortcut CTRL-SHIFT-B. I believe you can access its options by right clicking in the browser. Here you have the option to show only the classes in your project or all known classes.
I haven't checked but I expect every descendant from TComponent, including installed components to be visible below the TComponent node. Use CTRL-F to search for a particular class.
Edit: according to this Delphi Wiki page, CTRL+SHIFT+B is only available in Delphi5. I don't have Delphi 2007 to check for this but if you can not find a class browser in your version, I'd suspect there isn't any.