tclpkg-obj.cc

Go to the documentation of this file.
00001 /** @file tcl/tclpkg-obj.cc tcl interface packages for nub::object and
00002     nub::objectdb */
00003 ///////////////////////////////////////////////////////////////////////
00004 //
00005 // Copyright (c) 2002-2004 California Institute of Technology
00006 // Copyright (c) 2004-2007 University of Southern California
00007 // Rob Peters <rjpeters at usc dot edu>
00008 //
00009 // created: Fri Jun 14 16:24:33 2002
00010 // commit: $Id: tclpkg-obj.cc 11876 2009-10-22 15:53:06Z icore $
00011 // $HeadURL: svn://isvn.usc.edu/software/invt/trunk/saliency/src/tcl/tclpkg-obj.cc $
00012 //
00013 // --------------------------------------------------------------------
00014 //
00015 // This file is part of GroovX
00016 //   [http://ilab.usc.edu/rjpeters/groovx/]
00017 //
00018 // GroovX is free software; you can redistribute it and/or modify it
00019 // under the terms of the GNU General Public License as published by
00020 // the Free Software Foundation; either version 2 of the License, or
00021 // (at your option) any later version.
00022 //
00023 // GroovX is distributed in the hope that it will be useful, but
00024 // WITHOUT ANY WARRANTY; without even the implied warranty of
00025 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00026 // General Public License for more details.
00027 //
00028 // You should have received a copy of the GNU General Public License
00029 // along with GroovX; if not, write to the Free Software Foundation,
00030 // Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
00031 //
00032 ///////////////////////////////////////////////////////////////////////
00033 
00034 #ifndef GROOVX_TCL_TCLPKG_OBJ_CC_UTC20050628161246_DEFINED
00035 #define GROOVX_TCL_TCLPKG_OBJ_CC_UTC20050628161246_DEFINED
00036 
00037 #include "tcl/tclpkg-obj.h"
00038 
00039 #include "nub/objdb.h"
00040 #include "nub/objmgr.h"
00041 
00042 #include "tcl/objpkg.h"
00043 #include "tcl/pkg.h"
00044 #include "tcl/list.h"
00045 #include "tcl/interp.h"
00046 
00047 #include "rutz/demangle.h"
00048 #include "rutz/sfmt.h"
00049 
00050 #include <tcl.h>
00051 
00052 #include "rutz/trace.h"
00053 
00054 using nub::soft_ref;
00055 using nub::object;
00056 
00057 namespace
00058 {
00059   void dbClear() { nub::objectdb::instance().clear(); }
00060   void dbPurge() { nub::objectdb::instance().purge(); }
00061   void dbRelease(nub::uid id) { nub::objectdb::instance().release(id); }
00062   void dbClearOnExit() { nub::objectdb::instance().clear_on_exit(); }
00063 
00064   // This is just here to select between the const char* +
00065   // rutz::fstring versions of new_obj().
00066   soft_ref<object> objNew(const char* type)
00067   {
00068     return nub::obj_mgr::new_obj(type);
00069   }
00070 
00071   soft_ref<object> objNewArgs(const char* type,
00072                              tcl::list init_args,
00073                              tcl::interpreter interp)
00074   {
00075     soft_ref<object> obj(nub::obj_mgr::new_obj(type));
00076 
00077     for (unsigned int i = 0; i+1 < init_args.length(); i+=2)
00078       {
00079         tcl::list cmd_str;
00080         cmd_str.append("::->");
00081         cmd_str.append(obj.id());
00082         cmd_str.append(init_args[i]);
00083         cmd_str.append(init_args[i+1]);
00084         interp.eval(cmd_str.as_obj());
00085       }
00086 
00087     return obj;
00088   }
00089 
00090   tcl::list objNewArr(const char* type, unsigned int array_size)
00091   {
00092     tcl::list result;
00093 
00094     while (array_size-- > 0)
00095       {
00096         soft_ref<object> item(nub::obj_mgr::new_obj(type));
00097         result.append(item.id());
00098       }
00099 
00100     return result;
00101   }
00102 
00103   void objDelete(tcl::list objrefs)
00104   {
00105     tcl::list::iterator<nub::uid>
00106       itr = objrefs.begin<nub::uid>(),
00107       stop = objrefs.end<nub::uid>();
00108     while (itr != stop)
00109       {
00110         nub::objectdb::instance().remove(*itr);
00111         ++itr;
00112       }
00113   }
00114 
00115   void arrowDispatch(tcl::call_context& ctx)
00116   {
00117     /* old implementation was this:
00118 
00119        pkg->eval("proc ::-> {args} {\n"
00120                  "  set ids [lindex $args 0]\n"
00121                  "  set namesp [Obj::type [lindex $ids 0]]\n"
00122                  "  set cmd [lreplace $args 0 1 [lindex $args 1] $ids]\n"
00123                  "  namespace eval $namesp $cmd\n"
00124                  "}");
00125 
00126        but the problem was that it involved a string conversion cycle
00127        of the trailing args, which meant that we lost the internal rep
00128     */
00129 
00130     // e.g.      "-> {3 4} foo 4.5"
00131     // becomes   "Namesp::foo {3 4} 4.5"
00132 
00133     if (ctx.objc() < 3)
00134       throw rutz::error("bad objc", SRC_POS);
00135 
00136     Tcl_Obj* const* origargs = ctx.get_raw_args();
00137 
00138     tcl::list objrefs(origargs[1]);
00139 
00140     const rutz::fstring namesp =
00141       objrefs.get<soft_ref<object> >(0)->obj_typename();
00142 
00143     rutz::fstring origcmdname = ctx.get_arg<rutz::fstring>(2);
00144 
00145     rutz::fstring newcmdname =
00146       rutz::sfmt("%s::%s", namesp.c_str(), origcmdname.c_str());
00147 
00148     tcl::list newargs;
00149 
00150     newargs.append(newcmdname);
00151     newargs.append(objrefs);
00152 
00153     for (unsigned int i = 3; i < ctx.objc(); ++i)
00154       {
00155         newargs.append(origargs[i]);
00156       }
00157 
00158     // use eval_objv() instead of eval(), so that we don't break any
00159     // objects with fragile internal representations:
00160     ctx.interp().eval_objv(newargs);
00161   }
00162 }
00163 
00164 extern "C"
00165 int Objectdb_Init(Tcl_Interp* interp)
00166 {
00167 GVX_TRACE("Objectdb_Init");
00168 
00169   GVX_PKG_CREATE(pkg, interp, "Objectdb", "4.$Revision: 11876 $");
00170 
00171   pkg->on_exit( &dbClearOnExit );
00172 
00173   pkg->def( "clear", 0, &dbClear, SRC_POS );
00174   pkg->def( "purge", 0, &dbPurge, SRC_POS );
00175   pkg->def( "release", 0, &dbRelease, SRC_POS );
00176 
00177   GVX_PKG_RETURN(pkg);
00178 }
00179 
00180 extern "C"
00181 int Obj_Init(Tcl_Interp* interp)
00182 {
00183 GVX_TRACE("Obj_Init");
00184 
00185   GVX_PKG_CREATE(pkg, interp, "Obj", "4.$Revision: 11876 $");
00186   tcl::def_basic_type_cmds<object>(pkg, SRC_POS);
00187 
00188   pkg->def_getter("refCount", &object::dbg_ref_count, SRC_POS);
00189   pkg->def_getter("weakRefCount", &object::dbg_weak_ref_count, SRC_POS);
00190   pkg->def_action("incr_ref_count", &object::incr_ref_count, SRC_POS);
00191   pkg->def_action("decr_ref_count", &object::decr_ref_count, SRC_POS);
00192 
00193   pkg->def_getter( "type", &object::obj_typename, SRC_POS );
00194   pkg->def_getter( "realType", &object::real_typename, SRC_POS );
00195 
00196   pkg->def( "new", "typename", &objNew, SRC_POS );
00197   pkg->def( "new", "typename {cmd1 arg1 cmd2 arg2 ...}",
00198             rutz::bind_last(&objNewArgs, tcl::interpreter(interp)),
00199             SRC_POS );
00200   pkg->def( "newarr", "typename array_size=1", &objNewArr, SRC_POS );
00201   pkg->def( "delete", "objref(s)", &objDelete, SRC_POS );
00202 
00203   pkg->def_raw( "::->", tcl::arg_spec(3).nolimit(),
00204                 "objref(s) cmdname ?arg1 arg2 ...?",
00205                 &arrowDispatch, SRC_POS );
00206 
00207   pkg->namesp_alias("::", "new");
00208   pkg->namesp_alias("::", "newarr");
00209   pkg->namesp_alias("::", "delete");
00210 
00211   GVX_PKG_RETURN(pkg);
00212 }
00213 
00214 static const char __attribute__((used)) vcid_groovx_tcl_tclpkg_obj_cc_utc20050628161246[] = "$Id: tclpkg-obj.cc 11876 2009-10-22 15:53:06Z icore $ $HeadURL: svn://isvn.usc.edu/software/invt/trunk/saliency/src/tcl/tclpkg-obj.cc $";
00215 #endif // !GROOVX_TCL_TCLPKG_OBJ_CC_UTC20050628161246_DEFINED
Generated on Sun May 8 08:42:22 2011 for iLab Neuromorphic Vision Toolkit by  doxygen 1.6.3