1#!/usr/bin/env perl 2use warnings; 3use strict; 4use Test::More tests => 15; 5 6package Person; 7use parent 'Data::Inherited'; 8 9sub DEFAULTS { 10 first_name => 'John', 11 last_name => 'Smith', 12 ; 13} 14our $override_cache = 0; 15 16sub new { 17 my $class = shift; 18 my $self = bless {}, $class; 19 my %args = @_; 20 our $override_cache; 21 $override_cache = 1 - $override_cache; 22 %args = ($self->every_hash('DEFAULTS', $override_cache), %args); 23 $self->$_($args{$_}) for keys %args; 24 $self; 25} 26 27sub first_name { 28 return $_[0]->{first_name} if @_ == 1; 29 $_[0]->{first_name} = $_[1]; 30} 31 32sub last_name { 33 return $_[0]->{last_name} if @_ == 1; 34 $_[0]->{last_name} = $_[1]; 35} 36 37package Employee; 38our @ISA = 'Person'; 39 40sub DEFAULTS { 41 salary => 10_000, 42 ; 43} 44 45sub salary { 46 return $_[0]->{salary} if @_ == 1; 47 $_[0]->{salary} = $_[1]; 48} 49 50package LocatedEmployee; 51our @ISA = 'Employee'; 52 53# Note: no default for address, but different salary 54sub DEFAULTS { 55 salary => 20_000, 56 first_name => 'Johan', 57 ; 58} 59 60sub address { 61 return $_[0]->{address} if @_ == 1; 62 $_[0]->{address} = $_[1]; 63} 64 65package main; 66use Test::More; 67my $p; 68 69# twice, to test the every_hash caching mechanism, and twice again to get 70# both use the cache and use override_cache (see new() above) 71for (1 .. 4) { 72 $p = Person->new; 73 ok_prop( 74 $p, 75 first_name => 'John', 76 last_name => 'Smith', 77 ); 78} 79 80# now use hash context 81my %defaults = $p->every_hash('DEFAULTS'); 82is_deeply( 83 \%defaults, 84 { first_name => 'John', 85 last_name => 'Smith', 86 }, 87 'defaults in hash context' 88); 89$p = Employee->new; 90ok_prop( 91 $p, 92 first_name => 'John', 93 last_name => 'Smith', 94 salary => 10_000, 95); 96$p = LocatedEmployee->new; 97ok_prop( 98 $p, 99 first_name => 'Johan', 100 last_name => 'Smith', 101 salary => 20_000, 102); 103 104sub ok_prop { 105 my ($obj, %property) = @_; 106 while (my ($property, $value) = each %property) { 107 is( $obj->$property, $value, 108 sprintf '%s %s is %s' => ref($obj), 109 $property, $value 110 ); 111 } 112} 113