1package Graph::Attribute;
2
3use strict;
4
5sub _F () { 0 }
6sub _COMPAT02 () { 0x00000001 }
7
8sub import {
9    my $package = shift;
10    my %attr = @_;
11    my $caller = caller(0);
12    if (exists $attr{array}) {
13	my $i = $attr{array};
14	no strict 'refs';
15	*{"${caller}::_get_attributes"} = sub { $_[0]->[ $i ] };
16	*{"${caller}::_set_attributes"} =
17	    sub { $_[0]->[ $i ] ||= { };
18		  $_[0]->[ $i ] = $_[1] if @_ == 2;
19		  $_[0]->[ $i ] };
20	*{"${caller}::_has_attributes"} = sub { defined $_[0]->[ $i ] };
21	*{"${caller}::_delete_attributes"} = sub { undef $_[0]->[ $i ]; 1 };
22    } elsif (exists $attr{hash}) {
23	my $k = $attr{hash};
24	no strict 'refs';
25	*{"${caller}::_get_attributes"} = sub { $_[0]->{ $k } };
26	*{"${caller}::_set_attributes"} =
27	    sub { $_[0]->{ $k } ||= { };
28		  $_[0]->{ $k } = $_[1] if @_ == 2;
29		  $_[0]->{ $k } };
30	*{"${caller}::_has_attributes"} = sub { defined $_[0]->{ $k } };
31	*{"${caller}::_delete_attributes"} = sub { delete $_[0]->{ $k } };
32    } else {
33	die "Graph::Attribute::import($package @_) caller $caller\n";
34    }
35    my @api = qw(get_attribute
36		 get_attributes
37		 set_attribute
38		 set_attributes
39		 has_attribute
40		 has_attributes
41		 delete_attribute
42		 delete_attributes
43		 get_attribute_names
44		 get_attribute_values);
45    if (exists $attr{map}) {
46	my $map = $attr{map};
47	for my $api (@api) {
48	    my ($first, $rest) = ($api =~ /^(\w+?)_(.+)/);
49	    no strict 'refs';
50	    *{"${caller}::${first}_${map}_${rest}"} = \&$api;
51	}
52    }
53}
54
55sub set_attribute {
56    my $g = shift;
57    my $v = pop;
58    my $a = pop;
59    my $p = $g->_set_attributes;
60    $p->{ $a } = $v;
61    return 1;
62}
63
64sub set_attributes {
65    my $g = shift;
66    my $a = pop;
67    my $p = $g->_set_attributes( $a );
68    return 1;
69}
70
71sub has_attribute {
72    my $g = shift;
73    my $a = pop;
74    my $p = $g->_get_attributes;
75    $p ? exists $p->{ $a } : 0;
76}
77
78sub has_attributes {
79    my $g = shift;
80    $g->_get_attributes ? 1 : 0;
81}
82
83sub get_attribute {
84    my $g = shift;
85    my $a = pop;
86    my $p = $g->_get_attributes;
87    $p ? $p->{ $a } : undef;
88}
89
90sub delete_attribute {
91    my $g = shift;
92    my $a = pop;
93    my $p = $g->_get_attributes;
94    if (defined $p) {
95	delete $p->{ $a };
96	return 1;
97    } else {
98	return 0;
99    }
100}
101
102sub delete_attributes {
103    my $g = shift;
104    if ($g->_has_attributes) {
105	$g->_delete_attributes;
106	return 1;
107    } else {
108	return 0;
109    }
110}
111
112sub get_attribute_names {
113    my $g = shift;
114    my $p = $g->_get_attributes;
115    defined $p ? keys %{ $p } : ( );
116}
117
118sub get_attribute_values {
119    my $g = shift;
120    my $p = $g->_get_attributes;
121    defined $p ? values %{ $p } : ( );
122}
123
124sub get_attributes {
125    my $g = shift;
126    my $a = $g->_get_attributes;
127    ($g->[ _F ] & _COMPAT02) ? (defined $a ? %{ $a } : ()) : $a;
128}
129
1301;
131