4 # We go to a lot of trouble not to 'require Carp' at file scope,
5 # because Carp requires Exporter, and something has to give.
10 # First make import warnings look like they're coming from the "use".
11 local $SIG{__WARN__} = sub {
13 if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
15 local $Carp::CarpLevel = 1; # ignore package calling us too.
22 local $SIG{__DIE__} = sub {
24 local $Carp::CarpLevel = 1; # ignore package calling us too.
25 Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
26 if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
29 my($pkg, $callpkg, @imports) = @_;
30 my($type, $sym, $oops);
31 *exports = *{"${pkg}::EXPORT"};
35 grep(s/^&//, @exports);
36 @exports{@exports} = (1) x @exports;
37 my $ok = \@{"${pkg}::EXPORT_OK"};
40 @exports{@$ok} = (1) x @$ok;
44 if ($imports[0] =~ m#^[/!:]#){
45 my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
48 my($remove, $spec, @names, @allexports);
49 # negated first item implies starting with default set:
50 unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
51 foreach $spec (@imports){
52 $remove = $spec =~ s/^!//;
55 if ($spec eq 'DEFAULT'){
58 elsif ($tagdata = $tagsref->{$spec}) {
62 warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
67 elsif ($spec =~ m:^/(.*)/$:){
69 @allexports = keys %exports unless @allexports; # only do keys once
70 @names = grep(/$patn/, @allexports); # not anchored by default
73 @names = ($spec); # is a normal symbol name
76 warn "Import ".($remove ? "del":"add").": @names "
80 foreach $sym (@names) { delete $imports{$sym} }
83 @imports{@names} = (1) x @names;
86 @imports = keys %imports;
89 foreach $sym (@imports) {
90 if (!$exports{$sym}) {
92 $pkg->require_version($sym);
93 # If the version number was the only thing specified
94 # then we should act as if nothing was specified:
99 # We need a way to emulate 'use Foo ()' but still
100 # allow an easy version check: "use Foo 1.23, ''";
101 if (@imports == 2 and !$imports[1]) {
105 } elsif ($sym !~ s/^&// || !$exports{$sym}) {
107 Carp::carp(qq["$sym" is not exported by the $pkg module]);
114 Carp::croak("Can't continue after import errors");
121 *fail = *{"${pkg}::EXPORT_FAIL"};
124 # Build cache of symbols. Optimise the lookup by adding
125 # barewords twice... both with and without a leading &.
126 # (Technique could be applied to %exports cache at cost of memory)
127 my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail;
128 warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose;
129 @fail{@expanded} = (1) x @expanded;
132 foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} }
134 @failed = $pkg->export_fail(@failed);
135 foreach $sym (@failed) {
137 Carp::carp(qq["$sym" is not implemented by the $pkg module ],
138 "on this architecture");
142 Carp::croak("Can't continue after import errors");
147 warn "Importing into $callpkg from $pkg: ",
148 join(", ",sort @imports) if $Verbose;
150 foreach $sym (@imports) {
151 # shortcut for the common case of no type character
152 (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
153 unless $sym =~ s/^(\W)//;
155 *{"${callpkg}::$sym"} =
156 $type eq '&' ? \&{"${pkg}::$sym"} :
157 $type eq '$' ? \${"${pkg}::$sym"} :
158 $type eq '@' ? \@{"${pkg}::$sym"} :
159 $type eq '%' ? \%{"${pkg}::$sym"} :
160 $type eq '*' ? *{"${pkg}::$sym"} :
161 do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
165 sub heavy_export_to_level
169 my $callpkg = caller($level);
170 $pkg->export($callpkg, @_);
176 my($pkg, $var, $syms) = @_;
178 *export_tags = \%{"${pkg}::EXPORT_TAGS"};
179 push(@{"${pkg}::$var"},
180 map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) }
181 (@$syms) ? @$syms : keys %export_tags);
182 if ($nontag and $^W) {
183 # This may change to a die one day
185 Carp::carp("Some names are not tags");
196 sub require_version {
197 my($self, $wanted) = @_;
198 my $pkg = ref $self || $self;
199 my $version = ${"${pkg}::VERSION"};
200 if (!$version or $version < $wanted) {
201 $version ||= "(undef)";
202 my $file = $INC{"$pkg.pm"};
203 $file &&= " ($file)";
205 Carp::croak("$pkg $wanted required--this is only version $version$file")