5cd33bb8e2a8cb7f3e10a8e40cdda470a768f975
[scpubgit/stemmatology.git] / lib / Text / Tradition / Parser / GraphML.pm
1 package Text::Tradition::Parser::GraphML;
2
3 use strict;
4 use warnings;
5 use Exporter 'import';
6 use vars qw/ @EXPORT_OK $xpc /;
7
8 use XML::LibXML;
9 use XML::LibXML::XPathContext;
10
11 @EXPORT_OK = qw/ graphml_parse /;
12
13 =head1 NAME
14
15 Text::Tradition::Parser::GraphML
16
17 =head1 DESCRIPTION
18
19 Parser module for Text::Tradition, given a GraphML file that describes
20 a collation graph.  Returns the information about the graph that has
21 been parsed out from the GraphML.  This module is meant to be used
22 with a module (e.g. CollateX or Self) that interprets the specific
23 GraphML conventions of the source program.
24
25 =head1 METHODS
26
27 =head2 B<graphml_parse>( $init_opts )
28
29 parse( $init_opts );
30
31 Takes a set of Tradition initialization options, among which should be either
32 'file' or 'string'; parses that file or string and returns a list of nodes, edges,
33 and their associated data.
34
35 =cut
36
37 # Return graph -> nodeid -> { key1/val1, key2/val2, key3/val3 ... }
38 #              -> edgeid -> { source, target, wit1/val1, wit2/val2 ...}
39
40 sub graphml_parse {
41     my( $opts ) = @_;
42
43     my $parser = XML::LibXML->new();
44     my $doc;
45     if( exists $opts->{'string'} ) {
46         $doc = $parser->parse_string( $opts->{'string'} );
47     } elsif ( exists $opts->{'file'} ) {
48         $doc = $parser->parse_file( $opts->{'file'} );
49     } else {
50         warn "Could not find string or file option to parse";
51         return;
52     }
53     
54     my( $graphattr, $nodedata, $edgedata ) = ( {}, {}, {} );
55     my $graphml = $doc->documentElement();
56     $xpc = XML::LibXML::XPathContext->new( $graphml );
57     $xpc->registerNs( 'g', 'http://graphml.graphdrawing.org/xmlns' );
58     
59     # First get the ID keys, for node/edge data and for collation data
60     foreach my $k ( $xpc->findnodes( '//g:key' ) ) {
61         # Each key has a 'for' attribute to say whether it is for graph,
62         # node, or edge.
63         my $keyid = $k->getAttribute( 'id' );
64         my $keyname = $k->getAttribute( 'attr.name' );
65
66                 # Keep track of the XML identifiers for the data carried
67                 # in each node element.
68                 my $dtype = $k->getAttribute( 'for' );
69                 if( $dtype eq 'graph' ) {
70                         $graphattr->{$keyid} = $keyname;
71         } elsif( $dtype eq 'node' ) {
72             $nodedata->{$keyid} = $keyname;
73         } else {
74             $edgedata->{$keyid} = $keyname;
75         }
76     }
77
78     my @returned_graphs;
79     foreach my $graph_el ( $xpc->findnodes( '/g:graphml/g:graph' ) ) {
80         my $graph_hash = { 'nodes' => [],
81                                                    'edges' => [],
82                                                    'name'  => $graph_el->getAttribute( 'id' ) };
83                         
84                 my $node_reg = {};
85                 
86                 # Read in graph globals (if any).
87                 # print STDERR "Reading graphml global data\n";
88                 foreach my $dkey ( keys %$graphattr ) {
89                         my $keyname = $graphattr->{$dkey};
90                         my $keyvalue = _lookup_node_data( $graph_el, $dkey );
91                         $graph_hash->{'global'}->{$keyname} = $keyvalue if defined $keyvalue;
92                 }
93         
94                 # Add the nodes to the graph hash.
95                 # print STDERR "Reading graphml nodes\n"; 
96                 my @nodes = $xpc->findnodes( './/g:node', $graph_el );
97                 foreach my $n ( @nodes ) {
98                         # Could use a better way of registering these
99                         my $node_hash = {};
100                         foreach my $dkey ( keys %$nodedata ) {
101                                 my $keyname = $nodedata->{$dkey};
102                                 my $keyvalue = _lookup_node_data( $n, $dkey );
103                                 $node_hash->{$keyname} = $keyvalue if defined $keyvalue;
104                         }
105                         $node_reg->{$n->getAttribute( 'id' )} = $node_hash;
106                         push( @{$graph_hash->{'nodes'}}, $node_hash );
107                 }
108                         
109                 # Now add the edges, and cross-ref with the node objects.
110                 # print STDERR "Reading graphml edges\n";
111                 my @edges = $xpc->findnodes( './/g:edge', $graph_el );
112                 foreach my $e ( @edges ) {
113                         my $from = $e->getAttribute('source');
114                         my $to = $e->getAttribute('target');
115         
116                         # We don't know whether the edge data is one per witness
117                         # or one per witness type, or something else.  So we just
118                         # save it and let our calling parser decide.
119                         my $edge_hash = {
120                                 'source' => $node_reg->{$from},
121                                 'target' => $node_reg->{$to},
122                         };
123                         foreach my $wkey( keys %$edgedata ) {
124                                 my $wname = $edgedata->{$wkey};
125                                 my $wlabel = _lookup_node_data( $e, $wkey );
126                                 $edge_hash->{$wname} = $wlabel if $wlabel;
127                         }
128                         push( @{$graph_hash->{'edges'}}, $edge_hash );
129                 }
130         push( @returned_graphs, $graph_hash );
131     }
132     return @returned_graphs;
133 }
134
135
136 sub _lookup_node_data {
137     my( $xmlnode, $key ) = @_;
138     my $lookup_xpath = './g:data[@key="%s"]/child::text()';
139     my $data = $xpc->find( sprintf( $lookup_xpath, $key ), $xmlnode );
140     # If we get back an empty nodelist, we return undef.
141     if( ref( $data ) ) {
142         return undef unless $data->size;
143         return $data->to_literal->value;
144     }
145     # Otherwise we got back a value. Return it.
146     return $data;
147 }
148     
149 =back
150
151 =head1 LICENSE
152
153 This package is free software and is provided "as is" without express
154 or implied warranty.  You can redistribute it and/or modify it under
155 the same terms as Perl itself.
156
157 =head1 AUTHOR
158
159 Tara L Andrews, aurum@cpan.org
160
161 =cut
162
163 1;