• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Controller::Test;

# contains methods for test purposes only

use IO::All;
use Data::Dumper;
use LIMS::Local::Sugar;
use Time::HiRes qw(gettimeofday tv_interval);
use CGI::Application::Plugin::Output::XSV (':all');

use Moose;
BEGIN { extends 'LIMS::Base'; }
with 'LIMS::Controller::Roles::PDF';

# for test harness:
# $ENV{DEBUG_ON}=1;

startmode default {
    $self->_debug_path($self->get_current_runmode);

    return $self->dump_html;
}

# test flash under redirect:
runmode test_flash ($mode) {
    $self->_debug_path($self->get_current_runmode);

    # for 99test.t:
    if ($mode) {
        $self->flash( $mode => 'redirect from ' . $self->get_current_runmode );
    }
    # for Resources/Test flash:
    else {
        for ( qw/error warning info/ ) {
            $self->flash( $_ => 'redirect from ' . $self->get_current_runmode );
        }
    }

    #warn 'FLASH IS_EMPTY: '.$self->flash->is_empty;
    #$self->flash->set( $mode => 'redirected from ' . $self->get_current_runmode );
    #warn 'FLASH IS_EMPTY: '.$self->flash->is_empty;
    #warn Dumper $self->flash->dump;

	# uncomment next line to preserve content of session:
	# return $self->dump_html;
    return $self->redirect( $self->query->url . '/resources' );
}

runmode db_status {
	my $list = $self->model('Test')->db_status;
	return $self->tt_process({ list => $list });
}

runmode test_error {
    $self->_debug_path($self->get_current_runmode);
	require LIMS::Local::Stuff;
	my $str = LIMS::Local::Stuff::silly_werder()
	|| 'Silly::Werder package required for this test function';
    return $self->error($str);
}

runmode dump_session { $self->tt_process() }

runmode error_500 {
	return $self->forward('non-existant-runmode');
}

runmode test_email {
    $self->_debug_path($self->get_current_runmode);

    my $cfg = $self->cfg('settings');

    if ( $self->query->param('test_fail') ) {
        delete $cfg->{service_email}; # make it fail
    }

    my %data = (
        recipient => $cfg->{service_email},
        config    => $cfg,
        subject   => 'Test message from ' . $cfg->{application_name},
        message   => 'Test sent: ' . LIMS::Local::Utils::date_and_time_now,
    );

    my $rtn = $self->model('Email')->send_message(\%data); # Return::Value object

    return $self->tt_process({ result => $rtn });
}

runmode print_pdf {
    $self->_debug_path($self->get_current_runmode);

    my $html = do {
        my @args = ("\n\t", "\t", $self->dump_html);
        LIMS::Local::Utils::text_wrap(80, \@args);
    }; # warn $html;
    my $pdf = $self->inline_html_to_pdf(\$html);

    $self->header_add(-type => 'application/pdf', -expires => 'now');
    return $pdf;
}

# display $q->url methods:
runmode test_urls {
    my $q = $self->query;

    my %data = (
        ''             => $q->url(),
        'full=>1'      => $q->url(-full=>1),  # alternative syntax
        'relative=>1'  => $q->url(-relative=>1),
        'absolute=>1'  => $q->url(-absolute=>1),
        'path_info=>1' => $q->url(-path_info=>1),
        'base => 1'    => $q->url(-base => 1),
        'rewrite=>1'   => $q->url(-rewrite=>1),
        'rewrite=>0'   => $q->url(-rewrite=>0),

        'path_info=>1, -query=>1'   => $q->url(-path_info=>1,-query=>1),
        'path_info=>1, -rewrite=>1' => $q->url(-path_info=>1, -rewrite=>1),
        'path_info=>1, -rewrite=>0' => $q->url(-path_info=>1, -rewrite=>0),
    );

    $self->tt_params( queries => \%data );

    return $self->tt_process;
}

runmode forbidden_page {
    return $self->forbidden();
}

=begin # how to test this?
runmode memory_leak_test {
    my $test = {
        fred   => [qw(a b c d e)],
        ethel  => [qw(1 2 3 4 5)],
        george => {
            martha => 23,
            agnes  => 19,
        }
    };
    $test->{george}{phyllis} = $test;
    $test->{fred}[3] = $test->{george};
    $test->{george}{mary} = $test->{fred};
    return $test;
}
=cut

runmode arena_table {
    require Devel::Gladiator; #  qw(arena_ref_counts arena_table);
    return $self->tt_process( { data => Devel::Gladiator::arena_table() } );
};

runmode db_read_timer {
    my $cycles = $self->query->param('cycles'); # defaults in model to all rows
    my $i = $self->model('Test')->db_read_timer($cycles); # reads referrers table

    my $t = sprintf '%.4f sec', tv_interval $self->param('t0'), [gettimeofday];
    $self->tt_params(
        timer => $t,
        count => $i,
    );
    return $self->tt_process('test/db_timer.tt');
}

runmode db_write_timer {
    my $cycles = $self->query->param('cycles');
    $cycles = 10_000 unless defined $cycles; # to allow for '0'

    my $i = $self->model('Test')->db_write_timer($cycles); # writes to lims_test.timer table
    my $t = sprintf '%.4f sec', tv_interval $self->param('t0'), [gettimeofday];
    $self->tt_params(
        timer => $t,
        count => $i,
    );
    return $self->tt_process('test/db_timer.tt');
}

runmode db_read_write_timer {
    my $cycles = $self->query->param('cycles');
    $cycles = 10_000 unless defined $cycles; # to allow for '0'

    # reads from referrers & writes to lims_test.timer table:
    my $i = $self->model('Test')->db_read_write_timer($cycles);
    my $t = sprintf '%.4f sec', tv_interval $self->param('t0'), [gettimeofday];
    $self->tt_params(
        timer => $t,
        count => $i,
    );
    return $self->tt_process('test/db_timer.tt');
}

runmode rose_helpers {
    # get some db objects with relationships:
    my $data = $self->model('Test')->get_all_diagnoses;

    foreach my $o ( @$data ) {
        warn Dumper { $o->column_value_pairs };
    }
    $self->tt_params( data => $data );
    return $self->tt_process;
}

# test $SIG{__DIE__} handler:
runmode no_validation_profile {
    $self->js_validation_profile('no_exists');

    return $self->dump_html;
}

runmode xl_out {
    my @fields  = qw(member_id first_name last_name);
    my $headers = clean_field_names( \@fields );

    my $data = [
        {
            member_id => 1,
            first_name => 'foo',
            last_name => 'bar',
        }
    ];

    my %opts = (
        fields   => $headers,
        values   => $data,
        csv_opts => { sep_char => "\t" }, # = default
        filename => 'members.csv',
        include_headers => 1, # = default
    );

    return $self->xsv_report_web(\%opts);
}

runmode iterator {

    my $lots_of_records = $self->model('Base')->get_objects_iterator('Specimen');

    my $i = 0;

    while ( my $rec = $lots_of_records->next ) {
        if ( ++$i > 10 ) {
            # $self->pager({ query => \%args_for_search, total => $count });

        }
        # warn $i;
    }

    return $self->dump_html;
}

runmode xml_out ($location) {
    return unless $location && length $location >= 3; warn 'here';

    use XML::Simple qw(:strict); # need to specify ForceArray & KeyAttr if using :strict here

    my $xs = XML::Simple->new();

    my %xs_out_options = (
        RootName        => 'results',
        NoAttr          => 1,
        XMLDecl         => 1,        ,
        SuppressEmpty   => 1, # ? only works for xml_in
        KeyAttr         => [],
    );

    my %args = (
        query   => [ display_name => { like => '%' . $location . '%' } ],
        sort_by => 'display_name',
        limit   => 10,
    );

    my $sources = $self->model('Base')->get_objects( 'ReferralSource', \%args );
    # $self->debug( [ map { $_->display_name } @$sources ] );

    my @output = map {
        sprintf '<rs id="%s" info="%s">%s</rs>', # escape html (eg '&') or ajax function silently fails:
            $_->id, $_->organisation_code, $self->query->escapeHTML($_->display_name);
    } @$sources;

    # TODO: use XML::Simple to generate xml (My::ULISA)
    #my $xml = sprintf '<?xml version="1.0" encoding="utf-8" ?><results>%s</results>', join '', @output;

    # set header type to xml:
    $self->header_props(-type=>'text/xml');

    my $data = q!
<results>
<rs id="48" info="RBL14 ">Arrowe Park, Wirral</rs>
<rs id="21" info="NT308 ">BUPA - Gatwick Park</rs>
<rs id="22" info="NT320 ">BUPA - Park Way</rs>
<rs id="29" info="NT409 ">Chelsfield Park Hospital</rs>
</results>!;

    my $ref = XMLin($data, ForceArray => 1, KeyAttr => []); $self->debug($ref);
    my %rs;

    foreach (@$sources) {
        my $data = {
            info => $_->organisation_code,
            content => $self->query->escapeHTML($_->display_name)
        };
        #push @{$rs{rs}}, $data;
        $rs{$_->id} = $data;
    } # $self->debug(\%rs);

    my $xml = XMLout($ref, %xs_out_options);

    return $xml;
}

1;