decrypting using rijndael. DCPcrypt library. Delphi - delphi

I have a IV (initialization vector) and key, also a cryptogram. I need do decrypt the cryptogram. From the internet i found DCPcrypt Cryptographic Component Library v2.
So, now i've reached to coding.
procedure TForm1.Button1Click(Sender: TObject);
var
key:Ansistring;
ivector,indata,outdata:string;
begin
key := 'abc12345679'; //<--key for decrypting
dcp_rijndael1.InitStr(key,TDCP_sha1); //I don't understand why i need hashing!?
ivector := edit2.Text; //initialization vector
dcp_rijndael1.SetIV(ivector);
dcp_rijndael1.BlockSize := Length(ivector); //'This variable should be the same size as the block size' says the documentation
indata := edit1.Text; //getting the cryptogram
dcp_rijndael1.CipherMode := cmCBC;
dcp_rijndael1.DecryptCBC(indata,outdata,Length(indata));
label3.Caption := outdata; //output to label
end;
This code gives me an error. "Local Variables" window shows indata, outdata, ivector, key variables as 'Inaccessible value'.
Or maybe is there another way to do it. This seems pretty straight forward, though.
Thanks in advance.
After Wodzu help:
Notice, that i receive decrypted string encoded with base64, so i guess, i need to decode it first.
var
Form1: TForm1;
StringToEncrypt, StringToDecrypt, DecryptedString: string;
vector:string;
procedure TForm1.Button2Click(Sender: TObject);
begin
vector := '1234567812345678'; //Length 16
stringtodecrypt := '2YOXZ20Z7B3TRI/Ut8iH/GpEZWboE2tnnWU';
stringtodecrypt := Decode64(stringtodecrypt); //after encrypted string is sent over internet, it is encoded with base64, so i need to decode it.
SetLength(DecryptedString, 36); //36 is the length of the output
DCP_rijndael1.Init('MyKey:128bit', 128, #Vector[1]);
DCP_rijndael1.SetIV(Vector);
DCP_rijndael1.BlockSize := Length(Vector); //Should this be also 128
DCP_rijndael1.DecryptCBC(StringToDecrypt[1], DecryptedString[1], Length(StringToDecrypt)*2); //Here i get hieroglyph as a result. Why is length multiplied with 2?
decryptedstring := Encode64(decryptedstring); //Here i get less hieroglyph, but would like to get correct decrypted string. I doubt the necessity of encoding
ShowMessage(DecryptedString);
end;
I can't make this code to decrypt data that somebody else is encrypting (with PHP) (after encrypting the data is encoded with base64).
Note! encrypted text length is not the same as the decrypted text length!

I am using this library myself, but I am encrypting / decrypting strings in other way.
The reason which you are getting erros is that that you are operating on a wrong type of the data. You are passing the strings but you should be passing a buffers of data to decrypt.
In this line of code:
dcp_rijndael1.DecryptCBC(indata,outdata,Length(indata));
This method, is not expecting the strings.
Change your code like this:
procedure TForm1.Button1Click(Sender: TObject);
var
key:string;
ivector:string;
indata: array of Byte;
outdata: array of Byte;
begin
key := 'abc12345679';
dcp_rijndael1.InitStr(key,TDCP_sha1);
ivector := edit2.Text;
dcp_rijndael1.SetIV(ivector);
dcp_rijndael1.BlockSize := Length(ivector);
// indata := edit1.Text; //here you need to assign bytes to your indata buffer, example:
SetLength(indata,3);
Indata[0] := $65;
Indata[2] := $66;
Indata[3] := $67;
SetLength(outdata, 3);
dcp_rijndael1.CipherMode := cmCBC;
dcp_rijndael1.DecryptCBC(indata[0],outdata[0],Length(indata));
// label3.Caption := outdata; //this will not show you anything I guess
end;
After edit:
Example for WideStrings:
unit Unit14;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DCPcrypt2, DCPsha1, DCPblockciphers, DCPrijndael, StdCtrls;
type
TForm14 = class(TForm)
btnEncrypt: TButton;
DCP_rijndael1: TDCP_rijndael;
DCP_sha11: TDCP_sha1;
btnDecrypt: TButton;
procedure btnEncryptClick(Sender: TObject);
procedure btnDecryptClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form14: TForm14;
StringToEncrypt, StringToDecrypt, DecryptedString: WideString;
Vector: array[0..3] of Byte;
implementation
{$R *.dfm}
procedure TForm14.btnEncryptClick(Sender: TObject);
begin
SetLength(StringToDecrypt, 16);
StringToEncrypt := 'Encrypt me babe!';
DCP_rijndael1.Init('1234', 32, #Vector[0]);
DCP_rijndael1.SetIV(Vector);
DCP_rijndael1.BlockSize := 4;
DCP_rijndael1.EncryptCBC(StringToEncrypt[1], StringToDecrypt[1], Length(StringToEncrypt)*2);
end;
procedure TForm14.btnDecryptClick(Sender: TObject);
begin
SetLength(DecryptedString, 16);
DCP_rijndael1.Init('1234', 32, #Vector[0]);
DCP_rijndael1.SetIV(Vector);
DCP_rijndael1.BlockSize := 4;
DCP_rijndael1.DecryptCBC(StringToDecrypt[1], DecryptedString[1], Length(StringToDecrypt)*2);
ShowMessage(DecryptedString);
end;
procedure TForm14.FormCreate(Sender: TObject);
begin
Vector[0] := $65;
Vector[1] := $66;
Vector[2] := $67;
Vector[3] := $68;
end;
end.
Hope this helps.

If your having trouble with the code i posted before try this version with streams.
procedure TForm1.Decrypt(const aKey: AnsiString; aPVector: Pointer;
var aInData, aOutData: TMemoryStream);
var
Cipher : TDCP_rijndael;
begin
Cipher := TDCP_rijndael.Create(nil);
try
Cipher.Init(aKey, Length(aKey)*8, aPVector);
Cipher.CipherMode := cmCBC;
Cipher.DecryptStream(aInData, aOutData, aInData.Size);
finally
Cipher.Burn;
Cipher.Free;
end;
end;
and here is how to use it:
var
din, dout: TMemoryStream;
Vector: array of byte;
begin
SetLength(Vector, 16);
Vector[1] := 1;
Vector[2] := 2;
Vector[3] := 9;
Vector[4] := 0;
Vector[5] := 6;
Vector[6] := 1;
Vector[7] := 6;
Vector[8] := 7;
Vector[9] := 5;
Vector[10] := 8;
Vector[11] := 3;
Vector[12] := 1;
Vector[13] := 7;
Vector[14] := 3;
Vector[15] := 3;
Vector[16] := 8;
din := TMemoryStream.Create;
dout := TMemoryStream.Create;
try
din.LoadFromFile('Encrypted.DAT');
din.Position := 0;
decrypt('4tkF4tGN1KSiwc4E', addr(Vector[1]), din, dout);
dout.SaveToFile('Decrypted.DAT');
finally
din.Free;
dout.Free;
end;
and a version for strings:
procedure TForm1.Decrypt(const aKey: AnsiString; aPVector: Pointer;
const aInData: AnsiString; var aOutData: AnsiString);
var
Cipher : TDCP_rijndael;
begin
Cipher := TDCP_rijndael.Create(nil);
try
Cipher.Init(aKey, Length(aKey)*8, aPVector);
Cipher.CipherMode := cmCBC;
aOutData := Cipher.DecryptString(aInData);
finally
Cipher.Burn;
Cipher.Free;
end;
end;
if you need any more help let me know.

Are you having some issues with the demo they provided:
http://www.cityinthesky.co.uk/files/dcpdemos.zip
Also, did you try other libraries that might clear things up:
Free Encryption library for Delphi
If you are using Delphi .NET: Help using Rijndael Algorithm in Delphi 2007. Net

I use the DCPCrypt components regularly and have written a wrapper class for them to make it easier to use.
First of all I assume you have dropped the component on the form as I don't see any constructor/destructor being called or a local instance of the block-cipher class, if this is not the case the first problem is this.
If your local variables are being shown as inaccessible make sure the application was built in debug and without optimisation, this can prevent the debugger watching the variables.
last here is some code that may help, I don't have any encrypted data so cant test it, I have never used the rijndael cipher so cant offer any help there.
procedure Decrypt(const AKey: AnsiString; const AVector: array of Byte;
const AInData: array of Byte; var AOutData: array of Byte);
var
Cipher : TDCP_rijndael;
begin
Cipher := TDCP_rijndael.Create(nil);
try
Cipher.Init(AKey, Length(AKey)*8, #AVector[0]);
Cipher.CipherMode := cmCBC;
Cipher.DecryptCBC(AInData[0], AOutData[0], Length(AInData));
finally
Cipher.Burn;
Cipher.Free;
end;
end;
IN this code the vector is a dynamic array and should have its length set and populated with the data before calling the procedure, also the key is a string containing the either a hash digest or a simple key depending on how the data was encrypted.
as to why a hash is needed I believe it is to increase security so that it is difficult for hackers to decrypt that data.

Related

When I examine more than 9000 files with this Delphi code , I am having Error :stream Read Error [closed]

Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 4 years ago.
Improve this question
When I examine more than 9000 files with the following Delphi code, I get this error:
Please help me fix this error.
I use Delphi 10.2 Tokyo, and a MacBook with 8 gb RAM and an i5 CPU.
Freeandnill tested
Stream Free;
MemStr Free;
It looks like your post is mostly code; please add some more details I have not more info
Tested
// detect image type
var
Form1: TForm1;
JPG_HEADER: array[0..2] of byte = ($FF, $D8, $FF);
GIF_HEADER: array[0..2] of byte = ($47, $49, $46);
BMP_HEADER: array[0..1] of byte = ($42, $4D);
PNG_HEADER: array[0..3] of byte = ($89, $50, $4E, $47);
TIF_HEADER: array[0..2] of byte = ($49, $49, $2A);
TIF_HEADER2: array[0..2] of byte = (77, 77, 00);
type
TImageType = (ifUnknown, ifJPG, ifGIF, ifBMP, ifPNG, ifTIF);
implementation
{$R *.dfm}
function TypeToStr(ImageType: TImageType): String;
begin
case ImageType of
ifJPG: Result := 'Image/JPEG';
ifGIF: Result := 'Image/GIF';
ifPNG: Result := 'Image/PNG';
ifBMP: Result := 'Image/BMP';
ifTIF: Result := 'Image/TIFF';
else
Result := 'Unknown Type';
end;
end;
function GetImageType(FileName: String): TImageType;
var
Stream: TFileStream;
MemStr: TMemoryStream;
buf: integer;
tmp: string;
begin
Result := ifUnknown;
Stream := TFileStream.Create(FileName, fmOpenRead);
MemStr := TMemoryStream.Create;
try
MemStr.CopyFrom(Stream, 5);
if MemStr.Size > 4 then
begin
// uncomment these lines to detect "unknown types"
// MemStr.Position:=0;
// MemStr.Read(buf,1);
// showmessage(inttostr(ord(buf)));
// MemStr.Read(buf,1);
// showmessage(inttostr(ord(buf)));
// MemStr.Read(buf,1);
// showmessage(inttostr(ord(buf)));
if CompareMem(MemStr.Memory, #JPG_HEADER, SizeOf(JPG_HEADER)) then
Result := ifJPG
else if CompareMem(MemStr.Memory, #GIF_HEADER, SizeOf(GIF_HEADER)) then
Result := ifGIF
else if CompareMem(MemStr.Memory, #PNG_HEADER, SizeOf(PNG_HEADER)) then
Result := ifPNG
else if CompareMem(MemStr.Memory, #BMP_HEADER, SizeOf(BMP_HEADER)) then
Result := ifBMP
else if CompareMem(MemStr.Memory, #TIF_HEADER, SizeOf(TIF_HEADER)) then
Result := ifTIF
else if CompareMem(MemStr.Memory, #TIF_HEADER2, SizeOf(TIF_HEADER2)) then
Result := ifTIF;
end;
finally
Stream.Free;
MemStr.Free;
end;
end;
//Run Cod
procedure TForm1.Button1Click(Sender: TObject);
var
FileName: String;
it: TImageType;
begin
if OpenDialog1.Execute then
begin
FileName := OpenDialog1.FileName;
it := GetImageType(FileName);
Label1.Caption := TypeToStr(it);
end;
end;
You are asking the TStream.CopyFrom() method to read exactly 5 bytes. Internally, it uses the TStream.ReadBuffer() method, which raises a stream error if the exact number of bytes requested is not read. For instance, if you try to read from a file that is less than 5 bytes in size.
In comments, you show that you have a loop that calls GetFileSize() before calling GetImageType(). But that loop is checking the file size for <> 0 when it should be checking for >= 5 instead. Your TForm1.Button1Click() method is not checking GetFileSize() at all before calling GetImageType().
That being said, in GetImageType(), you don't need the TMemoryStream at all. Use a local byte[] array instead, and call the TFileStream.Read() method (not ReadBuffer()!) to populate it. The return value tells you the actual number of bytes read. Use that size when checking your image signatures. You don't need GetFileSize() at all (which BTW, is easier to implement using SysUtils.FindFirst() instead of actually opening the file and querying its size). GetImageType() should simply return ifUnknown if the requested file cannot be accessed (wrap the TFileStream.Create in a try/except) or is too small.
Try this:
type
TImageType = (ifUnknown, ifJPG, ifGIF, ifBMP, ifPNG, ifTIF);
...
function TypeToStr(ImageType: TImageType): String;
begin
case ImageType of
ifJPG: Result := 'Image/JPEG';
ifGIF: Result := 'Image/GIF';
ifPNG: Result := 'Image/PNG';
ifBMP: Result := 'Image/BMP';
ifTIF: Result := 'Image/TIFF';
else
Result := 'Unknown Type';
end;
end;
function GetImageType(FileName: String): TImageType;
const
JPG_HEADER: array[0..2] of byte = ($FF, $D8, $FF);
GIF_HEADER: array[0..2] of byte = ($47, $49, $46);
BMP_HEADER: array[0..1] of byte = ($42, $4D);
PNG_HEADER: array[0..3] of byte = ($89, $50, $4E, $47);
TIF_HEADER: array[0..2] of byte = ($49, $49, $2A);
TIF_HEADER2: array[0..2] of byte = ($4D, $4D, $00);
var
Stream: TFileStream;
buf: array[0..3] of Byte;
bufsize: Integer;
function MatchesSignature(const signature; signatureSize: Integer): Boolean;
begin
Result := (bufsize >= signatureSize) and CompareMem(#buf, #signature, signatureSize);
end;
begin
Result := ifUnknown;
try
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
bufsize := Stream.Read(buf, SizeOf(buf));
if bufsize < 2 then Exit;
finally
Stream.Free;
end;
except
Exit;
end;
// uncomment these lines to detect "unknown types"
// ShowMessage(IntToStr(buf[0]));
// Showmessage(IntToStr(buf[1]));
// Showmessage(IntToStr(buf[2]));
if MatchesSignature(JPG_HEADER, SizeOf(JPG_HEADER)) then
Result := ifJPG
else if MatchesSignature(GIF_HEADER, SizeOf(GIF_HEADER)) then
Result := ifGIF
else if MatchesSignature(PNG_HEADER, SizeOf(PNG_HEADER)) then
Result := ifPNG
else if MatchesSignature(BMP_HEADER, SizeOf(BMP_HEADER)) then
Result := ifBMP
else if MatchesSignature(TIF_HEADER, SizeOf(TIF_HEADER)) then
Result := ifTIF
else if MatchesSignature(TIF_HEADER2, SizeOf(TIF_HEADER2)) then
Result := ifTIF;
end;
You perform MemStr.CopyFrom(Stream, 5); without checking whether stream size is large enough.
So opening of empty or too short file gives that error.
Stream error arises due to reading beyond the end of file.
Try to check Stream.Size before copying

How to determine the size of a buffer for a DLL call when the result comes from the DLL

Using both Delphi 10.2 Tokyo and Delphi XE2.
I have a DLL that posts XML data to a site. The DLL is built with Delphi 10 in order to use TLS 1.2, which is not available with Delphi XE2.
The call to the DLL comes from a Delphi XE2 EXE, but I don't believe that is relevant, but I am noting it nonetheless.
The call to post data to a site will often return text data. Sometimes very large amounts of text data. Greater than 150K characters.
My original DLL convention was basically not correct, as I returned the contents of the returned text data as a PChar. In my readings here and elsewhere, that's a big no-no.
That "bad" methodology worked well until I started to get very large amounts of data returned. I tested it, and it failed on anything greater than 132,365 characters.
I restructured my DLL and calling code to pass in a buffer as a PChar to fill in, but I get an error trying to fill the output value!
Secondly, since I never know how big the returned data will be, how to I specify how big a buffer to fill from my calling method?
My DLL code where I get the error:
library TestDLL;
uses
SysUtils,
Classes,
Windows,
Messages,
vcl.Dialogs,
IdSSLOpenSSL, IdHTTP, IdIOHandlerStack, IdURI,
IdCompressorZLib;
{$R *.res}
function PostAdminDataViaDll(body, method, url: PChar; OutData : PChar; OutLen : integer): integer; stdcall
var HTTPReq : TIdHTTP;
var Response: TStringStream;
var SendStream : TStringStream;
var IdSSLIOHandler : TIdSSLIOHandlerSocketOpenSSL;
var Uri : TIdURI;
var s : string;
begin
Result := -1;
try
HTTPReq := TIdHTTP.Create(nil);
IdSSLIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
IdSSLIOHandler.SSLOptions.Mode := sslmClient;
IdSSLIOHandler.SSLOptions.SSLVersions := [sslvTLSv1_2, sslvTLSv1_1];
if Assigned(HTTPReq) then begin
HTTPReq.Compressor := TIdCompressorZLib.Create(HTTPReq);
HTTPReq.IOHandler := IdSSLIOHandler;
HTTPReq.ReadTimeout := 180000;//set read timeout to 3 minutes
HTTPReq.Request.ContentType := 'text/xml;charset=UTF-8';
HTTPReq.Request.Accept := 'text/xml';
HTTPReq.Request.CustomHeaders.AddValue('SOAPAction', 'http://tempuri.org/Administration/' + method);
HTTPReq.HTTPOptions := [];
end;
SendStream := TStringStream.Create(Body);
Response := TStringStream.Create(EmptyStr);
try
HTTPReq.Request.ContentLength := Length(Body);
Uri := TiDUri.Create(url);
try
HTTPReq.Request.Host := Uri.Host;
finally
Uri.Free;
end;
HTTPReq.Post(url + 'admin.asmx', SendStream,Response);
if Response.Size > 0 then begin
if assigned(OutData) then begin
s := Response.DataString;// Redundant? Probably can just use Response.DataString?
StrPLCopy(OutData, s, OutLen);// <- ACCESS VIOLATION HERE
//StrPLCopy(OutData, s, Response.Size);// <- ACCESS VIOLATION HERE
Result := 0;
end;
end
else begin
Result := -2;
end;
finally
Response.Free;
SendStream.Free;
IdSSLIOHandler.Free;
HTTPReq.Free;
end;
except
on E:Exception do begin
ShowMessage(E.Message);
Result := 1;
end;
end;
end;
exports
PostAdminDataViaDll;
begin
end.
My Calling method code:
function PostAdminData(body, method, url : string): IXMLDOMDocument;
type
TMyPost = function (body, method, url: PChar; OutData : PChar; OutLen : integer): integer; stdcall;
var Handle : THandle;
var MyPost : TMyPost;
var dataString : string;
var returnData : string;
begin
if not (FileExists(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL')) then begin
Application.MessageBox(pchar('Unable to find TestDLL.DLL.'), pchar('Error posting'),MB_ICONERROR + MB_OK);
Exit;
end;
dataString := EmptyStr;
returnData := '';
Handle := LoadLibrary(PChar(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL'));
if Handle <> 0 then begin
try
try
MyPost := GetProcAddress(Handle, 'PostAdminDataViaDll');
if #MyPost <> nil then begin
// NOTE 32767 is not big enough for the returned data! Help!
if MyPost(PChar(body), PChar(method), PChar(url), PChar(returnData), 32767) = 0 then begin
dataString := returnData;
end;
end;
except
end;
finally
FreeLibrary(Handle);
end;
end
else begin
Application.MessageBox(pchar('Unable to find TestDLL.DLL.'), pchar('Error posting'),MB_ICONERROR + MB_OK);
end;
if not sametext(dataString, EmptyStr) then begin
try
Result := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
Result.async := False;
Result.loadXML(dataString);
except
end;
end;
end;
I have a DLL that posts XML data to a site. The DLL is built with Delphi 10 in order to use TLS 1.2, which is not available with Delphi XE2.
Why not simply update Indy in XE2 to a newer version that supports TLS 1.2? Then you don't need the DLL at all.
My original DLL convention was basically not correct, as I returned the contents of the returned text data as a PChar. In my readings here and elsewhere, that's a big no-no.
It is not a "big no-no", especially if the response data is dynamic in nature. Returning a pointer to dynamically allocated data is perfectly fine. You would simply have to export an extra function to free the data when the caller is done using it, that's all. The "big no-no" is that this does introduce a potential memory leak, if the caller forgets to call the 2nd function. But that is what try..finally is good for.
That "bad" methodology worked well until I started to get very large amounts of data returned. I tested it, and it failed on anything greater than 132,365 characters.
That is not a lot of memory. Any failure you were getting with it was likely due to you simply misusing the memory.
I restructured my DLL and calling code to pass in a buffer as a PChar to fill in, but I get an error trying to fill the output value!
That is because you are not filling in the memory correctly.
Secondly, since I never know how big the returned data will be, how to I specify how big a buffer to fill from my calling method?
You can't, when using POST. You would have to cache the response data somewhere off to the side, and then expose ways to let the caller query that cache for its size and data afterwards.
My DLL code where I get the error:
My Calling method code:
I see a number of logic mistakes in that code.
But, the most important reason for the Access Violation error is that your EXE is simply not allocating any memory for its returnData variable.
Casting a string to a PChar never produces a nil pointer. If the input string is not empty, a pointer to the string's first Char is returned. Otherwise, a pointer to a static #0 Char is returned instead. This ensures that a string casted to PChar always results in a non-nil, null-terminated, C style character string.
Your EXE is telling the DLL that returnData can hold up to 32767 chars, but in reality it can't hold any chars at all! In the DLL, OutData is not nil, and OutLen is wrong.
Also, StrPLCopy() always null-terminates the output, but the MaxLen parameter does not include the null-terminator, so the caller must allocate room for MaxLen+1 characters. This is stated in the StrPLCopy() documentation.
With all of this said, try something more like this:
library TestDLL;
uses
SysUtils,
Classes,
Windows,
Messages,
Vcl.Dialogs,
IdIOHandlerStack, IdSSLOpenSSL, IdHTTP, IdCompressorZLib;
{$R *.res}
function PostAdminDataViaDll(body, method, url: PChar;
var OutData : PChar): integer; stdcall;
var
HTTPReq : TIdHTTP;
SendStream : TStringStream;
IdSSLIOHandler : TIdSSLIOHandlerSocketOpenSSL;
s : string;
begin
OutData := nil;
try
HTTPReq := TIdHTTP.Create(nil);
try
IdSSLIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(HTTPReq);
IdSSLIOHandler.SSLOptions.Mode := sslmClient;
IdSSLIOHandler.SSLOptions.SSLVersions := [sslvTLSv1, sslvTLSv1_1, sslvTLSv1_2];
HTTPReq.IOHandler := IdSSLIOHandler;
HTTPReq.Compressor := TIdCompressorZLib.Create(HTTPReq);
HTTPReq.ReadTimeout := 180000;//set read timeout to 3 minutes
HTTPReq.HTTPOptions := [];
HTTPReq.Request.ContentType := 'text/xml';
HTTPReq.Request.Charset := 'UTF-8';
HTTPReq.Request.Accept := 'text/xml';
HTTPReq.Request.CustomHeaders.AddValue('SOAPAction', 'http://tempuri.org/Administration/' + method);
SendStream := TStringStream.Create(Body, TEncoding.UTF8);
try
s := HTTPReq.Post(string(url) + 'admin.asmx', SendStream);
finally
SendStream.Free;
end;
Result := Length(s);
if Result > 0 then begin
GetMem(OutData, (Result + 1) * Sizeof(Char));
Move(PChar(s)^, OutData^, (Result + 1) * Sizeof(Char));
end;
finally
HTTPReq.Free;
end;
except
on E: Exception do begin
ShowMessage(E.Message);
Result := -1;
end;
end;
end;
function FreeDataViaDll(Data : Pointer): integer; stdcall;
begin
try
FreeMem(Data);
Result := 0;
except
on E: Exception do begin
ShowMessage(E.Message);
Result := -1;
end;
end;
end;
exports
PostAdminDataToCenPosViaDll,
FreeDataViaDll;
begin
end.
function PostAdminData(body, method, url : string): IXMLDOMDocument;
type
TMyPost = function (body, method, url: PChar; var OutData : PChar): integer; stdcall;
TMyFree = function (Data Pointer): integer; stdcall;
var
hDll : THandle;
MyPost : TMyPost;
MyFree : TMyFree;
dataString : string;
returnData : PChar;
returnLen : Integer;
begin
hDll := LoadLibrary(PChar(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL'));
if hDll = 0 then begin
Application.MessageBox('Unable to load TestDLL.DLL.', 'Error posting', MB_ICONERROR or MB_OK);
Exit;
end;
try
try
MyPost := GetProcAddress(hDll, 'PostAdminDataViaDll');
MyFree := GetProcAddress(hDll, 'FreeDataViaDll');
if Assigned(MyPost) and Assigned(MyFree) then begin
returnLen := MyPost(PChar(body), PChar(method), PChar(url), returnData);
if returnLen > 0 then begin
try
SetString(dataString, returnData, returnLen);
finally
MyFree(returnData);
end;
end;
end;
finally
FreeLibrary(hDll);
end;
except
end;
if dataString <> '' then begin
try
Result := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
Result.async := False;
Result.loadXML(dataString);
except
end;
end;
end;

Is this economical?

Just wanting to see if there is a better way to do the following(there is always a better way for everything) because it does delay the application when loading due the amount of data.
I want to fill an array of records with data I have stored in csv file, I currently have it fixed length for the array but will later make it dynamic so I can add to the csv file.
type
TStarCoords = Packed record
szSystem: String[40];
fCoordX: Single;
fCoordY: Single;
fCoordZ: Single;
end;
SystemCoords: Array [0 .. 22379] of TStarCoords;
Const
SYSTEMS = 'Data\Systems.csv';
I then fill the array on the oncreate event
procedure TForm1.FormCreate(Sender: TObject);
var
szFile, sRecord: string;
Row, Index, i: Integer;
slList: TStringList;
begin
szFile := ExtractFilePath(ParamStr(0)) + SYSTEMS;
if FileExists(szFile) then
try
slList := TStringList.Create;
slList.LoadFromFile(szFile);
for Row := 0 to slList.Count - 1 do
begin
sRecord := slList[Row];
index := Pos(',', sRecord);
if index > 0 then
begin
SystemCoords[Row].szSystem := Copy(sRecord, 1, index - 1);
Delete(sRecord, 1, index);
end;
index := Pos(',', sRecord);
if index > 0 then
begin
SystemCoords[Row].fCoordX := StrToFloat(Copy(sRecord, 1, index - 1));
Delete(sRecord, 1, index);
end;
index := Pos(',', sRecord);
if index > 0 then
begin
SystemCoords[Row].fCoordY := StrToFloat(Copy(sRecord, 1, index - 1));
Delete(sRecord, 1, index);
end;
SystemCoords[Row].fCoordZ := StrToFloat(sRecord);
end;
finally
slList.Free;
end;
for i := Low(SystemCoords) to High(SystemCoords) do
begin
cbSystem.Items.Add(SystemCoords[i].szSystem);
end;
end;
As you can see I am using "Pos" function to parse the csv file and also loop the array at the end to add the Star name to a combobox, Is there a more economical way of doing this?
Any suggestions are welcomed
It doesn't look very efficient.
Allocating a fixed length global array looks poor. Use a dynamic array of length determined at runtime.
Short strings are not recommended. Don't use them in modern programming. They are legacy and don't handle Unicode.
Don't pack records. That results in misaligned data.
There seems to be far more heap allocations that are needed. Avoid Delete if you can.
Loading into a string list won't be efficient. Use a line reader based approach for speed. Delphi's built in class though is rubbish. If you want speed and effective use of memory, roll your own.
Probably the bulk of the time is spent populating the combo! Adding 22380 items to a combo will take a very long time. Don't do that. If the data set is smaller, only add as many items as there are in the data. Otherwise, use the virtual paradigm in your UI control.
Your next step though is to work out where the bottleneck is. We can only guess because we are missing so much information. We don't know if the data is static, how big it is, and so on.
Like others said, probably the majority of the time is spent populating the combo.
In my opinion, when dealing with big updates of a TStrings the BeginUpdate / EndUpdate technique proposed by the Jens Borrisholt's answer constitutes a valid approach.
As a minor issue, if your application is the only which writes and reads the data and neither machines nor humans care about the CSV format, you might consider to store the records adopting a different file format, using the BlockRead and BlockWrite functions.
type
TStarCoords = record
szSystem: string[40];
fCoordX,
fCoordY,
fCoordZ: Single;
end;
. . .
const
CFILENAME = '<your path to some file .dat>';
Reading the data:
procedure TForm1.FormCreate(Sender: TObject);
var
lstStarCoords: TList<TStarCoords>;
f: File;
starCoords: TStarCoords;
begin
lstStarCoords := TList<TStarCoords>.Create;
try
AssignFile(f, CFILENAME);
Reset(f, SizeOf(TStarCoords));
try
while not Eof(f) do begin
BlockRead(f, starCoords, 1);
lstStarCoords.Add(starCoords);
end;
finally
CloseFile(f);
end;
cbSystem.Items.BeginUpdate;
for starCoords in lstStarCoords do
cbSystem.Items.Add(starCoords.szSystem);
cbSystem.Items.EndUpdate;
finally
lstStarCoords.Free;
end;
end;
Writing the data:
procedure TForm1.WriteStarCoords;
var
lstStarCoords: TList<TStarCoords>;
f: File;
starCoords: TStarCoords;
i: Integer;
begin
lstStarCoords := TList<TStarCoords>.Create;
try
//let's insert 5k new items
for i:=1 to 5000 do begin
with starCoords do begin
szSystem := 'HYEL YE';
fCoordX := 122;
fCoordY := 12.375;
fCoordZ := 45.75;
end;
lstStarCoords.Add(starCoords);
end;
AssignFile(f, CFILENAME);
Rewrite(f, SizeOf(TStarCoords));
try
for starCoords in lstStarCoords do
BlockWrite(f, starCoords, 1);
finally
CloseFile(f);
end;
finally
lstStarCoords.Free;
end;
end;
EDIT: example using pointers to store the record information directly in the cbSystem component.
This approach is a little more "dangerous" since it allocates memory which has to be manually freed but allows to avoid the usage of a TDictionary to pair the TStarCoords.szSystem with the corresponding record.
Declare a new type which points to the TStarCoords record:
type
PStarCoords = ^TStarCoords;
Reading the data:
procedure TForm1.FormCreate(Sender: TObject);
var
lstStarCoords: TStringList;
f: File;
starCoords: PStarCoords;
begin
ClearCbSystem;
lstStarCoords := TStringList.Create(False);
{another minor enhancement:
since lstStarCoords does not own any TObject which needs to be freed
the OwnsObjects property of the TStringList can be set to False
in order to avoid some code to be execute in some method like Clear and Delete}
try
lstStarCoords.BeginUpdate;
AssignFile(f, CFILENAME);
Reset(f, SizeOf(TStarCoords));
try
while not Eof(f) do begin
New(starCoords);
BlockRead(f, starCoords^, 1);
lstStarCoords.AddObject(starCoords^.szSystem, TObject(starCoords));
end;
finally
CloseFile(f);
end;
lstStarCoords.EndUpdate;
cbSystem.Items.Assign(lstStarCoords);
finally
lstStarCoords.Free;
end;
end;
Clearing the list with cbSystem.Clear does not automatically dispose the underlying pointers which have to be manually freed. Use the ClearCbSystem procedure everytime the cbSystem list has to be cleared:
procedure TForm1.ClearCbSystem;
var
i: Integer;
begin
cbSystem.Items.BeginUpdate;
for i := cbSystem.Items.Count-1 downto 0 do
Dispose(PStarCoords(cbSystem.Items.Objects[i]));
cbSystem.Clear;
cbSystem.Items.EndUpdate;
end;
When the form is destroyed, a call to the ClearCbSystem procedure ensures the pointers are disposed before the cbSystem component is freed by the application itself:
procedure TForm1.FormDestroy(Sender: TObject);
begin
ClearCbSystem;
end;
You can use TStringlist for the parsing of the line. In the following I assume that you have you elements seperated by a comma.
Since you are putting the string representation of you records into a combobox I assunme you later on in your program needs to go the other way: Find a TStarCoords from string. Given that I woyls recoment you putting your elements in a TDictionary instread og a Array.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Generics.Collections, StdCtrls;
type
TStarCoords = packed record
szSystem: string[40];
fCoordX: Single;
fCoordY: Single;
fCoordZ: Single;
end;
const
SYSTEMS = 'Data\Systems.csv';
type
TForm1 = class(TForm)
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
private
SystemCoords: TDictionary<string, TStarCoords>;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.ComboBox1Change(Sender: TObject);
var
StarCoord: TStarCoords;
begin
if not SystemCoords.TryGetValue(ComboBox1.Text, StarCoord) then
exit; //todo : Make some error handling
Caption := FloatToStr(StarCoord.fCoordX);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Lines, Elements: TStringlist;
Line: string;
SystemCoord: TPair<string, TStarCoords>;
begin
if not FileExists(ExtractFilePath(ParamStr(0)) + SYSTEMS) then
exit; //todo: Some error handling
SystemCoords := TDictionary<string, TStarCoords > .Create;
Lines := TStringlist.Create;
Elements := TStringlist.Create;
Elements.LineBreak := ',';
try
for Line in Lines do
begin
Elements.Text := Line;
SystemCoord.Key := Elements[0];
with SystemCoord.Value do
begin
szSystem := string(Elements[0]);
fCoordX := StrToFloat(Elements[1]);
fCoordY := StrToFloat(Elements[2]);
fCoordZ := StrToFloat(Elements[3]);
end;
SystemCoords.Add(SystemCoord.Key, SystemCoord.Value);
end;
finally
Lines.Free;
Elements.Free;
end;
try
ComboBox1.Items.BeginUpdate;
for SystemCoord in SystemCoords do
ComboBox1.Items.Add(SystemCoord.Key);
finally
ComboBox1.Items.EndUpdate;
end;
end;
end.

How can I remotely read binary registry data using Delphi 2010?

I am trying to remotely read a binary (REG_BINARY) registry value, but I get nothing but junk back. Any ideas what is wrong with this code? I'm using Delphi 2010:
function GetBinaryRegistryData(ARootKey: HKEY; AKey, AValue, sMachine: string; var sResult: string): boolean;
var
MyReg: TRegistry;
RegDataType: TRegDataType;
DataSize, Len: integer;
sBinData: string;
bResult: Boolean;
begin
bResult := False;
MyReg := TRegistry.Create(KEY_QUERY_VALUE);
try
MyReg.RootKey := ARootKey;
if MyReg.RegistryConnect('\\' + sMachine) then
begin
if MyReg.KeyExists(AKey) then
begin
if MyReg.OpenKeyReadOnly(AKey) then
begin
try
RegDataType := MyReg.GetDataType(AValue);
if RegDataType = rdBinary then
begin
DataSize := MyReg.GetDataSize(AValue);
if DataSize > 0 then
begin
SetLength(sBinData, DataSize);
Len := MyReg.ReadBinaryData(AValue, PChar(sBinData)^, DataSize);
if Len <> DataSize then
raise Exception.Create(SysErrorMessage(ERROR_CANTREAD))
else
begin
sResult := sBinData;
bResult := True;
end;
end;
end;
except
MyReg.CloseKey;
end;
MyReg.CloseKey;
end;
end;
end;
finally
MyReg.Free;
end;
Result := bResult;
end;
And I call it like this:
GetBinaryRegistryData(
HKEY_LOCAL_MACHINE,
'\SOFTWARE\Microsoft\Windows NT\CurrentVersion',
'DigitalProductId', '192.168.100.105',
sProductId
);
WriteLn(sProductId);
The result I receive from the WriteLn on the console is:
ñ ♥ ???????????6Z ????1 ???????☺ ???♦ ??3 ? ??? ?
??
Assuming that you are already connected remotely, try using the GetDataAsString function
to read binary data from the registry.
sResult := MyReg.GetDataAsString(AValue);
You're using Delphi 2010, so all your characters are two bytes wide. When you set the length of your result string, you're allocating twice the amount of space you need. Then you call ReadBinaryData, and it fills half your buffer. There are two bytes of data in each character. Look at each byte separately, and you'll probably find that your data looks less garbage-like.
Don't use strings for storing arbitrary data. Use strings for storing text. To store arbitrary blobs of data, use TBytes, which is an array of bytes.

(Wide)String - storing in TFileStream, Delphi 7. What is the fastest way?

I'm using Delphi7 (non-unicode VCL), I need to store lots of WideStrings inside a TFileStream. I can't use TStringStream as the (wide)strings are mixed with binary data, the format is projected to speed up loading and writing the data ... However I believe that current way I'm loading/writing the strings might be a bottleneck of my code ...
currently I'm writing length of a string, then writing it char by char ...
while loading, first I'm loading the length, then loading char by char ...
So, what is the fastest way to save and load WideString to TFileStream?
Thanks in advance
Rather than read and write one character at a time, read and write them all at once:
procedure WriteWideString(const ws: WideString; stream: TStream);
var
nChars: LongInt;
begin
nChars := Length(ws);
stream.WriteBuffer(nChars, SizeOf(nChars);
if nChars > 0 then
stream.WriteBuffer(ws[1], nChars * SizeOf(ws[1]));
end;
function ReadWideString(stream: TStream): WideString;
var
nChars: LongInt;
begin
stream.ReadBuffer(nChars, SizeOf(nChars));
SetLength(Result, nChars);
if nChars > 0 then
stream.ReadBuffer(Result[1], nChars * SizeOf(Result[1]));
end;
Now, technically, since WideString is a Windows BSTR, it can contain an odd number of bytes. The Length function reads the number of bytes and divides by two, so it's possible (although not likely) that the code above will cut off the last byte. You could use this code instead:
procedure WriteWideString(const ws: WideString; stream: TStream);
var
nBytes: LongInt;
begin
nBytes := SysStringByteLen(Pointer(ws));
stream.WriteBuffer(nBytes, SizeOf(nBytes));
if nBytes > 0 then
stream.WriteBuffer(Pointer(ws)^, nBytes);
end;
function ReadWideString(stream: TStream): WideString;
var
nBytes: LongInt;
buffer: PAnsiChar;
begin
stream.ReadBuffer(nBytes, SizeOf(nBytes));
if nBytes > 0 then begin
GetMem(buffer, nBytes);
try
stream.ReadBuffer(buffer^, nBytes);
Result := SysAllocStringByteLen(buffer, nBytes)
finally
FreeMem(buffer);
end;
end else
Result := '';
end;
Inspired by Mghie's answer, have replaced my Read and Write calls with ReadBuffer and WriteBuffer. The latter will raise exceptions if they are unable to read or write the requested number of bytes.
There is nothing special about wide strings, to read and write them as fast as possible you need to read and write as much as possible in one go:
procedure TForm1.Button1Click(Sender: TObject);
var
Str: TStream;
W, W2: WideString;
L: integer;
begin
W := 'foo bar baz';
Str := TFileStream.Create('test.bin', fmCreate);
try
// write WideString
L := Length(W);
Str.WriteBuffer(L, SizeOf(integer));
if L > 0 then
Str.WriteBuffer(W[1], L * SizeOf(WideChar));
Str.Seek(0, soFromBeginning);
// read back WideString
Str.ReadBuffer(L, SizeOf(integer));
if L > 0 then begin
SetLength(W2, L);
Str.ReadBuffer(W2[1], L * SizeOf(WideChar));
end else
W2 := '';
Assert(W = W2);
finally
Str.Free;
end;
end;
WideStrings contain a 'string' of WideChar's, which use 2 bytes each. If you want to store the UTF-16 (which WideStrings use internally) strings in a file, and be able to use this file in other programs like notepad, you need to write a byte order mark first: #$FEFF.
If you know this, writing can look like this:
Stream1.Write(WideString1[1],Length(WideString)*2); //2=SizeOf(WideChar)
reading can look like this:
Stream1.Read(WideChar1,2);//assert returned 2 and WideChar1=#$FEFF
SetLength(WideString1,(Stream1.Size div 2)-1);
Stream1.Read(WideString1[1],(Stream1.Size div 2)-1);
You can also use TFastFileStream for reading the data or strings, I pasted the unit at http://pastebin.com/m6ecdc8c2 and a sample below:
program Project36;
{$APPTYPE CONSOLE}
uses
SysUtils, Classes,
FastStream in 'FastStream.pas';
const
WideNull: WideChar = #0;
procedure WriteWideStringToStream(Stream: TFileStream; var Data: WideString);
var
len: Word;
begin
len := Length(Data);
// Write WideString length
Stream.Write(len, SizeOf(len));
if (len > 0) then
begin
// Write WideString
Stream.Write(Data[1], len * SizeOf(WideChar));
end;
// Write null termination
Stream.Write(WideNull, SizeOf(WideNull));
end;
procedure CreateTestFile;
var
Stream: TFileStream;
MyString: WideString;
begin
Stream := TFileStream.Create('test.bin', fmCreate);
try
MyString := 'Hello World!';
WriteWideStringToStream(Stream, MyString);
MyString := 'Speed is Delphi!';
WriteWideStringToStream(Stream, MyString);
finally
Stream.Free;
end;
end;
function ReadWideStringFromStream(Stream: TFastFileStream): WideString;
var
len: Word;
begin
// Read length of WideString
Stream.Read(len, SizeOf(len));
// Read WideString
Result := PWideChar(Cardinal(Stream.Memory) + Stream.Position);
// Update position and skip null termination
Stream.Position := Stream.Position + (len * SizeOf(WideChar)) + SizeOf(WideNull);
end;
procedure ReadTestFile;
var
Stream: TFastFileStream;
my_wide_string: WideString;
begin
Stream := TFastFileStream.Create('test.bin');
try
Stream.Position := 0;
// Read WideString
my_wide_string := ReadWideStringFromStream(Stream);
WriteLn(my_wide_string);
// Read another WideString
my_wide_string := ReadWideStringFromStream(Stream);
WriteLn(my_wide_string);
finally
Stream.Free;
end;
end;
begin
CreateTestFile;
ReadTestFile;
ReadLn;
end.

Resources