Perl example of inside-out object 

code=yes

# object oriented example - inside out
# tags #perl #programming #objectoriented

################
# lib/PlayingCard.pm
################

# from  http://perltraining.com.au/tips/2006-03-31.html
package PlayingCard;
use strict;
use warnings;
use NEXT;
use Scalar::Util qw/refaddr/;
# Using an enclosing block ensures that the attributes declared
# are *only* accessible inside the same block.  This is only really
# necessary for files with more than one class defined in them.
{
        my %suit_of;
        my %rank_of;
         
        sub new {
                my ($class, $rank, $suit) = @_;
                 
                # This strange looking line produces an
                # anonymous blessed scalar.
                 
                my $this = bless \do{my $anon_scalar}, $class;
                 
                # Attributes are stored in their respective
                # hashes.  We should also be checking that
                # $suit and $rank contain acceptable values for
                # our class.
                $rank_of{refaddr $this} = "Default Rank";
                $suit_of{refaddr $this} = "Default Suit";

                if ( $rank and !$suit ) {
                    $rank_of{refaddr $this} = $rank;
                } elsif ( $rank and $suit ) {
                    $rank_of{refaddr $this} = $rank;
                    $suit_of{refaddr $this} = $suit;
                }
                 
                return $this;
        }
         
        sub get_suit {
                my ($this) = @_;
                return $suit_of{refaddr $this};
        }
         
        sub get_rank {
                my ($this) = @_;
                return $rank_of{refaddr $this};
        }

        sub set_rank {
            my ($this, $new_rank) = @_;
            $rank_of{refaddr $this} = $new_rank;
        }

        sub DESTROY {
                my ($this) = @_;
                $this->EVERY::_destroy;
        }

        sub _destroy {
                my ($this) = @_;
                delete $suit_of{refaddr $this};
                delete $rank_of{refaddr $this};
         
        }

}
1;



##############
##############
# bin/test-playingcard.pl
#
#


#!/usr/bin/perl -wT

require '../lib/PlayingCard.pm';

print "Object A\n\n";
print "init A with (A rank 1) and (A suit 1)\n";
my $a = PlayingCard->new("A rank 1", "A suit 1");
print "A rank = " . $a->get_rank . "\n";
print "A suit = " . $a->get_suit . "\n";
print "setting A rank to new value (A rank 2)\n";
$a->set_rank("A rank 2");
print "A rank now = " . $a->get_rank . "\n";


print "\nObject B \n\n";

print "init B with (B rank 1) and (B suit 1)\n";
my $b = PlayingCard->new("B rank 1", "B suit 1");
print "B rank = " . $b->get_rank . "\n";
print "B suit = " . $b->get_suit . "\n";
print "setting B rank to new value (B rank 2)\n";
$b->set_rank("B rank 2");
print "B rank now = " . $b->get_rank . "\n";

print "\nback to Object A for A rank = " . $a->get_rank . "\n";


print "\nObject C \n\n";

print "init C with no params and accept default vals\n";
my $c = PlayingCard->new;
print "C rank = " . $c->get_rank . "\n";
print "C suit = " . $c->get_suit . "\n";
print "setting C rank to new value (C rank 2)\n";
$c->set_rank("C rank 2");
print "C rank now = " . $c->get_rank . "\n";

print "\nback to Object A for A rank = " . $a->get_rank . "\n";
print "back to Object B for B rank = " . $b->get_rank . "\n";
print "back to Object C for C rank = " . $c->get_rank . "\n";