Is there a way to access (and call) procedures like _CopyArray that are defined in the interface in the unit System?
NB: I am trying to create a routine that makes a deep clone of any dynamic array, and do not use Delphi 2010 (using Delphi 2007).
The reason why I am trying to solve this without using Copy is the fact that I have only a pointer where the dynamic array is located (the pointer that is) plus a typeinfo reference. I cannot call the Copy function because it implicitly needs to fill in the typeinfo.
SOLUTION:
You need to reference it by replacing the _ with an # and scoping it with system.
procedure CopyArray( dest, source, typeInfo: Pointer; cnt: Integer );
asm
PUSH dword ptr [EBP+8]
CALL system.#CopyArray
end;
type
PObject = ^TObject;
function TMessageRTTI.CloneDynArray( Source: Pointer; T: TTypeRecord ): Pointer;
var
TypeInfo: TTypeRecord;
L: Integer;
PObj: PObject;
PArr: PPointer;
begin
Assert( T.TypeKind = tkDynArray );
// set size of array
Result := nil;
L := Length( TIntegerDynArray( Source ) );
if L = 0 then Exit;
DynArraySetLength( Result, T.TypeInfo, 1, #L );
if Assigned( T.TypeData^.elType ) then TypeInfo := ByTypeInfo( T.TypeData^.elType^ ) else TypeInfo := nil;
if Assigned( TypeInfo ) then begin
case TypeInfo.TypeKind of
tkClass: begin
PObj := Result;
while L > 0 do begin
PObj^ := CloneObject( PObject( Source )^ );
Inc( PObject( Source ) );
Inc( PObj );
Dec( L );
end;
end;
tkDynArray: begin
PArr := Result;
while L > 0 do begin
PArr^ := CloneDynArray( PPointer( Source )^, TypeInfo );
Inc( PPointer( Source ) );
Inc( PArr );
Dec( L );
end;
end;
else CopyArray( Result, Source, TypeInfo.TypeInfo, L );
end;
end else begin
// We can simply clone the data
Move( Source^, Result^, L * T.ElementSize );
end;
end;
Like Serg and Andreas said, the _ routines all use compiler magic to provide functionality, so you should use Copy instead of _CopyArray, is instead of _IsClass, etc.
To directly answer your question though, no, there is no way to call those routines from Delphi code in other units. The makefile for the RTL passes an undocumented compiler switch when compiling System.pas and SysInit.pas which tells the compiler to convert any leading _ characters to #. _CopyArray becomes #CopyArray, for example. You can call it using a BASM (assembly) block, but that's it.
The comment by Andreas Rejbrand is actually an answer - the _CopyArray procedure is called automaticaly when you copy complicated arrays. For example, set a breakpoint in _CopyArray and run the following code (should be compiled with debug .dcu to activate the breakpoint):
procedure TForm1.Button4Click(Sender: TObject);
type
TArr2D = array of TBytes;
var
A, B: TArr2D;
begin
A:= TArr2D.Create(TBytes.Create(1, 2, 3), TBytes.Create(4, 5));
B:= Copy(A);
Button4.Caption:= IntToStr(B[1, 1]);
end;
Related
I'm trying to read a .MEM file using Delphi. It's a FoxPro Memory Variable Files. I've tried to read using TFileStream and load into TStringList. But, it only returns the first word.
F := TFileStream.Create(sFile, fmOpenRead);
L := TStringList.Create;
try
F.Position := 0;
L.LoadFromStream(F);
ShowMessage(L.Text);
finally
F.Free;
L.Free;
end;
The reason is because I want to migrate some useful .MEM values from an old program to my new program. Thanks for any help.
If it's a one-time affair and you have access to a VFP installation - i.e. the IDE, not only the runtime - then David Heffernan's suggestion is certainly the most sensible way. In this case you can load and inspect the .MEM via
release all extended && to clear away all existing memvars
restore from foo && assuming the file in question is named FOO.MEM
activate window Locals && inspect the variables...
list memory to foo && or list them to FOO.TXT
modify file foo.txt
However, LIST MEMORY (and DISPLAY MEMORY) also include all the system variables - the things that start with an underscore - which would need to be parsed off.
If it's an ongoing affair - repeated imports necessary - and you know which variables you need then there are two fairly clean and easy ways.
The first is only valid if a VFP IDE is installed on the computer on which the Delphi program is to be run. In this case you can instantiate VFP from Delphi (leave it invisible), have it read the .MEM and then query individual variables:
procedure fetch_variables_from_MEM (mem_filename: string; var_list: CFoos);
var
fox: Variant;
foo: CFoo;
begin
fox := CreateOleObject('VisualFoxpro.Application.9');
try
fox.DoCmd('release all extended');
fox.DoCmd('restore from ' + mem_filename);
for foo in var_list do
foo.Value := fox.Eval('m.' + foo.Name);
finally
fox.Quit; // AutoQuit not supported
end;
end;
I glossed over some details, like that CoInitialize() needs to be called on the thread somewhere before calling this, and I assumed suitable definitions for the variable list (a list/collection of hypothetical CFoo objects), but the sketched outline works - even in 64-bit Delphi.
The advantage is that things like datetime values arrive as TDateTime by virtue of the COM infrastructure and the use of variants.
The second easy way is applicable if an IDE is not available on the machine where the Delphi program is to be used but you have access to an IDE somewhere, so that you can build a small COM server:
define class FoxWrapper as custom olepublic
function Eval (cExpression as string) as variant
return evaluate(m.cExpression)
procedure DoCmd (cCommand as string)
&cCommand
enddefine
This can then be used instead of "VisualFoxPro.Application.9" in the example above. Note: for 64-bit Delphi you need to build this as an out-of-process server (i.e. an EXE). Also, this may run afoul of the VFP licence conditions.
For accessing the data directly, here's some quick & dirty Delphi code that I modelled after some FoxPro stuff that I coded eons ago and updated for VFP9. This is proof-of-principle code with simplified array handling and other compromises for the sake of exposition; it lacks all the production-quality noise necessitated by Delphi's half-assed language definition and its quarter-assed runtime.
type
TMEMVarHeader = packed record
var_name: array [0..10] of AnsiChar;
mem_type: AnsiChar; // 0ACDHLNOQYacdhlnoqy
big_size: UInt32; // only if mem_type == 'H'
width : Byte; // special meaning if mem_type == 'H'
decimals: Byte;
padding : array [0..13] of Byte; // 0 0 0 0 0 0 0 3 0 0 0 0 0 0
end;
SizeOf_TMEMVarHeader_eq_32 = true .. SizeOf(TMEMVarHeader) = 32;
TMEMVarInfo = record
header: TMEMVarHeader;
null_t: AnsiChar;
name : AnsiString;
value : Variant;
function ReadFromStream (stream: TStream): Boolean; // false if EOF
end;
function TMEMVarInfo.ReadFromStream (stream: TStream): Boolean;
const
DELPHI_EPOCH = 2415019.0;
var
header_bytes_read: Integer;
name_length: UInt16;
text_length: UInt32;
array_dim_1: UInt16;
array_dim_2: UInt16;
d: TDate; // 64-bit double
l: Boolean;
n: Double; // 64-bit double
q: array of Byte;
c: AnsiString;
t: TDateTime; // 64-bit double
y: Int64;
binary: Boolean;
i: Cardinal;
a: array of Variant;
v: TMEMVarInfo;
begin
name := ''; value := Unassigned;
header_bytes_read := stream.Read(header, SizeOf(header));
if header_bytes_read <> Sizeof(header) then begin
if not ((header_bytes_read = 1) and (header.var_name[0] = #26)) then
raise Exception.Create('unexpected MEM file format (problem reading header)');
result := false; // EOF
EXIT;
end;
result := true;
// variable name
if header.var_name[0] = #0 then begin // long variable name
assert(header.mem_type = LoCase(header.mem_type));
stream.ReadBuffer(name_length, Sizeof(name_length));
SetLength(name, name_length);
stream.ReadBuffer(name[1], name_length);
end else begin
assert(header.mem_type = UpCase(header.mem_type));
name := header.var_name;
end;
// variable value
case UpCase(header.mem_type) of
'A':
begin
stream.ReadBuffer(array_dim_1, SizeOf(array_dim_1));
stream.ReadBuffer(array_dim_2, SizeOf(array_dim_2));
if array_dim_2 = 0 then // it's a vector, not an array
array_dim_2 := 1;
SetLength(a, array_dim_1 * array_dim_2);
for i := 0 to array_dim_1 * array_dim_2 - 1 do begin
if not v.ReadFromStream(stream) then
raise Exception.Create('error reading array element');
a[i] := v.value;
end;
value := a;
end;
'0': begin stream.ReadBuffer(null_t, 1); value := Null; end;
'C', 'H', 'Q':
begin
if UpCase(header.mem_type) = 'H' then begin // length > 254
binary := header.width <> 0;
text_length := header.big_size;
end else begin
binary := UpCase(header.mem_type) = 'Q';
text_length := header.width;
end;
if binary then begin
SetLength(q, text_length); stream.ReadBuffer(q[0], text_length); value := q;
end else begin
SetLength(c, text_length); stream.ReadBuffer(c[1], text_length); value := c;
end;
end;
'D': begin stream.ReadBuffer(d, Sizeof(d)); if d > 0 then d := d - DELPHI_EPOCH; VarCast(value, d, varDate); end;
'L': begin stream.ReadBuffer(l, Sizeof(l)); value := l; end;
'N': begin stream.ReadBuffer(n, Sizeof(n)); value := n; end;
'T': begin stream.ReadBuffer(t, Sizeof(t)); if t > 0 then t := t - DELPHI_EPOCH; value := t; end;
'Y': begin stream.ReadBuffer(y, Sizeof(y)); VarCast(value, y / 10000.0, varCurrency); end;
else
raise Exception.Create('unexpected type ''' + header.mem_type + ''' in MEM file');
end;
end;
For reading a .MEM, create a TFileStream and a TMEMVarInfo variable, then read variables one by one until var_info.ReadFromStream(stream) returns false.
Note: the byte at offset 19h (shown as 3 in the structure comment) is a code page identifier. The values are the same as those found in .DBF headers, i.e. 1 for DOS 437, 3 for Windows 1252 and so on. However, even though VFP stores these identifiers when writing a .MEM, all the newer versions of VFP that I tested completely ignore these code page marks when loading a .MEM. A self-written importer could put the code page marks to good use, though.
Reading the binary .mem files is not the correct way to proceed. The correct solution is to get VFP to export the data. It knows how to read it. Get VFP to export to a known format, and read that. This is the standard approach to data migration.
With Delphi XE4, try the following code:
procedure TForm3.Button1Click(Sender: TObject);
var
myStr: string;
begin
Edit1.Text := TPerlRegEx.EscapeRegExChars('test');
end;
The result (Edit1.Text) is empty.
Is this a bug or I'm missing something? I previously had no problem with this TPerlRegEx.EscapeRegExChars function with the version from regular-expressions.info pre-DelphiXE.
Update 2: Just upgrading an app written in D2010 and encountering this bug, but just wondering how such an obvious bug can exist this long... now I'm seriously considering making my code compatible to Free Pascal, but I really like the antonymous method...
Update 1: I'm using Delphi XE4 Update 1.
It appears to be a bug. If that's the case, both the XE4 and XE5 versions contain it. I've opened a QC report to report it for XE4..XE6.
The problem appears to be with the last line of the function:
Result.Create(Tmp, 0, J);
Stepping through in the debugger shows that the Tmp (a TCharArray) correctly contains 't','e','s','t', #0, #0, #0, #0 at that point, yet Result contains '' when the function actually returns, as setting a breakpoint on the end; following that line indicates that result contains '' at that point (and when the function returns).
Providing a replacement version in a class helper with a minor change to actually store the return value from the call to Create fixes the problem:
type
TPerlRegExHelper = class helper for TPerlRegEx
public
class function EscapeRegExCharsEx(const S: string): string; static;
end;
class function TPerlRegExHelper.EscapeRegExCharsEx(const S: string): string;
var
I, J: Integer;
Tmp: TCharArray;
begin
SetLength(Tmp, S.Length * 2);
J := 0;
for I := Low(S) to High(S) do
begin
case S[I] of
'.', '[', ']', '(', ')', '?', '*', '+', '{', '}', '^', '$', '|', '\':
begin
Tmp[J] := '\';
Inc(j);
Tmp[J] := S[I];
end;
#0:
begin
Tmp[J] := '\';
Inc(j);
Tmp[J] := '0';
end;
else
Tmp[J] := S[I];
end;
Inc(J);
end;
{ Result.Create(Tmp, 0, J); } // The problem code from the original
Result := String.Create(Tmp, 0, J);
end;
The XE3 (and the open-source version you mention) implement the logic totally differently, using the more standard manipulation of Result beginning at the first line of the function with Result := S;, and then using System.Insert as needed to add room for the escape characters.
This is a bug introduced in the XE4 release that is still present in XE6. Previous versions were fine. It looks like the changes were made in readiness for some future switch to immutable strings.
Rather ironically the bug is caused by the string never being assigned a value at all. It's one thing to set out not to mutate a string, but quite another never to initialize it!
So to the analysis of the bug. The method in question in TPerlRegEx.EscapeRegExChars defined in the System.RegularExpressionsCore unit. This is a class function that returns a string. Its signature is:
class function EscapeRegExChars(const S: string): string;
The XE4 implementation makes but one reference to the result variable. As follows:
Result.Create(Tmp, 0, J);
Here, Tmp is an array of char containing the escaped text to be returned, and J is the length of that text.
So, it seems clear that the author intended for this code to assign to the function return variable Result. Sadly that does not occur. Why not? Well, the Create method being called is defined in the helper for string. This is TStringHelper defined in the System.SysUtils unit. There are three Create overloads and the one in play here is:
class function Create(const Value: array of Char; StartIndex: Integer;
Length: Integer): string; overload; static;
Note that this is a class static function. That means that it is not an instance method and has no Self pointer. So when called like this:
Result.Create(Tmp, 0, J);
It is simply a function call whose return value is ignored. It might appear that the result variable would be set but remember that this Create is a class static method. It therefore has no instance. The compiler simply uses the type of Result to resolve the method. The code is equivalent to:
string.Create(Tmp, 0, J);
Nothing more exciting than a call to a function whose return value is simply ignored. Defeated by the extended syntax that allows us to ignore function return values.
The fix to the code is simple enough. Replace that final line with
Result := string.Create(Tmp, 0, J);
You could apply the fix in a copy of the unit, and include that unit in your code. An alternative to that, my preferred option, is to use a code hook. Like this:
unit FixTPerlRegExEscapeRegExChars;
interface
implementation
uses
System.SysUtils, Winapi.Windows, System.RegularExpressionsCore;
procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
OldProtect: DWORD;
begin
if VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then
begin
Move(NewCode, Address^, Size);
FlushInstructionCache(GetCurrentProcess, Address, Size);
VirtualProtect(Address, Size, OldProtect, #OldProtect);
end;
end;
type
PInstruction = ^TInstruction;
TInstruction = packed record
Opcode: Byte;
Offset: Integer;
end;
procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
NewCode: TInstruction;
begin
NewCode.Opcode := $E9;//jump relative
NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;
function EscapeRegExChars(Self: TPerlRegEx; const S: string): string;
var
I, J: Integer;
Tmp: TCharArray;
begin
SetLength(Tmp, S.Length * 2);
J := 0;
for I := Low(S) to High(S) do
begin
case S[I] of
'.', '[', ']', '(', ')', '?', '*', '+', '{', '}', '^', '$', '|', '\':
begin
Tmp[J] := '\';
Inc(j);
Tmp[J] := S[I];
end;
#0:
begin
Tmp[J] := '\';
Inc(j);
Tmp[J] := '0';
end;
else
Tmp[J] := S[I];
end;
Inc(J);
end;
Result := string.Create(Tmp, 0, J);
end;
initialization
RedirectProcedure(#TPerlRegEx.EscapeRegExChars, #EscapeRegExChars);
end.
Add this unit to your project and the calls to TPerlRegEx.EscapeRegExChars will start working again.
{$APPTYPE CONSOLE}
uses
System.RegularExpressionsCore,
FixTPerlRegExEscapeRegExChars in 'FixTPerlRegExEscapeRegExChars.pas';
begin
Writeln(TPerlRegEx.EscapeRegExChars('test'));
Readln;
end.
Output
test
QC#124091
it works on 32-bit platform.but not 64-bit
here is the exzample
TVerbInfo = packed record
Verb: Smallint;
Flags: Word;
end;
var
VerbInfo: TVerbInfo;
strList : TStringList;
verb : Smallint;
flags : Word;
begin
strList := TStringList.create();
.....
verbInfo.verb := verb;
verbInfo.flags := flags;
strList.addObject('verb1',TObject(VerbInfo)); //invalid typecast happened here
end;
can anyone help me? thank you very much
You can try something like this:
function MakeVerbInfoObject(const AVerbInfo: TVerbInfo): TObject;
begin
Result := nil;
Move(AVerbInfo, Result, SizeOf(AVerbInfo));
end;
strList.addObject('verb1', MakeVerbInfoObject(VerbInfo));
Your cast TObject(VerbInfo) will compile provided that SizeOf(TObject) = SizeOf(TVerbInfo). But TObject is a pointer and so its size varies with architecture. On the other hand, SizeOf(TVerbInfo) does not vary with architecture. Hence the cast can only work on one architecture.
Using casts like this is how you had to do things in pre-generics Delphi. But nowadays, you should be using generic containers.
For instance, if you have a list and the strings are unique then you can use a dictionary:
TDictionary<string, TVerbInfo>
If it is possible for there to be duplicate strings then you would need a new record declaration:
type
TVerbInfo = record
Name: string
Verb: Integer;
Flags: Word;
end;
And then store a list of these in
TList<TVerbInfo>
One final point is that you should avoid using packed records. These result in mis-aligned data structures and that in turn leads to poor performance.
I think you have to run this on different platforms and compare results
ShowMessage( IntToStr( SizeOf( Integer ) ) );
ShowMessage( IntToStr( SizeOf( Pointer ) ) );
ShowMessage( IntToStr( SizeOf( TVerbInfo ) ) );
ShowMessage( IntToStr( SizeOf( TObject ) ) );
I suspect you cannot do a hardcast, because the sizes differ.
You may try to use workarounds like
type TBoth = record
case byte of
0: ( rec: TVerbInfo);
1: ( obj: TObject);
end;
You can also try to use TDictionary<String, TVerbInfo> type instead of TStringList
When I attempt to compile a pascal unit for Win64 platform, I encounter errors. The methods contain ASM block. I have no ideas how to make it works for Win64 platform:
Method 1:
Function TSparseList.ForAll( ApplyFunction: Pointer {TSPAApply} ): Integer; Assembler;
Asm
MOV EAX,[EAX].TSparseList.FList
JMP TSparsePointerArray.ForAll
End;
Method 2:
Function TSparsePointerArray.ForAll( ApplyFunction: Pointer {TSPAApply} ):
Integer;
Var
itemP: PAnsiChar; { Pointer to item in section } { patched by ccy }
item: Pointer;
i, callerBP: Cardinal;
j, index: Integer;
Begin
{ Scan section directory and scan each section that exists,
calling the apply function for each non-nil item.
The apply function must be a far local function in the scope of
the procedure P calling ForAll. The trick of setting up the stack
frame (taken from TurboVision's TCollection.ForEach) allows the
apply function access to P's arguments and local variables and,
if P is a method, the instance variables and methods of P's class '}
Result := 0;
i := 0;
Asm
mov eax,[ebp] { Set up stack frame for local }
mov callerBP,eax
End;
While ( i < slotsInDir ) And ( Result = 0 ) Do
Begin
itemP := secDir^[i];
If itemP <> Nil Then
Begin
j := 0;
index := i Shl SecShift;
While ( j < FSectionSize ) And ( Result = 0 ) Do
Begin
item := PPointer( itemP )^;
If item <> Nil Then
{ ret := ApplyFunction(index, item.Ptr); }
Asm
mov eax,index
mov edx,item
push callerBP
call ApplyFunction
pop ecx
mov #Result,eax
End;
Inc( itemP, SizeOf( Pointer ) );
Inc( j );
Inc( index )
End
End;
Inc( i )
End;
End;
I'm not familiar with the particulars of x64 instructions, so I can't help with rewriting the assembly code to support 64-bit, but I can tell you that Embarcadero's 64-bit compiler does not currently allow you to mix Pascal and Assembly in the same function. You can only write all-Pascal or all-Assembly functions, no mixing at all (a Pascal function can call an Assembly function and vice versa, but they cannot coexist together like in x86). So you will have to rewrite your methods.
You may be able to rewrite the whole method in x64 ASM. As Remy told, you'll need to rewrite the whole method, since you can't nest some asm .. end blocks within begin .. end.
The real issue is that calling conventions are not the same in Win32 and Win64 mode. Registers changes (i.e. they are 64 bit and now shall include SSE2 registers), but the main problem is about the fact that your call re-injector shall know the number of parameters: some space must be allocated on the stack for every parameter.
If your TSPAApply function has a number of fixed parameters, you could convert it to a plain pascal version - which is safer than everything.
type
TSPAApply = function(index: integer; item: pointer);
Function TSparseList.ForAll( ApplyFunction: Pointer {TSPAApply} ): Integer;
begin
result := FList.ForAll(ApplyFunction);
End;
Function TSparsePointerArray.ForAll( ApplyFunction: Pointer {TSPAApply} ):
Integer;
Var
itemP: PPointer;
i: Cardinal;
j, index: Integer;
Begin
Result := 0;
i := 0;
While ( i < slotsInDir ) And ( Result = 0 ) Do
Begin
itemP := secDir^[i];
If itemP <> Nil Then
Begin
j := 0;
index := i Shl SecShift;
While ( j < FSectionSize ) And ( Result = 0 ) Do
Begin
If itemP^ <> Nil Then
result := TSPAApply(ApplyFunction)(index,itemP^.Ptr);
Inc( itemP );
Inc( j );
Inc( index )
End
End;
Inc( i )
End;
End;
But you should better rely on a TMethod list, for a more generic OOP way of doing it. Some code refactoring would be a good idea, here.
Try
Function TSparseList.ForAll( ApplyFunction: Pointer {TSPAApply} ): Integer; Assembler;
Asm
MOV RAX,[RAX].TSparseList.FList
JMP TSparsePointerArray.ForAll
End;
Pointers are 64-bit on x64, so will occupy a full 64-bit register.
The "A" register is AL/AX/EAX/RAX for 8/16/32/64-bits respectively.
For the second function, I'd need to know more about the function being called in the asm block.
Is there a way to assign a multiline string value in Delphi without having to quote each line?
Edit (the specific problem): I have some SQL queries which I want to test outside Delphi. When copying the queries it is a bit of overhead to add and replace quotes every time.
Here's code for an application you can add to the IDE's Tools menu that might help. It was posted a while back to one of the CodeGear newsgroups by TeamB member Peter Below:
program ClipToStringConst;
// Remove the dot from the line below for a console app,
// per Rob Kennedy's comment. It works fine without being
// a console app.
{.$APPTYPE CONSOLE}
uses
Windows,
Classes,
Sysutils,
APIClipboard;
const
cIndent = ' '; // 2 spaces
cSingleQuote = '''';
EndChar : array [Boolean] of Char = ('+',';');
procedure Process;
var
SL: TStringlist;
i, max: Integer;
begin
if ClipboardHasFormat( CF_TEXT ) then
begin
SL := TStringlist.Create;
try
SL.Text := ClipboardAsString;
max := SL.count-1;
for i:= 0 to max do
SL[i] := cIndent +
AnsiQuotedStr( TrimRight(SL[i])+#32, cSingleQuote ) +
EndChar[i = max];
StringToClipboard( SL.Text );
finally
SL.Free;
end; { Finally }
end;
end;
begin
try
Process;
except
on E: Exception do
ShowException( E, ExceptAddr );
end;
end.
Just select the text in the SQL management tool after you've tested it and copy it to the clipboard. Switch to the Delphi Code Editor, place the insertion point where you want the constant text to appear, choose 'Clipboard To Const' or whatever you called it from the Tools menu, and then Ctrl+V to paste it into the editor.
It's a pretty handy little tool. You can also modify it to work the opposite way (ConstantToClipboard) to remove the source formatting and revert back to raw SQL, although I haven't bothered to do so yet.
EDIT: Missed a unit (APIClipboard). This needs to be a separate unit, obviously. Again, thanks to Peter Below:
{== Unit APIClipboard =================================================}
{: Clipboard access routines using only API functions
#author Dr. Peter Below
#desc Version 1.0 created 5 Juli 2000<BR>
Current revision 1.0<BR>
Last modified 5 Juli 2000<P>
This unit provides simply clipboard access routines that do not rely on
the VCL Clipbrd unit. That unit drags in Dialogs and Forms and a major
part of the VCL as a consequence, not appropriate for simple console
or non-form programs. This unit uses only API routines, the only VCL
units used are Classes (for exceptions and streams) and SysUtils.
}
{=====================================================================}
unit APIClipboard;
interface
uses
Windows, Classes;
procedure StringToClipboard( const S: String );
function ClipboardAsString: String;
procedure CopyDataToClipboard( fmt: DWORD; const data; datasize: Integer;
emptyClipboardFirst: Boolean = true );
procedure CopyDataFromClipboard( fmt: DWORD; S: TStream );
function ClipboardHasFormat( fmt: DWORD ): Boolean;
implementation
uses
Sysutils;
type
{: This is an internal exception class used by the <see unit=APIClipboard> }
EClipboardError = class( Exception )
public
constructor Create( const msg: String );
end;
resourcestring
eSystemOutOfMemory =
'could not allocate memory for clipboard data.';
eLockfailed =
'could not lock global memory handle.';
eSetDataFailed =
'could not copy data block to clipboard.';
eCannotOpenClipboard =
'could not open the clipboard.';
eErrorTemplate =
'APIClipboard: %s'#13#10+
'System error code: %d'#13#10+
'System error message: %s';
{-- EClipboardError.Create --------------------------------------------}
{: Creates a new EclipboardError object
#Param msg is the string to embed into the error message
#Precondition none
#Postcondition none
#desc Composes an error message that contains the passed message and the
API error code and matching error message. The CreateFmt constructor
inherited from the basic Exception class is used to do the work.
Created 5.7.2000 by P. Below
}{---------------------------------------------------------------------}
constructor EClipboardError.Create( const msg: String );
begin { Create }
CreateFmt( eErrorTemplate,
[msg, GetLastError, SysErrorMessage(GetLastError)] );
end; { EClipboardError.Create }
{-- DataToClipboard ---------------------------------------------------}
{: Copies a block of memory to the clipboard in a given format
#Param fmt is the clipboard format to use
#Param data is an untyped const parameter that addresses the data to copy
#Param datasize is the size of the data, in bytes
#Precondition The clipboard is already open. If not an EClipboardError
will result. This precondition cannot be asserted, unfortunately.
#Postcondition Any previously exisiting data of this format will have
been replaced by the new data, unless datasize was 0 or we run into an
exception. In this case the clipboard will be unchanged.
#desc Uses API methods to allocate and lock a global memory block of
approproate size, copies the data to it and submits the block to the
clipboard. Any error on the way will raise an EClipboardError
exception.<BR>
Created 5.7.2000 by P. Below
#Raises EClipboardError
}{---------------------------------------------------------------------}
procedure DataToClipboard( fmt: DWORD; Const data; datasize: Integer );
var
hMem: THandle;
pMem: Pointer;
begin { DataToClipboard }
if datasize <= 0 then
Exit;
hMem := GlobalAlloc( GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, datasize );
if hmem = 0 then
raise EClipboardError.Create( eSystemOutOfMemory );
pMem := GlobalLock( hMem );
if pMem = nil then
begin
GlobalFree( hMem );
raise EClipboardError.Create( eLockFailed );
end;
Move( data, pMem^, datasize );
GlobalUnlock( hMem );
if SetClipboardData( fmt, hMem ) = 0 then
raise EClipboardError( eSetDataFailed );
// Note: API docs are unclear as to whether the memory block has
// to be freed in case of failure. Since failure is unlikely here
// lets blithly ignore this issue for now.
end; { DataToClipboard }
{-- DataFromClipboard -------------------------------------------------}
{: Copies data from the clipboard into a stream
#Param fmt is the clipboard format to look for
#Param S is the stream to copy to
#precondition S <> nil
#postcondition If data was copied the streams position will have moved
#desc Tries to get a memory block for the requested clipboard format.
Nothing
further is done if this fails (because the format is not available or
the clipboard is not open, we treat neither as error here), otherwise
the memory handle is locked and the data copied into the stream. <P>
Note that we cannot determine the actual size of the data originally
copied to the clipboard, only the allocated size of the memory block!
Since GlobalAlloc works with a granularity of 32 bytes the block may be
larger than required for the data and thus the stream may contain some
spurious bytes at the end. There is no guarantee that these bytes will
be 0. <P>
If the memory handle obtained from the clipboard cannot be locked we
raise an <see class=EClipboardError> exception.
Created 5.7.2000 by P. Below
#Raises EClipboardError
}{---------------------------------------------------------------------}
procedure DataFromClipboard( fmt: DWORD; S: TStream );
var
hMem: THandle;
pMem: Pointer;
datasize: DWORD;
begin { DataFromClipboard }
Assert( Assigned( S ));
hMem := GetClipboardData( fmt );
if hMem <> 0 then
begin
datasize := GlobalSize( hMem );
if datasize > 0 then
begin
pMem := GlobalLock( hMem );
if pMem = nil then
raise EclipboardError.Create( eLockFailed );
try
S.WriteBuffer( pMem^, datasize );
finally
GlobalUnlock( hMem );
end;
end;
end;
end; { DatafromClipboard }
{-- CopyDataToClipboard -----------------------------------------------}
{: Copies a block of memory to the clipboard in a given format
#Param fmt is the clipboard format to use
#Param data is an untyped const parameter that addresses the data to copy
#Param datasize is the size of the data, in bytes
#Param emptyClipboardFirst determines if the clipboard should be emptied,
true by default
#Precondition The clipboard must not be open already
#Postcondition If emptyClipboardFirst is true all prior data will be
cleared from the clipboard, even if datasize is <= 0. The clipboard
is closed again.
#desc Tries to open the clipboard, empties it if required and then tries to
copy the passed data to the clipboard. This operation is a NOP if
datasize <= 0. If the clipboard cannot be opened a <see
class=EClipboardError>
is raised.
Created 5.7.2000 by P. Below
#Raises EClipboardError
}{---------------------------------------------------------------------}
procedure CopyDataToClipboard( fmt: DWORD; const data; datasize: Integer;
emptyClipboardFirst: Boolean = true );
begin { CopyDataToClipboard }
if OpenClipboard( 0 ) then
try
if emptyClipboardFirst then
EmptyClipboard;
DataToClipboard( fmt, data, datasize );
finally
CloseClipboard;
end
else
raise EclipboardError.Create( eCannotOpenClipboard );
end; { CopyDataToClipboard }
{-- StringToClipboard -------------------------------------------------}
{: Copies a string to clipboard in CF_TEXT clipboard format
#Param S is the string to copy, it may be empty.
#Precondition The clipboard must not be open already.
#Postcondition Any prior clipboard content will be cleared, but only
if S was not empty. The clipboard is closed again.
#desc Hands the brunt of the work off to <See routine=CopyDataToClipboard>,
but only if S was not empty. Otherwise nothing is done at all.<BR>
Created 5.7.2000 by P. Below
#Raises EClipboardError
}{---------------------------------------------------------------------}
procedure StringToClipboard( const S: String );
begin
if Length(S) > 0 Then
CopyDataToClipboard( CF_TEXT, S[1], Length(S)+1);
end; { StringToClipboard }
{-- CopyDataFromClipboard ---------------------------------------------}
{: Copies data from the clipboard into a stream
#Param fmt is the clipboard format to look for
#Param S is the stream to copy to
#Precondition S <> nil<P>
The clipboard must not be open already.
#Postcondition If data was copied the streams position will have moved.
The clipboard is closed again.
#desc Tries to open the clipboard, and then tries to
copy the data to the passed stream. This operation is a NOP if
the clipboard does not contain data in the requested format.
If the clipboard cannot be opened a <see class=EClipboardError>
is raised.
Created 5.7.2000 by P. Below
#Raises EClipboardError
}{---------------------------------------------------------------------}
procedure CopyDataFromClipboard( fmt: DWORD; S: TStream );
begin { CopyDataFromClipboard }
Assert( Assigned( S ));
if OpenClipboard( 0 ) then
try
DataFromClipboard( fmt , S );
finally
CloseClipboard;
end
else
raise EclipboardError.Create( eCannotOpenClipboard );
end; { CopyDataFromClipboard }
{-- ClipboardAsString -------------------------------------------------}
{: Returns any text contained on the clipboard
#Returns the clipboards content if it contained something in CF_TEXT
format, or an empty string.
#Precondition The clipboard must not be already open
#Postcondition The clipboard is closed.
#desc If the clipboard contains data in CF_TEXT format it is copied to a
temp memory stream, zero-terminated for good measure and copied into
the result string.
Created 5.7.2000 by P. Below
#Raises EClipboardError
}{---------------------------------------------------------------------}
function ClipboardAsString: String;
const
nullchar: Char = #0;
var
ms: TMemoryStream;
begin { ClipboardAsString }
if not IsClipboardFormatAvailable( CF_TEXT ) then
Result := EmptyStr
else
begin
ms:= TMemoryStream.Create;
try
CopyDataFromClipboard( CF_TEXT , ms );
ms.Seek( 0, soFromEnd );
ms.WriteBuffer( nullChar, Sizeof( nullchar ));
Result := PChar( ms.Memory );
finally
ms.Free;
end;
end;
end; { ClipboardAsString }
{-- ClipboardHasFormat ------------------------------------------------}
{: Checks if the clipboard contains data in the specified format
#Param fmt is the format to check for
#Returns true if the clipboard contains data in this format, false
otherwise
#Precondition none
#Postcondition none
#desc This is a simple wrapper around an API function.
Created 5.7.2000 by P. Below
}{---------------------------------------------------------------------}
function ClipboardHasFormat( fmt: DWORD ): Boolean;
begin { ClipboardHasFormat }
Result := IsClipboardFormatAvailable( fmt );
end; { ClipboardHasFormat }
end.
Sample use:
Prepare the text in your SQL editor, text editor, or whatever:
SELECT
lname,
fname,
dob
FROM
employees
Select all of the text, and copy to the clipboard using Ctrl+C.
Switch to the IDE's Code Editor, run the ClipboardToStringConst application (using the Tools menu item you added, or whatever other means you want). Place the editor's cursor (insertion point) where you want the constant text to appear, and press Ctrl+V to paste in the text.
const
MySQLText = | // The pipe indicates the insertion point.
The result:
const
MySQLText = 'SELECT '+
' lname, '+
' fname, '+
' dob '+
'FROM '+
' employees ';
You mean something like this?
myStr := 'first line'#13#10'secondline'#13#10'thirdline';
We had the same problem, and finally we created a small IDE plugin (merged with existing solutions). That creates two extra menu items (Copy and Paste extra). One of this pastes the formatted content of the clipboard to the code editor, the other does the same thing in reverse (copy the content of the selection to the clipboard and removes the extra charachters).
To use this:
Create new Package in Delphi
Add to "designide" to requires section (and remove anything else)
Create new Unit, and copy the code
Build and Install
Sample code:
unit ClipboardWizard;
interface
uses
Windows, SysUtils, Classes, ToolsAPI,
{$ifdef VER280} // XE7
VCL.Menus
{$else}
Menus
{$endif};
type
TClipboardWizard = class(TInterfacedObject, IOTAWizard)
private
FMainMenuItem, FCopyMenuItem, FPasteMenuItem: TMenuItem;
// Formatting
function GetFormattedString: string;
function RemoveUnneededChars(const Value: string): string;
// Menu events
procedure CopyToClipboard(Sender: TObject);
procedure PasteFromClipboard(Sender: TObject);
public
// TObject
constructor Create;
destructor Destroy; override;
// IOTANotifier
procedure AfterSave;
procedure BeforeSave;
procedure Destroyed;
procedure Modified;
// IOTAWizard
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
procedure Execute;
end;
procedure Register;
implementation
uses
Vcl.Clipbrd, System.StrUtils;
procedure Register;
begin
RegisterPackageWizard(TClipboardWizard.Create);
end;
// Formatting
function TClipboardWizard.RemoveUnneededChars(const Value: string): string;
var
List: TStringList;
q: integer;
s : string;
begin
if Trim(Value) <> '' then
begin
List := TStringList.Create;
try
List.Text := Value;
for q := 0 to List.Count - 1 do
begin
s := Trim(List[q]);
if Length(s) > 0 then
if s[1] = '''' then
s := Copy(s, 2, Length(s));
s := TrimLeft(ReverseString(s));
if Length(s) > 0 then
if s[1] = '+' then
s := TrimLeft(Copy(s, 2, Length(s)));
if Length(s) > 0 then
if s[1] = ';' then
s := TrimLeft(Copy(s, 2, Length(s)));
if Length(s) > 0 then
if s[1] = '''' then
s := TrimLeft(Copy(s, 2, Length(s)));
s := StringReplace(s, '''''', '''', [rfReplaceAll]);
List[q] := ReverseString(s)
end;
Result := List.Text;
finally
List.Free;
end;
end
else
Result := '';
end;
procedure TClipboardWizard.CopyToClipboard(Sender: TObject);
begin
with BorlandIDEServices as IOTAEditorServices do
if Assigned(TopView) then
Clipboard.AsText := RemoveUnneededChars(TopView.Block.Text);
end;
function TClipboardWizard.GetFormattedString: string;
const
FSingleQuote = '''';
Indent: array [boolean] of string = (' ', '');
EndChar: array [boolean] of string = (' +', ';');
var
List: TStringlist;
q: Integer;
begin
if Clipboard.HasFormat(CF_TEXT) then
begin
List := TStringlist.Create;
try
List.Text := Clipboard.AsText;
for q := 0 to List.Count - 1 do
List[q] := Indent[q <> 0] + AnsiQuotedStr(TrimRight(List[q]) + #32, FSingleQuote) +
EndChar[q = (List.Count - 1)];
Result := List.Text;
finally
List.Free;
end;
end;
end;
procedure TClipboardWizard.PasteFromClipboard(Sender: TObject);
begin
with BorlandIDEServices as IOTAEditorServices do
if Assigned(TopView) then
begin
TopView.Buffer.EditPosition.InsertText(GetFormattedString);
TopView.Paint; // invalidation
end;
end;
{ Anything else }
constructor TClipboardWizard.Create;
var
NTAServices : INTAServices;
begin
NTAServices := BorlandIDEServices as INTAServices;
// Main Menu
FMainMenuItem := TMenuItem.Create(nil);
FMainMenuItem.Caption := 'Clibrd Extra' ;
NTAServices.MainMenu.Items.Add(FMainMenuItem);
// Sub Menus
FCopyMenuItem := TMenuItem.Create(nil);
FCopyMenuItem.Caption := 'Copy to clipboard';
FCopyMenuItem.OnClick := Self.CopyToClipboard;
FMainMenuItem.Add(FCopyMenuItem);
FPasteMenuItem := TMenuItem.Create(nil);
FPasteMenuItem.Caption := 'Paste from clipboard';
FPasteMenuItem.OnClick := Self.PasteFromClipboard;
FMainMenuItem.Add(FPasteMenuItem);
end;
destructor TClipboardWizard.Destroy;
begin
if Assigned(FPasteMenuItem) then
FreeAndNil(FPasteMenuItem);
if Assigned(FCopyMenuItem) then
FreeAndNil(FCopyMenuItem);
if Assigned(FMainMenuItem) then
FreeAndNil(FMainMenuItem);
inherited;
end;
{ IOTANotifier }
procedure TClipboardWizard.AfterSave;
begin
end;
procedure TClipboardWizard.BeforeSave;
begin
end;
procedure TClipboardWizard.Destroyed;
begin
end;
procedure TClipboardWizard.Modified;
begin
end;
{ IOTAWizard }
function TClipboardWizard.GetIDString: string;
begin
Result := 'Clipboard.Wizard7';
end;
function TClipboardWizard.GetName: string;
begin
Result := 'Clipboard Wizard7';
end;
function TClipboardWizard.GetState: TWizardState;
begin
Result := [];
end;
procedure TClipboardWizard.Execute;
begin
end;
end.
I know the code is not perfect, but it works :-)
You could consider putting your SQL in TQuery components on Forms or Data Modules.
This solves the copy/paste problem, but it introduces others (such as the diffs between two versions of a query being worse).
You can't define a string on multiple lines without the quotes:
const
myString = 'this is a long string that extends' +
'to a second line';
Although, you can make a string out of control characters like:
const
myString = #83#84#82#73#78#71;
But that does not attribute to readble code.
In versions of Delphi >= 2007, if you are entering a quoted string over multiple lines it will automatically add a closing quote and + ' on the next line if you don't close the quote yourself.
It's not a solution to the problem but it does help speed up typing in long strings.
The short answer is no, it can't be done. (I know that is not what you want to hear.)
However Andreas Hausladen did develop an extension capable of just this. I googled for it but couldn't find it. I think it was in his DLangExtensions pack, of which he dropped support in late 2007 already. :(
I'm surprised no one's mentioned resources. Although a pain to implement the first time, once you've done it once you can implement retrieving long multiline strings from files without too much trouble. Random instructions I found here: http://www.delphibasics.info/home/delphibasicssnippets/usingresourcefileswithdelphi
With GExperts:
enable GExperts -> Editor Experts -> Paste Strings As
assign a shortcut
I am late to Party, but if GExperts i no Option:
Fast Solution: Use IDE Macro Recorder...
copy text (start recording SHIFT + STRG + R)
Press [Pos1] ['] [End] [' + sLineBreak +] [change line to one down]
(stop recording SHIFT + STRG + R)
(replay Key Strokes SHIFT + STRG + P) repeat until last line ... delete the + which is too much ...
Partially finished;
The Escaping of ' for Strings is not done this way ...