TreeOfTexts/lib/TreeOfTexts/Controller/Stemmagraph.pm

   1 package TreeOfTexts::Controller::Stemmagraph;
   2 use Moose;
   3 use namespace::autoclean;
   4 use File::Temp;
   5 use JSON;
   6 use Text::Tradition::Collation;
   7 use Text::Tradition::StemmaUtil qw/ character_input phylip_pars newick_to_svg /;
   8
   9 BEGIN { extends 'Catalyst::Controller' }
  10
  11 #
  12 # Sets the actions in this controller to be registered with no prefix
  13 # so they function identically to actions created in MyApp.pm
  14 #
  15 __PACKAGE__->config(namespace => '');
  16
  17 =head1 NAME
  18
  19 TreeOfTexts::Controller::Stemmagraph - Simple controller for stemma display
  20
  21 =head1 DESCRIPTION
  22
  23 [enter your description here]
  24
  25 =head1 METHODS
  26
  27 =cut
  28
  29 sub get_graph :Local {
  30         my( $self, $c ) = @_;
  31         # If called interactively, we have params 'display', 'output', 'witnesses'
  32         # If called non-interactively, we look at headers and content.
  33         # The body is actually a File::Temp object; this is undocumented but
  34         # so it seems to be.
  35         my $dotfile;
  36         my $must_unlink = 0;
  37         if( $c->request->params->{'dot'} ) {
  38             # Make a File::Temp object.
  39             my $tmpfile = File::Temp->new( UNLINK => 0 );
  40             print $tmpfile $c->request->params->{'dot'};
  41             $dotfile = $tmpfile->filename;
  42             $must_unlink = 1;
  43         } else {
  44             $dotfile = $c->request->body;
  45         }
  46         my $format = 'svg';
  47
  48     # Render the dot in the given format.
  49     my $collation = Text::Tradition::Collation->new();
  50     my $stemma = Text::Tradition::Stemma->new( 'collation' => $collation, 'dot' => $dotfile );
  51     unlink( $dotfile ) if $must_unlink;
  52     $c->stash->{result} = $stemma->as_svg;
  53     $c->forward( "View::SVG" );
  54 }
  55
  56 =head2 character_matrix
  57
  58 Given an alignment table in JSON form, in the parameter 'alignment', returns a
  59 character matrix suitable for input to Phylip PARS.
  60
  61 =cut
  62
  63 sub character_matrix :Local {
  64         my( $self, $c ) = @_;
  65         my $json = $c->request->params->{'alignment'};
  66         $c->log->debug( $json );
  67         my $table = from_json( $json );
  68         my $matrix = character_input( $table );
  69         $c->stash->{'result'} = { 'matrix' => $matrix };
  70         $c->forward( 'View::JSON' );
  71 }
  72
  73 =head2 run_pars
  74
  75 Takes either an alignment table in JSON format (passed as the parameter 'alignment')
  76 or a character matrix Phylip accepts (passed as the parameter 'matrix').  Returns
  77 either the Newick-format answer or an SVG representation of the graph.
  78
  79 =cut
  80
  81 sub run_pars :Local {
  82         my( $self, $c ) = @_;
  83         my $error;
  84         my $view = 'View::JSON';
  85         my $matrix;
  86         if( $c->request->param('matrix') ) {
  87                 $matrix = $c->request->param('matrix');
  88         } elsif( $c->request->param('alignment') ) {
  89                 # Make the matrix from the alignment
  90                 my $table = from_json( $c->request->param('alignment') );
  91                 $matrix = character_input( $table );
  92         } else {
  93                 $error = "Must pass either an alignment or a matrix";
  94         }
  95
  96         # Got the matrix, so try to run pars.
  97         my( $result, $output );
  98         unless( $error ) {
  99                 ( $result, $output ) = phylip_pars( $matrix );
 100                 $error = $output unless( $result );
 101         }
 102
 103         # Did we want newick or a graph?
 104         unless( $error ) {
 105                 my $format = 'newick';
 106                 $format = $c->request->param('format') if $c->request->param('format');
 107                 if( $format eq 'svg' ) {
 108                         # Do something
 109                         $c->stash->{'result'} = newick_to_svg( $output );
 110                         $view = 'View::SVG';
 111                 } elsif( $format ne 'newick' ) {
 112                         $error = "Requested output format $format unknown";
 113                 } else {
 114                         $c->stash->{'result'} = { 'tree' => $output };
 115                 }
 116         }
 117
 118         if( $error ) {
 119                 $c->stash->{'error'} = $error;
 120         } # else the stash is populated.
 121         $c->forward( $view );
 122 }
 123
 124 =head1 AUTHOR
 125
 126 Tara L Andrews
 127
 128 =head1 LICENSE
 129
 130 This library is free software. You can redistribute it and/or modify
 131 it under the same terms as Perl itself.
 132
 133 =cut
 134
 135 __PACKAGE__->meta->make_immutable;
 136
 137 1;