home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / TCL / BLT / _BLT.TAR / usr / lib / blt / applications / extloader / ext.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-04-22  |  15.9 KB  |  652 lines
  1. /*
  2.  * ext.c --
  3.  *
  4.  *    This module implements an extension library loading
  5.  *    mechanism for the Tcl library.
  6.  *
  7.  * Copyright 1993 by AT&T Bell Laboratories.
  8.  * Permission to use, copy, modify, and distribute this software
  9.  * and its documentation for any purpose and without fee is hereby
  10.  * granted, provided that the above copyright notice appear in all
  11.  * copies and that both that the copyright notice and warranty
  12.  * disclaimer appear in supporting documentation, and that the
  13.  * names of AT&T Bell Laboratories any of their entities not be used
  14.  * in advertising or publicity pertaining to distribution of the
  15.  * software without specific, written prior permission.
  16.  *
  17.  * AT&T disclaims all warranties with regard to this software, including
  18.  * all implied warranties of merchantability and fitness.  In no event
  19.  * shall AT&T be liable for any special, indirect or consequential
  20.  * damages or any damages whatsoever resulting from loss of use, data
  21.  * or profits, whether in an action of contract, negligence or other
  22.  * tortuous action, arising out of or in connection with the use or
  23.  * performance of this software.
  24.  *
  25.  * Extension command created by George Howlett.
  26.  */
  27.  
  28. #include "extConfig.h"
  29. #ifdef HAVE_STDLIB_H
  30. #include <stdlib.h>
  31. #endif
  32. #include <sys/stat.h>
  33. #ifdef HAVE_STRING_H
  34. #include <string.h>
  35. #endif
  36. #include <ctype.h>
  37. #include <tcl.h>
  38.  
  39. static Tcl_HashTable handleTable;    /* Table of shared library handles.
  40.                      * Indicates if the extension library
  41.                      * has been previously loaded and 
  42.                      * initialized */
  43. static int initialized = 0;
  44. static char *stdLoadPaths = "/lib /usr/lib /usr/local/lib";
  45.  
  46. typedef int (ExtInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
  47. typedef void *Xldr_Handle;
  48.  
  49. /*
  50.  *----------------------------------------------------------------------
  51.  *
  52.  * System dependent routines
  53.  *
  54.  * This currently works with the following operating systems only:
  55.  *
  56.  *     HP-UX 9.01  shl_load, shl_unload, shl_findsym
  57.  *    SunOS 4.x   dlopen, dlclose, dlfindsym, dlerror
  58.  *    SunOS 5.x
  59.  *
  60.  * This interface uses four routines to manipulate shared libraries.
  61.  *
  62.  *    static void *Xldr_Load(char *path);
  63.  *    static int Xldr_Unload(void *handle);
  64.  *    static void *Xldr_FindProc(void *handle, char *symbol);
  65.  *    static char *Xldr_Error(void *handle);
  66.  *
  67.  *----------------------------------------------------------------------
  68.  */
  69.  
  70. /* HP-UX */
  71.  
  72. #ifdef hpux
  73.  
  74. #include <dl.h>
  75.  
  76. /*
  77.  *----------------------------------------------------------------------
  78.  *
  79.  * Xldr_Load --
  80.  *
  81.  *    Loads an HP-UX shared library into the process.
  82.  *
  83.  *    Currently set for deferred bindings.  I don't know what
  84.  *    effects this will have on performance.
  85.  *
  86.  * Results:
  87.  *    If successful, returns a handle to the shared library.
  88.  *    Otherwise, returns NULL.
  89.  *
  90.  *----------------------------------------------------------------------
  91.  */
  92. static void *
  93. Xldr_Load(path)
  94.     char *path;
  95. {
  96.     return shl_load(path, BIND_IMMEDIATE | BIND_FIRST | BIND_VERBOSE, 0L);
  97. }
  98.  
  99. /*
  100.  *----------------------------------------------------------------------
  101.  *
  102.  * Xldr_Unload --
  103.  *
  104.  *    Unloads a Sun shared library from the process.
  105.  *
  106.  * Results:
  107.  *    If successful, returns 0, otherwise -1.
  108.  *
  109.  *----------------------------------------------------------------------
  110.  */
  111. static int
  112. Xldr_Unload(handle)
  113.     void *handle;
  114. {
  115.     return shl_unload(handle);
  116. }
  117.  
  118. /*
  119.  *----------------------------------------------------------------------
  120.  *
  121.  * Xldr_FindProc --
  122.  *
  123.  *    Finds the address associated with the symbol given.
  124.  *
  125.  *    Type is set to TYPE_PROCEDURE to ensure that the symbol
  126.  *    is a procedure.
  127.  *
  128.  * Results:
  129.  *    If successful, returns the address of the symbol.
  130.  *    Otherwise, returns NULL.
  131.  *
  132.  *----------------------------------------------------------------------
  133.  */
  134. static ExtInitProc *
  135. Xldr_FindProc(handle, symbol)
  136.     void *handle;
  137.     char *symbol;
  138. {
  139.     int result;
  140.     void *value;
  141.  
  142.     result = shl_findsym((shl_t)&handle, symbol, TYPE_UNDEFINED, &value);
  143.     if (result < 0) {
  144.     return (void *) NULL;
  145.     }
  146.     return (ExtInitProc *) value;
  147. }
  148.  
  149. #ifdef HAVE_ERRNO_H
  150. #include <errno.h>
  151. #endif
  152.  
  153. /*
  154.  *----------------------------------------------------------------------
  155.  *
  156.  * Xldr_Error --
  157.  *
  158.  *    Returns an error message of the last load error.
  159.  *
  160.  *----------------------------------------------------------------------
  161.  */
  162. static char *
  163. Xldr_Error()
  164. {
  165.     extern char *sys_errlist[];
  166.  
  167.     return sys_errlist[errno];
  168. }
  169.  
  170. #else /*hpux*/
  171.  
  172. /* SunOS 4.x, SunOS 5.x, etal.  Anything that uses "dlopen" */
  173.  
  174. #ifdef HAVE_DLFCN_H
  175. #include <dlfcn.h>
  176. #endif
  177.  
  178. /*
  179.  *----------------------------------------------------------------------
  180.  *
  181.  * Xldr_Load --
  182.  *
  183.  *    Loads a Sun shared library in the process.
  184.  *
  185.  *    According to the SunOS 4.x manual for dlopen(3), the flag should 
  186.  *    always be 1.
  187.  *
  188.  * Results:
  189.  *    If successful, returns a handle to the shared library.
  190.  *    Otherwise, returns NULL.
  191.  *
  192.  *----------------------------------------------------------------------
  193.  */
  194. static void *
  195. Xldr_Load(path)
  196.     char *path;
  197. {
  198.     return dlopen(path, 1);
  199. }
  200.  
  201. /*
  202.  *----------------------------------------------------------------------
  203.  *
  204.  * Xldr_Unload --
  205.  *
  206.  *    Unloads a Sun shared library from the process.
  207.  *
  208.  * Results:
  209.  *    If successful, returns 0, otherwise -1.
  210.  *
  211.  *----------------------------------------------------------------------
  212.  */
  213. static int
  214. Xldr_Unload(handle)
  215.     void *handle;
  216. {
  217.     int result;
  218.     
  219.     result = dlclose(handle);
  220.     if (result != 0) {
  221.     result = -1;
  222.     }
  223.     return result;
  224. }
  225.  
  226. /*
  227.  *----------------------------------------------------------------------
  228.  *
  229.  * Xldr_FindProc --
  230.  *
  231.  *    Finds the address associated with the symbol given.
  232.  *
  233.  *    There's no way to ensure that the symbol is a procedure.
  234.  *
  235.  * Results:
  236.  *    If successful, returns the address of the symbol.
  237.  *    Otherwise, returns NULL.
  238.  *
  239.  *----------------------------------------------------------------------
  240.  */
  241. static ExtInitProc *
  242. Xldr_FindProc(handle, symbol)
  243.     void *handle;
  244.     char *symbol;
  245. {
  246.     return (ExtInitProc *) dlsym(handle, symbol);
  247. }
  248.  
  249. /*
  250.  *----------------------------------------------------------------------
  251.  *
  252.  * Xldr_Error --
  253.  *
  254.  *    Returns an error message of the last load error.
  255.  *
  256.  *----------------------------------------------------------------------
  257.  */
  258. static char *
  259. Xldr_Error()
  260. {
  261.     return dlerror();
  262. }
  263.  
  264. #endif /* hpux */
  265.  
  266.  
  267.  
  268. #ifndef EXTENSION_VERSION
  269. #define EXTENSION_VERSION "1.0"
  270. #endif
  271.  
  272.  
  273. /*
  274.  *----------------------------------------------------------------------
  275.  *
  276.  * FindLibrary --
  277.  *
  278.  *    Finds the library given for a search path.  If the path variable
  279.  *    is set, it should contain a list of directories
  280.  *    representing the search path.  Other the standard library
  281.  *    directories will be searched.
  282.  *
  283.  *    The directories are stat-ed for their existence.
  284.  *
  285.  * Results:
  286.  *    If successful, returns the full path of the library, otherwise
  287.  *    NULL.
  288.  *
  289.  * Side Effects:
  290.  *    The string returned is malloc-ed. It is the responsibility of
  291.  *    the caller to free this string.
  292.  *
  293.  *----------------------------------------------------------------------
  294.  */
  295. static char *
  296. FindLibrary(interp, name)
  297.     Tcl_Interp *interp;
  298.     char *name;
  299. {
  300.     char *pathName;
  301.     struct stat statInfo;
  302.     char *library;
  303.  
  304.     if (*name != '/') {
  305.     int length;
  306.     int found = 0;
  307.     int numDirs;
  308.     char **dirArr;
  309.     char *pathList;
  310.     register int i;
  311.     
  312.     pathList = Tcl_GetVar2(interp, "tcl_extloadpath", (char *)NULL, 
  313.            TCL_GLOBAL_ONLY);
  314.     if (pathList == NULL) {
  315.         pathList = stdLoadPaths; /* use default path */
  316.     }
  317.     if (Tcl_SplitList(interp, pathList, &numDirs, &dirArr) != TCL_OK) {
  318.         Tcl_AppendResult(interp, "can't split \"", pathList, "\"",
  319.                  (char *)NULL);
  320.         return NULL;
  321.     }
  322.     for (i = 0; i < numDirs; i++) {
  323.         length = strlen(dirArr[i]) + strlen(name) + 2;
  324.         pathName = (char *)malloc(sizeof(char) * length);
  325.         sprintf(pathName, "%s/%s", dirArr[i], name);
  326.         if (stat(pathName, &statInfo) >= 0) {
  327.         found = 1;
  328.         break;
  329.         }
  330.         free(pathName);
  331.     }
  332.     free((char *)dirArr);
  333.     if (!found) {
  334.         Tcl_AppendResult(interp, "can't find \"", name,
  335.         "\" in library path", (char *)NULL);
  336.         return NULL;
  337.     }
  338.     } else {
  339.     if (stat(name, &statInfo) < 0) {
  340.         Tcl_AppendResult(interp, "can't find \"", name, "\": ",
  341.         Tcl_PosixError(interp), (char *)NULL);
  342.         return NULL;
  343.     }
  344.     pathName = (char *)malloc(sizeof(char) * (strlen(name) + 1));
  345.  
  346.     strcpy(pathName, name);
  347.     }
  348.     return (pathName);
  349. }
  350.  
  351. /*
  352.  *----------------------------------------------------------------------
  353.  *
  354.  * LoadLibrary --
  355.  *
  356.  *    Loads the shared object file representing into the current
  357.  *    process.
  358.  *
  359.  * Results:
  360.  *    Returns a standard Tcl result. If the load was successful, or
  361.  *    previously successful, TCL_OK is returned. Otherwise TCL_ERROR
  362.  *    is returned and an error message is left in interp->result.
  363.  *
  364.  * Side Effects:
  365.  *    The shared library is loaded into to the current process.
  366.  *
  367.  *----------------------------------------------------------------------
  368.  */
  369. static int
  370. LoadLibrary(interp, libName)
  371.     Tcl_Interp *interp;
  372.     char *libName;
  373. {
  374.     void *handle;
  375.     Tcl_HashEntry *entryPtr;
  376.     char *pathName;
  377.  
  378.     pathName = FindLibrary(interp, libName);
  379.     if (pathName == NULL) {
  380.     return TCL_ERROR;
  381.     }
  382.     entryPtr = Tcl_FindHashEntry(&handleTable, pathName);
  383.     if (entryPtr != NULL) {
  384.     handle = (void *)Tcl_GetHashValue(entryPtr);
  385.     if (handle != NULL) {
  386.         free(pathName);
  387.         return TCL_OK;        /* Already loaded */
  388.     }
  389.     }
  390.     handle = Xldr_Load(pathName);
  391.     if (handle == NULL) {
  392.     Tcl_AppendResult(interp, "can't load library \"", pathName,
  393.              "\": ", Xldr_Error(), (char *)NULL);
  394.     free(pathName);
  395.     return TCL_ERROR;
  396.     }
  397.     if (entryPtr == NULL) {
  398.     int dummy;
  399.  
  400.     entryPtr = Tcl_CreateHashEntry (&handleTable, pathName, &dummy);
  401.     }
  402.     Tcl_SetHashValue(entryPtr, (ClientData)handle);
  403.     free(pathName);
  404.     return TCL_OK;
  405. }
  406.  
  407. /*
  408.  *----------------------------------------------------------------------
  409.  *
  410.  * InitLibrary --
  411.  *
  412.  *    Searches for and calls the designated library initialization
  413.  *    routine. 
  414.  *
  415.  * Results:
  416.  *    Returns a standard Tcl result. If the load was successful, or
  417.  *    previously successful, TCL_OK is returned. Otherwise TCL_ERROR
  418.  *    is returned and an error message is left in interp->result.
  419.  *
  420.  * Side Effects:
  421.  *    The shared library is loaded into to the current process.
  422.  *
  423.  *----------------------------------------------------------------------
  424.  */
  425. static int
  426. InitLibrary(interp, procName)
  427.     Tcl_Interp *interp;
  428.     char *procName;
  429. {
  430.     ExtInitProc *initProc;
  431.     Tcl_HashEntry *entryPtr;
  432.     Tcl_HashSearch cursor;
  433.     void *handle;
  434.     
  435.     /*
  436.      * Find the address of the initialization procedure, searching all
  437.      * the libraries loaded so far.
  438.      */
  439.     initProc = NULL;
  440.     for (entryPtr = Tcl_FirstHashEntry(&handleTable, &cursor); 
  441.      entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&cursor)) {
  442.     handle = (void *)Tcl_GetHashValue(entryPtr);
  443.     initProc = Xldr_FindProc(handle, procName);
  444.     if (initProc != NULL) {
  445.         break;
  446.     }
  447.     }
  448.     if (initProc == NULL) {
  449.     Tcl_AppendResult(interp, "can't find init routine \"", procName,
  450.          "\": ", Xldr_Error(), (char *)NULL);
  451.     return TCL_ERROR;
  452.     }
  453.     /* 
  454.      * Finally, run the initialization procedure.
  455.      */
  456.     return ((*initProc) (interp));
  457. }
  458.  
  459. /*
  460.  *----------------------------------------------------------------------
  461.  *
  462.  * LoadExtension --
  463.  *
  464.  *    Loads the shared object file representing the extension and 
  465.  *    calls its initialization procedure.
  466.  *
  467.  * Results:
  468.  *    Returns a standard Tcl result. If the load was successful, or
  469.  *    previously successful, TCL_OK is returned. Otherwise TCL_ERROR
  470.  *    is returned and an error message is left in interp->result.
  471.  *
  472.  * Side Effects:
  473.  *    The shared library is attached to the process.
  474.  *
  475.  *----------------------------------------------------------------------
  476.  */
  477. static int
  478. LoadExtension(interp, name)
  479.     Tcl_Interp *interp;
  480.     char *name;
  481. {
  482.     char *libraries;
  483.     register int i;
  484.     char **libArr;
  485.     int numLibs;
  486.     int result = TCL_ERROR;
  487.  
  488.     libraries = Tcl_GetVar2(interp, "tcl_extensions", name, TCL_GLOBAL_ONLY);
  489.     if (libraries == NULL) {
  490.     Tcl_AppendResult(interp, "can't find extension \"", name, 
  491.              "\" in tcl_extensions", (char *)NULL);
  492.     return TCL_ERROR;
  493.     }
  494.     if (Tcl_SplitList(interp, libraries, &numLibs, &libArr) != TCL_OK) {
  495.     return TCL_ERROR;
  496.     }
  497.     if (numLibs < 2) {
  498.     Tcl_AppendResult(interp, "two few items in extension entry for \"", 
  499.              name, "\"", (char *)NULL);
  500.     goto error;
  501.     }
  502.     /* 
  503.      * The following items are names of libraries.  Find each library
  504.      * (absolute path) from the item and try to load it.
  505.      */
  506.     for (i = 1; i < numLibs; i++) {
  507.     if (LoadLibrary(interp, libArr[i]) != TCL_OK) {
  508.         goto error;
  509.     }
  510.     }
  511.     /* 
  512.      * Run the initialization procedure.
  513.      */
  514.     if (InitLibrary(interp, libArr[0]) != TCL_OK) {
  515.     goto error;
  516.     }
  517.     result = TCL_OK;
  518.   error:
  519.     free ((char *)libArr);
  520.     return result;
  521. }
  522.  
  523. /*
  524.  *--------------------------------------------------------------
  525.  *
  526.  * ExtensionCmd --
  527.  *
  528.  *    This procedure is invoked to process the Tcl command
  529.  *    that loads extensions in the Tcl shell. See the user
  530.  *    documentation for details on what it does.
  531.  *
  532.  * Results:
  533.  *    A standard Tcl result.
  534.  *
  535.  * Side effects:
  536.  *    See the user documentation.
  537.  *
  538.  *--------------------------------------------------------------
  539.  */
  540. static int
  541. ExtensionCmd(clientData, interp, argc, argv)
  542.     ClientData clientData;
  543.     Tcl_Interp *interp;
  544.     int argc;
  545.     char **argv;
  546. {
  547.     char c;
  548.     int length;
  549.  
  550.     if (argc < 2) {
  551.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  552.         " option ?args? \"", (char *)NULL);
  553.     return TCL_ERROR;
  554.     }
  555.     if (!initialized) {
  556.     static char initCmd[] = " \n\
  557.         if [info exists env(TCL_EXTMAP)] { \n\
  558.                 set file $env(TCL_EXTMAP) \n\
  559.         } else { \n\
  560.                 set file [info library]/extensions.tcl \n\
  561.             } \n\
  562.             if [file readable $file] { \n\
  563.                 source $file \n\
  564.             } \n\
  565.         ";
  566.     if (Tcl_Eval(interp, initCmd) != TCL_OK) {
  567.         return TCL_ERROR;
  568.         }
  569.     Tcl_ResetResult(interp);
  570.     Tcl_InitHashTable(&handleTable, TCL_STRING_KEYS);
  571.     initialized = 1;
  572.     }
  573.     c = argv[1][0];
  574.     length = strlen(argv[1]);
  575.     if ((c == 'a') && (strncmp(argv[1], "add", length) == 0)) {
  576.     register int i;
  577.  
  578.     for (i = 2; i < argc; i++) {
  579.         if (LoadExtension(interp, argv[i]) != TCL_OK) {
  580.         return TCL_ERROR;
  581.         }
  582.     }
  583.     } else if ((c == 'l') && (length > 2) && 
  584.            (strncmp(argv[1], "lload", length) == 0)){
  585.     if (argc != 3) {
  586.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  587.                  " load library\"", (char *)NULL);
  588.         return TCL_ERROR;
  589.     }
  590.     if (LoadLibrary(interp, argv[2]) != TCL_OK) {
  591.         return TCL_ERROR;
  592.     }
  593.     } else if ((c == 'l') && (length > 2) && 
  594.     (strncmp(argv[1], "linit", length) == 0)){
  595.     if (argc != 3) {
  596.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  597.                  " init library\"", (char *)NULL);
  598.         return TCL_ERROR;
  599.     }
  600.     if (InitLibrary(interp, argv[2]) != TCL_OK) {
  601.         return TCL_ERROR;
  602.     }
  603.     } else if ((c == 'l') && (length > 2) &&
  604.            (strncmp(argv[1], "libs", length) == 0)) {
  605.     Tcl_HashSearch cursor;
  606.     Tcl_HashEntry *entryPtr;
  607.     char *pathName;
  608.  
  609.     for (entryPtr = Tcl_FirstHashEntry(&handleTable, &cursor);
  610.         entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&cursor)) {
  611.         pathName = Tcl_GetHashKey(&handleTable, entryPtr);
  612.         Tcl_AppendElement(interp, pathName);
  613.     }
  614.     } else {
  615.     Tcl_AppendResult(interp, "unknown option \"", argv[1],
  616.         "\": should be add, libs, linit, or lload", (char *)NULL);
  617.     return TCL_ERROR;
  618.     }
  619.  
  620.     return TCL_OK;
  621. }
  622.  
  623. /*
  624.  *--------------------------------------------------------------
  625.  *
  626.  * Extension_Init --
  627.  *
  628.  *    This procedure is invoked to initialized the Tcl command
  629.  *    that corresponds to the "extension" command.
  630.  *
  631.  * Results:
  632.  *    None.
  633.  *
  634.  * Side effects:
  635.  *    Creates the new "extension" command.
  636.  *
  637.  *--------------------------------------------------------------
  638.  */
  639. int
  640. Extension_Init(interp)
  641.     Tcl_Interp *interp;
  642. {
  643.     Tcl_CmdInfo info;
  644.  
  645.     if (!Tcl_GetCommandInfo(interp, "extension", &info)) {
  646.     Tcl_CreateCommand(interp, "extension", ExtensionCmd, (ClientData)0,
  647.         (Tcl_CmdDeleteProc *)NULL);
  648.     }
  649.     return TCL_OK;
  650. }
  651.  
  652.