From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Sun, 3 Jun 2001 16:50:33 +0000 (+0000)
Subject: Upgrade to Attribute::Handlers 0.70.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=04070b925af8464d3aedecd339180269e7246ebd;p=p5sagit%2Fp5-mst-13.2.git

Upgrade to Attribute::Handlers 0.70.

NOTE: this unearthed the "too late for CHECK block" bug,
that's why the 1_compile.t change.

p4raw-id: //depot/perl@10407
---

diff --git a/MANIFEST b/MANIFEST
index 8c1d6f3..24b9a7b 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -670,6 +670,20 @@ keywords.h		The keyword numbers
 keywords.pl		Program to write keywords.h
 lib/AnyDBM_File.pm	Perl module to emulate dbmopen
 lib/Attribute/Handlers.pm	Attribute::Handlers
+lib/Attribute/Handlers/demo/Demo.pm	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/Descriptions.pm	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/MyClass.pm	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo.pl	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo2.pl	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo3.pl	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo4.pl	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo_call.pl	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo_chain.pl	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo_cycle.pl	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo_hashdir.pl	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo_phases.pl	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo_range.pl	Attribute::Handlers demo
+lib/Attribute/Handlers/demo/demo_rawdata.pl	Attribute::Handlers demo
 lib/AutoLoader.pm	Autoloader base class
 lib/AutoSplit.pm	Split up autoload functions
 lib/Benchmark.pm	Measure execution time
diff --git a/lib/Attribute/Handlers/demo/Demo.pm b/lib/Attribute/Handlers/demo/Demo.pm
new file mode 100755
index 0000000..d826935
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/Demo.pm
@@ -0,0 +1,49 @@
+$DB::single = 1;
+
+package Demo;
+use Attribute::Handlers;
+no warnings 'redefine';
+
+sub Demo : ATTR(SCALAR) {
+	my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
+	$data = '<undef>' unless defined $data;
+	print STDERR 'Scalar $', *{$symbol}{NAME},
+		     " ($referent) was ascribed ${attr}\n",
+		     "with data ($data)\nin phase $phase\n";
+};
+
+sub This : ATTR(SCALAR) {
+	print STDERR "This at ",
+		     join(":", map { defined() ? $_ : "" } caller(1)),
+		     "\n";
+}
+
+sub Demo : ATTR(HASH) {
+	my ($package, $symbol, $referent, $attr, $data) = @_;
+	$data = '<undef>' unless defined $data;
+	print STDERR 'Hash %', *{$symbol}{NAME},
+		     " ($referent) was ascribed ${attr} with data ($data)\n";
+};
+
+sub Demo : ATTR(CODE) {
+	my ($package, $symbol, $referent, $attr, $data) = @_;
+	$data = '<undef>' unless defined $data;
+	print STDERR 'Sub &', *{$symbol}{NAME},
+		     " ($referent) was ascribed ${attr} with data ($data)\n";
+};
+
+sub Multi : ATTR {
+	my ($package, $symbol, $referent, $attr, $data) = @_;
+	$data = '<undef>' unless defined $data;
+	print STDERR ref($referent), ' ', *{$symbol}{NAME},
+		     " ($referent) was ascribed ${attr} with data ($data)\n";
+};
+
+sub ExplMulti : ATTR(ANY) {
+	my ($package, $symbol, $referent, $attr, $data) = @_;
+	$data = '<undef>' unless defined $data;
+	print STDERR ref($referent), ' ', *{$symbol}{NAME},
+		     " ($referent) was ascribed ${attr} with data ($data)\n";
+};
+
+1;
diff --git a/lib/Attribute/Handlers/demo/Descriptions.pm b/lib/Attribute/Handlers/demo/Descriptions.pm
new file mode 100755
index 0000000..e904dbb
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/Descriptions.pm
@@ -0,0 +1,24 @@
+package Descriptions;
+
+use Attribute::Handlers;
+
+my %name;
+
+sub name {
+	return $name{$_[2]}||*{$_[1]}{NAME};
+}
+
+sub UNIVERSAL::Name :ATTR {
+	$name{$_[2]} = $_[4];
+}
+
+sub UNIVERSAL::Purpose :ATTR {
+	print STDERR "Purpose of ", &name, " is $_[4]\n";
+}
+
+sub UNIVERSAL::Unit :ATTR {
+	print STDERR &name, " measured in $_[4]\n";
+}
+
+
+1;
diff --git a/lib/Attribute/Handlers/demo/MyClass.pm b/lib/Attribute/Handlers/demo/MyClass.pm
new file mode 100755
index 0000000..60948eb
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/MyClass.pm
@@ -0,0 +1,63 @@
+package MyClass;
+use v5.6.0;
+use base Attribute::Handlers;
+no warnings 'redefine';
+
+
+sub Good : ATTR(SCALAR) {
+	my ($package, $symbol, $referent, $attr, $data) = @_;
+
+	# Invoked for any scalar variable with a :Good attribute,
+	# provided the variable was declared in MyClass (or
+	# a derived class) or typed to MyClass.
+
+	# Do whatever to $referent here (executed in CHECK phase).
+	local $" = ", ";
+	print "MyClass::Good:ATTR(SCALAR)(@_);\n";
+};
+
+sub Bad : ATTR(SCALAR) {
+	# Invoked for any scalar variable with a :Bad attribute,
+	# provided the variable was declared in MyClass (or
+	# a derived class) or typed to MyClass.
+	local $" = ", ";
+	print "MyClass::Bad:ATTR(SCALAR)(@_);\n";
+}
+
+sub Good : ATTR(ARRAY) {
+        # Invoked for any array variable with a :Good attribute,
+        # provided the variable was declared in MyClass (or
+        # a derived class) or typed to MyClass.
+	local $" = ", ";
+	print "MyClass::Good:ATTR(ARRAY)(@_);\n";
+};
+
+sub Good : ATTR(HASH) {
+        # Invoked for any hash variable with a :Good attribute,
+        # provided the variable was declared in MyClass (or
+        # a derived class) or typed to MyClass.
+	local $" = ", ";
+	print "MyClass::Good:ATTR(HASH)(@_);\n";
+};
+
+sub Ugly : ATTR(CODE) {
+        # Invoked for any subroutine declared in MyClass (or a 
+        # derived class) with an :Ugly attribute.
+	local $" = ", ";
+	print "MyClass::UGLY:ATTR(CODE)(@_);\n";
+};
+
+sub Omni : ATTR {
+        # Invoked for any scalar, array, hash, or subroutine
+        # with an :Omni attribute, provided the variable or
+        # subroutine was declared in MyClass (or a derived class)
+        # or the variable was typed to MyClass.
+        # Use ref($_[2]) to determine what kind of referent it was.
+	local $" = ", ";
+	my $type = ref $_[2];
+	print "MyClass::OMNI:ATTR($type)(@_);\n";
+	use Data::Dumper 'Dumper';
+	print Dumper [ \@_ ];
+};
+
+1;
diff --git a/lib/Attribute/Handlers/demo/demo.pl b/lib/Attribute/Handlers/demo/demo.pl
new file mode 100755
index 0000000..02fa64a
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo.pl
@@ -0,0 +1,31 @@
+#! /usr/local/bin/perl -w
+
+use v5.6.0;
+use base Demo;
+
+my $y : Demo :This($this) = sub : Demo(1,2,3) {};
+sub x : Demo(4,5,6) :Multi {}
+my %z : Demo(hash) :Multi(method,maybe);
+# my %a : NDemo(hash);
+
+{
+	package Named;
+
+	use base Demo;
+
+	sub Demo :ATTR(SCALAR) { print STDERR "tada\n" }
+
+	my $y : Demo :This($this) = sub : Demo(1,2,3) {};
+	sub x : ExplMulti :Demo(4,5,6) {}
+	my %z : ExplMulti :Demo(hash);
+	my Named $q : Demo;
+}
+
+package Other;
+
+my Demo $dother : Demo :This($this) = "okay";
+my Named $nother : Demo :This($this) = "okay";
+
+# my $unnamed : Demo;
+
+# sub foo : Demo();
diff --git a/lib/Attribute/Handlers/demo/demo2.pl b/lib/Attribute/Handlers/demo/demo2.pl
new file mode 100755
index 0000000..387ab44
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo2.pl
@@ -0,0 +1,21 @@
+#! /usr/local/bin/perl -w
+
+use v5.6.0;
+use base Demo;
+no warnings 'redefine';
+
+my %z1 :Multi(method?maybe);
+my %z2 :Multi(method,maybe);
+my %z3 :Multi(qw(method,maybe));
+my %z4 :Multi(qw(method maybe));
+my %z5 :Multi('method','maybe');
+
+sub foo :Demo(till=>ears=>are=>bleeding) {}
+sub foo :Demo(['till','ears','are','bleeding']) {}
+sub foo :Demo(qw/till ears are bleeding/) {}
+sub foo :Demo(till,ears,are,bleeding) {}
+
+sub foo :Demo(my,ears,are,bleeding) {}
+sub foo :Demo(my=>ears=>are=>bleeding) {}
+sub foo :Demo(qw/my, ears, are, bleeding/) {}
+sub foo :Demo(qw/my ears are bleeding) {}
diff --git a/lib/Attribute/Handlers/demo/demo3.pl b/lib/Attribute/Handlers/demo/demo3.pl
new file mode 100755
index 0000000..6760fc0
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo3.pl
@@ -0,0 +1,16 @@
+package main;
+use MyClass;
+
+my MyClass $x :Good :Bad(1**1-1) :Omni(vorous);
+
+package SomeOtherClass;
+use base MyClass;
+
+sub tent { 'acle' }
+
+sub w :Ugly(sister) :Omni('po',tent()) {}
+
+my @y :Good :Omni(s/cie/nt/);
+
+my %y :Good(q/bye) :Omni(q/bus/);
+
diff --git a/lib/Attribute/Handlers/demo/demo4.pl b/lib/Attribute/Handlers/demo/demo4.pl
new file mode 100755
index 0000000..22d9fd9
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo4.pl
@@ -0,0 +1,9 @@
+use Descriptions;
+
+my $capacity : Name(capacity)
+	     : Purpose(to store max storage capacity for files)
+	     : Unit(Gb);
+
+package Other;
+
+sub foo : Purpose(to foo all data before barring it) { }
diff --git a/lib/Attribute/Handlers/demo/demo_call.pl b/lib/Attribute/Handlers/demo/demo_call.pl
new file mode 100755
index 0000000..1a97342
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo_call.pl
@@ -0,0 +1,11 @@
+#! /usr/local/bin/perl -w
+
+use Attribute::Handlers;
+
+sub Call : ATTR {
+	use Data::Dumper 'Dumper';
+	print Dumper [ @_ ];
+}
+
+
+sub x : Call(some,data) { };
diff --git a/lib/Attribute/Handlers/demo/demo_chain.pl b/lib/Attribute/Handlers/demo/demo_chain.pl
new file mode 100755
index 0000000..8999c1c
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo_chain.pl
@@ -0,0 +1,27 @@
+#! /usr/local/bin/perl -w
+
+use Attribute::Handlers;
+
+sub Prefix : ATTR {
+  my ($glob, $sub) = @_[1,2];
+  no warnings 'redefine';
+  *$glob = sub {
+                 print "This happens first\n";
+                 $sub->(@_);
+               };
+}
+
+sub Postfix : ATTR {
+  my ($glob, $sub) = @_[1,2];
+  no warnings 'redefine';
+  *$glob = sub {
+                 $sub->(@_);
+                 print "This happens last\n";
+               };
+}
+
+sub test : Postfix Prefix {
+  print "Hello World\n";
+}
+
+test();
diff --git a/lib/Attribute/Handlers/demo/demo_cycle.pl b/lib/Attribute/Handlers/demo/demo_cycle.pl
new file mode 100755
index 0000000..954316f
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo_cycle.pl
@@ -0,0 +1,9 @@
+use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
+
+my $next : Cycle(['A'..'Z']);
+
+print tied $next, "\n";
+
+while (<>) {
+	print $next, "\n";
+}
diff --git a/lib/Attribute/Handlers/demo/demo_hashdir.pl b/lib/Attribute/Handlers/demo/demo_hashdir.pl
new file mode 100755
index 0000000..2e7a4e2
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo_hashdir.pl
@@ -0,0 +1,7 @@
+use Attribute::Handlers autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
+
+my %dot : Dir('.', DIR_UNLINK);
+
+print join "\n", keys %dot;
+
+delete $dot{killme};
diff --git a/lib/Attribute/Handlers/demo/demo_phases.pl b/lib/Attribute/Handlers/demo/demo_phases.pl
new file mode 100755
index 0000000..022f7e1
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo_phases.pl
@@ -0,0 +1,18 @@
+#! /usr/local/bin/perl -w
+
+use Attribute::Handlers;
+use Data::Dumper 'Dumper';
+
+sub UNIVERSAL::Beginner : ATTR(SCALAR,BEGIN,END)
+	{ print STDERR "Beginner: ", Dumper \@_}
+
+sub UNIVERSAL::Checker : ATTR(CHECK,SCALAR)
+	{ print STDERR "Checker: ", Dumper \@_}
+
+sub UNIVERSAL::Initer : ATTR(SCALAR,INIT)
+	{ print STDERR "Initer: ", Dumper \@_}
+
+package Other;
+
+my $x :Initer(1) :Checker(2) :Beginner(3);
+my $y :Initer(4) :Checker(5) :Beginner(6);
diff --git a/lib/Attribute/Handlers/demo/demo_range.pl b/lib/Attribute/Handlers/demo/demo_range.pl
new file mode 100755
index 0000000..b63d518
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo_range.pl
@@ -0,0 +1,21 @@
+package UNIVERSAL;
+use Attribute::Handlers;
+use Tie::RangeHash;
+
+sub Ranged : ATTR(HASH) {
+	my ($package, $symbol, $referent, $attr, $data) = @_;
+	tie %$referent, 'Tie::RangeHash';
+}
+
+package main;
+
+my %next : Ranged;
+
+$next{'cat,dog'} = "animal";
+$next{'fish,fowl'} = "meal";
+$next{'heaven,hell'} = "reward";
+
+while (<>) {
+	chomp;
+	print $next{$_}||"???", "\n";
+}
diff --git a/lib/Attribute/Handlers/demo/demo_rawdata.pl b/lib/Attribute/Handlers/demo/demo_rawdata.pl
new file mode 100755
index 0000000..c0754f0
--- /dev/null
+++ b/lib/Attribute/Handlers/demo/demo_rawdata.pl
@@ -0,0 +1,12 @@
+package UNIVERSAL;
+use Attribute::Handlers;
+
+sub Cooked : ATTR(SCALAR) { print pop, "\n" }
+sub PostRaw : ATTR(SCALAR,RAWDATA) { print pop, "\n" }
+sub PreRaw : ATTR(SCALAR,RAWDATA) { print pop, "\n" }
+
+package main;
+
+my $x : Cooked(1..5);
+my $y : PreRaw(1..5);
+my $z : PostRaw(1..5);
diff --git a/t/lib/1_compile.t b/t/lib/1_compile.t
index 7d28d00..a713c6c 100644
--- a/t/lib/1_compile.t
+++ b/t/lib/1_compile.t
@@ -61,6 +61,8 @@ delete_by_prefix('ExtUtils::MM_');	# ExtUtils::MakeMaker's domain
 delete_by_prefix('File::Spec::');	# File::Spec's domain
 add_by_name('File::Spec::Functions');	# put this back
 
+delete_by_prefix('Attribute::Handlers');# we test this, and we have demos
+
 sub using_feature {
     my $use = "use$_[0]";
     exists $Config{$use} &&
@@ -76,9 +78,8 @@ unless (using_feature('threads') && has_extension('Thread')) {
 delete_by_prefix('unicode::');
 add_by_name('unicode::distinct');	# put this back
 
-
-# Delete all modules which have their own tests.  This makes
-# this test a lot faster.
+# Delete all modules which have their own tests.
+# This makes this test a lot faster.
 foreach my $mod (<DATA>) {
     chomp $mod;
     delete_by_name($mod);