259 lines
9.4 KiB
ObjectPascal
259 lines
9.4 KiB
ObjectPascal
/// this unit will patch the System.pas RTL to use a custom NON OLE COMPATIBLE
|
|
// WideString type, NOT using the slow Windows API, but FastMM4 (without COW)
|
|
// - this unit is a part of the freeware Synopse mORMot framework,
|
|
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
|
unit SynFastWideString;
|
|
|
|
interface
|
|
|
|
(*
|
|
This file is part of Synopse Framework.
|
|
|
|
Synopse Framework. Copyright (C) 2022 Arnaud Bouchez
|
|
Synopse Informatique - https://synopse.info
|
|
|
|
*** BEGIN LICENSE BLOCK *****
|
|
Version: MPL 1.1/GPL 2.0/LGPL 2.1
|
|
|
|
The contents of this file are subject to the Mozilla Public License Version
|
|
1.1 (the "License"); you may not use this file except in compliance with
|
|
the License. You may obtain a copy of the License at
|
|
http://www.mozilla.org/MPL
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
|
for the specific language governing rights and limitations under the License.
|
|
|
|
The Original Code is Synopse Framework.
|
|
|
|
The Initial Developer of the Original Code is Arnaud Bouchez.
|
|
|
|
Portions created by the Initial Developer are Copyright (C) 2022
|
|
the Initial Developer. All Rights Reserved.
|
|
|
|
Contributor(s):
|
|
|
|
Alternatively, the contents of this file may be used under the terms of
|
|
either the GNU General Public License Version 2 or later (the "GPL"), or
|
|
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
|
|
in which case the provisions of the GPL or the LGPL are applicable instead
|
|
of those above. If you wish to allow use of your version of this file only
|
|
under the terms of either the GPL or the LGPL, and not to allow others to
|
|
use your version of this file under the terms of the MPL, indicate your
|
|
decision by deleting the provisions above and replace them with the notice
|
|
and other provisions required by the GPL or the LGPL. If you do not delete
|
|
the provisions above, a recipient may use your version of this file under
|
|
the terms of any one of the MPL, the GPL or the LGPL.
|
|
|
|
***** END LICENSE BLOCK *****
|
|
|
|
DISCLAIMER:
|
|
|
|
Purpose of this unit is to patch the system.pas unit for older versions
|
|
of Delphi, so that WideString memory allocation would use FastMM4 instead
|
|
of the slow BSTR Windows API.
|
|
|
|
It will speed up the WideString process a lot, especially when a lot of
|
|
content is allocated, since FastMM4 is much more aggressive than Windows'
|
|
global heap and the BSTR slow API. It could be more than 50 times faster,
|
|
especially when releasing the used memory.
|
|
|
|
The WideString implementation pattern does NOT feature Copy-On-Write, so is
|
|
slower than the string=UnicodeString type as implemented since Delphi 2009.
|
|
This is the reason why this unit won't do anything on Unicode versions of
|
|
the compiler, since the new string type is to be preferred.
|
|
|
|
HOW TO USE:
|
|
|
|
Just add the unit at the TOP of your .dpr uses clause, just after FastMM4
|
|
(if you use it, and you should!) i.e. before all other units used by your
|
|
program. It should be initialized before any WideString is allocated.
|
|
|
|
Then the patch will be applied at runtime. Nothing to recompile!
|
|
|
|
program MyProgram;
|
|
|
|
uses
|
|
{$I SynDprUses.inc} // will enable FastMM4 prior to Delphi 2006
|
|
SynFastWideString, // will use FastMM4 prior to Delphi 2009
|
|
...
|
|
|
|
NOTE:
|
|
|
|
Since we add a trailing 0 byte at the end of the buffer, we need the
|
|
memory manager to let enough place for it: oldest Borland MM does not :(
|
|
SO IF YOU WORK WITH A VERSION PRIOR TO DELPHI 2006, ADD FASTMM4 TO YOUR .DPR
|
|
|
|
WARNING:
|
|
|
|
------------------------------------------------------------------
|
|
USING THIS UNIT MAY BREAK COMPATIBILITY WITH OLE/COM LIBRARIES !
|
|
------------------------------------------------------------------
|
|
You won't be able to retrieve and release WideString/BSTR variables from an
|
|
OleDB / ADO database provider, or any COM object.
|
|
Do not use this unit if you are calling such external call!
|
|
|
|
In practice, if you only SEND some BSTR content to the provider (e.g. if
|
|
you use our SynOleDB unit without stored procedure call, or if you use
|
|
TWideString fields for most SynDBDataSet classes), it will work.
|
|
You would have issues only if you *retrieve* a BSTR from the COM object,
|
|
or expect the COM object to *change* the BSTR size, e.g. with a "var"
|
|
WideString parameter or a COM method returning a WideString. In this case,
|
|
you could use the WideStringFree() procedure to release such an instance.
|
|
|
|
It is for educational purpose only, and/or if you are 100% sure that your
|
|
code will stay self-contained, under Delphi 7 or Delphi 2007, and need use
|
|
of WideString instead of string=AnsiString.
|
|
|
|
-----------------------------------------------
|
|
YOU HAVE BEEN WARNED - USE AT YOUR OWN RISK ! :)
|
|
-----------------------------------------------
|
|
|
|
*)
|
|
|
|
/// this low-level helper can be used to free a WideString returned by COM/OLE
|
|
// - WideString instances created with this unit can be safely sent to any
|
|
// COM/OLE object, as soon as they are constant parameters, but not a "var"
|
|
// parameter or a callback function result
|
|
// - any WideString instance returned by a COM object should NOT be released
|
|
// by Delphi automatically, since the following would create a memory error:
|
|
// ! TrueBSTRWideStringVariable := '';
|
|
// - if you are using SynFastWideString, you should use this procedure to
|
|
// release true BSTR WideString instance, as such:
|
|
// ! type
|
|
// ! _Catalog = interface(IDispatch)
|
|
// ! // this method will be safe to use with our unit
|
|
// ! function Create(const ConnectString: WideString): OleVariant; safecall;
|
|
// ! // this method won't be safe, since it returns a true BSTR as WideString
|
|
// ! function GetObjectOwner(const ObjectName: WideString; ObjectType: OleVariant;
|
|
// ! ObjectTypeId: OleVariant): WideString; safecall;
|
|
// ! end;
|
|
// !...
|
|
// !function CheckCatalogOwner(const catalog: _Catalog): string;
|
|
// !var bstr: WideString;
|
|
// !begin
|
|
// ! try // force manual handling of this true BSTR instance lifetime
|
|
// ! bstr := catalog.GetObjectOwner('name',null,null);
|
|
// ! result := bstr; // conversion to string will work
|
|
// ! finally
|
|
// ! WideStringFree(bstr); // manual release, and set bstr := nil
|
|
// ! end;
|
|
// !end;
|
|
// - do a regular TrueBSTRWideStringVariable := '' since Delphi 2009, or
|
|
// call the low-level oleaut32.dll API for older versions, as expected by COM
|
|
procedure WideStringFree(var TrueBSTRWideStringVariable: WideString);
|
|
|
|
|
|
implementation
|
|
|
|
{$ifdef UNICODE}
|
|
// since Delphi 2009, use string=UnicodeString type, which features CopyOnWrite
|
|
// -> do not patch anything
|
|
{$define NOOVERRIDE}
|
|
{$endif}
|
|
{$ifdef FPC}
|
|
// our low-level Delphi Win32 specific hack won't work with FPC
|
|
{$define NOOVERRIDE}
|
|
{$endif}
|
|
|
|
{$ifdef NOOVERRIDE}
|
|
|
|
procedure WideStringFree(var TrueBSTRWideStringVariable: WideString);
|
|
begin
|
|
TrueBSTRWideStringVariable := ''; // regular handling via System.pas
|
|
end;
|
|
|
|
{$else}
|
|
|
|
uses
|
|
Windows;
|
|
|
|
{$RANGECHECKS OFF}
|
|
{$STACKFRAMES OFF}
|
|
{$OPTIMIZATION ON}
|
|
{$DEBUGINFO OFF}
|
|
|
|
type // some types here since we do not want any dependency on any other units
|
|
PByteArray = ^TByteArray;
|
|
TByteArray = array[0..MaxInt-1] of byte;
|
|
|
|
// we need to patch the oleaut32.dll library calls as defined in System.pas
|
|
// -> retrieve CALL address from low-level funtions asm, then the API slot
|
|
|
|
function _SysAllocStringLen: pointer;
|
|
asm
|
|
lea eax,System.@WStrFromPWCharLen+8
|
|
end;
|
|
|
|
function _SysReAllocStringLen: pointer;
|
|
asm
|
|
lea eax,System.@WStrAsg+8
|
|
end;
|
|
|
|
function _SysFreeString: pointer;
|
|
asm
|
|
lea eax,System.@WStrClr+8
|
|
end;
|
|
|
|
procedure PatchAPI(source,dest: pointer);
|
|
var RestoreProtection,Ignore: DWORD;
|
|
begin
|
|
while PByte(source)^<>$e8 do // search first CALL within the function code
|
|
inc(PByte(source));
|
|
inc(PByte(source));
|
|
inc(PByte(source),PInteger(source)^+SizeOf(integer)); // go to the CALL stub
|
|
if PWord(source)^<>$25ff then // expect "jmp dword ptr []" asm
|
|
halt;
|
|
inc(PWord(source));
|
|
source := PPointer(source)^; // get "dword ptr []" address of API redirection
|
|
if VirtualProtect(source,SizeOf(source),PAGE_EXECUTE_READWRITE,RestoreProtection) then begin
|
|
PPointer(source)^ := dest; // replace oleaut32.dll API with our own function
|
|
VirtualProtect(source,SizeOf(source),RestoreProtection,Ignore);
|
|
FlushInstructionCache(GetCurrentProcess,source,SizeOf(source));
|
|
end;
|
|
end;
|
|
|
|
|
|
// those are the 3 redirected API calls -> just use AnsiString for allocation
|
|
|
|
function SysAllocStringLen(P: PAnsiChar; Len: integer): pointer; stdcall;
|
|
begin
|
|
result := nil;
|
|
Len := Len*2;
|
|
SetString(AnsiString(result),P,Len);
|
|
PByteArray(result)[Len+1] := 0; // ensure finishes with a #0 WideChar
|
|
end;
|
|
|
|
function SysReAllocStringLen(var S: AnsiString; P: PAnsiChar; Len: integer): LongBool; stdcall;
|
|
begin
|
|
Len := Len*2;
|
|
SetString(S,P,Len);
|
|
PByteArray(S)[Len+1] := 0; // ensure finishes with a #0 WideChar
|
|
result := true;
|
|
end;
|
|
|
|
procedure SysFreeString(S: pointer); stdcall;
|
|
begin
|
|
AnsiString(S) := '';
|
|
end;
|
|
|
|
procedure OleAut32SysFreeString(S: pointer); stdcall;
|
|
external 'oleaut32.dll' name 'SysFreeString'
|
|
|
|
procedure WideStringFree(var TrueBSTRWideStringVariable: WideString);
|
|
begin
|
|
if pointer(TrueBSTRWideStringVariable)<>nil then begin
|
|
OleAut32SysFreeString(pointer(TrueBSTRWideStringVariable));
|
|
pointer(TrueBSTRWideStringVariable) := nil;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
PatchAPI(_SysAllocStringLen,@SysAllocStringLen);
|
|
PatchAPI(_SysReAllocStringLen,@SysReAllocStringLen);
|
|
PatchAPI(_SysFreeString,@SysFreeString);
|
|
|
|
{$endif NOOVERRIDE}
|
|
|
|
end.
|