| Line | Stmts. | Exclusive
Time | Avg. |
|---|
| 1 | | | | package AutoLoader; |
| 2 | | | | |
| 3 | | | | use strict; |
| 4 | | | | use 5.006_001; |
| 5 | | | | |
| 6 | | | | our($VERSION, $AUTOLOAD); |
| 7 | | | | |
| 8 | | | | my $is_dosish; |
| 9 | | | | my $is_epoc; |
| 10 | | | | my $is_vms; |
| 11 | | | | my $is_macos; |
| 12 | | | | |
| 13 | | | | BEGIN { |
| 14 | | | | $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare'; |
| 15 | | | | $is_epoc = $^O eq 'epoc'; |
| 16 | | | | $is_vms = $^O eq 'VMS'; |
| 17 | | | | $is_macos = $^O eq 'MacOS'; |
| 18 | | | | $VERSION = '5.60'; |
| 19 | | | | } |
| 20 | | | | |
| 21 | | | | AUTOLOAD { |
| 22 | 1 | 3e-06 | 3e-06 | my $sub = $AUTOLOAD; |
| 23 | 1 | 1e-06 | 1e-06 | my $filename; |
| 24 | | | | # Braces used to preserve $1 et al. |
| 25 | | | | { |
| 26 | | | | # Try to find the autoloaded file from the package-qualified |
| 27 | | | | # name of the sub. e.g., if the sub needed is |
| 28 | | | | # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is |
| 29 | | | | # something like '/usr/lib/perl5/Getopt/Long.pm', and the |
| 30 | | | | # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'. |
| 31 | | | | # |
| 32 | | | | # However, if @INC is a relative path, this might not work. If, |
| 33 | | | | # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is |
| 34 | | | | # 'lib/Getopt/Long.pm', and we want to require |
| 35 | | | | # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib'). |
| 36 | | | | # In this case, we simple prepend the 'auto/' and let the |
| 37 | | | | # C<require> take care of the searching for us. |
| 38 | | | | |
| 39 | 2 | 0.00001 | 7e-06 | my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/); |
| 40 | 1 | 4e-06 | 4e-06 | $pkg =~ s#::#/#g; |
| 41 | 1 | 5e-06 | 5e-06 | if (defined($filename = $INC{"$pkg.pm"})) { |
| 42 | 1 | 1e-06 | 1e-06 | if ($is_macos) { |
| 43 | | | | $pkg =~ tr#/#:#; |
| 44 | | | | $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s; |
| 45 | | | | } else { |
| 46 | 1 | 0.00003 | 0.00003 | $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s; |
| 47 | | | | } |
| 48 | | | | |
| 49 | | | | # if the file exists, then make sure that it is a |
| 50 | | | | # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al', |
| 51 | | | | # or './lib/auto/foo/bar.al'. This avoids C<require> searching |
| 52 | | | | # (and failing) to find the 'lib/auto/foo/bar.al' because it |
| 53 | | | | # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib'). |
| 54 | | | | |
| 55 | 1 | 0.00002 | 0.00002 | if (-r $filename) { |
| 56 | | | | unless ($filename =~ m|^/|s) { |
| 57 | | | | if ($is_dosish) { |
| 58 | | | | unless ($filename =~ m{^([a-z]:)?[\\/]}is) { |
| 59 | | | | if ($^O ne 'NetWare') { |
| 60 | | | | $filename = "./$filename"; |
| 61 | | | | } else { |
| 62 | | | | $filename = "$filename"; |
| 63 | | | | } |
| 64 | | | | } |
| 65 | | | | } |
| 66 | | | | elsif ($is_epoc) { |
| 67 | | | | unless ($filename =~ m{^([a-z?]:)?[\\/]}is) { |
| 68 | | | | $filename = "./$filename"; |
| 69 | | | | } |
| 70 | | | | } |
| 71 | | | | elsif ($is_vms) { |
| 72 | | | | # XXX todo by VMSmiths |
| 73 | | | | $filename = "./$filename"; |
| 74 | | | | } |
| 75 | | | | elsif (!$is_macos) { |
| 76 | | | | $filename = "./$filename"; |
| 77 | | | | } |
| 78 | | | | } |
| 79 | | | | } |
| 80 | | | | else { |
| 81 | 1 | 1e-06 | 1e-06 | $filename = undef; |
| 82 | | | | } |
| 83 | | | | } |
| 84 | 1 | 1e-06 | 1e-06 | unless (defined $filename) { |
| 85 | | | | # let C<require> do the searching |
| 86 | 1 | 2e-06 | 2e-06 | $filename = "auto/$sub.al"; |
| 87 | 1 | 5e-06 | 5e-06 | $filename =~ s#::#/#g; |
| 88 | | | | } |
| 89 | | | | } |
| 90 | 1 | 0 | 0 | my $save = $@; |
| 91 | 1 | 9e-06 | 9e-06 | local $!; # Do not munge the value. |
| 92 | 3 | 0.00008 | 0.00003 | eval { local $SIG{__DIE__}; require $filename }; |
| 93 | 1 | 2e-06 | 2e-06 | if ($@) { |
| 94 | 1 | 3e-06 | 3e-06 | if (substr($sub,-9) eq '::DESTROY') { |
| 95 | | | | no strict 'refs'; |
| 96 | 2 | 6e-06 | 3e-06 | *$sub = sub {}; |
| 97 | 1 | 1e-06 | 1e-06 | $@ = undef; |
| 98 | | | | } elsif ($@ =~ /^Can't locate/) { |
| 99 | | | | # The load might just have failed because the filename was too |
| 100 | | | | # long for some old SVR3 systems which treat long names as errors. |
| 101 | | | | # If we can successfully truncate a long name then it's worth a go. |
| 102 | | | | # There is a slight risk that we could pick up the wrong file here |
| 103 | | | | # but autosplit should have warned about that when splitting. |
| 104 | | | | if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ |
| 105 | | | | eval { local $SIG{__DIE__}; require $filename }; |
| 106 | | | | } |
| 107 | | | | } |
| 108 | 1 | 1e-06 | 1e-06 | if ($@){ |
| 109 | | | | $@ =~ s/ at .*\n//; |
| 110 | | | | my $error = $@; |
| 111 | | | | require Carp; |
| 112 | | | | Carp::croak($error); |
| 113 | | | | } |
| 114 | | | | } |
| 115 | 1 | 1e-06 | 1e-06 | $@ = $save; |
| 116 | 1 | 4e-06 | 4e-06 | goto &$sub; |
| 117 | | | | } |
| 118 | | | | |
| 119 | | | | sub import { |
| 120 | | | | my $pkg = shift; |
| 121 | | | | my $callpkg = caller; |
| 122 | | | | |
| 123 | | | | # |
| 124 | | | | # Export symbols, but not by accident of inheritance. |
| 125 | | | | # |
| 126 | | | | |
| 127 | | | | if ($pkg eq 'AutoLoader') { |
| 128 | | | | no strict 'refs'; |
| 129 | | | | *{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD |
| 130 | | | | if @_ and $_[0] =~ /^&?AUTOLOAD$/; |
| 131 | | | | } |
| 132 | | | | |
| 133 | | | | # |
| 134 | | | | # Try to find the autosplit index file. Eg., if the call package |
| 135 | | | | # is POSIX, then $INC{POSIX.pm} is something like |
| 136 | | | | # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in |
| 137 | | | | # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that. |
| 138 | | | | # |
| 139 | | | | # However, if @INC is a relative path, this might not work. If, |
| 140 | | | | # for example, @INC = ('lib'), then |
| 141 | | | | # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require |
| 142 | | | | # 'auto/POSIX/autosplit.ix' (without the leading 'lib'). |
| 143 | | | | # |
| 144 | | | | |
| 145 | | | | (my $calldir = $callpkg) =~ s#::#/#g; |
| 146 | | | | my $path = $INC{$calldir . '.pm'}; |
| 147 | | | | if (defined($path)) { |
| 148 | | | | # Try absolute path name. |
| 149 | | | | if ($is_macos) { |
| 150 | | | | (my $malldir = $calldir) =~ tr#/#:#; |
| 151 | | | | $path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s; |
| 152 | | | | } else { |
| 153 | | | | $path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#; |
| 154 | | | | } |
| 155 | | | | |
| 156 | | | | eval { require $path; }; |
| 157 | | | | # If that failed, try relative path with normal @INC searching. |
| 158 | | | | if ($@) { |
| 159 | | | | $path ="auto/$calldir/autosplit.ix"; |
| 160 | | | | eval { require $path; }; |
| 161 | | | | } |
| 162 | | | | if ($@) { |
| 163 | | | | my $error = $@; |
| 164 | | | | require Carp; |
| 165 | | | | Carp::carp($error); |
| 166 | | | | } |
| 167 | | | | } |
| 168 | | | | } |
| 169 | | | | |
| 170 | | | | sub unimport { |
| 171 | | | | my $callpkg = caller; |
| 172 | | | | |
| 173 | | | | no strict 'refs'; |
| 174 | | | | my $symname = $callpkg . '::AUTOLOAD'; |
| 175 | | | | undef *{ $symname } if \&{ $symname } == \&AUTOLOAD; |
| 176 | | | | *{ $symname } = \&{ $symname }; |
| 177 | | | | } |
| 178 | | | | |
| 179 | | | | 1; |
| 180 | | | | |
| 181 | | | | __END__ |
| 182 | | | | |