http://wiki.crossplatform.ru/index.php?title=Perl/FAQ/%D0%9A%D0%BB%D0%B0%D1%81%D1%81%D1%8B,_%D0%9E%D0%B1%D1%8A%D0%B5%D0%BA%D1%82%D1%8B_%D0%B8_%D1%81%D0%B2%D1%8F%D0%B7%D0%B8&feed=atom&action=history
Perl/FAQ/Классы, Объекты и связи - История изменений
2024-03-28T19:22:14Z
История изменений этой страницы в вики
MediaWiki 1.15.1
http://wiki.crossplatform.ru/index.php?title=Perl/FAQ/%D0%9A%D0%BB%D0%B0%D1%81%D1%81%D1%8B,_%D0%9E%D0%B1%D1%8A%D0%B5%D0%BA%D1%82%D1%8B_%D0%B8_%D1%81%D0%B2%D1%8F%D0%B7%D0%B8&diff=3518&oldid=prev
Root: Новая: {{Perl_header}} == Introduction == <source lang="perl"> #----------------------------- $object = {}; # hash reference bless($object, "Data::Encoder"); # bless $...
2008-12-03T12:56:12Z
<p>Новая: {{Perl_header}} == Introduction == <source lang="perl"> #----------------------------- $object = {}; # hash reference bless($object, "Data::Encoder"); # bless $...</p>
<p><b>Новая страница</b></p><div>{{Perl_header}}<br />
<br />
== Introduction ==<br />
<source lang="perl"><br />
#-----------------------------<br />
$object = {}; # hash reference<br />
bless($object, "Data::Encoder"); # bless $object into Data::Encoder class<br />
<br />
bless($object); # bless $object into current package<br />
#-----------------------------<br />
$obj = [3,5];<br />
print ref($obj), " ", $obj->[1], "\n";<br />
<br />
bless($obj, "Human::Cannibal");<br />
print ref($obj), " ", $obj->[1], "\n";<br />
<br />
ARRAY 5<br />
<br />
Human::Cannibal 5<br />
#-----------------------------<br />
$obj->{Stomach} = "Empty"; # directly accessing an object's contents<br />
<br />
$obj->{NAME} = "Thag"; # uppercase field name to make it stand out (optional)<br />
#-----------------------------<br />
$encoded = $object->encode("data");<br />
#-----------------------------<br />
<br />
$encoded = Data::Encoder->encode("data");<br />
#-----------------------------<br />
sub new {<br />
my $class = shift;<br />
<br />
my $self = {}; # allocate new hash for object<br />
bless($self, $class);<br />
return $self;<br />
<br />
}<br />
#-----------------------------<br />
$object = Class->new();<br />
#-----------------------------<br />
$object = Class::new("Class");<br />
#-----------------------------<br />
sub class_only_method {<br />
<br />
my $class = shift;<br />
die "class method called on object" if ref $class;<br />
<br />
# more code here<br />
} <br />
#-----------------------------<br />
sub instance_only_method {<br />
my $self = shift;<br />
<br />
die "instance method called on class" unless ref $self;<br />
# more code here<br />
} <br />
<br />
#-----------------------------<br />
$lector = new Human::Cannibal;<br />
feed $lector "Zak";<br />
move $lector "New York";<br />
#-----------------------------<br />
$lector = Human::Cannibal-><br />
new();<br />
<br />
$lector->feed("Zak");<br />
$lector->move("New York");<br />
#-----------------------------<br />
printf STDERR "stuff here\n";<br />
<br />
#-----------------------------<br />
move $obj->{FIELD}; # probably wrong<br />
move $ary[$i]; # probably wrong<br />
#-----------------------------<br />
$obj->move->{FIELD}; # Surprise!<br />
<br />
$ary->move->[$i]; # Surprise!<br />
#-----------------------------<br />
$obj->{FIELD}-><br />
move()<br />
; # Nope, you wish<br />
<br />
$ary[$i]-><br />
move;<br />
# Nope, you wish<br />
#-----------------------------<br />
<br />
</source><br />
== Constructing an Object ==<br />
<source lang="perl"><br />
#-----------------------------<br />
sub new {<br />
<br />
my $class = shift;<br />
my $self = { };<br />
<br />
bless($self, $class);<br />
return $self;<br />
} <br />
#-----------------------------<br />
sub new { bless( { }, shift ) }<br />
<br />
#-----------------------------<br />
sub new { bless({}) }<br />
#-----------------------------<br />
sub new {<br />
<br />
my $self = { }; # allocate anonymous hash<br />
bless($self);<br />
<br />
# init two sample attributes/data members/fields<br />
$self->{START} = time(); <br />
$self->{AGE} = 0;<br />
<br />
return $self;<br />
} <br />
#-----------------------------<br />
sub new {<br />
my $classname = shift; # What class are we constructing?<br />
<br />
my $self = {}; # Allocate new memory<br />
bless($self, $classname); # Mark it of the right type<br />
$self->{START} = <br />
<br />
time();<br />
# init data fields<br />
$self->{AGE} = <br />
0;<br />
<br />
return $self; # And give it back<br />
} <br />
#-----------------------------<br />
sub new {<br />
<br />
my $classname = shift; # What class are we constructing?<br />
my $self = {}; # Allocate new memory<br />
<br />
bless($self, $classname); # Mark it of the right type<br />
$self->_init(@_); # Call _init with remaining args<br />
return $self;<br />
<br />
} <br />
<br />
# "private" method to initialize fields. It always sets START to<br />
# the current time, and AGE to 0. If called with arguments, _init<br />
# interprets them as key+value pairs to initialize the object with.<br />
sub _init {<br />
my $self = shift;<br />
<br />
$self->{START} = <br />
time();<br />
<br />
$self->{AGE} = 0;<br />
<br />
if (@_) {<br />
my %extra = @_;<br />
<br />
@$self{keys %extra} = values %extra;<br />
} <br />
<br />
} <br />
#-----------------------------<br />
<br />
</source><br />
== Destroying an Object ==<br />
<source lang="perl"><br />
#-----------------------------<br />
sub DESTROY {<br />
my $self = shift;<br />
<br />
printf("$self dying at %s\n", scalar localtime);<br />
} <br />
#-----------------------------<br />
<br />
$self->{WHATEVER} = $self;<br />
<br />
#-----------------------------<br />
<br />
</source><br />
== Managing Instance Data ==<br />
<source lang="perl"><br />
#-----------------------------<br />
sub get_name {<br />
my $self = shift;<br />
<br />
return $self->{NAME};<br />
} <br />
<br />
sub set_name {<br />
<br />
my $self = shift;<br />
$self->{NAME} = shift;<br />
<br />
} <br />
#-----------------------------<br />
sub name {<br />
my $self = shift;<br />
<br />
if (@_) { $self->{NAME} = shift } <br />
<br />
return $self->{NAME};<br />
} <br />
#-----------------------------<br />
sub age {<br />
<br />
my $self = shift;<br />
my $prev = $self->{AGE};<br />
<br />
if (@_) { $self->{AGE} = shift } <br />
<br />
return $prev;<br />
} <br />
# sample call of get and set: happy birthday!<br />
$obj->age( 1 + $obj->age );<br />
<br />
#-----------------------------<br />
$him = Person-><br />
new()<br />
;<br />
$him->{NAME} = "Sylvester";<br />
<br />
$him->{AGE} = 23;<br />
#-----------------------------<br />
use Carp;<br />
sub name {<br />
<br />
my $self = shift;<br />
return $self->{NAME} unless @_;<br />
<br />
local $_ = shift;<br />
croak "too many arguments" if @_;<br />
<br />
if ($^W) {<br />
/[^\s\w'-]/ && carp "funny characters in name"; #'<br />
<br />
/\d/ && carp "numbers in name";<br />
/\S+(\s+\S+)+/ || carp "prefer multiword name";<br />
/\S/ || carp "name is blank";<br />
<br />
} <br />
s/(\w+)/\u\L$1/g; # enforce capitalization<br />
$self->{NAME} = $_;<br />
<br />
} <br />
#-----------------------------<br />
package Person;<br />
<br />
# this is the same as before...<br />
sub new {<br />
<br />
my $that = shift;<br />
my $class = ref($that) || $that;<br />
<br />
my $self = {<br />
NAME => undef,<br />
AGE => undef,<br />
PEERS => [],<br />
};<br />
<br />
bless($self, $class);<br />
return $self;<br />
}<br />
<br />
use Alias qw(attr);<br />
<br />
use vars qw($NAME $AGE @PEERS);<br />
<br />
sub name {<br />
<br />
my $self = attr shift;<br />
if (@_) { $NAME = shift; }<br />
<br />
return $NAME;<br />
};<br />
<br />
sub age {<br />
my $self = attr shift;<br />
<br />
if (@_) { $AGE = shift; }<br />
return $AGE;<br />
<br />
}<br />
<br />
sub peers {<br />
my $self = attr shift;<br />
<br />
if (@_) { @PEERS = @_; }<br />
<br />
return @PEERS;<br />
}<br />
<br />
sub exclaim {<br />
my $self = attr shift;<br />
<br />
return sprintf "Hi, I'm %s, age %d, working with %s",<br />
$NAME, $AGE, join(", ", @PEERS);<br />
<br />
}<br />
<br />
sub happy_birthday {<br />
my $self = attr shift;<br />
<br />
return ++$AGE;<br />
}<br />
#-----------------------------<br />
<br />
</source><br />
== Managing Class Data ==<br />
<source lang="perl"><br />
#-----------------------------<br />
package Person;<br />
<br />
$Body_Count = 0; <br />
<br />
sub population { return $Body_Count }<br />
<br />
sub new { # constructor<br />
$Body_Count++;<br />
return bless({}, shift);<br />
<br />
}<br />
<br />
sub DESTROY { --$BodyCount } # destructor<br />
<br />
# later, the user can say this:<br />
package main;<br />
<br />
for (1..10) { push @people, Person->new }<br />
<br />
printf "There are %d people alive.\n", Person->population();<br />
<br />
There are 10 people alive.<br />
#-----------------------------<br />
$him = Person-><br />
<br />
new()<br />
;<br />
$him->gender("male");<br />
<br />
$her = Person-><br />
new()<br />
<br />
;<br />
$her->gender("female");<br />
#-----------------------------<br />
FixedArray->Max_Bounds(100); # set for whole class<br />
$alpha = FixedArray->new();<br />
<br />
printf "Bound on alpha is %d\n", $alpha->Max_Bounds();<br />
100<br />
<br />
$beta = FixedArray->new();<br />
$beta->Max_Bounds(50); # still sets for whole class<br />
<br />
printf "Bound on alpha is %d\n", $alpha->Max_Bounds();<br />
50<br />
#-----------------------------<br />
package FixedArray;<br />
<br />
$Bounds = 7; # default<br />
sub new { bless( {}, shift ) }<br />
<br />
sub Max_Bounds {<br />
my $proto = shift;<br />
$Bounds = shift if @_; # allow updates<br />
<br />
return $Bounds;<br />
} <br />
#-----------------------------<br />
sub Max_Bounds { $Bounds }<br />
<br />
#-----------------------------<br />
sub new {<br />
my $class = shift;<br />
my $self = bless({}, $class);<br />
<br />
$self->{Max_Bounds_ref} = \$Bounds;<br />
return $self;<br />
} <br />
<br />
#-----------------------------<br />
<br />
</source><br />
== Using Classes as Structs ==<br />
<source lang="perl"><br />
#-----------------------------<br />
use Class::Struct; # load struct-building module<br />
<br />
struct Person => { # create a definition for a "Person"<br />
<br />
name => '$', # name field is a scalar<br />
age => '$', # age field is also a scalar<br />
peers => '@', # but peers field is an array (reference)<br />
<br />
};<br />
<br />
my $p = Person-><br />
new()<br />
; # allocate an empty Person struct<br />
<br />
$p->name("Jason Smythe"); # set its name field<br />
<br />
$p->age(13); # set its age field<br />
$p->peers( ["Wilbur", "Ralph", "Fred" ] ); # set its peers field<br />
<br />
<br />
# or this way:<br />
@{$p->peers} = ("Wilbur", "Ralph", "Fred");<br />
<br />
# fetch various values, including the zeroth friend<br />
printf "At age %d, %s's first friend is %s.\n",<br />
$p->age, $p->name, $p->peers(0);<br />
<br />
#-----------------------------<br />
use Class::Struct;<br />
<br />
struct Person => {name => '$', age => '$'}; #'<br />
<br />
struct Family => {head => 'Person', address => '$', members => '@'}; #'<br />
<br />
$folks = Family-><br />
new();<br />
<br />
$dad = $folks->head;<br />
$dad->name("John");<br />
<br />
$dad->age(34);<br />
<br />
printf("%s's age is %d\n", $folks->head->name, $folks->head->age);<br />
<br />
#-----------------------------<br />
sub Person::age {<br />
use Carp;<br />
my ($self, $age) = @_;<br />
<br />
if (@_ > 2) { confess "too many arguments" } <br />
<br />
elsif (@_ == 1) { return $struct->{'age'} }<br />
<br />
elsif (@_ == 2) {<br />
carp "age `$age' isn't numeric" if $age !~ /^\d+/;<br />
<br />
carp "age `$age' is unreasonable" if $age > 150;<br />
$self->{'age'} = $age;<br />
<br />
} <br />
} <br />
#-----------------------------<br />
if ($^W) { <br />
<br />
carp "age `$age' isn't numeric" if $age !~ /^\d+/;<br />
carp "age `$age' is unreasonable" if $age > 150;<br />
<br />
}<br />
#-----------------------------<br />
my $gripe = $^W ? \&carp : \&croak;<br />
$gripe->("age `$age' isn't numeric") if $age !~ /^\d+/;<br />
<br />
$gripe->("age `$age' is unreasonable") if $age > 150;<br />
#-----------------------------<br />
struct Family => [head => 'Person', address => '$', members => '@']; #'<br />
<br />
#-----------------------------<br />
struct Card => { <br />
name => '$',<br />
color => '$',<br />
cost => '$',<br />
type => '$',<br />
release => '$',<br />
text => '$',<br />
<br />
};<br />
#-----------------------------<br />
struct Card => map { $_ => '$' } qw(name color cost type release text); #'<br />
#-----------------------------<br />
<br />
struct hostent => { reverse qw{<br />
$ name<br />
@ aliases<br />
$ addrtype<br />
$ length<br />
@ addr_list<br />
<br />
}};<br />
#-----------------------------<br />
#define h_type h_addrtype<br />
#define h_addr h_addr_list[0]<br />
#-----------------------------<br />
# make (hostent object)-><br />
type()<br />
same as (hostent object)-><br />
addrtype()<br />
<br />
*hostent::type = \&hostent::addrtype;<br />
<br />
# make (hostenv object)-><br />
addr()<br />
same as (hostenv object)->addr_list(0)<br />
<br />
sub hostent::addr { shift->addr_list(0,@_) }<br />
<br />
#-----------------------------<br />
package Extra::hostent;<br />
use Net::hostent;<br />
@ISA = qw(hostent);<br />
<br />
sub addr { shift->addr_list(0,@_) } <br />
<br />
1;<br />
#-----------------------------<br />
<br />
</source><br />
== Cloning Objects ==<br />
<source lang="perl"><br />
#-----------------------------<br />
my $proto = shift;<br />
my $class = ref($proto) || $proto;<br />
<br />
my $parent = ref($proto) && $proto;<br />
#-----------------------------<br />
$ob1 = SomeClass-><br />
<br />
new()<br />
;<br />
# later on<br />
$ob2 = (ref $ob1)-><br />
new();<br />
<br />
#-----------------------------<br />
$ob1 = Widget->new();<br />
$ob2 = $ob1->new();<br />
#-----------------------------<br />
sub new {<br />
my $proto = shift;<br />
<br />
my $class = ref($proto) || $proto;<br />
my $parent = ref($proto) && $proto;<br />
<br />
my $self;<br />
# check whether we're shadowing a new from @ISA<br />
if (@ISA && $proto->SUPER::can('new') ) {<br />
<br />
$self = $proto->SUPER::new(@_);<br />
} else { <br />
$self = {};<br />
<br />
bless ($self, $proto);<br />
}<br />
bless($self, $class);<br />
<br />
$self->{PARENT} = $parent;<br />
$self->{START} = time(); # init data fields<br />
<br />
$self->{AGE} = 0;<br />
return $self;<br />
} <br />
<br />
#-----------------------------<br />
<br />
</source><br />
== Calling Methods Indirectly ==<br />
<source lang="perl"><br />
#-----------------------------<br />
$methname = "flicker";<br />
$obj->$methname(10); # calls $obj->flicker(10);<br />
<br />
# call three methods on the object, by name<br />
<br />
foreach $m ( qw(start run stop) ) {<br />
$obj-><br />
<br />
$m();<br />
<br />
} <br />
#-----------------------------<br />
@methods = qw(name rank serno);<br />
%his_info = map { $_ => $ob->$_() } @methods;<br />
<br />
# same as this:<br />
<br />
%his_info = (<br />
'name' => $ob-><br />
name()<br />
<br />
,<br />
'rank' => $ob-><br />
rank()<br />
,<br />
'serno' => $ob-><br />
<br />
serno()<br />
,<br />
);<br />
#-----------------------------<br />
my $fnref = sub { $ob->method(@_) };<br />
<br />
#-----------------------------<br />
$fnref->(10, "fred");<br />
#-----------------------------<br />
$obj->method(10, "fred");<br />
<br />
#-----------------------------<br />
$obj->can('method_name')->($obj_target, @arguments)<br />
if $obj_target->isa( ref $obj );<br />
<br />
#-----------------------------<br />
<br />
</source><br />
== Determining Subclass Membership ==<br />
<source lang="perl"><br />
#-----------------------------<br />
$obj->isa("HTTP::Message"); # as object method<br />
HTTP::Response->isa("HTTP::Message"); # as class method<br />
<br />
<br />
if ($obj->can("method_name")) { .... } # check method validity<br />
#-----------------------------<br />
$has_io = $fd->isa("IO::Handle");<br />
<br />
$itza_handle = IO::Socket->isa("IO::Handle");<br />
#-----------------------------<br />
$his_print_method = $obj->can('as_string');<br />
#-----------------------------<br />
Some_Module->VERSION(3.0);<br />
<br />
$his_vers = $obj-><br />
VERSION()<br />
;<br />
#-----------------------------<br />
use Some_Module 3.0;<br />
#-----------------------------<br />
use vars qw($VERSION);<br />
<br />
$VERSION = '1.01';<br />
#-----------------------------<br />
<br />
</source><br />
== Writing an Inheritable Class ==<br />
<source lang="perl"><br />
#-----------------------------<br />
package Person;<br />
sub new {<br />
<br />
my $class = shift;<br />
my $self = { };<br />
<br />
return bless $self, $class;<br />
} <br />
sub name {<br />
<br />
my $self = shift;<br />
$self->{NAME} = shift if @_;<br />
<br />
return $self->{NAME};<br />
} <br />
sub age {<br />
<br />
my $self = shift;<br />
$self->{AGE} = shift if @_;<br />
<br />
return $self->{AGE};<br />
} <br />
#-----------------------------<br />
use Person;<br />
<br />
my $dude = Person-><br />
new()<br />
;<br />
$dude->name("Jason");<br />
<br />
$dude->age(23);<br />
printf "%s is age %d.\n", $dude->name, $dude->age;<br />
<br />
#-----------------------------<br />
package Employee;<br />
use Person;<br />
@ISA = ("Person");<br />
<br />
1;<br />
#-----------------------------<br />
use Employee;<br />
my $empl = Employee-><br />
new()<br />
<br />
;<br />
$empl->name("Jason");<br />
$empl->age(23);<br />
printf "%s is age %d.\n", $empl->name, $empl->age;<br />
<br />
#-----------------------------<br />
$him = Person::<br />
new()<br />
; # WRONG<br />
#-----------------------------<br />
<br />
</source><br />
== Accessing Overridden Methods ==<br />
<source lang="perl"><br />
#-----------------------------<br />
sub meth { <br />
my $self = shift;<br />
<br />
$self->SUPER::<br />
meth()<br />
;<br />
}<br />
#-----------------------------<br />
$self-><br />
meth();<br />
# Call wherever first meth is found<br />
<br />
$self->Where::<br />
meth();<br />
# Start looking in package "Where"<br />
$self->SUPER::<br />
meth(); <br />
# Call overridden version<br />
#-----------------------------<br />
sub new {<br />
<br />
my $classname = shift; # What class are we constructing?<br />
my $self = $classname->SUPER::new(@_);<br />
<br />
$self->_init(@_);<br />
return $self; # And give it back<br />
} <br />
<br />
sub _init {<br />
my $self = shift;<br />
$self->{START} = time(); # init data fields<br />
<br />
$self->{AGE} = 0;<br />
$self->{EXTRA} = { @_ }; # anything extra<br />
<br />
}<br />
#-----------------------------<br />
$obj = Widget->new( haircolor => red, freckles => 121 );<br />
<br />
#-----------------------------<br />
my $self = bless {}, $class;<br />
for my $class (@ISA) {<br />
<br />
my $meth = $class . "::_init";<br />
$self->$meth(@_) if $class->can("_init");<br />
<br />
} <br />
#-----------------------------<br />
<br />
</source><br />
== Generating Attribute Methods Using AUTOLOAD ==<br />
<source lang="perl"><br />
#-----------------------------<br />
package Person;<br />
use strict;<br />
use Carp;<br />
<br />
use vars qw($AUTOLOAD %ok_field);<br />
<br />
# Authorize four attribute fields<br />
for my $attr ( qw(name age peers parent) ) { $ok_field{$attr}++; } <br />
<br />
sub AUTOLOAD {<br />
my $self = shift;<br />
my $attr = $AUTOLOAD;<br />
<br />
$attr =~ s/.*:://;<br />
return unless $attr =~ /[^A-Z]/; # skip DESTROY and all-cap methods<br />
<br />
croak "invalid attribute method: -><br />
$attr()"<br />
unless $ok_field{$attr};<br />
$self->{uc $attr} = shift if @_;<br />
<br />
return $self->{uc $attr};<br />
}<br />
sub new {<br />
<br />
my $proto = shift;<br />
my $class = ref($proto) || $proto;<br />
<br />
my $parent = ref($proto) && $proto;<br />
my $self = {};<br />
<br />
bless($self, $class);<br />
$self->parent($parent);<br />
return $self;<br />
<br />
} <br />
1;<br />
#-----------------------------<br />
use Person;<br />
my ($dad, $kid);<br />
<br />
$dad = Person->new;<br />
$dad->name("Jason");<br />
$dad->age(23);<br />
$kid = $dad->new;<br />
<br />
$kid->name("Rachel");<br />
$kid->age(2);<br />
printf "Kid's parent is %s\n", $kid->parent->name;<br />
<br />
#Kid's parent is Jason<br />
#-----------------------------<br />
sub AUTOLOAD {<br />
my $self = shift;<br />
my $attr = $AUTOLOAD;<br />
<br />
$attr =~ s/.*:://;<br />
return if $attr eq 'DESTROY'; <br />
<br />
if ($ok_field{$attr}) {<br />
$self->{uc $attr} = shift if @_;<br />
<br />
return $self->{uc $attr};<br />
} else {<br />
<br />
my $superior = "SUPER::$attr";<br />
$self->$superior(@_);<br />
} <br />
<br />
}<br />
#-----------------------------<br />
<br />
</source><br />
== Solving the Data Inheritance Problem ==<br />
<source lang="perl"><br />
#-----------------------------<br />
sub Employee::age {<br />
my $self = shift;<br />
<br />
$self->{Employee_age} = shift if @_;<br />
return $self->{Employee_age};<br />
<br />
} <br />
#-----------------------------<br />
package Person;<br />
use Class::Attributes; # see explanation below<br />
mkattr qw(name age peers parent);<br />
<br />
#-----------------------------<br />
package Employee;<br />
@ISA = qw(Person);<br />
use Class::Attributes;<br />
<br />
mkattr qw(salary age boss);<br />
#-----------------------------<br />
package Class::Attributes;<br />
use strict;<br />
<br />
use Carp;<br />
use Exporter ();<br />
use vars qw(@ISA @EXPORT);<br />
<br />
@ISA = qw(Exporter);<br />
@EXPORT = qw(mkattr);<br />
sub mkattr {<br />
<br />
my $hispack = caller();<br />
for my $attr (@_) {<br />
<br />
my($field, $method);<br />
$method = "${hispack}::$attr";<br />
($field = $method) =~ s/:/_/g; <br />
<br />
no strict 'refs'; # here comes the kluglich bit<br />
*$method = sub {<br />
my $self = shift;<br />
<br />
confess "too many arguments" if @_ > 1;<br />
$self->{$field} = shift if @_;<br />
<br />
return $self->{$field}; <br />
};<br />
} <br />
} <br />
<br />
1;<br />
#-----------------------------<br />
<br />
</source><br />
== Coping with Circular Data Structures ==<br />
<source lang="perl"><br />
#-----------------------------<br />
$node->{NEXT} = $node;<br />
#-----------------------------<br />
package Ring;<br />
<br />
# return an empty ring structure<br />
sub new {<br />
my $class = shift;<br />
<br />
my $node = { };<br />
$node->{NEXT} = $node->{PREV} = $node;<br />
<br />
my $self = { DUMMY => $node, COUNT => 0 };<br />
<br />
bless $self, $class;<br />
return $self;<br />
}<br />
#-----------------------------<br />
use Ring;<br />
<br />
$COUNT = 1000;<br />
for (1 .. 20) { <br />
<br />
my $r = Ring-><br />
new()<br />
;<br />
for ($i = 0; $i < $COUNT; $i++) { $r->insert($i) } <br />
<br />
}<br />
#-----------------------------<br />
# when a Ring is destroyed, destroy the ring structure it contains <br />
sub DESTROY {<br />
my $ring = shift;<br />
<br />
my $node;<br />
for ( $node = $ring->{DUMMY}->{NEXT};<br />
<br />
$node != $ring->{DUMMY}; <br />
$node = $node->{NEXT} )<br />
{<br />
<br />
$ring->delete_node($node);<br />
} <br />
$node->{PREV} = $node->{NEXT} = undef;<br />
<br />
} <br />
<br />
# delete a node from the ring structure<br />
sub delete_node {<br />
my ($ring, $node) = @_;<br />
<br />
$node->{PREV}->{NEXT} = $node->{NEXT};<br />
$node->{NEXT}->{PREV} = $node->{PREV};<br />
<br />
--$ring->{COUNT};<br />
} <br />
#-----------------------------<br />
# $node = $ring->search( $value ) : find $value in the ring<br />
# structure in $node<br />
sub search {<br />
<br />
my ($ring, $value) = @_;<br />
my $node = $ring->{DUMMY}->{NEXT};<br />
<br />
while ($node != $ring->{DUMMY} && $node->{VALUE} != $value) {<br />
<br />
$node = $node->{NEXT};<br />
}<br />
return $node;<br />
} <br />
<br />
# $ring->insert( $value ) : insert $value into the ring structure<br />
sub insert {<br />
my ($ring, $value) = @_;<br />
<br />
my $node = { VALUE => $value };<br />
$node->{NEXT} = $ring->{DUMMY}->{NEXT};<br />
<br />
$ring->{DUMMY}->{NEXT}->{PREV} = $node;<br />
<br />
$ring->{DUMMY}->{NEXT} = $node;<br />
$node->{PREV} = $ring->{DUMMY};<br />
<br />
++$ring->{COUNT};<br />
} <br />
<br />
# $ring->delete_value( $value ) : delete a node from the ring<br />
# structure by value<br />
sub delete_value {<br />
<br />
my ($ring, $value) = @_;<br />
my $node = $ring->search($value);<br />
<br />
return if $node == $ring->{DUMMY};<br />
$ring->delete_node($node);<br />
<br />
}<br />
<br />
<br />
1;<br />
#-----------------------------<br />
<br />
</source><br />
== Overloading Operators ==<br />
<source lang="perl"><br />
#-----------------------------<br />
use overload ('<=>' => \&threeway_compare);<br />
<br />
sub threeway_compare {<br />
my ($s1, $s2) = @_;<br />
<br />
return uc($s1->{NAME}) cmp uc($s2->{NAME});<br />
<br />
} <br />
<br />
use overload ( '""' => \&stringify );<br />
<br />
sub stringify {<br />
my $self = shift;<br />
return sprintf "%s (%05d)", <br />
<br />
ucfirst(lc($self->{NAME})),<br />
$self->{IDNUM};<br />
}<br />
#-----------------------------<br />
<br />
package TimeNumber;<br />
use overload '+' => \&my_plus,<br />
'-' => \&my_minus,<br />
'*' => \&my_star,<br />
'/' => \&my_slash;<br />
<br />
#-----------------------------<br />
sub my_plus {<br />
my($left, $right) = @_;<br />
<br />
my $answer = $left-><br />
new();<br />
<br />
$answer->{SECONDS} = $left->{SECONDS} + $right->{SECONDS};<br />
<br />
$answer->{MINUTES} = $left->{MINUTES} + $right->{MINUTES};<br />
$answer->{HOURS} = $left->{HOURS} + $right->{HOURS};<br />
<br />
if ($answer->{SECONDS} >= 60) {<br />
$answer->{SECONDS} %= 60;<br />
<br />
$answer->{MINUTES} ++;<br />
} <br />
<br />
if ($answer->{MINUTES} >= 60) {<br />
<br />
$answer->{MINUTES} %= 60;<br />
$answer->{HOURS} ++;<br />
<br />
} <br />
<br />
return $answer;<br />
<br />
} <br />
#-----------------------------<br />
#!/usr/bin/perl<br />
# show_strnum - demo operator overloading<br />
use StrNum; <br />
<br />
<br />
$x = StrNum("Red"); $y = StrNum("Black");<br />
$z = $x + $y; $r = $z * 3;<br />
<br />
print "values are $x, $y, $z, and $r\n";<br />
print "$x is ", $x < $y ? "LT" : "GE", " $y\n";<br />
<br />
# values are Red, Black, RedBlack, and RedBlackRedBlackRedBlack<br />
# Red is GE Black<br />
#-----------------------------<br />
# download the following standalone program<br />
package StrNum;<br />
<br />
use Exporter ();<br />
@ISA = 'Exporter';<br />
<br />
@EXPORT = qw(StrNum); # unusual<br />
<br />
use overload (<br />
'<=>' => \&spaceship,<br />
'cmp' => \&spaceship,<br />
'""' => \&stringify,<br />
'bool' => \&boolify,<br />
'0+' => \&numify,<br />
'+' => \&concat,<br />
'*' => \&repeat,<br />
<br />
);<br />
<br />
# constructor<br />
sub StrNum($) { <br />
my ($value) = @_; <br />
<br />
return bless \$value; <br />
} <br />
<br />
sub stringify { ${ $_[0] } } <br />
<br />
sub numify { ${ $_[0] } } <br />
<br />
sub boolify { ${ $_[0] } } <br />
<br />
# providing <=> gives us <, ==, etc. for free.<br />
sub spaceship { <br />
my ($s1, $s2, $inverted) = @_;<br />
<br />
return $inverted ? $$s2 cmp $$s1 : $$s1 cmp $$s2;<br />
} <br />
<br />
# this uses stringify<br />
<br />
sub concat { <br />
my ($s1, $s2, $inverted) = @_;<br />
<br />
return StrNum $inverted ? ($s2 . $s1) : ($s1 . $s2);<br />
} <br />
<br />
# this uses stringify<br />
sub repeat { <br />
my ($s1, $s2, $inverted) = @_;<br />
<br />
return StrNum $inverted ? ($s2 x $s1) : ($s1 x $s2);<br />
<br />
}<br />
<br />
1;<br />
<br />
#-----------------------------<br />
#!/usr/bin/perl<br />
# demo_fixnum - show operator overloading<br />
use FixNum;<br />
<br />
FixNum->places(5);<br />
<br />
$x = FixNum->new(40);<br />
$y = FixNum->new(12);<br />
<br />
print "sum of $x and $y is ", $x + $y, "\n";<br />
<br />
print "product of $x and $y is ", $x * $y, "\n";<br />
<br />
$z = $x / $y;<br />
printf "$z has %d places\n", $z->places;<br />
<br />
$z->places(2) unless $z->places;<br />
print "div of $x by $y is $z\n";<br />
<br />
print "square of that is ", $z * $z, "\n";<br />
<br />
sum of STRFixNum: 40 and STRFixNum: 12 is STRFixNum: 52<br />
<br />
product of STRFixNum: 40 and STRFixNum: 12 is STRFixNum: 480<br />
<br />
STRFixNum: 3 has 0 places<br />
<br />
div of STRFixNum: 40 by STRFixNum: 12 is STRFixNum: 3.33<br />
<br />
square of that is STRFixNum: 11.11<br />
#-----------------------------<br />
# download the following standalone program<br />
package FixNum;<br />
<br />
use strict;<br />
<br />
my $PLACES = 0;<br />
<br />
sub new {<br />
my $proto = shift;<br />
<br />
my $class = ref($proto) || $proto;<br />
my $parent = ref($proto) && $proto;<br />
<br />
my $v = shift;<br />
my $self = {<br />
<br />
VALUE => $v,<br />
PLACES => undef,<br />
}; <br />
if ($parent && defined $parent->{PLACES}) {<br />
<br />
$self->{PLACES} = $parent->{PLACES};<br />
} elsif ($v =~ /(\.\d*)/) {<br />
<br />
$self->{PLACES} = length($1) - 1;<br />
<br />
} else {<br />
$self->{PLACES} = 0;<br />
<br />
} <br />
return bless $self, $class;<br />
} <br />
<br />
sub places {<br />
<br />
my $proto = shift;<br />
my $self = ref($proto) && $proto;<br />
<br />
my $type = ref($proto) || $proto;<br />
<br />
if (@_) {<br />
<br />
my $places = shift;<br />
($self ? $self->{PLACES} : $PLACES) = $places;<br />
<br />
} <br />
return $self ? $self->{PLACES} : $PLACES;<br />
} <br />
<br />
sub _max { $_[0] > $_[1] ? $_[0] : $_[1] } <br />
<br />
use overload '+' => \&add,<br />
'*' => \&multiply,<br />
'/' => \&divide,<br />
'<=>' => \&spaceship,<br />
'""' => \&as_string,<br />
'0+' => \&as_number;<br />
<br />
sub add {<br />
my ($this, $that, $flipped) = @_;<br />
<br />
<br />
my $result = $this->new( $this->{VALUE} + $that->{VALUE} );<br />
<br />
$result->places( _max($this->{PLACES}, $that->{PLACES} ));<br />
<br />
return $result;<br />
} <br />
<br />
sub multiply {<br />
my ($this, $that, $flipped) = @_;<br />
<br />
my $result = $this->new( $this->{VALUE} * $that->{VALUE} );<br />
<br />
$result->places( _max($this->{PLACES}, $that->{PLACES} ));<br />
<br />
return $result;<br />
} <br />
<br />
sub divide {<br />
my ($this, $that, $flipped) = @_;<br />
<br />
my $result = $this->new( $this->{VALUE} / $that->{VALUE} );<br />
<br />
$result->places( _max($this->{PLACES}, $that->{PLACES} ));<br />
<br />
return $result;<br />
} <br />
<br />
sub as_string {<br />
my $self = shift;<br />
<br />
return sprintf("STR%s: %.*f", ref($self), <br />
<br />
defined($self->{PLACES}) ? $self->{PLACES} : $PLACES, <br />
$self->{VALUE});<br />
<br />
} <br />
<br />
sub as_number {<br />
my $self = shift;<br />
<br />
return $self->{VALUE};<br />
} <br />
<br />
sub spaceship {<br />
<br />
my ($this, $that, $flipped) = @_;<br />
$this->{VALUE} <=> $that->{VALUE};<br />
<br />
} <br />
<br />
1;<br />
<br />
#-----------------------------<br />
<br />
</source><br />
== Creating Magic Variables with tie ==<br />
<source lang="perl"><br />
#-----------------------------<br />
tie $s, "SomeClass"<br />
#-----------------------------<br />
<br />
SomeClass-><br />
TIESCALAR()<br />
#-----------------------------<br />
$p = $s<br />
#-----------------------------<br />
$p = $obj-><br />
FETCH()<br />
#-----------------------------<br />
$s = 10<br />
<br />
#-----------------------------<br />
$obj->STORE(10)<br />
#-----------------------------<br />
#!/usr/bin/perl<br />
# demo_valuering - show tie class<br />
use ValueRing;<br />
tie $color, 'ValueRing', qw(red blue);<br />
<br />
print "$color $color $color $color $color $color\n";<br />
red blue red blue red blue<br />
<br />
<br />
$color = 'green';<br />
print "$color $color $color $color $color $color\n";<br />
green red blue green red blue<br />
#-----------------------------<br />
# download the following standalone program<br />
<br />
package ValueRing;<br />
<br />
# this is the constructor for scalar ties<br />
sub TIESCALAR {<br />
my ($class, @values) = @_;<br />
<br />
bless \@values, $class;<br />
return \@values;<br />
} <br />
<br />
# this intercepts read accesses<br />
sub FETCH {<br />
my $self = shift;<br />
<br />
push(@$self, shift(@$self));<br />
return $self->[-1];<br />
<br />
} <br />
<br />
# this intercepts write accesses<br />
sub STORE {<br />
my ($self, $value) = @_;<br />
<br />
unshift @$self, $value;<br />
return $value;<br />
} <br />
<br />
1;<br />
<br />
#-----------------------------<br />
no UnderScore;<br />
#-----------------------------<br />
#!/usr/bin/perl<br />
# nounder_demo - show how to ban $_ from your program<br />
no UnderScore;<br />
@tests = (<br />
<br />
"Assignment" => sub { $_ = "Bad" },<br />
"Reading" => sub { print }, <br />
<br />
"Matching" => sub { $x = /badness/ },<br />
"Chop" => sub { chop },<br />
"Filetest" => sub { -x }, <br />
<br />
"Nesting" => sub { for (1..3) { print } },<br />
<br />
);<br />
<br />
while ( ($name, $code) = splice(@tests, 0, 2) ) {<br />
<br />
print "Testing $name: ";<br />
eval { &$code };<br />
print $@ ? "detected" : "missed!";<br />
<br />
print "\n";<br />
} <br />
#-----------------------------<br />
Testing Assignment: detected<br />
<br />
Testing Reading: detected<br />
<br />
Testing Matching: detected<br />
<br />
Testing Chop: detected<br />
<br />
Testing Filetest: detected<br />
<br />
Testing Nesting: 123missed!<br />
#-----------------------------<br />
# download the following standalone program<br />
package UnderScore;<br />
<br />
use Carp;<br />
sub TIESCALAR {<br />
my $class = shift;<br />
<br />
my $dummy;<br />
return bless \$dummy => $class;<br />
} <br />
<br />
sub FETCH { croak "Read access to \$_ forbidden" } <br />
sub STORE { croak "Write access to \$_ forbidden" } <br />
<br />
sub unimport { tie($_, _ _PACKAGE_ _) }<br />
sub import { untie $_ } <br />
<br />
tie($_, _ _PACKAGE_ _) unless tied $_;<br />
1;<br />
<br />
#-----------------------------<br />
#!/usr/bin/perl <br />
<br />
# appendhash_demo - show magic hash that autoappends<br />
use Tie::AppendHash;<br />
tie %tab, 'Tie::AppendHash';<br />
<br />
$tab{beer} = "guinness";<br />
<br />
$tab{food} = "potatoes";<br />
$tab{food} = "peas";<br />
<br />
while (my($k, $v) = each %tab) {<br />
<br />
print "$k => [@$v]\n";<br />
}<br />
#-----------------------------<br />
food => [potatoes peas]<br />
<br />
beer => [guinness]<br />
#-----------------------------<br />
# download the following standalone program<br />
package Tie::AppendHash;<br />
use strict;<br />
<br />
use Tie::Hash;<br />
use Carp;<br />
use vars qw(@ISA);<br />
<br />
@ISA = qw(Tie::StdHash);<br />
sub STORE {<br />
my ($self, $key, $value) = @_;<br />
<br />
push @{$self->{key}}, $value;<br />
} <br />
1;<br />
<br />
#-----------------------------<br />
#!/usr/bin/perl <br />
# folded_demo - demo hash that magically folds case<br />
use Tie::Folded;<br />
tie %tab, 'Tie::Folded';<br />
<br />
$tab{VILLAIN} = "big "; <br />
$tab{herOine} = "red riding hood";<br />
<br />
$tab{villain} .= "bad wolf"; <br />
<br />
while ( my($k, $v) = each %tab ) {<br />
<br />
print "$k is $v\n";<br />
}<br />
#-----------------------------<br />
heroine is red riding hood<br />
<br />
villain is big bad wolf<br />
#-----------------------------<br />
<br />
# download the following standalone program<br />
package Tie::Folded;<br />
<br />
use strict;<br />
use Tie::Hash;<br />
use vars qw(@ISA);<br />
<br />
@ISA = qw(Tie::StdHash);<br />
sub STORE {<br />
my ($self, $key, $value) = @_;<br />
<br />
return $self->{lc $key} = $value;<br />
} <br />
<br />
sub FETCH {<br />
my ($self, $key) = @_;<br />
<br />
return $self->{lc $key};<br />
} <br />
sub EXISTS {<br />
<br />
my ($self, $key) = @_;<br />
return exists $self->{lc $key};<br />
<br />
} <br />
sub DEFINED {<br />
my ($self, $key) = @_;<br />
<br />
return defined $self->{lc $key};<br />
} <br />
1;<br />
<br />
#-----------------------------<br />
#!/usr/bin/perl -w<br />
# revhash_demo - show hash that permits key *or* value lookups<br />
use strict;<br />
use Tie::RevHash;<br />
my %tab;<br />
<br />
tie %tab, 'Tie::RevHash';<br />
%tab = qw{<br />
Red Rojo<br />
Blue Azul<br />
Green Verde<br />
};<br />
<br />
$tab{EVIL} = [ "No way!", "Way!!" ];<br />
<br />
while ( my($k, $v) = each %tab ) {<br />
<br />
print ref($k) ? "[@$k]" : $k, " => ",<br />
ref($v) ? "[@$v]" : $v, "\n";<br />
<br />
} <br />
#-----------------------------<br />
[No way! Way!!] => EVIL<br />
<br />
EVIL => [No way! Way!!]<br />
<br />
Blue => Azul<br />
<br />
Green => Verde<br />
<br />
Rojo => Red<br />
<br />
Red => Rojo<br />
<br />
Azul => Blue<br />
<br />
Verde => Green<br />
#-----------------------------<br />
# download the following standalone program<br />
package Tie::RevHash;<br />
<br />
use Tie::RefHash;<br />
use vars qw(@ISA);<br />
@ISA = qw(Tie::RefHash);<br />
<br />
sub STORE {<br />
my ($self, $key, $value) = @_;<br />
<br />
$self->SUPER::STORE($key, $value);<br />
$self->SUPER::STORE($value, $key);<br />
}<br />
<br />
sub DELETE {<br />
my ($self, $key) = @_;<br />
<br />
my $value = $self->SUPER::FETCH($key);<br />
$self->SUPER::DELETE($key);<br />
<br />
$self->SUPER::DELETE($value);<br />
}<br />
<br />
1;<br />
<br />
#-----------------------------<br />
use Counter;<br />
<br />
tie *CH, 'Counter';<br />
while (<CH>) {<br />
print "Got $_\n";<br />
<br />
} <br />
#-----------------------------<br />
# download the following standalone program<br />
package Counter;<br />
sub TIEHANDLE {<br />
<br />
my $class = shift;<br />
my $start = shift;<br />
<br />
return bless \$start => $class;<br />
} <br />
sub READLINE {<br />
<br />
my $self = shift;<br />
return ++$$self;<br />
} <br />
<br />
1;<br />
<br />
#-----------------------------<br />
use Tie::Tee;<br />
tie *TEE, 'Tie::Tee', *STDOUT, *STDERR;<br />
<br />
print TEE "This line goes both places.\n";<br />
#-----------------------------<br />
#!/usr/bin/perl<br />
# demo_tietee<br />
use Tie::Tee;<br />
use Symbol;<br />
<br />
@handles = (*STDOUT);<br />
for $i ( 1 .. 10 ) {<br />
<br />
push(@handles, $handle = gensym());<br />
open($handle, ">/tmp/teetest.$i");<br />
} <br />
<br />
tie *TEE, 'Tie::Tee', @handles;<br />
print TEE "This lines goes many places.\n";<br />
#-----------------------------<br />
# download the following standalone program<br />
<br />
package Tie::Tee;<br />
<br />
sub TIEHANDLE {<br />
my $class = shift;<br />
<br />
my $handles = [@_];<br />
<br />
bless $handles, $class;<br />
<br />
return $handles;<br />
}<br />
<br />
sub PRINT {<br />
my $href = shift;<br />
<br />
my $handle;<br />
my $success = 0;<br />
<br />
foreach $handle (@$href) {<br />
<br />
$success += print $handle @_;<br />
}<br />
<br />
return $success == @$href;<br />
<br />
} <br />
<br />
1;<br />
<br />
#-----------------------------<br />
<br />
</source><br />
<br />
{{Perl_Footer}}</div>
Root