Not all features are implemented, but should be enough to get you started.
Example usage included. Enjoy.
Phil
Code: Select all
;TCL Module V0.1 - Phil Smith
;not all TCL API commands are implemented, not even close to all of them
;not all declarations are used... yet.
;to add a TCL API function
; 1. Create the prototype
; 2. Create a global variable of that prototype
; 3. add a call to assignfunction in tcl_init to map the variable to the tcl API function.
;TCL functions are case sensitive!!!!
DeclareModule tcl
#tcl_ok=0
#tcl_error=1
#tcl_volatile=1
#tcl_static=0
#tcl_dynamic=3
#TCL_GLOBAL_ONLY= 1
#TCL_NAMESPACE_ONLY= 2
#TCL_APPEND_VALUE= 4
#TCL_LIST_ELEMENT= 8
#TCL_TRACE_READS= $10
#TCL_TRACE_WRITES= $20
#TCL_TRACE_UNSETS= $40
#TCL_TRACE_DESTROYED= $80
#TCL_INTERP_DESTROYED= $100
#TCL_LEAVE_ERR_MSG= $200
#TCL_TRACE_ARRAY= $800
#TCL_READABLE = (1<<1)
#TCL_WRITABLE= (1<<2)
#TCL_EXCEPTION= (1<<3)
; /*
; * Flag values To pass To Tcl_OpenCommandChannel To indicate the disposition
; * of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR, are also used in
; * Tcl_GetStdChannel.
; */
#TCL_STDIN= (1<<1)
#TCL_STDOUT= (1<<2)
#TCL_STDERR= (1<<3)
#TCL_ENFORCE_MODE= (1<<4)
ImportC ""
dup(fileID)
close(fileID)
EndImport
Structure twoPtrValue
*ptr1
*ptr2
EndStructure
Structure TptrAndLongRep
*ptr
value.l
EndStructure
Structure Tcl_Obj
refCount.i
*bytes.string
length.i
*typePtr
StructureUnion
intValue.i
doubleValue.d
*otherValuePtr
prtValue.twoPtrValue
ptrAndLongRep.TptrAndLongRep
EndStructureUnion
EndStructure
Prototype.i proto_tcl_createInterp()
Prototype.i proto_tcl_deleteInterp(*interp)
Prototype.i proto_tcl_ObjCmdProc(*dummy,*interp,objc,*objv)
Prototype.i proto_tcl_createobjCommand(*interp,cmdName.p-utf8,*proc,*clientData,*deleteProc)
Prototype.i proto_tcl_SetObjResult(*interp,*objPtr)
Prototype.i proto_tcl_Eval(*interp,script.p-utf8)
Prototype.i proto_tcl_EvalFie(*interp,filename.p-utf8)
Prototype.i proto_tcl_FSGetCwd(*ptr)
Prototype.i proto_tcl_FSChdir(*ptr,path.p-utf8)
Prototype.i proto_tcl_SetStringObj(*ptr,bytes.p-utf8,length)
Prototype.i proto_tcl_NewStringObj(bytes.p-utf8,length)
Prototype.i proto_tcl_GetStringResult(*interp)
Prototype.i proto_tcl_GetObjResult(*interp)
Prototype.i proto_tcl_GetStringFromObj(*ptr,*lengthPtr)
Prototype.i proto_tcl_GetString(*obj)
Prototype.i proto_tcl_GetVar2Ex(*interp,name1.p-utf8,name2.p-utf8,flags.i)
Prototype.i proto_tcl_GetReturnOptions(*interp,code.i)
Prototype.i proto_tcl_GetVar(*interp,varName.p-utf8,flags)
Prototype.i proto_tcl_DictObjGet(*interp,*error_dict,*error_info,*error_msg)
Prototype.i proto_tcl_MakeFileChannel(*fp,flags)
Prototype.i proto_tcl_RegisterChannel(*ptr,*channel)
Prototype.i proto_tcl_SetStdChannel(*channel,channel_id)
Prototype.i proto_tcl_Close(*interp,*channel)
Prototype.i proto_tcl_GetChannelName(*channel)
Prototype.i proto_tcl_OpenFileChannel(*interp,fileName.p-utf8,mode.p-ascii,permissions)
Prototype.i proto_tcl_SetChannelOption(*interp,*channel,optionName.p-utf8,optionValue.p-utf8)
Prototype.i proto_tcl_UnregisterChannel(*interp,*channel)
Prototype.i proto_tcl_GetStdChannel(channel_id)
Prototype.i proto_tcl_SetVar(*interp,varName.p-utf8,newValue.p-UTF8,flags)
Prototype.i proto_tcl_Free(*ptr)
Prototype.i proto_tcl_FreeResult(*ptr)
Prototype.i proto_tcl_ResetResult(*ptr)
Global tcl_Close.proto_tcl_Close
Global tcl_createInterp.proto_tcl_createInterp
Global tcl_createObjCommand.proto_tcl_createobjCommand
Global tcl_DictObjGet.proto_tcl_DictObjGet
Global tcl_DeleteInterp.proto_tcl_DeleteInterp
Global tcl_eval.proto_tcl_Eval
Global tcl_evalFile.proto_tcl_EvalFie
Global tcl_FSGetCwd.proto_tcl_FSGetCwd
Global tcl_FSChdir.proto_tcl_FSChdir
Global tcl_GetChannelName.proto_tcl_GetChannelName
Global tcl_GetObjResult.proto_tcl_GetObjResult
Global tcl_GetReturnOptions.proto_tcl_GetReturnOptions
Global tcl_GetStdChannel.proto_tcl_GetStdChannel
Global tcl_GetString.proto_tcl_GetString
Global tcl_GetStringFromObj.proto_tcl_GetStringFromObj
Global tcl_GetStringResult.proto_tcl_GetStringResult
Global tcl_GetVar.proto_tcl_GetVar
Global tcl_GetVar2Ex.proto_tcl_GetVar2Ex
Global tcl_MakeFileChannel.proto_tcl_MakeFileChannel
Global tcl_NewStringObj.proto_tcl_NewstringObj
Global tcl_OpenFileChannel.proto_tcl_OpenFileChannel
Global tcl_RegisterChannel.proto_tcl_RegisterChannel
Global tcl_SetChannelOption.proto_tcl_SetChannelOption
Global tcl_SetObjResult.proto_tcl_SetObjResult
Global tcl_SetStdChannel.proto_tcl_SetStdChannel
Global tcl_UnregisterChannel.proto_tcl_UnregisterChannel
Global tcl_setVar.proto_tcl_SetVar
Global tcl_Free.proto_tcl_Free
Global tcl_FreeResult.proto_tcl_FreeResult
Global tcl_ResetResult.proto_tcl_ResetResult
#TCL_LIBRARY_NAME="libtcl.dylib" ;default TCL library, you can change it here or when you call tcl_init
Define tclError$
Declare tcl_init(*msg.string,lib$=#TCL_LIBRARY_NAME)
Declare.s tcl_stackTrace(*interp,rc)
Declare.s tcl_getResult(*interp)
Declare tcl_setResult(*interp,r$) ;old tcl function wrapped to use new API
EndDeclareModule
Module tcl
EnableExplicit
Define *interp
Prototype proto_handleError(msg$)
Macro assignFunction(funcVar,funcName)
funcVar=GetFunction(tclLib,funcName)
If funcVar=#nil
s$=funcName+" is null"
r=#False
EndIf
EndMacro
;you must call this before using TCL. Returns false with error message in *msg if fails
;*msg.string - pointer to a message buffer
;lib$ - your tcl library
Procedure tcl_init(*msg.string,lib$=#TCL_LIBRARY_NAME)
; tcl_shareFunctions()
Define tclLib
Define s$
If Not IsLibrary(tclLib)
tclLib= OpenLibrary(#PB_Any,lib$)
If Not tclLib
s$="tcl library not found"
PokeS(*msg,s$)
ProcedureReturn #False
EndIf
EndIf
Define r=#True
assignFunction(tcl_createInterp,"Tcl_CreateInterp")
assignFunction(tcl_createObjCommand,"Tcl_CreateObjCommand")
assignFunction(tcl_SetObjResult,"Tcl_SetObjResult")
; assignFunction(tcl_SetResult,"Tcl_SetResult")
assignFunction(tcl_eval,"Tcl_Eval")
assignFunction(tcl_NewStringObj,"Tcl_NewStringObj")
assignFunction(tcl_GetStringResult,"Tcl_GetStringResult")
assignFunction(tcl_GetObjResult,"Tcl_GetObjResult")
assignFunction(tcl_GetStringFromObj,"Tcl_GetStringFromObj")
;assignFunction(tcl_GetErrorLine,"Tcl_GetErrorLine")
assignFunction(tcl_GetVar2Ex,"Tcl_GetVar2Ex")
assignFunction(tcl_GetString,"Tcl_GetString")
assignFunction(tcl_GetReturnOptions,"Tcl_GetReturnOptions")
assignFunction(tcl_GetVar,"Tcl_GetVar")
assignFunction(tcl_DictObjGet,"Tcl_DictObjGet")
assignFunction(tcl_MakeFileChannel,"Tcl_MakeFileChannel")
assignFunction(tcl_RegisterChannel,"Tcl_RegisterChannel")
assignFunction(tcl_SetStdChannel,"Tcl_SetStdChannel")
assignFunction(tcl_Close,"Tcl_Close")
assignFunction(tcl_GetChannelName,"Tcl_GetChannelName")
assignFunction(tcl_OpenFileChannel,"Tcl_OpenFileChannel")
assignFunction(tcl_SetChannelOption,"Tcl_SetChannelOption")
assignFunction(tcl_UnregisterChannel,"Tcl_UnregisterChannel")
assignFunction(tcl_GetStdChannel,"Tcl_GetStdChannel")
assignfunction(tcl_DeleteInterp,"Tcl_DeleteInterp")
assignFunction(tcl_evalFile,"Tcl_EvalFile")
assignFunction(tcl_FSGetCwd,"Tcl_FSGetCwd")
assignFunction(tcl_FSChdir,"Tcl_FSChdir")
assignFunction(tcl_SetVar,"Tcl_SetVar")
assignFunction(tcl_GetVar,"Tcl_GetVar")
assignfunction(tcl_Free,"Tcl_Free")
assignfunction(tcl_FreeResult,"Tcl_FreeResult")
assignfunction(tcl_ResetResult,"Tcl_ResetResult")
If s$<>""
PokeS(*msg,s$)
EndIf
ProcedureReturn r
EndProcedure
;get the stack trace for an error
Procedure.s tcl_stackTrace(*interp,rc)
Define *options=tcl_GetReturnOptions(*interp,rc)
Define *key=tcl_NewStringObj("-errorinfo",-1)
Define *stacktrace.Tcl_Obj=AllocateStructure(Tcl_Obj)
Tcl_DictObjGet(*interp,*options,*key,@*stacktrace)
ProcedureReturn PeekS(*stacktrace\bytes,-1,#PB_UTF8)
EndProcedure
;get the result of a TCL command execution
Procedure.s tcl_getResult(*interp)
Define r$
Define *obj.Tcl_Obj=tcl_GetObjResult(*interp)
r$=PeekS(*obj\bytes,-1,#PB_UTF8)
ProcedureReturn r$
EndProcedure
Procedure tcl_setResult(*interp,r$)
Define *obj=tcl::tcl_NewStringObj(r$,-1)
tcl_setObjResult(*interp,*obj)
EndProcedure
EndModule
CompilerIf #PB_Compiler_IsMainFile
UseModule tcl
Macro quotestr(s)
Chr(34)+s+Chr(34)
EndMacro
;get all the arguments passed to a custom tcl function and put them in params$()
;the first element in the list will be the name of the command
Procedure getParameters(objc,*objv.integer,List params$())
Define cnt
Define *ptr.Tcl_Obj
Define s$
Shared *app
;*objv+SizeOf(integer)
For cnt=0 To objc-1
*ptr=*objv\i
If *ptr<>#nil And *ptr\bytes<>#nil
s$=PeekS(*ptr\bytes,-1,#PB_UTF8)
AddElement(params$())
params$()=s$
*objv+SizeOf(integer)
EndIf
Next
EndProcedure
;a custom TCL command
;*dummy - ignore
;*interp - pointer to tcl interpreter
;objc - number of arguments, including the command itself
;objv - pointer to list of arguments
; Use getParameters to parse this
Procedure tclDebug(*dummy,*interp,objc,*objv.integer)
Define cnt
Define *ptr.Tcl_Obj
Define s$
NewList params$()
getParameters(objc,*objv,params$())
ForEach(params$())
If ListIndex(params$())=0
Continue ;skip first element since its just the command name
EndIf
s$=s$+" "+params$()
Next
Debug s$
EndProcedure
Define msg$=Space(200)
If Not tcl_init(@msg$)
Debug msg$ ;most likely a function was not successully mapped to a variable due to misspelling
End
EndIf
Define *interp=tcl_CreateInterp()
;register our custom TCL command
tcl_createObjCommand(*interp,"debug",@tclDebug(),0,0)
Restore testcode
Define line$
Read.s line$
Define code$
While line$<>""
code$+line$+#LF$
Read.s line$
Wend
Define rc=tcl_eval(*interp,code$)
If rc<>#TCL_OK
Debug tcl_stackTrace(*interp,rc)
Else
Debug "execution completed"
Debug "result="+tcl_getResult(*interp)
EndIf
tcl_DeleteInterp(*interp)
DataSection
testcode:
Data$ "proc hello {} {"
Data$ "debug hello"
Data$ "}"
Data$ "hello"
Data$ "set msg "+quotestr("hello again")
Data$ "debug $msg"
Data$ ""
EndDataSection
CompilerEndIf
. Even lists, maps, ... everything is a string! It's a scripting language, but IMHO a bit weird, buggy and old.