Don’t let XSLoader load relative paths
[perl.git] / dist / XSLoader / XSLoader_pm.PL
1 use strict;
2 use Config;
3 # We require DynaLoader to make sure that mod2fname is loaded
4 eval { require DynaLoader };
5
6 1 while unlink "XSLoader.pm";
7 open OUT, ">XSLoader.pm" or die $!;
8 print OUT <<'EOT';
9 # Generated from XSLoader.pm.PL (resolved %Config::Config value)
10 # This file is unique for every OS
11
12 package XSLoader;
13
14 $VERSION = "0.21";
15
16 #use strict;
17
18 package DynaLoader;
19
20 EOT
21
22 # dlutils.c before 5.006 has this:
23 #
24 #    #ifdef DEBUGGING
25 #        dl_debug = SvIV( perl_get_sv("DynaLoader::dl_debug", 0x04) );
26 #    #endif
27 #
28 # where 0x04 is GV_ADDWARN, which causes a warning to be issued by the call
29 # into XS below, if DynaLoader.pm hasn't been loaded.
30 # It was changed to 0 in the commit(s) that added XSLoader to the core
31 # (9cf41c4d23a47c8b and its parent 9426adcd48655815)
32 # Hence to backport XSLoader to work silently with earlier DynaLoaders we need
33 # to ensure that the variable exists:
34
35 print OUT <<'EOT' if $] < 5.006;
36
37 # enable debug/trace messages from DynaLoader perl code
38 $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
39
40 EOT
41
42 print OUT <<'EOT';
43 # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
44 # NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
45 boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
46                                 !defined(&dl_error);
47 package XSLoader;
48
49 sub load {
50     package DynaLoader;
51
52     my ($caller, $modlibname) = caller();
53     my $module = $caller;
54
55     if (@_) {
56         $module = $_[0];
57     } else {
58         $_[0] = $module;
59     }
60
61     # work with static linking too
62     my $boots = "$module\::bootstrap";
63     goto &$boots if defined &$boots;
64
65     goto \&XSLoader::bootstrap_inherit unless $module and defined &dl_load_file;
66
67     my @modparts = split(/::/,$module);
68     my $modfname = $modparts[-1];
69
70 EOT
71
72 # defined &DynaLoader::mod2fname catches most cases, except when
73 # cross-compiling to a system that defines mod2fname. Using 
74 # $Config{d_libname_unique} is a best attempt at catching those cases.
75 print OUT <<'EOT' if defined &DynaLoader::mod2fname || $Config{d_libname_unique};
76     # Some systems have restrictions on files names for DLL's etc.
77     # mod2fname returns appropriate file base name (typically truncated)
78     # It may also edit @modparts if required.
79     $modfname = &DynaLoader::mod2fname(\@modparts) if defined &DynaLoader::mod2fname;
80
81 EOT
82
83 print OUT <<'EOT' if $^O eq 'os2';
84
85     # os2 static build can dynaload, but cannot dynaload Perl modules...
86     die 'Dynaloaded Perl modules are not available in this build of Perl' if $OS2::is_static;
87
88 EOT
89
90 print OUT <<'EOT';
91     my $modpname = join('/',@modparts);
92     my $c = () = split(/::/,$caller,-1);
93     $modlibname =~ s,[\\/][^\\/]+$,, while $c--;    # Q&D basename
94     # Does this look like a relative path?
95     if ($modlibname !~ m|^[\\/]|) {
96         # Someone may have a #line directive that changes the file name, or
97         # may be calling XSLoader::load from inside a string eval.  We cer-
98         # tainly do not want to go loading some code that is not in @INC,
99         # as it could be untrusted.
100         #
101         # We could just fall back to DynaLoader here, but then the rest of
102         # this function would go untested in the perl core, since all @INC
103         # paths are relative during testing.  That would be a time bomb
104         # waiting to happen, since bugs could be introduced into the code.
105         #
106         # So look through @INC to see if $modlibname is in it.  A rela-
107         # tive $modlibname is not a common occurrence, so this block is
108         # not hot code.
109         FOUND: {
110             for (@INC) {
111                 if ($_ eq $modlibname) {
112                     last FOUND;
113                 }
114             }
115             # Not found.  Fall back to DynaLoader.
116             goto \&XSLoader::bootstrap_inherit;
117         }
118     }
119 EOT
120
121 my $dl_dlext = quotemeta($Config::Config{'dlext'});
122
123 print OUT <<"EOT";
124     my \$file = "\$modlibname/auto/\$modpname/\$modfname.$dl_dlext";
125 EOT
126
127 print OUT <<'EOT';
128
129 #   print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug;
130
131     my $bs = $file;
132     $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
133
134     if (-s $bs) { # only read file if it's not empty
135 #       print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
136         eval { do $bs; };
137         warn "$bs: $@\n" if $@;
138         goto \&XSLoader::bootstrap_inherit;
139     }
140
141     goto \&XSLoader::bootstrap_inherit if not -f $file;
142
143     my $bootname = "boot_$module";
144     $bootname =~ s/\W/_/g;
145     @DynaLoader::dl_require_symbols = ($bootname);
146
147     my $boot_symbol_ref;
148
149 EOT
150
151     if ($^O eq 'darwin') {
152       my $extra_arg = ', 1 ' if $DynaLoader::VERSION ge '1.37';
153 print OUT <<"EOT";
154     if (\$boot_symbol_ref = dl_find_symbol( 0, \$bootname $extra_arg)) {
155         goto boot; #extension library has already been loaded, e.g. darwin
156     }
157 EOT
158     }
159
160 print OUT <<'EOT';
161     # Many dynamic extension loading problems will appear to come from
162     # this section of code: XYZ failed at line 123 of DynaLoader.pm.
163     # Often these errors are actually occurring in the initialisation
164     # C code of the extension XS file. Perl reports the error as being
165     # in this perl code simply because this was the last perl code
166     # it executed.
167
168     my $libref = dl_load_file($file, 0) or do { 
169         require Carp;
170         Carp::croak("Can't load '$file' for module $module: " . dl_error());
171     };
172     push(@DynaLoader::dl_librefs,$libref);  # record loaded object
173
174 EOT
175 my $dlsrc = $Config{dlsrc};
176 if ($dlsrc eq 'dl_freemint.xs' || $dlsrc eq 'dl_dld.xs') {
177     print OUT <<'EOT';
178     my @unresolved = dl_undef_symbols();
179     if (@unresolved) {
180         require Carp;
181         Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
182     }
183
184 EOT
185 }
186
187 print OUT <<'EOT';
188     $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do {
189         require Carp;
190         Carp::croak("Can't find '$bootname' symbol in $file\n");
191     };
192
193     push(@DynaLoader::dl_modules, $module); # record loaded module
194
195   boot:
196     my $xs = dl_install_xsub($boots, $boot_symbol_ref, $file);
197
198     # See comment block above
199     push(@DynaLoader::dl_shared_objects, $file); # record files loaded
200     return &$xs(@_);
201 }
202 EOT
203
204 # Can't test with DynaLoader->can('bootstrap_inherit') when building in the
205 # core, as XSLoader gets built before DynaLoader.
206
207 if ($] >= 5.006) {
208     print OUT <<'EOT';
209
210 sub bootstrap_inherit {
211     require DynaLoader;
212     goto \&DynaLoader::bootstrap_inherit;
213 }
214
215 EOT
216 } else {
217     print OUT <<'EOT';
218
219 sub bootstrap_inherit {
220     # Versions of DynaLoader prior to 5.6.0 don't have bootstrap_inherit.
221     package DynaLoader;
222
223     my $module = $_[0];
224     local *DynaLoader::isa = *{"$module\::ISA"};
225     local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader');
226     # Cannot goto due to delocalization.  Will report errors on a wrong line?
227     require DynaLoader;
228     DynaLoader::bootstrap(@_);
229 }
230
231 EOT
232 }
233
234 print OUT <<'EOT';
235 1;
236
237
238 __END__
239
240 =head1 NAME
241
242 XSLoader - Dynamically load C libraries into Perl code
243
244 =head1 VERSION
245
246 Version 0.17
247
248 =head1 SYNOPSIS
249
250     package YourPackage;
251     require XSLoader;
252
253     XSLoader::load();
254
255 =head1 DESCRIPTION
256
257 This module defines a standard I<simplified> interface to the dynamic
258 linking mechanisms available on many platforms.  Its primary purpose is
259 to implement cheap automatic dynamic loading of Perl modules.
260
261 For a more complicated interface, see L<DynaLoader>.  Many (most)
262 features of C<DynaLoader> are not implemented in C<XSLoader>, like for
263 example the C<dl_load_flags>, not honored by C<XSLoader>.
264
265 =head2 Migration from C<DynaLoader>
266
267 A typical module using L<DynaLoader|DynaLoader> starts like this:
268
269     package YourPackage;
270     require DynaLoader;
271
272     our @ISA = qw( OnePackage OtherPackage DynaLoader );
273     our $VERSION = '0.01';
274     bootstrap YourPackage $VERSION;
275
276 Change this to
277
278     package YourPackage;
279     use XSLoader;
280
281     our @ISA = qw( OnePackage OtherPackage );
282     our $VERSION = '0.01';
283     XSLoader::load 'YourPackage', $VERSION;
284
285 In other words: replace C<require DynaLoader> by C<use XSLoader>, remove
286 C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>.  Do not
287 forget to quote the name of your package on the C<XSLoader::load> line,
288 and add comma (C<,>) before the arguments (C<$VERSION> above).
289
290 Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have
291 the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the
292 more backward-compatible
293
294     use vars qw($VERSION @ISA);
295
296 one can remove this reference to C<@ISA> together with the C<@ISA> assignment.
297
298 If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes
299
300     XSLoader::load 'YourPackage';
301
302 If the call to C<load> is from C<YourPackage>, then that can be further
303 simplified to
304
305     XSLoader::load();
306
307 as C<load> will use C<caller> to determine the package.
308
309 =head2 Backward compatible boilerplate
310
311 If you want to have your cake and eat it too, you need a more complicated
312 boilerplate.
313
314     package YourPackage;
315     use vars qw($VERSION @ISA);
316
317     @ISA = qw( OnePackage OtherPackage );
318     $VERSION = '0.01';
319     eval {
320        require XSLoader;
321        XSLoader::load('YourPackage', $VERSION);
322        1;
323     } or do {
324        require DynaLoader;
325        push @ISA, 'DynaLoader';
326        bootstrap YourPackage $VERSION;
327     };
328
329 The parentheses about C<XSLoader::load()> arguments are needed since we replaced
330 C<use XSLoader> by C<require>, so the compiler does not know that a function
331 C<XSLoader::load()> is present.
332
333 This boilerplate uses the low-overhead C<XSLoader> if present; if used with
334 an antique Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>.
335
336 =head1 Order of initialization: early load()
337
338 I<Skip this section if the XSUB functions are supposed to be called from other
339 modules only; read it only if you call your XSUBs from the code in your module,
340 or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">).
341 What is described here is equally applicable to the L<DynaLoader|DynaLoader>
342 interface.>
343
344 A sufficiently complicated module using XS would have both Perl code (defined
345 in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>).  If this
346 Perl code makes calls into this XS code, and/or this XS code makes calls to
347 the Perl code, one should be careful with the order of initialization.
348
349 The call to C<XSLoader::load()> (or C<bootstrap()>) calls the module's
350 bootstrap code. For modules build by F<xsubpp> (nearly all modules) this
351 has three side effects:
352
353 =over
354
355 =item *
356
357 A sanity check is done to ensure that the versions of the F<.pm> and the
358 (compiled) F<.xs> parts are compatible. If C<$VERSION> was specified, this
359 is used for the check. If not specified, it defaults to
360 C<$XS_VERSION // $VERSION> (in the module's namespace)
361
362 =item *
363
364 the XSUBs are made accessible from Perl
365
366 =item *
367
368 if a C<BOOT:> section was present in the F<.xs> file, the code there is called.
369
370 =back
371
372 Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is
373 convenient to have XSUBs installed before the Perl code is defined; for
374 example, this makes prototypes for XSUBs visible to this Perl code.
375 Alternatively, if the C<BOOT:> section makes calls to Perl functions (or
376 uses Perl variables) defined in the F<.pm> file, they must be defined prior to
377 the call to C<XSLoader::load()> (or C<bootstrap()>).
378
379 The first situation being much more frequent, it makes sense to rewrite the
380 boilerplate as
381
382     package YourPackage;
383     use XSLoader;
384     use vars qw($VERSION @ISA);
385
386     BEGIN {
387        @ISA = qw( OnePackage OtherPackage );
388        $VERSION = '0.01';
389
390        # Put Perl code used in the BOOT: section here
391
392        XSLoader::load 'YourPackage', $VERSION;
393     }
394
395     # Put Perl code making calls into XSUBs here
396
397 =head2 The most hairy case
398
399 If the interdependence of your C<BOOT:> section and Perl code is
400 more complicated than this (e.g., the C<BOOT:> section makes calls to Perl
401 functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:>
402 section altogether.  Replace it with a function C<onBOOT()>, and call it like
403 this:
404
405     package YourPackage;
406     use XSLoader;
407     use vars qw($VERSION @ISA);
408
409     BEGIN {
410        @ISA = qw( OnePackage OtherPackage );
411        $VERSION = '0.01';
412        XSLoader::load 'YourPackage', $VERSION;
413     }
414
415     # Put Perl code used in onBOOT() function here; calls to XSUBs are
416     # prototype-checked.
417
418     onBOOT;
419
420     # Put Perl initialization code assuming that XS is initialized here
421
422
423 =head1 DIAGNOSTICS
424
425 =over
426
427 =item C<Can't find '%s' symbol in %s>
428
429 B<(F)> The bootstrap symbol could not be found in the extension module.
430
431 =item C<Can't load '%s' for module %s: %s>
432
433 B<(F)> The loading or initialisation of the extension module failed.
434 The detailed error follows.
435
436 =item C<Undefined symbols present after loading %s: %s>
437
438 B<(W)> As the message says, some symbols stay undefined although the
439 extension module was correctly loaded and initialised. The list of undefined
440 symbols follows.
441
442 =back
443
444 =head1 LIMITATIONS
445
446 To reduce the overhead as much as possible, only one possible location
447 is checked to find the extension DLL (this location is where C<make install>
448 would put the DLL).  If not found, the search for the DLL is transparently
449 delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list.
450
451 In particular, this is applicable to the structure of C<@INC> used for testing
452 not-yet-installed extensions.  This means that running uninstalled extensions
453 may have much more overhead than running the same extensions after
454 C<make install>.
455
456
457 =head1 KNOWN BUGS
458
459 The new simpler way to call C<XSLoader::load()> with no arguments at all
460 does not work on Perl 5.8.4 and 5.8.5.
461
462
463 =head1 BUGS
464
465 Please report any bugs or feature requests via the perlbug(1) utility.
466
467
468 =head1 SEE ALSO
469
470 L<DynaLoader>
471
472
473 =head1 AUTHORS
474
475 Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>.
476
477 CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni
478 E<lt>sebastien@aperghis.netE<gt>.
479
480 Previous maintainer was Michael G Schwern <schwern@pobox.com>.
481
482
483 =head1 COPYRIGHT & LICENSE
484
485 Copyright (C) 1990-2011 by Larry Wall and others.
486
487 This program is free software; you can redistribute it and/or modify
488 it under the same terms as Perl itself.
489
490 =cut
491 EOT
492
493 close OUT or die $!;