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