Is there any way to call a procedure by its name in a String variable in Ada, as Python does with:
def _ssh(hostname, port):
pass
def _telnet(hostname, port):
pass
def _mosh(hostname, port):
pass
protocols = {
'ssh': _ssh,
'mosh': _mosh,
'telnet': _telnet
}
# call your function by string
hostname = 'localhost'
port = '22'
protocol = 'ssh'
result = protocols[protocol](hostname, port)
Well, it’s a bit of work, since you don't have any convenient shorthand for creating maps (a.k.a. dictionaries). This does the job:
with Ada.Containers.Indefinite_Ordered_Maps;
with Ada.Text_IO; use Ada.Text_IO;
procedure Alubio is
We need a pointer-to-subprogram to instantiate the Map
type Handler is access procedure (Hostname : String; Port : Integer);
A map from string to the pointer-to-subprogram. It needs to be "indefinite" because the type String is indefinite (not fixed-size), and it needs to be "ordered" because we don’t want the bother of declaring hash functions etc.
package Maps is new Ada.Containers.Indefinite_Ordered_Maps
(Key_Type => String,
Element_Type => Handler);
I like to declare subprograms before defining them, but it’s not strictly necessary here
procedure Ssh (Hostname : String; Port : Integer);
procedure Mosh (Hostname : String; Port : Integer);
procedure Telnet (Hostname : String; Port : Integer);
The Map
Map : Maps.Map;
The demo subprograms
procedure Ssh (Hostname : String; Port : Integer) is
begin
Put_Line ("ssh, " & Hostname & Port'Image);
end Ssh;
procedure Mosh (Hostname : String; Port : Integer) is
begin
Put_Line ("mosh, " & Hostname & Port'Image);
end Mosh;
procedure Telnet (Hostname : String; Port : Integer) is
begin
Put_Line ("telnet, " & Hostname & Port'Image);
end Telnet;
begin
Set up the Map
Map.Insert ("ssh", Ssh'Access);
Map.Insert ("mosh", Mosh'Access);
Map.Insert ("telnet", Telnet'Access);
Call the subprograms via the Map. Not quite sure why the .all (dereferencing the pointer-to-subprogram) is needed, you often don’t: here, without it, the compiler says "invalid procedure or entry call", pointing at Map.
Map ("ssh").all ("s", 1);
Map ("mosh").all ("m", 2);
Map ("telnet").all ("t", 3);
end Alubio;
The output:
$ ./alubio
ssh, s 1
mosh, m 2
telnet, t 3
A simple way is to use an enumerated type and a case statement.
type Protocol is (ssh, mosh, telnet);
then with a variable given_protocol : Protocol :
case given_protocol is
when ssh => Ssh (Hostname, Port);
when mosh => Mosh (Hostname, Port);
when telnet => Telnet (Hostname, Port);
end case;
This avoids access types and maps.
You get given_protocol from a String by using the 'Value attribute: given_protocol := Protocol'Value (given_string).
From what I know, this is not possible as Ada doesn't store the functions and procedures in a hashmap as Python do.
You can still provide a function taking the string as argument and returning an access to the function that you can call afterwards but I'm not sure that's what you're trying to do.
Related
I am learning Ada and I've hit a design problem. Excuse me as I'm not up with basic Ada mechanisms and idioms.
Let's say I want to represent an operation. Operators can be either plus or minus and operands can be either integers or strings.
Disclaimer: some things may not make much sense on a semantic level (minus on strings, operators without operands, ...) but it's all about representation.
For now I have the following incorrect code:
operand.ads:
package Operand is
-- I want a None for unary operands or operators without operands
type Operand_Type is (Int, Str, None);
-- This needs to be tagged
type Instance (Op_Type : Operand_Type := None) is tagged record
case Op_Type is
when Int =>
Int_Value : Integer;
when Str =>
Str_Value : String (1 .. 10);
when None =>
null;
end case;
end record;
-- Some methods on operands...
end Operand;
operation.ads:
with Operand;
package Operation is
type Operation_Type is (Plus, Minus);
-- This also needs to be tagged
type Instance is tagged record
Left, Right : Operand.Instance;
end record;
-- Some methods on operations...
end Operation;
main.adb:
with Operand;
with Operation;
procedure Main is
Op : Operation.Instance;
begin
Op.Left := (Op_Type => Operand.Int, Int_Value => 1);
Op.Right := (Op_Type => Operand.Int, Int_Value => 3);
end Main;
When I try to compile I get the following errors:
$ gnatmake main.adb
gcc -c main.adb
operand.ads:7:45: discriminants of nonlimited tagged type cannot have defaults
operation.ads:9:28: unconstrained subtype in component declaration
gnatmake: "main.adb" compilation error
I get why I can't use defaults on tagged type's discriminant but I don't really know how to get around this limitation.
Proposal 1:
Stop using variant records and use a record with one field for each operand. But I feel like this is just throwing away code elegance.
Proposal 2:
Remove defaults from Operand.Instance record and constrain Left and Right from Operation.Instance record. But I get a runtime error :
raised CONSTRAINT_ERROR : main.adb:7 discriminant check failed
As I cannot dynamically change discriminant value of a record's field.
Any help would be much appreciated !
Jim Rogers already discussed using inheritance. You can also use composition if you like by creating an internal non tagged type (which allows defaults), make the Operand.Instance type tagged private, have the private implementation use the internal non tagged version, and just add what operations you need to set and get the operands:
with Ada.Text_IO; use Ada.Text_IO;
procedure Hello is
package Operand is
-- I want a None for unary operands or operators without operands
type Operand_Type is (Int, Str, None);
Invalid_Operand : exception;
-- This needs to be tagged
type Instance is tagged private;
function Int_Value(Value : Integer) return Instance;
function Str_Value(Value : String) return Instance;
function Null_Instance return Instance;
function Int_Value(Self : Instance) return Integer;
function Str_Value(Self : Instance) return String;
function Op_Type(Self : Instance) return Operand_Type;
-- Some methods on operands...
private
type Instance_Internal (Op_Type : Operand_Type := None) is record
case Op_Type is
when Int =>
Int_Value : Integer;
when Str =>
Str_Value : String (1 .. 10);
when None =>
null;
end case;
end record;
type Instance is tagged record
Impl : Instance_Internal;
end record;
function Int_Value(Value : Integer) return Instance is (Impl => (Int, Value));
function Str_Value(Value : String) return Instance is (Impl => (Str, Value));
function Null_Instance return Instance is (Impl => (Op_Type => None));
function Int_Value(Self : Instance) return Integer
is (if Self.Impl.Op_Type = Int then Self.Impl.Int_Value else raise Invalid_Operand);
function Str_Value(Self : Instance) return String
is (if Self.Impl.Op_Type = Str then Self.Impl.Str_Value else raise Invalid_Operand);
function Op_Type(Self : Instance) return Operand_Type
is (Self.Impl.Op_Type);
end Operand;
package Operation is
type Operation_Type is (Plus, Minus);
-- This also needs to be tagged
type Instance is tagged record
Left, Right : Operand.Instance;
end record;
-- Some methods on operations...
end Operation;
Op : Operation.Instance;
begin
Put_Line("Hello, world!");
Op.Left := Operand.Int_Value(1);
Op.Right := Operand.Int_Value(3);
Put_Line(Integer'Image(Op.Left.Int_Value));
Put_Line(Integer'Image(Op.Right.Int_Value));
end Hello;
You can break the Operand package into spec and body for better readability, this was just for example.
In my test code below, I am trying to modify a variable by passing it as system.address to another procedure.
with Ada.Text_IO;
with System;
with System.Storage_Elements;
procedure Main is
procedure Modify ( Var : in out System.Address) is
use System.Storage_Elements;
begin
Var := Var + 10;
end Modify;
My_Var : Integer := 10;
begin
-- Insert code here.
Modify (My_Var'Address);
Ada.Text_IO.Put_Line("My_Var is:" & Integer(My_Var)'Image );
end Main;
Compiler is returning an error as below,
17:17 actual for "Var" must be a variable
I could not understand the reason as My_Var(actual for Var) is clearly a variable. What should I change to modify My_Var with system.address?
Note: The context of this trail is that I am trying to understand an interface module in an existing legacy project. While there could be better ways to achieve what I need, I want to understand if it is possible to modify a variable with above method.
It would be helpful if you could show the relevant part of the legacy interface module -- it would help us understand what you need and want to do.
That said, first note that passing a parameter by reference is not usually done in Ada by explicitly passing the 'Address of the actual variable. As you say, there are other and better ways.
If you pass a System.Address value, and then want to read or write whatever data resides at that address, you have to do the read/write through a variable that you force to have that address, or through an access value (the Ada equivalent of "pointer") that you force to point at that addressed location. In both cases, you are responsible for ensuring that the type of the variable, or of the access value, matches the actual type of the data that you want to read or write.
To create an access value that points to memory at a given address, you should use the predefined package System.Address_To_Access_Conversions. That requires some understanding of access values and generics, so I won't show an example here.
To force a variable to have a given address, you declare the variable with the Address aspect set to the given address. The code below shows how that can be done for this example. Note the declaration of the local variable Modify.Var (and note that I changed the name of the parameter from Var to Var_Addr).
with Ada.Text_IO;
with System;
procedure Mod_By_Addr is
procedure Modify (Var_Addr : in System.Address) is
Var : Integer with Address => Var_Addr;
begin
Var := Var + 10;
end Modify;
My_Var : aliased Integer := 10;
begin
Modify (My_Var'Address);
Ada.Text_IO.Put_Line("My_Var is:" & Integer(My_Var)'Image );
end Mod_By_Addr;
Since the Var_Addr parameter is not modified in the Modify procedure, it can be declared with the "in" mode, and so the actual parameter can be an expression (My_Var'Address).
HTH
You modify the address and not the variable. Try to change parameter to Addr : in System.Address and declare Var : Integer with Address => Addr in Modify.
Another way of modifying the variable I have understood using address_to_Access_Conversions is shown below,
with Ada.Text_IO;
with System.Address_To_Access_Conversions;
with System.Storage_Elements;
procedure Main is
procedure Modify ( Var : in System.Address) is
use System.Storage_Elements;
package Convert is new System.Address_To_Access_Conversions (Integer);
begin
Ada.Text_IO.Put_Line(Convert.To_Pointer (Var).all'Img);
end Modify;
My_Var : Integer := 10;
begin
Modify (My_Var'Address);
Ada.Text_IO.Put_Line("My_Var is:" & Integer(My_Var)'Image );
end Main;
I call a function from DLL-file in Inno Setup Script and its return type is PAnsiChar.
In order to get the whole string I need to dereference the pointer but the standard pascal syntax doesn't work here.
Is it even possible to do that?
function SQLDLL : PAnsiChar;
external 'GetSQLServerInstances#files:IsStartServer.dll stdcall setuponly';
function NextButtonClick(CurPage: Integer): Boolean;
var
hWnd: Integer;
Str : AnsiString;
begin
if CurPage = wpWelcome then begin
hWnd := StrToInt(ExpandConstant('{wizardhwnd}'));
MessageBox(hWnd, 'Hello from Windows API function', 'MessageBoxA', MB_OK or MB_ICONINFORMATION);
MyDllFuncSetup(hWnd, 'Hello from custom DLL function', 'MyDllFunc', MB_OK or MB_ICONINFORMATION);
Str := SQLDLL;
try
{ if this DLL does not exist (it shouldn't), an exception will be raised }
DelayLoadedFunc(hWnd, 'Hello from delay loaded function', 'DllFunc', MB_OK or MB_ICONINFORMATION);
except
{ handle missing dll here }
end;
end;
Result := True;
end;
I have only the DLL-file. The original language is Delphi.
I updated to the latest version of Inno Setup 6.0.3 and tested this code on my home Windows 10 Pro machine:
[Setup]
AppName=My Program
AppVersion=1.5
WizardStyle=modern
DefaultDirName={autopf}\My Program
DisableProgramGroupPage=yes
DisableWelcomePage=no
UninstallDisplayIcon={app}\MyProg.exe
OutputDir=userdocs:Inno Setup Examples Output
[Files]
Source: "MyProg.exe"; DestDir: "{app}"
Source: "MyProg.chm"; DestDir: "{app}"
Source: "Readme.txt"; DestDir: "{app}"; Flags: isreadme
Source: "IsStartServer.dll"; Flags: dontcopy
[Code]
function SQLDLL : PAnsiChar;
external 'GetSQLServerInstances#files:IsStartServer.dll stdcall';
function NextButtonClick(CurPage: Integer): Boolean;
var
Str : PAnsiChar;
begin
Str := SQLDLL;
Result := True;
end;
and now I'm having this kind of error:
I don't understand why does it have to look into my 'temp' directory? I've also heard that this problem may somehow be connected with the group policies in Windows 10 UAC, but I'm not really sure what should I do here to get rid of this error.
If I understand correctly, your SQLDLL manages some memory buffer itself and returns a pointer to a Unicode string (not ANSI, that's why you got only one character when you tried PAnsiChar, according to your comment).
Inno Setup doesn't support this directly and doesn't even have a PWideChar type. However, we can handle it ourselves. We just have to allocate a Inno string with the right size and copy the data manually.
Here is a working example how to do that. It uses GetCommandLineW as an example function that returns a PWideChar, but you can do the same with your SQLDLL function.
Get the pointer from the external function and store it in a variable (a Cardinal - in my example I created a typedef PWideChar for it).
Get the string length using lstrlenW.
Create an empty regular String, but set it to the right length using SetLength. This will reserve enough capacity that we can write the actual contents into it in the next step.
Use lstrcpyW to copy the string that's referenced by the pointer to your regular String variable.
(In case you use the ANSI version of Inno Setup: Use WideCharToMultiByte instead, see my update at the end of this post.)
The trick is to import lstrcpyW in such a way that the destination pointer is declared as String but the source pointer is declared as Cardinal (or my typedef PWideChar here).
type
PWideChar = Cardinal; { Inno doesn't have a pointer type, so we use a Cardinal instead }
{ Example of a function that returns a PWideChar }
function GetCommandLineW(): PWideChar;
external 'GetCommandLineW#kernel32.dll stdcall';
{ This function allows us to get us the length of a string from a PWideChar }
function lstrlenW(lpString: PWideChar): Cardinal;
external 'lstrlenW#kernel32.dll stdcall';
{ This function copies a string - we declare it in such a way that we can pass a pointer
to an Inno string as destination
This works because Inno will actually pass a PWideChar that points to the start of the
string contents in memory, and internally the string is still null-terminated
We just have to make sure that the string already has the right size beforehand! }
function lstrcpyW_ToInnoString(lpStringDest: String; lpStringSrc: PWideChar): Integer;
external 'lstrcpyW#kernel32.dll stdcall';
function InitializeSetup(): Boolean;
var
returnedPointer: PWideChar; { This is what we get from the external function }
stringLength: Cardinal; { Length of the string we got }
innoString: String; { This is where we'll copy the string into }
begin
{ Let's get the PWideChar from the external function }
returnedPointer := GetCommandLineW();
{ The pointer is actually just a renamed Cardinal at this point: }
Log('String pointer = ' + IntToStr(returnedPointer));
{ Now we have to manually allocate a new Inno string with the right length and
copy the data into it }
{ Start by getting the string length }
stringLength := lstrlenW(returnedPointer);
Log('String length = ' + IntToStr(stringLength));
{ Create a string with the right size }
innoString := '';
SetLength(innoString, stringLength);
{ This check is necessary because an empty Inno string would translate to a NULL pointer
and not a pointer to an empty string, and lstrcpyW cannot handle that. }
if StringLength > 0 then begin
{ Copy string contents from the external buffer to the Inno string }
lstrcpyW_ToInnoString(innoString, returnedPointer);
end;
{ Now we have the value stored in a proper string variable! }
Log('String value = ' + innoString);
Result := False;
end;
If you put this into an installer and run it, you see output like this:
[15:10:55,551] String pointer = 9057226
[15:10:55,560] String length = 106
[15:10:55,574] String value = "R:\Temp\is-9EJQ6.tmp\testsetup.tmp" /SL5="$212AC6,121344,121344,Z:\Temp\testsetup.exe" /DEBUGWND=$222722
As you can see, the command line string (which we get as a PWideChar) is copied to a regular string variable correctly and can be accessed normally at the end.
Update: In case you are using the ANSI version of Inno Setup and not Unicode, this code alone won't work. The change needed is this: Instead of using lstrcpyW, you'd use WideCharToMultiByte:
function WideCharToMultiByte_ToInnoString(CodePage: Cardinal; dwFlags: Cardinal; lpWideCharStr: PWideChar; cchWideChar: Cardinal; lpMultiByteStr: String; cbMultiByte: Cardinal; lpDefaultChar: Cardinal; lpUsedDefaultChar: Cardinal): Integer;
external 'WideCharToMultiByte#kernel32.dll stdcall';
{ Later on: Instead of calling lstrcpyW_ToInnoString, use this:
Note: The first parameter 0 stands for CP_ACP (current ANSI code page), and the
string lengths are increased by 1 to include the null terminator }
WideCharToMultiByte_ToInnoString(0, 0, returnedPointer, stringLength + 1, innoString, stringLength + 1, 0, 0);
You cannot dereference a pointer in Inno Setup Pascal Script.
But there are numerous hacks that allow that. Those hacks are very specific, so it depends on particular use case.
Though in your specific case, as pointers to character arrays are widespread in APIs, Inno Setup Pascal Script (similarly to Delphi) can assign a pointer to a character array to a string.
So, you should be able to simply assign the PChar to AnsiString:
function ReturnsPAnsiChar: PAnsiChar; extern '...';
var
Str: AnsiString;
begin
Str := ReturnsPAnsiChar;
end;
See How to return a string from a DLL to Inno Setup?
I'm interfacing to a USB device (on Debian Stretch) using hidraw, and I need to process some information supplied by the USB device in the form of wchar_t* which I need to convert into (Ada) Wide_String. This is giving some trouble and I'm not seeing a clean way forward using the facilities in Interfaces.C and Interfaces.C.Strings.
All files are edited down without destroying their consistency. They will build, but without one of these, they won't actually run.
The problem is that device information like Serial Number and Product Name are presented by the Linux device driver as an access stddef_h.wchar_t from which I want to return a Wide_String or even a normal String) and I'm not seeing any good way to get there.
Interfaces.C.Strings has function Value (Item : in chars_ptr) return String; but no equivalent exists for Wide_String that I can see. So I think I need an equivalent Value function for wide characters.
The approach below uses To_Ada (from Interfaces.C) to return a Wide_String given a wchar_array. It fails, of course, because an access wchar_t is not convertible to a wchar_array.
-- helper function to deal with wchar_t * to wide_string
function Value (P : access stddef_h.wchar_t) return Wide_String is
temp : Wide_String(1 .. 256);
count : natural := 0;
-- ugliness to convert pointer types
type sd_wchar_ptr is access all stddef_h.wchar_t;
type wchar_array_ptr is access wchar_array;
Function To_Wchar_Array_Ptr is new Ada.Unchecked_Conversion(sd_wchar_ptr, wchar_array_ptr);
-- this does NOT create the required wchar_array pointer
WCP : wchar_array_ptr := To_Wchar_Array_Ptr(sd_wchar_ptr(P));
begin
Put_Line("Wide string");
To_Ada(WCP.all, temp, count);
Put_Line("Wide string length " & natural'image(count));
return temp(1..count);
end Value;
and the inevitable result
./test_hid
Wide string
Execution terminated by unhandled exception raised STORAGE_ERROR :
stack overflow or erroneous memory access
A similar character by character approach would be possible ... if (and I can't believe I'm saying this!) you could increment access types...
Feels like there's something missing from Interfaces.C here... what am I missing? any ideas to get round this relatively trivial seeming stumbling block?
EDIT : I'm leaning towards some brazen theft from the Interfaces.C.Strings sources with appropriate changes, but I'd welcome alternative suggestions.
The rest of this below is the full story so far (including all code necessary to reproduce)
Step 1 : generate low level Ada bindings automatically using gcc.
gcc -c -fdump-ada-spec-slim /usr/include/hidapi/hidapi.h
producing the low level binding package hidapi_hidapi_h
pragma Ada_2005;
pragma Style_Checks (Off);
with Interfaces.C; use Interfaces.C;
with Interfaces.C.Strings;
with stddef_h;
with System;
package hidapi_hidapi_h is
-- see source file /usr/include/hidapi/hidapi.h
type hid_device_info is record
path : Interfaces.C.Strings.chars_ptr; -- /usr/include/hidapi/hidapi.h:51
vendor_id : aliased unsigned_short; -- /usr/include/hidapi/hidapi.h:53
product_id : aliased unsigned_short; -- /usr/include/hidapi/hidapi.h:55
serial_number : access stddef_h.wchar_t; -- /usr/include/hidapi/hidapi.h:57
release_number : aliased unsigned_short; -- /usr/include/hidapi/hidapi.h:60
manufacturer_string : access stddef_h.wchar_t; -- /usr/include/hidapi/hidapi.h:62
product_string : access stddef_h.wchar_t; -- /usr/include/hidapi/hidapi.h:64
usage_page : aliased unsigned_short; -- /usr/include/hidapi/hidapi.h:67
usage : aliased unsigned_short; -- /usr/include/hidapi/hidapi.h:70
interface_number : aliased int; -- /usr/include/hidapi/hidapi.h:75
next : access hid_device_info; -- /usr/include/hidapi/hidapi.h:78
end record;
pragma Convention (C_Pass_By_Copy, hid_device_info); -- /usr/include/hidapi/hidapi.h:49
function hid_enumerate (arg1 : unsigned_short; arg2 : unsigned_short) return access hid_device_info; -- /usr/include/hidapi/hidapi.h:132
pragma Import (C, hid_enumerate, "hid_enumerate");
end hidapi_hidapi_h;
This is a low level binding, exposing C types (and the binding generator has decided that the wchar_t in Interfaces.C isn't good enough, it wants one from stddef.h too, so...
pragma Ada_2005;
pragma Style_Checks (Off);
with Interfaces.C; use Interfaces.C;
package stddef_h is
-- unsupported macro: NULL ((void *)0)
subtype size_t is unsigned_long; -- /usr/lib/gcc/x86_64-linux-gnu/6/include/stddef.h:216
subtype wchar_t is int; -- /usr/lib/gcc/x86_64-linux-gnu/6/include/stddef.h:328
end stddef_h;
Because it is a low level binding; we want to hide it (and implement RAII etc) behind a simpler and more usable high level binding, so ... (below)
with Ada.Finalization; use Ada.Finalization;
private with hidapi_hidapi_h;
private with System;
package hidapi is
type id is new natural range 0 .. 2**16 - 1;
type hid_device is new Limited_Controlled with private;
-- find first matching devices by enumeration : the RA part of RAII.
function enumerate (vendor_id, product_id : id) return hid_device;
-- accessors for device characteristics on enumerated device
function Serial_No (D : hid_device) return Wide_String;
function Product_String (D : hid_device) return Wide_String;
private
type hid_device is new Limited_Controlled with record
member : access hidapi_hidapi_h.hid_device_info;
addr : System.Address;
end record;
end hidapi;
and its implementation, containing the problem function value to return a Wide_String.
with hidapi_hidapi_h;
with Interfaces.C; use Interfaces.C;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Conversion;
with stddef_h;
package body hidapi is
function enumerate (vendor_id, product_id : id) return hid_device is
use hidapi_hidapi_h;
first : access hid_device_info;
begin
first := hid_enumerate(unsigned_short(vendor_id), unsigned_short(product_id));
if first /= null then
return H : hid_device do
H.member := first;
H.addr := System.Null_Address;
end return;
else raise Program_Error;
end if;
end enumerate;
-- helper function to deal with wchar_t * to wide_string
function Value (P : access stddef_h.wchar_t) return Wide_String is
temp : Wide_String(1 .. 256);
count : natural := 0;
type sd_wchar_ptr is access all stddef_h.wchar_t;
type wchar_array_ptr is access wchar_array;
Function To_Wchar_Array_Ptr is new Ada.Unchecked_Conversion(sd_wchar_ptr, wchar_array_ptr);
WCP : wchar_array_ptr := To_Wchar_Array_Ptr(sd_wchar_ptr(P));
begin
Put_Line("Wide string");
To_Ada(WCP.all, temp, count);
Put_Line("Wide string length " & natural'image(count));
return temp(1..count);
end Value;
function Serial_No (D : hid_device) return Wide_String is
use hidapi_hidapi_h;
begin
return Value(D.member.serial_number);
end Serial_No;
function Product_String (D : hid_device) return Wide_String is
use hidapi_hidapi_h;
begin
return Value(D.member.product_string);
end Product_String;
end hidapi;
And of course a test case to exercise it...
with Hidapi;
with Ada.Wide_Text_IO;
procedure Test_Hid is
usbrelay_vendor_id : constant Hidapi.id := 16#16c0#;
usbrelay_product_id : constant Hidapi.id := 16#05df#;
Device : Hidapi.hid_device := Hidapi.Enumerate(usbrelay_vendor_id, usbrelay_product_id);
begin
Ada.Wide_Text_IO.Put_Line("Serial : " & Device.Serial_No);
Ada.Wide_Text_IO.Put_Line("Product : " & Device.Product_String);
end Test_Hid;
One answer, slavishly copying the approach in the package body for Tnterfaces.C.Strings with necessary changes.
The naughty stuff is in functions "+" and Peek which use Unchecked Conversions on pointers,
to permit address arithmetic. Not pointer increment, but pointer+offset. One change is that the offset has to be scaled for 4 byte characters. I haven't set that scaling in a portable manner, but note that "+" will overload for each different return type so that offsets will be scaled appropriately for different named access types.
to allow the stddef_h.wchar_t to be viewed as a Wide_Wide_Character in the absence of any type conversion function. Whether the representation is correct is another matter (here, it is) but this technique could also be used to fake the input type of a suitable conversion function like To_Ada in Interfaces.C.
The remainder is straightforward character by character handling. One other change (so far) is to return Wide_Wide_Character rather than Wide_Character (because as the stddef_h package above reveals, the stored characters are 32 bit, same size as Interfaces.C.int. I'm happy to change my interface, but Wide_String could be easily handled by Ada.Strings packages.
type sd_wchar_ptr is access all stddef_h.wchar_t;
type w_w_char_ptr is access all char32_t;
-- Two Unchecked_Conversions to allow pointer arithmetic
-- And a third to allow the resulting storage to be interpreted as Wide_Wide_Char
function To_Sd_wchar_ptr is new Ada.Unchecked_Conversion (System.Address, sd_wchar_ptr);
function To_Address is new Ada.Unchecked_Conversion (sd_wchar_ptr, System.Address);
function To_Wchar_Ptr is new Ada.Unchecked_Conversion (sd_wchar_ptr, w_w_char_ptr);
-- pointer + offset arithmetic, with offset scaled for size of stddef_h.wchar_t;
-- TODO: attempted better way of computing word size ran into type errors
function "+" (Left : sd_wchar_ptr; Right : size_t) return sd_wchar_ptr is
begin
return To_Sd_wchar_ptr (To_Address (Left) + Storage_Offset (Right) * 4);
end "+";
function Peek (From : sd_wchar_ptr) return char32_t is
begin
return To_Wchar_Ptr(From).all;
end Peek;
function Strlen (Item : sd_wchar_ptr) return size_t is
Item_Index : size_t := 0;
begin
if Item = Null then
raise Program_Error;
end if;
loop
if Peek (Item + Item_Index) = char32_nul then
return Item_Index;
end if;
Item_Index := Item_Index + 1;
end loop;
end Strlen;
function Value (Item : sd_wchar_ptr) return char32_array is
Result : char32_array (0 .. Strlen (Item));
begin
if Item = Null then
raise Program_Error;
end if;
Put_Line("String length " & size_t'image(Strlen(Item)));
-- Note that the following loop will also copy the terminating Nul
for J in Result'Range loop
Result (J) := Peek (Item + J);
end loop;
return Result;
end Value;
-- helper function to deal with wchar_t * to wide_wide_string
function Value (Item : access stddef_h.wchar_t) return Wide_Wide_String is
begin
return To_Ada (Value (sd_wchar_ptr(Item)));
end Value;
I am trying to write a proxy server in Indy to receive HTTPS calls from external clients and forward them in HTTP to another server application on the same machine. Reason is that the other application does not support SSL and so I want to wrap its traffic in an SSL layer for external security.
My current approach is to use a TIdHTTPserver with an SSL IOHandler, and in its OnCommandGet handler I create a TIdHTTP client on the fly which fetches a TFileStream ContentStream from the internal application and returns that stream as the Response.ContentStream to the external caller.
The problem with this approach is the latency caused by having to wait for the internal content stream to be fully received before the external stream can start to be sent. And for example it cannot work for streaming media.
My question is: is there a better way to proxy HTTPS to HTTP that would work for streams? I.e without having to use an intermediate file stream.
If the requesting client supports HTTP 1.1 chunking (see RFC 2616 Section 3.6.1), that would allow you to read data from the target server and send it immediately to the client in real-time.
If you are using a fairly recent version of Indy, TIdHTTP has an OnChunkReceived event, and an hoNoReadChunked flag in its HTTPOptions property:
New TIdHTTP flags and OnChunkReceived event
In your TIdHTTPServer.OnCommand... event handler, you can populate the AResponseInfo as needed. Make sure to:
leave AResponseInfo.ContentText and AResponseInfo.ContentStream unassigned
set AResponseInfo.ContentLength to 0
set AResponseInfo.TransferEncoding to 'chunked'
Then call the AResponseInfo.WriteHeader() method directly, such as in the TIdHTTP.OnHeadersRecceived event, to send the response headers to the client.
Then you can read the target server's response body using OnChunkedReceived or hoNoReadChunked, and write each received chunk to the client using AContext.Connection.IOHandler directly.
However, there are some caveats to this:
if you use the TIdHTTP.OnChunkReceived event, you still need to provide an output TStream to TIdHTTP or else the event is not triggered (this restriction might be removed in a future release). However, you can use TIdEventStream without assigning an OnWrite event handler to it. Or write a custom TStream class that overrides the virtual Write() method to do nothing. Or, just use any TStream you want, and have the OnChunkReceived event handler clear the received Chunk so nothing is available to write to the TStream.
if you use the hoNoReadChunked flag, this allows you to manually read the HTTP chunks from TIdHTTP.IOHandler directly after TIdHTTP exits. Just make sure you enable HTTP keep-alives or else TIdHTTP will close the connection to the server before you have a chance to read the server's response body.
If you are using an older version of Indy, or if the target server does not support chunking, all is not lost. You should be able to write a custom TStream class that overwrites the virtual Write() method to write the provided data block to the client as an HTTP chunk. And then you can use that class as the output TStream for TIdHTTP.
If the client does not support HTTP chunking, or if these approaches do not work for you, then you will likely have to resort to using TIdTCPServer directly instead of TIdHTTPServer and implement the entire HTTP protocol yourself from scratch, then you can handle your own streaming as needed. Have a look at the source code for TIdHTTPProxyServer for some ideas (TIdHTTPProxyServer itself is not suitable for your particular situation, but it will show you how to pass HTTP requests/responses between connections in near real-time in general).
Thank you for the very comprehensive answer. The way I finally solved it was to create a TStream descendent to use as the ContentStream for the server response. The TStream wis a wrapper around a TIdTcpClient which contains a rudimentary HTTP implementation and whose TStream.Read function fetches the HTTP contents for the Tcp connection.
type
TTcpSocketStream = class(TStream)
private
FAuthorization: string;
FBuffer: TBytes;
FBytesRead: Int64;
FCommand: string;
FContentLength: Int64;
FContentType: string;
FDocument: string;
FHeaders: TIdHeaderList;
FHost: string;
FIntercept: TServerLogEvent;
FPort: Integer;
FResponseCode: Integer;
FQueryParams: string;
FTcpClient: TIdTCPClient;
FWwwAuthenticate: string;
public
constructor Create;
destructor Destroy; override;
procedure Initialize;
function Read(var Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
property Authorization: string read FAuthorization write FAuthorization;
property Command: string read FCommand write FCommand;
property ContentType: string read FContentType;
property ContentLength: Int64 read FContentLength;
property Document: string read FDocument write FDocument;
property Host: string read fHost write FHost;
property Intercept: TServerLogEvent read FIntercept write FIntercept;
property Port: Integer read FPort write FPort;
property QueryParams: string read FQueryParams write FQueryParams;
property ResponseCode: Integer read FResponseCode;
property WWWAuthenticate: string read FWwwAuthenticate
write FWwwAuthenticate;
end;
const
crlf = #13#10;
cContentSeparator = crlf+crlf;
implementation
{ TTcpSocketStream }
constructor TTcpSocketStream.Create;
begin
inherited;
FHeaders := TIdHeaderList.Create(QuoteHTTP);
FTcpClient := TIdTcpClient.Create(nil);
FTcpClient.ConnectTimeout := 5000;
FTcpClient.ReadTimeout := 5000;
FCommand := 'GET';
FPort := 443;
FResponseCode := 404;
end;
destructor TTcpSocketStream.Destroy;
begin
if FTcpClient.Connected then
FTcpClient.Disconnect;
if FTcpClient.Intercept <> nil then
begin
FTcpClient.Intercept.Free;
FTcpClient.Intercept := nil;
end;
FTcpClient.Free;
FHeaders.Free;
SetLength(FBuffer, 0);
inherited;
end;
procedure TTcpSocketStream.Initialize;
var
s: string;
LLog: TClientLogEvent;
LRespText: string;
begin
try
if FQueryParams <> '' then
FQueryParams := '?' + FQueryParams;
FTcpClient.Port := FPort;
FTcpClient.Host := FHost;
if FIntercept <> nil then
begin
LLog := TClientLogEvent.Create;
LLog.OnLog := FIntercept.OnLog;
FTcpClient.Intercept := LLog;
end;
FTcpClient.Connect;
if FTcpClient.Connected then
begin
FTcpClient.IOHandler.Writeln(Format('%s %s%s HTTP/1.1',
[FCommand, FDocument, FQueryParams]));
FTcpClient.IOHandler.Writeln('Accept: */*');
if FAuthorization <> '' then
FTcpClient.IOHandler.Writeln(Format('Authorization: %s',
[FAuthorization]));
FTcpClient.IOHandler.Writeln('Connection: Close');
FTcpClient.IOHandler.Writeln(Format('Host: %s:%d', [FHost, FPort]));
FTcpClient.IOHandler.Writeln('User-Agent: Whitebear SSL Proxy');
FTcpClient.IOHandler.Writeln('');
LRespText := FTcpClient.IOHandler.ReadLn;
s := LRespText;
Fetch(s);
s := Trim(s);
FResponseCode := StrToIntDef(Fetch(s, ' ', False), -1);
repeat
try
s := FTcpClient.IOHandler.ReadLn;
except
on Exception do
break;
end;
if s <> '' then
FHeaders.Add(s);
until s = '';
FContentLength := StrToInt64Def(FHeaders.Values['Content-Length'], -1);
FContentType := FHeaders.Values['Content-Type'];
FWwwAuthenticate := FHeaders.Values['WWW-Authenticate'];
end;
except
on E:Exception do ;
end;
end;
function TTcpSocketStream.Read(var Buffer; Count: Integer): Longint;
begin
Result := 0;
try
if FTcpClient.Connected then
begin
if Length(FBuffer) < Count then
SetLength(FBuffer, Count);
FTcpClient.IOHandler.ReadBytes(FBuffer, Count, False);
Move(FBuffer[0], PChar(Buffer), Count);
Inc(FBytesRead, Count);
Result := Count;
end;
except
on Exception do ;
end;
end;
function TTcpSocketStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
Result := 0;
case Origin of
soBeginning: Result := Offset;
soCurrent: Result := FBytesRead + Offset;
soEnd: Result := FContentLength + Offset;
end;
end;