perllib/Graph/Attribute.pm

   1 package Graph::Attribute;
   2
   3 use strict;
   4
   5 sub _F () { 0 }
   6 sub _COMPAT02 () { 0x00000001 }
   7
   8 sub 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
  55 sub 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
  64 sub set_attributes {
  65     my $g = shift;
  66     my $a = pop;
  67     my $p = $g->_set_attributes( $a );
  68     return 1;
  69 }
  70
  71 sub has_attribute {
  72     my $g = shift;
  73     my $a = pop;
  74     my $p = $g->_get_attributes;
  75     $p ? exists $p->{ $a } : 0;
  76 }
  77
  78 sub has_attributes {
  79     my $g = shift;
  80     $g->_get_attributes ? 1 : 0;
  81 }
  82
  83 sub get_attribute {
  84     my $g = shift;
  85     my $a = pop;
  86     my $p = $g->_get_attributes;
  87     $p ? $p->{ $a } : undef;
  88 }
  89
  90 sub 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
 102 sub 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
 112 sub get_attribute_names {
 113     my $g = shift;
 114     my $p = $g->_get_attributes;
 115     defined $p ? keys %{ $p } : ( );
 116 }
 117
 118 sub get_attribute_values {
 119     my $g = shift;
 120     my $p = $g->_get_attributes;
 121     defined $p ? values %{ $p } : ( );
 122 }
 123
 124 sub get_attributes {
 125     my $g = shift;
 126     my $a = $g->_get_attributes;
 127     ($g->[ _F ] & _COMPAT02) ? (defined $a ? %{ $a } : ()) : $a;
 128 }
 129
 130 1;