File: Inheritable.pm

package info (click to toggle)
libclass-makemethods-perl 1.01-5
  • links: PTS, VCS
  • area: main
  • in suites: buster, sid, stretch
  • size: 1,864 kB
  • ctags: 516
  • sloc: perl: 10,495; makefile: 2
file content (126 lines) | stat: -rw-r--r-- 3,715 bytes parent folder | download
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;