PureBasic Forums - English

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