• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Role::Base;

# provides shared methods for LIMS, and at least one other LIMS::Local class

use Moose::Role;

use YAML::Tiny;
use Regexp::Common;
use Sort::Naturally;
use LIMS::Local::Chart;
use LIMS::Local::Utils;
use Scalar::Util qw(weaken);

#-------------------------------------------------------------------------------
# supplies some callback methods (eg join_hash_values, symbolise) to templates
# called as: $self->render_view('some/template.tt', { foo => $foo, etc });
sub render_view {
	my $self = shift;
	my $tmpl = shift
		|| return $self->error('no template name passed to render_view()');
	my $args = shift || {}; # optional args for template

    my $_self = $self; weaken $_self; # or get circular refs inside the callbacks
    
	# so tmpl can supply a hash + keys to join
	my $join_hash_values = sub {
		my ($separator, $hash) = @_;
		return join $separator, grep defined, @{ $hash }{ @_ };
	};

    # eg 10/9/L -> <sup>9</sup>, ul -> &micro;
    my $symbolised = sub {
        my $str = shift;
        return LIMS::Local::Utils::symbolise($str);
    };
    
	my $line_break = sub {
		my $str = shift;
		$str =~ s/(\r\n)+/\n\n/g; # insert 2 line-breaks for FILTER html_line_break
		return $str;
	};
	
	my $get_trial_number = sub {
		# my ($patient_id, trial_id) = @_; just hand @_ direct:		
		my $trial_no
			= $_self->model('ClinicalTrial')->get_trial_number(@_);
		return $trial_no;
	};
	
	my $start_date = sub {
		return $_self->model('Request')->get_first_request_date;
	};
    
	my $nsort = sub {
		my $list = shift; # warn Dumper $list;
		return Sort::Naturally::nsort(@$list);
	};
	
	my $has_mdt_contact = sub {
		my $id = shift; # parent_organisation_id
		return $_self->model('ReferralSource')->has_mdt_contact($id);
	};
	
	my $make_chart = sub {
		my ($chart_type, $request_id) = @_; # warn $chart_type; warn $request_id;
		
		my $chart = LIMS::Local::Chart->new(
			request_id => $request_id,
			model      => $_self->model,
		);
		do { $chart->$chart_type() }; 
		
		return 'bar';
	};
	
    my $is_numerical = sub {
        my $str = shift;
        return $str =~ /\A$RE{num}{real}\Z/; # only matches int & decimal numbers
    };

    my $sig_figs = sub {
        my $param = shift;
        return LIMS::Local::Utils::sig_figs($param);
    };
    
    my $format_first_name = sub {
        my $patient = shift;
        return $_self->_format_first_name($patient); # returns empty if no rule
    };
    
    # NB: these accessors MUST NOT clash with existing ones:
	$self->tt_params(
        format_firstname => $format_first_name,
        join_hash_values => $join_hash_values,
		get_trial_number => $get_trial_number,
		has_mdt_contact  => $has_mdt_contact,
		natural_sort	 => $nsort,
		start_date       => $start_date,
		line_break		 => $line_break,
        symbolise        => $symbolised,
		create_chart	 => $make_chart,
        is_numerical     => $is_numerical,
        sig_figs         => $sig_figs,
    );

	return $self->tt_process($tmpl, $args);
}

sub model {
    my $self = shift;
    my $classname = shift
		|| $self->error( 'Required classname attribute missing' );
    # warn 'classname:'. $classname;

    # return stashed package object if it exists:
    if ( my $stashed = $self->stash->{"model::$classname"} ) {
           # $self->debug("model::$classname IS in stash");
        return $stashed;
    }

    my $package = "LIMS::Model::$classname";
    # $self->debug("model::$classname NOT in stash");

	# load package via require:
    unless (eval "require $package") {
        $self->error("Unable to load module [$package].");
    }

	my %args = (
		_lims_db  => $self->lims_db, # required by LIMS::Model::Base
		_session  => $self->session, # required by LIMS::Model::Roles::SessionData
	);
	
    # instantiate object
    my $model = $package->new(%args)
	|| $self->error("unable to instatiate [$package]."); # $self->debug("instatiated $package.");

    $self->stash->{"model::$classname"} = $model;

    return $model;
}

#-------------------------------------------------------------------------------
sub get_yaml_file {
	my ($self, $filename) = @_; # warn $filename;

	return $self->stash->{__yaml_file}->{$filename}
		if $self->stash->{__yaml_file}->{$filename}; # in case called in a loop

	my $src = $self->cfg('path_to_app_root') . "/config/.local/$filename.yml";
	return 0 unless (-e $src);  # eg function not configured
	
=begin # could use 'eval', but probably want to preserve & output any error:
	my $yaml;
	eval {
		$yaml = YAML::Tiny->read($src);
	}; die @$ if @$;
	
	return $yaml->[0];
=cut
	my $yaml = YAML::Tiny->read($src)->[0]; # $self->debug($yaml);
	
	# stash in case we're called in loop (eg print_run, get_blood_tube_type):
	$self->stash->{__yaml_file}->{$filename} = $yaml;
	return $yaml;
}

#-------------------------------------------------------------------------------
# uses firstname_format.yml to apply special formatting to first_name:
sub _format_first_name {
    my ($self, $patient) = @_;
    
    my $rules = $self->get_yaml_file('firstname_format') || return 0;

    my $first_name = $patient->first_name; # warn $first_name;
    my $last_name  = $patient->last_name;  # warn $last_name;

    for (@$rules) {
        # regex, which attr (lname or fname) to apply regex to, format to apply:
        my ($regex, $apply_to, $format) = @$_;
            # warn Dumper [$regex, $apply_to, $format];
        if (
            ( $apply_to eq 'first_name' && $first_name =~ qr/\A($regex)\Z/ ) ||
            ( $apply_to eq 'last_name'  && $last_name  =~ qr/\A($regex)\Z/ )
        ) { # warn 'here';
            if ($format eq 'upper') { # warn 'here';
                return uc $first_name; # can't do: $format($first_name) - error
            }
        }
    }
    # no rule so return empty: 
    return 0;
}

1;