1package Graph::AdjacencyMap::Heavy; 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 7use strict; 8 9# $SIG{__DIE__ } = sub { use Carp; confess }; 10# $SIG{__WARN__} = sub { use Carp; confess }; 11 12use Graph::AdjacencyMap qw(:flags :fields); 13use base 'Graph::AdjacencyMap'; 14 15require overload; # for de-overloading 16 17require Data::Dumper; 18 19sub __set_path { 20 my $m = shift; 21 my $f = $m->[ _f ]; 22 my $id = pop if ($f & _MULTI); 23 if (@_ != $m->[ _a ] && !($f & _HYPER)) { 24 require Carp; 25 Carp::confess(sprintf "Graph::AdjacencyMap::Heavy: arguments %d expected %d", 26 scalar @_, $m->[ _a ]); 27 } 28 my $p; 29 $p = ($f & _HYPER) ? 30 (( $m->[ _s ] ||= [ ] )->[ @_ ] ||= { }) : 31 ( $m->[ _s ] ||= { }); 32 my @p = $p; 33 my @k; 34 while (@_) { 35 my $k = shift; 36 my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k; 37 if (@_) { 38 $p = $p->{ $q } ||= {}; 39 return unless $p; 40 push @p, $p; 41 } 42 push @k, $q; 43 } 44 return (\@p, \@k); 45} 46 47sub __set_path_node { 48 my ($m, $p, $l) = splice @_, 0, 3; 49 my $f = $m->[ _f ] ; 50 my $id = pop if ($f & _MULTI); 51 unless (exists $p->[-1]->{ $l }) { 52 my $i = $m->_new_node( \$p->[-1]->{ $l }, $id ); 53 $m->[ _i ]->{ defined $i ? $i : "" } = [ @_ ]; 54 return defined $id ? ($id eq _GEN_ID ? $$id : $id) : $i; 55 } else { 56 return $m->_inc_node( \$p->[-1]->{ $l }, $id ); 57 } 58} 59 60sub set_path { 61 my $m = shift; 62 my $f = $m->[ _f ]; 63 if (@_ > 1 && ($f & _UNORDUNIQ)) { 64 if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } 65 else { $m->__arg(\@_) } 66 } 67 my ($p, $k) = $m->__set_path( @_ ); 68 return unless defined $p && defined $k; 69 my $l = defined $k->[-1] ? $k->[-1] : ""; 70 return $m->__set_path_node( $p, $l, @_ ); 71} 72 73sub __has_path { 74 my $m = shift; 75 my $f = $m->[ _f ]; 76 if (@_ != $m->[ _a ] && !($f & _HYPER)) { 77 require Carp; 78 Carp::confess(sprintf "Graph::AdjacencyMap::Heavy: arguments %d expected %d", 79 scalar @_, $m->[ _a ]); 80 } 81 if (@_ > 1 && ($f & _UNORDUNIQ)) { 82 if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } 83 else { $m->__arg(\@_) } 84 } 85 my $p = $m->[ _s ]; 86 return unless defined $p; 87 $p = $p->[ @_ ] if ($f & _HYPER); 88 return unless defined $p; 89 my @p = $p; 90 my @k; 91 while (@_) { 92 my $k = shift; 93 my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k; 94 if (@_) { 95 $p = $p->{ $q }; 96 return unless defined $p; 97 push @p, $p; 98 } 99 push @k, $q; 100 } 101 return (\@p, \@k); 102} 103 104sub has_path { 105 my $m = shift; 106 my $f = $m->[ _f ]; 107 if (@_ > 1 && ($f & _UNORDUNIQ)) { 108 if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } 109 else { $m->__arg(\@_) } 110 } 111 my ($p, $k) = $m->__has_path( @_ ); 112 return unless defined $p && defined $k; 113 return exists $p->[-1]->{ defined $k->[-1] ? $k->[-1] : "" }; 114} 115 116sub has_path_by_multi_id { 117 my $m = shift; 118 my $f = $m->[ _f ]; 119 my $id = pop; 120 if (@_ > 1 && ($f & _UNORDUNIQ)) { 121 if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } 122 else { $m->__arg(\@_) } 123 } 124 my ($e, $n) = $m->__get_path_node( @_ ); 125 return undef unless $e; 126 return exists $n->[ _nm ]->{ $id }; 127} 128 129sub _get_path_node { 130 my $m = shift; 131 my $f = $m->[ _f ]; 132 if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. 133 @_ = sort @_ if ($f & _UNORD); 134 return unless exists $m->[ _s ]->{ $_[0] }; 135 my $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ]; 136 my $k = [ $_[0], $_[1] ]; 137 my $l = $_[1]; 138 return ( exists $p->[-1]->{ $l }, $p->[-1]->{ $l }, $p, $k, $l ); 139 } else { 140 if (@_ > 1 && ($f & _UNORDUNIQ)) { 141 if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } 142 else { $m->__arg(\@_) } 143 } 144 $m->__get_path_node( @_ ); 145 } 146} 147 148sub _get_path_id { 149 my $m = shift; 150 my $f = $m->[ _f ]; 151 my ($e, $n); 152 if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. 153 @_ = sort @_ if ($f & _UNORD); 154 return unless exists $m->[ _s ]->{ $_[0] }; 155 my $p = $m->[ _s ]->{ $_[0] }; 156 $e = exists $p->{ $_[1] }; 157 $n = $p->{ $_[1] }; 158 } else { 159 ($e, $n) = $m->_get_path_node( @_ ); 160 } 161 return undef unless $e; 162 return ref $n ? $n->[ _ni ] : $n; 163} 164 165sub _get_path_count { 166 my $m = shift; 167 my $f = $m->[ _f ]; 168 my ($e, $n) = $m->_get_path_node( @_ ); 169 return undef unless $e && defined $n; 170 return 171 ($f & _COUNT) ? $n->[ _nc ] : 172 ($f & _MULTI) ? scalar keys %{ $n->[ _nm ] } : 1; 173} 174 175sub __attr { 176 my $m = shift; 177 if (@_) { 178 if (ref $_[0] && @{ $_[0] }) { 179 if (@{ $_[0] } != $m->[ _a ]) { 180 require Carp; 181 Carp::confess(sprintf 182 "Graph::AdjacencyMap::Heavy: arguments %d expected %d\n", 183 scalar @{ $_[0] }, $m->[ _a ]); 184 } 185 my $f = $m->[ _f ]; 186 if (@{ $_[0] } > 1 && ($f & _UNORDUNIQ)) { 187 if (($f & _UNORDUNIQ) == _UNORD && @{ $_[0] } == 2) { 188 @{ $_[0] } = sort @{ $_[0] } 189 } else { $m->__arg(\@_) } 190 } 191 } 192 } 193} 194 195sub _get_id_path { 196 my ($m, $i) = @_; 197 my $p = defined $i ? $m->[ _i ]->{ $i } : undef; 198 return defined $p ? @$p : ( ); 199} 200 201sub del_path { 202 my $m = shift; 203 my $f = $m->[ _f ]; 204 if (@_ > 1 && ($f & _UNORDUNIQ)) { 205 if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } 206 else { $m->__arg(\@_) } 207 } 208 my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ ); 209 return unless $e; 210 my $c = ($f & _COUNT) ? --$n->[ _nc ] : 0; 211 if ($c == 0) { 212 delete $m->[ _i ]->{ ref $n ? $n->[ _ni ] : $n }; 213 delete $p->[-1]->{ $l }; 214 while (@$p && @$k && keys %{ $p->[-1]->{ $k->[-1] } } == 0) { 215 delete $p->[-1]->{ $k->[-1] }; 216 pop @$p; 217 pop @$k; 218 } 219 } 220 return 1; 221} 222 223sub del_path_by_multi_id { 224 my $m = shift; 225 my $f = $m->[ _f ]; 226 my $id = pop; 227 if (@_ > 1 && ($f & _UNORDUNIQ)) { 228 if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } 229 else { $m->__arg(\@_) } 230 } 231 my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ ); 232 return unless $e; 233 delete $n->[ _nm ]->{ $id }; 234 unless (keys %{ $n->[ _nm ] }) { 235 delete $m->[ _i ]->{ $n->[ _ni ] }; 236 delete $p->[-1]->{ $l }; 237 while (@$p && @$k && keys %{ $p->[-1]->{ $k->[-1] } } == 0) { 238 delete $p->[-1]->{ $k->[-1] }; 239 pop @$p; 240 pop @$k; 241 } 242 } 243 return 1; 244} 245 246sub paths { 247 my $m = shift; 248 return values %{ $m->[ _i ] } if defined $m->[ _i ]; 249 wantarray ? ( ) : 0; 250} 251 2521; 253__END__ 254