package DBIx::Class::Graph::Wrapper; use strict; use warnings; use Class::C3; use base qw/Graph/; use List::MoreUtils qw(uniq); sub _rs { my $self = shift; if(@_) { $self->[6] = $_[0]; } return $self->[6]; } sub _add_edge { my $g = shift; my ( $from, $to ) = @_; my @e = $g->next::method( $from, $to ); die "we need two vertices to succeed" if ( @e != 2 ); if($from->has_column( $from->_group_column )) { # we have no relationship $g->delete_edge( $from, $g->successors($from) ) if ( $from->_connect_by eq "successor" && $g->successors($from) ); $g->delete_edge( $g->predecessors($to), $to ) if ( $to->_connect_by eq "predecessor" && $g->predecessors($to) ); } ( $from, $to ) = ( $to, $from ) if ( $to->_connect_by eq "predecessor" ); if($from->has_column( $from->_group_column )) { $from->update( { $from->_group_column => $to->id } ) unless ( $from->_group_column eq $to->id ); } else { my $rel = $from->_group_rel; my $addrel = "add_to_".$from->_group_rel; my $next = 0; for($to->$rel->all) { if($_->id == $from->id) { $next = 1; last; } } unless($next) { $to->$addrel($from); } } return @e; } sub delete_edge { my $g = shift; my @v = @_; if ( @v != 2 ) { warn "need 2 vertices to delete an edge"; return; } if ( $v[0]->_connect_by eq "predecessor" ) { $v[1]->update( { $v[1]->_group_column => "" } ); } else { $v[0]->update( { $v[0]->_group_column => "" } ); } return $g->next::method(@v); } sub delete_vertex { my $g = shift; my $v = shift; my @succ; if ( $v->_connect_by eq "predecessor" ) { @succ = $g->successors($v); } else { @succ = $g->predecessors($v); } for (@succ) { $_->update( { $_->_group_column => "" } ); } my $e = $g->next::method($v); $v->delete; return $e; } sub get_vertex { my $self = shift; my $id = shift; my @v = $self->vertices; my @cols = $self->_rs->result_source->primary_columns; my $pkey = shift @cols; for (@v) { return $_ if ( $_->can($pkey) && $_->$pkey eq $id ); } } sub all_successors { my $g = shift; my @root = @_; my @succ; my @return; foreach my $succ (@root) { push( @succ, $g->successors($succ) ); @succ = uniq @succ; } foreach my $succ (@succ) { push( @succ, $g->successors($succ) ); @succ = uniq @succ; } return @succ; } sub all_predecessors { my $g = shift; my @root = @_; my @pred; my @return; foreach my $pred (@root) { push( @pred, $g->predecessors($pred) ); @pred = uniq @pred; } foreach my $pred (@pred) { push( @pred, $g->predecessors($pred) ); @pred = uniq @pred; } return @pred; } # Preloaded methods go here. 1; =head1 NAME DBIx::Class::Graph::Wrapper - Overloaded L class =head1 DESCRIPTION Inherits from L and overloads some methods to store the data to the database. =head1 SEE ALSO See L for details. =head1 AUTHOR Moritz Onken, Eonken@houseofdesign.deE =head1 COPYRIGHT AND LICENSE Copyright (C) 2008 by Moritz Onken This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =cut