}
};
-=head2 add_stemma( $dotfile )
+=head2 add_stemma( dotfile => $dotfile )
+=head2 add_stemma( dot => $dotstring )
+=head2 add_stemma( $stemma_obj )
Initializes a Text::Tradition::Stemma object from the given dotfile,
and associates it with the tradition.
sub add_stemma {
my $self = shift;
- my %opts = @_;
- my $stemma_fh;
- if( $opts{'dotfile'} ) {
- open $stemma_fh, '<', $opts{'dotfile'}
- or warn "Could not open file " . $opts{'dotfile'};
- } elsif( $opts{'dot'} ) {
- my $str = $opts{'dot'};
- open $stemma_fh, '<', \$str;
+ my $stemma;
+ if( ref( @_ ) eq 'Text::Tradition::Stemma' ) {
+ $stemma = shift;
+ } else {
+ $stemma = Text::Tradition::Stemma->new( @_ );
}
- # Assume utf-8
- binmode $stemma_fh, ':utf8';
- my $stemma = Text::Tradition::Stemma->new(
- 'dot' => $stemma_fh );
$self->_add_stemma( $stemma ) if $stemma;
return $stemma;
}
use Graph::Reader::Dot;
use IPC::Run qw/ run binary /;
use Text::Tradition::Error;
-use Text::Tradition::StemmaUtil qw/ editable_graph display_graph parse_newick /;
+use Text::Tradition::StemmaUtil qw/ read_graph editable_graph display_graph
+ parse_newick /;
use Moose;
=head1 NAME
use_ok( 'Text::Tradition::Stemma' );
# Try to create a bad graph
-my $baddotfh;
-open( $baddotfh, 't/data/besoin_bad.dot' ) or die "Could not open test dotfile";
try {
- my $stemma = Text::Tradition::Stemma->new( dot => $baddotfh );
+ my $stemma = Text::Tradition::Stemma->new( dotfile => 't/data/besoin_bad.dot' );
ok( 0, "Created broken stemma from dotfile with syntax error" );
} catch( Text::Tradition::Error $e ) {
like( $e->message, qr/^Error trying to parse/, "Syntax error in dot threw exception" );
}
# Create a good graph
-my $dotfh;
-open( $dotfh, 't/data/florilegium.dot' ) or die "Could not open test dotfile";
-binmode( $dotfh, ':utf8' );
-my $stemma = Text::Tradition::Stemma->new( dot => $dotfh );
+my $stemma = Text::Tradition::Stemma->new( dotfile => 't/data/florilegium.dot' );
is( ref( $stemma ), 'Text::Tradition::Stemma', "Created stemma from good dotfile" );
is( scalar $stemma->witnesses, 13, "Found correct number of extant witnesses" );
is( scalar $stemma->hypotheticals, 8, "Found correct number of extant hypotheticals" );
ok( $found_unicode_sigil, "Found a correctly encoded Unicode sigil" );
# Create an undirected graph
-my $undirdotfh;
-open( $undirdotfh, 't/data/besoin_undirected.dot' ) or die "Could not open test dotfile";
-binmode( $undirdotfh, ':utf8' );
-my $udstemma = Text::Tradition::Stemma->new( dot => $undirdotfh );
+my $udstemma = Text::Tradition::Stemma->new( dotfile => 't/data/besoin_undirected.dot' );
is( ref( $udstemma ), 'Text::Tradition::Stemma', "Created stemma from undirected dotfile" );
is( scalar $udstemma->witnesses, 13, "Found correct number of extant witnesses" );
is( scalar $udstemma->hypotheticals, 12, "Found correct number of hypotheticals" );
sub BUILD {
my( $self, $args ) = @_;
# If we have been handed a dotfile, initialize it into a graph.
+ my $dotstring;
if( exists $args->{'dot'} ) {
- $self->_graph_from_dot( $args->{'dot'} );
- }
+ $dotstring = $args->{'dot'};
+ } elsif( exists $args->{'dotfile'} ) {
+ # Read the file into a string.
+ my @dotlines;
+ open( DOTFH, $args->{'dotfile'} )
+ or throw( "Could not read specified dot file " . $args->{'dotfile'} );
+ binmode( DOTFH, ':encoding(UTF-8)' );
+ @dotlines = <DOTFH>;
+ close DOTFH;
+ $dotstring = join( '', @dotlines );
+ }
+ $self->_graph_from_dot( $dotstring ) if $dotstring;
}
before 'graph' => sub {
};
sub _graph_from_dot {
- my( $self, $dotfh ) = @_;
- my $reader = Graph::Reader::Dot->new();
- # Redirect STDOUT in order to trap any error messages - syntax errors
- # are evidently not fatal.
- my $graph;
- my $reader_out;
- my $reader_err;
- {
- local(*STDOUT);
- open( STDOUT, ">", \$reader_out );
- local(*STDERR);
- open( STDERR, ">", \$reader_err );
- $graph = $reader->read_graph( $dotfh );
- close STDOUT;
- close STDERR;
- }
- if( $reader_out && $reader_out =~ /error/s ) {
- throw( "Error trying to parse dot: $reader_out" );
- } elsif( !$graph ) {
- throw( "Failed to create graph from dot" );
- }
+ my( $self, $dotstring ) = @_;
+ my $graph = read_graph( $dotstring );
+
## HORRIBLE HACK but there is no API access to graph attributes!
- my $graph_id = exists $graph->[4]->{'name'} ? $graph->[4]->{'name'} : 'stemma';
- # Correct for implicit graph -> digraph quirk of reader
- if( $reader_err && $reader_err =~ /graph will be treated as digraph/ ) {
- my $udgraph = $graph->undirected_copy;
- foreach my $v ( $graph->vertices ) {
- $udgraph->set_vertex_attributes( $v, $graph->get_vertex_attributes( $v ) );
- }
- $graph = $udgraph;
- }
+ my $graph_id = $graph->has_graph_attribute( 'name' )
+ ? $graph->get_graph_attribute( 'name' ) : 'stemma';
$self->graph( $graph );
$self->set_identifier( $graph_id );
}
sub alter_graph {
my( $self, $dotstring ) = @_;
- my $dotfh;
- open $dotfh, '<', \$dotstring;
- binmode $dotfh, ':utf8';
- $self->_graph_from_dot( $dotfh );
+ $self->_graph_from_dot( $dotstring );
}
=head2 editable( $opts )
use File::Temp;
use File::Which;
use Graph;
+use Graph::Reader::Dot;
use IPC::Run qw/ run binary /;
use Text::Tradition::Error;
-@EXPORT_OK = qw/ display_graph editable_graph
+@EXPORT_OK = qw/ read_graph display_graph editable_graph
character_input phylip_pars parse_newick newick_to_svg /;
=head1 NAME
=head1 SUBROUTINES
+=head2 read_graph( $dotstr) {
+
+Parses the graph specification on the filehandle in $dotstr and returns a Graph
+object. This subroutine works around some deficiencies in Graph::Reader::Dot.
+
+=cut
+
+sub read_graph {
+ my $dotstr = shift;
+ # Graph::Reader::Dot does not handle bare non-ASCII Unicode word characters.
+ # We get around this by wrapping all words in double quotes, as long as they
+ # aren't already wrapped, and as long as they aren't the initial '(di)?graph'.
+ # Also need to deal correctly with the graph title.
+ if( $dotstr =~ /^\s*((di)?graph)\s+(.*?)\s*\{(.*)$/s ) {
+ my( $decl, $ident, $rest ) = ( $1, $3, $4 );
+ unless( substr( $ident, 0, 1 ) eq '"' ) {
+ $ident = '"'.$ident.'"';
+ }
+ $rest =~ s/(?<!")\b(\w+)\b(?!")/"$1"/g;
+ $dotstr = "$decl $ident { $rest";
+ }
+
+ # Now open a filehandle onto the string and pass it to Graph::Reader::Dot.
+ my $dotfh;
+ open $dotfh, '<', \$dotstr;
+ binmode $dotfh, ':utf8';
+ my $reader = Graph::Reader::Dot->new();
+ # Redirect STDOUT in order to trap any error messages - syntax errors
+ # are evidently not fatal.
+ my $graph;
+ my $reader_out;
+ my $reader_err;
+ {
+ local(*STDOUT);
+ open( STDOUT, ">", \$reader_out );
+ local(*STDERR);
+ open( STDERR, ">", \$reader_err );
+ $graph = $reader->read_graph( $dotfh );
+ close STDOUT;
+ close STDERR;
+ }
+ if( $reader_out && $reader_out =~ /error/s ) {
+ throw( "Error trying to parse dot: $reader_out" );
+ } elsif( !$graph ) {
+ throw( "Failed to create graph from dot" );
+ }
+ # Wrench the graph identifier out of the graph
+ ## HORRIBLE HACK but there is no API access to the graph identifier!
+ $graph->set_graph_attribute( 'name', $graph->[4]->{'name'} );
+
+ # Correct for implicit graph -> digraph quirk of reader
+ if( $reader_err && $reader_err =~ /graph will be treated as digraph/ ) {
+ my $udgraph = $graph->undirected_copy;
+ $udgraph->set_graph_attributes( $graph->get_graph_attributes );
+ foreach my $v ( $graph->vertices ) {
+ $udgraph->set_vertex_attributes( $v, $graph->get_vertex_attributes( $v ) );
+ }
+ $graph = $udgraph;
+ }
+
+ return $graph;
+}
+
=head2 display_graph( $graph, $opts )
Returns a dot specification intended for display, according to the logical
Q [ class=extant ];
S [ class=extant ];
T [ class=extant ];
- "α" -> A;
- "α" -> T;
- "α" -> "δ";
- "δ" -> 2;
+ α -> A;
+ α -> T;
+ α -> δ;
+ δ -> 2;
2 -> C;
2 -> B;
B -> P;
B -> S;
- "δ" -> "γ";
- "γ" -> 3;
+ δ -> γ;
+ γ -> 3;
3 -> F;
3 -> H;
- "γ" -> 4;
+ γ -> 4;
4 -> D;
4 -> 5;
5 -> Q;
ok( $editable =~ /hypothetical/, "Graph contains an edit class" );
# Test changing the name of the Graph
-$editable =~ s/^(digraph )\"?Stemma\"?/$1"Simple test stemma"/;
+$editable =~ s/Stemma/Simple test stemma/;
$stemma->alter_graph( $editable );
is( $stemma->identifier, "Simple test stemma", "Successfully changed name of graph" );
use_ok( 'Text::Tradition::Stemma' );
# Try to create a bad graph
-my $baddotfh;
-open( $baddotfh, 't/data/besoin_bad.dot' ) or die "Could not open test dotfile";
try {
- my $stemma = Text::Tradition::Stemma->new( dot => $baddotfh );
+ my $stemma = Text::Tradition::Stemma->new( dotfile => 't/data/besoin_bad.dot' );
ok( 0, "Created broken stemma from dotfile with syntax error" );
} catch( Text::Tradition::Error $e ) {
like( $e->message, qr/^Error trying to parse/, "Syntax error in dot threw exception" );
}
# Create a good graph
-my $dotfh;
-open( $dotfh, 't/data/florilegium.dot' ) or die "Could not open test dotfile";
-binmode( $dotfh, ':utf8' );
-my $stemma = Text::Tradition::Stemma->new( dot => $dotfh );
+my $stemma = Text::Tradition::Stemma->new( dotfile => 't/data/florilegium.dot' );
is( ref( $stemma ), 'Text::Tradition::Stemma', "Created stemma from good dotfile" );
is( scalar $stemma->witnesses, 13, "Found correct number of extant witnesses" );
is( scalar $stemma->hypotheticals, 8, "Found correct number of extant hypotheticals" );
ok( $found_unicode_sigil, "Found a correctly encoded Unicode sigil" );
# Create an undirected graph
-my $undirdotfh;
-open( $undirdotfh, 't/data/besoin_undirected.dot' ) or die "Could not open test dotfile";
-binmode( $undirdotfh, ':utf8' );
-my $udstemma = Text::Tradition::Stemma->new( dot => $undirdotfh );
+my $udstemma = Text::Tradition::Stemma->new( dotfile => 't/data/besoin_undirected.dot' );
is( ref( $udstemma ), 'Text::Tradition::Stemma', "Created stemma from undirected dotfile" );
is( scalar $udstemma->witnesses, 13, "Found correct number of extant witnesses" );
is( scalar $udstemma->hypotheticals, 12, "Found correct number of hypotheticals" );
projects / scpubgit/stemmatology.git / commitdiff