[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package Exporter::Heavy; 2 3 use strict; 4 no strict 'refs'; 5 6 # On one line so MakeMaker will see it. 7 require Exporter; our $VERSION = $Exporter::VERSION; 8 # Carp does this now for us, so we can finally live w/o Carp 9 #$Carp::Internal{"Exporter::Heavy"} = 1; 10 11 =head1 NAME 12 13 Exporter::Heavy - Exporter guts 14 15 =head1 SYNOPSIS 16 17 (internal use only) 18 19 =head1 DESCRIPTION 20 21 No user-serviceable parts inside. 22 23 =cut 24 25 # 26 # We go to a lot of trouble not to 'require Carp' at file scope, 27 # because Carp requires Exporter, and something has to give. 28 # 29 30 sub _rebuild_cache { 31 my ($pkg, $exports, $cache) = @_; 32 s/^&// foreach @$exports; 33 @{$cache}{@$exports} = (1) x @$exports; 34 my $ok = \@{"$pkg}::EXPORT_OK"}; 35 if (@$ok) { 36 s/^&// foreach @$ok; 37 @{$cache}{@$ok} = (1) x @$ok; 38 } 39 } 40 41 sub heavy_export { 42 43 # First make import warnings look like they're coming from the "use". 44 local $SIG{__WARN__} = sub { 45 my $text = shift; 46 if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) { 47 require Carp; 48 local $Carp::CarpLevel = 1; # ignore package calling us too. 49 Carp::carp($text); 50 } 51 else { 52 warn $text; 53 } 54 }; 55 local $SIG{__DIE__} = sub { 56 require Carp; 57 local $Carp::CarpLevel = 1; # ignore package calling us too. 58 Carp::croak("$_[0]Illegal null symbol in \@$1}::EXPORT") 59 if $_[0] =~ /^Unable to create sub named "(.*?)::"/; 60 }; 61 62 my($pkg, $callpkg, @imports) = @_; 63 my($type, $sym, $cache_is_current, $oops); 64 my($exports, $export_cache) = (\@{"$pkg}::EXPORT"}, 65 $Exporter::Cache{$pkg} ||= {}); 66 67 if (@imports) { 68 if (!%$export_cache) { 69 _rebuild_cache ($pkg, $exports, $export_cache); 70 $cache_is_current = 1; 71 } 72 73 if (grep m{^[/!:]}, @imports) { 74 my $tagsref = \%{"$pkg}::EXPORT_TAGS"}; 75 my $tagdata; 76 my %imports; 77 my($remove, $spec, @names, @allexports); 78 # negated first item implies starting with default set: 79 unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/; 80 foreach $spec (@imports){ 81 $remove = $spec =~ s/^!//; 82 83 if ($spec =~ s/^://){ 84 if ($spec eq 'DEFAULT'){ 85 @names = @$exports; 86 } 87 elsif ($tagdata = $tagsref->{$spec}) { 88 @names = @$tagdata; 89 } 90 else { 91 warn qq["$spec" is not defined in %$pkg}::EXPORT_TAGS]; 92 ++$oops; 93 next; 94 } 95 } 96 elsif ($spec =~ m:^/(.*)/$:){ 97 my $patn = $1; 98 @allexports = keys %$export_cache unless @allexports; # only do keys once 99 @names = grep(/$patn/, @allexports); # not anchored by default 100 } 101 else { 102 @names = ($spec); # is a normal symbol name 103 } 104 105 warn "Import ".($remove ? "del":"add").": @names " 106 if $Exporter::Verbose; 107 108 if ($remove) { 109 foreach $sym (@names) { delete $imports{$sym} } 110 } 111 else { 112 @imports{@names} = (1) x @names; 113 } 114 } 115 @imports = keys %imports; 116 } 117 118 my @carp; 119 foreach $sym (@imports) { 120 if (!$export_cache->{$sym}) { 121 if ($sym =~ m/^\d/) { 122 $pkg->VERSION($sym); # inherit from UNIVERSAL 123 # If the version number was the only thing specified 124 # then we should act as if nothing was specified: 125 if (@imports == 1) { 126 @imports = @$exports; 127 last; 128 } 129 # We need a way to emulate 'use Foo ()' but still 130 # allow an easy version check: "use Foo 1.23, ''"; 131 if (@imports == 2 and !$imports[1]) { 132 @imports = (); 133 last; 134 } 135 } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) { 136 # Last chance - see if they've updated EXPORT_OK since we 137 # cached it. 138 139 unless ($cache_is_current) { 140 %$export_cache = (); 141 _rebuild_cache ($pkg, $exports, $export_cache); 142 $cache_is_current = 1; 143 } 144 145 if (!$export_cache->{$sym}) { 146 # accumulate the non-exports 147 push @carp, 148 qq["$sym" is not exported by the $pkg module\n]; 149 $oops++; 150 } 151 } 152 } 153 } 154 if ($oops) { 155 require Carp; 156 Carp::croak("@{carp}Can't continue after import errors"); 157 } 158 } 159 else { 160 @imports = @$exports; 161 } 162 163 my($fail, $fail_cache) = (\@{"$pkg}::EXPORT_FAIL"}, 164 $Exporter::FailCache{$pkg} ||= {}); 165 166 if (@$fail) { 167 if (!%$fail_cache) { 168 # Build cache of symbols. Optimise the lookup by adding 169 # barewords twice... both with and without a leading &. 170 # (Technique could be applied to $export_cache at cost of memory) 171 my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail; 172 warn "$pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose; 173 @{$fail_cache}{@expanded} = (1) x @expanded; 174 } 175 my @failed; 176 foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} } 177 if (@failed) { 178 @failed = $pkg->export_fail(@failed); 179 foreach $sym (@failed) { 180 require Carp; 181 Carp::carp(qq["$sym" is not implemented by the $pkg module ], 182 "on this architecture"); 183 } 184 if (@failed) { 185 require Carp; 186 Carp::croak("Can't continue after import errors"); 187 } 188 } 189 } 190 191 warn "Importing into $callpkg from $pkg: ", 192 join(", ",sort @imports) if $Exporter::Verbose; 193 194 foreach $sym (@imports) { 195 # shortcut for the common case of no type character 196 (*{"$callpkg}::$sym"} = \&{"$pkg}::$sym"}, next) 197 unless $sym =~ s/^(\W)//; 198 $type = $1; 199 no warnings 'once'; 200 *{"$callpkg}::$sym"} = 201 $type eq '&' ? \&{"$pkg}::$sym"} : 202 $type eq '$' ? \${"$pkg}::$sym"} : 203 $type eq '@' ? \@{"$pkg}::$sym"} : 204 $type eq '%' ? \%{"$pkg}::$sym"} : 205 $type eq '*' ? *{"$pkg}::$sym"} : 206 do { require Carp; Carp::croak("Can't export symbol: $type$sym") }; 207 } 208 } 209 210 sub heavy_export_to_level 211 { 212 my $pkg = shift; 213 my $level = shift; 214 (undef) = shift; # XXX redundant arg 215 my $callpkg = caller($level); 216 $pkg->export($callpkg, @_); 217 } 218 219 # Utility functions 220 221 sub _push_tags { 222 my($pkg, $var, $syms) = @_; 223 my @nontag = (); 224 my $export_tags = \%{"$pkg}::EXPORT_TAGS"}; 225 push(@{"$pkg}::$var"}, 226 map { $export_tags->{$_} ? @{$export_tags->{$_}} 227 : scalar(push(@nontag,$_),$_) } 228 (@$syms) ? @$syms : keys %$export_tags); 229 if (@nontag and $^W) { 230 # This may change to a die one day 231 require Carp; 232 Carp::carp(join(", ", @nontag)." are not tags of $pkg"); 233 } 234 } 235 236 sub heavy_require_version { 237 my($self, $wanted) = @_; 238 my $pkg = ref $self || $self; 239 return $pkg}->VERSION($wanted); 240 } 241 242 sub heavy_export_tags { 243 _push_tags((caller)[0], "EXPORT", \@_); 244 } 245 246 sub heavy_export_ok_tags { 247 _push_tags((caller)[0], "EXPORT_OK", \@_); 248 } 249 250 1;
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |