MkCall_tcl.c

Go to the documentation of this file.

 
/* LABEL-NO */
 
#include  "LibMkKernel_tcl.h"
#include  "mk_check_tcl.h"
#include  <tclInt.h>
 
/*****************************************************************************/
/*                                                                           */
/*                                Proc-Call                                  */
/*                                                                           */
/*****************************************************************************/
 
enum MkErrorE MK(CheckCallable) (OT_Check_ARGS, MK_CBP* retP)
{
  OT_SETUP_doc
  if ((*skipP) >= objc) {
    WrongNumArgs(hdl,(*skipP), objc, -999, +999, arg);
    goto error;
  }
  Tcl_ResetResult(interp);
  OT_OBJ_T argO = objv[(*skipP)++];
 
  int myobjc;
  Tcl_Obj **myobjv;
  check_LNG (Tcl_ListObjGetElements(interp, argO, &myobjc, &myobjv)) goto tcl_error;
 
  // BUG-FIX: set the "default" value for "NULL" = ""
  // defined in: ./lib_TCL.tcl → map_M2C
  // mark=MK_NULL
  if (myobjc == 0) goto null;                                     /* empty list */
  if (Tcl_GetObjectFromObj (interp, myobjv[0])) {                 /* method? */
    if (myobjc > 1 && OT_LNG_NULL_IS(myobjv[1])) goto null;
  } else {
    Tcl_ResetResult(interp);
    if (OT_LNG_NULL_IS(myobjv[0])) goto null;                     /* proc */
  }
 
  struct MkCallS *call = *retP;
 
  if (*retP == NULL) {
    call = *retP = MkSysCalloc(MK_ERROR_PANIC,1,sizeof(struct MkCallS));
    call->isAlloc = true;
  }
 
  call->signature = MkCallS_SIG;
  call->mth       = argO;
  call->hdl       = hdl;
  call->interp    = interp;
  call->mkrt      = MK_RT_PTR;
  call->nsO       = STRN2VAL(Tcl_GetCurrentNamespace(interp)->fullName);
 
  OT_REF_INCR(call->mth);
  OT_REF_INCR(call->nsO);
 
//colorGREEN("call<%p>, type<%d>, nsO<%p>",call,call->type,call->nsO);
 
  return MK_OK;
tcl_error:
  OT_ERROR_LNG_2_META(hdl);
error:
  return MkErrorStack_0E();
null:
  *retP = NULL;
  return MK_OK;
}
 
#define mycheck_LNG(val) \
  check_LNG(val) { \
    OT_ERROR_LNG_2_META(hdl); \
    goto error; \
  }
 
#define mycheck_NULL(var) \
  check_NULL(var) { \
    OT_ERROR_LNG_2_META(hdl); \
    goto error; \
  }
 
#define mycheck_NULL_2(var,str) \
  check_NULL(var) { \
    MkErrorSetC_2M(hdl,str); \
    goto error; \
  }
 
#define myListObjIndex(itp,lst,idx) ({ \
  OT_OBJ_T _ret; \
  mycheck_LNG(Tcl_ListObjIndex(itp,lst,idx,&_ret)); \
  mycheck_NULL_2(_ret,"LIST-IDX-LOOKUP-ERROR at " #lst "' index '" #idx "'"); \
  _ret; \
})
 
#define myListObjPop(itp,lst) ({ \
  OT_OBJ_T _ret = myListObjIndex(itp,lst,0); \
  Tcl_IncrRefCount(_ret); \
  mycheck_LNG(Tcl_ListObjReplace(itp,lst,0,1,0,NULL)); \
  _ret; \
})
 
#define myListObjLength(itp,lst) ({ \
  int _len=0; \
  mycheck_LNG(Tcl_ListObjLength(itp, lst, &_len)); \
  _len; \
})
 
#define myGetBooleanFromObj(itp,lngO) ({ \
  int _retB = 0; \
  mycheck_LNG(Tcl_GetBooleanFromObj(itp,lngO,&_retB)); \
  ( _retB > 0 ); \
})
 
#define myEvalObjvAR(frm,itp,opt,objc,objv) ({ \
  OT_OBJ_T _ret = MK(EvalObjvAR)(MK_RT_CALL frm, itp, opt, objc, objv);   \
  mycheck_NULL(_ret); \
  _ret; \
})
 
#define myGetObjectFromObj(itp,_mng,slf) ({ \
  OT_SELF_T _ret = Tcl_GetObjectFromObj(itp,slf); \
  check_NULL(_ret) { \
    MkErrorSetC_2M(_mng,Tcl_GetStringResult (itp)); \
    goto error; \
  } \
  _ret; \
})
 
#define myWrongTypeOfStaticArgError(exp,cls,got) \
  MkErrorVD("WrongTypeOfStaticArgError", "expect type '%s' for class '%s', but got '%s'", exp, cls, got ); \
  goto error;
 
static enum MkErrorE NS(sProcResolve_StaticMethod)(
  OT_VARFRAME_ARGS, 
  OT_ENV_T interp, 
  MK_MNG hdl,
  struct MkCallS *call, 
  OT_OBJ_T clsO, 
  OT_OBJ_T *mthOP,
  bool needArg, 
  bool needError
) {
  enum MkErrorE ret = MK_OK;
  OT_OBJ_T mthO = *mthOP;
 
//X0(hdl)
//printXLng(hdl,clsO)
//printXLng(hdl,mthO)
 
  // is a "PRIVATE/PUBLIC method"
  // call: info object methods -all -private
  OT_OBJ_T mthL = NULL;
  {
    RL_init( RL_O(0,RG(infoObjectMethodsCmd)) RL_NewS(2,"-all") RL_NewS(3,"-private") ) RL_O(1,clsO);
    mthL = myEvalObjvAR(varframe,interp,TCL_EVAL_GLOBAL,4,RL_data);
  }
 
  // search for the meth, result: >0 found, -1 = not found
  // lsearch -exact mthL mthO
  OT_OBJ_T isMthO = NULL;
  {
    RL_init( RL_NewS(0,"lsearch") RL_NewS(1,"-exact") ) ; RL_O(2,mthL) ; RL_O(3,mthO)
    isMthO = myEvalObjvAR(varframe,interp,TCL_EVAL_GLOBAL, 4, RL_data);
  }
 
  int mthIdx;
  mycheck_LNG(Tcl_GetIntFromObj(interp,isMthO,&mthIdx));
 
  if (mthIdx == -1) {
    RL_init( RL_O(0,RG(infoClassSuperclassesCmd)) ) ; RL_O(1,clsO)
 
    // CURRENT class has NO method -> continue with superclass
    // call: info class subclasses CLASS
    OT_OBJ_T superclassesL = myEvalObjvAR(varframe,interp,TCL_EVAL_GLOBAL, 2, RL_data);
 
//printXLng(hdl,superclassesL)
 
    // get superclassesL as objv
    int objc;
    OT_OBJ_T *objv;
    mycheck_LNG(Tcl_ListObjGetElements(interp,superclassesL,&objc,&objv));
    for (int i=0; i<objc; i++) {
      check_META(NS(sProcResolve_StaticMethod)(OT_VARFRAME_CALL,interp,hdl,call,objv[i],mthOP,true,false)) continue;
      // ok found something
      goto end;
    }
    if (needError) {
      myWrongTypeOfStaticArgError("static Callable", VAL2STR(clsO), VAL2STR(mthO));
    } else {
      goto error;
    }
    goto end;
 
  } else {
 
    // get static "my"
    OT_SELF_T object = myGetObjectFromObj(interp,hdl,clsO);
    OT_OBJ_T myCmdO = MK(GetMyFromObject)(interp,object);
      check_NULL(myCmdO)  {
        OT_ERROR_LNG_2_META(hdl);
        goto error;
      }
 
    call->type  = MkCallS_static;
    call->my    = myCmdO;
      Tcl_IncrRefCount(myCmdO);
    call->mth   = mthO;
      Tcl_IncrRefCount(mthO);
      *mthOP = NULL;
  }
 
end:
//printTxt("OK");
  return ret;
 
error:
 
    call->type  = MkCallS_error;
    call->my    = NULL;
    call->mth   = NULL;
 
//printXTxt(hdl,"ERROR");
//printXTxt(hdl,MkErrorGetText_0E());
//printXTxt(hdl,Tcl_GetStringResult(interp));
  return MK_ERROR;
}
 
#if 0
  #define dbgMsg(fmt,...) printV(fmt,__VA_ARGS__)
  #define dbgObj(obj)     printLngObj(obj)
#else
  #define dbgMsg(fmt,...)
  #define dbgObj(obj)
#endif
 
enum MkErrorE NS(ProcResolve) (
  MK_RT_ARGS
  OT_ENV_T interp,
  MK_MNG          hdl,
  struct MkCallS  *call
) {
//L0
  OT_VARFRAME_CREATE
  enum MkErrorE ret = MK_OK;
  OT_OBJ_T arg0 = NULL;
  OT_OBJ_T arg1 = NULL;
  OT_OBJ_T tstO = Tcl_DuplicateObj(call->mth);
 
  if (call->nsPtr == NULL) {
    call->nsPtr = Tcl_FindNamespace(interp,VAL2STR(call->nsO),NULL,TCL_GLOBAL_ONLY);
      if (call->nsPtr == NULL) return MK_OK ;   // instance namespace already deleted
  }
 
  Namespace * savedNsPtr = NULL;
  Tcl_Command procCmd = NULL;
  Interp *iPtr = (Interp *) interp;
 
  // check if "arg0" is an object or class
  arg0 = myListObjPop(interp,tstO);
 
dbgMsg("nsPtr<%p>", call->nsPtr)
 
  savedNsPtr = iPtr->varFramePtr->nsPtr;
  iPtr->varFramePtr->nsPtr = (Namespace *) call->nsPtr;
 
dbgObj(arg0);
  
  //Tcl_Command procCmd = Tcl_FindCommand (interp,Tcl_GetString(arg0),call->ns,0);
  procCmd = Tcl_GetCommandFromObj (interp,arg0);
 
dbgMsg("procCmd<%p>", procCmd)
 
  if (procCmd != NULL) {
 
    OT_SELF_T obj0 = Tcl_GetObjectFromObj(interp,arg0);
    Tcl_ResetResult(interp);
 
    if (obj0 != NULL) {
dbgMsg("%s","object")
      // first is NON "proc" and "object" → interface, method (own or other)
 
      arg1 = myListObjPop(interp,tstO);
 
      // check if "arg0" is an "instance" or "class"
      OT_CLS_T cls0 = Tcl_GetObjectAsClass(obj0);
 
      if (cls0 != NULL) {
dbgMsg("%s","class method")
        // class method -> static
        check_META(NS(sProcResolve_StaticMethod)( OT_VARFRAME_CALL,interp,hdl,call,arg0,&arg1,true,true)) goto error;
      } else {
dbgMsg("%s","instance method")
        // instance method
        OT_OBJ_T myCmdO = MK(GetMyFromObject)(interp,obj0);
          check_NULL(myCmdO)  {
            OT_ERROR_LNG_2_META(hdl);
            goto error;
          }
 
        call->type = MkCallS_other_method;
        call->my  = myCmdO;
          Tcl_IncrRefCount(myCmdO);
        call->mth = arg1;
          Tcl_IncrRefCount(arg1);
          arg1 = NULL;
      }
 
    } else {
 
dbgMsg("%s","proc")
      call->type = MkCallS_proc;
      call->mth = arg0;
        Tcl_IncrRefCount(arg0);
        arg0 = NULL;
    }
 
  } else {
dbgMsg("%s","NON proc instance method")
    // first is NON "proc" and NON "object" → method on OWN class
    call->type = MkCallS_own_method;
    call->my  = NULL;
    call->mth = arg0;
      Tcl_IncrRefCount(arg0);
      arg0 = NULL;
  }
 
  // resolve additional arguments
  int tstOLen = myListObjLength(interp, tstO);
  if (tstOLen > MkProcResolve_maxArgsLen) {
    MkErrorSetV_2M(hdl, "expect max '%d' additional arguments to callback but got '%d' "
                        "with '%s'", MkProcResolve_maxArgsLen, tstOLen, Tcl_GetString(tstO));
    goto error;
  } else if (tstOLen > 0) {
    call->args = tstO;
      Tcl_IncrRefCount(tstO);
      tstO = NULL;
  } else {
    call->args = NULL; 
  }
 
end:
  OT_REF_DECR_AND_NULL(arg0);
  OT_REF_DECR_AND_NULL(arg1);
  OT_REF_DECR_AND_NULL(tstO);
  OT_VARFRAME_DELETE
  if (savedNsPtr) iPtr->varFramePtr->nsPtr = savedNsPtr;
  return ret;
 
error:
  ret = MkErrorStack_1M(hdl);
  if (savedNsPtr) iPtr->varFramePtr->nsPtr = savedNsPtr;
  goto end;
}
 
// **********************************************************************
 
/*
[ObjectDeleteCall signature]
  callback-args := typeName:MK_STRN[in], typeHdl:MK_HDL[in], objHdl:MK_HDL[in]
  [static]    proc callback { callback-args ?additional-args...? } ...
              MkObjectC DeleteCallbackSetup "NAME" callback "FILTER"
  [instance]  ::oo::class create XXX {
                method callback { callback-args ?additional-args...? } ...
              }
              MkObjectC DeleteCallbackSetup "NAME" [list [self] callback] "FILTER"
  [class]     ::oo::class create YYY {
                self method callback { callback-args ?additional-args...? } ...
              }
              MkObjectC DeleteCallbackSetup "NAME" [list YYY callback] "FILTER"
[ObjectDeleteCall signature]
*/
 
enum MkErrorE NS(ObjectDeleteCall) ( MkObjectDeleteCallF_ARGS )
{
  MkObjectDeleteCallF_CHECK;
 
  // if NO self object is available than NO callback is called
  if (!MkSelfExists(obj)) return MK_OK;
 
  // 1. setup environment
  SETUP_interp
  if (interp==NULL || Tcl_InterpDeleted(interp)) return MK_OK;
 
  // 2. setup arguments
  struct MkCallS *call = __data__;
  OT_OBJ_T objv[5+MkProcResolve_maxArgsLen] = {0};
  int objc = 0;
 
  //Tcl_ResetResult(interp);
//printLLngObj(call->mth);
 
  // 3. setup my
rescan:
  switch (call->type) {
    case MkCallS_own_method:
//printLTxt("MkCallS_own_method");
      return MkErrorSetC_1E("MkCallS_own_method not supported");
      break;
    case MkCallS_other_method:
    case MkCallS_static:
//printLTxt("MkCallS_other_method OR MkCallS_static");
      objv[objc++] = call->my;
      break;
    case MkCallS_proc:
//printLTxt("MkCallS_proc");
      break;
    case MkCallS_init: {
      check_META(MK(ProcResolve)(MK_RT_CALL interp, call->hdl, call)) goto error_mq;
      goto rescan;
    }
    case MkCallS_error:
//printLTxt("MkCallS_error");
      goto error;
    case MkCallS_null:
//printLTxt("MkCallS_null");
      return MK_OK;
  }
 
  // 4. setup methode
  if (call->mth)  objv[objc++] = call->mth;
 
  // 5. setup OBJ arg
  switch (call->type) {
    case MkCallS_other_method:
    case MkCallS_static:
    case MkCallS_proc:
      objv[objc++] = STR2VAL(typeName,-1);
      objv[objc++] = HDL2VAL(typeHdl);
      objv[objc++] = HDL2VAL(objHdl);
      break;
    case MkCallS_own_method:
    case MkCallS_init:
      break;
    case MkCallS_error:
      goto error;
    case MkCallS_null:
      return MK_OK;
  }
 
  if (call->args) MK(ProcResolveAppendArgs)(call,&objc,objv);
 
  // 3. call the callback
  // require "MK(EvalObjv)" to cleanup "objv"
  int ret = MK(EvalObjv) (interp, objc, objv, TCL_EVAL_GLOBAL);
 
//printV("ret=%i, code=%s\n", ret, MkLogErrorE(MkErrorGetCode_0E()))
 
  if (ret == TCL_OK) {
    Tcl_ResetResult(interp);
    return MkErrorGetCode_0E();
  }
 
error:
  OT_ERROR_LNG_2_META(call->hdl);
 
error_mq:
  return MkErrorStack_0E();
}
 
void NS(ObjectDeleteFree) ( MkObjectDeleteFreeF_ARGS )
{
  if ( MK_RT_REF.mkThreadData.ptr == NULL || Tcl_InterpDeleted(MK_RT_REF.mkThreadData.ptr)) return;
  MK(CallFree)(dataP);
}