# use Modern::Perl qw(2012); # not supported in perl 5.10 # use autodie; # TODO: exons not sorted naturally; data supplied to tt as chr:location key, not exon package NGS; use Dancer2 ':syntax'; 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 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, }; _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 port for debug rules: $opts->{port} = config->{port}; 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): 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; 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 $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;