use Test::More; use Scalar::Util qw(reftype); my $n_tests; use_ok('Person'); BEGIN{ $n_tests++ } # OBJECT # instantiate object my $p = Person->new; is(ref $p, 'Person', 'object is Person'); is(reftype $p, 'SCALAR', 'object type is SCALAR'); BEGIN { $n_tests += 2 } # set fullname by setting given and surname $p->given = 'Xaver'; is($p->fullname, 'Xaver', 'fullname is givenName only'); $p->surname = 'Unsinn'; is($p->fullname, 'Xaver Unsinn','fullname is "givenName surname"'); BEGIN { $n_tests += 2 } # set given and surname by setting fullname $p->fullname = 'John Doe'; is($p->given, 'John', 'givenName is set after setting fullname'); is($p->surname, 'Doe', 'surname is set after setting fullname'); BEGIN { $n_tests += 2 } # dereferencing as hash - for confusion only ;-) # is($p->{given}, 'John', 'hash dereferencing of SCALAR is correct'); # $p->{given} = 'Xaver'; # is($p->given, 'John', '...which is correct, no setting via hashref'); # is($p->{surname}, 'Doe', 'hash dereferencing of SCALAR is correct'); # is($p->{fullname}, 'John Doe', 'hash dereferencing of SCALAR is correct'); # BEGIN { $n_tests += 4 } # CLASS Person->fullname = 'Christian Surname'; is(Person->given, 'Christian', 'class attribute for given is set'); is(Person->surname, 'Surname', 'class attribute for surname is set'); BEGIN { $n_tests += 2 } BEGIN { plan tests => $n_tests } #### package Person; use strict; use warnings; use Hash::Util::FieldHash qw(fieldhashes id); use overload '%{}' => \&_refsub, fallback => 1; fieldhashes \my(%given,%surname,%fullname); # package attribute 'fullname' tie $Person::fullname{Person}, 'Person::fullname', 'Person'; sub new { my $class = shift; my %args = @_; my $obj = bless do{ \my $x }, $class; for(qw{given surname}) { $obj->$_ = $args{$_} if $args{$_}; } tie $fullname{$obj}, 'Person::fullname', $obj; $obj; } # make getters/setters for (qw{given surname fullname}) { eval "sub $_ : lvalue { \$${_}{shift()} }"; } # provide $obj->{attribute} syntactic sugar - for more confusion # sub _refsub { # my $obj = shift; # warn "WARNING: dereferencing $obj as hashref is deprecated\n"; # warn "WARNING: setting an attribute via hashref does NOT work\n"; # { # given => $obj->given, # surname => $obj->surname, # fullname => $obj->fullname, # }; # } # tied interface for compound attribute 'fullname' package Person::fullname; sub TIESCALAR { my $class = shift; my $obj = shift; my $tied = bless \$obj, $class; } sub FETCH { my $obj = shift; join" ", grep {length} $$obj->given,$$obj->surname; } sub STORE { my $obj = shift; my ($first, $last) = split /\s+/,shift; $$obj->given = $first; $$obj->surname = $last; } 1;