summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/Attribute/Handlers.pm
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Attribute/Handlers.pm')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Attribute/Handlers.pm94
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.