I'm reading this article that explain how to set a TLS callback in Delphi. The article author says the example works on "Delphi: 2007, 2010, XE4, XE10". But I have tested on Delphi 10 Seattle, Berlin, and Rio, and it does not work (the TLS callback is not executed), but when i test it on Delphi XE5, it works fine.
I also noted that the size of the .map file when compiling the test_app project in Delphi XE5 and Delphi 10 are different. The .map file in Delphi 10 is 5x bigger than the .map file in Delphi XE5 (something around 25KB and 125KB, respectively).
What detail am I missing here?
Following is the code with a reasonable translation to English of the add_tls project and the test_app project.
PS: The test_app project needs to be set to generate a .map file. Project > Options > Linking > Map file => Detailed.
add_tls:
program add_tls;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,
Classes,
SysUtils,
Generics.Collections;
procedure ShowHelp;
begin
Writeln('Usage: AddTls.exe "executable path"');
Writeln('Return Codes:');
Writeln(' - 0: TLS Callback successfully added');
Writeln(' - 1: the path to the executable file is not specified');
Writeln(' - 2: executable not found');
Writeln(' - 3: MAP file not found matching the specified file');
Writeln(' - 4: MAP file parsing error');
Writeln(' - 5: error accessing executable file');
Writeln(' - 6: there is no initialized TLS section in the executable file');
end;
type
TSectionData = record
Index: Integer;
StartAddr: DWORD;
SectionName: ShortString;
end;
TSectionDataList = TList<TSectionData>;
const
HardcodeTLS32Offset = 12;
//
// This is an easy way to search for TLS BUT tables - only in projects,
// collected in XE and above
// If the executable is built by another compiler, it will not work naturally
// but the article is not about that :)
// so:
// =============================================================================
function GetTlsTableAddr(const FilePath: string): DWORD;
var
F: TFileStream;
DOS: TImageDosHeader;
NT: TImageNtHeaders;
I: Integer;
Section: TImageSectionHeader;
begin
Result := 0;
// open the file for reading
F := TFileStream.Create(FilePath, fmOpenRead or fmShareDenyWrite);
try
// read DOS header to go to NT
F.ReadBuffer(DOS, SizeOf(TImageDosHeader));
F.Position := DOS._lfanew;
// We read the NT header to get the number of sections
F.ReadBuffer(NT, SizeOf(TImageNtHeaders));
// read sections and look for TLS
for I := 0 to NT.FileHeader.NumberOfSections - 1 do
begin
F.ReadBuffer(Section, SizeOf(TImageSectionHeader));
if PAnsiChar(#Section.Name[0]) = '.tls' then
begin
// found IMAGE_TLS_DIRECTORY, we immediately correct the AddressOfCallback field
Result := Section.PointerToRawData + HardcodeTLS32Offset;
Break;
end;
end;
finally
F.Free;
end;
end;
// just parse the map file and look for the addresses of the sections
function GetSectionDataList(const FilePath: string; var Index: Integer): TSectionDataList;
var
S: TStringList;
Line: string;
Section: TSectionData;
begin
Result := TSectionDataList.Create;
try
S := TStringList.Create;
try
S.LoadFromFile(FilePath);
Index := 0;
Writeln('I am looking for a table of sections...');
while Copy(Trim(S[Index]), 1, 5) <> 'Start' do
Inc(Index);
Inc(Index);
while Trim(S[Index]) <> '' do
begin
Line := Trim(S[Index]);
Section.Index := StrToInt(Copy(Line, 1, 4));
Delete(Line, 1, 5);
Section.StartAddr := StrToInt('$' + Copy(Line, 1, 8));
Delete(Line, 1, 19);
Section.SectionName := ShortString(Trim(Copy(Line, 1, 8)));
Result.Add(Section);
Inc(Index);
end;
Writeln('Total sections found: ', Result.Count);
finally
S.Free;
end;
except
// we suppress all exceptions. there are error codes
on E: Exception do
Writeln('GetSectionDataList: ' + E.ClassName + ': ' + E.Message);
end;
end;
// again, parse the mapfile and look for the address of the function called tls_callback
// which (if found) we summarize with the address of the section in which it is located
function GetTlsCallbackAddr(const FilePath: string;
SectionDataList: TSectionDataList; Index: Integer): DWORD;
var
S: TStringList;
Line: string;
SectionIndex, TlsAddr: Integer;
begin
Result := 0;
try
S := TStringList.Create;
try
S.LoadFromFile(FilePath);
Writeln('Looking for tls_callback...');
repeat
Line := Trim(S[Index]);
Inc(Index);
if Index = S.Count then Break;
until Pos('.tls_callback', Line) <> 0;
if Pos('.tls_callback', Line) = 0 then
begin
Writeln('No tls_callback entry found in MAP file');
Exit;
end;
SectionIndex := StrToInt(Copy(Line, 1, 4));
Delete(Line, 1, 5);
TlsAddr := StrToInt('$' + Copy(Line, 1, 8));
Writeln('tls_callback found, offset: ', IntToHex(TlsAddr, 8), ', section: ', SectionIndex);
Writeln('Looking for a record about the section...');
for Index := 0 to SectionDataList.Count - 1 do
if SectionDataList[Index].Index = SectionIndex then
begin
Result := SectionDataList[Index].StartAddr + DWORD(TlsAddr);
Writeln('TLS Callback, found in section "', SectionDataList[Index].SectionName,
'", offset sections: ', IntToHex(SectionDataList[Index].StartAddr, 8),
', calculated addressc: ', IntToHex(Result, 8));
Break;
end;
if Result = 0 then
Writeln('Section containing tls_callback not found')
finally
S.Free;
end;
except
// we suppress all exceptions. there are error codes
on E: Exception do
Writeln('GetTlsCallbackAddr: ' + E.ClassName + ': ' + E.Message);
end;
end;
// directly patch file
function Patch(const FilePath, MapPath: string; TlsTable, CallbackAddr: DWORD): Boolean;
var
F: TFileStream;
NewFilePath, BackUpFilePath: string;
OldCallbackTableAddr: DWORD;
begin
Result := False;
try
NewFilePath := ExtractFilePath(FilePath) + 'tls_aded_' +
ExtractFileName(FilePath);
Writeln('I create a copy of the file, the path: ', NewFilePath);
CopyFile(PChar(FilePath), PChar(NewFilePath), False);
F := TFileStream.Create(NewFilePath, fmOpenReadWrite);
try
Writeln('File open');
F.Position := TlsTable;
// read the address where the previous callback referred
F.ReadBuffer(OldCallbackTableAddr, 4);
// in a delphi image, it refers to the SizeOfZeroFill structure of IMAGE_TLS_DIRECTORY
// in which both last fields are filled with zeros (supposedly there is no callback chain)
// Therefore, we will not spoil the working structure and make it refer to the address
// immediately outside of this structure (plus 2 yards in 32 bit, in 64 bit)
Inc(OldCallbackTableAddr, SizeOf(DWORD) * 2);
F.Position := TlsTable;
// write a new address to the old place
F.WriteBuffer(OldCallbackTableAddr, 4);
Writeln('Assigned a new address to the chain of processors, offset: ', IntToHex(TlsTable, 8),
', new value: ', IntToHex(OldCallbackTableAddr, 8));
// now we jump to the place where the VA address of the handler (not RVA) should be written
// skip SizeOfZeroFill and Characteristics and get right behind them
F.Position := TlsTable + SizeOf(DWORD) * 3;
// and now write the address of our callback
F.WriteBuffer(CallbackAddr, 4);
Writeln('Callback address set, offset: ', IntToHex(TlsTable + SizeOf(DWORD) * 3, 8));
// after which we write zero to indicate the end of the callback chain
CallbackAddr := 0;
F.WriteBuffer(CallbackAddr, 4);
finally
F.Free;
end;
// if everything is fine, then rename back
Writeln('I create a backup');
BackUpFilePath := FilePath + '.bak';
DeleteFile(BackUpFilePath);
RenameFile(FilePath, BackUpFilePath);
Writeln('I keep the result');
RenameFile(NewFilePath, FilePath);
Writeln('All tasks completed');
Result := True;
except
// we suppress all exceptions. there are error codes
on E: Exception do
begin
// in the event of an error, we clean ourselves up - returning everything back
DeleteFile(NewFilePath);
RenameFile(BackUpFilePath, FilePath);
Writeln('Patch: ' + E.ClassName + ': ' + E.Message);
end;
end;
end;
var
MapPath: string;
TlsTable, CallbackAddr: DWORD;
SectionDataList: TSectionDataList;
Index: Integer;
begin
ExitCode := 0;
if ParamCount = 0 then
begin
ShowHelp;
ExitCode := 1;
ExitProcess(ExitCode);
end;
if not FileExists(ParamStr(1)) then
begin
Writeln('No executable found: ', ParamStr(1));
ExitCode := 2;
ExitProcess(ExitCode);
end;
TlsTable := GetTlsTableAddr(ParamStr(1));
if TlsTable = 0 then
begin
ExitCode := 6;
ExitProcess(ExitCode);
end;
MapPath := ChangeFileExt(ParamStr(1), '.map');
if not FileExists(MapPath) then
begin
Writeln('MAP file not found: ', MapPath);
ExitCode := 3;
ExitProcess(ExitCode);
end;
Index := 0;
SectionDataList := GetSectionDataList(MapPath, Index);
try
if SectionDataList.Count = 0 then
begin
Writeln('Could not build partition table');
ExitCode := 9;
ExitProcess(ExitCode);
end;
CallbackAddr := GetTlsCallbackAddr(MapPath, SectionDataList, Index);
if CallbackAddr = 0 then
begin
ExitCode := 4;
ExitProcess(ExitCode);
end;
if not Patch(ParamStr(1), MapPath, TlsTable, CallbackAddr) then
ExitCode := 5;
finally
SectionDataList.Free;
end;
ExitProcess(ExitCode);
end.
test_app:
program test_app;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows;
// this callback will be called if the file is correctly patched
procedure tls_callback(hModule: HMODULE;
ul_reason_for_call: DWORD; lpReserved: Pointer); stdcall;
begin
if ul_reason_for_call = DLL_PROCESS_ATTACH then
MessageBox(0, 'TLS Callback Message', nil, 0);
end;
const
ptls_callback: Pointer = #tls_callback;
begin
// so that the tls_callback procedure appears in the MAP file
// you need a link to it, it’s corny like this:
if ptls_callback <> nil then
MessageBox(0, 'Entry Point Message', nil, 0);
end.
If your aim is to have some code execute as soon as possible, here is something which works on any Delphi revision, and on any platform (not only Windows).
Create a small unit with no dependency (no uses clause at all).
unit FirstLoaded;
interface
// NO "uses" clause!
implementation
procedure SomeThingToDoEarly;
begin
end;
initialization
SomeThingToDoEarly;
end.
Then put it as first unit in the uses clause of your project .dpr - before anything else.
program Project1;
uses
FirstLoaded, // before anything!
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
The code in the initialization part of your unit will be called just after system.pas.
Be aware that if you add something in your uses clause of your unit, those units (and their dependencies) would be initialized first.
Using Rad Studio 10 Seattle, DUnitX and TestInsight, I would need to show some texts in the console or any log screen. How can it be done? I have not been able to find it in the web.
procedure CreateRunner;
var fn : TFileName;
begin
runner := TDUnitX.CreateRunner;
runner.UseRTTI := True;
fn := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)) + 'dUnitX.Log';
ConsoleLogger := TDUnitXConsoleLogger.Create(false);
TextFileLogger:= TDUnitXTextFileLogger.Create(fn);
nunitLogger := TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile);
runner.AddLogger(ConsoleLogger );
runner.AddLogger(TextFileLogger);
runner.AddLogger(nunitLogger);
end;
Here's how to add log messages, fragments copied from https://github.com/VSoftTechnologies/DUnitX/blob/d5861ce0de6a9fbfdc8c158b0b1c8614082c188d/Examples/DUnitX.Examples.General.pas
[TestFixture('ExampleFixture1','General Example Tests')]
TMyExampleTests = class
public
[Test]
procedure LogMessageTypes;
end;
procedure TMyExampleTests.LogMessageTypes;
begin
TDUnitX.CurrentRunner.Log(TLogLevel.Information, 'Information');
TDUnitX.CurrentRunner.Log(TLogLevel.Warning, 'Warning');
TDUnitX.CurrentRunner.Log(TLogLevel.Error, 'Error');
end;
If you want to have a less convoluted syntax, you can always add an interposer for the Assert class like so
Assert = class(DUnitX.Assert.Assert) //Or (DunitX.Assert.Ex.Assert)
public
class procedure Log(const message: string);
end;
class procedure Assert.Log(const message: string);
begin
TDUnitX.CurrentRunner.Log(TLogLevel.Information, message);
end;
https://github.com/jsf3rd/DUnitX.git/trunk/Examples
var
runner : ITestRunner;
logger : ITestLogger;
begin
try
//Create the runner
runner := TDUnitX.CreateRunner;
runner.UseRTTI := True;
//tell the runner how we will log things
if TDUnitX.Options.ConsoleMode <> TDunitXConsoleMode.Off then
begin
logger := TDUnitXConsoleLogger.Create(TDUnitX.Options.ConsoleMode = TDunitXConsoleMode.Quiet);
runner.AddLogger(logger);
end;
//Run tests
results := runner.Execute;
System.Write('Done.. press <Enter> key to quit.');
System.Readln;
except
on E: Exception do
System.Writeln(E.ClassName, ': ', E.Message);
end;
I am consuming a WSDL and when I try to execute one of the methods i am getting the error
.. raised exception class EPropertyConvertError with message 'Invalid
property element: System'
Any ideas what causes this?
Here is the code I am running (cEPS_* are constants defined earlier in the code):
procedure TForm1.Button1Click(Sender: TObject);
var
Headers : ISOAPHeaders;
aResult: c_ExpressPSAPI.Response;
begin
try
FEPS_SoapService := c_ExpressPSAPI.GetExpressSoap();
FEPS_Headers := (FEPS_SoapService as ISOAPHeaders);
FEPS_Application := c_ExpressPSAPI.Application.Create();
FEPS_Application.ApplicationID := cEPS_ApplicationID;
FEPS_Application.ApplicationName := cEPS_ApplicationName;
FEPS_Credentials := c_ExpressPSAPI.Credentials.Create();
FEPS_Credentials.AccountID := cEPS_AccountID;
FEPS_Credentials.AccountToken := cEPS_AccountToken;
FEPS_Credentials.AcceptorID := cEPS_AcceptorID;
FEPS_Credentials.NewAccountToken := '';
aResult := c_ExpressPSAPI.Response.Create;
aResult := FEPS_SoapService.HealthCheck(FEPS_Credentials, FEPS_Application);
except
on E : ERemotableException do
ShowMessage(E.ClassName + ' error raised, with message : ' + E.FaultDetail + ' :: '
+ E.Message);
end;
end;
And here is the WSDL code:
ExpressSoap = interface(IInvokable)
['{83D77575-DBDE-3A05-D048-60B2F6BCDFE6}']
function HealthCheck(const credentials: Credentials; const application: Application): Response; stdcall;
Please consider this record:
Type
TStudent = record
Name:String;
Age: Integer;
Class:String;
end;
I have a class TSchool that has the following function:
function AddStudent(LStudent:TStudent):Boolean;
I want to use this class (TSchool) in the dwsunit, and this function too, but i can't figure out how to send the record type as parameter.
This is how far i've reached:
procedure TForm1.dwsUnitClassesTSchoolMethodsAddStudentEval(Info: TProgramInfo;
ExtObject: TObject);
begin
Info.ResultAsBoolean:=(ExtObject as TSchool).AddStudent(Info.Vars['LStudent'].Value);
end;
but this is not working, it keeps on giving me error about incompatible types.
I have also defined in the dwsunit a record TSchool, but this didn't work either.
Any Help is appreciated.
I don't have Delphi 2010 at my disposal now, but I do have Delphi XE(it should work in D2010 also), so here's what works for me, you can of course modify to fit your needs:
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils
,Windows
,dwsComp
,dwsCompiler
,dwsExprs
,dwsCoreExprs
,dwsRTTIExposer
,Generics.Collections
;
// required
{$RTTI EXPLICIT METHODS([vcPublic, vcPublished]) PROPERTIES([vcPublic, vcPublished])}
{M+}
type
// student definition
TStudent = record
Name: string;
Age: Integer;
AClass: string;
end;
// student list, we use generics
TStudentList = class(TList<TStudent>);
// school class
TSchool = class(TObject)
private
FStudentList: TStudentList;
published
constructor Create;
destructor Destroy; override;
published
procedure AddStudent(AStudent: TStudent);
function GetStudentCount: Integer;
function GetStudent(Index: Integer): TStudent;
end;
{ TSchool }
procedure TSchool.AddStudent(AStudent: TStudent);
begin
FStudentList.Add(AStudent);
end;
constructor TSchool.Create;
begin
FStudentList := TStudentList.Create;
end;
function TSchool.GetStudentCount: Integer;
begin
Result := FStudentList.Count;
end;
function TSchool.GetStudent(Index: Integer): TStudent;
begin
Result := FStudentList[ Index ];
end;
destructor TSchool.Destroy;
begin
FStudentList.Free;
inherited;
end;
procedure TestRecords;
var
LScript: TDelphiWebScript;
LUnit: TdwsUnit;
LProg: IdwsProgram;
LExec: IdwsProgramExecution;
begin
LScript := TDelphiWebScript.Create(NIL);
LUnit := TdwsUnit.Create(NIL);
try
LUnit.UnitName := 'MySuperDuperUnit';
LUnit.Script := LScript;
// expose TStudent record to the script
LUnit.ExposeRTTI(TypeInfo(TStudent));
// expose TSchool class to script
LUnit.ExposeRTTI(TypeInfo(TSchool));
// compile a simple script
LProg := LScript.Compile(
'var LSchool := TSchool.Create;'#$D#$A +
'var LStudent: TStudent;'#$D#$A +
'var Index: Integer;'#$D#$A +
'for Index := 0 to 10 do begin'#$D#$A +
'LStudent.Name := Format(''Student #%d'', [Index]);'#$D#$A +
'LStudent.Age := 10 + Index;'#$D#$A +
'LStudent.AClass := ''a-4'';'#$D#$A +
'LSchool.AddStudent( LStudent );'#$D#$A +
'end;'#$D#$A +
'PrintLn(Format(''There are %d students in school.'', [LSchool.GetStudentCount]));'#$D#$A +
'LStudent := LSchool.GetStudent( 5 );'#$D#$A +
'PrintLn(''6th student info:'');'#$D#$A +
'PrintLn(Format(''Name: %s''#$D#$A''Age: %d''#$D#$A''AClass: %s'', [LStudent.Name, LStudent.Age, LStudent.Aclass]));'
);
if LProg.Msgs.HasErrors then begin
Writeln(LProg.Msgs.AsInfo);
Exit;
end;
try
LExec := LProg.Execute;
except
on E: Exception do
WriteLn(E.Message + #$D#$A + LExec.Msgs.AsInfo );
end;
Writeln(LExec.Result.ToString);
finally
LScript.Free;
end;
end;
begin
try
Writeln('press enter to begin');
Readln;
TestRecords;;
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
I am writing a console application using BDE 2006 and I want it to be able to prompt for a password string and mask it with "*" as the user is typing. I have looked around but I could not find examples of how to do this. Everything I saw was how to do this in TEdit. Any pointers on how to accomplish this?
Thanks in advance,
Nic
Here's a working solution:
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows;
function GetPassword(const InputMask: Char = '*'): string;
var
OldMode: Cardinal;
c: char;
begin
GetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), OldMode);
SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), OldMode and not (ENABLE_LINE_INPUT or ENABLE_ECHO_INPUT));
try
while not Eof do
begin
Read(c);
if c = #13 then // Carriage Return
Break;
Result := Result + c;
if c = #8 then // Back Space
Write(#8)
else
Write(InputMask);
end;
finally
SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), OldMode);
end;
end;
begin
try
Writeln(Format(sLineBreak + 'pswd=%s',[GetPassword]));
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Update: Note that the above code handles the BackSpaces visually, but keeps them embedded in the password, which might not be what you want.
In that case the following code would filter them out:
if c = #13 then // Carriage Return
Break;
if (c = #8) and (Length(Result) > 0) then // Back Space
begin
Delete(Result, Length(Result), 1);
Write(#8);
end
else
begin
Result := Result + c;
Write(InputMask);
end;
I have a unit with procedure ConsoleGetPassword(const caption: String; var Password: string); which does what you want
see http://gist.github.com/570659
This works.
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows;
const
BUF_LEN = 1024;
var
amt, i, cmode: cardinal;
buf: packed array[0..BUF_LEN - 1] of char;
begin
try
Write('Enter password: ');
GetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), cmode);
SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), cmode and not ENABLE_ECHO_INPUT);
ReadConsole(GetStdHandle(STD_INPUT_HANDLE), #buf[0], BUF_LEN, amt, nil);
SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), cmode);
Writeln;
Writeln;
Writeln('You entered: ');
for i := 0 to amt - 3 do
Write(buf[i]);
Writeln;
Writeln;
Writeln('Done');
Readln;
except
on E:Exception do
begin
Writeln(E.Classname, ': ', E.Message);
Readln;
end;
end;
end.
Please see this article on CodeProject, it may be in C#, but it does give you the right clues and the direction to take, involving ReadConsoleInput and WriteConsole API