This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ext/ + -Wall
[perl5.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
12 /* pointer to allocated memory for last error message */
13 static char *LastError  = (char*)NULL;
14
15 /* flag for immediate rather than lazy linking (spots unresolved symbol) */
16 static int dl_nonlazy = 0;
17
18 #ifdef DL_LOADONCEONLY
19 static HV *dl_loaded_files = Nullhv;    /* only needed on a few systems */
20 #endif
21
22
23 #ifdef DEBUGGING
24 static int dl_debug = 0;        /* value copied from $DynaLoader::dl_debug */
25 #define DLDEBUG(level,code)     if (dl_debug>=level) { code; }
26 #else
27 #define DLDEBUG(level,code)
28 #endif
29
30 #ifdef DL_UNLOAD_ALL_AT_EXIT
31 /* Close all dlopen'd files */
32 static void
33 dl_unload_all_files(pTHXo_ void *unused)
34 {
35     CV *sub;
36     AV *dl_librefs;
37     SV *dl_libref;
38
39     if ((sub = get_cv("DynaLoader::dl_unload_file", FALSE)) != NULL) {
40         dl_librefs = get_av("DynaLoader::dl_librefs", FALSE);
41         while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) {
42            dSP;
43            ENTER;
44            SAVETMPS;
45            PUSHMARK(SP);
46            XPUSHs(sv_2mortal(dl_libref));
47            PUTBACK;
48            call_sv((SV*)sub, G_DISCARD | G_NODEBUG);
49            FREETMPS;
50            LEAVE;
51         }
52     }
53 }
54 #endif
55
56 static void
57 dl_generic_private_init(pTHXo)  /* called by dl_*.xs dl_private_init() */
58 {
59     char *perl_dl_nonlazy;
60 #ifdef DEBUGGING
61     SV *sv = get_sv("DynaLoader::dl_debug", 0);
62     dl_debug = sv ? SvIV(sv) : 0;
63 #endif
64     if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL )
65         dl_nonlazy = atoi(perl_dl_nonlazy);
66     if (dl_nonlazy)
67         DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n"));
68 #ifdef DL_LOADONCEONLY
69     if (!dl_loaded_files)
70         dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */
71 #endif
72 #ifdef DL_UNLOAD_ALL_AT_EXIT
73     call_atexit(&dl_unload_all_files, (void*)0);
74 #endif
75 }
76
77
78 /* SaveError() takes printf style args and saves the result in LastError */
79 static void
80 SaveError(pTHXo_ char* pat, ...)
81 {
82     va_list args;
83     SV *msv;
84     char *message;
85     STRLEN len;
86
87     /* This code is based on croak/warn, see mess() in util.c */
88
89     va_start(args, pat);
90     msv = vmess(pat, &args);
91     va_end(args);
92
93     message = SvPV(msv,len);
94     len++;              /* include terminating null char */
95
96     /* Allocate some memory for the error message */
97     if (LastError)
98         LastError = (char*)saferealloc(LastError, len) ;
99     else
100         LastError = (char *) safemalloc(len) ;
101
102     /* Copy message into LastError (including terminating null char)    */
103     strncpy(LastError, message, len) ;
104     DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",LastError));
105 }
106