Add to Attribute::Handlers the ability to report caller's file and line

number. Based on:

Subject: FW: Attribute::Handlers
From: "David Feldman" <David.Feldman@tudor.com>
Message-ID: <BA9AB162DD5CED46AC03DC5904B19C5B3736B4@tudor.com>

plus docs and tests.

p4raw-id: //depot/perl@29243

diff --git a/MANIFEST b/MANIFEST
index 502d98d..6ae4cf2 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1382,6 +1382,7 @@ lib/Attribute/Handlers/demo/MyClass.pm    Attribute::Handlers demo
 lib/Attribute/Handlers.pm      Attribute::Handlers
 lib/Attribute/Handlers/README          Attribute::Handlers
 lib/Attribute/Handlers/t/multi.t       See if Attribute::Handlers works
+lib/Attribute/Handlers/t/linerep.t     See if Attribute::Handlers works
 lib/attributes.pm              For "sub foo : attrlist"
 lib/AutoLoader.pm              Autoloader base class
 lib/AutoLoader.t               See if AutoLoader works

diff --git a/lib/Attribute/Handlers.pm b/lib/Attribute/Handlers.pm
index b1986bd..a9ce6b0 100644 (file)
--- a/lib/Attribute/Handlers.pm
+++ b/lib/Attribute/Handlers.pm
@@ -2,7 +2,7 @@ package Attribute::Handlers;
 use 5.006;
 use Carp;
 use warnings;
-$VERSION = '0.78_03';
+$VERSION = '0.78_04';
 # $DB::single=1;
 
 my %symcache;
@@ -114,6 +114,7 @@ sub _gen_handler_AH_() {
        return sub {
            _resolve_lastattr;
            my ($pkg, $ref, @attrs) = @_;
+           my (undef, $filename, $linenum) = caller 2;
            foreach (@attrs) {
                my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
                if ($attr eq 'ATTR') {
@@ -141,7 +142,7 @@ sub _gen_handler_AH_() {
                        my $handler = $pkg->can("_ATTR_${type}_${attr}");
                        next unless $handler;
                        my $decl = [$pkg, $ref, $attr, $data,
-                                   $raw{$handler}, $phase{$handler}];
+                                   $raw{$handler}, $phase{$handler}, $filename, $linenum];
                        foreach my $gphase (@global_phases) {
                            _apply_handler_AH_($decl,$gphase)
                                if $global_phases{$gphase} <= $global_phase;
@@ -172,7 +173,7 @@ push @UNIVERSAL::ISA, 'Attribute::Handlers::UNIVERSAL'
 
 sub _apply_handler_AH_ {
        my ($declaration, $phase) = @_;
-       my ($pkg, $ref, $attr, $data, $raw, $handlerphase) = @$declaration;
+       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";
        my $type = ref $ref;
@@ -190,6 +191,8 @@ sub _apply_handler_AH_ {
                       $attr,
                       (@$data>1? $data : $data->[0]),
                       $phase,
+                      $filename,
+                      $linenum,
                      );
        return 1;
 }
@@ -298,19 +301,20 @@ To create a handler, define it as a subroutine with the same name as
 the desired attribute, and declare the subroutine itself with the  
 attribute C<:ATTR>. For example:
 
-       package LoudDecl;
-       use Attribute::Handlers;
-
-       sub Loud :ATTR {
-               my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
-               print STDERR
-                       ref($referent), " ",
-                       *{$symbol}{NAME}, " ",
-                       "($referent) ", "was just declared ",
-                       "and ascribed the ${attr} attribute ",
-                       "with data ($data)\n",
-                       "in phase $phase\n";
-       }
+    package LoudDecl;
+    use Attribute::Handlers;
+
+    sub Loud :ATTR {
+       my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
+       print STDERR
+           ref($referent), " ",
+           *{$symbol}{NAME}, " ",
+           "($referent) ", "was just declared ",
+           "and ascribed the ${attr} attribute ",
+           "with data ($data)\n",
+           "in phase $phase\n",
+           "in file $filename at line $linenum\n";
+    }
 
 This creates a handler for the attribute C<:Loud> in the class LoudDecl.
 Thereafter, any subroutine declared with a C<:Loud> attribute in the class
@@ -346,7 +350,15 @@ any data associated with that attribute;
 
 =item [5]
 
-the name of the phase in which the handler is being invoked.
+the name of the phase in which the handler is being invoked;
+
+=item [6]
+
+the filename in which the handler is being invoked;
+
+=item [7]
+
+the line number in this file.
 
 =back
 

diff --git a/lib/Attribute/Handlers/t/linerep.t b/lib/Attribute/Handlers/t/linerep.t
new file mode 100644 (file)
index 0000000..9a2188b
--- /dev/null
+++ b/lib/Attribute/Handlers/t/linerep.t
@@ -0,0 +1,42 @@
+#!perl
+
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+       chdir 't' if -d 't';
+       @INC = '../lib';
+    }
+}
+
+use Test::More tests => 16;
+use Attribute::Handlers;
+
+sub Args : ATTR(CODE) {
+    my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
+    is( $package,      'main',         'package' );
+    is( $symbol,       \*foo,          'symbol' );
+    is( $referent,     \&foo,          'referent' );
+    is( $attr,         'Args',         'attr' );
+    is( $data,         'bar',          'data' );
+    is( $phase,                'CHECK',        'phase' );
+    is( $filename,     __FILE__,       'filename' );
+    is( $linenum,      25,             'linenum' );
+}
+
+sub foo :Args(bar) {}
+
+my $bar :SArgs(grumpf);
+
+sub SArgs : ATTR(SCALAR) {
+    my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
+    is( $package,      'main',         'package' );
+    is( $symbol,       'LEXICAL',      'symbol' );
+    is( $referent,     \$bar,          'referent' );
+    is( $attr,         'SArgs',        'attr' );
+    is( $data,         'grumpf',       'data' );
+    is( $phase,                'CHECK',        'phase' );
+    TODO: {
+       local $TODO = "Doesn't work correctly";
+    is( $filename,     __FILE__,       'filename' );
+    is( $linenum,      25,             'linenum' );
+    }
+}

diff --git a/lib/Attribute/Handlers/t/multi.t b/lib/Attribute/Handlers/t/multi.t
index db00b1c..a8156c2 100644 (file)
--- a/lib/Attribute/Handlers/t/multi.t
+++ b/lib/Attribute/Handlers/t/multi.t
@@ -1,3 +1,12 @@
+#!perl
+
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+       chdir 't' if -d 't';
+       @INC = '../lib';
+    }
+}
+
 END {print "not ok 1\n" unless $loaded;}
 use v5.6.0;
 use Attribute::Handlers;