libtcl-perl-1.02+ds.orig/0000755000175000017500000000000012344561445014510 5ustar gregoagregoalibtcl-perl-1.02+ds.orig/MANIFEST0000644000175000017500000000153512344561445015645 0ustar gregoagregoaChanges Makefile.PL Tcl extension makefile writer MANIFEST This list of files README Introduction to the Tcl extension Tcl.pm Tcl extension module Tcl.xs Tcl extension implementation t/call.t See the 'call' and 'icall' methods t/constants.t See if constants and flags are set up properly t/createcmd.t See if command creation works t/eval.t See if Eval-ish things work t/info.t See if Tcl info command works t/result.t See if Tcl result protocol works t/subclass.t See if we can subclass Tcl t/trace.t See if variable tarcing works t/unicode.t some unicode tests t/var.t See if access to/from Tcl variables works t/export_to_tcl.t test convenience sub export_to_tcl typemap Tcl extension types tclcfg.tcl Tcl script to discover TCL installation options META.yml Module meta-data (added by MakeMaker) libtcl-perl-1.02+ds.orig/Changes0000644000175000017500000001046211525175263016005 0ustar gregoagregoaRevision history for Perl extension Tcl. 1.02 2011-02-11 - fix export_to_tcl and test 1.01 2011-02-10 - export_to_tcl convenience sub 1.00 2010-11-23 - 1.0 release 0.99 2010-11-02 - more 'stubs' platform binaries - hashes also treated specially in $interp->call(...) 0.98 2009-11-24 - moved to git - Add flag to CreateCommand to suppress useless first 3 args - documentation - better tkkit.dll support - Makefile.PL has better support for AIX, Solaris, Windows 64, darwin 0.97 2008-09-07 - --usestubs default on linux - Makefile.PL should exit with status 0 on error 0.95 2007-06-07 - configuration cygwin help from Jerry D. Hedden 0.91 2006-11-13 --usestubs is no by default 0.90 2006-11-11 - more Darwin support - move 'new' method to Tcl.pm - replace DynaLoader with XSLoader, Tcl is no more ISA-DynaLoader - removed bogus insecure do"$Tcl::config::tcl_pm_path/Tcl.cfg" 0.89 23-may-2006 - Binary stub archives for various platforms to allow building the Tcl module without any Tcl distribution on the system. - misc OS shared libraries loading improvements 0.88 23-aug-2005 - documentation - moveable distributions - implement & document - TODO file removal - more OS support in Makefile.PL - some code modification in Tcl bridge - more tests 0.87 02-feb-2005 - automatic cleanup on widget deletion 0.85 31-dec-2004 - Makefile.PL makes --usestubs the default - minor test fixes for portability 0.84 13-sept-2004 - Tcl.pm changes to be more perlTk compatible - Makefile.PL contains few more OS-dependent processing 0.81 09-may-2004 - some Tcl.xs improvements, Makefile.PL now requires Tcl/Tk version 8.4 (Jeff Hobbs) 0.80 03-may-2004 - many Tcl.xs improvements from Jeff Hobbs, Gisle Aas (better handling for numbers, Unicode) - changes for event variables and in Tcl::Ev - ::perl::Eval proc in Tcl to eval in Perl - references to Perl objects now created in Tcl in ::perl namespace 0.77 17-apr-2004 - quick fix of 1=>1.0 problem - add wcall wrapper to Tcl.pm 0.76 17-apr-2004 - many improvements in Tcl.pm, Tcl.xs from Jeff Hobbs - many improvements in Tcl.pm, Tcl.xs from Gisle Aas - more tests by Jeff Hobbs, Gisle Aas - subclassing is more correct with respect to Tcl::Tk module - Makefile.PL and ceMakefile.PL now integrated to one file - General cleaning of code, more comments - Tcl-800 currently not supported, only recent versions 0.75 28-mar-2004, Vadim Konovalov - ARRAY REF are processed in $interp->call(...) for perlTk compat - replace undef with '' in $interp->call(...) 0.72 20-aug-2003, Vadim Konovalov - now widget object become replaced to widget path in arguments to 'call' - better error handling and diagnostic for calls to Tcl/Tk - now returning undef from handler subroutine do not causes an error in Tcl side. Instead, some error traping should be invented 0.71 03-jul-2003, Vadim Konovalov - support Tcl version 8.0.x 0.7 02-jul-2003, Vadim Konovalov - Some possible coredumps were fixed (but not completely, hence FIXME warning in Tcl.xs) - some fixes from Slaven Rezic, (FreeBSD support and some more) - perl-5.005 support (FreeBSD has this version after installation) 0.6 08-jun-2003, Vadim Konovalov - now Tcl 'is-a' Tcl::Tk - improved access method for TCL Events (%y, %y and so on) - WinCE support - few BUGs fixed 0.5 25-may-2003, Vadim Konovalov - 'linux' and 'cygwin' supported 0.4 19-may-2003, Vadim Konovalov - changed version system and added module VERSION variable - compatibility changes to support modern versions of Perl and Tcl (perl-5.6.0, perl-5.8.0, tcl-8.4.2) - call to Tcl_FindExecutable, as long as Tcl now requires this (otherwise Tcl dumps core, as RTFS-ing of Tcl shows) - XS function "Tcl::call" renamed to "Tcl::icall" and "Tcl::call" implemented in Tcl.pm and now contains more complex logic. - sub create_tcl_sub and ev_sub were added, they could be used to create event fields-aware subroutines - added 'tclcfg.tcl' to output tcl configuration, used from Makefile.PL - Makefile.PL changed to be more consistent - use strict; Tcl-b3 11-mar-2001, Andrew Brown - minor update for compatability with perl 5.6.0 by Andrew Brown Tcl-b2 1997, Malcolm Beattie - Created entire module. libtcl-perl-1.02+ds.orig/typemap0000644000175000017500000000006011525175263016105 0ustar gregoagregoaTcl T_PTROBJ Tcl::Var T_AVREF PerlIO * T_INOUT libtcl-perl-1.02+ds.orig/Tcl.xs0000644000175000017500000012553111525175263015614 0ustar gregoagregoa/* * Tcl.xs -- * * This file contains XS code for the Perl's Tcl bridge module. * * Copyright (c) 1994-1997, Malcolm Beattie * Copyright (c) 2003-2004, Vadim Konovalov * Copyright (c) 2004 ActiveState Corp., a division of Sophos PLC * */ #define PERL_NO_GET_CONTEXT /* we want efficiency */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifndef DEBUG_REFCOUNTS #define DEBUG_REFCOUNTS 0 #endif /* * Until we update for 8.4 CONST-ness */ #define USE_NON_CONST /* * Both Perl and Tcl use these macros */ #undef STRINGIFY #undef JOIN #include #ifdef USE_TCL_STUBS /* * If we use the Tcl stubs mechanism, this provides us Tcl version * and direct dll independence, but we must force the loading of * the dll ourselves based on a set of heuristics in NpLoadLibrary. */ #ifndef TCL_LIB_FILE # ifdef WIN32 # define TCL_LIB_FILE "tcl84.dll" # elif defined(__APPLE__) # define TCL_LIB_FILE "Tcl" # elif defined(__hpux) # define TCL_LIB_FILE "libtcl8.4.sl" # else # define TCL_LIB_FILE "libtcl8.4.so" # endif #endif /* * Default directory in which to look for Tcl/Tk libraries. The * symbol is defined by Makefile. */ #ifndef LIB_RUNTIME_DIR # define LIB_RUNTIME_DIR "." #endif static char defaultLibraryDir[sizeof(LIB_RUNTIME_DIR)+200] = LIB_RUNTIME_DIR; #if defined(WIN32) #ifndef HMODULE #define HMODULE void * #endif #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN #define dlopen(libname, flags) LoadLibrary(libname) #define dlclose(path) ((void *) FreeLibrary((HMODULE) path)) #define DLSYM(handle, symbol, type, proc) \ (proc = (type) GetProcAddress((HINSTANCE) handle, symbol)) #define snprintf _snprintf #elif defined(__APPLE__) #include static short DOMAINS[] = { kUserDomain, kLocalDomain, kNetworkDomain, kSystemDomain }; static const int DOMAINS_LEN = sizeof(DOMAINS)/sizeof(DOMAINS[0]); #elif defined(__hpux) /* HPUX requires shl_* routines */ #include #define HMODULE shl_t #define dlopen(libname, flags) shl_load(libname, \ BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L) #define dlclose(path) shl_unload((shl_t) path) #define DLSYM(handle, symbol, type, proc) \ if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE, \ (void *) &proc) != 0) { proc = NULL; } #endif #ifndef HMODULE #include #define HMODULE void * #define DLSYM(handle, symbol, type, proc) \ (proc = (type) dlsym(handle, symbol)) #endif #ifndef MAX_PATH #define MAX_PATH 1024 #endif /* * Tcl library handle */ static HMODULE tclHandle = NULL; static Tcl_Interp *g_Interp = NULL; static int (* tclKit_AppInit)(Tcl_Interp *) = NULL; #else /* * !USE_TCL_STUBS */ static int (* tclKit_AppInit)(Tcl_Interp *) = Tcl_Init; #if defined(HAVE_TKINIT) && defined(WIN32) HANDLE _hinst = 0; BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, LPVOID reserved) { _hinst = hInst; return TRUE; } #endif #endif typedef Tcl_Interp *Tcl; typedef AV *Tcl__Var; #ifdef HAVE_TKINIT EXTERN char * TclSetPreInitScript (char * string); void TclpInitLibraryPath(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); EXTERN void TkWinSetHINSTANCE (HINSTANCE hInstance); #endif #ifdef HAVE_BLTINIT extern Tcl_PackageInitProc Blt_Init, Blt_SafeInit; #endif /* * Variables denoting the Tcl object types defined in the core. * These may not exist - guard against NULL result. */ static Tcl_ObjType *tclBooleanTypePtr = NULL; static Tcl_ObjType *tclByteArrayTypePtr = NULL; static Tcl_ObjType *tclDoubleTypePtr = NULL; static Tcl_ObjType *tclIntTypePtr = NULL; static Tcl_ObjType *tclListTypePtr = NULL; static Tcl_ObjType *tclStringTypePtr = NULL; static Tcl_ObjType *tclWideIntTypePtr = NULL; /* * This tells us whether Tcl is in a "callable" state. Set to 1 in BOOT * and 0 in Tcl__Finalize (END). Once finalized, we should not make any * more calls to Tcl_* APIs. * hvInterps is a hash that records all live interps, so that we can * force their deletion before the finalization. */ static int initialized = 0; static HV *hvInterps = NULL; /* * FUNCTIONS */ #ifdef USE_TCL_STUBS /* *---------------------------------------------------------------------- * * NpLoadLibrary -- * * * Results: * Stores the handle of the library found in tclHandle and the * name it successfully loaded from in dllFilename (if dllFilenameSize is != 0). * * Side effects: * Loads the library - user needs to dlclose it.. * *---------------------------------------------------------------------- */ static int NpLoadLibrary(pTHX_ HMODULE *tclHandle, char *dllFilename, int dllFilenameSize) { char *dl_path, libname[MAX_PATH]; HMODULE handle = (HMODULE) NULL; /* * Try a user-supplied Tcl dll to start with. * If the var is supplied, force this to be correct or error out. */ dl_path = SvPV_nolen(get_sv("Tcl::DL_PATH", TRUE)); if (dl_path && *dl_path) { handle = dlopen(dl_path, RTLD_NOW | RTLD_GLOBAL); if (handle) { memcpy(libname, dl_path, MAX_PATH); } else { #if !defined(WIN32) && !defined(__hpux) char *error = dlerror(); if (error != NULL) { warn(error); } #endif warn("NpLoadLibrary: could not find Tcl library at '%s'", dl_path); return TCL_ERROR; } } #ifdef __APPLE__ if (!handle) { OSErr oserr; FSRef ref; int i; for (i = 0; i < DOMAINS_LEN; i++) { oserr = FSFindFolder(DOMAINS[i], kFrameworksFolderType, kDontCreateFolder, &ref); if (oserr != noErr) { continue; } oserr = FSRefMakePath(&ref, (UInt8*)libname, sizeof(libname)); if (oserr != noErr) { continue; } /* * This should really just try loading Tcl.framework/Tcl, but will * fail if the user has requested an alternate TCL_LIB_FILE. */ strcat(libname, "/Tcl.framework/" TCL_LIB_FILE); /* printf("Try \"%s\"\n", libname); */ handle = dlopen(libname, RTLD_NOW | RTLD_GLOBAL); if (handle) { break; } } } #endif if (!handle) { char *pos; if (strlen(TCL_LIB_FILE) < 3) { warn("Invalid base Tcl library filename provided: '%s'", TCL_LIB_FILE); return TCL_ERROR; } /* Try based on full path. */ snprintf(libname, MAX_PATH-1, "%s/%s", defaultLibraryDir, TCL_LIB_FILE); handle = dlopen(libname, RTLD_NOW | RTLD_GLOBAL); if (!handle) { /* Try based on anywhere in the path. */ strcpy(libname, TCL_LIB_FILE); handle = dlopen(libname, RTLD_NOW | RTLD_GLOBAL); } if (!handle) { /* Try different versions anywhere in the path. */ pos = strstr(libname, "tcl8")+4; if (*pos == '.') { pos++; } *pos = '9'; /* count down from '8' to '4'*/ while (!handle && (--*pos > '3')) { handle = dlopen(libname, RTLD_NOW | RTLD_GLOBAL); } } } #ifdef WIN32 if (!handle) { char path[MAX_PATH], vers[MAX_PATH]; DWORD result, size = MAX_PATH; HKEY regKey; #define TCL_REG_DIR_KEY "Software\\ActiveState\\ActiveTcl" result = RegOpenKeyEx(HKEY_LOCAL_MACHINE, TCL_REG_DIR_KEY, 0, KEY_READ, ®Key); if (result != ERROR_SUCCESS) { warn("Could not access registry \"HKLM\\%s\"\n", TCL_REG_DIR_KEY); result = RegOpenKeyEx(HKEY_CURRENT_USER, TCL_REG_DIR_KEY, 0, KEY_READ, ®Key); if (result != ERROR_SUCCESS) { warn("Could not access registry \"HKCU\\%s\"\n", TCL_REG_DIR_KEY); return TCL_ERROR; } } result = RegQueryValueEx(regKey, "CurrentVersion", NULL, NULL, vers, &size); RegCloseKey(regKey); if (result != ERROR_SUCCESS) { warn("Could not access registry \"%s\" CurrentVersion\n", TCL_REG_DIR_KEY); return TCL_ERROR; } snprintf(path, MAX_PATH-1, "%s\\%s", TCL_REG_DIR_KEY, vers); result = RegOpenKeyEx(HKEY_LOCAL_MACHINE, path, 0, KEY_READ, ®Key); if (result != ERROR_SUCCESS) { warn("Could not access registry \"%s\"\n", path); return TCL_ERROR; } size = MAX_PATH; result = RegQueryValueEx(regKey, NULL, NULL, NULL, path, &size); RegCloseKey(regKey); if (result != ERROR_SUCCESS) { warn("Could not access registry \"%s\" Default\n", TCL_REG_DIR_KEY); return TCL_ERROR; } warn("Found current Tcl installation at \"%s\"\n", path); snprintf(libname, MAX_PATH-1, "%s\\bin\\%s", path, TCL_LIB_FILE); handle = dlopen(libname, RTLD_NOW | RTLD_GLOBAL); } #endif if (!handle) { warn("NpLoadLibrary: could not find Tcl dll\n"); return TCL_ERROR; } *tclHandle = handle; if (dllFilenameSize > 0) { memcpy(dllFilename, libname, dllFilenameSize); } return TCL_OK; } /* *---------------------------------------------------------------------- * * NpInitialize -- * * Create the main interpreter. * * Results: * The pointer to the main interpreter. * * Side effects: * Will panic if called twice. (Must call DestroyMainInterp in between) * *---------------------------------------------------------------------- */ static int NpInitialize(pTHX_ SV *X) { static Tcl_Interp * (* createInterp)() = NULL; static void (* findExecutable)(char *) = NULL; /* * We want the Tcl_InitStubs func static to ourselves - before Tcl * is loaded dyanmically and possibly changes it. */ static CONST char *(*initstubs)(Tcl_Interp *, CONST char *, int) = Tcl_InitStubs; char dllFilename[MAX_PATH]; dllFilename[0] = '\0'; #ifdef USE_TCL_STUBS /* * Determine the libname and version number dynamically */ if (tclHandle == NULL) { /* * First see if some other part didn't already load Tcl. */ DLSYM(tclHandle, "Tcl_CreateInterp", Tcl_Interp * (*)(), createInterp); if (createInterp == NULL) { if (NpLoadLibrary(aTHX_ &tclHandle, dllFilename, MAX_PATH) != TCL_OK) { warn("Failed to load Tcl dll!"); return TCL_ERROR; } } DLSYM(tclHandle, "Tcl_CreateInterp", Tcl_Interp * (*)(), createInterp); if (createInterp == NULL) { #if !defined(WIN32) && !defined(__hpux) char *error = dlerror(); if (error != NULL) { warn(error); } #endif return TCL_ERROR; } DLSYM(tclHandle, "Tcl_FindExecutable", void (*)(char *), findExecutable); DLSYM(tclHandle, "TclKit_AppInit", int (*)(Tcl_Interp *), tclKit_AppInit); } #else createInterp = Tcl_CreateInterp; findExecutable = Tcl_FindExecutable; #endif #ifdef WIN32 if (dllFilename[0] == '\0') { GetModuleFileNameA((HINSTANCE) tclHandle, dllFilename, MAX_PATH); } findExecutable(dllFilename); #else findExecutable(X && SvPOK(X) ? SvPV_nolen(X) : NULL); #endif g_Interp = createInterp(); if (g_Interp == (Tcl_Interp *) NULL) { warn("Failed to create main Tcl interpreter!"); return TCL_ERROR; } /* * Until Tcl_InitStubs is called, we cannot make any Tcl/Tk API * calls without grabbing them by symbol out of the dll. * This will be Tcl_PkgRequire for non-stubs builds. */ if (initstubs(g_Interp, "8.4", 0) == NULL) { warn("Failed to initialize Tcl stubs!"); return TCL_ERROR; } /* * If we didn't find TclKit_AppInit, then this is a regular Tcl * installation, so invoke Tcl_Init. * Otherwise, we need to set the kit path to indicate we want to * use the dll as our base kit. */ if (tclKit_AppInit == NULL) { tclKit_AppInit = Tcl_Init; } else { char * (* tclKit_SetKitPath)(char *) = NULL; /* * We need to see if this has TclKit_SetKitPath. This is in * special base kit dlls that have embedded data in the dll. */ if (dllFilename[0] != '\0') { DLSYM(tclHandle, "TclKit_SetKitPath", char * (*)(char *), tclKit_SetKitPath); if (tclKit_SetKitPath != NULL) { /* * XXX: Need to figure out how to populate dllFilename if * NpLoadLibrary didn't do it for us on Unix. */ tclKit_SetKitPath(dllFilename); } } } if (tclKit_AppInit(g_Interp) != TCL_OK) { CONST84 char *msg = Tcl_GetVar(g_Interp, "errorInfo", TCL_GLOBAL_ONLY); warn("Failed to initialize Tcl with %s:\n%s", (tclKit_AppInit == Tcl_Init) ? "Tcl_Init" : "TclKit_AppInit", msg); return TCL_ERROR; } /* * Hold on to the interp handle until finalize, as special * kit-based interps require the first initialized interp to * remain alive. */ return TCL_OK; } #endif #if DEBUG_REFCOUNTS static void check_refcounts(Tcl_Obj *objPtr) { int rc = objPtr->refCount; if (rc != 1) { fprintf(stderr, "objPtr %p refcount %d\n", objPtr, rc); fflush(stderr); } if (objPtr->typePtr == tclListTypePtr) { int objc, i; Tcl_Obj **objv; Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); for (i = 0; i < objc; i++) { check_refcounts(objv[i]); } } } #endif static int has_highbit(CONST char *s, int len) { CONST char *e = s + len; while (s < e) { if (*s++ & 0x80) return 1; } return 0; } static SV * SvFromTclObj(pTHX_ Tcl_Obj *objPtr) { SV *sv; int len; char *str; if (objPtr == NULL) { /* * Use newSV(0) instead of &PL_sv_undef as it may be stored in an AV. * It also provides symmetry with the other newSV* calls below. * This SV will also be mortalized later. */ sv = newSV(0); } else if (objPtr->typePtr == tclIntTypePtr) { sv = newSViv(objPtr->internalRep.longValue); } else if (objPtr->typePtr == tclDoubleTypePtr) { sv = newSVnv(objPtr->internalRep.doubleValue); } else if (objPtr->typePtr == tclBooleanTypePtr) { /* * Booleans can originate as words (yes/true/...), so if there is a * string rep, use it instead. We could check if the first byte * isdigit(). No need to check utf-8 as the all valid boolean words * are ascii-7. */ if (objPtr->typePtr == NULL) { sv = newSVsv(boolSV(objPtr->internalRep.longValue != 0)); } else { str = Tcl_GetStringFromObj(objPtr, &len); sv = newSVpvn(str, len); } } else if (objPtr->typePtr == tclByteArrayTypePtr) { str = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); sv = newSVpvn(str, len); } else if (objPtr->typePtr == tclListTypePtr) { /* * tclListTypePtr should become an AV. * This code needs to reconcile with G_ context in prepare_Tcl_result * and user's expectations of how data will be passed in. The key is * that a stringified-list and pure-list should be operable in the * same way in Perl. * * We have to watch for "empty" lists, which could equate to the * empty string. Tcl's literal object sharing means that "" could * be typed as a list, although we don't want to see it that way. * Just treat empty list objects as an empty (not undef) SV. */ int objc; Tcl_Obj **objv; Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); if (objc) { int i; AV *av = newAV(); for (i = 0; i < objc; i++) { av_push(av, SvFromTclObj(aTHX_ objv[i])); } sv = sv_bless(newRV_noinc((SV *) av), gv_stashpv("Tcl::List", 1)); } else { sv = newSVpvn("", 0); } } /* tclStringTypePtr is true unicode */ /* tclWideIntTypePtr is 64-bit int */ else { str = Tcl_GetStringFromObj(objPtr, &len); sv = newSVpvn(str, len); /* should turn on, but let's check this first for efficiency */ if (len && has_highbit(str, len)) { /* * Tcl can encode NULL as overlong utf-8 \300\200 (\xC0\x80). * Tcl itself doesn't require this, but some extensions do when * they pass the string data to native C APIs (like strlen). * Tk is the most notable case for this (calling out to native UI * toolkit APIs that don't take counted strings). * s/\300\200/\0/g */ char *nul_start; STRLEN len; char *s = SvPV(sv, len); char *end = s + len; while ((nul_start = memchr(s, '\300', len))) { if (nul_start + 1 < end && nul_start[1] == '\200') { /* found it */ nul_start[0] = '\0'; memmove(nul_start + 1, nul_start + 2, end - (nul_start + 2)); len--; end--; *end = '\0'; SvCUR_set(sv, SvCUR(sv) - 1); } len -= (nul_start + 1) - s; s = nul_start + 1; } SvUTF8_on(sv); } } return sv; } /* * Create a Tcl_Obj from a Perl SV. * Return Tcl_Obj with refcount = 0. Caller should call Tcl_IncrRefCount * or pass of to function that does (manage object lifetime). */ static Tcl_Obj * TclObjFromSv(pTHX_ SV *sv) { Tcl_Obj *objPtr = NULL; if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV && (!SvOBJECT(SvRV(sv)) || sv_isa(sv, "Tcl::List"))) { /* * Recurse into ARRAYs, turning them into Tcl list Objs */ SV **svp; AV *av = (AV *) SvRV(sv); I32 avlen = av_len(av); int i; objPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); for (i = 0; i <= avlen; i++) { svp = av_fetch(av, i, FALSE); if (svp == NULL) { /* watch for sparse arrays - translate as empty element */ /* XXX: Is this handling refcount on NewObj right? */ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj()); } else { if ((AV *) SvRV(*svp) == av) { /* XXX: Is this a proper check for cyclical reference? */ croak("cyclical array reference found"); abort(); } Tcl_ListObjAppendElement(NULL, objPtr, TclObjFromSv(aTHX_ sv_mortalcopy(*svp))); } } } else if (SvPOK(sv)) { STRLEN length; char *str = SvPV(sv, length); /* * Tcl's "String" object expects utf-8 strings. If we aren't sure * that we have a utf-8 data, pass it as a Tcl ByteArray (C char*). * * XXX Possible optimization opportunity here. Tcl will actually * XXX accept and handle most latin-1 char sequences correctly, but * XXX not blocks of truly binary data. This code is 100% correct, * XXX but could be tweaked to improve performance. */ if (SvUTF8(sv)) { /* * Tcl allows NULL to be encoded overlong as \300\200 (\xC0\x80). * Tcl itself doesn't require this, but some extensions do when * they pass the string data to native C APIs (like strlen). * Tk is the most notable case for this (calling out to native UI * toolkit APIs that don't take counted strings). */ if (memchr(str, '\0', length)) { /* ($sv_copy = $sv) =~ s/\0/\300\200/g */ SV *sv_copy = sv_mortalcopy(sv); STRLEN len; char *s = SvPV(sv_copy, len); char *nul; while ((nul = memchr(s, '\0', len))) { STRLEN i = nul - SvPVX(sv_copy); s = SvGROW(sv_copy, SvCUR(sv_copy) + 2); nul = s + i; memmove(nul + 2, nul + 1, SvEND(sv_copy) - (nul + 1)); nul[0] = '\300'; nul[1] = '\200'; SvCUR_set(sv_copy, SvCUR(sv_copy) + 1); s = nul + 2; len = SvEND(sv_copy) - s; } str = SvPV(sv_copy, length); } objPtr = Tcl_NewStringObj(str, length); } else { objPtr = Tcl_NewByteArrayObj((unsigned char *)str, length); } } else if (SvNOK(sv)) { double dval = SvNV(sv); int ival; /* * Perl does math with doubles by default, so 0 + 1 == 1.0. * Check for int-equiv doubles and make those ints. * XXX This check possibly only necessary for <=5.6.x */ if (((double)(ival = SvIV(sv)) == dval)) { objPtr = Tcl_NewIntObj(ival); } else { objPtr = Tcl_NewDoubleObj(dval); } } else if (SvIOK(sv)) { objPtr = Tcl_NewIntObj(SvIV(sv)); } else { /* * Catch-all * XXX: Should we recurse other REFs, or better to stringify them? */ STRLEN length; char *str = SvPV(sv, length); /* * Tcl's "String" object expects utf-8 strings. If we aren't sure * that we have a utf-8 data, pass it as a Tcl ByteArray (C char*). */ if (SvUTF8(sv)) { /* * Should we consider overlong NULL encoding for Tcl here? */ objPtr = Tcl_NewStringObj(str, length); } else { objPtr = Tcl_NewByteArrayObj((unsigned char *) str, length); } } return objPtr; } int Tcl_EvalInPerl(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { dTHX; /* fetch context */ dSP; I32 count; SV *sv; int rc; /* * This is the command created in Tcl to eval stuff in Perl */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); } ENTER; SAVETMPS; PUSHMARK(sp); PUTBACK; count = perl_eval_sv(sv_2mortal(SvFromTclObj(aTHX_ objv[1])), G_EVAL|G_SCALAR); SPAGAIN; if (SvTRUE(ERRSV)) { Tcl_SetResult(interp, SvPV_nolen(ERRSV), TCL_VOLATILE); POPs; /* pop the undef off the stack */ rc = TCL_ERROR; } else { if (count != 1) { croak("Perl sub bound to Tcl proc returned %d args, expected 1", count); } sv = POPs; /* pop the undef off the stack */ if (SvOK(sv)) { Tcl_Obj *objPtr = TclObjFromSv(aTHX_ sv); /* Tcl_SetObjResult will incr refcount */ Tcl_SetObjResult(interp, objPtr); } rc = TCL_OK; } PUTBACK; /* * If the routine returned undef, it indicates that it has done the * SetResult itself and that we should return TCL_ERROR */ FREETMPS; LEAVE; return rc; } int Tcl_PerlCallWrapper(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { dTHX; /* fetch context */ dSP; AV *av = (AV *) clientData; I32 count; SV *sv; int flag; int rc; /* * av = [$perlsub, $realclientdata, $interp, $deleteProc] * (where $deleteProc is optional but we don't need it here anyway) */ if (AvFILL(av) != 3 && AvFILL(av) != 4) croak("bad clientdata argument passed to Tcl_PerlCallWrapper"); flag = SvIV(*av_fetch(av, 3, FALSE)); ENTER; SAVETMPS; PUSHMARK(sp); if (flag & 1) { if (objc) { objc--; objv++; EXTEND(sp, objc); } } else { EXTEND(sp, objc + 2); /* * Place clientData and original interp on the stack, then the * Tcl object invoke list, including the command name. Users * who only want the args from Tcl can splice off the first 3 args */ PUSHs(sv_mortalcopy(*av_fetch(av, 1, FALSE))); PUSHs(sv_mortalcopy(*av_fetch(av, 2, FALSE))); } while (objc--) { PUSHs(sv_2mortal(SvFromTclObj(aTHX_ *objv++))); } PUTBACK; count = perl_call_sv(*av_fetch(av, 0, FALSE), G_EVAL|G_SCALAR); SPAGAIN; if (SvTRUE(ERRSV)) { Tcl_SetResult(interp, SvPV_nolen(ERRSV), TCL_VOLATILE); POPs; /* pop the undef off the stack */ rc = TCL_ERROR; } else { if (count != 1) { croak("Perl sub bound to Tcl proc returned %d args, expected 1", count); } sv = POPs; /* pop the undef off the stack */ if (SvOK(sv)) { Tcl_Obj *objPtr = TclObjFromSv(aTHX_ sv); /* Tcl_SetObjResult will incr refcount */ Tcl_SetObjResult(interp, objPtr); } rc = TCL_OK; } PUTBACK; /* * If the routine returned undef, it indicates that it has done the * SetResult itself and that we should return TCL_ERROR */ FREETMPS; LEAVE; return rc; } void Tcl_PerlCallDeleteProc(ClientData clientData) { dTHX; /* fetch context */ AV *av = (AV *) clientData; /* * av = [$perlsub, $realclientdata, $interp, $deleteProc] * (where $deleteProc is optional but we don't need it here anyway) */ if (AvFILL(av) == 4) { dSP; PUSHMARK(sp); EXTEND(sp, 1); PUSHs(sv_mortalcopy(*av_fetch(av, 1, FALSE))); PUTBACK; (void) perl_call_sv(*av_fetch(av, 4, FALSE), G_SCALAR|G_DISCARD); } else if (AvFILL(av) != 3) { croak("bad clientdata argument passed to Tcl_PerlCallDeleteProc"); } SvREFCNT_dec(av); } void prepare_Tcl_result(pTHX_ Tcl interp, char *caller) { dSP; Tcl_Obj *objPtr, **objv; int gimme, objc, i; objPtr = Tcl_GetObjResult(interp); gimme = GIMME_V; if (gimme == G_SCALAR) { /* * This checks Tcl_Obj type. XPUSH not needed because we * are called when there is enough space on the stack. */ PUSHs(sv_2mortal(SvFromTclObj(aTHX_ objPtr))); } else if (gimme == G_ARRAY) { if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { croak("%s called in list context did not return a valid Tcl list", caller); } if (objc) { EXTEND(sp, objc); for (i = 0; i < objc; i++) { /* * This checks Tcl_Obj type */ PUSHs(sv_2mortal(SvFromTclObj(aTHX_ objv[i]))); } } } else { /* G_VOID context - ignore result */ } PUTBACK; return; } char * var_trace(ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags) { dTHX; /* fetch context */ if (flags & TCL_TRACE_READS) { warn("TCL_TRACE_READS\n"); } else if (flags & TCL_TRACE_WRITES) { warn("TCL_TRACE_WRITES\n"); } else if (flags & TCL_TRACE_ARRAY) { warn("TCL_TRACE_ARRAY\n"); } else if (flags & TCL_TRACE_UNSETS) { warn("TCL_TRACE_UNSETS\n"); } return 0; } MODULE = Tcl PACKAGE = Tcl PREFIX = Tcl_ SV * Tcl__new(class = "Tcl") char * class CODE: RETVAL = newSV(0); /* * We might consider Tcl_Preserve/Tcl_Release of the interp. */ if (initialized) { Tcl interp = Tcl_CreateInterp(); /* * Add to the global hash of live interps. */ if (hvInterps) { (void) hv_store(hvInterps, (const char *) &interp, sizeof(Tcl), &PL_sv_undef, 0); } sv_setref_pv(RETVAL, class, (void*)interp); } OUTPUT: RETVAL SV * Tcl_result(interp) Tcl interp CODE: if (initialized) { RETVAL = SvFromTclObj(aTHX_ Tcl_GetObjResult(interp)); } else { RETVAL = &PL_sv_undef; } OUTPUT: RETVAL void Tcl_Eval(interp, script, flags = 0) Tcl interp SV * script int flags SV * interpsv = ST(0); STRLEN length = NO_INIT char *cscript = NO_INIT PPCODE: if (!initialized) { return; } (void) sv_2mortal(SvREFCNT_inc(interpsv)); PUTBACK; Tcl_ResetResult(interp); /* sv_mortalcopy here prevents stringifying script - necessary ?? */ cscript = SvPV(sv_mortalcopy(script), length); if (Tcl_EvalEx(interp, cscript, length, flags) != TCL_OK) { croak(Tcl_GetStringResult(interp)); } prepare_Tcl_result(aTHX_ interp, "Tcl::Eval"); SPAGAIN; #ifdef HAVE_TKINIT char* Tcl_SetPreInitScript(script) char * script CODE: if (!initialized) { return; } RETVAL = TclSetPreInitScript(script); OUTPUT: RETVAL void TclpInitLibraryPath(path) char * path PPCODE: int lengthPtr=0; Tcl_Encoding encodingPtr; if (!initialized) { return; } /* interface to TclpInitLibraryPath changed between 8.4.x and 8.5.x */ TclpInitLibraryPath(&path, &lengthPtr, &encodingPtr); void Tcl_SetDefaultEncodingDir(script) char * script PPCODE: if (!initialized) { return; } Tcl_SetDefaultEncodingDir(script); char* Tcl_GetDefaultEncodingDir(void) CODE: if (!initialized) { return; } RETVAL = Tcl_GetDefaultEncodingDir(); OUTPUT: RETVAL void* Tcl_GetEncoding(interp, enc) Tcl interp char *enc PPCODE: if (!initialized) { return; } Tcl_GetEncoding(interp,enc); #endif /* HAVE_TKINIT */ void Tcl_EvalFile(interp, filename) Tcl interp char * filename SV * interpsv = ST(0); PPCODE: if (!initialized) { return; } (void) sv_2mortal(SvREFCNT_inc(interpsv)); PUTBACK; Tcl_ResetResult(interp); if (Tcl_EvalFile(interp, filename) != TCL_OK) { croak(Tcl_GetStringResult(interp)); } prepare_Tcl_result(aTHX_ interp, "Tcl::EvalFile"); SPAGAIN; void Tcl_EvalFileHandle(interp, handle) Tcl interp PerlIO* handle int append = 0; SV * interpsv = ST(0); SV * sv = sv_newmortal(); char * s = NO_INIT PPCODE: if (!initialized) { return; } (void) sv_2mortal(SvREFCNT_inc(interpsv)); PUTBACK; while ((s = sv_gets(sv, handle, append))) { if (!Tcl_CommandComplete(s)) append = 1; else { Tcl_ResetResult(interp); if (Tcl_Eval(interp, s) != TCL_OK) croak(Tcl_GetStringResult(interp)); append = 0; } } if (append) croak("unexpected end of file in Tcl::EvalFileHandle"); prepare_Tcl_result(aTHX_ interp, "Tcl::EvalFileHandle"); SPAGAIN; void Tcl_invoke(interp, sv, ...) Tcl interp SV * sv PPCODE: { /* * 'Tcl::invoke' invokes the command directly, avoiding * command tracing and the ::unknown mechanism. */ #define NUM_OBJS 16 Tcl_Obj *baseobjv[NUM_OBJS]; Tcl_Obj **objv = baseobjv; char *cmdName; int objc, i, result; STRLEN length; Tcl_CmdInfo cmdinfo; if (!initialized) { return; } objv = baseobjv; objc = items-1; if (objc > NUM_OBJS) { New(666, objv, objc, Tcl_Obj *); } SP += items; PUTBACK; /* Verify first arg is a Tcl command */ cmdName = SvPV(sv, length); if (!Tcl_GetCommandInfo(interp, cmdName, &cmdinfo)) { croak("Tcl procedure '%s' not found", cmdName); } if (cmdinfo.objProc && cmdinfo.isNativeObjectProc) { /* * We might want to check that this isn't * TclInvokeStringCommand, which just means we waste time * making Tcl_Obj's. * * Emulate TclInvokeObjectCommand (from Tcl), namely create the * object argument array "objv" before calling right procedure */ objv[0] = Tcl_NewStringObj(cmdName, length); Tcl_IncrRefCount(objv[0]); for (i = 1; i < objc; i++) { /* * Use efficient Sv to Tcl_Obj conversion. * This returns Tcl_Obj with refcount 1. * This can cause recursive calls if we have tied vars. */ objv[i] = TclObjFromSv(aTHX_ sv_mortalcopy(ST(i+1))); Tcl_IncrRefCount(objv[i]); } SP -= items; PUTBACK; /* * Result interp result and invoke the command's object-based * Tcl_ObjCmdProc. */ #if DEBUG_REFCOUNTS for (i = 1; i < objc; i++) { check_refcounts(objv[i]); } #endif Tcl_ResetResult(interp); result = (*cmdinfo.objProc)(cmdinfo.objClientData, interp, objc, objv); /* * Decrement ref count for first arg, others decr'd below */ Tcl_DecrRefCount(objv[0]); } else { /* * we have cmdinfo.objProc==0 * prepare string arguments into argv (1st is already done) * and call found procedure */ char *baseargv[NUM_OBJS]; char **argv = baseargv; if (objc > NUM_OBJS) { New(666, argv, objc, char *); } argv[0] = cmdName; for (i = 1; i < objc; i++) { /* * We need the inefficient round-trip through Tcl_Obj to * ensure that we are listify-ing correctly. * This can cause recursive calls if we have tied vars. */ objv[i] = TclObjFromSv(aTHX_ sv_mortalcopy(ST(i+1))); Tcl_IncrRefCount(objv[i]); argv[i] = Tcl_GetString(objv[i]); } SP -= items; PUTBACK; /* * Result interp result and invoke the command's string-based * procedure. */ #if DEBUG_REFCOUNTS for (i = 1; i < objc; i++) { check_refcounts(objv[i]); } #endif Tcl_ResetResult(interp); result = (*cmdinfo.proc)(cmdinfo.clientData, interp, objc, argv); if (argv != baseargv) { Safefree(argv); } } /* * Decrement the ref counts for the argument objects created above */ for (i = 1; i < objc; i++) { Tcl_DecrRefCount(objv[i]); } if (result != TCL_OK) { croak(Tcl_GetStringResult(interp)); } prepare_Tcl_result(aTHX_ interp, "Tcl::invoke"); if (objv != baseobjv) { Safefree(objv); } SPAGAIN; #undef NUM_OBJS } void Tcl_icall(interp, sv, ...) Tcl interp SV * sv PPCODE: { /* * 'Tcl::icall' passes the args to Tcl to invoke. It will do * command tracing and call ::unknown mechanism for unrecognized * commands. */ #define NUM_OBJS 16 Tcl_Obj *baseobjv[NUM_OBJS]; Tcl_Obj **objv = baseobjv; int objc, i, result; if (!initialized) { return; } objc = items-1; if (objc > NUM_OBJS) { New(666, objv, objc, Tcl_Obj *); } SP += items; PUTBACK; for (i = 0; i < objc; i++) { /* * Use efficient Sv to Tcl_Obj conversion. * This returns Tcl_Obj with refcount 1. * This can cause recursive calls if we have tied vars. */ objv[i] = TclObjFromSv(aTHX_ sv_mortalcopy(ST(i+1))); Tcl_IncrRefCount(objv[i]); } SP -= items; PUTBACK; /* * Reset current result and invoke using Tcl_EvalObjv. * This will trigger command traces and handle async signals. */ #if DEBUG_REFCOUNTS for (i = 1; i < objc; i++) { check_refcounts(objv[i]); } #endif Tcl_ResetResult(interp); result = Tcl_EvalObjv(interp, objc, objv, 0); /* * Decrement the ref counts for the argument objects created above */ for (i = 0; i < objc; i++) { Tcl_DecrRefCount(objv[i]); } if (result != TCL_OK) { croak(Tcl_GetStringResult(interp)); } prepare_Tcl_result(aTHX_ interp, "Tcl::icall"); if (objv != baseobjv) { Safefree(objv); } SPAGAIN; #undef NUM_OBJS } void Tcl_DESTROY(interp) Tcl interp CODE: if (initialized) { Tcl_DeleteInterp(interp); /* * Remove from the global hash of live interps. */ if (hvInterps) { (void) hv_delete(hvInterps, (const char *) interp, sizeof(Tcl), G_DISCARD); } } void Tcl__Finalize(interp=NULL) Tcl interp CODE: /* * This should be called from the END block - when we no * longer plan to use Tcl *AT ALL*. */ if (!initialized) { return; } if (hvInterps) { /* * Delete all the global hash of live interps. */ HE *he; hv_iterinit(hvInterps); he = hv_iternext(hvInterps); while (he) { I32 len; interp = *((Tcl *) hv_iterkey(he, &len)); Tcl_DeleteInterp(interp); he = hv_iternext(hvInterps); } hv_undef(hvInterps); hvInterps = NULL; } #ifdef USE_TCL_STUBS if (g_Interp) { Tcl_DeleteInterp(g_Interp); g_Interp = NULL; } #endif Tcl_Finalize(); initialized = 0; #ifdef USE_TCL_STUBS if (tclHandle) { dlclose(tclHandle); tclHandle = NULL; } #endif void Tcl_Init(interp) Tcl interp CODE: if (!initialized) { return; } if (tclKit_AppInit(interp) != TCL_OK) { croak(Tcl_GetStringResult(interp)); } Tcl_CreateObjCommand(interp, "::perl::Eval", Tcl_EvalInPerl, (ClientData) NULL, NULL); #ifdef HAVE_DDEINIT void Dde_Init(interp) Tcl interp CODE: Dde_Init(interp); #endif #ifdef HAVE_TKINIT void Tk_Init(interp) Tcl interp CODE: Tk_Init(interp); #endif #ifdef HAVE_TIXINIT void Tix_Init(interp) Tcl interp CODE: Tix_Init(interp); #endif #ifdef HAVE_BLTINIT void Blt_Init(interp) Tcl interp CODE: Blt_Init(interp); void Blt_StaticPackage(interp) Tcl interp PPCODE: Tcl_StaticPackage(interp, "BLT", Blt_Init, Blt_SafeInit); #endif #ifdef HAVE_MEMCHANINIT void Memchan_Init(interp) Tcl interp CODE: Memchan_Init(interp); #endif #ifdef HAVE_TRFINIT void Trf_Init(interp) Tcl interp CODE: Trf_Init(interp); #endif #ifdef HAVE_VFSINIT void Vfs_Init(interp) Tcl interp CODE: Vfs_Init(interp); #endif int Tcl_DoOneEvent(interp, flags) Tcl interp int flags CODE: RETVAL = initialized ? Tcl_DoOneEvent(flags) : 0; OUTPUT: RETVAL void Tcl_CreateCommand(interp,cmdName,cmdProc,clientData=&PL_sv_undef,deleteProc=&PL_sv_undef,flags=0) Tcl interp char * cmdName SV * cmdProc SV * clientData SV * deleteProc int flags CODE: if (!initialized) { return; } if (SvIOK(cmdProc)) Tcl_CreateCommand(interp, cmdName, (Tcl_CmdProc *) SvIV(cmdProc), INT2PTR(ClientData, SvIV(clientData)), NULL); else { AV *av = (AV *) SvREFCNT_inc((SV *) newAV()); av_store(av, 0, newSVsv(cmdProc)); av_store(av, 1, newSVsv(clientData)); av_store(av, 2, newSVsv(ST(0))); av_store(av, 3, newSViv(flags)); if (SvOK(deleteProc)) { av_store(av, 4, newSVsv(deleteProc)); } Tcl_CreateObjCommand(interp, cmdName, Tcl_PerlCallWrapper, (ClientData) av, Tcl_PerlCallDeleteProc); } ST(0) = &PL_sv_yes; XSRETURN(1); void Tcl_SetResult(interp, sv) Tcl interp SV * sv CODE: if (!initialized) { return; } { Tcl_Obj *objPtr = TclObjFromSv(aTHX_ sv); /* Tcl_SetObjResult will incr refcount */ Tcl_SetObjResult(interp, objPtr); ST(0) = ST(1); XSRETURN(1); } void Tcl_AppendElement(interp, str) Tcl interp char * str void Tcl_ResetResult(interp) Tcl interp SV * Tcl_AppendResult(interp, ...) Tcl interp int i = NO_INIT CODE: if (initialized) { Tcl_Obj *objPtr = Tcl_GetObjResult(interp); for (i = 1; i < items; i++) { Tcl_AppendObjToObj(objPtr, TclObjFromSv(aTHX_ ST(i))); } RETVAL = SvFromTclObj(aTHX_ objPtr); } else { RETVAL = &PL_sv_undef; } OUTPUT: RETVAL SV * Tcl_DeleteCommand(interp, cmdName) Tcl interp char * cmdName CODE: RETVAL = boolSV(Tcl_DeleteCommand(interp, cmdName) == TCL_OK); OUTPUT: RETVAL void Tcl_SplitList(interp, str) Tcl interp char * str int argc = NO_INIT char ** argv = NO_INIT char ** tofree = NO_INIT PPCODE: if (Tcl_SplitList(interp, str, &argc, &argv) == TCL_OK) { tofree = argv; EXTEND(sp, argc); while (argc--) PUSHs(sv_2mortal(newSVpv(*argv++, 0))); ckfree((char *) tofree); } SV * Tcl_SetVar(interp, varname, value, flags = 0) Tcl interp char * varname SV * value int flags CODE: RETVAL = SvFromTclObj(aTHX_ Tcl_SetVar2Ex(interp, varname, NULL, TclObjFromSv(aTHX_ value), flags)); OUTPUT: RETVAL SV * Tcl_SetVar2(interp, varname1, varname2, value, flags = 0) Tcl interp char * varname1 char * varname2 SV * value int flags CODE: RETVAL = SvFromTclObj(aTHX_ Tcl_SetVar2Ex(interp, varname1, varname2, TclObjFromSv(aTHX_ value), flags)); OUTPUT: RETVAL SV * Tcl_GetVar(interp, varname, flags = 0) Tcl interp char * varname int flags CODE: RETVAL = SvFromTclObj(aTHX_ Tcl_GetVar2Ex(interp, varname, NULL, flags)); OUTPUT: RETVAL SV * Tcl_GetVar2(interp, varname1, varname2, flags = 0) Tcl interp char * varname1 char * varname2 int flags CODE: RETVAL = SvFromTclObj(aTHX_ Tcl_GetVar2Ex(interp, varname1, varname2, flags)); OUTPUT: RETVAL SV * Tcl_UnsetVar(interp, varname, flags = 0) Tcl interp char * varname int flags CODE: RETVAL = boolSV(Tcl_UnsetVar2(interp, varname, NULL, flags) == TCL_OK); OUTPUT: RETVAL SV * Tcl_UnsetVar2(interp, varname1, varname2, flags = 0) Tcl interp char * varname1 char * varname2 int flags CODE: RETVAL = boolSV(Tcl_UnsetVar2(interp, varname1, varname2, flags) == TCL_OK); OUTPUT: RETVAL MODULE = Tcl PACKAGE = Tcl::List SV* as_string(SV* sv,...) PREINIT: Tcl_Obj* objPtr; int len; char *str; CODE: objPtr = TclObjFromSv(aTHX_ sv); Tcl_IncrRefCount(objPtr); str = Tcl_GetStringFromObj(objPtr, &len); RETVAL = newSVpvn(str, len); /* should turn on, but let's check this first for efficiency */ if (len && has_highbit(str, len)) { SvUTF8_on(RETVAL); } Tcl_DecrRefCount(objPtr); OUTPUT: RETVAL MODULE = Tcl PACKAGE = Tcl::Var SV * FETCH(av, key = NULL) Tcl::Var av char * key SV * sv = NO_INIT Tcl interp = NO_INIT char * varname1 = NO_INIT int flags = 0; CODE: /* * This handles both hash and scalar fetches. The blessed object * passed in is [$interp, $varname, $flags] ($flags optional). */ if (!initialized) { return; } if (AvFILL(av) != 1 && AvFILL(av) != 2) { croak("bad object passed to Tcl::Var::FETCH"); } sv = *av_fetch(av, 0, FALSE); if (sv_derived_from(sv, "Tcl")) { IV tmp = SvIV((SV *) SvRV(sv)); interp = INT2PTR(Tcl, tmp); } else { croak("bad object passed to Tcl::Var::FETCH"); } if (AvFILL(av) == 2) { flags = (int) SvIV(*av_fetch(av, 2, FALSE)); } varname1 = SvPV_nolen(*av_fetch(av, 1, FALSE)); RETVAL = SvFromTclObj(aTHX_ Tcl_GetVar2Ex(interp, varname1, key, flags)); OUTPUT: RETVAL void STORE(av, sv1, sv2 = NULL) Tcl::Var av SV * sv1 SV * sv2 SV * sv = NO_INIT Tcl interp = NO_INIT char * varname1 = NO_INIT Tcl_Obj * objPtr = NO_INIT int flags = 0; CODE: /* * This handles both hash and scalar stores. The blessed object * passed in is [$interp, $varname, $flags] ($flags optional). */ if (!initialized) { return; } if (AvFILL(av) != 1 && AvFILL(av) != 2) croak("bad object passed to Tcl::Var::STORE"); sv = *av_fetch(av, 0, FALSE); if (sv_derived_from(sv, "Tcl")) { IV tmp = SvIV((SV *) SvRV(sv)); interp = INT2PTR(Tcl, tmp); } else croak("bad object passed to Tcl::Var::STORE"); if (AvFILL(av) == 2) { flags = (int) SvIV(*av_fetch(av, 2, FALSE)); } varname1 = SvPV_nolen(*av_fetch(av, 1, FALSE)); /* * HASH: sv1 == key, sv2 == value * SCALAR: sv1 == value, sv2 NULL * Tcl_SetVar2Ex will incr refcount */ if (sv2) { objPtr = TclObjFromSv(aTHX_ sv2); Tcl_SetVar2Ex(interp, varname1, SvPV_nolen(sv1), objPtr, flags); } else { objPtr = TclObjFromSv(aTHX_ sv1); Tcl_SetVar2Ex(interp, varname1, NULL, objPtr, flags); } MODULE = Tcl PACKAGE = Tcl BOOT: { SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */ #ifdef USE_TCL_STUBS if (NpInitialize(aTHX_ x) == TCL_ERROR) { croak("Unable to initialize Tcl"); } #else /* Ideally this would be passed the dll instance location. */ Tcl_FindExecutable(x && SvPOK(x) ? SvPV_nolen(x) : NULL); #if defined(HAVE_TKINIT) && defined(WIN32) /* HAVE_TKINIT means we're linking Tk statically with tcl.dll * so we need to perform same initialization as in * tk/win/tkWin32Dll.c * (unless all this goes statically into perl.dll; in this case * handle to perl.dll should be substituted TODO) * -- VKON */ TkWinSetHINSTANCE(_hinst); #endif #endif initialized = 1; hvInterps = newHV(); } tclBooleanTypePtr = Tcl_GetObjType("boolean"); tclByteArrayTypePtr = Tcl_GetObjType("bytearray"); tclDoubleTypePtr = Tcl_GetObjType("double"); tclIntTypePtr = Tcl_GetObjType("int"); tclListTypePtr = Tcl_GetObjType("list"); tclStringTypePtr = Tcl_GetObjType("string"); tclWideIntTypePtr = Tcl_GetObjType("wideInt"); /* set up constant subs */ { HV *stash = gv_stashpvn("Tcl", 3, TRUE); newCONSTSUB(stash, "OK", newSViv(TCL_OK)); newCONSTSUB(stash, "ERROR", newSViv(TCL_ERROR)); newCONSTSUB(stash, "RETURN", newSViv(TCL_RETURN)); newCONSTSUB(stash, "BREAK", newSViv(TCL_BREAK)); newCONSTSUB(stash, "CONTINUE", newSViv(TCL_CONTINUE)); newCONSTSUB(stash, "GLOBAL_ONLY", newSViv(TCL_GLOBAL_ONLY)); newCONSTSUB(stash, "NAMESPACE_ONLY", newSViv(TCL_NAMESPACE_ONLY)); newCONSTSUB(stash, "APPEND_VALUE", newSViv(TCL_APPEND_VALUE)); newCONSTSUB(stash, "LIST_ELEMENT", newSViv(TCL_LIST_ELEMENT)); newCONSTSUB(stash, "TRACE_READS", newSViv(TCL_TRACE_READS)); newCONSTSUB(stash, "TRACE_WRITES", newSViv(TCL_TRACE_WRITES)); newCONSTSUB(stash, "TRACE_UNSETS", newSViv(TCL_TRACE_UNSETS)); newCONSTSUB(stash, "TRACE_DESTROYED", newSViv(TCL_TRACE_DESTROYED)); newCONSTSUB(stash, "INTERP_DESTROYED", newSViv(TCL_INTERP_DESTROYED)); newCONSTSUB(stash, "LEAVE_ERR_MSG", newSViv(TCL_LEAVE_ERR_MSG)); newCONSTSUB(stash, "TRACE_ARRAY", newSViv(TCL_TRACE_ARRAY)); newCONSTSUB(stash, "LINK_INT", newSViv(TCL_LINK_INT)); newCONSTSUB(stash, "LINK_DOUBLE", newSViv(TCL_LINK_DOUBLE)); newCONSTSUB(stash, "LINK_BOOLEAN", newSViv(TCL_LINK_BOOLEAN)); newCONSTSUB(stash, "LINK_STRING", newSViv(TCL_LINK_STRING)); newCONSTSUB(stash, "LINK_READ_ONLY", newSViv(TCL_LINK_READ_ONLY)); newCONSTSUB(stash, "WINDOW_EVENTS", newSViv(TCL_WINDOW_EVENTS)); newCONSTSUB(stash, "FILE_EVENTS", newSViv(TCL_FILE_EVENTS)); newCONSTSUB(stash, "TIMER_EVENTS", newSViv(TCL_TIMER_EVENTS)); newCONSTSUB(stash, "IDLE_EVENTS", newSViv(TCL_IDLE_EVENTS)); newCONSTSUB(stash, "ALL_EVENTS", newSViv(TCL_ALL_EVENTS)); newCONSTSUB(stash, "DONT_WAIT", newSViv(TCL_DONT_WAIT)); newCONSTSUB(stash, "EVAL_GLOBAL", newSViv(TCL_EVAL_GLOBAL)); newCONSTSUB(stash, "EVAL_DIRECT", newSViv(TCL_EVAL_DIRECT)); } libtcl-perl-1.02+ds.orig/README0000644000175000017500000000376411525175263015401 0ustar gregoagregoaNAME Tcl extension module for Perl5 DESCRIPTION The Tcl extension provides a small but complete interface into libtcl and any other Tcl-based library. It lets you create Tcl interpreters (as perl5 objects), bind in commands to them (either perl subroutines or C functions dynamically loaded with the DynaLoader extension) and execute Tcl code in those interpreters. There is a Tcl::Tk extension (not to be confused with "native" perl5 Perl/Tk extension) distributed separately which provides a raw but complete interface to the whole of libtk via this Tcl extension. Build in the usual way for a perl extension: 1. Tweak Makefile.PL is necessary only if your Tcl include files could not be found automatically by Makefile.PL script. Normally you just make sure you have right tcl in your path at a moment of running Makefile.PL script. 2. perl Makefile.PL make 3. Before installing, you can run the small test suite with make test if you wish. 4. make install In rare case when you do cross-compiling for WinCE, you need to edit Makefile.PL to reflect your paths, and then invoke as perl -MCross=[your-cross-name] Makefile.PL AUTHOR Malcolm Beattie mbeattie@sable.ox.ac.uk MAINTAINERS Vadim Konovalov vkonovalov@peterstar.ru Jeff Hobbs Gisle Aas LICENSE This program is free software; you can redistribute it and/or modify it under the terms of either: a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" which comes with every Perl distribution. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the Artistic License for more details. Copyright (c) 1994-1997, Malcolm Beattie All rights reserved. libtcl-perl-1.02+ds.orig/tclcfg.tcl0000644000175000017500000000066711525175263016466 0ustar gregoagregoaputs "tclsh=[info nameofexecutable]" set libdir [info library] set dirs [list \ [file dirname $libdir] \ [file dirname [file dirname $libdir]] \ [file join [file dirname [file dirname [info nameofexe]]] lib] \ ] foreach dir $dirs { if {[file exists [file join $dir tclConfig.sh]]} { puts "tclConfig.sh=[file join $dir tclConfig.sh]" break } } puts "tcl_library=$libdir" puts "tcl_version=$tcl_version" libtcl-perl-1.02+ds.orig/t/0000755000175000017500000000000011525175306014750 5ustar gregoagregoalibtcl-perl-1.02+ds.orig/t/trace.t0000644000175000017500000000064111525175263016236 0ustar gregoagregoause Tcl; $| = 1; print "1..2\n"; $i = new Tcl; tie $perlscalar, Tcl::Var, $i, "tclscalar"; tie %perlhash, Tcl::Var, $i, "tclhash"; $i->Eval('set tclscalar ok; set tclhash(key) 1'); printf "%s %s\n", $perlscalar, $perlhash{"key"}; $perlscalar = "newvalue"; $perlhash{"newkey"} = 2; $i->Eval(<<'EOT'); if {($tclscalar == "newvalue") && ($tclhash(newkey) == 2)} { puts "ok 2" } else { puts "not ok 2" } EOT libtcl-perl-1.02+ds.orig/t/subclass.t0000644000175000017500000000050411525175263016755 0ustar gregoagregoa#!perl -w use strict; use Test qw(plan ok); plan tests => 4; { package MyTcl; require Tcl; @MyTcl::ISA = qw(Tcl); sub eval { my $self = shift; $self->Eval(@_); } } my $tcl = MyTcl->new; ok(ref($tcl), "MyTcl"); ok($tcl->isa("Tcl")); ok($tcl->eval("set var 42"), 42); ok($tcl->eval("set var"), 42); libtcl-perl-1.02+ds.orig/t/result.t0000644000175000017500000000206511525175263016460 0ustar gregoagregoause Tcl; $| = 1; print "1..5\n"; sub foo { my $interp = $_[1]; $i->SetResult("ok 2"); return undef; } $i = new Tcl; $i->Eval('expr 10 + 30'); print $i->result == 40 ? "ok 1\n" : "not ok 1\n"; $i->CreateCommand("foo", \&foo); # previously it was assumed that perl when subroutine returns undef it is # treated as an exception. This is very uncomfortable from, say, handlers, # where undef could be returned if a user is not aware os return value. # As long as this was not documented, let's change this, so following test # should always return "ok 2" $i->Eval('if {[catch foo res]} {puts $res} else {puts "ok 2"}'); $i->ResetResult(); @qlist = qw(a{b g\h j{{k} l}m{ \}n); foreach (@qlist) { $i->AppendElement($_); } if ($i->result eq 'a\{b {g\h} j\{\{k\} l\}m\{ {\}n}') { print "ok 3\n"; } else { print "not ok 3\n"; } @qlistout = $i->SplitList($i->result); if ("@qlistout" eq "@qlist") { print "ok 4\n"; } else { print "not ok 4\n"; } if ($i->SplitList('bad { format')) { print "not ok 5\n"; } else { print "ok 5\n"; } libtcl-perl-1.02+ds.orig/t/call.t0000644000175000017500000000243311525175263016054 0ustar gregoagregoa# call.t # # Tests for the 'call' and 'icall' functions. # use Tcl; $| = 1; print "1..15\n"; my $i = Tcl->new; my (@res, $res, $a, $b); $res = $i->call('set', 'var', "ok 1"); print "$res\n"; $res = $i->icall('set', 'var', "ok 2"); print "$res\n"; @res = $i->call('set', 'var', ['ok', '3']); print STDOUT join(' ', @res), "\n"; @res = $i->icall('set', 'var', ['ok', '4']); print STDOUT join(' ', @res), "\n"; ($a, $b) = $i->call('list', '5', 'ok'); print "$b $a\n"; ($a, $b) = $i->icall('list', '6', 'ok'); print "$b $a\n"; $i->call("puts", "ok 7"); $i->icall("puts", "ok 8"); $a = $i->call("list", 1, $i->call("list", 2, 3), 4); print "not " unless @$a == 4 && $a->[1] == 2 && $a eq "1 2 3 4"; print "ok 9\n"; $a = $i->call("list", 1, scalar($i->call("list", 2, 3)), 4); print "not " unless @$a == 3 && $a->[1][0] == 2 && $a eq "1 {2 3} 4"; print "ok 10\n"; my $v = 1; $i->call("after", 250, sub { print "ok 11\n"; $v++; }); $i->call("vwait", \$v); print "not " unless $v == 2; print "ok 12\n"; $i->call("eval", <<'EOT'); proc f1 {h v} { upvar $h arr puts "ok $arr(ok)" set arr(foo) 14 incr $v } EOT my %h = (foo => 1, bar => 2, ok => 13); $i->call("after", 250, "f1", \%h, \$v); $i->call("vwait", \$v); print "ok $h{foo}\n"; print "not " unless $v == 3; print "ok 15\n"; libtcl-perl-1.02+ds.orig/t/unicode.t0000644000175000017500000000535111525175263016571 0ustar gregoagregoa#!perl -w # Test the transfer of null and various unicode data through assorted APIs. # The \x{2030} is the permille sign. # # On Unix this progam shows different wrong behaviour depending # on what kind of locale it runs under. use strict; use Test qw(plan ok); plan tests => 6; use Tcl; my $int = new Tcl; my $str = "This is a string\n"; $str .= "This is a string containing NUL (\0) and some other controls (\a\r)\n"; $str .= "\0 \x{2030}\n"; $str .= "[\0 \x{2030}]\n"; $str .= "bytes: " . join("", map chr, 0 .. 255) . "\n"; $str .= "uni: " . join("", map chr, 0 .. 300) . "\n"; my $output = <<"EOT"; This is a string This is a string containing NUL (\0) and some other controls (\a\r) \0 \x{2030} [\0 \x{2030}] bytes: \0\1\2\3\4\5\6\a\b\t \13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\x7F\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF uni: \0\1\2\3\4\5\6\a\b\t \13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\x7F\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF\x{100}\x{101}\x{102}\x{103}\x{104}\x{105}\x{106}\x{107}\x{108}\x{109}\x{10A}\x{10B}\x{10C}\x{10D}\x{10E}\x{10F}\x{110}\x{111}\x{112}\x{113}\x{114}\x{115}\x{116}\x{117}\x{118}\x{119}\x{11A}\x{11B}\x{11C}\x{11D}\x{11E}\x{11F}\x{120}\x{121}\x{122}\x{123}\x{124}\x{125}\x{126}\x{127}\x{128}\x{129}\x{12A}\x{12B}\x{12C} EOT my $res = $int->SetVar("unitest", $str); ok($res, $output); $res = $int->Eval("append unitest \"\\0\\1\\2\\n\""); $output .= "\0\1\2\n"; ok($int->result, $output); ok($res, $output); ok($int->GetVar("unitest"), $output); $res = $int->AppendResult("", "\0", "\x{2030}"); $output .= "\0\x{2030}"; ok($res, $output); ok($int->result, $output); libtcl-perl-1.02+ds.orig/t/eval.t0000644000175000017500000000042411525175263016066 0ustar gregoagregoause Tcl; $| = 1; print "1..5\n"; $i = new Tcl; $i->Eval(q(puts "ok 1")); ($a, $b) = $i->Eval(q(list 2 ok)); print "$b $a\n"; eval { $i->Eval(q(error "ok 3\n")) }; print $@; $i->call("puts", "ok 4"); $i->EvalFileHandle(\*DATA); __END__ set foo ok set bar 5 puts "$foo $bar" libtcl-perl-1.02+ds.orig/t/createcmd.t0000644000175000017500000000120311525175263017062 0ustar gregoagregoause Tcl; $| = 1; # 5.8.0 has an order destroy issue that prevents proper Tcl finalization my $tests = $] == 5.008 ? 3 : 4; print "1..$tests\n"; sub foo { my($clientdata, $interp, @args) = @_; print "$clientdata->{OK} $args[1]\n"; } sub foogone { my($clientdata) = @_; print "$clientdata->{OK} 3\n"; } sub bar { "ok 2" } sub bargone { print "ok $_[0]\n"; } $i = new Tcl; $i->CreateCommand("foo", \&foo, {OK => "ok"}, \&foogone); $i->CreateCommand("bar", \&bar, 4, \&bargone); $i->Eval("foo 1"); $i->Eval("puts [bar]"); $i->DeleteCommand("foo"); # final destructor of $i triggers destructor for Tcl proc bar (!5.8.0) libtcl-perl-1.02+ds.orig/t/var.t0000644000175000017500000000243311525175263015731 0ustar gregoagregoause Tcl; $| = 1; print "1..8\n"; sub foo { my $interp = $_[1]; my $glob = $interp->GetVar("bar", Tcl::GLOBAL_ONLY); my $loc = $interp->GetVar("bar"); print "$glob $loc\n"; $interp->Eval('puts $four', Tcl::EVAL_GLOBAL); } $i = new Tcl; $i->SetVar("foo", "ok 1"); $i->Eval('puts $foo'); $i->Eval('set foo "ok 2\n"'); print $i->GetVar("foo"); $i->CreateCommand("foo", \&foo); $i->Eval(<<'EOT'); set bar ok set four "ok 4" proc baz {} { set bar 3 set four "not ok 4" foo } baz EOT $i->Eval('set a(OK) ok; set a(five) 5'); $ok = $i->GetVar2("a", "OK"); $five = $i->GetVar2("a", "five"); print "$ok $five\n"; print defined($i->GetVar("nonesuch")) ? "not ok 6\n" : "ok 6\n"; # some Unicode tests if ($]>=5.006 && $i->GetVar("tcl_version")>=8.1) { $i->SetVar("univar","\x{abcd}\x{1234}"); if ($i->GetVar("univar") ne "\x{abcd}\x{1234}") { print "not "; } print "ok 7 # Unicode persistence during [SG]etVar\n"; my $r; tie $r, Tcl::Var, $i, "perl_r"; $r = "\x{abcd}\x{1234}"; if ($r ne "\x{abcd}\x{1234}") { print "not "; } print "ok 8 # Unicode persistence for tied variable\n"; binmode(STDOUT, ":utf8") if $] >= 5.008; print "# $r\n"; } else { for (7..8) {print "ok $_ # skipped: not Unicode-aware Perl or Tcl\n";} } libtcl-perl-1.02+ds.orig/t/constants.t0000644000175000017500000000103011525175263017145 0ustar gregoagregoa#!perl -w use strict; use Test qw(plan ok); plan tests => 3; use Tcl; # These tests are bit lame, as they depend on the actual values, # but at least it verifies that the constants are set up. ok(Tcl::OK, 0); ok(Tcl::ERROR, 1); ok(Tcl::GLOBAL_ONLY | Tcl::NAMESPACE_ONLY | Tcl::APPEND_VALUE | Tcl::LIST_ELEMENT | Tcl::TRACE_READS | Tcl::TRACE_WRITES | Tcl::TRACE_UNSETS | Tcl::TRACE_DESTROYED | Tcl::INTERP_DESTROYED | Tcl::LEAVE_ERR_MSG | Tcl::TRACE_ARRAY, 0xBFF); libtcl-perl-1.02+ds.orig/t/export_to_tcl.t0000644000175000017500000000131511525175263020024 0ustar gregoagregoa# tests convenience sub export_to_tcl use Test; BEGIN {plan tests=>4} use Tcl; my $int = new Tcl; $tcl::foo = $tcl::foo = 'qwerty'; my $x = "some perl scalar var"; $int->export_to_tcl(subs_from=>'tcl',vars_from=>'tcl'); $int->export_to_tcl(subs=>{lala=>sub{"ok"}}, namespace=>''); $int->export_to_tcl(vars=>{foo1=>\$x}, namespace=>''); # this should croak: #$int->export_to_tcl(vars=>{foo=>$x}, namespace=>''); $int->export_to_tcl(subs_from=>''); # this will bind sub named sub1 below sub sub1 {"sub1 its me"} sub tcl::sub2 {"sub2 its me"} ok($int->call('perl::sub1'),"sub1 its me"); ok($int->call('lala'),"ok"); ok($int->Eval('set perl::foo'),'qwerty'); ok($int->call('set','foo1'),'some perl scalar var'); libtcl-perl-1.02+ds.orig/t/info.t0000644000175000017500000000121211525175263016066 0ustar gregoagregoa#!perl -w use strict; use Test qw(plan ok); plan tests => 6; use Tcl; use File::Spec::Functions; my $tcl = Tcl->new; ok($tcl); if ($^O eq 'cygwin') { my $cpath = $tcl->Eval("info nameofexecutable"); $cpath = `cygpath -u '$cpath'`; chomp($cpath); ok($cpath, canonpath($^X)); } else { ok(canonpath($tcl->Eval("info nameofexecutable")), canonpath($^X)); } ok($tcl->Eval("info exists tcl_platform"), 1); my $tclversion = $tcl->Eval("info tclversion"); ok($tclversion =~ /^8\.\d+$/); ok(substr($tcl->Eval("info patchlevel"), 0, length($tclversion)), $tclversion); ok(length($tcl->Eval("info patchlevel")) > length($tclversion)); libtcl-perl-1.02+ds.orig/Makefile.PL0000644000175000017500000002323311525175263016464 0ustar gregoagregoa#!perl -w # before running this script make sure you have 'tclsh' in your path, # and this 'tcl' distribution is required one. # FreeBSD users may want to modify name of tcl interpreter (this is # $tclsh variable below) as long as 'tclsh' does not work in their case use strict; use Getopt::Long qw(GetOptions); use ExtUtils::MakeMaker; use Config; my $tclsh = 'tclsh'; my $tclconfig; my $buildspec; my $usestubs = ($^O eq 'MSWin32' ? 0 : 1); my $libpath; my $incpath; my $defs = ""; my $buildtype = ""; my $wince; my @extraargs; my $arch; my $stub = "tclstub8.4"; # These need updating as more platforms are added to tcl-core/ area if ($^O eq "aix") { $arch = "aix"; } elsif ($^O eq "MSWin32") { $stub = "tclstub84"; $arch = "win32-x86" if ($Config{archname} =~ /-x86-/); $arch = "win32-x64" if ($Config{archname} =~ /-x64-/); } elsif ($^O eq "darwin") { $arch = "darwin-universal"; } elsif ($^O eq "solaris") { $arch = "$^O-x86" if ($Config{archname} =~ /86/); $arch = "$^O-sparc" if ($Config{archname} =~ /sun4/); } elsif ($^O eq "aix") { $arch = "$^O"; } elsif ($^O eq "hpux") { $arch = "$^O-ia64" if ($Config{archname} =~ /ia64/i); $arch = "$^O-parisc" if ($Config{archname} =~ /pa-risc/i); } elsif ($^O eq "linux") { $arch = "$^O-i686" if ($Config{archname} =~ /i\d86/); $arch = "$^O-ia64" if ($Config{archname} =~ /ia64/i); $arch = "$^O-x86_64" if ($Config{archname} =~ /x86_64/); } elsif ($^O eq "cygwin") { $tclconfig = '/usr/lib/tclConfig.sh'; } elsif ($^O eq "solaris") { $arch = "$^O-x86" if ($Config{archname} =~ /[ix]86/); $arch = "$^O-sparc" if ($Config{archname} =~ /sun4/); } sub _die ($) { # now CPAN smokers report FAIL if Makefile.PL dies, it # should exit with status 0 my $err = shift; warn $err; exit 0; } GetOptions("tclsh=s", \$tclsh, # Use this tclsh executable as a # base to find the lib info needed "tclconfig=s", \$tclconfig, # Use the specified Tcl config file # instead of basing the values on # the tclsh exe found "buildspec", \$buildspec, # Used with --tclconfig, use the # build (instead of install) values # for determining lib info "usestubs!", \$usestubs, # we want to use the Tcl stubs # mechanism by default "library=s", \$libpath, # Use this specific Tcl library "include=s", \$incpath, # Use this specific include path "define=s", \$defs, # Use this specific set of defines ) || _die <] [--tclconfig ] [--buildspec] [--nousestubs] [...] or for WinCE cross-compilation: perl -MCross=[your-cross-name] Makefile.PL PERL_CORE=1 PERL_SRC=[your-perl-distribution-for-wince-crosscompiling] or for expert compilation: perl --library=-l/path/to/tcl(stub).a --include=-I/path/to/tcl/include --define="-DLIB_RUNTIME_DIR=... -DTCL_LIB_FILE=..." EOT if (defined $Cross::platform) { # All appropriate environment variables shoult be set properly, such # as OSVERSION, PLATFORM, WCEROOT, SDKROOT. This is usually done with # appropriate 'bat' file. such as WCEMIPS.BAT # # # edit following two paths to reflect your situation # when editing please note that there should be tcl84.lib # libraries at "$tcldir\\wince\\$Cross::platform-release" # my $tcldir = 'D:\personal\pocketPC\tcltk\84a2\tcl8.4a2'; WriteMakefile( NAME => "Tcl", VERSION_FROM => 'Tcl.pm', LIBS => ["-l$tcldir\\wince\\$Cross::platform-release\\tcl84.lib"], INC => "-I$tcldir\\generic", ); exit; } if ($usestubs) { $defs .= " -DUSE_TCL_STUBS"; $buildtype = "stub"; } # If using stubs, we will set the LIB_RUNTIME_DIR and TCL_LIB_FILE # to point to the install location as the default dll to load. if (defined($libpath) && defined($incpath)) { # do nothing - set on command line } elsif (!defined($tclconfig) && defined($arch) && $usestubs) { $incpath = "-Itcl-core/include"; $libpath = "-Ltcl-core/$arch -l$stub"; if ($^O eq 'darwin') { # OS X also requires the Carbon framework by default $libpath .= " -framework Carbon"; } } elsif ($tclconfig || $^O eq 'darwin') { unless ($tclconfig) { open(TCLSH, "$tclsh tclcfg.tcl |") or _die "error starting tclsh: $!\n"; my $tclcfg = join '', ; close(TCLSH); my %tclcfg = $tclcfg =~ /^([^=]+)=(.*?)\n/gm; $tclconfig = $tclcfg{'tclConfig.sh'}; } _die "Tcl config file '$tclconfig' not found\n" unless (-f $tclconfig); # Retrieve all info based on tclConfig.sh my $variant = ($usestubs ? "_STUB" : ""); $variant = "_BUILD$variant" if $buildspec; my $libspecvar = "TCL${variant}_LIB_SPEC"; my %tclcfg; process_tclconfig($tclconfig, \%tclcfg); _die "Tcl requires Tcl v8.4 or greater, found '$tclcfg{TCL_VERSION}'\n" unless (defined $tclcfg{'TCL_VERSION'} && $tclcfg{'TCL_VERSION'} >= 8.4); $libpath = $tclcfg{$libspecvar}; $incpath = $tclcfg{'TCL_INCLUDE_SPEC'}; if ($usestubs) { if ($^O eq 'MSWin32') { $defs .= " -DLIB_RUNTIME_DIR=\\\"$tclcfg{'TCL_EXEC_PREFIX'}/bin\\\""; $defs .= " -DTCL_LIB_FILE=\\\"$tclcfg{'TCL_DLL_FILE'}\\\""; } elsif ($^O eq 'darwin' && $tclcfg{'TCL_STUB_LIB_PATH'} =~ /\.framework/ ) { (my $fmk = $tclcfg{'TCL_STUB_LIB_PATH'}) =~ s/(?<=\.framework).*//; $defs .= " -DLIB_RUNTIME_DIR=\\\"$fmk\\\""; $defs .= " -DTCL_LIB_FILE=\\\"$tclcfg{'TCL_LIB_FILE'}\\\""; @extraargs = (dynamic_lib => {OTHERLDFLAGS => "-framework Carbon"}); } else { $defs .= " -DLIB_RUNTIME_DIR=\\\"$tclcfg{'TCL_EXEC_PREFIX'}/lib\\\""; $defs .= " -DTCL_LIB_FILE=\\\"$tclcfg{'TCL_LIB_FILE'}\\\""; } } } else { open(TCLSH, "$tclsh tclcfg.tcl |") or _die "error starting tclsh: $!\n"; my $tclcfg = join '', ; close(TCLSH); print $tclcfg; my %tclcfg = $tclcfg =~ /^([^=]+)=(.*?)\n/gm; # This is to allow propagation of this value to sub-Makefile.PLs $ENV{'TCLSH_PROG'} = $tclsh; if (0 && -f $tclcfg{'tclConfig.sh'}) { # Retrieve all info based on tclConfig.sh # Don't do this unless the user passes --tclconfig process_tclconfig($tclcfg{'tclConfig.sh'}, \%tclcfg); # libpath/incpath vars need to be set here if used ... } else { my $tclver = $tclcfg{tcl_version}; # currently version must be 8.4+ my ($vmaj,$vmin) = ($tclver =~ /^(\d+)\.(\d+)/); _die "Tcl requires Tcl v8.4 or greater, found '$vmaj.$vmin'\n" if ($vmaj < 8 || ($vmaj == 8 && $vmin < 4)); if ($tclcfg{tcl_library} =~ /^(.*)[\\\/]lib[\\\/]/) { $libpath = "-L$1/lib"; $incpath = "-I$1/include"; $defs .= " -DLIB_RUNTIME_DIR=\\\"$1/lib\\\"" if $usestubs; } if ($^O eq 'MSWin32') { $tclver=~s/\.//; $defs .= " -DTCL_LIB_FILE=\\\"tcl$tclver.dll\\\"" if $usestubs; } elsif ($^O eq 'freebsd') { $tclver=~s/\.//; $tclsh=~/([\d.]+)$/ and $incpath .= " -I/usr/local/include/tcl$1"; $defs .= " -DTCL_LIB_FILE=\\\"libtcl$tclver.so\\\"" if $usestubs; } elsif ($^O eq 'hpux') { #$tclver = ''; $defs .= " -DTCL_LIB_FILE=\\\"libtcl$tclver.sl\\\"" if $usestubs; } else { #$tclver = ''; $defs .= " -DTCL_LIB_FILE=\\\"libtcl$tclver.so\\\"" if $usestubs; } $libpath .= " -ltcl$buildtype$tclver"; } } print "LIBS = $libpath\n"; print "INC = $incpath\n"; print "DEFINE = $defs\n"; if ($^O eq 'darwin') { # darwin has a broken ranlib that requires you to run it anytime # you copy an archive file, so ensure ours it up-to-date system("ranlib tcl-core/$arch/libtclstub8.4.a"); system("git update-index --assume-unchanged tcl-core/$arch/libtclstub8.4.a") if -d ".git"; if ($libpath =~ /-framework/) { # Frameworks require slightly different compile options @extraargs = (dynamic_lib => {OTHERLDFLAGS => $libpath}); $libpath = ""; } } #print <<"#EOS"; WriteMakefile( NAME => "Tcl", VERSION_FROM => 'Tcl.pm', LICENSE => 'perl', MIN_PERL_VERSION => '5.006', ABSTRACT_FROM => 'Tcl.pm', META_MERGE => { resources => { repository => 'http://github.com/gisle/tcl.pm', MailingList => 'mailto:tcltk@perl.org', } }, LIBS => ["$libpath"], INC => "$incpath", DEFINE => $defs, @extraargs, ); #EOS sub process_tclconfig { # Process a tclConfig.sh file for build info my $tclconfig = shift; my $hashref = shift; open(TCLSH, $tclconfig) or _die "error opening file '$tclconfig': $!\n"; print "Using config data in $tclconfig\n"; my $tclcfg = join '', ; close(TCLSH); %$hashref = $tclcfg =~ /^(\w+)=['"]?(.*?)["']?\n/gm; for my $k (keys %$hashref) { # Handle sh subs like ${TCL_DBGX} $hashref->{$k} =~ s/\$\{(\w+)\}/(exists $hashref->{$1} ? $hashref->{$1} : $&)/eg; # Handle any cygdrive-style paths $hashref->{$k} =~ s,/cygdrive/(\w)/,$1:/,ig; } } sub MY::libscan { my($self, $path) =@_; return '' if $path =~ /\.pl$/i; return $path; } BEGIN { # compatibility with older versions of MakeMaker my $developer = -f ".git"; my %mm_req = ( LICENCE => 6.31, META_MERGE => 6.45, META_ADD => 6.45, MIN_PERL_VERSION => 6.48, ); undef(*WriteMakefile); *WriteMakefile = sub { my %arg = @_; for (keys %mm_req) { unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) { warn "$_ $@" if $developer; delete $arg{$_}; } } ExtUtils::MakeMaker::WriteMakefile(%arg); }; } libtcl-perl-1.02+ds.orig/META.yml0000644000175000017500000000112711525175306015757 0ustar gregoagregoa--- #YAML:1.0 name: Tcl version: 1.02 abstract: Tcl extension module for Perl author: [] license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: perl: 5.006 resources: MailingList: mailto:tcltk@perl.org repository: http://github.com/gisle/tcl.pm no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 libtcl-perl-1.02+ds.orig/Tcl.pm0000644000175000017500000006775211525175263015610 0ustar gregoagregoapackage Tcl; $Tcl::VERSION = '1.02'; $Tcl::STACK_TRACE = 1; =head1 NAME Tcl - Tcl extension module for Perl =head1 SYNOPSIS use Tcl; $interp = Tcl->new; $interp->Eval('puts "Hello world"'); =head1 DESCRIPTION The Tcl extension module gives access to the Tcl library with functionality and interface similar to the C functions of Tcl. In other words, you can =over =item * create Tcl interpreters The Tcl interpreters so created are Perl objects whose destructors delete the interpreters cleanly when appropriate. =item * execute Tcl code in an interpreter The code can come from strings, files or Perl filehandles. =item * bind in new Tcl procedures The new procedures can be either C code (with addresses presumably obtained using I and I) or Perl subroutines (by name, reference or as anonymous subs). The (optional) deleteProc callback in the latter case is another perl subroutine which is called when the command is explicitly deleted by name or else when the destructor for the interpreter object is explicitly or implicitly called. =item * Manipulate the result field of a Tcl interpreter =item * Set and get values of variables in a Tcl interpreter =item * Tie perl variables to variables in a Tcl interpreter The variables can be either scalars or hashes. =back =head2 Methods in class Tcl To create a new Tcl interpreter, use $interp = Tcl->new; The following methods and routines can then be used on the Perl object returned (the object argument omitted in each case). =over =item $interp->Init () Invoke I on the interpeter. =item $interp->Eval (STRING, FLAGS) Evaluate script STRING in the interpreter. If the script returns successfully (TCL_OK) then the Perl return value corresponds to Tcl interpreter's result otherwise a I exception is raised with the $@ variable corresponding to Tcl's interpreter result object. In each case, I means that if the method is called in scalar context then the string result is returned but if the method is called in list context then the result is split as a Tcl list and returned as a Perl list. The FLAGS field is optional and can be a bitwise OR of the constants Tcl::EVAL_GLOBAL or Tcl::EVAL_DIRECT. =item $interp->GlobalEval (STRING) REMOVED. Evalulate script STRING at global level. Call I(STRING, Tcl::EVAL_GLOBAL) instead. =item $interp->EvalFile (FILENAME) Evaluate the contents of the file with name FILENAME. Otherwise, the same as I() above. =item $interp->EvalFileHandle (FILEHANDLE) Evaluate the contents of the Perl filehandle FILEHANDLE. Otherwise, the same as I() above. Useful when using the filehandle DATA to tack on a Tcl script following an __END__ token. =item $interp->call (PROC, ARG, ...) Looks up procedure PROC in the interpreter and invokes it using Tcl's eval semantics that does command tracing and will use the ::unknown (AUTOLOAD) mechanism. The arguments (ARG, ...) are not passed through the Tcl parser. For example, spaces embedded in any ARG will not cause it to be split into two Tcl arguments before being passed to PROC. Before invoking procedure PROC special processing is performed on ARG list: 1. All subroutine references within ARG will be substituted with Tcl name which is responsible to invoke this subroutine. This Tcl name will be created using CreateCommand subroutine (see below). 2. All references to scalars will be substituted with names of Tcl variables transformed appropriately. These first two items allows to write and expect it to work properly such code as: my $r = 'aaaa'; button(".d", -textvariable => \$r, -command=>sub {$r++}); 3. All references to hashes will be substituted with names of Tcl array variables transformed appropriately. 4. As a special case, there is a mechanism to deal with Tk's special event variables (they are mentioned as '%x', '%y' and so on throughout Tcl). When creating a subroutine reference that uses such variables, you must declare the desired variables using Tcl::Ev as the first argument to the subroutine. Example: sub textPaste { my ($x,$y,$w) = @_; widget($w)->insert("\@$x,$y", $interp->Eval('selection get')); } $widget->bind('<2>', [\&textPaste, Tcl::Ev('%x', '%y'), $widget] ); =item $interp->return_ref (NAME) returns a reference corresponding to NAME, which was associated during previously called C<< $interpnt->call(...) >> preprocessing. As a typical example this could be variable associated with a widget. =item $interp->delete_ref (NAME) deletes and returns a reference corresponding to NAME, which was associated during previously called C<< $interpnt->call(...) >> preprocessing. =item $interp->icall (PROC, ARG, ...) Looks up procedure PROC in the interpreter and invokes it using Tcl's eval semantics that does command tracing and will use the ::unknown (AUTOLOAD) mechanism. The arguments (ARG, ...) are not passed through the Tcl parser. For example, spaces embedded in any ARG will not cause it to be split into two Tcl arguments before being passed to PROC. This is the lower-level procedure that the 'call' method uses. Arguments are converted efficiently from Perl SVs to Tcl_Objs. A Perl AV array becomes a Tcl_ListObj, an SvIV becomes a Tcl_IntObj, etc. The reverse conversion is done to the result. =item $interp->invoke (PROC, ARG, ...) Looks up procedure PROC in the interpreter and invokes it directly with arguments (ARG, ...) without passing through the Tcl parser. For example, spaces embedded in any ARG will not cause it to be split into two Tcl arguments before being passed to PROC. This differs from icall/call in that it directly invokes the command name without allowing for command tracing or making use of Tcl's unknown (AUTOLOAD) mechanism. If the command does not already exist in the interpreter, and error will be thrown. Arguments are converted efficiently from Perl SVs to Tcl_Objs. A Perl AV array becomes a Tcl_ListObj, an SvIV becomes a Tcl_IntObj, etc. The reverse conversion is done to the result. =item Tcl::Ev (FIELD, ...) Used to declare %-substitution variables of interest to a subroutine callback. FIELD is expected to be of the form "%#" where # is a single character, and multiple fields may be specified. Returns a blessed object that the 'call' method will recognize when it is passed as the first argument to a subroutine in a callback. See description of 'call' method for details. =item $interp->result () Returns the current Tcl interpreter result. List v. scalar context is handled as in I() above. =item $interp->CreateCommand (CMDNAME, CMDPROC, CLIENTDATA, DELETEPROC, FLAGS) Binds a new procedure named CMDNAME into the interpreter. The CLIENTDATA and DELETEPROC arguments are optional. There are two cases: (1) CMDPROC is the address of a C function (presumably obtained using I and I. In this case CLIENTDATA and DELETEPROC are taken to be raw data of the ClientData and deleteProc field presumably obtained in a similar way. (2) CMDPROC is a Perl subroutine (either a sub name, a sub reference or an anonymous sub). In this case CLIENTDATA can be any perl scalar (e.g. a ref to some other data) and DELETEPROC must be a perl sub too. When CMDNAME is invoked in the Tcl interpeter, the arguments passed to the Perl sub CMDPROC are (CLIENTDATA, INTERP, LIST) where INTERP is a Perl object for the Tcl interpreter which called out and LIST is a Perl list of the arguments CMDNAME was called with. If the 1-bit of FLAGS is set then the 3 first arguments on the call to CMDPROC are suppressed. As usual in Tcl, the first element of the list is CMDNAME itself. When CMDNAME is deleted from the interpreter (either explicitly with I or because the destructor for the interpeter object is called), it is passed the single argument CLIENTDATA. =item $interp->DeleteCommand (CMDNAME) Deletes command CMDNAME from the interpreter. If the command was created with a DELETEPROC (see I above), then it is invoked at this point. When a Tcl interpreter object is destroyed either explicitly or implicitly, an implicit I happens on all its currently registered commands. =item $interp->SetResult (STRING) Sets Tcl interpreter result to STRING. =item $interp->AppendResult (LIST) Appends each element of LIST to Tcl's interpreter result object. =item $interp->AppendElement (STRING) Appends STRING to Tcl interpreter result object as an extra Tcl list element. =item $interp->ResetResult () Resets Tcl interpreter result. =item $interp->SplitList (STRING) Splits STRING as a Tcl list. Returns a Perl list or the empty list if there was an error (i.e. STRING was not a properly formed Tcl list). In the latter case, the error message is left in Tcl's interpreter result object. =item $interp->SetVar (VARNAME, VALUE, FLAGS) The FLAGS field is optional. Sets Tcl variable VARNAME in the interpreter to VALUE. The FLAGS argument is the usual Tcl one and can be a bitwise OR of the constants Tcl::GLOBAL_ONLY, Tcl::LEAVE_ERR_MSG, Tcl::APPEND_VALUE, Tcl::LIST_ELEMENT. =item $interp->SetVar2 (VARNAME1, VARNAME2, VALUE, FLAGS) Sets the element VARNAME1(VARNAME2) of a Tcl array to VALUE. The optional argument FLAGS behaves as in I above. =item $interp->GetVar (VARNAME, FLAGS) Returns the value of Tcl variable VARNAME. The optional argument FLAGS behaves as in I above. =item $interp->GetVar2 (VARNAME1, VARNAME2, FLAGS) Returns the value of the element VARNAME1(VARNAME2) of a Tcl array. The optional argument FLAGS behaves as in I above. =item $interp->UnsetVar (VARNAME, FLAGS) Unsets Tcl variable VARNAME. The optional argument FLAGS behaves as in I above. =item $interp->UnsetVar2 (VARNAME1, VARNAME2, FLAGS) Unsets the element VARNAME1(VARNAME2) of a Tcl array. The optional argument FLAGS behaves as in I above. =back =head2 Linking Perl and Tcl variables You can I a Perl variable (scalar or hash) into class Tcl::Var so that changes to a Tcl variable automatically "change" the value of the Perl variable. In fact, as usual with Perl tied variables, its current value is just fetched from the Tcl variable when needed and setting the Perl variable triggers the setting of the Tcl variable. To tie a Perl scalar I<$scalar> to the Tcl variable I in interpreter I<$interp> with optional flags I<$flags> (see I above), use tie $scalar, "Tcl::Var", $interp, "tclscalar", $flags; Omit the I<$flags> argument if not wanted. To tie a Perl hash I<%hash> to the Tcl array variable I in interpreter I<$interp> with optional flags I<$flags> (see I above), use tie %hash, "Tcl::Var", $interp, "array", $flags; Omit the I<$flags> argument if not wanted. Any alteration to Perl variable I<$hash{"key"}> affects the Tcl variable I and I. =head2 Accessing Perl from within Tcl After creation of Tcl interpreter, in addition to evaluation of Tcl/Tk commands within Perl, other way round also instantiated. Within a special namespace C< ::perl > following objects are created: ::perl::Eval So it is possible to use Perl objects from within Tcl. =head2 Moving Tcl/Tk around with Tcl.pm NOTE: explanations below is for developers managing Tcl/Tk installations itself, users should skip this section. In order to create Tcl/Tk application with this module, you need to make sure that Tcl/Tk is available within visibility of this module. There are many ways to achieve this, varying on ease of starting things up and providing flexible moveable archived files. Following list enumerates them, in order of increased possibility to change location. =over =item * First method Install Tcl/Tk first, then install Perl module Tcl, so installed Tcl/Tk will be used. This is most normal approach, and no care of Tcl/Tk distribution is taken on Perl side (this is done on Tcl/Tk side) =item * Second method Copy installed Tcl/Tk binaries to some location, then install Perl module Tcl with a special action to make Tcl.pm know of this location. This approach makes sure that only chosen Tcl installation is used. =item * Third method During compiling Tcl Perl module, Tcl/Tk could be statically linked into module's shared library and all other files zipped into a single archive, so each file extracted when needed. To link Tcl/Tk binaries, prepare their libraries and then instruct Makefile.PL to use these libraries in a link stage. (TODO provide better detailed description) =back =cut use strict; our $DL_PATH; unless (defined $DL_PATH) { $DL_PATH = $ENV{PERL_TCL_DL_PATH} || $ENV{PERL_TCL_DLL} || ""; } unless ($DL_PATH) { require Config; for my $inc (@INC) { my $tkkit = "$inc/auto/Tcl/tkkit.$Config::Config{so}"; if (-f $tkkit) { $DL_PATH = $tkkit; last; } } } my $path; if ($^O eq 'darwin') { # Darwin 7.9 (OS X 10.3) requires the path of the executable be prepended # for #! scripts to operate properly (avoids RegisterProcess error). require Config; unless (grep { $_ eq $Config::Config{binexp} } split $Config::Config{path_sep}, $ENV{PATH}) { $path = join $Config::Config{path_sep}, $Config::Config{binexp}, $ENV{PATH}; } } require XSLoader; { local $ENV{PATH} = $path if $path; XSLoader::load('Tcl', $Tcl::VERSION); } sub new { my $int = _new(@_); return $int; } eval { require "Tclaux.pm"; }; END { Tcl::_Finalize(); } #TODO make better wording here # %anon_refs keeps track of anonymous subroutines that were created with # "CreateCommand" method during process of transformation of arguments for # "call" and other stuff such as scalar refs and so on. # (TODO -- find out how to check for refcounting and proper releasing of # resources) my %anon_refs; # %widget_refs is an array to hold refs that were created when working with # widget the point is - it's not dangerous to delete more than needed, because # those will be re-created at the very next time they needed. # however when widget goes away, it is good to delete anything that comes # into mind with that widget my %widget_refs; my $current_widget = ''; sub _current_refs_widget {$current_widget=shift} # Subroutine "call" preprocess the arguments for special cases # and then calls "icall" (implemented in Tcl.xs), which invokes # the command in Tcl. sub call { my $interp = shift; my @args = @_; # Process arguments looking for special cases for (my $argcnt=0; $argcnt<=$#args; $argcnt++) { my $arg = $args[$argcnt]; my $ref = ref($arg); next unless $ref; if ($ref eq 'CODE') { # We have been passed something like \&subroutine # Create a proc in Tcl that invokes this subroutine (no args) $args[$argcnt] = $interp->create_tcl_sub($arg); $widget_refs{$current_widget}->{$args[$argcnt]}++; } elsif ($ref =~ /^Tcl::Tk::Widget\b/) { # We have been passed a widget reference. # Convert to its Tk pathname (eg, .top1.fr1.btn2) $args[$argcnt] = $arg->path; $current_widget = $args[$argcnt] if $argcnt==0; } elsif ($ref eq 'SCALAR') { # We have been passed something like \$scalar # Create a tied variable between Tcl and Perl. # stringify scalar ref, create in ::perl namespace on Tcl side # This will be SCALAR(0xXXXXXX) - leave it to become part of a # Tcl array. my $nm = "::perl::$arg"; #$nm =~ s/\W/_/g; # remove () from stringified name unless (exists $anon_refs{$nm}) { $widget_refs{$current_widget}->{$nm}++; $anon_refs{$nm} = $arg; my $s = $$arg; tie $$arg, 'Tcl::Var', $interp, $nm; $s = '' unless defined $s; $$arg = $s; } $args[$argcnt] = $nm; # ... and substitute its name } elsif ($ref eq 'HASH') { # We have been passed something like \%hash # Create a tied variable between Tcl and Perl. # stringify hash ref, create in ::perl namespace on Tcl side # This will be HASH(0xXXXXXX) - leave it to become part of a # Tcl array. my $nm = $arg; $nm =~ s/\W/_/g; # remove () from stringified name $nm = "::perl::$nm"; unless (exists $anon_refs{$nm}) { $widget_refs{$current_widget}->{$nm}++; $anon_refs{$nm} = $arg; my %s = %$arg; tie %$arg, 'Tcl::Var', $interp, $nm; %$arg = %s; } $args[$argcnt] = $nm; # ... and substitute its name } elsif ($ref eq 'ARRAY' && ref($arg->[0]) eq 'CODE') { # We have been passed something like [\&subroutine, $arg1, ...] # Create a proc in Tcl that invokes this subroutine with args my $events; # Look for Tcl::Ev objects as the first arg - these must be # passed through for Tcl to evaluate. Used primarily for %-subs # This could check for any arg ref being Tcl::Ev obj, but it # currently doesn't. if ($#$arg >= 1 && ref($arg->[1]) eq 'Tcl::Ev') { $events = splice(@$arg, 1, 1); } $args[$argcnt] = $interp->create_tcl_sub(sub { $arg->[0]->(@_, @$arg[1..$#$arg]); }, $events); } elsif ($ref eq 'ARRAY' && ref($arg->[0]) =~ /^Tcl::Tk::Widget\b/) { # We have been passed [$Tcl_Tk_widget, 'method name', ...] # Create a proc in Tcl that invokes said method with args my $events; # Look for Tcl::Ev objects as the first arg - these must be # passed through for Tcl to evaluate. Used primarily for %-subs # This could check for any arg ref being Tcl::Ev obj, but it # currently doesn't. if ($#$arg >= 1 && ref($arg->[1]) eq 'Tcl::Ev') { $events = splice(@$arg, 1, 1); } my $wid = $arg->[0]; my $method_name = $arg->[1]; $args[$argcnt] = $interp->create_tcl_sub(sub { $wid->$method_name(@$arg[2..$#$arg]); }, $events); } elsif (ref($arg) eq 'REF' and ref($$arg) eq 'SCALAR') { # this is a very special shortcut: if we see construct like \\"xy" # then place proper Tcl::Ev(...) for easier access my $events = [map {"%$_"} split '', $$$arg]; if (ref($args[$argcnt+1]) eq 'ARRAY' && ref($args[$argcnt+1]->[0]) eq 'CODE') { $arg = $args[$argcnt+1]; $args[$argcnt] = $interp->create_tcl_sub(sub { $arg->[0]->(@_, @$arg[1..$#$arg]); }, $events); } elsif (ref($args[$argcnt+1]) eq 'CODE') { $args[$argcnt] = $interp->create_tcl_sub($args[$argcnt+1],$events); } else { warn "not CODE/ARRAY expected after description of event fields"; } splice @args, $argcnt+1, 1; } } # Done with special var processing. The only processing that icall # will do with the args is efficient conversion of SV to Tcl_Obj. # A SvIV will become a Tcl_IntObj, ARRAY refs will become Tcl_ListObjs, # and so on. The return result from icall will do the opposite, # converting a Tcl_Obj to an SV. if (!$Tcl::STACK_TRACE) { return $interp->icall(@args); } elsif (wantarray) { my @res; eval { @res = $interp->icall(@args); }; if ($@) { require Carp; Carp::confess ("Tcl error '$@' while invoking array result call:\n" . "\t\"@args\""); } return @res; } else { my $res; eval { $res = $interp->icall(@args); }; if ($@) { require Carp; Carp::confess ("Tcl error '$@' while invoking scalar result call:\n" . "\t\"@args\""); } return $res; } } # wcall is simple wrapper to 'call' but it tries to search $res in %anon_hash # This implementation is temporary sub wcall { if (wantarray) { return call(@_); } else { my $res = call(@_); if (exists $anon_refs{$res}) { return $anon_refs{$res}; } return $res; } } sub return_ref { my $interp = shift; my $rname = shift; return $anon_refs{$rname}; } sub delete_ref { my $interp = shift; my $rname = shift; my $ref = delete $anon_refs{$rname}; if (ref($ref) eq 'CODE') { $interp->DeleteCommand($rname); } else { $interp->UnsetVar($rname); #TODO: will this delete variable in Tcl? untie $$ref; } return $ref; } sub return_widget_refs { my $interp = shift; my $wpath = shift; return keys %{$widget_refs{$wpath}}; } sub delete_widget_refs { my $interp = shift; my $wpath = shift; for (keys %{$widget_refs{$wpath}}) { #print STDERR "del:$wpath($_)\n"; delete $widget_refs{$wpath}->{$_}; $interp->delete_ref($_); } } # create_tcl_sub will create TCL sub that will invoke perl anonymous sub # If $events variable is specified then special processing will be # performed to provide needed '%' variables. # If $tclname is specified then procedure will have namely that name, # otherwise it will have machine-readable name. # Returns tcl script suitable for using in tcl events. sub create_tcl_sub { my ($interp,$sub,$events,$tclname) = @_; unless ($tclname) { # stringify sub, becomes "CODE(0x######)" in ::perl namespace $tclname = "::perl::$sub"; } unless (exists $anon_refs{$tclname}) { $anon_refs{$tclname} = $sub; $interp->CreateCommand($tclname, $sub, undef, undef, 1); } if ($events) { # Add any %-substitutions to callback $tclname = "$tclname " . join(' ', @{$events}); } return $tclname; } sub Ev { my @events = @_; return bless \@events, "Tcl::Ev"; } package Tcl::List; use overload '""' => \&as_string, fallback => 1; package Tcl::Var; sub TIESCALAR { my $class = shift; my @objdata = @_; unless (@_ == 2 || @_ == 3) { require Carp; Carp::croak('Usage: tie $s, Tcl::Var, $interp, $varname [, $flags]'); }; bless \@objdata, $class; } sub TIEHASH { my $class = shift; my @objdata = @_; unless (@_ == 2 || @_ == 3) { require Carp; Carp::croak('Usage: tie %hash, Tcl::Var, $interp, $varname [, $flags]'); } bless \@objdata, $class; } my %arraystates; sub FIRSTKEY { my $obj = shift; die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" unless @{$obj} == 2 || @{$obj} == 3; my ($interp, $varname, $flags) = @$obj; $arraystates{$varname} = $interp->invoke("array","startsearch",$varname); my $r = $interp->invoke("array","nextelement",$varname,$arraystates{$varname}); if ($r eq '') { delete $arraystates{$varname}; return undef; } return $r; } sub NEXTKEY { my $obj = shift; die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" unless @{$obj} == 2 || @{$obj} == 3; my ($interp, $varname, $flags) = @$obj; my $r = $interp->invoke("array","nextelement",$varname,$arraystates{$varname}); if ($r eq '') { delete $arraystates{$varname}; return undef; } return $r; } sub CLEAR { my $obj = shift; die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" unless @{$obj} == 2 || @{$obj} == 3; my ($interp, $varname, $flags) = @$obj; $interp->invoke("array", "unset", "$varname"); #$interp->invoke("array", "set", "$varname", ""); } sub DELETE { my $obj = shift; unless (@{$obj} == 2 || @{$obj} == 3) { require Carp; Carp::croak("STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)"); } my ($interp, $varname, $flags) = @{$obj}; my ($str1) = @_; $interp->invoke("unset", "$varname($str1)"); # protect strings? } sub UNTIE { my $ref = shift; #print STDERR "UNTIE:$ref(@_)\n"; } sub DESTROY { my $ref = shift; delete $anon_refs{$ref->[1]}; } # This is the perl equiv to the C version, for reference # #sub STORE { # my $obj = shift; # croak "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" # unless @{$obj} == 2 || @{$obj} == 3; # my ($interp, $varname, $flags) = @{$obj}; # my ($str1, $str2) = @_; # if ($str2) { # $interp->SetVar2($varname, $str1, $str2, $flags); # } else { # $interp->SetVar($varname, $str1, $flags || 0); # } #} # #sub FETCH { # my $obj = shift; # croak "FETCH Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" # unless @{$obj} == 2 || @{$obj} == 3; # my ($interp, $varname, $flags) = @{$obj}; # my $key = shift; # if ($key) { # return $interp->GetVar2($varname, $key, $flags || 0); # } else { # return $interp->GetVar($varname, $flags || 0); # } #} package Tcl; =head1 Other Tcl interpreter methods =over 2 =item export_to_tcl method An interpreter method, export_to_tcl, is used to expose a number of perl subroutines and variables all at once into tcl/tk. B takes a hash as arguments, which represents named parameters, with following allowed values: =over 4 =item B => '...' tcl namespace, where commands and variables are to be created, defaults to 'perl'. If '' is specified - then global namespace is used. A possible '::' at end is stripped. =item B => { ... } anonymous hash of subs to be created in Tcl, in the form /tcl name/ => /code ref/ =item B => { ... } anonymous hash of vars to be created in Tcl, in the form /tcl name/ => /code ref/ =item B => '...' a name of Perl namespace, from where all existing subroutines will be searched and Tcl command will be created for each of them. =item B => '...' a name of Perl namespace, from where all existing variables will be searched, and each such variable will be tied to Tcl. =back An example: use strict; use Tcl; my $int = new Tcl; $tcl::foo = 'qwerty'; $int->export_to_tcl(subs_from=>'tcl',vars_from=>'tcl'); $int->Eval(<<'EOS'); package require Tk button .b1 -text {a fluffy button} -command perl::fluffy_sub button .b2 -text {a foo button} -command perl::foo entry .e -textvariable perl::foo pack .b1 .b2 .e focus .b2 tkwait window . EOS sub tcl::fluffy_sub { print "Hi, I am a fluffy sub\n"; } sub tcl::foo { print "Hi, I am foo\n"; $tcl::foo++; } =cut sub export_to_tcl { my $int = shift; my %args = @_; # name of Tcl package to hold tcl commands bound to perl subroutines my $tcl_namespace = (exists $args{namespace} ? $args{namespace} : 'perl::'); $tcl_namespace=~s/(?:::)?$/::/; # a batch of perl subroutines which tcl counterparts should be created my $subs = $args{subs} || {}; # a batch of perl variables which tcl counterparts should be created my $vars = $args{vars} || {}; # TBD: # only => \@list_of_names # argument to be able to limit the names to export to Tcl. if (exists $args{subs_from}) { # name of Perl package, which subroutines would be bound to tcl commands my $subs_from = $args{subs_from}; $subs_from =~ s/::$//; no strict 'refs'; for my $name (keys %{"$subs_from\::"}) { #print STDERR "$name;\n"; if (defined &{"$subs_from\::$name"}) { if (exists $subs->{$name}) { next; } #print STDERR "binding sub '$name'\n"; $int->CreateCommand("$tcl_namespace$name", \&{"$subs_from\::$name"}, undef, undef, 1); } } } if (exists $args{vars_from}) { # name of Perl package, which subroutines would be bound to tcl commands my $vars_from = $args{vars_from}; $vars_from =~ s/::$//; no strict 'refs'; for my $name (keys %{"$vars_from\::"}) { #print STDERR "$name;\n"; if (defined ${"$vars_from\::$name"}) { if (exists $vars->{$name}) { next; } #print STDERR "binding var '$name' in '$tcl_namespace'\n"; local $_ = ${"$vars_from\::$name"}; tie ${"$vars_from\::$name"}, 'Tcl::Var', $int, "$tcl_namespace$name"; ${"$vars_from\::$name"} = $_; } if (0) { # array, hash - no need to do anything. # (or should we?) } } } for my $subname (keys %$subs) { #print STDERR "binding2 sub '$subname'\n"; $int->CreateCommand("$tcl_namespace$subname",$subs->{$subname}, undef, undef, 1); } for my $varname (keys %$vars) { #print STDERR "binding2 var '$varname'\n"; unless (ref($vars->{$varname})) { require 'Carp.pm'; Carp::croak("should pass var ref as variable bind parameter"); } local $_ = ${$vars->{$varname}}; tie ${$vars->{$varname}}, 'Tcl::Var', $int, "$tcl_namespace$varname"; ${$vars->{$varname}} = $_; } } =item B extra convenience sub, binds to tcl all subs and vars from perl B namespace =back =cut sub export_tcl_namespace { my $int = shift; $int->export_to_tcl(subs_from=>'tcl', vars_from=>'tcl'); } =head1 AUTHORS Malcolm Beattie, mbeattie@sable.ox.ac.uk, 23 Oct 1994. Vadim Konovalov, vkon@cpan.org, 19 May 2003. Jeff Hobbs, jeff (a) activestate . com, 22 Mar 2004. Gisle Aas, gisle (a) activestate . com, 14 Apr 2004. =head1 COPYRIGHT This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut 1;