perllib/Graph/AdjacencyMap/Vertex.pm

   1 package Graph::AdjacencyMap::Vertex;
   2
   3 # THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY.
   4 # THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND
   5 # ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES.
   6
   7 use strict;
   8
   9 # $SIG{__DIE__ } = sub { use Carp; confess };
  10 # $SIG{__WARN__} = sub { use Carp; confess };
  11
  12 use Graph::AdjacencyMap qw(:flags :fields);
  13 use base 'Graph::AdjacencyMap';
  14
  15 use Scalar::Util qw(weaken);
  16
  17 sub _new {
  18     my ($class, $flags, $arity) = @_;
  19     bless [ 0, $flags, $arity ], $class;
  20 }
  21
  22 require overload; # for de-overloading
  23
  24 sub __set_path {
  25     my $m = shift;
  26     my $f = $m->[ _f ];
  27     my $id = pop if ($f & _MULTI);
  28     if (@_ != 1) {
  29         require Carp;
  30         Carp::confess(sprintf "Graph::AdjacencyMap::Vertex: arguments %d expected 1", scalar @_);
  31     }
  32     my $p;
  33     $p = $m->[ _s ] ||= { };
  34     my @p = $p;
  35     my @k;
  36     my $k = shift;
  37     my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k;
  38     push @k, $q;
  39     return (\@p, \@k);
  40 }
  41
  42 sub __set_path_node {
  43     my ($m, $p, $l) = splice @_, 0, 3;
  44     my $f = $m->[ _f ];
  45     my $id = pop if ($f & _MULTI);
  46     unless (exists $p->[-1]->{ $l }) {
  47         my $i = $m->_new_node( \$p->[-1]->{ $l }, $id );
  48         $m->[ _i ]->{ defined $i ? $i : "" } = $_[0];
  49     } else {
  50         $m->_inc_node( \$p->[-1]->{ $l }, $id );
  51     }
  52 }
  53
  54 sub set_path {
  55     my $m = shift;
  56     my $f = $m->[ _f ];
  57     my ($p, $k) = $m->__set_path( @_ );
  58     return unless defined $p && defined $k;
  59     my $l = defined $k->[-1] ? $k->[-1] : "";
  60     my $set = $m->__set_path_node( $p, $l, @_ );
  61     return $set;
  62 }
  63
  64 sub __has_path {
  65     my $m = shift;
  66     my $f = $m->[ _f ];
  67     if (@_ != 1) {
  68         require Carp;
  69         Carp::confess(sprintf
  70                       "Graph::AdjacencyMap: arguments %d expected 1\n",
  71                       scalar @_);
  72     }
  73     my $p = $m->[ _s ];
  74     return unless defined $p;
  75     my @p = $p;
  76     my @k;
  77     my $k = shift;
  78     my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k;
  79     push @k, $q;
  80     return (\@p, \@k);
  81 }
  82
  83 sub has_path {
  84     my $m = shift;
  85     my ($p, $k) = $m->__has_path( @_ );
  86     return unless defined $p && defined $k;
  87     return exists $p->[-1]->{ defined $k->[-1] ? $k->[-1] : "" };
  88 }
  89
  90 sub has_path_by_multi_id {
  91     my $m = shift;
  92     my $id = pop;
  93     my ($e, $n) = $m->__get_path_node( @_ );
  94     return undef unless $e;
  95     return exists $n->[ _nm ]->{ $id };
  96 }
  97
  98 sub _get_path_id {
  99     my $m = shift;
 100     my $f = $m->[ _f ];
 101     my ($e, $n) = $m->__get_path_node( @_ );
 102     return undef unless $e;
 103     return ref $n ? $n->[ _ni ] : $n;
 104 }
 105
 106 sub _get_path_count {
 107     my $m = shift;
 108     my $f = $m->[ _f ];
 109     my ($e, $n) = $m->__get_path_node( @_ );
 110     return 0 unless $e && defined $n;
 111     return
 112         ($f & _COUNT) ? $n->[ _nc ] :
 113         ($f & _MULTI) ? scalar keys %{ $n->[ _nm ] } : 1;
 114 }
 115
 116 sub __attr {
 117     my $m = shift;
 118     if (@_ && ref $_[0] && @{ $_[0] } != $m->[ _a ]) {
 119         require Carp;
 120         Carp::confess(sprintf "Graph::AdjacencyMap::Vertex: arguments %d expected %d",
 121                       scalar @{ $_[0] }, $m->[ _a ]);
 122     }
 123 }
 124
 125 sub _get_id_path {
 126     my ($m, $i) = @_;
 127     return defined $m->[ _i ] ? $m->[ _i ]->{ $i } : undef;
 128 }
 129
 130 sub del_path {
 131     my $m = shift;
 132     my $f = $m->[ _f ];
 133     my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ );
 134     return unless $e;
 135     my $c = ($f & _COUNT) ? --$n->[ _nc ] : 0;
 136     if ($c == 0) {
 137         delete $m->[ _i ]->{ ref $n ? $n->[ _ni ] : $n };
 138         delete $p->[ -1 ]->{ $l };
 139     }
 140     return 1;
 141 }
 142
 143 sub del_path_by_multi_id {
 144     my $m = shift;
 145     my $f = $m->[ _f ];
 146     my $id = pop;
 147     my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ );
 148     return unless $e;
 149     delete $n->[ _nm ]->{ $id };
 150     unless (keys %{ $n->[ _nm ] }) {
 151         delete $m->[ _i ]->{ $n->[ _ni ] };
 152         delete $p->[-1]->{ $l };
 153     }
 154     return 1;
 155 }
 156
 157 sub paths {
 158     my $m = shift;
 159     return map { [ $_ ] } values %{ $m->[ _i ] } if defined $m->[ _i ];
 160     wantarray ? ( ) : 0;
 161 }
 162
 163 1;
 164 =pod
 165
 166 =head1 NAME
 167
 168 Graph::AdjacencyMap - create and a map of graph vertices or edges
 169
 170 =head1 SYNOPSIS
 171
 172     Internal.
 173
 174 =head1 DESCRIPTION
 175
 176 B<This module is meant for internal use by the Graph module.>
 177
 178 =head2 Object Methods
 179
 180 =over 4
 181
 182 =item del_path(@id)
 183
 184 Delete a Map path by ids.
 185
 186 =item del_path_by_multi_id($id)
 187
 188 Delete a Map path by a multi(vertex) id.
 189
 190 =item has_path(@id)
 191
 192 Return true if the Map has the path by ids, false if not.
 193
 194 =item has_path_by_multi_id($id)
 195
 196 Return true ifd the a Map has the path by a multi(vertex) id, false if not.
 197
 198 =item paths
 199
 200 Return all the paths of the Map.
 201
 202 =item set_path(@id)
 203
 204 Set the path by @ids.
 205
 206 =back
 207
 208 =head1 AUTHOR AND COPYRIGHT
 209
 210 Jarkko Hietaniemi F<jhi@iki.fi>
 211
 212 =head1 LICENSE
 213
 214 This module is licensed under the same terms as Perl itself.
 215
 216 =cut