/usr/share/perl5/Data/Stag/GraphHandler.pm is in libdata-stag-perl 0.11-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | package Data::Stag::GraphHandler;
=head1 NAME
Data::Stag::GraphHandler - Graph Handler
=head1 SYNOPSIS
my $p = Data::Stag->parser;
$p->handler('graph');
$p->handler->mapping([vertex=>[
$p->parse
=cut
=head1 DESCRIPTION
=head1 PUBLIC METHODS -
=cut
use strict;
use base qw(Data::Stag::BaseHandler);
use vars qw($VERSION);
$VERSION="0.11";
use Graph;
sub init {
my $self = shift;
$self->SUPER::init(@_);
$self->graph(new Graph);
}
sub graph {
my $self = shift;
$self->{graph} = shift if @_;
return $self->{graph};
}
sub mapping {
my $self = shift;
$self->{_mapping} = shift if @_;
return $self->{_mapping};
}
sub graph_edges {
my $self = shift;
$self->{_graph_edges} = shift if @_;
return $self->{_graph_edges};
}
sub catch_end {
my $self = shift;
my $ev = shift;
my $node = shift;
my $g = $self->graph;
my $map = $self->mapping;
if ($map) {
my $uid_tag = $map->get_uid;
my @vertexmaps = $map->getnode_vertex;
my @edgemaps = $map->getnode_edge;
my ($emap) = grep {$ev eq $_->get_tag} @edgemaps;
if ($emap) {
my $parent_tag = $emap->get_parent;
my $child_tag = $emap->get_child;
my $parent = $node->get($parent_tag);
my $child = $node->get($child_tag);
if (!@vertexmaps) {
# graph defined purely by edges
$g->add_vertex($parent);
$g->add_vertex($child);
}
$g->add_edge($parent, $child);
$self->_set_attributes($g, $node, [$parent, $child], $emap->get_att);
}
my ($vmap) = grep {$ev eq $_->get_tag} @vertexmaps;
if ($vmap) {
my $uid = $node->get($uid_tag);
$g->add_vertex($uid);
$self->_set_attributes($g, $node, [$uid], $vmap->get_att);
}
}
return;
}
sub _set_attributes {
my $self = shift;
my ($g, $node, $idref, @atts) = @_;
if (!scalar(@atts) ||
grep {$_ eq '*'} @atts) {
my %atth = map { $_->name => 1 } $node->kids;
@atts = keys %atth;
}
foreach my $att (@atts) {
my @v = $node->get($att);
foreach my $v (@v) {
$g->set_attribute($att, @$idref, $v);
}
}
return;
}
1;
|