diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Attribute')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tlperl/lib/Attribute/Handlers.pm | 94 |
1 files changed, 70 insertions, 24 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Attribute/Handlers.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Attribute/Handlers.pm index f028286fb8..861ea2f8d5 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Attribute/Handlers.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Attribute/Handlers.pm @@ -4,9 +4,9 @@ use Carp; use warnings; use strict; our $AUTOLOAD; -our $VERSION = '1.01'; # remember to update version in POD! +our $VERSION = '1.03'; # remember to update version in POD! # $DB::single=1; - +my $debug= $ENV{DEBUG_ATTRIBUTE_HANDLERS} || 0; my %symcache; sub findsym { my ($pkg, $ref, $type) = @_; @@ -73,21 +73,49 @@ sub import { local $Exporter::ExportLevel = 2; $tieclass->import(eval $args); } - $attr =~ s/__CALLER__/caller(1)/e; - $attr = caller()."::".$attr unless $attr =~ /::/; - eval qq{ - sub $attr : ATTR(VAR) { - my (\$ref, \$data) = \@_[2,4]; - my \$was_arrayref = ref \$data eq 'ARRAY'; - \$data = [ \$data ] unless \$was_arrayref; - my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")"; - (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata - :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata - :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata - : die "Can't autotie a \$type\n" - } 1 - } or die "Internal error: $@"; - } + my $code = qq{ + : ATTR(VAR) { + my (\$ref, \$data) = \@_[2,4]; + my \$was_arrayref = ref \$data eq 'ARRAY'; + \$data = [ \$data ] unless \$was_arrayref; + my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")"; + (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata + :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata + :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata + : die "Can't autotie a \$type\n" + } + }; + + if ($attr =~ /\A__CALLER__::/) { + no strict 'refs'; + my $add_import = caller; + my $next = defined &{ $add_import . '::import' } && \&{ $add_import . '::import' }; + *{ $add_import . '::import' } = sub { + my $caller = caller; + my $full_attr = $attr; + $full_attr =~ s/__CALLER__/$caller/; + eval qq{ sub $full_attr $code 1; } + or die "Internal error: $@"; + + goto &$next + if $next; + my $uni = defined &UNIVERSAL::import && \&UNIVERSAL::import; + for my $isa (@{ $add_import . '::ISA' }) { + if (my $import = $isa->can('import')) { + goto &$import + if $import != $uni; + } + } + goto &$uni + if $uni; + }; + } + else { + $attr = caller()."::".$attr unless $attr =~ /::/; + eval qq{ sub $attr $code 1; } + or die "Internal error: $@"; + } + } } else { croak "Can't understand $_"; @@ -213,7 +241,8 @@ sub _apply_handler_AH_ { my ($declaration, $phase) = @_; my ($pkg, $ref, $attr, $data, $raw, $handlerphase, $filename, $linenum) = @$declaration; return unless $handlerphase->{$phase}; - # print STDERR "Handling $attr on $ref in $phase with [$data]\n"; + print STDERR "Handling $attr on $ref in $phase with [$data]\n" + if $debug; my $type = ref $ref; my $handler = "_ATTR_${type}_${attr}"; my $sym = findsym($pkg, $ref); @@ -221,12 +250,29 @@ sub _apply_handler_AH_ { no warnings; if (!$raw && defined($data)) { if ($data ne '') { - my $evaled = eval("package $pkg; no warnings; no strict; - local \$SIG{__WARN__}=sub{die}; [$data]"); - $data = $evaled unless $@; + # keeping the minimum amount of code inside the eval string + # makes debugging perl internals issues with this logic easier. + my $code= "package $pkg; my \$ref= [$data]; \$data= \$ref; 1"; + print STDERR "Evaling: '$code'\n" + if $debug; + local $SIG{__WARN__} = sub{ die }; + no strict; + no warnings; + # Note in production we do not need to use the return value from + # the eval or even consult $@ after the eval - if the evaled code + # compiles and runs successfully then it will update $data with + # the compiled form, if it fails then $data stays unchanged. The + # return value and $@ are only used for debugging purposes. + # IOW we could just replace the following with eval($code); + eval($code) or do { + print STDERR "Eval failed: $@" + if $debug; + }; } else { $data = undef } } + + # now call the handler with the $data decoded (maybe) $pkg->$handler($sym, (ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref), $attr, @@ -272,7 +318,7 @@ Attribute::Handlers - Simpler definition of attribute handlers =head1 VERSION -This document describes version 1.01 of Attribute::Handlers. +This document describes version 1.03 of Attribute::Handlers. =head1 SYNOPSIS @@ -672,13 +718,13 @@ and need to export their attributes to any module that calls them. To facilitate this, Attribute::Handlers recognizes a special "pseudo-class" -- C<__CALLER__>, which may be specified as the qualifier of an attribute: - package Tie::Me::Kangaroo:Down::Sport; + package Tie::Me::Kangaroo::Down::Sport; use Attribute::Handlers autotie => { '__CALLER__::Roo' => __PACKAGE__ }; This causes Attribute::Handlers to define the C<Roo> attribute in the package -that imports the Tie::Me::Kangaroo:Down::Sport module. +that imports the Tie::Me::Kangaroo::Down::Sport module. Note that it is important to quote the __CALLER__::Roo identifier because a bug in perl 5.8 will refuse to parse it and cause an unknown error. |