[ID 20011201.170] Time::HiRes in devel-perl causes segfaults for xs users
[p5sagit/p5-mst-13.2.git] / 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 #ifndef XS_VERSION
12 #  define XS_VERSION "0"
13 #endif
14 #define MY_CXT_KEY "DynaLoader::_guts" XS_VERSION
15
16 typedef struct {
17     char *      x_dl_last_error;        /* pointer to allocated memory for
18                                            last error message */
19     int         x_dl_nonlazy;           /* flag for immediate rather than lazy
20                                            linking (spots unresolved symbol) */
21 #ifdef DL_LOADONCEONLY
22     HV *        x_dl_loaded_files;      /* only needed on a few systems */
23 #endif
24 #ifdef DL_CXT_EXTRA
25     my_cxtx_t   x_dl_cxtx;              /* extra platform-specific data */
26 #endif
27 #ifdef DEBUGGING
28     int         x_dl_debug;     /* value copied from $DynaLoader::dl_debug */
29 #endif
30 } my_cxt_t;
31
32 START_MY_CXT
33
34 #define dl_last_error   (MY_CXT.x_dl_last_error)
35 #define dl_nonlazy      (MY_CXT.x_dl_nonlazy)
36 #ifdef DL_LOADONCEONLY
37 #define dl_loaded_files (MY_CXT.x_dl_loaded_files)
38 #endif
39 #ifdef DL_CXT_EXTRA
40 #define dl_cxtx         (MY_CXT.x_dl_cxtx)
41 #endif
42 #ifdef DEBUGGING
43 #define dl_debug        (MY_CXT.x_dl_debug)
44 #endif
45
46 #ifdef DEBUGGING
47 #define DLDEBUG(level,code) \
48     STMT_START {                                        \
49         dMY_CXT;                                        \
50         if (dl_debug>=level) { code; }                  \
51     } STMT_END
52 #else
53 #define DLDEBUG(level,code)     NOOP
54 #endif
55
56 #ifdef DL_UNLOAD_ALL_AT_EXIT
57 /* Close all dlopen'd files */
58 static void
59 dl_unload_all_files(pTHX_ void *unused)
60 {
61     CV *sub;
62     AV *dl_librefs;
63     SV *dl_libref;
64
65     if ((sub = get_cv("DynaLoader::dl_unload_file", FALSE)) != NULL) {
66         dl_librefs = get_av("DynaLoader::dl_librefs", FALSE);
67         while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) {
68            dSP;
69            ENTER;
70            SAVETMPS;
71            PUSHMARK(SP);
72            XPUSHs(sv_2mortal(dl_libref));
73            PUTBACK;
74            call_sv((SV*)sub, G_DISCARD | G_NODEBUG);
75            FREETMPS;
76            LEAVE;
77         }
78     }
79 }
80 #endif
81
82 static void
83 dl_generic_private_init(pTHX)   /* called by dl_*.xs dl_private_init() */
84 {
85     char *perl_dl_nonlazy;
86     MY_CXT_INIT;
87
88     dl_last_error = NULL;
89     dl_nonlazy = 0;
90 #ifdef DL_LOADONCEONLY
91     dl_loaded_files = Nullhv;
92 #endif
93 #ifdef DEBUGGING
94     {
95         SV *sv = get_sv("DynaLoader::dl_debug", 0);
96         dl_debug = sv ? SvIV(sv) : 0;
97     }
98 #endif
99     if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL )
100         dl_nonlazy = atoi(perl_dl_nonlazy);
101     if (dl_nonlazy)
102         DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n"));
103 #ifdef DL_LOADONCEONLY
104     if (!dl_loaded_files)
105         dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */
106 #endif
107 #ifdef DL_UNLOAD_ALL_AT_EXIT
108     call_atexit(&dl_unload_all_files, (void*)0);
109 #endif
110 }
111
112
113 /* SaveError() takes printf style args and saves the result in dl_last_error */
114 static void
115 SaveError(pTHX_ char* pat, ...)
116 {
117     dMY_CXT;
118     va_list args;
119     SV *msv;
120     char *message;
121     STRLEN len;
122
123     /* This code is based on croak/warn, see mess() in util.c */
124
125     va_start(args, pat);
126     msv = vmess(pat, &args);
127     va_end(args);
128
129     message = SvPV(msv,len);
130     len++;              /* include terminating null char */
131
132     /* Allocate some memory for the error message */
133     if (dl_last_error)
134         dl_last_error = (char*)saferealloc(dl_last_error, len);
135     else
136         dl_last_error = (char*)safemalloc(len);
137
138     /* Copy message into dl_last_error (including terminating null char) */
139     strncpy(dl_last_error, message, len) ;
140     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error));
141 }
142