fix __CALLER__ handling in Attribute::Handlers

Attribute::Handlers supports a __CALLER__ token when declaring autotie
attributes. This is meant to create the attribute in the caller of the
class it is used in. The only reliable way for this to work requires
creating an import method in the calling class. Instead,
Attribute::Handlers was trying to walk up the call stack from when its
own import would be called. This used to partially work, at least enough
to be deceptive. Checking the caller deeper in the call stack of
Attribute::Handlers would allow the __CALLER__ attribute to work only
for the first time the module using it was called. Any future users
would not re-compile the module, so they would not re-invoke
Attribute::Handlers' import method, and would not get the autotie
attribute defined.

This attempt to find the caller's caller also started failing as of
f6387cff9cb31db4cf18c8641917ea4639ac2b65.

Fix the handling of __CALLER__ by creating an import method in the
caller if it is used, so that users of the calling module will reliably
get the attribute defined.

2 files changed, 71 insertions, 17 deletions

diff --git a/dist/Attribute-Handlers/lib/Attribute/Handlers.pm b/dist/Attribute-Handlers/lib/Attribute/Handlers.pm
index f028286fb8..6df8a02a66 100644
--- a/dist/Attribute-Handlers/lib/Attribute/Handlers.pm
+++ b/dist/Attribute-Handlers/lib/Attribute/Handlers.pm
@@ -4,7 +4,7 @@ use Carp;
 use warnings;
 use strict;
 our $AUTOLOAD;
-our $VERSION = '1.01'; # remember to update version in POD!
+our $VERSION = '1.02'; # remember to update version in POD!
 # $DB::single=1;
 
 my %symcache;
@@ -73,21 +73,36 @@ 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';
+                    *{ caller . '::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: $@";
+
+                    };
+                }
+                else {
+                    $attr = caller()."::".$attr unless $attr =~ /::/;
+                    eval qq{ sub $attr $code 1; }
+                      or die "Internal error: $@";
+                }
+            }
         }
         else {
             croak "Can't understand $_"; 
@@ -272,7 +287,7 @@ Attribute::Handlers - Simpler definition of attribute handlers
 
 =head1 VERSION
 
-This document describes version 1.01 of Attribute::Handlers.
+This document describes version 1.02 of Attribute::Handlers.
 
 =head1 SYNOPSIS
 
diff --git a/dist/Attribute-Handlers/t/caller.t b/dist/Attribute-Handlers/t/caller.t
new file mode 100644
index 0000000000..e06d4c5d73
--- /dev/null
+++ b/dist/Attribute-Handlers/t/caller.t
@@ -0,0 +1,39 @@
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+BEGIN {
+    package MyTie;
+    BEGIN { $INC{'MyTie.pm'} = 1 }
+
+    use Attribute::Handlers autotie => { '__CALLER__::Mine' => __PACKAGE__ };
+
+    sub TIESCALAR {
+        my ($class, $data) = @_;
+        bless \$data, $class;
+    }
+
+    sub FETCH { ${$_[0]} }
+    sub STORE { ${$_[0]} = $_[1] }
+}
+
+use MyTie;
+
+eval q{
+    my $var :Mine;
+    1;
+};
+::is $@, '',
+    'attribute available in caller';
+
+{
+    package Pack2;
+    use MyTie;
+
+    eval q{
+        my $var :Mine;
+        1;
+    };
+    ::is $@, '',
+        'attribute available in caller of second package';
+}