dslinux/user/perl/lib/Attribute/Handlers/demo Demo.pm Descriptions.pm MyClass.pm demo.pl demo2.pl demo3.pl demo4.pl demo_call.pl demo_chain.pl demo_cycle.pl demo_hashdir.pl demo_phases.pl demo_range.pl demo_rawdata.pl
cayenne
dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:27:06 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/lib/Attribute/Handlers/demo
In directory antilope:/tmp/cvs-serv7729/lib/Attribute/Handlers/demo
Added Files:
Demo.pm Descriptions.pm MyClass.pm demo.pl demo2.pl demo3.pl
demo4.pl demo_call.pl demo_chain.pl demo_cycle.pl
demo_hashdir.pl demo_phases.pl demo_range.pl demo_rawdata.pl
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: MyClass.pm ---
package MyClass;
$VERSION = '1.00';
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;
--- NEW FILE: demo3.pl ---
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/);
--- NEW FILE: demo_chain.pl ---
#! /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();
--- NEW FILE: demo_phases.pl ---
#! /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);
--- NEW FILE: demo.pl ---
#! /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();
--- NEW FILE: demo_range.pl ---
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";
}
--- NEW FILE: Demo.pm ---
$DB::single = 1;
package Demo;
$VERSION = '1.00';
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;
--- NEW FILE: demo2.pl ---
#! /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) {}
--- NEW FILE: demo_rawdata.pl ---
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);
--- NEW FILE: demo_call.pl ---
#! /usr/local/bin/perl -w
use Attribute::Handlers;
sub Call : ATTR {
use Data::Dumper 'Dumper';
print Dumper [ @_ ];
}
sub x : Call(some,data) { };
--- NEW FILE: demo_cycle.pl ---
package Selfish;
sub TIESCALAR {
use Data::Dumper 'Dumper';
print Dumper [ \@_ ];
bless [ @_[1..$#_] ], $_[0];
}
sub FETCH {
use Data::Dumper 'Dumper';
Dumper [ @{$_[0]} ];
}
package main;
use Attribute::Handlers autotieref => { Selfish => Selfish };
my $next : Selfish("me");
print "$next\n";
my $last : Selfish("you","them","who?");
print "$last\n";
my $other : Selfish(["you","them","who?"]);
print "$other\n";
--- NEW FILE: demo4.pl ---
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) { }
--- NEW FILE: demo_hashdir.pl ---
use Attribute::Handlers autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
my %dot : Dir('.', DIR_UNLINK);
print join "\n", keys %dot;
delete $dot{killme};
print join "\n", keys %dot;
--- NEW FILE: Descriptions.pm ---
package Descriptions;
$VERSION = '1.00';
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;
More information about the dslinux-commit
mailing list