1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
=head1 NAME
Class::MakeMethods::Utility::Inheritable - "Inheritable" data
=head1 SYNOPSIS
package MyClass;
sub new { ... }
package MySubclass;
@ISA = 'MyClass';
...
my $obj = MyClass->new(...);
my $subobj = MySubclass->new(...);
use Class::MakeMethods::Utility::Inheritable qw(get_vvalue set_vvalue );
my $dataset = {};
set_vvalue($dataset, 'MyClass', 'Foobar'); # Set value for class
get_vvalue($dataset, 'MyClass'); # Gets value "Foobar"
get_vvalue($dataset, $obj); # Objects "inherit"
set_vvalue($dataset, $obj, 'Foible'); # Until you override
get_vvalue($dataset, $obj); # Now finds "Foible"
get_vvalue($dataset, 'MySubclass'); # Subclass "inherits"
get_vvalue($dataset, $subobj); # As do its objects
set_vvalue($dataset, 'MySubclass', 'Foozle'); # Until we override it
get_vvalue($dataset, 'MySubclass'); # Now finds "Foozle"
get_vvalue($dataset, $subobj); # Change cascades down
set_vvalue($dataset, $subobj, 'Foolish'); # Until we override again
get_vvalue($dataset, 'MyClass'); # Superclass is unchanged
=head1 DESCRIPTION
This module provides several functions which allow you to store values in a hash corresponding to both objects and classes, and to retrieve those values by searching a object's inheritance tree until it finds a matching entry.
This functionality is used by Class::MakeMethods::Standard::Inheritable and Class::MakeMethods::Composite::Inheritable to construct methods that can both store class data and be overridden on a per-object level.
=cut
########################################################################
package Class::MakeMethods::Utility::Inheritable;
$VERSION = 1.000;
@EXPORT_OK = qw( get_vvalue set_vvalue find_vself );
sub import { require Exporter and goto &Exporter::import } # lazy Exporter
use strict;
########################################################################
=head1 REFERENCE
=head2 find_vself
$vself = find_vself( $dataset, $instance );
Searches $instance's inheritance tree until it finds a matching entry in the dataset, and returns either the instance, the class that matched, or undef.
=cut
sub find_vself {
my $dataset = shift;
my $instance = shift;
return $instance if ( exists $dataset->{$instance} );
my $v_self;
my @isa_search = ( ref($instance) || $instance );
while ( scalar @isa_search ) {
$v_self = shift @isa_search;
return $v_self if ( exists $dataset->{$v_self} );
no strict 'refs';
unshift @isa_search, @{"$v_self\::ISA"};
}
return;
}
=head2 get_vvalue
$value = get_vvalue( $dataset, $instance );
Searches $instance's inheritance tree until it finds a matching entry in the dataset, and returns that value
=cut
sub get_vvalue {
my $dataset = shift;
my $instance = shift;
my $v_self = find_vself($dataset, $instance);
# warn "Dataset: " . join( ', ', %$dataset );
# warn "Retrieving $dataset -> $instance ($v_self): '$dataset->{$v_self}'";
return $v_self ? $dataset->{$v_self} : ();
}
=head2 set_vvalue
$value = set_vvalue( $dataset, $instance, $value );
Searches $instance's inheritance tree until it finds a matching entry in the dataset, and returns that value
=cut
sub set_vvalue {
my $dataset = shift;
my $instance = shift;
my $value = shift;
if ( defined $value ) {
# warn "Setting $dataset -> $instance = $value";
$dataset->{$instance} = $value;
} else {
# warn "Clearing $dataset -> $instance";
delete $dataset->{$instance};
undef;
}
}
########################################################################
1;
|
