ext/DynaLoader/dlutils.c

   1 /* dlutils.c - handy functions and definitions for dl_*.xs files
   2  *
   3  * Currently this file is simply #included into dl_*.xs/.c files.
   4  * It should really be split into a dlutils.h and dlutils.c
   5  *
   6  * Modified:
   7  * 29th Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd
   8  *                      files when the interpreter exits
   9  */
  10
  11 #define MY_CXT_KEY "DynaLoader_guts"
  12
  13 typedef struct {
  14     char *      x_dl_last_error;        /* pointer to allocated memory for
  15                                            last error message */
  16     int         x_dl_nonlazy;           /* flag for immediate rather than lazy
  17                                            linking (spots unresolved symbol) */
  18 #ifdef DL_LOADONCEONLY
  19     HV *        x_dl_loaded_files;      /* only needed on a few systems */
  20 #endif
  21 #ifdef DL_CXT_EXTRA
  22     my_cxtx_t   x_dl_cxtx;              /* extra platform-specific data */
  23 #endif
  24 #ifdef DEBUGGING
  25     int         x_dl_debug;     /* value copied from $DynaLoader::dl_debug */
  26 #endif
  27 } my_cxt_t;
  28
  29 /* XXX most of this is boilerplate code that should abstracted further into
  30  * macros and exposed via XSUB.h */
  31
  32 #if defined(USE_ITHREADS)
  33
  34 #define dMY_CXT_SV \
  35         SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY,             \
  36                                   sizeof(MY_CXT_KEY)-1, TRUE)
  37
  38 /* we allocate my_cxt in a Perl SV so that it will be released when
  39  * the interpreter goes away */
  40 #define dMY_CXT_INIT \
  41         dMY_CXT_SV;                                                     \
  42         /* newSV() allocates one more than needed */                    \
  43         my_cxt_t *my_cxt = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
  44         Zero(my_cxt, 1, my_cxt_t);                                      \
  45         sv_setuv(my_cxt_sv, (UV)my_cxt);
  46
  47 #define dMY_CXT \
  48         dMY_CXT_SV;                                                     \
  49         my_cxt_t *my_cxt = (my_cxt_t*)SvUV(my_cxt_sv)
  50
  51 #define dl_last_error   (my_cxt->x_dl_last_error)
  52 #define dl_nonlazy      (my_cxt->x_dl_nonlazy)
  53 #ifdef DL_LOADONCEONLY
  54 #define dl_loaded_files (my_cxt->x_dl_loaded_files)
  55 #endif
  56 #ifdef DL_CXT_EXTRA
  57 #define dl_cxtx         (my_cxt->x_dl_cxtx)
  58 #endif
  59 #ifdef DEBUGGING
  60 #define dl_debug        (my_cxt->x_dl_debug)
  61 #endif
  62
  63 #else /* USE_ITHREADS */
  64
  65 static my_cxt_t my_cxt;
  66
  67 #define dMY_CXT_SV      dNOOP
  68 #define dMY_CXT_INIT    dNOOP
  69 #define dMY_CXT         dNOOP
  70
  71 #define dl_last_error   (my_cxt.x_dl_last_error)
  72 #define dl_nonlazy      (my_cxt.x_dl_nonlazy)
  73 #ifdef DL_LOADONCEONLY
  74 #define dl_loaded_files (my_cxt.x_dl_loaded_files)
  75 #endif
  76 #ifdef DL_CXT_EXTRA
  77 #define dl_cxtx         (my_cxt.x_dl_cxtx)
  78 #endif
  79 #ifdef DEBUGGING
  80 #define dl_debug        (my_cxt.x_dl_debug)
  81 #endif
  82
  83 #endif /* !defined(USE_ITHREADS) */
  84
  85
  86 #ifdef DEBUGGING
  87 #define DLDEBUG(level,code) \
  88     STMT_START {                                        \
  89         dMY_CXT;                                        \
  90         if (dl_debug>=level) { code; }                  \
  91     } STMT_END
  92 #else
  93 #define DLDEBUG(level,code)     NOOP
  94 #endif
  95
  96 #ifdef DL_UNLOAD_ALL_AT_EXIT
  97 /* Close all dlopen'd files */
  98 static void
  99 dl_unload_all_files(pTHX_ void *unused)
 100 {
 101     CV *sub;
 102     AV *dl_librefs;
 103     SV *dl_libref;
 104
 105     if ((sub = get_cv("DynaLoader::dl_unload_file", FALSE)) != NULL) {
 106         dl_librefs = get_av("DynaLoader::dl_librefs", FALSE);
 107         while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) {
 108            dSP;
 109            ENTER;
 110            SAVETMPS;
 111            PUSHMARK(SP);
 112            XPUSHs(sv_2mortal(dl_libref));
 113            PUTBACK;
 114            call_sv((SV*)sub, G_DISCARD | G_NODEBUG);
 115            FREETMPS;
 116            LEAVE;
 117         }
 118     }
 119 }
 120 #endif
 121
 122 static void
 123 dl_generic_private_init(pTHX)   /* called by dl_*.xs dl_private_init() */
 124 {
 125     char *perl_dl_nonlazy;
 126     dMY_CXT_INIT;
 127
 128     dl_last_error = NULL;
 129     dl_nonlazy = 0;
 130 #ifdef DL_LOADONCEONLY
 131     dl_loaded_files = Nullhv;
 132 #endif
 133 #ifdef DEBUGGING
 134     {
 135         SV *sv = get_sv("DynaLoader::dl_debug", 0);
 136         dl_debug = sv ? SvIV(sv) : 0;
 137     }
 138 #endif
 139     if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL )
 140         dl_nonlazy = atoi(perl_dl_nonlazy);
 141     if (dl_nonlazy)
 142         DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n"));
 143 #ifdef DL_LOADONCEONLY
 144     if (!dl_loaded_files)
 145         dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */
 146 #endif
 147 #ifdef DL_UNLOAD_ALL_AT_EXIT
 148     call_atexit(&dl_unload_all_files, (void*)0);
 149 #endif
 150 }
 151
 152
 153 /* SaveError() takes printf style args and saves the result in dl_last_error */
 154 static void
 155 SaveError(pTHX_ char* pat, ...)
 156 {
 157     dMY_CXT;
 158     va_list args;
 159     SV *msv;
 160     char *message;
 161     STRLEN len;
 162
 163     /* This code is based on croak/warn, see mess() in util.c */
 164
 165     va_start(args, pat);
 166     msv = vmess(pat, &args);
 167     va_end(args);
 168
 169     message = SvPV(msv,len);
 170     len++;              /* include terminating null char */
 171
 172     /* Allocate some memory for the error message */
 173     if (dl_last_error)
 174         dl_last_error = (char*)saferealloc(dl_last_error, len);
 175     else
 176         dl_last_error = (char*)safemalloc(len);
 177
 178     /* Copy message into dl_last_error (including terminating null char) */
 179     strncpy(dl_last_error, message, len) ;
 180     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error));
 181 }
 182