X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fstemmaweb%2FController%2FRoot.pm;h=d798cbd8017fe986a25b2bc7da29cd62a7dfdf28;hb=63378fe0ded6c73b770dc34025f5508467a16ade;hp=abc19522939b97edf1f1df04127b09158b00b292;hpb=e0b902362ea75e07419933809f6cf99a2f2d082c;p=scpubgit%2Fstemmaweb.git diff --git a/lib/stemmaweb/Controller/Root.pm b/lib/stemmaweb/Controller/Root.pm index abc1952..d798cbd 100644 --- a/lib/stemmaweb/Controller/Root.pm +++ b/lib/stemmaweb/Controller/Root.pm @@ -1,9 +1,10 @@ package stemmaweb::Controller::Root; -use File::Temp; use Moose; use namespace::autoclean; use Text::Tradition::Analysis qw/ run_analysis /; use TryCatch; +use XML::LibXML; +use XML::LibXML::XPathContext; BEGIN { extends 'Catalyst::Controller' } @@ -52,6 +53,17 @@ sub about :Local :Args(0) { $c->stash->{template} = 'about.tt'; } +=head2 help/* + +A dispatcher for documentation of various aspects of the application. + +=cut + +sub help :Local :Args(1) { + my( $self, $c, $topic ) = @_; + $c->stash->{template} = "$topic.tt"; +} + =head1 Elements of index page =head2 directory @@ -90,8 +102,7 @@ sub directory :Local :Args(0) { { name: , language: , public: , - filename: , - file: } + file: } Creates a new tradition belonging to the logged-in user, with the given name and the collation given in the uploaded file. The file type is indicated via @@ -100,7 +111,6 @@ name of the new tradition. =cut -## TODO Figure out how to mimic old-style HTML file uploads in AJAX / HTML5 sub newtradition :Local :Args(0) { my( $self, $c ) = @_; return _json_error( $c, 403, 'Cannot save a tradition without being logged in' ) @@ -109,35 +119,55 @@ sub newtradition :Local :Args(0) { my $user = $c->user->get_object; # Grab the file upload, check its name/extension, and call the # appropriate parser(s). - my $upload = File::Temp->new(); - print $upload $c->request->param('file'); - close $upload; + my $upload = $c->request->upload('file'); my $name = $c->request->param('name') || 'Uploaded tradition'; my $lang = $c->request->param( 'language' ) || 'Default'; my $public = $c->request->param( 'public' ) ? 1 : undef; - my( $ext ) = $c->request->param( 'filename' ) =~ /\.(\w+)$/; + my( $ext ) = $upload->filename =~ /\.(\w+)$/; my %newopts = ( 'name' => $name, 'language' => $lang, 'public' => $public, - 'file' => $upload->filename + 'file' => $upload->tempname ); my $tradition; my $errmsg; if( $ext eq 'xml' ) { - # Try the different XML parsing options to see if one works. - foreach my $type ( qw/ CollateX CTE TEI / ) { + my $type; + # Parse the XML to see which flavor it is. + my $parser = XML::LibXML->new(); + my $doc; + try { + $doc = $parser->parse_file( $newopts{'file'} ); + } catch( $err ) { + $errmsg = "XML file parsing error: $err"; + } + if( $doc ) { + if( $doc->documentElement->nodeName eq 'GraphML' ) { + $type = 'CollateX'; + } elsif( $doc->documentElement->nodeName ne 'TEI' ) { + $errmsg = 'Unrecognized XML type ' . $doc->documentElement->nodeName; + } else { + my $xpc = XML::LibXML::XPathContext->new( $doc->documentElement ); + my $venc = $xpc->findvalue( '/TEI/teiHeader/encodingDesc/variantEncoding/attribute::method' ); + if( $venc && $venc eq 'double-end-point' ) { + $type = 'CTE'; + } else { + $type = 'TEI'; + } + } + } + # Try the relevant XML parsing option. + if( $type ) { + delete $newopts{'file'}; + $newopts{'xmlobj'} = $doc; try { $tradition = Text::Tradition->new( %newopts, 'input' => $type ); } catch ( Text::Tradition::Error $e ) { $errmsg = $e->message; - } catch { - $errmsg = "Unexpected parsing error"; - } - if( $tradition ) { - $errmsg = undef; - last; + } catch ( $e ) { + $errmsg = "Unexpected parsing error: $e"; } } } elsif( $ext =~ /^(txt|csv|xls(x)?)$/ ) { @@ -155,8 +185,8 @@ sub newtradition :Local :Args(0) { ); } catch ( Text::Tradition::Error $e ) { $errmsg = $e->message; - } catch { - $errmsg = "Unexpected parsing error"; + } catch ( $e ) { + $errmsg = "Unexpected parsing error: $e"; } } else { # Error unless we have a recognized filename extension @@ -195,6 +225,9 @@ Returns information about a particular text. sub textinfo :Local :Args(1) { my( $self, $c, $textid ) = @_; my $tradition = $c->model('Directory')->tradition( $textid ); + ## Have to keep users in the same scope as tradition + my $newuser; + my $olduser; unless( $tradition ) { return _json_error( $c, 404, "No tradition with ID $textid" ); } @@ -222,7 +255,8 @@ sub textinfo :Local :Args(1) { } # Handle language param, making Default => null my $langval = delete $params->{language} || 'Default'; - unless( $tradition->language eq $langval ) { + + unless( $tradition->language eq $langval || !$tradition->can('language') ) { try { $tradition->language( $langval ); $changed = 1; @@ -242,20 +276,26 @@ sub textinfo :Local :Args(1) { } # Handle ownership change - my $newuser; if( exists $params->{'owner'} ) { # Only admins can update user / owner my $newownerid = delete $params->{'owner'}; + if( $tradition->has_user && !$tradition->user ) { + $tradition->clear_user; + } unless( !$newownerid || - ( $tradition->has_user && $tradition->user->id eq $newownerid ) ) { + ( $tradition->has_user && $tradition->user->email eq $newownerid ) ) { unless( $c->user->get_object->is_admin ) { return _json_error( $c, 403, "Only admin users can change tradition ownership" ); } - $newuser = $m->find_user({ username => $newownerid }); + $newuser = $m->find_user({ email => $newownerid }); unless( $newuser ) { return _json_error( $c, 500, "No such user " . $newownerid ); } + if( $tradition->has_user ) { + $olduser = $tradition->user; + $olduser->remove_tradition( $tradition ); + } $newuser->add_tradition( $tradition ); $changed = 1; } @@ -274,12 +314,19 @@ sub textinfo :Local :Args(1) { my $textinfo = { textid => $textid, name => $tradition->name, - language => $tradition->language, + #language => $tradition->language, public => $tradition->public || 0, - owner => $tradition->user ? $tradition->user->id : undef, + owner => $tradition->user ? $tradition->user->email : undef, witnesses => [ map { $_->sigil } $tradition->witnesses ], }; - my @stemmasvg = map { $_->as_svg() } $tradition->stemmata; + if( $tradition->can('language') ) { + $textinfo->{'language'} = $tradition->language; + } + my @stemmasvg = map { { + name => $_->identifier, + directed => _json_bool( !$_->is_undirected ), + svg => $_->as_svg() } } + $tradition->stemmata; map { $_ =~ s/\n/ /mg } @stemmasvg; $textinfo->{stemmata} = \@stemmasvg; $c->stash->{'result'} = $textinfo; @@ -335,6 +382,21 @@ sub stemma :Local :Args(2) { 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/(?forward('View::SVG'); } else { # JSON $stemma_xml =~ s/\n/ /mg; - $c->stash->{'result'} = { 'stemmaid' => $stemmaid, 'stemmasvg' => $stemma_xml }; + $c->stash->{'result'} = { + 'stemmaid' => $stemmaid, + 'name' => $stemma->identifier, + 'directed' => _json_bool( !$stemma->is_undirected ), + 'svg' => $stemma_xml }; $c->forward('View::JSON'); } } @@ -417,6 +483,30 @@ sub stemmadot :Local :Args(2) { $c->forward('View::JSON'); } +=head2 download + + GET /download/$textid + +Returns the full XML definition of the tradition and its stemmata, if any. + +=cut + +sub download :Local :Args(1) { + my( $self, $c, $textid ) = @_; + my $tradition = $c->model('Directory')->tradition( $textid ); + unless( $tradition ) { + return _json_error( $c, 404, "No tradition with ID $textid" ); + } + my $ok = _check_permission( $c, $tradition ); + return unless $ok; + try { + $c->stash->{'result'} = $tradition->collation->as_graphml(); + } catch( Text::Tradition::Error $e ) { + return _json_error( $c, 500, $e->message ); + } + $c->forward('View::GraphML'); +} + #################### ### Helper functions #################### @@ -446,6 +536,10 @@ sub _json_error { return 0; } +sub _json_bool { + return $_[0] ? JSON::true : JSON::false; +} + =head2 default Standard 404 error page