use Moose;
use namespace::autoclean;
use JSON qw ();
-use LWP::UserAgent;
use TryCatch;
use XML::LibXML;
use XML::LibXML::XPathContext;
#
__PACKAGE__->config(namespace => '');
-my $STEMWEB_BASE_URL = 'http://slinkola.users.cs.helsinki.fi';
-
=head1 NAME
stemmaweb::Controller::Root - Root Controller for stemmaweb
if( $c->req->param('withtradition') ) {
$c->stash->{'withtradition'} = $c->req->param('withtradition');
}
- # Get the current list of Stemweb algorithms
- my $ua = LWP::UserAgent->new();
- my $resp = $ua->get( $STEMWEB_BASE_URL . '/algorithms/available' );
- if( $resp->is_success ) {
- $c->stash->{'stemweb_algorithms'} = $resp->content;
- } else {
- $c->stash->{'stemweb_algorithms'} = '{}';
- }
$c->stash->{template} = 'index.tt';
}
$errmsg = "XML file parsing error: $err";
}
if( $doc ) {
- if( $doc->documentElement->nodeName eq 'GraphML' ) {
+ if( $doc->documentElement->nodeName eq 'graphml' ) {
$type = 'CollateX';
} elsif( $doc->documentElement->nodeName ne 'TEI' ) {
$errmsg = 'Unrecognized XML type ' . $doc->documentElement->nodeName;
$tradition->name( $newname );
$changed = 1;
} catch {
- return _json_error( $c, 500, "Error setting name to $newname" );
+ return _json_error( $c, 500, "Error setting name to $newname: $@" );
}
}
}
$tradition->language( $langval );
$changed = 1;
} catch {
- return _json_error( $c, 500, "Error setting language to $langval" );
+ return _json_error( $c, 500, "Error setting language to $langval: $@" );
}
}
owner => $tradition->user ? $tradition->user->email : undef,
witnesses => [ map { $_->sigil } $tradition->witnesses ],
};
+ ## TODO Make these into callbacks in the other controllers maybe?
if( $tradition->can('language') ) {
$textinfo->{'language'} = $tradition->language;
}
if( $tradition->can('stemweb_jobid') ) {
$textinfo->{'stemweb_jobid'} = $tradition->stemweb_jobid || 0;
}
- my @stemmasvg = map { {
- name => $_->identifier,
- directed => _json_bool( !$_->is_undirected ),
- svg => $_->as_svg() } }
- $tradition->stemmata;
- map { $_ =~ s/\n/ /mg } @stemmasvg;
+ my @stemmasvg = map { _stemma_info( $_ ) } $tradition->stemmata;
$textinfo->{stemmata} = \@stemmasvg;
$c->stash->{'result'} = $textinfo;
$c->forward('View::JSON');
$c->stash->{'result'} = $collation->as_svg;
$c->forward('View::SVG');
}
+
+sub _stemma_info {
+ my( $stemma, $sid ) = @_;
+ my $ssvg = $stemma->as_svg();
+ $ssvg =~ s/\n/ /mg;
+ my $sinfo = {
+ name => $stemma->identifier,
+ directed => _json_bool( !$stemma->is_undirected ),
+ svg => $ssvg };
+ if( $sid ) {
+ $sinfo->{stemmaid} = $sid;
+ }
+ return $sinfo;
+}
+
+## TODO Separate stemma manipulation functionality into its own controller.
=head2 stemma
if( $c->req->method eq 'POST' ) {
if( $ok eq 'full' ) {
my $dot = $c->request->body_params->{'dot'};
- # Graph::Reader::Dot does not handle bare unicode. 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 .*'.
- # Horrible HACK.
- my @dlines = split( "\n", $dot );
- my $wdot = '';
- foreach( @dlines ) {
- unless( /^(di)?graph/ ) { # Skip the first line
- s/(?<!")\b(\w+)\b(?!")/"$1"/g;
- }
- $wdot .= "$_\n";
- }
- # $dot =~ s/(?<!")\b(?!(?:digraph|stemma)\b)(\w+)\b(?!")/"$1"/g;
- $dot = $wdot;
- print STDERR "$dot\n";
try {
if( $stemmaid eq 'n' ) {
# We are adding a new stemma.
if( !$stemma && $tradition->stemma_count > $stemmaid ) {
$stemma = $tradition->stemma( $stemmaid );
}
- my $stemma_xml = $stemma ? $stemma->as_svg() : '';
# What was requested, XML or JSON?
my $return_view = 'SVG';
if( my $accept_header = $c->req->header('Accept') ) {
}
}
if( $return_view eq 'SVG' ) {
- $c->stash->{'result'} = $stemma_xml;
+ $c->stash->{'result'} = $stemma->as_svg();
$c->forward('View::SVG');
} else { # JSON
- $stemma_xml =~ s/\n/ /mg;
- $c->stash->{'result'} = {
- 'stemmaid' => $stemmaid,
- 'name' => $stemma->identifier,
- 'directed' => _json_bool( !$stemma->is_undirected ),
- 'svg' => $stemma_xml };
+ $c->stash->{'result'} = { _stemma_info( $stemma, $stemmaid ) };
$c->forward('View::JSON');
}
}
$c->forward('View::JSON');
}
+=head2 stemmaroot
+
+ POST /stemmaroot/$textid/$stemmaseq, { root: <root node ID> }
+
+Orients the given stemma so that the given node is the root (archetype). Returns the
+information structure for the new stemma.
+
+=cut
+
+sub stemmaroot :Local :Args(2) {
+ my( $self, $c, $textid, $stemmaid ) = @_;
+ my $m = $c->model('Directory');
+ my $tradition = $m->tradition( $textid );
+ unless( $tradition ) {
+ return _json_error( $c, 404, "No tradition with ID $textid" );
+ }
+ my $ok = _check_permission( $c, $tradition );
+ if( $ok eq 'full' ) {
+ my $stemma = $tradition->stemma( $stemmaid );
+ try {
+ $stemma->root_graph( $c->req->param('root') );
+ $m->save( $tradition );
+ } catch( Text::Tradition::Error $e ) {
+ return _json_error( $c, 400, $e->message );
+ } catch {
+ return _json_error( $c, 500, "Error re-rooting stemma: $@" );
+ }
+ $c->stash->{'result'} = _stemma_info( $stemma );
+ $c->forward('View::JSON');
+ } else {
+ return _json_error( $c, 403,
+ 'You do not have permission to update stemmata for this tradition' );
+ }
+}
+
=head2 download
GET /download/$textid