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