Perl/FAQ/Классы, Объекты и связи

#-----------------------------
$object = {};                       # hash reference
bless($object, "Data::Encoder");    # bless $object into Data::Encoder class
 
bless($object);                     # bless $object into current package
#-----------------------------
$obj = [3,5];
print ref($obj), " ", $obj->[1], "\n";
 
bless($obj, "Human::Cannibal");
print ref($obj), " ", $obj->[1], "\n";
 
ARRAY 5
 
Human::Cannibal 5
#-----------------------------
$obj->{Stomach} = "Empty";   # directly accessing an object's contents
 
$obj->{NAME}    = "Thag";        # uppercase field name to make it stand out (optional)
#-----------------------------
$encoded = $object->encode("data");
#-----------------------------
 
$encoded = Data::Encoder->encode("data");
#-----------------------------
sub new {
    my $class = shift;
 
    my $self  = {};         # allocate new hash for object
    bless($self, $class);
    return $self;
 
}
#-----------------------------
$object = Class->new();
#-----------------------------
$object = Class::new("Class");
#-----------------------------
sub class_only_method {
 
    my $class = shift;
    die "class method called on object" if ref $class;
 
    # more code here
} 
#-----------------------------
sub instance_only_method {
    my $self = shift;
 
    die "instance method called on class" unless ref $self;
    # more code here
} 
 
#-----------------------------
$lector = new Human::Cannibal;
feed $lector "Zak";
move $lector "New York";
#-----------------------------
$lector = Human::Cannibal->
new();
 
$lector->feed("Zak");
$lector->move("New York");
#-----------------------------
printf STDERR "stuff here\n";
 
#-----------------------------
move $obj->{FIELD};                 # probably wrong
move $ary[$i];                      # probably wrong
#-----------------------------
$obj->move->{FIELD};                # Surprise!
 
$ary->move->[$i];                   # Surprise!
#-----------------------------
$obj->{FIELD}->
move()
;              # Nope, you wish
 
$ary[$i]->
move;
                     # Nope, you wish
#-----------------------------

#-----------------------------
sub new {
 
    my $class = shift;
    my $self  = { };
 
    bless($self, $class);
    return $self;
} 
#-----------------------------
sub new { bless( { }, shift ) }
 
#-----------------------------
sub new { bless({}) }
#-----------------------------
sub new {
 
    my $self = { };  # allocate anonymous hash
    bless($self);
 
    # init two sample attributes/data members/fields
    $self->{START} = time();  
    $self->{AGE}   = 0;
 
    return $self;
} 
#-----------------------------
sub new {
    my $classname  = shift;         # What class are we constructing?
 
    my $self      = {};             # Allocate new memory
    bless($self, $classname);       # Mark it of the right type
    $self->{START}  = 
 
time();
       # init data fields
    $self->{AGE}    = 
0;
 
    return $self;                   # And give it back
} 
#-----------------------------
sub new {
 
    my $classname  = shift;         # What class are we constructing?
    my $self      = {};             # Allocate new memory
 
    bless($self, $classname);       # Mark it of the right type
    $self->_init(@_);               # Call _init with remaining args
    return $self;
 
} 
 
# "private" method to initialize fields.  It always sets START to
# the current time, and AGE to 0.  If called with arguments, _init
# interprets them as key+value pairs to initialize the object with.
sub _init {
    my $self = shift;
 
    $self->{START} = 
time();
 
    $self->{AGE}   = 0;
 
    if (@_) {
        my %extra = @_;
 
        @$self{keys %extra} = values %extra;
    } 
 
} 
#-----------------------------

#-----------------------------
sub DESTROY {
    my $self = shift;
 
    printf("$self dying at %s\n", scalar localtime);
} 
#-----------------------------
 
$self->{WHATEVER} = $self;
 
#-----------------------------

#-----------------------------
sub get_name {
    my $self = shift;
 
    return $self->{NAME};
} 
 
sub set_name {
 
    my $self      = shift;
    $self->{NAME} = shift;
 
} 
#-----------------------------
sub name {
    my $self = shift;
 
    if (@_) { $self->{NAME} = shift } 
 
    return $self->{NAME};
} 
#-----------------------------
sub age {
 
    my $self = shift;
    my $prev = $self->{AGE};
 
    if (@_) { $self->{AGE} = shift } 
 
    return $prev;
} 
# sample call of get and set: happy birthday!
$obj->age( 1 + $obj->age );
 
#-----------------------------
$him = Person->
new()
;
$him->{NAME} = "Sylvester";
 
$him->{AGE}  = 23;
#-----------------------------
use Carp;
sub name {
 
    my $self = shift;
    return $self->{NAME} unless @_;
 
    local $_ = shift;
    croak "too many arguments" if @_;
 
    if ($^W) {
        /[^\s\w'-]/         && carp "funny characters in name"; #'
 
        /\d/                && carp "numbers in name";
        /\S+(\s+\S+)+/      || carp "prefer multiword name";
        /\S/                || carp "name is blank";
 
    } 
    s/(\w+)/\u\L$1/g;       # enforce capitalization
    $self->{NAME} = $_;
 
} 
#-----------------------------
package Person;
 
# this is the same as before...
sub new {
 
     my $that  = shift;
     my $class = ref($that) || $that;
 
     my $self = {
           NAME  => undef,
           AGE   => undef,
           PEERS => [],
    };
 
    bless($self, $class);
    return $self;
}
 
use Alias qw(attr);
 
use vars qw($NAME $AGE @PEERS);
 
sub name {
 
    my $self = attr shift;
    if (@_) { $NAME = shift; }
 
    return    $NAME;
};
 
sub age {
    my $self = attr shift;
 
    if (@_) { $AGE = shift; }
    return    $AGE;
 
}
 
sub peers {
    my $self = attr shift;
 
    if (@_) { @PEERS = @_; }
 
    return    @PEERS;
}
 
sub exclaim {
    my $self = attr shift;
 
    return sprintf "Hi, I'm %s, age %d, working with %s",
            $NAME, $AGE, join(", ", @PEERS);
 
}
 
sub happy_birthday {
    my $self = attr shift;
 
    return ++$AGE;
}
#-----------------------------

#-----------------------------
package Person;
 
$Body_Count = 0; 
 
sub population { return $Body_Count }
 
sub new {                                   # constructor
    $Body_Count++;
    return bless({}, shift);
 
}
 
sub DESTROY { --$BodyCount }                # destructor
 
# later, the user can say this:
package main;
 
for (1..10) { push @people, Person->new }
 
printf "There are %d people alive.\n", Person->population();
 
There are 10 people alive.
#-----------------------------
$him = Person->
 
new()
;
$him->gender("male");
 
$her = Person->
new()
 
;
$her->gender("female");
#-----------------------------
FixedArray->Max_Bounds(100);                # set for whole class
$alpha = FixedArray->new();
 
printf "Bound on alpha is %d\n", $alpha->Max_Bounds();
100
 
$beta = FixedArray->new();
$beta->Max_Bounds(50);                      # still sets for whole class
 
printf "Bound on alpha is %d\n", $alpha->Max_Bounds();
50
#-----------------------------
package FixedArray;
 
$Bounds = 7;  # default
sub new { bless( {}, shift ) }
 
sub Max_Bounds {
    my $proto  = shift;
    $Bounds    = shift if @_;          # allow updates
 
    return $Bounds;
} 
#-----------------------------
sub Max_Bounds { $Bounds }
 
#-----------------------------
sub new {
    my $class = shift;
    my $self = bless({}, $class);
 
    $self->{Max_Bounds_ref} = \$Bounds;
    return $self;
} 
 
#-----------------------------

#-----------------------------
use Class::Struct;          # load struct-building module
 
struct Person => {          # create a definition for a "Person"
 
    name   => '$',          #    name field is a scalar
    age    => '$',          #    age field is also a scalar
    peers  => '@',          #    but peers field is an array (reference)
 
};
 
my $p = Person->
new()
;      # allocate an empty Person struct
 
$p->name("Jason Smythe");                   # set its name field
 
$p->age(13);                                # set its age field
$p->peers( ["Wilbur", "Ralph", "Fred" ] );  # set its peers field
 
 
# or this way:
@{$p->peers} = ("Wilbur", "Ralph", "Fred");
 
# fetch various values, including the zeroth friend
printf "At age %d, %s's first friend is %s.\n",
    $p->age, $p->name, $p->peers(0);
 
#-----------------------------
use Class::Struct;
 
struct Person => {name => '$',      age  => '$'};  #'
 
struct Family => {head => 'Person', address => '$', members => '@'};  #'
 
$folks  = Family->
new();
 
$dad    = $folks->head;
$dad->name("John");
 
$dad->age(34);
 
printf("%s's age is %d\n", $folks->head->name, $folks->head->age);
 
#-----------------------------
sub Person::age {
    use Carp;
    my ($self, $age) = @_;
 
    if    (@_  > 2) {  confess "too many arguments" } 
 
    elsif (@_ == 1) {  return $struct->{'age'}      }
 
    elsif (@_ == 2) {
        carp "age `$age' isn't numeric"   if $age !~ /^\d+/;
 
        carp "age `$age' is unreasonable" if $age > 150;
        $self->{'age'} = $age;
 
    } 
} 
#-----------------------------
if ($^W) { 
 
    carp "age `$age' isn't numeric"   if $age !~ /^\d+/;
    carp "age `$age' is unreasonable" if $age > 150;
 
}
#-----------------------------
my $gripe = $^W ? \&carp : \&croak;
$gripe->("age `$age' isn't numeric")   if $age !~ /^\d+/;
 
$gripe->("age `$age' is unreasonable") if $age > 150;
#-----------------------------
struct Family => [head => 'Person', address => '$', members => '@'];  #'
 
#-----------------------------
struct Card => { 
    name    => '$',
    color   => '$',
    cost    => '$',
    type    => '$',
    release => '$',
    text    => '$',
 
};
#-----------------------------
struct Card => map { $_ => '$' } qw(name color cost type release text); #'
#-----------------------------
 
struct hostent => { reverse qw{
    $ name
    @ aliases
    $ addrtype
    $ length
    @ addr_list
 
}};
#-----------------------------
#define h_type h_addrtype
#define h_addr h_addr_list[0]
#-----------------------------
# make (hostent object)->
type()
 same as (hostent object)->
addrtype()
 
*hostent::type = \&hostent::addrtype;
 
# make (hostenv object)->
addr()
 same as (hostenv object)->addr_list(0)
 
sub hostent::addr { shift->addr_list(0,@_) }
 
#-----------------------------
package Extra::hostent;
use Net::hostent;
@ISA = qw(hostent);
 
sub addr { shift->addr_list(0,@_) } 
 
1;
#-----------------------------

#-----------------------------
my $proto  = shift;
my $class  = ref($proto) || $proto;
 
my $parent = ref($proto) && $proto;
#-----------------------------
$ob1 = SomeClass->
 
new()
;
# later on
$ob2 = (ref $ob1)->
new();
 
#-----------------------------
$ob1 = Widget->new();
$ob2 = $ob1->new();
#-----------------------------
sub new {
    my $proto  = shift;
 
    my $class  = ref($proto) || $proto;
    my $parent = ref($proto) && $proto;
 
    my $self;
    # check whether we're shadowing a new from @ISA
    if (@ISA && $proto->SUPER::can('new') ) {
 
        $self = $proto->SUPER::new(@_);
    } else { 
        $self = {};
 
        bless ($self, $proto);
    }
    bless($self, $class);
 
    $self->{PARENT}  = $parent;
    $self->{START}   = time();   # init data fields
 
    $self->{AGE}     = 0;
    return $self;
} 
 
#-----------------------------

#-----------------------------
$methname = "flicker";
$obj->$methname(10);         # calls $obj->flicker(10);
 
# call three methods on the object, by name
 
foreach $m ( qw(start run stop) ) {
    $obj->
 
$m();
 
} 
#-----------------------------
@methods = qw(name rank serno);
%his_info = map { $_ => $ob->$_() } @methods;
 
# same as this:
 
%his_info = (
    'name'  => $ob->
name()
 
,
    'rank'  => $ob->
rank()
,
    'serno' => $ob->
 
serno()
,
);
#-----------------------------
my $fnref = sub { $ob->method(@_) };
 
#-----------------------------
$fnref->(10, "fred");
#-----------------------------
$obj->method(10, "fred");
 
#-----------------------------
$obj->can('method_name')->($obj_target, @arguments)
   if $obj_target->isa( ref $obj );
 
#-----------------------------

#-----------------------------
$obj->isa("HTTP::Message");                  # as object method
HTTP::Response->isa("HTTP::Message");       # as class method
 
 
if ($obj->can("method_name")) { .... }       # check method validity
#-----------------------------
$has_io = $fd->isa("IO::Handle");
 
$itza_handle = IO::Socket->isa("IO::Handle");
#-----------------------------
$his_print_method = $obj->can('as_string');
#-----------------------------
Some_Module->VERSION(3.0);
 
$his_vers = $obj->
VERSION()
;
#-----------------------------
use Some_Module 3.0;
#-----------------------------
use vars qw($VERSION);
 
$VERSION = '1.01';
#-----------------------------

#-----------------------------
package Person;
sub new {
 
    my $class = shift;
    my $self  = { };
 
    return bless $self, $class;
} 
sub name {
 
    my $self = shift;
    $self->{NAME} = shift if @_;
 
    return $self->{NAME};
} 
sub age {
 
    my $self = shift;
    $self->{AGE} = shift if @_;
 
    return $self->{AGE};
} 
#-----------------------------
use Person;
 
my $dude = Person->
new()
;
$dude->name("Jason");
 
$dude->age(23);
printf "%s is age %d.\n", $dude->name, $dude->age;
 
#-----------------------------
package Employee;
use Person;
@ISA = ("Person");
 
1;
#-----------------------------
use Employee;
my $empl = Employee->
new()
 
;
$empl->name("Jason");
$empl->age(23);
printf "%s is age %d.\n", $empl->name, $empl->age;
 
#-----------------------------
$him = Person::
new()
;               # WRONG
#-----------------------------

#-----------------------------
sub meth { 
    my $self = shift;
 
    $self->SUPER::
meth()
;
}
#-----------------------------
$self->
meth();
                # Call wherever first meth is found
 
$self->Where::
meth();
         # Start looking in package "Where"
$self->SUPER::
meth(); 
        # Call overridden version
#-----------------------------
sub new {
 
    my $classname  = shift;         # What class are we constructing?
    my $self       = $classname->SUPER::new(@_);
 
    $self->_init(@_);
    return $self;                   # And give it back
} 
 
sub _init {
    my $self = shift;
    $self->{START}   = time();   # init data fields
 
    $self->{AGE}     = 0;
    $self->{EXTRA}   = { @_ };   # anything extra
 
}
#-----------------------------
$obj = Widget->new( haircolor => red, freckles => 121 );
 
#-----------------------------
my $self = bless {}, $class;
for my $class (@ISA) {
 
    my $meth = $class . "::_init";
    $self->$meth(@_) if $class->can("_init");
 
} 
#-----------------------------

#-----------------------------
package Person;
use strict;
use Carp;
 
use vars qw($AUTOLOAD %ok_field);
 
# Authorize four attribute fields
for my $attr ( qw(name age peers parent) ) { $ok_field{$attr}++; } 
 
sub AUTOLOAD {
    my $self = shift;
    my $attr = $AUTOLOAD;
 
    $attr =~ s/.*:://;
    return unless $attr =~ /[^A-Z]/;  # skip DESTROY and all-cap methods
 
    croak "invalid attribute method: ->
$attr()"
 unless $ok_field{$attr};
    $self->{uc $attr} = shift if @_;
 
    return $self->{uc $attr};
}
sub new {
 
    my $proto  = shift;
    my $class  = ref($proto) || $proto;
 
    my $parent = ref($proto) && $proto;
    my $self = {};
 
    bless($self, $class);
    $self->parent($parent);
    return $self;
 
} 
1;
#-----------------------------
use Person;
my ($dad, $kid);
 
$dad = Person->new;
$dad->name("Jason");
$dad->age(23);
$kid = $dad->new;
 
$kid->name("Rachel");
$kid->age(2);
printf "Kid's parent is %s\n", $kid->parent->name;
 
#Kid's parent is Jason
#-----------------------------
sub AUTOLOAD {
    my $self = shift;
    my $attr = $AUTOLOAD;
 
    $attr =~ s/.*:://;
    return if $attr eq 'DESTROY';   
 
    if ($ok_field{$attr}) {
        $self->{uc $attr} = shift if @_;
 
        return $self->{uc $attr};
    } else {
 
        my $superior = "SUPER::$attr";
        $self->$superior(@_);
    } 
 
}
#-----------------------------

#-----------------------------
sub Employee::age {
    my $self = shift;
 
    $self->{Employee_age} = shift if @_;
    return $self->{Employee_age};
 
} 
#-----------------------------
package Person;
use Class::Attributes;  # see explanation below
mkattr qw(name age peers parent);
 
#-----------------------------
package Employee;
@ISA = qw(Person);
use Class::Attributes;
 
mkattr qw(salary age boss);
#-----------------------------
package Class::Attributes;
use strict;
 
use Carp;
use Exporter ();
use vars qw(@ISA @EXPORT);
 
@ISA = qw(Exporter);
@EXPORT = qw(mkattr);
sub mkattr {
 
    my $hispack = caller();
    for my $attr (@_) {
 
        my($field, $method);
        $method = "${hispack}::$attr";
        ($field = $method) =~ s/:/_/g; 
 
        no strict 'refs'; # here comes the kluglich bit
        *$method = sub {
            my $self = shift;
 
            confess "too many arguments" if @_ > 1;
            $self->{$field} = shift if @_;
 
            return $self->{$field};   
        };
    } 
} 
 
1;
#-----------------------------

#-----------------------------
$node->{NEXT} = $node;
#-----------------------------
package Ring;
 
# return an empty ring structure
sub new {
    my $class = shift;
 
    my $node  = { };
    $node->{NEXT} = $node->{PREV} = $node;
 
    my $self  = { DUMMY => $node, COUNT => 0 };
 
    bless $self, $class;
    return $self;
}
#-----------------------------
use Ring;
 
$COUNT = 1000;
for (1 .. 20) { 
 
    my $r = Ring->
new()
;
    for ($i = 0; $i < $COUNT; $i++) { $r->insert($i) } 
 
}
#-----------------------------
# when a Ring is destroyed, destroy the ring structure it contains 
sub DESTROY {
    my $ring = shift;
 
    my $node;
    for ( $node  =  $ring->{DUMMY}->{NEXT};
 
          $node !=  $ring->{DUMMY}; 
          $node  =  $node->{NEXT} )
    {
 
             $ring->delete_node($node);
    } 
    $node->{PREV} = $node->{NEXT} = undef;
 
} 
 
# delete a node from the ring structure
sub delete_node {
    my ($ring, $node) = @_;
 
    $node->{PREV}->{NEXT} = $node->{NEXT};
    $node->{NEXT}->{PREV} = $node->{PREV};
 
    --$ring->{COUNT};
} 
#-----------------------------
# $node = $ring->search( $value ) : find $value in the ring
# structure in $node
sub search {
 
    my ($ring, $value) = @_;
    my $node = $ring->{DUMMY}->{NEXT};
 
    while ($node != $ring->{DUMMY} && $node->{VALUE} != $value) {
 
          $node = $node->{NEXT};
    }
    return $node;
} 
 
# $ring->insert( $value ) : insert $value into the ring structure
sub insert {
    my ($ring, $value) = @_;
 
    my $node = { VALUE => $value };
    $node->{NEXT} = $ring->{DUMMY}->{NEXT};
 
    $ring->{DUMMY}->{NEXT}->{PREV} = $node;
 
    $ring->{DUMMY}->{NEXT} = $node;
    $node->{PREV} = $ring->{DUMMY};
 
    ++$ring->{COUNT};
} 
 
# $ring->delete_value( $value ) : delete a node from the ring
# structure by value
sub delete_value {
 
    my ($ring, $value) = @_;
    my $node = $ring->search($value);
 
    return if $node == $ring->{DUMMY};
    $ring->delete_node($node);
 
}
 
 
1;
#-----------------------------

#-----------------------------
use overload ('<=>' => \&threeway_compare);
 
sub threeway_compare {
    my ($s1, $s2) = @_;
 
    return uc($s1->{NAME}) cmp uc($s2->{NAME});
 
} 
 
use overload ( '""'  => \&stringify );
 
sub stringify {
    my $self = shift;
    return sprintf "%s (%05d)", 
 
            ucfirst(lc($self->{NAME})),
            $self->{IDNUM};
}
#-----------------------------
 
package TimeNumber;
use overload '+' => \&my_plus,
             '-' => \&my_minus,
             '*' => \&my_star,
             '/' => \&my_slash;
 
#-----------------------------
sub my_plus {
    my($left, $right) = @_;
 
    my $answer = $left->
new();
 
    $answer->{SECONDS} = $left->{SECONDS} + $right->{SECONDS};
 
    $answer->{MINUTES} = $left->{MINUTES} + $right->{MINUTES};
    $answer->{HOURS}   = $left->{HOURS}   + $right->{HOURS};
 
    if ($answer->{SECONDS} >= 60) {
        $answer->{SECONDS} %= 60;
 
        $answer->{MINUTES} ++;
    } 
 
    if ($answer->{MINUTES} >= 60) {
 
        $answer->{MINUTES} %= 60;
        $answer->{HOURS}   ++;
 
    } 
 
    return $answer;
 
} 
#-----------------------------
#!/usr/bin/perl
# show_strnum - demo operator overloading
use StrNum;           
 
 
$x = StrNum("Red"); $y = StrNum("Black");
$z = $x + $y; $r = $z * 3;
 
print "values are $x, $y, $z, and $r\n";
print "$x is ", $x < $y ? "LT" : "GE", " $y\n";
 
# values are Red, Black, RedBlack, and RedBlackRedBlackRedBlack
# Red is GE Black
#-----------------------------
# download the following standalone program
package StrNum;
 
use Exporter ();
@ISA = 'Exporter';
 
@EXPORT = qw(StrNum);  # unusual
 
use overload        (
        '<=>'   => \&spaceship,
        'cmp'   => \&spaceship,
        '""'    => \&stringify,
        'bool'  => \&boolify,
        '0+'    => \&numify,
        '+'     => \&concat,
        '*'     => \&repeat,
 
);
 
# constructor
sub StrNum($) { 
    my ($value) = @_; 
 
    return bless \$value; 
} 
 
sub stringify { ${ $_[0] } } 
 
sub numify    { ${ $_[0] } } 
 
sub boolify   { ${ $_[0] } } 
 
# providing <=> gives us <, ==, etc. for free.
sub spaceship { 
    my ($s1, $s2, $inverted) = @_;
 
    return $inverted ? $$s2 cmp $$s1 : $$s1 cmp $$s2;
} 
 
# this uses stringify
 
sub concat { 
    my ($s1, $s2, $inverted) = @_;
 
    return StrNum $inverted ? ($s2 . $s1) : ($s1 . $s2);
} 
 
# this uses stringify
sub repeat { 
    my ($s1, $s2, $inverted) = @_;
 
    return StrNum $inverted ? ($s2 x $s1) : ($s1 x $s2);
 
}
 
1;
 
#-----------------------------
#!/usr/bin/perl
# demo_fixnum - show operator overloading
use FixNum;
 
FixNum->places(5);
 
$x = FixNum->new(40);
$y = FixNum->new(12);
 
print "sum of $x and $y is ", $x + $y, "\n";
 
print "product of $x and $y is ", $x * $y, "\n";
 
$z = $x / $y;
printf "$z has %d places\n", $z->places;
 
$z->places(2) unless $z->places;
print "div of $x by $y is $z\n";
 
print "square of that is ", $z * $z, "\n";
 
sum of STRFixNum: 40 and STRFixNum: 12 is STRFixNum: 52
 
product of STRFixNum: 40 and STRFixNum: 12 is STRFixNum: 480
 
STRFixNum: 3 has 0 places
 
div of STRFixNum: 40 by STRFixNum: 12 is STRFixNum: 3.33
 
square of that is STRFixNum: 11.11
#-----------------------------
# download the following standalone program
package FixNum;
 
use strict;
 
my $PLACES = 0;
 
sub new {
    my $proto   = shift;
 
    my $class   = ref($proto) || $proto;
    my $parent  = ref($proto) && $proto;
 
    my $v = shift;
    my $self = {
 
        VALUE  => $v,
        PLACES => undef,
    }; 
    if ($parent && defined $parent->{PLACES}) {
 
        $self->{PLACES} = $parent->{PLACES};
    } elsif ($v =~ /(\.\d*)/) {
 
        $self->{PLACES} = length($1) - 1;
 
    }  else {
        $self->{PLACES} = 0;
 
    } 
    return bless $self, $class;
} 
 
sub places {
 
    my $proto = shift;
    my $self  = ref($proto) && $proto;
 
    my $type  = ref($proto) || $proto;
 
    if (@_) {
 
        my $places = shift;
        ($self ? $self->{PLACES} : $PLACES) = $places;
 
    } 
    return $self ? $self->{PLACES} : $PLACES;
} 
 
sub _max { $_[0] > $_[1] ? $_[0] : $_[1] } 
 
use overload '+'    => \&add,
             '*'    => \&multiply,
             '/'    => \&divide,
             '<=>'  => \&spaceship,
             '""'   => \&as_string,
             '0+'   => \&as_number;
 
sub add {
    my ($this, $that, $flipped) = @_;
 
 
    my $result = $this->new( $this->{VALUE} + $that->{VALUE} );
 
    $result->places( _max($this->{PLACES}, $that->{PLACES} ));
 
    return $result;
} 
 
sub multiply {
    my ($this, $that, $flipped) = @_;
 
    my $result = $this->new( $this->{VALUE} * $that->{VALUE} );
 
    $result->places( _max($this->{PLACES}, $that->{PLACES} ));
 
    return $result;
} 
 
sub divide {
    my ($this, $that, $flipped) = @_;
 
    my $result = $this->new( $this->{VALUE} / $that->{VALUE} );
 
    $result->places( _max($this->{PLACES}, $that->{PLACES} ));
 
    return $result;
} 
 
sub as_string {
    my $self = shift;
 
    return sprintf("STR%s: %.*f", ref($self), 
 
        defined($self->{PLACES}) ? $self->{PLACES} : $PLACES, 
            $self->{VALUE});
 
} 
 
sub as_number {
    my $self = shift;
 
    return $self->{VALUE};
} 
 
sub spaceship {
 
    my ($this, $that, $flipped) = @_;
    $this->{VALUE} <=> $that->{VALUE};
 
} 
 
1;
 
#-----------------------------

#-----------------------------
tie $s, "SomeClass"
#-----------------------------
 
SomeClass->
TIESCALAR()
#-----------------------------
$p = $s
#-----------------------------
$p = $obj->
FETCH()
#-----------------------------
$s = 10
 
#-----------------------------
$obj->STORE(10)
#-----------------------------
#!/usr/bin/perl
# demo_valuering - show tie class
use ValueRing;
tie $color, 'ValueRing', qw(red blue);
 
print "$color $color $color $color $color $color\n";
red blue red blue red blue
 
 
$color = 'green';
print "$color $color $color $color $color $color\n";
green red blue green red blue
#-----------------------------
# download the following standalone program
 
package ValueRing;
 
# this is the constructor for scalar ties
sub TIESCALAR {
    my ($class, @values) = @_;
 
    bless  \@values, $class;
    return \@values;
} 
 
# this intercepts read accesses
sub FETCH {
    my $self = shift;
 
    push(@$self, shift(@$self));
    return $self->[-1];
 
} 
 
# this intercepts write accesses
sub STORE {
    my ($self, $value) = @_;
 
    unshift @$self, $value;
    return $value;
} 
 
1;
 
#-----------------------------
no UnderScore;
#-----------------------------
#!/usr/bin/perl
# nounder_demo - show how to ban $_ from your program
no UnderScore;
@tests = (
 
    "Assignment"  => sub { $_ = "Bad" },
    "Reading"     => sub { print }, 
 
    "Matching"    => sub { $x = /badness/ },
    "Chop"        => sub { chop },
    "Filetest"    => sub { -x }, 
 
    "Nesting"     => sub { for (1..3) { print } },
 
);
 
while ( ($name, $code) = splice(@tests, 0, 2) ) {
 
    print "Testing $name: ";
    eval { &$code };
    print $@ ? "detected" : "missed!";
 
    print "\n";
} 
#-----------------------------
Testing Assignment: detected
 
Testing Reading: detected
 
Testing Matching: detected
 
Testing Chop: detected
 
Testing Filetest: detected
 
Testing Nesting: 123missed!
#-----------------------------
# download the following standalone program
package UnderScore;
 
use Carp;
sub TIESCALAR {
    my $class = shift;
 
    my $dummy;
    return bless \$dummy => $class;
} 
 
sub FETCH { croak "Read access to \$_ forbidden"  } 
sub STORE { croak "Write access to \$_ forbidden" } 
 
sub unimport { tie($_, _     _PACKAGE_     _) }
sub import { untie $_ } 
 
tie($_, _     _PACKAGE_     _) unless tied $_;
1;
 
#-----------------------------
#!/usr/bin/perl 
 
# appendhash_demo - show magic hash that autoappends
use Tie::AppendHash;
tie %tab, 'Tie::AppendHash';
 
$tab{beer} = "guinness";
 
$tab{food} = "potatoes";
$tab{food} = "peas";
 
while (my($k, $v) = each %tab) {
 
    print "$k => [@$v]\n";
}
#-----------------------------
food => [potatoes peas]
 
beer => [guinness]
#-----------------------------
# download the following standalone program
package Tie::AppendHash;
use strict;
 
use Tie::Hash;
use Carp;
use vars qw(@ISA);
 
@ISA = qw(Tie::StdHash);
sub STORE {
    my ($self, $key, $value) = @_;
 
    push @{$self->{key}}, $value;
} 
1;
 
#-----------------------------
#!/usr/bin/perl 
# folded_demo - demo hash that magically folds case
use Tie::Folded;
tie %tab, 'Tie::Folded';
 
$tab{VILLAIN}  = "big "; 
$tab{herOine}  = "red riding hood";
 
$tab{villain} .= "bad wolf";   
 
while ( my($k, $v) = each %tab ) {
 
    print "$k is $v\n";
}
#-----------------------------
heroine is red riding hood
 
villain is big bad wolf
#-----------------------------
 
# download the following standalone program
package Tie::Folded;
 
use strict;
use Tie::Hash;
use vars qw(@ISA);
 
@ISA = qw(Tie::StdHash);
sub STORE {
    my ($self, $key, $value) = @_;
 
    return $self->{lc $key} = $value;
    } 
 
sub FETCH {
    my ($self, $key) = @_;
 
    return $self->{lc $key};
} 
sub EXISTS {
 
    my ($self, $key) = @_;
    return exists $self->{lc $key};
 
} 
sub DEFINED {
    my ($self, $key) = @_;
 
    return defined $self->{lc $key};
} 
1;
 
#-----------------------------
#!/usr/bin/perl -w
# revhash_demo - show hash that permits key *or* value lookups
use strict;
use Tie::RevHash;
my %tab;
 
tie %tab, 'Tie::RevHash';
%tab = qw{
    Red         Rojo
    Blue        Azul
    Green       Verde
};
 
$tab{EVIL} = [ "No way!", "Way!!" ];
 
while ( my($k, $v) = each %tab ) {
 
    print ref($k) ? "[@$k]" : $k, " => ",
        ref($v) ? "[@$v]" : $v, "\n";
 
} 
#-----------------------------
[No way! Way!!] => EVIL
 
EVIL => [No way! Way!!]
 
Blue => Azul
 
Green => Verde
 
Rojo => Red
 
Red => Rojo
 
Azul => Blue
 
Verde => Green
#-----------------------------
# download the following standalone program
package Tie::RevHash;
 
use Tie::RefHash;
use vars qw(@ISA);
@ISA = qw(Tie::RefHash);
 
sub STORE {
    my ($self, $key, $value) = @_;
 
    $self->SUPER::STORE($key, $value);
    $self->SUPER::STORE($value, $key);
}
 
sub DELETE {
    my ($self, $key) = @_;
 
    my $value = $self->SUPER::FETCH($key);
    $self->SUPER::DELETE($key);
 
    $self->SUPER::DELETE($value);
}
 
1;
 
#-----------------------------
use Counter;
 
tie *CH, 'Counter';
while (<CH>) {
    print "Got $_\n";
 
} 
#-----------------------------
# download the following standalone program
package Counter;
sub TIEHANDLE {
 
    my $class = shift;
    my $start = shift;
 
    return bless \$start => $class;
} 
sub READLINE {
 
    my $self = shift;
    return ++$$self;
} 
 
1;
 
#-----------------------------
use Tie::Tee;
tie *TEE, 'Tie::Tee', *STDOUT, *STDERR;
 
print TEE "This line goes both places.\n";
#-----------------------------
#!/usr/bin/perl
# demo_tietee
use Tie::Tee;
use Symbol;
 
@handles = (*STDOUT);
for $i ( 1 .. 10 ) {
 
    push(@handles, $handle = gensym());
    open($handle, ">/tmp/teetest.$i");
} 
 
tie *TEE, 'Tie::Tee', @handles;
print TEE "This lines goes many places.\n";
#-----------------------------
# download the following standalone program
 
package Tie::Tee;
 
sub TIEHANDLE {
    my $class   = shift;
 
    my $handles = [@_];
 
    bless $handles, $class;
 
    return $handles;
}
 
sub PRINT {
    my $href = shift;
 
    my $handle;
    my $success = 0;
 
    foreach $handle (@$href) {
 
        $success += print $handle @_;
    }
 
    return $success == @$href;
 
}                                     
 
1;
 
#-----------------------------