REBOL [ Title: "RebCall system" File: %rebcall.r Date: 15-Dec-2005 Version: 1.0.0 Author: "Pascal Hurni" Library: [ level: 'intermediate platform: 'windows type: [module] domain: [external-library extension win-api] tested-under: [w2k view 1.3.1 view 1.3.2] support: http://mortimer.devcave.net/projects/rebcall license: 'bsd see-also: http://mortimer.devcave.net ] Purpose: { Call DLL functions efficiently with REBOL/View without the need for REBOL/View/Pro or REBOL/Command. This script only works on Windows with a patched REBOL interpreter. Details available at http://mortimer.devcave.net/projects/rebcall Actually only the types that fits in 32 bits are supported for the parameters. Thus decimal! values are not. It could also work on future REBOL/Core, here are the requierements: - get-env has to be defined (and get process environment variables) - struct! datatype must be available. } ] ;-- Already set? if not value? 'rebcall [ ;-- defines operator & and cast* do %addr.r rebcall: make object! [ ;-- Because RebCall starts when WinSock is initialized, use some network function to do so close open udp://127.0.0.1:0 ;-- TCP port of the in-process call handler port-no: to-integer get-env "_REBCALL_PORT" ;-- Protocol: ;-- LoadLibrary 1 0 LibraryName ;-- FreeLibrary 2 hLib ;-- GetProcAddress 3 hLib ProcName ;-- Call (stdcall) 4 pFunc NumOfParam ParamArray ;-- Call (cdecl) 5 pFunc NumOfParam ParamArray cmd-loadlibrary: #{01000000} cmd-freelibrary: #{02000000} cmd-getprocaddress: #{03000000} cmd-call-std: #{04000000} cmd-call-c: #{05000000} ;-- The rebol port connected to the handler call-port: none ;-- The command buffer command: make binary! 128 ;-- The result buffer result: make binary! 4 to-bin: func [value][reverse load join "#{" [to-hex to-integer value "}"]] ;-- Work variables. Defined here, so the global context is not poluated. dummy-string: make struct! [s [string!]] none retval: none ;-- Connect to handler connect: func [ /port portno][ ;-- Already connected? if not call-port [ either error? try [call-port: open/direct/binary join tcp://127.0.0.1: any [portno port-no]][ call-port: none ][ call-port/timeout: 60 ] ] ] ;-- Disconnect from handler disconnect: does [ close call-port call-port: none ] ;-- Test if connected connected?: does [ found? call-port ] ;-- LoadLibrary set 'load-library func [libname [string! file!]][ clear result clear command append command reduce [cmd-loadlibrary #{00000000} form libname #{00}] write-io call-port command length? command read-io call-port result 4 copy result ] ;-- FreeLibrary set 'free-library func [lib [binary!]][ ;-- Sanity check if 4 <> length? lib [ make error! "Lib has to be 4 bytes" ] clear result clear command append command reduce [cmd-freelibrary lib] write-io call-port command length? command read-io call-port result 4 to-integer result ] ;-- Create a rebol function that calls the target DLL function set 'make-routine func [spec [block!] lib [binary!] func-name [string!] /cdecl /debug /local func-spec ret-type ret stub call-cmd][ ;-- Sanity check if 4 <> length? lib [ make error! "Lib has to be 4 bytes" ] ;-- Ask our handler if the func-name is available clear result clear command append command reduce [cmd-getprocaddress lib func-name #{00}] write-io call-port command length? command read-io call-port result 4 if zero? to-integer result [ make error! "This function is not exported by the passed library" ] ;-- determine the return type func-spec: copy spec ret-type: reduce [none] if ret: find func-spec [return: ][ ret-type: second ret remove/part ret 2 ] ;-- create the stub stub: copy [] forskip func-spec 2 [ switch func-spec/2/1 [ binary! [append stub compose [append command & (func-spec/1)]] struct! [append stub compose [append command & (func-spec/1)]] string! [append stub compose [append command & (func-spec/1)]] integer! [append stub compose [append command to-bin (func-spec/1)]] long [append stub compose [append command to-bin (func-spec/1)]] short [append stub compose [append command to-bin (func-spec/1)]] char [append stub compose [append command to-bin (func-spec/1)]] logic! [append stub compose [append command to-bin (func-spec/1)]] block! [append stub compose [ ;-- We must create a dynamic stub because a block! is like a vararg foreach p (func-spec/1) [ switch to-word type? p [ binary! [append command & p] struct! [append command & p] string! [append command & p] integer! [append command to-bin p] long [append command to-bin p] short [append command to-bin p] char [append command to-bin p] logic! [append command to-bin p] ] ] ;-- Don't forget to modify the param count change at command 9 to-char add length? (func-spec/1) pick command 9 ]] ] if debug [ append stub compose/deep [print reform ["^-REBCALL>^- Param: " (mold func-spec/1) (func-spec/1)]] ] ] call-cmd: either cdecl [cmd-call-c][cmd-call-std] ;-- create the function func-spec: head func-spec make function! func-spec compose/deep [ (either debug [compose [print join "^-REBCALL> " (func-name)]][]) ;-- Create the param array clear result clear command append command (call-cmd) append command (result) append command to-char (divide length? func-spec 2) append command #{000000} (stub) write-io call-port command length? command read-io call-port result 4 retval: (switch/default ret-type/1 [ none [[none]] char [[to-integer copy/part result 1]] short [[to-integer head reverse copy/part result 2]] long [[to-integer head reverse copy/part result 4]] integer! [[to-integer head reverse copy/part result 4]] logic! [[to-logic to-integer head reverse copy/part result 4]] string! [[ do [ change third dummy-string result copy any [dummy-string/s ""] ]]] binary! [ ;-- For now I don't know what to do with binary return value, I could return a pointer to a struct. ;-- The problem is that the length is not known. ] ][ ;-- Defaults to LONG [to-integer head reverse copy/part result 4] ]) (either debug [ compose/deep [print reform ["^-REBCALL>^- return: " result retval] retval ]][]) ] ] ] ] ; endif not value? ;----------------------------------------------------------- ;-- Process script arguments if any if equal? system/script/args 'connect [rebcall/connect]