Damian-o-rama: upgrade to Attribute::Handlers 0.75,

Filter::Simple 0.61, NEXT 0.02, Switch 2.05, and
Text::Balanced 1.86.

p4raw-id: //depot/perl@11842

6 files changed, 228 insertions, 35 deletions

diff --git a/lib/Attribute/Handlers.pm b/lib/Attribute/Handlers.pm
index b71a36da75..dbd1bf41c7 100644
--- a/lib/Attribute/Handlers.pm
+++ b/lib/Attribute/Handlers.pm
@@ -2,8 +2,8 @@ package Attribute::Handlers;
 use 5.006;
 use Carp;
 use warnings;
-$VERSION = '0.70';
-$DB::single=1;
+$VERSION = '0.75';
+# $DB::single=1;
 
 my %symcache;
 sub findsym {
@@ -36,19 +36,23 @@ sub _usage_AH_ {
 	croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
 }
 
+my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
+
 sub import {
     my $class = shift @_;
     return unless $class eq "Attribute::Handlers";
     while (@_) {
 	my $cmd = shift;
-        if ($cmd eq 'autotie') {
+        if ($cmd =~ /^autotie((?:ref)?)$/) {
+	    my $tiedata = '($was_arrayref ? $data : @$data)';
+	       $tiedata = ($1 ? '$ref, ' : '') . $tiedata;
             my $mapping = shift;
 	    _usage_AH_ $class unless ref($mapping) eq 'HASH';
 	    while (my($attr, $tieclass) = each %$mapping) {
-		$tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*))(.*)/$1/is;
+                $tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
 		my $args = $3||'()';
-		usage $class unless $attr =~ m/^[_a-z]\w*(::[_a-z]\w*)*$/i
-		                 && $tieclass =~ m/^[_a-z]\w*(::[_a-z]\w*)/i
+		_usage_AH_ $class unless $attr =~ $qual_id
+		                 && $tieclass =~ $qual_id
 		                 && eval "use base $tieclass; 1";
 	        if ($tieclass->isa('Exporter')) {
 		    local $Exporter::ExportLevel = 2;
@@ -59,14 +63,12 @@ sub import {
 	        eval qq{
 	            sub $attr : ATTR(VAR) {
 			my (\$ref, \$data) = \@_[2,4];
-			\$data = [ \$data ] unless ref \$data eq 'ARRAY';
-			# print \$ref, ": ";
-			# use Data::Dumper 'Dumper';
-			# print Dumper [ [\$ref, \$data] ];
+			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',\@\$data
-			:(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',\@\$data
-			:(\$type eq 'HASH')  ? tie \%\$ref,'$tieclass',\@\$data
+			 (\$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: $@";
@@ -91,10 +93,10 @@ sub _resolve_lastattr {
 }
 
 sub AUTOLOAD {
-	my ($class) = @_;
-	$AUTOLOAD =~ /_ATTR_(.*?)_(.*)/ or
+	my ($class) = $AUTOLOAD =~ m/(.*)::/g;
+	$AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
 	    croak "Can't locate class method '$AUTOLOAD' via package '$class'";
-	croak "Attribute handler '$2' doesn't handle $1 attributes";
+	croak "Attribute handler '$3' doesn't handle $2 attributes";
 }
 
 sub DESTROY {}
@@ -106,7 +108,7 @@ sub _gen_handler_AH_() {
 	    _resolve_lastattr;
 	    my ($pkg, $ref, @attrs) = @_;
 	    foreach (@attrs) {
-		my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/i or next;
+		my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
 		if ($attr eq 'ATTR') {
 			$data ||= "ANY";
 			$raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
@@ -185,8 +187,8 @@ Attribute::Handlers - Simpler definition of attribute handlers
 
 =head1 VERSION
 
-This document describes version 0.70 of Attribute::Handlers,
-released June  3, 2001.
+This document describes version 0.75 of Attribute::Handlers,
+released September  3, 2001.
 
 =head1 SYNOPSIS
 
@@ -546,11 +548,36 @@ C<__CALLER__>, which may be specified as the qualifier of an attribute:
 
         package Tie::Me::Kangaroo:Down::Sport;
 
-        use Attribute::Handler autotie => { __CALLER__::Roo => __PACKAGE__ };
+        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.
 
+=head3 Passing the tied object to C<tie>
+
+Occasionally it is important to pass a reference to the object being tied
+to the TIESCALAR, TIEHASH, etc. that ties it. 
+
+The C<autotie> mechanism supports this too. The following code:
+
+	use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
+	my $var : Selfish(@args);
+
+has the same effect as:
+
+	tie my $var, 'Tie::Selfish', @args;
+
+But when C<"autotieref"> is used instead of C<"autotie">:
+
+	use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
+	my $var : Selfish(@args);
+
+the effect is to pass the C<tie> call an extra reference to the variable
+being tied:
+
+        tie my $var, 'Tie::Selfish', \$var, @args;
+
+
 
 =head1 EXAMPLES
 
@@ -752,5 +779,4 @@ Bug reports and other feedback are most welcome.
 
          Copyright (c) 2001, Damian Conway. All Rights Reserved.
        This module is free software. It may be used, redistributed
-      and/or modified under the terms of the Perl Artistic License
-            (see http://www.perl.com/perl/misc/Artistic.html)
+           and/or modified under the same terms as Perl itself.
diff --git a/lib/Attribute/Handlers/Changes b/lib/Attribute/Handlers/Changes
index 9aa870eb44..4df4edb9e7 100644
--- a/lib/Attribute/Handlers/Changes
+++ b/lib/Attribute/Handlers/Changes
@@ -26,7 +26,7 @@ Revision history for Perl extension Attribute::Handlers
 	- Critical doc patch
 
 
-0.65	Sun Jun  3 07:40:03 2001
+0.70	Sun Jun  3 07:40:03 2001
 
 	- Added __CALLER__ pseudo class for 'autotie'
 
@@ -44,3 +44,20 @@ Revision history for Perl extension Attribute::Handlers
 
 	- Cleaned up interactions with other class hierarchies
 	  (due to being base class of UNIVERSAL)
+
+
+0.75	Mon Sep  3 09:07:08 2001
+
+	- Cleaned up AUTOLOAD
+
+	- Numerous bug fixes (thanks Pete)
+
+	- Fixed handling of attribute data that includes a newline (thanks Pete)
+
+	- Added "autotieref" option (thanks Pete)
+
+	- Switched off $DB::single
+
+	- Changed licence for inclusion in core distribution
+
+	- Fixed 'autotie' for tied classes with multi-level names (thanks Jeff)
diff --git a/lib/Attribute/Handlers/README b/lib/Attribute/Handlers/README
index 2de8de9f3f..e8f07833bd 100644
--- a/lib/Attribute/Handlers/README
+++ b/lib/Attribute/Handlers/README
@@ -1,5 +1,5 @@
 ==============================================================================
-                Release of version 0.70 of Attribute::Handlers
+                Release of version 0.75 of Attribute::Handlers
 ==============================================================================
 
 
@@ -46,15 +46,28 @@ AUTHOR
 COPYRIGHT
              Copyright (c) 2001, Damian Conway. All Rights Reserved.
            This module is free software. It may be used, redistributed
-          and/or modified under the terms of the Perl Artistic License
-                (see http://www.perl.com/perl/misc/Artistic.html)
+               and/or modified under the same terms as Perl itself.
 
 
 ==============================================================================
 
-CHANGES IN VERSION 0.70
+CHANGES IN VERSION 0.75
+
+
+	- Cleaned up AUTOLOAD
+
+	- Numerous bug fixes (thanks Pete)
+
+	- Fixed handling of attribute data that includes a newline (thanks Pete)
+
+	- Added "autotieref" option (thanks Pete)
+
+	- Switched off $DB::single
+
+	- Changed licence for inclusion in core distribution
+
+	- Fixed 'autotie' for tied classes with multi-level names (thanks Jeff)
 
-(No changes have been documented for this version)
 
 ==============================================================================
 
diff --git a/lib/Attribute/Handlers/demo/demo.pl b/lib/Attribute/Handlers/demo/demo.pl
index 02fa64a07b..7a269e81b5 100755
--- a/lib/Attribute/Handlers/demo/demo.pl
+++ b/lib/Attribute/Handlers/demo/demo.pl
@@ -4,7 +4,7 @@ use v5.6.0;
 use base Demo;
 
 my $y : Demo :This($this) = sub : Demo(1,2,3) {};
-sub x : Demo(4,5,6) :Multi {}
+sub x : Demo(4, 5, 6) :Multi {}
 my %z : Demo(hash) :Multi(method,maybe);
 # my %a : NDemo(hash);
 
diff --git a/lib/Attribute/Handlers/demo/demo_cycle.pl b/lib/Attribute/Handlers/demo/demo_cycle.pl
index 954316f513..771de94ea0 100755
--- a/lib/Attribute/Handlers/demo/demo_cycle.pl
+++ b/lib/Attribute/Handlers/demo/demo_cycle.pl
@@ -1,9 +1,15 @@
-use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
+package Selfish;
 
-my $next : Cycle(['A'..'Z']);
+sub TIESCALAR {
+	use Data::Dumper 'Dumper';
+	print Dumper [ \@_ ];
+	bless {}, $_[0];
+}
 
-print tied $next, "\n";
+package main;
 
-while (<>) {
-	print $next, "\n";
-}
+use Attribute::Handlers autotieref => { Selfish => Selfish };
+
+my $next : Selfish("me");
+
+print "$next\n";
diff --git a/lib/Attribute/Handlers/t/multi.t b/lib/Attribute/Handlers/t/multi.t
new file mode 100644
index 0000000000..5f4e59e0ec
--- /dev/null
+++ b/lib/Attribute/Handlers/t/multi.t
@@ -0,0 +1,131 @@
+END {print "not ok 1\n" unless $loaded;}
+use v5.6.0;
+use Attribute::Handlers;
+$loaded = 1;
+
+CHECK { $main::phase++ }
+
+######################### End of black magic.
+
+# Insert your test code below (better if it prints "ok 13"
+# (correspondingly "not ok 13") depending on the success of chunk 13
+# of the test code):
+
+sub ok { $::count++; push @::results, [$_[1], $_[0]?"":"not "]; }
+
+END { print "1..$::count\n";
+      print map "$_->[1]ok $_->[0]\n",
+		sort {$a->[0]<=>$b->[0]}
+			grep $_->[0], @::results }
+
+package Test;
+use warnings;
+no warnings 'redefine';
+
+sub UNIVERSAL::Lastly :ATTR(INIT) { ::ok $_[4][0] && $main::phase, $_[4][1] }
+
+sub UNIVERSAL::Okay :ATTR(BEGIN) { ::ok  $_[4][0] && !$main::phase, $_[4][1] }
+
+sub Dokay :ATTR(SCALAR) { ::ok @{$_[4]} }
+sub Dokay :ATTR(HASH)   { ::ok @{$_[4]} }
+sub Dokay :ATTR(ARRAY)  { ::ok @{$_[4]} }
+sub Dokay :ATTR(CODE)   { ::ok @{$_[4]} }
+
+sub Vokay :ATTR(VAR)    { ::ok @{$_[4]} }
+
+sub Aokay :ATTR(ANY)    { ::ok @{$_[4]} }
+
+package main;
+use warnings;
+
+my $x1 :Lastly(1,41);
+my @x1 :Lastly(1=>42);
+my %x1 :Lastly(1,43);
+sub x1 :Lastly(1,44) {}
+
+my Test $x2 :Dokay(1,5);
+
+package Test;
+my $x3 :Dokay(1,6);
+my Test $x4 :Dokay(1,7);
+sub x3 :Dokay(1,8) {}
+
+my $y1 :Okay(1,9);
+my @y1 :Okay(1,10);
+my %y1 :Okay(1,11);
+sub y1 :Okay(1,12) {}
+
+my $y2 :Vokay(1,13);
+my @y2 :Vokay(1,14);
+my %y2 :Vokay(1,15);
+# BEGIN {eval 'sub y2 :Vokay(0,16) {}; 1' or
+::ok(1,16);
+# }
+
+my $z :Aokay(1,17);
+my @z :Aokay(1,18);
+my %z :Aokay(1,19);
+sub z :Aokay(1,20) {};
+
+package DerTest;
+use base 'Test';
+use warnings;
+
+my $x5 :Dokay(1,21);
+my Test $x6 :Dokay(1,22);
+sub x5 :Dokay(1,23);
+
+my $y3 :Okay(1,24);
+my @y3 :Okay(1,25);
+my %y3 :Okay(1,26);
+sub y3 :Okay(1,27) {}
+
+package Unrelated;
+
+my $x11 :Okay(1,1);
+my @x11 :Okay(1=>2);
+my %x11 :Okay(1,3);
+sub x11 :Okay(1,4) {}
+
+BEGIN { eval 'my $x7 :Dokay(0,28)' or ::ok(1,28); }
+my Test $x8 :Dokay(1,29);
+eval 'sub x7 :Dokay(0,30) {}' or ::ok(1,30);
+
+
+package Tie::Loud;
+
+sub TIESCALAR { ::ok(1,31); bless {}, $_[0] }
+sub FETCH { ::ok(1,32); return 1 }
+sub STORE { ::ok(1,33); return 1 }
+
+package Tie::Noisy;
+
+sub TIEARRAY { ::ok(1,$_[1]); bless {}, $_[0] }
+sub FETCH { ::ok(1,35); return 1 }
+sub STORE { ::ok(1,36); return 1 }
+sub FETCHSIZE { 100 }
+
+package Tie::Row::dy;
+
+sub TIEHASH { ::ok(1,$_[1]); bless {}, $_[0] }
+sub FETCH { ::ok(1,38); return 1 }
+sub STORE { ::ok(1,39); return 1 }
+
+package main;
+
+eval 'sub x7 :ATTR(SCALAR) :ATTR(CODE) {}' and ::ok(0,40) or ::ok(1,40);
+
+use Attribute::Handlers autotie => {      Other::Loud => Tie::Loud,
+				                Noisy => Tie::Noisy,
+				     UNIVERSAL::Rowdy => Tie::Row::dy,
+                                   };
+
+my Other $loud : Loud;
+$loud++;
+
+my @noisy : Noisy(34);
+$noisy[0]++;
+
+my %rowdy : Rowdy(37);
+$rowdy{key}++;
+