File Coverage

blib/arch/XSLoader.pm
Criterion Covered Total %
statement 0 45 0.0
branch 0 20 0.0
condition 0 3 0.0
subroutine 0 2 0.0
pod 1 2 50.0
total 1 72 1.3


line stmt bran cond sub pod time code
1             # Generated from XSLoader.pm.PL (resolved %Config::Config value)
2             # This file is unique for every OS
3              
4             package XSLoader;
5              
6             $VERSION = "0.22";
7              
8             #use strict;
9              
10             package DynaLoader;
11              
12             # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
13             # NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
14             boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
15             !defined(&dl_error);
16             package XSLoader;
17              
18             sub load {
19             package DynaLoader;
20              
21 0     0 1   my ($caller, $modlibname) = caller();
22 0           my $module = $caller;
23              
24 0 0         if (@_) {
25 0           $module = $_[0];
26             } else {
27 0           $_[0] = $module;
28             }
29              
30             # work with static linking too
31 0           my $boots = "$module\::bootstrap";
32 0 0         goto &$boots if defined &$boots;
33              
34 0 0 0       goto \&XSLoader::bootstrap_inherit unless $module and defined &dl_load_file;
35              
36 0           my @modparts = split(/::/,$module);
37 0           my $modfname = $modparts[-1];
38              
39 0           my $modpname = join('/',@modparts);
40 0           my $c = () = split(/::/,$caller,-1);
41 0           $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
42             # Does this look like a relative path?
43 0 0         if ($modlibname !~ m{^/}) {
44             # Someone may have a #line directive that changes the file name, or
45             # may be calling XSLoader::load from inside a string eval. We cer-
46             # tainly do not want to go loading some code that is not in @INC,
47             # as it could be untrusted.
48             #
49             # We could just fall back to DynaLoader here, but then the rest of
50             # this function would go untested in the perl core, since all @INC
51             # paths are relative during testing. That would be a time bomb
52             # waiting to happen, since bugs could be introduced into the code.
53             #
54             # So look through @INC to see if $modlibname is in it. A rela-
55             # tive $modlibname is not a common occurrence, so this block is
56             # not hot code.
57             FOUND: {
58 0           for (@INC) {
  0            
59 0 0         if ($_ eq $modlibname) {
60 0           last FOUND;
61             }
62             }
63             # Not found. Fall back to DynaLoader.
64 0           goto \&XSLoader::bootstrap_inherit;
65             }
66             }
67 0           my $file = "$modlibname/auto/$modpname/$modfname.so";
68              
69             # print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug;
70              
71 0           my $bs = $file;
72 0           $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
73              
74 0 0         if (-s $bs) { # only read file if it's not empty
75             # print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
76 0           eval { do $bs; };
  0            
77 0 0         warn "$bs: $@\n" if $@;
78 0           goto \&XSLoader::bootstrap_inherit;
79             }
80              
81 0 0         goto \&XSLoader::bootstrap_inherit if not -f $file;
82              
83 0           my $bootname = "boot_$module";
84 0           $bootname =~ s/\W/_/g;
85 0           @DynaLoader::dl_require_symbols = ($bootname);
86              
87 0           my $boot_symbol_ref;
88              
89             # Many dynamic extension loading problems will appear to come from
90             # this section of code: XYZ failed at line 123 of DynaLoader.pm.
91             # Often these errors are actually occurring in the initialisation
92             # C code of the extension XS file. Perl reports the error as being
93             # in this perl code simply because this was the last perl code
94             # it executed.
95              
96 0 0         my $libref = dl_load_file($file, 0) or do {
97 0           require Carp;
98 0           Carp::croak("Can't load '$file' for module $module: " . dl_error());
99             };
100 0           push(@DynaLoader::dl_librefs,$libref); # record loaded object
101              
102 0 0         $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do {
103 0           require Carp;
104 0           Carp::croak("Can't find '$bootname' symbol in $file\n");
105             };
106              
107 0           push(@DynaLoader::dl_modules, $module); # record loaded module
108              
109 0           boot:
110             my $xs = dl_install_xsub($boots, $boot_symbol_ref, $file);
111              
112             # See comment block above
113 0           push(@DynaLoader::dl_shared_objects, $file); # record files loaded
114 0           return &$xs(@_);
115             }
116              
117             sub bootstrap_inherit {
118 0     0 0   require DynaLoader;
119 0           goto \&DynaLoader::bootstrap_inherit;
120             }
121              
122             1;
123              
124              
125             __END__