package NGS; use Modern::Perl qw(2012); # 5.14 use autodie; # TODO: exons not sorted naturally; data supplied to tt as chr:location key, not exon use Dancer2; use Dancer2::Core::Error; # use Dancer::Plugin::Database; # doesn't work in D2 use Time::HiRes qw(gettimeofday tv_interval); use Data::Dump qw(dump); use Carp qw(croak); use Template; use IO::All; use autodie; use NGS::VEP; our $VERSION = '0.1'; # --- Globals ------------------------------------------------------------------ use constant VEP_SRC_FILENAME => 'data_src'; # form param containing filename use constant VEP_INPUT_TT => 'vep.tt'; # tmpl contains vep data input form use constant VEP_OUTPUT_TT => 'vep/result.tt'; # tmpl to handle vep results #------------------------------------------------------------------------------- hook before_template_render => sub { my $tokens = shift; $tokens->{nsort_labno} = sub { my $list = shift || return; # warn dump $list; return sort _sort_by_labno(@$list); }; $tokens->{nsort_exon} = sub { # can't do this yet - key = chr:location not exon my $list = shift || return; # warn dump $list; return sort _sort_by_exon(@$list); }; }; #------------------------------------------------------------------------------- get '/' => sub { template 'index' }; # default index page #------------------------------------------------------------------------------- get '/vep' => sub { debug 'GET upload page'; template VEP_INPUT_TT, { title => 'Upload VEP DataFile' }; }; #------------------------------------------------------------------------------- post '/vep' => sub { debug 'POST upload page'; # debug "Params are : " . dump( request->params ); my %allparams = params; # debug dump \%allparams; my $input = { data_file => upload(VEP_SRC_FILENAME) || undef, form_opts => \%allparams, }; # warn dump $input->{data_file}; _validate_user_input($input); # debug 'Validation results: ' . dump($input); #-- display any errors if ( exists $input->{upload_error} ) { debug 'have upload error'; return template VEP_INPUT_TT, { title => 'Upload Data Error', warning_message => 'You must upload the file again!', %$input, }; } #-- passed validation debug 'OK passed the error checks.'; my $src = $input->{data_file}->content; # debug $data; my $opts = $input->{form_opts}; # add running environment for VEP debug rules: $opts->{environment} = dancer_app->environment; # warn $opts->{environment}; my $t0 = [gettimeofday]; # set t0 # send submitted src data to vep script: my $data = _parse({ src => $src, opts => $opts }); $data->{runtime} = tv_interval $t0, [gettimeofday]; # vep script runtime # delete temp file (if exists; auto-deleted for .t uploads): unless ( $input->{data_file}->{temp_fh} ) { # only exists for .t uploads if ( my $tmp_file = $input->{data_file}->tempname ) { io($tmp_file)->unlink if -e $tmp_file; } } return template VEP_OUTPUT_TT, { results => $data }; }; #------------------------------------------------------------------------------- sub _parse { my $args = shift; # warn dump $args->{opts}; my %args = ( form_opts => $args->{opts}, src_data => $args->{src}, ); my $parser = NGS::VEP->new(%args); return $parser->result; } #------------------------------------------------------------------------------- sub _validate_user_input { my $validation_report = shift; if ( defined $validation_report->{data_file} ) { debug 'At least there is a file uploaded.'; #------ Check that the file is a valid data file $validation_report->{upload_error} = 'Not a valid data file!' unless _validate_file( $validation_report->{data_file} ); } else { $validation_report->{upload_error} = 'No data file uploaded!'; } } #------------------------------------------------------------------------------- sub _validate_file { my $in_file = shift; # warn dump $in_file; my $cfg = config->{InputFile}; my $max_file_size = $cfg->{max_file_size} * 1024 * 1024; # MB my $file_suffix = $cfg->{file_suffix}; return ( $in_file && ( lc $in_file->basename =~ /$file_suffix\Z/ ) && ( $in_file->size <= $max_file_size ) ); } #------------------------------------------------------------------------------- sub _sort_by_labno { my ($y1, $r1) = split '_', $a; # warn Dumper [$r1, $y1]; my ($y2, $r2) = split '_', $b; # warn Dumper [$r2, $y2]; return $y1 <=> $y2 || $r1 <=> $r2; } #------------------------------------------------------------------------------- sub _sort_by_exon { return $a cmp $b; } true;