Calling external dll with array of pchar as parameter in XE - delphi

I have a delphi project that works fine in delphi 6, but when I upgraded to XE it does not work.
I know it has to do with the new unicode type in delphi XE, I have tried changing the definition of the parameter from pchar to pansichar, ansichar but no succes so far. Can anyone see what i have done wrong?
My project calls a function in an third party dll that is defined like this:
type
PPChar = array of PChar;
{$EXTERNALSYM gsapi_init_with_args}
function gsapi_init_with_args(pinstance:Pgs_main_instance;argc:integer;argv:PPChar):integer; stdcall;
Implementation
{$EXTERNALSYM gsapi_init_with_args}
function gsapi_init_with_args; stdcall; external gsdll32 name 'gsapi_init_with_args';
And here is how I call the function.
procedure PSPDF(input : string; output:string);
var
code:integer;
instance:Pointer;
argv:array of PAnsiChar;
begin
new(instance);
setlength(argv,10);
code:=gsapi_new_instance(#instance,nil);
if code<>0 then
begin
raise Exception.Create('Impossible to open an instance of ghostscript. Error code: '+IntToStr(code));
end;
try
argv[0] := PAnsiChar('ps2pdf');
argv[1] := PAnsiChar('-dNOPAUSE');
argv[2] := PAnsiChar('-dBATCH');
argv[3] := PAnsiChar('-dSAFER');
argv[4] := PAnsiChar('-sDEVICE=pdfwrite');
argv[5] := PAnsiChar(PAnsiString('-sOutputFile='+output));
argv[6] := PAnsiChar('-c');
argv[7] := PAnsiChar('.setpdfwrite');
argv[8] := PAnsiChar('-f');
argv[9] := PAnsiChar(PAnsiString(input));
gsapi_new_instance(instance, nil);
code := gsapi_init_with_args(instance,length(argv),#argv[0]);
if code<0 then
raise Exception.Create('ERROR: init_args: '+IntToStr(code));
gsapi_exit(instance);
gsapi_delete_instance(instance);
finally
end;
end;
I will very much appreciate if someone can help me out.
Mario.

Changing PChar to PAnsiChar is the correct thing to do, however array of ... is not safe to use in DLL function parameters and was the wrong thing to use even in your Delphi 6 project. After looking at the official Ghostscript documentation, try this instead, in both projects:
interface
type
PPAnsiChar = ^PAnsiChar;
{$NODEFINE PPAnsiChar}
function gsapi_new_instance(var pinstance: Pointer; caller_handle: Pointer): Integer; stdcall;
{$EXTERNALSYM gsapi_new_instance}
procedure gsapi_delete_instance(instance: Pointer); stdcall;
{$EXTERNALSYM gsapi_delete_instance}
function gsapi_init_with_args(instance: Pointer; argc: Integer; argv: PPAnsiChar): Integer; stdcall;
{$EXTERNALSYM gsapi_init_with_args}
function gsapi_exit(instance: Pointer): Integer; stdcall;
{$EXTERNALSYM gsapi_exit}
implementation
function gsapi_new_instance; external gsdll32 name 'gsapi_new_instance';
procedure gsapi_delete_instance; external gsdll32 name 'gsapi_delete_instance';
function gsapi_init_with_args; external gsdll32 name 'gsapi_init_with_args';
function gsapi_exit; external gsdll32 name 'gsapi_exit';
.
procedure PSPDF(input : AnsiString; output: AnsiString);
var
code:integer;
instance: Pointer;
argv: array of PAnsiChar;
begin
code := gsapi_new_instance(instance, nil);
if code < 0 then
raise Exception.Create('Impossible to open an instance of ghostscript. Error code: '+IntToStr(code));
try
SetLength(argv, 10);
argv[0] := PAnsiChar('ps2pdf');
argv[1] := PAnsiChar('-dNOPAUSE');
argv[2] := PAnsiChar('-dBATCH');
argv[3] := PAnsiChar('-dSAFER');
argv[4] := PAnsiChar('-sDEVICE=pdfwrite');
argv[5] := PAnsiChar('-sOutputFile='+output);
argv[6] := PAnsiChar('-c');
argv[7] := PAnsiChar('.setpdfwrite');
argv[8] := PAnsiChar('-f');
argv[9] := PAnsiChar(input);
code := gsapi_init_with_args(instance, Length(argv), #argv[0]);
if code < 0 then
raise Exception.Create('ERROR: init_args: '+IntToStr(code));
try
...
finally
gsapi_exit(instance);
end;
finally
gsapi_delete_instance(instance);
end;
end;
Update: here is a corrected version of the gsapi.pas unit that should work in both Delphi versions:
// Copyright (c) 2001-2002 Alessandro Briosi
//
// Permission is hereby granted, free of charge, to any person
// obtaining a copy of this software and associated documentation
// files (the "Software"), to deal in the Software without
// restriction, including without limitation the rights to use, copy,
// modify, merge, publish, distribute, sublicense, and/or sell copies
// of the Software, and to permit persons to whom the Software is
// furnished to do so, subject to the following conditions:
//
// The above copyright notice and this permission notice shall be
// included in all copies or substantial portions of the Software.
//
// THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
// EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
// MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
// NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
// BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
// ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
// CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
// SOFTWARE.
//
//
// This software was written by Alessandro Briosi with the
// assistance of Russell Lang, as an example of how the
// Ghostscript DLL may be used Delphi.
//
unit gsapi;
interface
uses
Windows;
// {$HPPEMIT '#include <iminst.h>'}
const
gsdll32 = 'gsdll32.dll';
STDIN_BUF_SIZE = 128;
{$EXTERNALSYM STDIN_BUF_SIZE}
STDOUT_BUF_SIZE = 128;
{$EXTERNALSYM STDOUT_BUF_SIZE}
STDERR_BUF_SIZE = 128;
{$EXTERNALSYM STDERR_BUF_SIZE}
DISPLAY_VERSION_MAJOR = 1;
{$EXTERNALSYM DISPLAY_VERSION_MAJOR}
DISPLAY_VERSION_MINOR = 0;
{$EXTERNALSYM DISPLAY_VERSION_MINOR}
//* Define the color space alternatives */
DISPLAY_COLORS_NATIVE = $01;
{$EXTERNALSYM DISPLAY_COLORS_NATIVE}
DISPLAY_COLORS_GRAY = $02;
{$EXTERNALSYM DISPLAY_COLORS_GRAY}
DISPLAY_COLORS_RGB = $04;
{$EXTERNALSYM DISPLAY_COLORS_RGB}
DISPLAY_COLORS_CMYK = $08;
{$EXTERNALSYM DISPLAY_COLORS_CMYK}
DISPLAY_COLORS_MASK = $000f;
{$EXTERNALSYM DISPLAY_COLORS_MASK}
//* Define whether alpha information, or an extra unused bytes is included */
//* DISPLAY_ALPHA_FIRST and DISPLAY_ALPHA_LAST are not implemented */
DISPLAY_ALPHA_NONE = $00;
{$EXTERNALSYM DISPLAY_ALPHA_NONE}
DISPLAY_ALPHA_FIRST = $10;
{$EXTERNALSYM DISPLAY_ALPHA_FIRST}
DISPLAY_ALPHA_LAST = $20;
{$EXTERNALSYM DISPLAY_ALPHA_LAST}
DISPLAY_UNUSED_FIRST = $40; //* e.g. Mac xRGB */
{$EXTERNALSYM DISPLAY_UNUSED_FIRST}
DISPLAY_UNUSED_LAST = $80; //* e.g. Windows BGRx */
{$EXTERNALSYM DISPLAY_UNUSED_LAST}
DISPLAY_ALPHA_MASK = $0070;
{$EXTERNALSYM DISPLAY_ALPHA_MASK}
// * Define the depth per component for DISPLAY_COLORS_GRAY,
// * DISPLAY_COLORS_RGB and DISPLAY_COLORS_CMYK,
// * or the depth per pixel for DISPLAY_COLORS_NATIVE
// * DISPLAY_DEPTH_2 and DISPLAY_DEPTH_12 have not been tested.
// *
DISPLAY_DEPTH_1 = $0100;
{$EXTERNALSYM DISPLAY_DEPTH_1}
DISPLAY_DEPTH_2 = $0200;
{$EXTERNALSYM DISPLAY_DEPTH_2}
DISPLAY_DEPTH_4 = $0400;
{$EXTERNALSYM DISPLAY_DEPTH_4}
DISPLAY_DEPTH_8 = $0800;
{$EXTERNALSYM DISPLAY_DEPTH_8}
DISPLAY_DEPTH_12 = $1000;
{$EXTERNALSYM DISPLAY_DEPTH_12}
DISPLAY_DEPTH_16 = $2000;
{$EXTERNALSYM DISPLAY_DEPTH_16}
//* unused (1<<14) */
//* unused (1<<15) */
DISPLAY_DEPTH_MASK = $ff00;
{$EXTERNALSYM DISPLAY_DEPTH_MASK}
// * Define whether Red/Cyan should come first,
// * or whether Blue/Black should come first
// */
DISPLAY_BIGENDIAN = $00000; //* Red/Cyan first */
{$EXTERNALSYM DISPLAY_BIGENDIAN}
DISPLAY_LITTLEENDIAN = $10000; //* Blue/Black first */
{$EXTERNALSYM DISPLAY_LITTLEENDIAN}
DISPLAY_ENDIAN_MASK = $00010000;
{$EXTERNALSYM DISPLAY_ENDIAN_MASK}
//* Define whether the raster starts at the top or bottom of the bitmap */
DISPLAY_TOPFIRST = $00000; //* Unix, Mac */
{$EXTERNALSYM DISPLAY_TOPFIRST}
DISPLAY_BOTTOMFIRST = $20000; //* Windows */
{$EXTERNALSYM DISPLAY_BOTTOMFIRST}
DISPLAY_FIRSTROW_MASK = $00020000;
{$EXTERNALSYM DISPLAY_FIRSTROW_MASK}
//* Define whether packing RGB in 16-bits should use 555
// * or 565 (extra bit for green)
// */
DISPLAY_NATIVE_555 = $00000;
{$EXTERNALSYM DISPLAY_NATIVE_555}
DISPLAY_NATIVE_565 = $40000;
{$EXTERNALSYM DISPLAY_NATIVE_565}
DISPLAY_555_MASK = $00040000;
{$EXTERNALSYM DISPLAY_555_MASK}
type
TGSAPIrevision = record
product: PAnsiChar;
copyright: PAnsiChar;
revision: Longint;
revisiondat: Longint;
end;
TStdioFunction = function(caller_handle: Pointer; buf: PAnsiChar; len: Integer): Integer; stdcall;
TPollFunction = function(caller_handle: Pointer): Integer; stdcall;
TDisplayEvent = function(handle: Pointer; device: Pointer): Integer; cdecl;
TDisplayPreResizeEvent = function(handle: Pointer; device: Pointer;
width: Integer; height: Integer; raster: Integer; format: UINT): Integer; cdecl;
TDisplayResizeEvent = function(handle: Pointer; device: Pointer;
width: Integer; height: Integer; raster: Integer; format: UINT; pimage: PAnsiChar): Integer; cdecl;
TDisplayPageEvent = function(handle: Pointer; device: Pointer; copies: Integer; flush: Integer): Integer; cdecl;
TDisplayUpdateEvent = function(handle: Pointer; device: Pointer; x: Integer; y: Integer; w: Integer; h: Integer): Integer; cdecl;
TDisplayMemAlloc = procedure(handle: Pointer; device: Pointer; size: ulong); cdecl;
TDisplayMemFree = function(handle: Pointer; device: Pointer; mem: Pointer): Integer; cdecl;
TDisplayCallback = record
size: Integer;
version_major: Integer;
version_minor: Integer;
// New device has been opened */
// This is the first event from this device. */
display_open: TDisplayEvent;
// Device is about to be closed. */
// Device will not be closed until this function returns. */
display_preclose: TDisplayEvent;
// Device has been closed. */
// This is the last event from this device. */
display_close: TDisplayEvent;
// Device is about to be resized. */
// Resize will only occur if this function returns 0. */
// raster is byte count of a row. */
display_presize: TDisplayPreResizeEvent;
// Device has been resized. */
// New pointer to raster returned in pimage */
display_size: TDisplayResizeEvent;
// flushpage */
display_sync: TDisplayEvent;
// showpage */
// If you want to pause on showpage, then don't return immediately */
display_page: TDisplayPageEvent;
// Notify the caller whenever a portion of the raster is updated. */
// This can be used for cooperative multitasking or for
// progressive update of the display.
// This function pointer may be set to NULL if not required.
//
display_update: TDisplayUpdateEvent;
// Allocate memory for bitmap */
// This is provided in case you need to create memory in a special
// way, e.g. shared. If this is NULL, the Ghostscript memory device
// allocates the bitmap. This will only called to allocate the
// image buffer. The first row will be placed at the address
// returned by display_memalloc.
//
display_memalloc: TDisplayMemAlloc;
// Free memory for bitmap */
// If this is NULL, the Ghostscript memory device will free the bitmap */
display_memfree: TDisplayMemFree;
end;
PPAnsiChar = ^PAnsiChar;
{$NODEFINE PPAnsiChar}
function gsapi_revision(var pr: TGSAPIrevision; len: Integer): Integer; stdcall;
{$EXTERNALSYM gsapi_revision}
function gsapi_new_instance(var pinstance: Pointer; caller_handle: Pointer): Integer; stdcall;
{$EXTERNALSYM gsapi_new_instance}
procedure gsapi_delete_instance(pinstance: Pointer); stdcall;
{$EXTERNALSYM gsapi_delete_instance}
function gsapi_set_stdio(pinstance: Pointer;
stdin_fn: TStdioFunction; stdout_fn: TStdioFunction;
stderr_fn: TStdioFunction): Integer; stdcall;
{$EXTERNALSYM gsapi_set_stdio}
function gsapi_set_poll(pinstance: Pointer; poll_fn: TPollFunction): Integer; stdcall;
{$EXTERNALSYM gsapi_set_poll}
function gsapi_set_display_callback(pinstance: Pointer; const callback: TDisplayCallback): Integer; stdcall;
{$EXTERNALSYM gsapi_set_display_callback}
function gsapi_init_with_args(pinstance: Pointer; argc: Integer; argv: PPAnsiChar): Integer; stdcall;
{$EXTERNALSYM gsapi_init_with_args}
function gsapi_run_string_begin(pinstance: Pointer; user_errors: Integer; var pexit_code: Integer): Integer; stdcall;
{$EXTERNALSYM gsapi_run_string_begin}
function gsapi_run_string_continue(pinstance: Pointer; str: PAnsiChar; len: Integer; user_errors: Integer; var pexit_code: Integer): Integer; stdcall;
{$EXTERNALSYM gsapi_run_string_continue}
function gsapi_run_string_end(pinstance: Pointer; user_errors: Integer; var pexit_code: Integer): Integer; stdcall;
{$EXTERNALSYM gsapi_run_string_end}
function gsapi_run_string_with_length(pinstance: Pointer; str: PAnsiChar; len: Integer; user_errors: Integer; var pexit_code: Integer): Integer; stdcall;
{$EXTERNALSYM gsapi_run_string_with_length}
function gsapi_run_string(pinstance: Pointer; str: PAnsiChar; user_errors: Integer; var pexit_code: Integer): Integer; stdcall;
{$EXTERNALSYM gsapi_run_string}
function gsapi_run_file(pinstance: Pointer; file_name: PAnsiChar; user_errors: Integer; var pexit_code: Integer): Integer; stdcall;
{$EXTERNALSYM gsapi_run_file}
function gsapi_exit(pinstance: Pointer): Integer; stdcall;
{$EXTERNALSYM gsapi_exit}
implementation
function gsapi_revision; external gsdll32 name 'gsapi_revision';
function gsapi_new_instance; external gsdll32 name 'gsapi_new_instance';
procedure gsapi_delete_instance; external gsdll32 name 'gsapi_delete_instance';
function gsapi_set_stdio; external gsdll32 name 'gsapi_set_stdio';
function gsapi_set_poll; external gsdll32 name 'gsapi_set_poll';
function gsapi_set_display_callback; external gsdll32 name 'gsapi_set_display_callback';
function gsapi_init_with_args; external gsdll32 name 'gsapi_init_with_args';
function gsapi_run_string_begin; external gsdll32 name 'gsapi_run_string_begin';
function gsapi_run_string_continue; external gsdll32 name 'gsapi_run_string_continue';
function gsapi_run_string_end; external gsdll32 name 'gsapi_run_string_end';
function gsapi_run_string_with_length; external gsdll32 name 'gsapi_run_string_with_length';
function gsapi_run_string; external gsdll32 name 'gsapi_run_string';
function gsapi_run_file; external gsdll32 name 'gsapi_run_file';
function gsapi_exit; external gsdll32 name 'gsapi_exit';
end.

The old Delphi 6 PChar is PAnsiChar on Unicode Delphi (2009+), so everything should work if you change all the PChar references to PAnsiChar.
(Including your Pgs_main_instance declaration, if any PChar is over there)
type
PPAnsiChar = array of PAnsiChar;
{$EXTERNALSYM gsapi_init_with_args}
function gsapi_init_with_args(pinstance: Pgs_main_instance;
argc: Integer; argv:PPAnsiChar): Integer; stdcall;
implementation
function gsapi_init_with_args(pinstance: Pgs_main_instance;
argc: Integer; argv:PPAnsiChar): Integer;
external gsdll32 name 'gsapi_init_with_args';
Calling code:
var
argv:PPAnsiChar;
instance: Pointer;
begin
new(instance); //how many bytes, this really doesn't make sense with a untyped pointer!
setlength(argv, 4);
argv[0] := PAnsiChar('ps2pdf');
argv[1] := PAnsiChar('-dNOPAUSE');
argv[2] := PAnsiChar('-dBATCH');
argv[3] := PAnsiChar('-dSAFER');
gsapi_init_with_args(instance, Length(argv), argv);
end;
To understand what's new in Unicode, I advise you to read the Delphi and Unicode white paper from Marco Cantù.

Related

NetWkstaGetInfo ACCESS_VIOLATION under WIN64

I'm have code, which works fine during many years under WIN32. But yesterday, after compiling under WIN64 I'm got strange ACCESS_VIOLATION error when trying get wki100_langroup field. Where wrong this code? (Computer not in domain and in Delphi 11 debug window I can see, that this field is empty)
const
NERR_SUCCESS = 0;
type
WKSTA_INFO_100 = record
wki100_platform_id: DWORD;
wki100_computername: LPWSTR;
wki100_langroup: LPWSTR;
wki100_ver_major: DWORD;
wki100_ver_minor: DWORD;
end;
LPWKSTA_INFO_100 = ^WKSTA_INFO_100;
function NetWkstaGetInfo(ServerName: LPWSTR; Level: DWORD; var BufPtr: Pointer): DWORD; stdcall;
external 'netapi32.dll' Name 'NetWkstaGetInfo';
function GetDomain: string;
var
PBuf: Pointer;
Res: Integer;
begin
Result := '';
Res := NetWkstaGetInfo(nil, 100, PBuf);
if (Res = NERR_Success) then begin
Result := LPWKSTA_INFO_100(PBuf)^.wki100_langroup; // ACCESS_VIOLATION here
if Assigned(PBuf) then
NetApiBufferFree(PBuf);
end;
end;
Update:
After changing Pointer to PByte I have the same exception
function NetWkstaGetInfo(ServerName: LPWSTR; Level: DWORD; BufPtr: PByte): DWORD; stdcall;
external 'netapi32.dll' Name 'NetWkstaGetInfo';
function GetDomain: string;
var
PBuf: PByte;
Res: Integer;
begin
Result := '';
Res := NetWkstaGetInfo(nil, 100, #PBuf);
if (Res = NERR_Success) then begin
Result := LPWKSTA_INFO_100(PBuf)^.wki100_langroup; // ACCESS_VIOLATION here
if Assigned(PBuf) then
NetApiBufferFree(PBuf);
end;
end;
Screenshots from Win32:
and Win64 breakpoints:
The symptoms suggest that some other code changed default record alignment for WKSTA_INFO_100 record type.
Under 32-bit compiler that wouldn't have an impact because all values in the record are also 32-bit therefore they will be correctly aligned even if other alignment size is specified.
Under 64-bit compiler DWORD is 32-bit, while LPWSTR is 64-bit. With default 8 byte alignment that means there will be 4 padding bytes inserted after wki100_platform_id. If some other alignment is used following fields will not be at correct positions.
To correct this you need to specify 8 byte alignment {$A8} before type declaration.
type
{$A8}
WKSTA_INFO_100 = record
wki100_platform_id: DWORD;
wki100_computername: LPWSTR;
wki100_langroup: LPWSTR;
wki100_ver_major: DWORD;
wki100_ver_minor: DWORD;
end;

Jedi: Needing of value for GUID_DEVINTERFACE_IMAGE: TGUID

Good morning,
I'm wanting catch the total number of webcams in a computer, and traslate a source code that found in C++ (code is here) to Delphi like following:
const
MAX_PATH = 260;
CR_SUCCESS =$00000000;
type
HDevInfo = Pointer; { a pointer to a HID device info structure }
THDEVINFO = Pointer;
PSP_DevInfo_Data = ^TSP_DevInfo_Data;
SP_DEVINFO_DATA = packed record
cbSize: DWORD;
ClassGuid: TGUID;
DevInst: DWORD;
Reserved: LongWord;
end;
TSP_DevInfo_Data = SP_DEVINFO_DATA;
PDEVPROPKEY = ^TDEVPROPKEY;
DEVPROPKEY = packed record
fmtid : TGUID ;
pid : Pointer;
end;
TDEVPROPKEY = DEVPROPKEY;
DEVPROPTYPE = Pointer;
PCWSTR = PWCHAR;
TDEVINST = DWord;
TPOSVERSIONINFOW = ^TOSVERSIONINFOW;
TOSVERSIONINFOW = packed record
dwOSVersionInfoSize : DWORD ;
dwMajorVersion : DWORD ;
dwMinorVersion : DWORD ;
dwBuildNumber : DWORD ;
dwPlatformId : DWORD ;
szCSDVersion : array[0..127] of wchar;
end;
function SetupDiGetDeviceProperty(DeviceInfoSet: THDEVINFO; DeviceInfoData: PSP_DEVINFO_DATA; const PropertyKey: PDEVPROPKEY; var PropertyType:DEVPROPTYPE; PropertyBuffer:PBYTE;PropertyBufferSize:DWORD; RequiredSize:PDWORD; Flags:DWORD): BOOL; stdcall; external 'Setupapi.DLL' name 'SetupDiGetDevicePropertyW';
function SetupDiGetClassDevsW(const ClassGuid: PGUID; Enumerator: PCWSTR; hwndParent: HWND; Flags: DWORD): THDEVINFO; stdcall; external 'Setupapi.DLL' name 'SetupDiGetClassDevsW';
function SetupDiGetClassDevsA(ClassGuid: PGUID; const Enumerator: PAnsiChar;
hwndParent: HWND; Flags: DWORD): THandle; stdcall; external 'SetupApi.dll';
function SetupDiEnumDeviceInfo(DeviceInfoSet: THDEVINFO; MemberIndex: DWORD; DeviceInfoData: PSP_DEVINFO_DATA): BOOL; stdcall; external 'Setupapi.DLL' name 'SetupDiEnumDeviceInfo';
function CM_Get_Device_IDW(DeviceInstanceHandle: TDEVINst; Buffer:PCWSTR; Bufferlen : ULONG; ulFlags:ULONG): DWORD; stdcall; external 'Setupapi.DLL' name 'CM_Get_Device_IDW';
function SetupDiGetDeviceRegistryPropertyW(DeviceInfoSet: THDEVINFO; const DeviceInfoData: SP_DevInfo_Data; Property_: DWORD; var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall; external 'Setupapi.DLL' name 'SetupDiGetDeviceRegistryPropertyW';
function GetVersionExW(OsVersion:TPOSVERSIONINFOW): BOOL; stdcall; external 'Kernel32.dll' name 'GetVersionExW';
const
DIGCF_PRESENT = $00000002;
DIGCF_ALLCLASSES = $00000004;
DIGCF_PROFILE = $00000008;
DIGCF_DEVICEINTERFACE = $00000010;
INVALID_HANDLE_VALUE = DWORD($FFFFFFFF);
MAX_DEVICE_ID_LEN = 200;
SPDRP_DEVICEDESC = ($00000000) ;
DEVPKEY_Device_BusReportedDeviceDesc : TDEVPROPKEY = (fmtid : '{540b947e-8b40-45bc-a8a2-6a0b894cbda2}' ; pid : pointer(4) );
implementation
function GetNumCam: integer;
var
MemberIndex: integer;
dev: HDEVINFO;
DeviceInfoData: SP_DEVINFO_DATA;
begin
DeviceInfoData.cbSize := sizeof(DeviceInfoData);
dev := SetupDiGetClassDevsA(#GUID_DEVINTERFACE_IMAGE, nil, nil, DIGCF_PRESENT);
if dev = nil then begin
//raise exception.Create('Nenhum dispositivo encontrado');
exit;
end
else
while SetupDiEnumDeviceInfo(dev,MemberIndex, #DeviceInfoData) do
begin
MemberIndex:= MemberIndex + 1;
end;
Result:= MemberIndex;
end;
but I'm with difficulties for find a value for GUID_DEVINTERFACE_IMAGE in Delphi, and after assign this value for this constant. I saw in (this unit) but don't have this constant for I catch the value.
Someone have the exact value for this constant, please?
Thank in advance.
The value can be found in the documentation:
{0x6bdd1fc6L, 0x810f, 0x11d0, 0xbe, 0xc7, 0x08,
0x00, 0x2b, 0xe2, 0x09, 0x2f}
In Delphi you declare it like this:
const
GUID_DEVINTERFACE_IMAGE: TGUID = (
D1:$6bdd1fc6; D2:$810f; D3:$11d0; D4:($be, $c7, $08, $00, $2b, $e2, $09, $2f)
);
or like this:
const
GUID_DEVINTERFACE_IMAGE: TGUID = '{6bdd1fc6-810f-11d0-bec7-08002be2092f}';

Delphi code to get Owner of a Netware file not working

I'm a Delphi developer and have never programmed for netware. But I need to find the owner of a file on a netware share. After some research, I got this code snippet from a newsgroup (original author: Chris Morgan). It's basically a way to dynamically load netware dll and get the "owner" information of a file. Please look at the function GetNetwareFileOwner.
The problem is, I don't have direct access to a netware share for testing. I'm sending a small test program every time to a user who tests it by selecting a file on the netware share and then reports the results. I'm getting the error code by a small code insert after the call NWIntScanExtenedInfo where it fails with the error codes given below. Any ideas what can be wrong?
Error codes:
1) At first, the following code gave error 899E (INVALID_FILENAME) on the above call. The file name was in English--no special characters there. And the file was selected on the share with a regular File Open dialog.
2) After that, suspecting a case problem, I commented the two AnsiUpperCase lines to keep the name in original case exactly as the File Open Dialog received it. This gives the error 89FF now (NO_FILES_FOUND_ERROR).
P.S. I compiled the test with Delphi 2007. May be there is a structure problem of the top structure. I haven't checked the byte length and alignment. Will do so.
// netware records and function definitions
type
// sizeof(NW_EXT_FILE_INFO) should be 140 bytes - check byte alignment
NW_EXT_FILE_INFO = record
sequence: integer;
parent: integer;
attributes: integer;
uniqueID: shortint;
flags: shortint;
nameSpace: shortint;
nameLength: shortint;
name: array[0..11] of shortint;
creationDateAndTime: integer;
ownerID: integer;
lastArchiveDateAndTime: integer;
lastArchiverID: integer;
updateDateAndTime: integer;
lastUpdatorID: integer;
dataForkSize: integer;
dataForkFirstFAT: integer;
nextTrusteeEntry: integer;
reserved: array[0..35] of shortint;
inheritedRightsMask: word;
lastAccessDate: word;
deletedFileTime: integer;
deletedDateAndTime: integer;
deletorID: integer;
reserved2: array[0..15] of shortint;
otherForkSize: array[0..1] of integer;
end;
// functions defined in CALWIN32.DLL
TNWCallsInit = function(reserved1: pointer;
reserved2: pointer): integer; stdcall;
TNWCallsTerm = function(reserved: pointer): integer; stdcall;
TNWParseNetWarePath = function(const path: pchar; var conn: cardinal;
var dirhandle: cardinal; newpath: pchar): integer; stdcall;
TNWAllocTemporaryDirectoryHandle = function(conn: cardinal;
dirhandle: cardinal; const path: pchar; var newdirhandle: cardinal;
rightsmask: pshortint): integer; stdcall;
TNWDeallocateDirectoryHandle = function(conn: cardinal;
dirhandle: cardinal): integer; stdcall;
TNWIntScanExtendedInfo = function(conn: cardinal; dirhandle: cardinal;
attrs: shortint; iterhandle: Pinteger; const searchPattern: pchar;
var entryinfo: NW_EXT_FILE_INFO; augmentflag: shortint): integer;
stdcall;
TNWGetObjectName = function(conn: cardinal; objID: integer;
objname: pchar; objtype: pword): integer; stdcall;
const
FA_NORMAL = $00;
FA_HIDDEN = $02;
FA_SYSTEM = $04;
// return codes
SUCCESSFUL = $00;
NOT_MY_RESOURCE = $883C;
// get file owner for Netware server file
function GetNetwareFileOwner(const FilePath: string): string;
var
hcalwin: HINST;
NWCallsInit: TNWCallsInit;
NWParseNetWarePath: TNWParseNetWarePath;
NWAllocTemporaryDirectoryHandle: TNWAllocTemporaryDirectoryHandle;
NWIntScanExtendedInfo: TNWIntScanExtendedInfo;
NWGetObjectName: TNWGetObjectName;
NWDeallocateDirectoryHandle: TNWDeallocateDirectoryHandle;
NWCallsTerm: TNWCallsTerm;
hconn,
hdir,
retcode: cardinal;
filedir: string; { DOS path of parent folder
(upper case) }
nwfilename: string; { DOS filename (upper case) }
nwfiledir: array[0..255] of char; { Netware path of
parent folder }
rights: shortint;
i: integer;
entryinfo: NW_EXT_FILE_INFO;
objtype: word;
begin
Result := '';
// load netware client library and required functions
hcalwin := LoadLibrary('calwin32.dll');
if hcalwin<=0 then exit; // netware client not present on PC
#NWCallsInit := GetProcAddress(hcalwin,'NWCallsInit');
#NWParseNetWarePath := GetProcAddress(hcalwin,'NWParseNetWarePath');
#NWAllocTemporaryDirectoryHandle := GetProcAddress(hcalwin,
'NWAllocTemporaryDirectoryHandle');
#NWIntScanExtendedInfo :=
GetProcAddress(hcalwin,'NWIntScanExtendedInfo');
#NWGetObjectName := GetProcAddress(hcalwin,'NWGetObjectName');
#NWDeallocateDirectoryHandle := GetProcAddress(hcalwin,
'NWDeallocateDirectoryHandle');
#NWCallsTerm := GetProcAddress(hcalwin,'NWCallsTerm');
// initialise netware libs
if NWCallsInit(nil,nil)<>SUCCESSFUL then exit;
try
filedir := AnsiUpperCase(ExtractFileDir(FilePath));
retcode := NWParseNetWarePath(pchar(filedir),hconn,hdir,nwfiledir);
if retcode=NOT_MY_RESOURCE then exit; // local or non-netware disk
// get a dir handle
NWAllocTemporaryDirectoryHandle(hconn,0,nwfiledir,hdir,#rights);
// get the file info
i := -1;
nwfilename := AnsiUpperCase(ExtractFileName(FilePath));
retcode := NWIntScanExtendedInfo(hconn,hdir,
FA_NORMAL+FA_SYSTEM+FA_HIDDEN,
#i,pchar(nwfilename),entryinfo,0);
if retcode=SUCCESSFUL then begin
// get file owner name from ID
SetLength(Result,MAX_PATH);
retcode := NWGetObjectName(hconn,entryinfo.ownerID,
pchar(Result),#objtype);
if retcode=SUCCESSFUL then
SetLength(Result,Length(Result)) // got owner
else SetLength(Result,0); // failed to get owner
end;
// deallocate dir handle
NWDeallocateDirectoryHandle(hconn,hdir);
finally
// clean up
NWCallsTerm(nil);
FreeLibrary(hcalwin);
end;
end;
Are you sure about stdcall? Tru cdecl and so on.
Also, You done give information about delphi's version.
If you use a version BEFORE delphi2009 pchar is a one-byte char.
But if you use delphi2009 or next, pchar is 2 byte char.
So, if you need one byte char you must use PAnsiChar insthead.
I don't know if netware dll parameters are unicode or ansi...
Cher.
A.

openssl error "assertion failed" during EVP_EncryptFinal_ex, delphi

While working with openSSL library, I met a problem with EVP_EncryptFinal_ex.
Concretely, it fails with fatal error ./crypto/evp/evp_enc.c(348) OpenSSL internal error, assertion failed: b <= sizeof ctx -> buf every time, not depending on algorithm (aes or des).
Here is my code. It is simplified as much as possible.
procedure AESTest;
var
key : TBytes;
keyLen : Integer;
dataIn : string;
dataOut : TBytes;
inLen, outLen, resLen : integer;
// Context of an algorithm pointer
e_ctx : Pointer;
begin
// 256 bit key
keyLen := 32;
setlength(key, KeyLen);
RAND_bytes(#(key[0]), KeyLen);
// Input data to encrypt
dataIn := 'Simple data of 29 bits length';
inLen := length(dataIn);
// Init ctx
e_ctx := EVP_CIPHER_CTX_new();
EVP_CIPHER_CTX_init(e_ctx);
EVP_EncryptInit_ex(e_ctx, EVP_aes_256_cbc, nil, #key[0], nil);
// Prepare ouput buf in order to openSSL docs
outLen := inLen + EVP_CIPHER_CTX_block_size(e_ctx) - 1;
setlength(dataOut, outLen);
EVP_EncryptUpdate(e_ctx, #dataOut[0], outLen, #dataIn[1], inLen);
EVP_EncryptFinal_ex(e_ctx, #dataOut[outLen], resLen);
outLen := outLen + resLen;
setlength(dataOut, outLen);
// ... here goes decryption part but it does not matter now
end;
Just to be precise, imports used:
const
LIB_DLL_NAME = 'libeay32.dll';
type
PEVP_CIPHER_CTX : Pointer;
PEVP_CIPHER : Pointer;
function EVP_CIPHER_CTX_new : PEVP_CIPHER_CTX; cdecl; external LIB_DLL_NAME;
procedure EVP_CIPHER_CTX_init(a: PEVP_CIPHER_CTX); cdecl; external LIB_DLL_NAME;
function EVP_aes_256_cbc : PEVP_CIPHER_CTX; cdecl; external LIB_DLL_NAME;
function RAND_bytes(Arr : PByte; ArrLen : integer) : integer; cdecl; external LIB_DLL_NAME;
function EVP_CIPHER_CTX_block_size(ctx: PEVP_CIPHER_CTX): integer; cdecl; external LIB_DLL_NAME;
function EVP_EncryptInit_ex(ctx: PEVP_CIPHER_CTX; cipher_type: PEVP_CIPHER; Engine : Pointer; key: PByte; iv: PByte): integer; cdecl; external LIB_DLL_NAME;
function EVP_EncryptUpdate(ctx: PEVP_CIPHER_CTX; data_out: PByte; var outl: integer; data_in: PByte; inl: integer): integer; cdecl; external LIB_DLL_NAME;
function EVP_EncryptFinal_ex(ctx: PEVP_CIPHER_CTX; data_out: PByte; var outl: integer): integer; external LIB_DLL_NAME;
I actually tried to read source codes (evp_enc.c) and found the assertion:
OPENSSL_assert(b <= sizeof ctx->buf);
Here b is size of a block for current cypher. This assertion makes sense, but still I can't figure out how it could be failed in my code.
I am trying to beat this problem for a couple of days already, and I would be grateful for any advices.
UPDATE: Here are two lines from evp_enc.c:
b=ctx->cipher->block_size;
OPENSSL_assert(b <= sizeof ctx->buf);
according to the code, b is a size of block for current cipher, for aes_256_cbc it is 16 bit long.
The problem is in your declaration of the function EVP_EncryptFinal_ex. You shoud add cdecl directive (like in all other functions).
So, the new declaration will be:
function EVP_EncryptFinal_ex(ctx: PEVP_CIPHER_CTX; data_out: PByte; var outl: integer): integer; cdecl; external LIB_DLL_NAME;

Delphi: working with Pointer functions

I'm new in delphi, my program developed in delphi working with a dll developed in C++, I need working with pointer functions that throw exceptions of Access Violation address and after many test I don't know how resolve It.
this is defintion of the pointer function in delphi that translate since header c++
type
TMICRCallback = function: Integer of Object; stdcall;
TStatusCallback = function(dwParam: Cardinal): Integer of Object; stdcall;
type
TBiMICRSetReadBackFunction =
function(const nHande: Integer;
pMicrCB: TMICRCallback;
var pReadBuffSize: Byte;
var readCharBuff: Byte;
var pStatus: Byte;
var pDetail: Byte
): Integer; stdcall;
var
BiMICRSetReadBackFunction: TBiMICRSetReadBackFunction;
type
TBiMICRSetReadBackFunction =
function(const nHande: Integer;
pMicrCB: TMICRCallback;
var pReadBuffSize: Byte;
var readCharBuff: Byte;
var pStatus: Byte;
var pDetail: Byte
): Integer; stdcall;
var
BiMICRSetReadBackFunction: TBiMICRSetReadBackFunction;
this is a code that call the pointer functions
type
function CBMICRRead : Integer; stdcall;
function CBMICRStatus(dwStatus: LongWord) : Integer; stdcall;
Respuesta : TMICRCallback;
Estado : TStatusCallback;
BiSetStatusBackFunction(m_hApi, Estado);
BiMICRSetReadBackFunction (m_hApi,
Respuesta,
m_MICRReadBuffSize,
m_MICRReadBuff[0],
m_MICRReadStatus,
m_MICRReadStDetail);
This is the C++ side of the interface:
typedef int (CALLBACK* MICRCallback)(void);
typedef int (CALLBACK* StatusCallback)(DWORD);
int WINAPI BiSetStatusBackFunction(int nHandle,
int (CALLBACK *pStatusCB)(DWORD dwStatus));
int WINAPI BiMICRSetReadBackFunction(int nHandle,
int (CALLBACK *pMicrCB)(void),
LPBYTE pReadBuffSize,
LPBYTE readCharBuff,
LPBYTE pStatus,
LPBYTE pDetail);
You must avoid Object as passing parameters from/to DLL function call result.
TMICRCallback = function: Integer; stdcall;
TStatusCallback = function(dwParam: Cardinal): Integer; stdcall;

Resources