Skip to content

Commit 20c9b9b

Browse files
dzziedzzie
committed
AddObject support (script callback to resolver) Scripts can now access host COM objects by name
1 parent c19854a commit 20c9b9b

13 files changed

Lines changed: 185 additions & 23 deletions

File tree

‎CVariable.cls‎

Lines changed: 0 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -19,16 +19,7 @@ Public index As Long 'for arrays
1919
Public pAryElement As Long
2020

2121
Property Let name(v As String)
22-
2322
m_name = Replace(v, "main::", Empty)
24-
25-
' If InStr(v, "::") > 0 Then
26-
' tmp = Split(v, "::")
27-
' m_name = tmp(1)
28-
' namespace = tmp(0)
29-
' Else
30-
' m_name = v
31-
' End If
3223
End Property
3324

3425
Property Get name() As String

‎Form1.frm‎

Lines changed: 17 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -392,7 +392,7 @@ Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA"
392392

393393
Private Declare Function run_script Lib "sb_engine" (ByVal lpLibFileName As String, ByVal use_debugger As Long) As Long
394394
Private Declare Sub GetErrorString Lib "sb_engine" (ByVal iErrorCode As Long, ByVal buf As String, ByVal sz As Long)
395-
Private Declare Sub SetCallBacks Lib "sb_engine" (ByVal msgProc As Long, ByVal dbgCmdProc As Long)
395+
Private Declare Sub SetCallBacks Lib "sb_engine" (ByVal msgProc As Long, ByVal dbgCmdProc As Long, ByVal hostResolverProc As Long)
396396

397397

398398
Dim loadedFile As String
@@ -579,7 +579,7 @@ Private Sub ExecuteScript(Optional withDebugger As Boolean)
579579
End Sub
580580

581581
Private Sub Form_Load()
582-
582+
583583
mnuCallStackPopup.Visible = False
584584

585585
Dim incDir As String, modDir As String
@@ -594,7 +594,7 @@ Private Sub Form_Load()
594594
modDir = "D:\desktop\full_scriptbasic\scriptbasic\modules\"
595595
SetConfig incDir, modDir
596596

597-
SetCallBacks AddressOf vb_stdout, AddressOf GetDebuggerCommand
597+
SetCallBacks AddressOf vb_stdout, AddressOf GetDebuggerCommand, AddressOf HostResolver
598598
scivb.LoadHighlighter App.Path & "\dependancies\vb.bin"
599599

600600
scivb.DirectSCI.HideSelection False
@@ -611,7 +611,11 @@ Private Sub Form_Load()
611611
lvVars.ColumnHeaders(lvVars.ColumnHeaders.Count).Width = lvVars.Width - lvVars.ColumnHeaders(lvVars.ColumnHeaders.Count).Left - 100
612612

613613
'App.Path & "\scripts\com_voice_test.sb"
614-
LoadFile App.Path & "\scripts\functions.txt"
614+
'LoadFile App.Path & "\scripts\functions.txt"
615+
616+
AddObject "Form1", Me
617+
AddString "test", "this is my string from vb!"
618+
LoadFile App.Path & "\scripts\GetHostObject.sb"
615619

616620

617621
End Sub
@@ -640,19 +644,23 @@ End Sub
640644

641645
Public Sub SyncUI()
642646

643-
Dim curLine As Long
647+
Dim curline As Long
644648

645649
scivb.DeleteMarker lastEIP, 1
646650

647-
curLine = GetCurrentDebugLine(hDebugObject)
648-
scivb.SetMarker curLine, 1
649-
lastEIP = curLine
651+
curline = GetCurrentDebugLine(hDebugObject)
652+
scivb.SetMarker curline, 1
653+
lastEIP = curline
650654

651-
scivb.GotoLine curLine
655+
scivb.GotoLine curline
652656
scivb.HighLightActiveLine = True
653657
scivb.SetFocus
654658

655659
RefreshVariables
656660
RefreshCallStack
657661

658662
End Sub
663+
664+
Public Function Alert(msg As String)
665+
MsgBox msg
666+
End Function

‎Module1.bas‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
Attribute VB_Name = "Module1"
2-
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, source As Any, ByVal Length As Long)
2+
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, source As Any, ByVal Length As Long)
33
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
44

55
'get the currently executing line number
@@ -183,7 +183,6 @@ Public Function GetVariableValue(varName As String) As String
183183

184184
End Function
185185

186-
187186
Public Function GetDebuggerCommand(ByVal buf As Long, ByVal sz As Long) As Long
188187

189188
Dim b() As Byte

‎engine/dllmain.c‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -29,10 +29,11 @@ void __stdcall SetDefaultDirs(char* incDir, char* modDir){
2929
pszDefaultModuleDir = strdup(modDir);
3030
}
3131

32-
void __stdcall SetCallBacks(void* lpfnMsgHandler, void* lpfnDbgHandler){
32+
void __stdcall SetCallBacks(void* lpfnMsgHandler, void* lpfnDbgHandler, void* lpfnHostResolver){
3333
#pragma EXPORT
3434
vbStdOut = (vbCallback)lpfnMsgHandler;
3535
vbDbgHandler = (vbDbgCallback)lpfnDbgHandler;
36+
vbHostResolver = (vbHostResolverCallback)lpfnHostResolver;
3637
}
3738

3839
int __stdcall GetErrorString(int iErrorCode, char* buf, int bufSz){

‎engine/extensions/COM.cpp‎

Lines changed: 77 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,8 @@
1111
declare sub CreateObject alias "CreateObject" lib "test.exe"
1212
declare sub CallByName alias "CallByName" lib "test.exe"
1313
declare sub ReleaseObject alias "ReleaseObject" lib "test.exe"
14+
declare sub GetHostObject alias "GetHostObject" lib "sb_engine.dll"
15+
declare sub GetHostString alias "GetHostString" lib "sb_engine.dll"
1416
1517
const VbGet = 2
1618
const VbLet = 4
@@ -43,6 +45,7 @@
4345

4446
int com_dbg = 0;
4547
int initilized=0;
48+
vbHostResolverCallback vbHostResolver = NULL;
4649

4750
//vbCallType aligns with DISPATCH_XX values for Invoke
4851
enum vbCallType{ VbGet = 2, VbLet = 4, VbMethod = 1, VbSet = 8 };
@@ -132,6 +135,80 @@ void color_printf(colors c, const char *format, ...)
132135
LONGVALUE(besRETURNVALUE) = 0; \
133136
goto cleanup;}
134137

138+
139+
140+
//Object GetHostObject("Form1")
141+
//this is for embedded hosts, so script clients can dynamically look up obj pointers
142+
//for use with teh COM functions. Instead of the MS Script host design of AddObject
143+
//here we allow the script to query values from a host resolver. Its easier than
144+
//trying to mess with the internal Symbol tables, and cleaner than editing an include
145+
//script on the fly every single launch to add global variables which would then show up
146+
//in the debug pane. this function can be used for retrieving any long value
147+
besFUNCTION(GetHostObject)
148+
int retVal=0;
149+
int slen;
150+
char* myCopy = NULL;
151+
VARIABLE Argument;
152+
besRETURNVALUE = besNEWMORTALLONG;
153+
154+
if( besARGNR != 1) RETURN0("GetHostObject takes one argument!")
155+
156+
Argument = besARGUMENT(1);
157+
besDEREFERENCE(Argument);
158+
159+
if( TYPE(Argument) != VTYPE_STRING) RETURN0("GetHostObject requires a string argument")
160+
if( STRLEN(Argument) > 1000) RETURN0("GetHostObject argument to long")
161+
162+
myCopy = GetCString(Argument);
163+
if(myCopy==0) RETURN0("malloc failed low mem")
164+
165+
if(vbHostResolver==NULL) RETURN0("GetHostObject requires vbHostResolver callback to be set")
166+
167+
retVal = vbHostResolver(myCopy, strlen(myCopy), 0);
168+
169+
cleanup:
170+
LONGVALUE(besRETURNVALUE) = retVal;
171+
if(myCopy) free(myCopy);
172+
return 0;
173+
174+
besEND
175+
176+
//as above but for retrieving strings up to 1024 chars long
177+
besFUNCTION(GetHostString)
178+
int retVal=0;
179+
int slen=0;
180+
char* myCopy = NULL;
181+
char buf[1026];
182+
VARIABLE Argument;
183+
besRETURNVALUE = besNEWMORTALLONG;
184+
185+
if( besARGNR != 1) RETURN0("GetHostString takes one argument!")
186+
187+
Argument = besARGUMENT(1);
188+
besDEREFERENCE(Argument);
189+
190+
if( TYPE(Argument) != VTYPE_STRING) RETURN0("GetHostString requires a string argument")
191+
if( STRLEN(Argument) > 1000) RETURN0("GetHostString argument to long")
192+
193+
myCopy = GetCString(Argument);
194+
if(myCopy==0) RETURN0("malloc failed low mem")
195+
196+
if(vbHostResolver==NULL) RETURN0("GetHostStringt requires vbHostResolver callback to be set")
197+
198+
//we are actually going to use our own fixed size buffer for this in case its a string value to be returned..
199+
strcpy(buf, myCopy);
200+
retVal = vbHostResolver(buf, strlen(buf), 1024);
201+
slen = strlen(buf);
202+
203+
cleanup:
204+
besALLOC_RETURN_STRING(slen);
205+
if(slen > 0) memcpy(STRINGVALUE(besRETURNVALUE),buf,slen);
206+
if(myCopy) free(myCopy);
207+
return 0;
208+
209+
besEND
210+
211+
135212
//ReleaseObject(obj)
136213
besFUNCTION(ReleaseObject)
137214

‎engine/sb/include/vb.h‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,8 +18,11 @@ typedef void (__stdcall *vbCallback)(cb_type, char*, int);
1818
//Public Function GetDebuggerCommand(ByVal buf As Long, ByVal sz As Long) As Long
1919
typedef int (__stdcall *vbDbgCallback)(char*, int);
2020

21+
typedef int (__stdcall *vbHostResolverCallback)(char*, int, int);
22+
2123
extern vbCallback vbStdOut;
2224
extern vbDbgCallback vbDbgHandler;
25+
extern vbHostResolverCallback vbHostResolver;
2326

2427
#ifdef __cplusplus
2528
}

‎engine/sb/scriba.c‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,11 +25,13 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
2525
#include "basext.h"
2626
#include "vb.h"
2727

28+
//next 4 added dzzie
2829
vbCallback vbStdOut = NULL;
2930
vbDbgCallback vbDbgHandler = NULL;
3031
char* pszDefaultIncludeDir = NULL;
3132
char* pszDefaultModuleDir = NULL;
3233

34+
3335
/*POD
3436
=H scriba_new()
3537

‎engine/sb_engine.dll‎

2 KB
Binary file not shown.

‎modHostObjs.bas‎

Lines changed: 60 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,60 @@
1+
Attribute VB_Name = "modHostObjs"
2+
3+
Private objs As New Collection 'of CVariable
4+
5+
Sub AddObject(name As String, value As Object)
6+
Dim v As New CVariable
7+
v.name = name
8+
v.value = ObjPtr(value)
9+
v.varType = "long"
10+
On Error Resume Next
11+
objs.Add v, name
12+
End Sub
13+
14+
Sub AddLong(name As String, value As Long)
15+
Dim v As New CVariable
16+
v.name = name
17+
v.value = value
18+
v.varType = "long"
19+
On Error Resume Next
20+
objs.Add v, name
21+
End Sub
22+
23+
Sub AddString(name As String, value As String)
24+
Dim v As New CVariable
25+
If Len(value) > 1024 Then Exit Sub
26+
v.name = name
27+
v.value = value
28+
v.varType = "string"
29+
On Error Resume Next
30+
objs.Add v, name
31+
End Sub
32+
33+
34+
Public Function HostResolver(ByVal buf As Long, ByVal strlen As Long, ByVal totalBufSz As Long) As Long
35+
36+
Dim b() As Byte
37+
Dim name As String
38+
Dim v As CVariable
39+
40+
ReDim b(strlen)
41+
CopyMemory b(0), ByVal buf, strlen
42+
name = StrConv(b, vbUnicode)
43+
If Right(name, 1) = Chr(0) Then name = Left(name, Len(name) - 1)
44+
45+
On Error Resume Next
46+
Set v = objs(name)
47+
48+
If v Is Nothing Then Exit Function 'returns 0
49+
50+
If v.varType = "long" Then
51+
HostResolver = v.value
52+
Else
53+
If Len(v.value) + 1 < totalBufSz Then
54+
b() = StrConv(v.value & Chr(0), vbFromUnicode)
55+
CopyMemory ByVal buf, b(0), UBound(b) + 1
56+
End If
57+
End If
58+
59+
End Function
60+

‎scripts/GetHostObject.sb‎

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
declare sub GetHostObject alias "GetHostObject" lib "sb_engine.dll"
2+
declare sub GetHostString alias "GetHostString" lib "sb_engine.dll"
3+
declare sub CallByName alias "CallByName" lib "sb_engine.dll"
4+
5+
const VbGet = 2
6+
const VbLet = 4
7+
const VbMethod = 1
8+
const VbSet = 8
9+
10+
obj = GetHostObject("Form1")
11+
12+
if obj = 0 then
13+
print "GetHostObject failed! Make sure host called AddObject\n"
14+
else
15+
CallByName(obj, "caption", VbLet, "this is my form caption!")
16+
CallByName(obj, "Alert", VbMethod, "This is my test")
17+
end if
18+
19+
print "GetHostString(test)=", GetHostString("test")

0 commit comments

Comments
 (0)