TLS (Thread-Local-Storage) Callback support in Delphi 10 versions - delphi

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.

Related

DeviceIoControl - GetLastError: ERROR_NOACCESS - 998

I have a kernel driver written in C, where it is expecting a text of type PCWSTR. What's the Delphi type equivalent to send a control code? I tried sending using the following code but GetLastError reports ERROR_NOACCESS. How to solve that?
program Driverloader;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,
WinSvc,
SysUtils;
function InstallAndStartDriver(DriverPath, DriverName: WideString; out DriverDevice: THandle): Boolean;
var
hSCManager, hService: THandle;
lpServiceArgVectors: PWideChar;
begin
Result := False;
hSCManager := 0;
hSCManager := OpenSCManagerW(nil, nil, SC_MANAGER_ALL_ACCESS);
if hSCManager <> 0 then
begin
try
Writeln('OpenSCManagerW() - OK');
hService := 0;
hService := CreateServiceW(hSCManager, PWideChar(DriverName), PWideChar(DriverName), SERVICE_ALL_ACCESS, SERVICE_KERNEL_DRIVER, SERVICE_DEMAND_START, SERVICE_ERROR_NORMAL, PWideChar(DriverPath), nil, nil, nil, nil, nil);
hService := 0;
lpServiceArgVectors := nil;
hService := OpenServiceW(hSCManager, PWideChar(DriverName), SERVICE_ALL_ACCESS);
if hService <> 0 then
begin
try
Writeln('OpenServiceW() - OK');
if StartServiceW(hService, 0, PWideChar(lpServiceArgVectors)) then
begin
Writeln('StartServiceW() - OK');
Result := True;
end;
finally
CloseServiceHandle(hService);
end;
end;
finally
CloseServiceHandle(hSCManager);
end;
end;
if Result the
begin
DriverDevice := CreateFileW(PWideChar('\\.\' + DriverName), GENERIC_READ or GENERIC_WRITE, 0, PSECURITY_DESCRIPTOR(nil), OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
Result := GetLastError() = ERROR_SUCCESS;
Writeln('CreateFileW() - ' + IntToStr(GetLastError));
end;
end;
function CTL_CODE(DeviceType, _Function, Method, Access: Cardinal): Cardinal;
begin
Result := (DeviceType shl 16) or (Access shl 14) or (_Function shl 2) or (Method);
end;
var
driver: THandle;
BytesReturned, IOCTL_PATH_DELETE: Cardinal;
szInput, szOutput: array[0..255] of WideChar;
begin
try
IOCTL_PATH_DELETE := CTL_CODE(FILE_DEVICE_UNKNOWN, $500, METHOD_BUFFERED, FILE_ANY_ACCESS);
lstrcpy(szInput, '\??\C:\Program Files\Software Folder');
if InstallAndStartDriver(IncludeTrailingPathDelimiter(GetCurrentDir) + 'MyDriver.sys', 'MyDriver', driver) then
begin
Writeln('InstallAndStartDriver() - OK');
Sleep(2000);
if not DeviceIOControl(driver, IOCTL_PATH_DELETE, PWideChar(szInput[0]), SizeOf(szInput), PWideChar(szOutput[0]), SizeOf(szOutput) * MAXBYTE, BytesReturned, nil) then
Writeln('DeviceIOControl() - Error: ' + IntToStr(GetLastError))
else
Writeln('Success! - ' + szOutput);
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.
Edit
Receiving text on kernel driver "Dispatch" method:
NTSTATUS DrvDispatch(IN PDEVICE_OBJECT DeviceObject, IN PIRP Irp)
{
PIO_STACK_LOCATION irpStack;
PVOID ioBuffer;
ULONG ioControlCode;
NTSTATUS ntStatus;
PCWSTR Path;
Irp->IoStatus.Status = STATUS_SUCCESS;
Irp->IoStatus.Information = 0;
irpStack = IoGetCurrentIrpStackLocation(Irp);
ioBuffer = Irp->AssociatedIrp.SystemBuffer;
switch (irpStack->MajorFunction) {
case IRP_MJ_DEVICE_CONTROL:
ioControlCode = irpStack->Parameters.DeviceIoControl.IoControlCode;
switch (ioControlCode) {
case IOCTL_PATH_DELETE: {
Path = *(PCWSTR*)ioBuffer; // <-- fails and stop here
dprintf("%s\n", Path);
break;
}
default:
Irp->IoStatus.Status = STATUS_INVALID_PARAMETER;
break;
}
break;
}
ntStatus = Irp->IoStatus.Status;
IoCompleteRequest(Irp, IO_NO_INCREMENT);
return ntStatus;
}
While calling DeviceIOControl(IOCTL_PATH_DELETE), when you pass in szInput and szOutput, you are type-casting a single WideChar to a PWideChar, so whatever numeric value that WideChar contains will be mis-interpreted as a memory address, which is wrong. So you end up passing in invalid memory addresses, which can easily account for the ERROR_NOACCESS error.
Change PWideChar(szInput[0]) to PWideChar(#szInput[0]) or simply get rid of the type-cast altogether, passing #szInput as-is. Same with szOutput.
if not DeviceIOControl(driver, IOCTL_PATH_DELETE, #szInput, SizeOf(szInput), #szOutput, SizeOf(szOutput), BytesReturned, nil) then
Also, your use of GetLastError() on CreateFileW() is wrong. The return value of GetLastError() is indeterminate and not valid to use unless CreateFileW() returns INVALID_HANDLE_VALUE, OR if you use dwCreationDisposition=CREATE_ALWAYS or dwCreationDisposition=OPEN_ALWAYS, neither of which you are using.
DriverDevice := CreateFileW(...);
Result := DriverDevice <> INVALID_HANDLE_VALUE;
if not Result then
Writeln('CreateFileW() - Error: ' + IntToStr(GetLastError))
else
Writeln('CreateFileW() - Success!');
UPDATE: your kernel driver is expecting a pointer to a pointer to a null-terminated wide string. But your Delphi code is passing in a pointer to a null-terminated string. That is why your kernel code is crashing. You need to remove the unnecessary level of indirection in the kernel code:
//Path = *(PCWSTR*)ioBuffer;
Path = (PCWSTR)ioBuffer;
Also, your call to dprintf() is expecting a narrow string, but you are passing it a wide string. To print a wide string, you need to use %S instead of %s, eg:
dprintf("%S\n", Path);
On a side note, your Delphi code is leaking the handle returned by CreateServiceW(). You need to call CloseServiceHandle():
hService := CreateServiceW(...);
if hService <> 0 then
CloseServiceHandle(hService); // <-- ADD THIS!
lpServiceArgVectors := nil;
hService := OpenServiceW(...);
if hService <> 0 then
begin
...
end;
However, there is no good reason to immediately close a created service just to re-open it again. Use the handle that CreateServiceW() gives you:
hService := CreateServiceW(...);
lpServiceArgVectors := nil;
if hService <> 0 then
begin
...
end;

How do I make SetThreadDesktop API work from a console application?

I saw Stack Overflow question How to switch a process between default desktop and Winlogon desktop?.
And I have produced a minimal test-case creating a console project application, but SetThreadDesktop() does not switch my program to the target desktop.
Why does this happen?
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Winapi.Windows,
System.SysUtils,
Vcl.Graphics,
function RandomPassword(PLen: Integer): string;
var
str: string;
begin
Randomize;
str := 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
Result := '';
repeat
Result := Result + str[Random(Length(str)) + 1];
until (Length(Result) = PLen)
end;
procedure Print;
var
DCDesk: HDC;
bmp: TBitmap;
hmod, hmod2 : HMODULE;
BitBltAPI: function(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): BOOL; stdcall;
GetWindowDCAPI: function(hWnd: HWND): HDC; stdcall;
begin
hmod := GetModuleHandle('Gdi32.dll');
hmod2:= GetModuleHandle('User32.dll');
if (hmod <> 0) and (hmod2 <> 0) then begin
bmp := TBitmap.Create;
bmp.Height := Screen.Height;
bmp.Width := Screen.Width;
GetWindowDCAPI := GetProcAddress(hmod2, 'GetWindowDC');
if (#GetWindowDCAPI <> nil) then begin
DCDesk := GetWindowDCAPI(GetDesktopWindow);
end;
BitBltAPI := GetProcAddress(hmod, 'BitBlt');
if (#BitBltAPI <> nil) then begin
BitBltAPI(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, DCDesk, 0, 0, SRCCOPY);
bmp.SaveToFile('ScreenShot_------_' + RandomPassword(8) + '.bmp');
end;
ReleaseDC(GetDesktopWindow, DCDesk);
bmp.Free;
FreeLibrary(hmod);
FreeLibrary(hmod2);
end;
end;
//===============================================================================================================================
var
hWinsta, hdesktop:thandle;
begin
try
while True do
begin
hWinsta := OpenWindowStation('WinSta0', TRUE, GENERIC_ALL);
If hwinsta <> INVALID_HANDLE_VALUE then
begin
SetProcessWindowStation (hWinsta);
hdesktop := OpenDesktop ('default_set', 0, TRUE, GENERIC_ALL);
if (hdesktop <> INVALID_HANDLE_VALUE) then
if SetThreadDesktop (hdesktop) then
begin
Print; // Captures screen of target desktop.
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
end;
end;
Sleep(5000);
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Checking errors, the SetThreadDesktop() call fails with error code 170 (ERROR_BUSY, The requested resource is in use) when the target desktop is open.
var
threahdesk: boolean;
...
threahdesk := SetThreadDesktop (hdesktop);
ShowMessage(IntToStr(GetLastError));
if threahdesk Then
begin
Print;
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
end;
After that I saw several suggestion in some forums, my actual code is as follows:
var
hWinsta, hdesktop:thandle;
threahdesk, setprocwst: Boolean;
////////////////////////////////////////////////////////////////////////////////
begin
try
while True do
begin
Application.Free;
hWinsta:= OpenWindowStation('WinSta0', TRUE, GENERIC_ALL);
If hwinsta <> 0 Then
Begin
setprocwst := SetProcessWindowStation(hWinsta);
if setprocwst then
hdesktop:= OpenDesktop('default_set', 0, TRUE, GENERIC_ALL);
If (hdesktop <> 0) Then
threahdesk := SetThreadDesktop(hdesktop);
Application := TApplication.Create(nil);
Application.Initialize;
Application.Run;
If threahdesk Then
Begin
Print;
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
End;
End;
Sleep(5000);
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
The answer by Dmitriy is accurate in that the function fails because the calling thread has windows or hooks, although it doesn't explain how so.
The reason SetThreadDesktop is failing with ERROR_BUSY is, you have "forms.pas" in your uses list. Although it's missing in the code you posted (semicolon in "uses" clause is also missing hinting more units), the use of the Screen global variable makes it evident that you have "forms" in uses. "Forms" pulls in "controls.pas" which initializes the Application object. In its constructor, the Application creates a utility window for its PopupControlWnd. There may be other windows created but this one is enough reason for the function to fail.
You use Screen for its width/height. Un-use "forms", you can use API to retrieve that information.
There are other issues in the code like missing/wrong error checking which have been mentioned in the comments to the question, but they are not relevant to why SetThreadDesktop fails.
Below sample program demonstrates there's no problem calling SetThreadDesktop in the main thread of a console application, provided there's a desktop with name 'default_set' in the window station in which the program is running and has access rights to.
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
// Vcl.Forms, // uncomment to get an ERROR_BUSY
Winapi.Windows;
var
hSaveDesktop, hDesktop: HDESK;
begin
hSaveDesktop := GetThreadDesktop(GetCurrentThreadId);
Win32Check(hSaveDesktop <> 0);
hDesktop := OpenDesktop('default_set', 0, True, GENERIC_ALL);
Win32Check(hDesktop <> 0);
try
Win32Check(SetThreadDesktop(hDesktop));
try
// --
finally
Win32Check(SetThreadDesktop(hSaveDesktop));
end;
finally
Win32Check(CloseDesktop(hDesktop));
end;
end.
From the SetThreadDesktop() documentation:
The SetThreadDesktop function will fail if the calling thread has any windows or hooks on its current desktop (unless the hDesktop parameter is a handle to the current desktop).

Find and Replace Text in a Large TextFile (Delphi XE5)

I am trying to find and replace text in a text file. I have been able to do this in the past with methods like:
procedure SmallFileFindAndReplace(FileName, Find, ReplaceWith: string);
begin
with TStringList.Create do
begin
LoadFromFile(FileName);
Text := StringReplace(Text, Find, ReplaceWith, [rfReplaceAll, rfIgnoreCase]);
SaveToFile(FileName);
Free;
end;
end;
The above works fine when a file is relatively small, however; when the the file size is something like 170 Mb the above code will cause the following error:
EOutOfMemory with message 'Out of memory'
I have tried the following with success, however it takes a long time to run:
procedure Tfrm_Main.button_MakeReplacementClick(Sender: TObject);
var
fs : TFileStream;
s : AnsiString;
//s : string;
begin
fs := TFileStream.Create(edit_SQLFile.Text, fmOpenread or fmShareDenyNone);
try
SetLength(S, fs.Size);
fs.ReadBuffer(S[1], fs.Size);
finally
fs.Free;
end;
s := StringReplace(s, edit_Find.Text, edit_Replace.Text, [rfReplaceAll, rfIgnoreCase]);
fs := TFileStream.Create(edit_SQLFile.Text, fmCreate);
try
fs.WriteBuffer(S[1], Length(S));
finally
fs.Free;
end;
end;
I am new to "Streams" and working with buffers.
Is there a better way to do this?
Thank You.
You have two mistakes in first code example and three - in second example:
Do not load whole large file in memory, especially in 32bit application. If file size more than ~1 Gb, you always get "Out of memory"
StringReplace slows with large strings, because of repeated memory reallocation
In second code you don`t use text encoding in file, so (for Windows) your code "think" that file has UCS2 encoding (two bytes per character). But what you get, if file encoding is Ansi (one byte per character) or UTF8 (variable size of char)?
Thus, for correct find&replace you must use file encoding and read/write parts of file, as LU RD said:
interface
uses
System.Classes,
System.SysUtils;
type
TFileSearchReplace = class(TObject)
private
FSourceFile: TFileStream;
FtmpFile: TFileStream;
FEncoding: TEncoding;
public
constructor Create(const AFileName: string);
destructor Destroy; override;
procedure Replace(const AFrom, ATo: string; ReplaceFlags: TReplaceFlags);
end;
implementation
uses
System.IOUtils,
System.StrUtils;
function Max(const A, B: Integer): Integer;
begin
if A > B then
Result := A
else
Result := B;
end;
{ TFileSearchReplace }
constructor TFileSearchReplace.Create(const AFileName: string);
begin
inherited Create;
FSourceFile := TFileStream.Create(AFileName, fmOpenReadWrite);
FtmpFile := TFileStream.Create(ChangeFileExt(AFileName, '.tmp'), fmCreate);
end;
destructor TFileSearchReplace.Destroy;
var
tmpFileName: string;
begin
if Assigned(FtmpFile) then
tmpFileName := FtmpFile.FileName;
FreeAndNil(FtmpFile);
FreeAndNil(FSourceFile);
TFile.Delete(tmpFileName);
inherited;
end;
procedure TFileSearchReplace.Replace(const AFrom, ATo: string;
ReplaceFlags: TReplaceFlags);
procedure CopyPreamble;
var
PreambleSize: Integer;
PreambleBuf: TBytes;
begin
// Copy Encoding preamble
SetLength(PreambleBuf, 100);
FSourceFile.Read(PreambleBuf, Length(PreambleBuf));
FSourceFile.Seek(0, soBeginning);
PreambleSize := TEncoding.GetBufferEncoding(PreambleBuf, FEncoding);
if PreambleSize <> 0 then
FtmpFile.CopyFrom(FSourceFile, PreambleSize);
end;
function GetLastIndex(const Str, SubStr: string): Integer;
var
i: Integer;
tmpSubStr, tmpStr: string;
begin
if not(rfIgnoreCase in ReplaceFlags) then
begin
i := Pos(SubStr, Str);
Result := i;
while i > 0 do
begin
i := PosEx(SubStr, Str, i + 1);
if i > 0 then
Result := i;
end;
if Result > 0 then
Inc(Result, Length(SubStr) - 1);
end
else
begin
tmpStr := UpperCase(Str);
tmpSubStr := UpperCase(SubStr);
i := Pos(tmpSubStr, tmpStr);
Result := i;
while i > 0 do
begin
i := PosEx(tmpSubStr, tmpStr, i + 1);
if i > 0 then
Result := i;
end;
if Result > 0 then
Inc(Result, Length(tmpSubStr) - 1);
end;
end;
var
SourceSize: int64;
procedure ParseBuffer(Buf: TBytes; var IsReplaced: Boolean);
var
i: Integer;
ReadedBufLen: Integer;
BufStr: string;
DestBytes: TBytes;
LastIndex: Integer;
begin
if IsReplaced and (not(rfReplaceAll in ReplaceFlags)) then
begin
FtmpFile.Write(Buf, Length(Buf));
Exit;
end;
// 1. Get chars from buffer
ReadedBufLen := 0;
for i := Length(Buf) downto 0 do
if FEncoding.GetCharCount(Buf, 0, i) <> 0 then
begin
ReadedBufLen := i;
Break;
end;
if ReadedBufLen = 0 then
raise EEncodingError.Create('Cant convert bytes to str');
FSourceFile.Seek(ReadedBufLen - Length(Buf), soCurrent);
BufStr := FEncoding.GetString(Buf, 0, ReadedBufLen);
if rfIgnoreCase in ReplaceFlags then
IsReplaced := ContainsText(BufStr, AFrom)
else
IsReplaced := ContainsStr(BufStr, AFrom);
if IsReplaced then
begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end
else
LastIndex := Length(BufStr);
SetLength(BufStr, LastIndex);
FSourceFile.Seek(FEncoding.GetByteCount(BufStr) - ReadedBufLen, soCurrent);
BufStr := StringReplace(BufStr, AFrom, ATo, ReplaceFlags);
DestBytes := FEncoding.GetBytes(BufStr);
FtmpFile.Write(DestBytes, Length(DestBytes));
end;
var
Buf: TBytes;
BufLen: Integer;
bReplaced: Boolean;
begin
FSourceFile.Seek(0, soBeginning);
FtmpFile.Size := 0;
CopyPreamble;
SourceSize := FSourceFile.Size;
BufLen := Max(FEncoding.GetByteCount(AFrom) * 5, 2048);
BufLen := Max(FEncoding.GetByteCount(ATo) * 5, BufLen);
SetLength(Buf, BufLen);
bReplaced := False;
while FSourceFile.Position < SourceSize do
begin
BufLen := FSourceFile.Read(Buf, Length(Buf));
SetLength(Buf, BufLen);
ParseBuffer(Buf, bReplaced);
end;
FSourceFile.Size := 0;
FSourceFile.CopyFrom(FtmpFile, 0);
end;
how to use:
procedure TForm2.btn1Click(Sender: TObject);
var
Replacer: TFileSearchReplace;
StartTime: TDateTime;
begin
StartTime:=Now;
Replacer:=TFileSearchReplace.Create('c:\Temp\123.txt');
try
Replacer.Replace('some текст', 'some', [rfReplaceAll, rfIgnoreCase]);
finally
Replacer.Free;
end;
Caption:=FormatDateTime('nn:ss.zzz', Now - StartTime);
end;
Your first try creates several copies of the file in memory:
it loads the whole file into memory (TStringList)
it creates a copy of this memory when accessing the .Text property
it creates yet another copy of this memory when passing that string to StringReplace (The copy is the result which is built in StringReplace.)
You could try to solve the out of memory problem by getting rid of one or more of these copies:
e.g. read the file into a simple string variable rather than a TStringList
or keep the string list but run the StringReplace on each line separately and write the result to the file line by line.
That would increase the maximum file size your code can handle, but you will still run out of memory for huge files. If you want to handle files of any size, your second approach is the way to go.
No - I don't think there's a faster way that the 2nd option (if you want a completely generic search'n'replace function for any file of any size). It may be possible to make a faster version if you code it specifically according to your requirements, but as a general-purpose search'n'replace function, I don't believe you can go faster...
For instance, are you sure you need case-insensitive replacement? I would expect that this would be a large part of the time spent in the replace function. Try (just for kicks) to remove that requirement and see if it doesn't speed up the execution quite a bit on large files (this depends on how the internal coding of the StringReplace function is made - if it has a specific optimization for case-sensitive searches)
I believe refinement of Kami's code is needed to account for the string not being found, but the start of a new instance of the string might occur at the end of the buffer. The else clause is different:
if IsReplaced then begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end else
LastIndex :=Length(BufStr) - Length(AFrom) + 1;
Correct fix is this one:
if IsReplaced then
begin
LastIndex := GetLastIndex(BufStr, AFrom);
LastIndex := Max(LastIndex, Length(BufStr) - Length(AFrom) + 1);
end
else
if FSourceFile.Position < SourceSize then
LastIndex := Length(BufStr) - Length(AFrom) + 1
else
LastIndex := Length(BufStr);

How to create Picture and HTML formats all together on the clipboard?

I need to create the following formats all together on the clipboard:
CF_BITMAP
CF_DIB
CF_DIB5
HTML Format
This is a console program which can create either the picture formats OR the HTML Format, but not all together on the clipboard:
program CopyImageFromFile;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Winapi.Windows,
Vcl.Clipbrd,
Vcl.ExtCtrls,
Vcl.Imaging.pngimage,
System.SysUtils;
function FormatHTMLClipboardHeader(HTMLText: string): string;
const
CrLf = #13#10;
begin
Result := 'Version:0.9' + CrLf;
Result := Result + 'StartHTML:-1' + CrLf;
Result := Result + 'EndHTML:-1' + CrLf;
Result := Result + 'StartFragment:000081' + CrLf;
Result := Result + 'EndFragment:°°°°°°' + CrLf;
Result := Result + HTMLText + CrLf;
Result := StringReplace(Result, '°°°°°°', Format('%.6d', [Length(Result)]), []);
end;
procedure CopyHTMLAndImageToClipBoard(const str, APngFile: AnsiString; const htmlStr: AnsiString = '');
var
gMem: HGLOBAL;
lp: PChar;
Strings: array[0..1] of AnsiString;
Formats: array[0..1] of UINT;
i: Integer;
ThisImage: TImage;
MyFormat: Word;
Bitmap: TBitMap;
AData: THandle;
APalette: HPALETTE;
begin
gMem := 0;
//{$IFNDEF USEVCLCLIPBOARD}
//Win32Check(OpenClipBoard(0));
//{$ENDIF}
Clipboard.Open;
try
//most descriptive first as per api docs
Strings[0] := FormatHTMLClipboardHeader(htmlStr);
Strings[1] := str;
Formats[0] := RegisterClipboardFormat('HTML Format');
Formats[1] := CF_TEXT;
{$IFNDEF USEVCLCLIPBOARD}
Win32Check(EmptyClipBoard);
{$ENDIF}
for i := 0 to High(Strings) do
begin
if Strings[i] = '' then Continue;
//an extra "1" for the null terminator
gMem := GlobalAlloc(GMEM_DDESHARE + GMEM_MOVEABLE, Length(Strings[i]) + 1);
{Succeeded, now read the stream contents into the memory the pointer points at}
try
Win32Check(gmem <> 0);
lp := GlobalLock(gMem);
Win32Check(lp <> nil);
CopyMemory(lp, PChar(Strings[i]), Length(Strings[i]) + 1);
finally
GlobalUnlock(gMem);
end;
Win32Check(gmem <> 0);
SetClipboardData(Formats[i], gMEm);
Win32Check(gmem <> 0);
gmem := 0;
end;
ThisImage := TImage.Create(nil);
try
ThisImage.Picture.LoadFromFile(APngFile);
// Comment this out to copy only the HTML Format:
Clipboard.Assign(ThisImage.Picture);
{MyFormat := CF_PICTURE;
ThisImage.Picture.SaveToClipBoardFormat(MyFormat, AData, APalette);
ClipBoard.SetAsHandle(MyFormat, AData);}
finally
ThisImage.Free;
end;
finally
//{$IFNDEF USEVCLCLIPBOARD}
//Win32Check(CloseClipBoard);
//{$ENDIF}
Clipboard.Close;
end;
end;
var
HTML: string;
begin
try
// Usage: CopyImageFromFile.exe test.png
// test.png is 32 bit with alpha channel
if ParamCount = 1 then
begin
if FileExists(ParamStr(1)) then
begin
if LowerCase(ExtractFileExt(ParamStr(1))) = '.png' then
begin
HTML := '<img border="0" src="file:///' + ParamStr(1) + '">';
CopyHTMLAndImageToClipBoard('test', ParamStr(1), HTML);
end;
end;
end;
except
on E: Exception do
begin
Writeln(E.ClassName, ': ', E.Message);
Readln;
end;
end;
end.
So how can I create all these formats together on the clipboard?
TClipboard empties the clipboard the first time you use a TClipboard method to put data on the clipboard (TClipboard.Assign(), TClipboard.SetBuffer(), TClipboard.SetAsHandle(), etc) after calling Open(). TClipboard expects you to use only its methods for accessing the clipboard, so your use of SetClpboardData() directly to store your string data is bypassing TClipboard's internal logic, thus your call to Assign() is seen as the first clipboard write and TClipboard wipes out any data you stored with SetClipboardData().
To avoid that, you have a few choices:
Assign() your image to the clipboard first, then save your string items with SetClipboardData() afterwards.
don't use Assign() at all. Use TPicture.SaveToClipboardFormat() directly and then call SetClipboardData().
don't use SetClipboardData() directly unless USEVCLCLIPBOARD is not defined. Use TClipboard.SetAsHandle() instead.
I would suggest #3. Let TClipboard do all of the work:
var
CF_HTML: UINT = 0;
// TClipboard.SetBuffer() allows a format and an arbitrary buffer
// to be specified and handles the global memory allocation.
// However, it is protected, so using an accessor class to reach it.
//
// TClipboard.AsText and TClipboard.SetTextBuf() always use
// CF_(UNICODE)TEXT, and TClipboard.SetAsHandle() requires manual
// allocation...
//
type
TClipboardAccess = class(TClipboard)
end;
procedure CopyHTMLAndImageToClipBoard(const str, APngFile: AnsiString; const htmlStr: AnsiString = '');
var
TmpHtmlStr: AnsiString;
ThisImage: TPicture;
begin
Clipboard.Open;
try
//most descriptive first as per api docs
TmpHtmlStr := FormatHTMLClipboardHeader(htmlStr);
TClipboardAccess(Clipboard).SetBuffer(CF_HTML, PAnsiChar(TmpHtmlStr)^, Length(TmpHtmlStr) + 1);
TClipboardAccess(Clipboard).SetBuffer(CF_TEXT, PAnsiChar(Str)^, Length(Str) + 1);
ThisImage := TPicture.Create;
try
ThisImage.LoadFromFile(APngFile);
Clipboard.Assign(ThisImage);
finally
ThisImage.Free;
end;
finally
Clipboard.Close;
end;
end;
initialization
CF_HTML := RegisterClipboardFormat('HTML Format');
If you really need to support {$IFNDEF USEVCLCLIPBOARD} then you cannot use TClipboard at all, eg:
var
CF_HTML: UINT = 0;
{$IFDEF USEVCLCLIPBOARD}
// TClipboard.SetBuffer() allows a format and an arbitrary buffer
// to be specified and handles the global memory allocation.
// However, it is protected, so using an accessor class to reach it.
//
// TClipboard.AsText and TClipboard.SetTextBuf() always use
// CF_(UNICODE)TEXT, and TClipboard.SetAsHandle() requires manual
// allocation...
//
type
TClipboardAccess = class(TClipboard)
end;
{$ENDIF}
procedure CopyHTMLAndImageToClipBoard(const str, APngFile: AnsiString; const htmlStr: AnsiString = '');
var
ThisImage: TPicture;
{$IFNDEF USEVCLCLIPBOARD}
ImgData: THandle;
ImgFormat: Word;
ImgPalette: HPALETTE;
{$ENDIF}
procedure SetAsText(Format: UINT; const S: AnsiString);
{$IFNDEF USEVCLCLIPBOARD}
var
gMem: HGLOBAL;
lp: PAnsiChar;
{$ENDIF}
begin
{$IFDEF USEVCLCLIPBOARD}
TClipboardAccess(Clipboard).SetBuffer(Format, PAnsiChar(S)^, Length(S) + 1);
{$ELSE}
//an extra "1" for the null terminator
gMem := GlobalAlloc(GMEM_DDESHARE + GMEM_MOVEABLE, Length(S) + 1);
Win32Check(gmem <> 0);
try
{Succeeded, now read the stream contents into the memory the pointer points at}
lp := GlobalLock(gMem);
Win32Check(lp <> nil);
try
CopyMemory(lp, PAnsiChar(S), Length(S) + 1);
finally
GlobalUnlock(gMem);
end;
except
GlobalFree(gMem);
raise;
end;
SetClipboardData(Format, gMem);
{$ENDIF}
end;
begin
{$IFDEF USEVCLCLIPBOARD}
Clipboard.Open;
{$ELSE}
Win32Check(OpenClipBoard(0));
{$ENDIF}
try
//most descriptive first as per api docs
SetAsText(CF_HTML, FormatHTMLClipboardHeader(htmlStr));
SetAsText(CF_TEXT, Str);
ThisImage := TPicture.Create;
try
ThisImage.LoadFromFile(APngFile);
{$IFDEF USEVCLCLIPBOARD}
Clipboard.Assign(ThisImage);
{$ELSE}
ImgPalette := 0;
ThisImage.SaveToClipboardFormat(ImgFormat, ImgData, ImgPalette);
SetClipboardData(ImgFormat, ImgData);
if ImgPalette <> 0 then
SetClipboardData(CF_PALETTE, ImgPalette);
{$ENDIF}
finally
ThisImage.Free;
end;
finally
{$IFDEF USEVCLCLIPBOARD}
Clipboard.Close;
{$ELSE}
Win32Check(CloseClipBoard);
{$ENDIF}
end;
end;
initialization
CF_HTML := RegisterClipboardFormat('HTML Format');
David is right. You need to have one pair of open/close, and only one EmptyClipboard. You need to iterate through your formats and call SetClipboardData for each one.
RegisterClipboardFormat should only be called once, so do that in some initialization routine.
I would also try to avoid doing any file I/O once you've opened the clipboard, as you don't want to hold it open longer than necessary. i.e. read your pictures from disk first, if possible.

Why is my code causing a I/O 104 error?

This program raises an I/O 104 error on EoF when first entering the while loop.
The purpose of the program is to look up if a username is already taken. The existing usernames are stored in a text file.
procedure TForm1.btnRegisterClick(Sender: TObject);
begin
sCUser := edtUserName.Text;
AssignFile(tNames, 'Names.txt');
begin
try
Reset(tNames);
except
ShowMessage('File not found');
Exit;
end;
end;
rewrite(tNames);
while not EoF(tNames) do // I get a I/O 104 Error here `
begin
Readln(tNames, sLine);
iPosComme := Pos(',', sLine);
sUser := Copy(sLine, 1, iPosComme - 1);
Delete(sLine, 1, iPosComme - 1);
if sCUser = sUser then begin
ShowMessage('Username taken');
end
else
begin
rewrite(tNames);
Writeln(tNames, sCUser + ',' + '0');
CloseFile(tNames);
end;
end;
end;
Remove the call to Rewrite()before Eof(). Even if you were not getting an IO error, your code would still fail because Rewrite() closes the file you opened with Reset() and then it creates a new bank file, so Eof() would always be True.
Update: error 104 is file not open for input, which means Reset() is not opening the file but is not raising an exception (which sounds like an RTL bug if Eof() is raising an exception, indicating that {I+} is active).
In any case, using AssignFile() and related routines is the old way to do file I/O. You should use newer techniques, like FileOpen() with FileRead(), TFileStream with TStreamReader, TStringList, etc...
Update: your loop logic is wrong. You are comparing only the first line. If it does not match the user, you are wiping out the file, writing the user to a new file, closing the file, and then continuing the loop. EoF() will then fail at that point. You need to rewrite your loop to the following:
procedure TForm1.btnRegisterClick(Sender: TObject
var
SCUser, sUser: String;
tNames: TextFile;
iPosComme: Integer;
Found: Boolean;
begin
sCUser := edtUserName.Text;
AssignFile(tNames,'Names.txt');
try
Reset(tNames);
except
ShowMessage('File not found');
Exit;
end;
try
Found := False;
while not EoF(tNames) do
begin
Readln(tNames,sLine);
iPosComme := Pos(',', sLine);
sUser := Copy(sLine ,1,iPosComme -1);
if sCUser = sUser then
begin
ShowMessage('Username taken') ;
Found := True;
Break;
end;
end;
if not Found then
Writeln(tNames,sCUser + ',0');
finally
CloseFile(tNames);
end;
end;
For the sake of completeness, this Version works for me, but it is hard to guess what the code is intended to do. Especially the while loop seems a bit displaced, since the file will contain exactly one line after the rewrite-case has ben hit once.
program wtf;
{$APPTYPE CONSOLE}
{$I+}
uses
SysUtils;
procedure Sample( sCUser : string);
var sUser, sLine : string;
iPosComme : Integer;
tnames : textfile;
begin
AssignFile(tNames,'Names.txt');
try
Reset(tNames);
except
Writeln('File not found');
Exit;
end;
while not EoF(tNames) do
begin
Readln(tNames,sLine);
iPosComme := Pos(',', sLine);
sUser := Copy(sLine ,1,iPosComme -1);
Delete( sLine,1, iPosComme -1);
if sCuser = sUser then begin
Writeln('Username taken') ;
end
else begin
Rewrite(tNames);
Writeln(tNames,sCUser + ',' + '0');
CloseFile(tNames);
Break; // file has been overwritten and closed
end;
end;
end;
begin
try
Sample('foobar');
except
on E: Exception do Writeln(E.ClassName, ': ', E.Message);
end;
end.
I wrote a version of this method that uses the newer TStreamReader and TStreamWriter classes.
This won't work with Delphi 7 of course, it's just to show how this could be done in newer versions of Delphi.
The code was heavily inspired by Remys answer.
procedure TForm1.btnRegisterClick(Sender: TObject);
var
Stream: TStream;
Reader: TStreamReader;
Writer: TStreamWriter;
Columns: TStringList;
UserName: string;
Found: Boolean;
FileName: string;
Encoding: TEncoding;
begin
FileName := ExpandFileName('Names.txt'); // An absolute path would be even better
UserName := edtUsername.Text;
Found := False;
Encoding := TEncoding.Default; // or another encoding, e.g. TEncoding.Unicode for Unicode
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Reader := TStreamReader.Create(Stream, Encoding);
try
Columns := TStringList.Create;
try
Columns.Delimiter := ',';
Columns.StrictDelimiter := True; // or False, depending on the file format
while not Reader.EndOfStream do
begin
Columns.DelimitedText := Reader.ReadLine;
if Columns.Count > 0 then
begin
if AnsiSameStr(Columns[0], UserName) then // or AnsiSameText if UserName is not case-sensitive
begin
ShowMessage('Username taken') ;
Found := True;
Break;
end;
end;
end;
finally
Columns.Free;
end;
finally
Reader.Free;
end;
finally
Stream.Free;
end;
if not Found then
begin
Writer := TStreamWriter.Create(FileName, True, Encoding);
try
// Warning: This will cause problems when the file does not end with a new line
Writer.WriteLine(UserName + ',0');
finally
Writer.Free;
end;
end;
end;
If performance and memory usage are not a concern:
procedure TForm1.btnRegisterClick(Sender: TObject);
var
Rows: TStringList;
Columns: TStringList;
UserName: string;
Found: Boolean;
FileName: string;
Encoding: TEncoding;
Row: string;
begin
FileName := ExpandFileName('Names.txt'); // An absolute path would be even better
UserName := edtUsername.Text;
Found := False;
Encoding := TEncoding.Default; // or another encoding, e.g. TEncoding.Unicode for Unicode
Rows := TStringList.Create;
try
Rows.LoadFromFile(FileName, Encoding);
Columns := TStringList.Create;
try
Columns.Delimiter := ',';
Columns.StrictDelimiter := True; // or False, depending on the file format
for Row in Rows do
begin
Columns.DelimitedText := Row;
if Columns.Count > 0 then
begin
if AnsiSameStr(Columns[0], UserName) then // or AnsiSameText if UserName is not case-sensitive
begin
ShowMessage('Username taken') ;
Found := True;
Break;
end;
end;
end;
finally
Columns.Free;
end;
if not Found then
begin
Rows.Add(UserName + ',0');
Rows.SaveToFile(FileName, Encoding);
end;
finally
Rows.Free;
end;
end;
This solution can be adapted to Delphi 7 by removing the Encoding variable.
If it's part of a bigger database it should be stored in a real database management system rather than a text file.

Resources