#!/usr/local/bin/perl

# $Id: diversity_view,v 1.13.2.1 2007/06/14 19:04:09 kclark Exp $

use strict;
use CGI;
use Data::Dumper;
use Fcntl;
use File::Spec::Functions;
use Geo::Coordinates::DecimalDegrees;
use Gramene::Config;
use Gramene::QTL::DB;
use Gramene::Page;
use Gramene::Utils qw( get_logger pager commify similarity_search );
use Lingua::EN::Inflect qw( PL_N );
use List::Util qw( max );
use List::MoreUtils qw( any );
use Readonly;
use Template;

use lib '/opt/GDPDM/lib';
use GDPDM::Config qw( get_config );
use GDPDM::CDBI;
use GDPDM::Utils qw( table_name_to_class );

use vars qw( $TABLE_DISPLAY_NAME );

Readonly my $COMMA           => q{,};
Readonly my $COMMA_SPACE     => q{, };
Readonly my $ITEMS_PER_PAGE  => 25;
Readonly my $MIN_WORD_LENGTH => 3;
Readonly my $NL              => qq{\n};
Readonly my $TAB             => qq{\t};
Readonly my $VERSION         => sprintf "%d.%02d", 
                                q$Revision: 1.13.2.1 $ =~ /(\d+)\.(\d+)/;

delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin';

use vars qw( @All_Objects @Objects @DBs );

@All_Objects     = GDPDM::CDBI->represented_tables;
@Objects         = qw[ div_passport div_synonym div_stock cdv_marker ];
my $q            = CGI->new;
my $output_type  = 'text/html';

my ( $t, $Page, $html );
eval { 
    $Page            ||= Gramene::Page->new( Apache->request );
    my $cfile        = Gramene::Config->new;
    my $config       = $cfile->get('diversity');
    my $gr_config    = $cfile->get('gramene');
    my $config_dir   = catdir( $gr_config->{'base_dir'}, 'conf' );
    my $gdpdm_config = get_config( catfile( $config_dir, 'gdpdm.conf' ) );
    @DBs             = GDPDM::Config->available_databases;
    my $template_dir = $config->{'template_dir'};
    $t               = Template->new( 
        INCLUDE_PATH => $template_dir,
        WRAPPER      => 'wrapper.tmpl',
        VARIABLES    => {
            cgi          => $q,
            gramene_page => $Page,
            objects      => \@Objects,
            dbs          => \@DBs,
        },
        FILTERS      => { 
            'decimal2dm' => [ \&decimal_to_dm, 1 ] # dynamic filter
        }
    );

    my $action              = $q->param('action')  || 'home';
    my %valid_db            = map { $_->{'key'}, 1 } @DBs;
    my $db_name             = $q->param('db_name') 
                           || $q->cookie('db_name') || '';
    $db_name                = '' if !$valid_db{ $db_name };
    my $db                  = GDPDM::CDBI->db_Main( $db_name );
    $db_name                = GDPDM::CDBI->current_db_name;
    my $db_config           = $gdpdm_config->{ $db_name };
    my $column_display_name = $gdpdm_config->{'column_display_name'} || {};
    $TABLE_DISPLAY_NAME   ||= $gdpdm_config->{'table_display_name'}  || {};

    $q->param( 'db_name', $db_name );

    if ( $action eq 'show_allele_data' ) {
        my $experiment_id = $q->param('div_experiment_id') 
                            or die 'No experiment id';
        my $marker_id     = $q->param('cdv_marker_id')   || 0;
        my $passport_id   = $q->param('div_passport_id') || 0;
        my $page_num      = $q->param('page')            || 1;
        my $order_by      = $q->param('order_by')        || 'marker_name';

        unless ( $marker_id || $passport_id ) {
            die 'Missing germplasm or marker id';
        }

        my $sql = q[
            select    mk.cdv_marker_id,
                      mk.name as marker_name, 
                      pa.div_passport_id,
                      pa.accename as passport_accename,
                      pa.accenumb as passport_accenumb,
                      tax.genus,
                      tax.species,
                      tax.subspecies,
                      tax.subtaxa,
                      stk.seed_lot,
                      l.country,
                      ou.div_obs_unit_id,
                      al.accession, 
                      al.allele_num,
                      al.value as allele_value,
                      aa.div_allele_assay_id
            from      div_obs_unit ou
            left join div_obs_unit_sample ous
            on        ou.div_obs_unit_id=ous.div_obs_unit_id
            left join div_allele al
            on        ous.div_obs_unit_sample_id=al.div_obs_unit_sample_id
            left join div_allele_assay aa
            on        al.div_allele_assay_id=aa.div_allele_assay_id
            left join div_poly_type pt
            on        aa.div_poly_type_id=pt.div_poly_type_id
            left join cdv_marker mk   
            on        aa.cdv_marker_id=mk.cdv_marker_id
            left join div_stock stk
            on        ou.div_stock_id=stk.div_stock_id
            left join div_passport pa
            on        stk.div_passport_id=pa.div_passport_id
            left join div_taxonomy tax
            on        pa.div_taxonomy_id=tax.div_taxonomy_id
            left join div_accession_collecting ac
            on        pa.div_accession_collecting_id=
                      ac.div_accession_collecting_id
            left join div_locality l
            on        ac.div_locality_id=l.div_locality_id
            where     ou.div_experiment_id=?
        ];

        if ( my $allele_poly_type = $db_config->{'allele_poly_type'} ) {
            my $types = join( $COMMA,
                map { s/^\s+|\s+$//; qq['$_'] } 
                split /$COMMA/, $allele_poly_type
            );

            $sql .= " and pt.poly_type in ($types) ";
        }

        my $experiment = GDPDM::CDBI::DivExperiment->retrieve($experiment_id)
                         or die "Bad experiment id ($experiment_id)\n";;

        my $passport;
        if ( $passport_id ) {
            $passport = GDPDM::CDBI::DivPassport->retrieve($passport_id)
                        or die "Bad germplasm id ($passport_id)\n";
            $sql .= " and stk.div_passport_id=$passport_id ";
        }

        my $marker;
        if ( $marker_id ) {
            $marker = GDPDM::CDBI::CdvMarker->retrieve($marker_id)
                      or die "Bad marker id ($marker_id)\n";
            $sql .= " and mk.cdv_marker_id=$marker_id ";
        }

        my $alleles = $db->selectall_arrayref(
            $sql, { Columns => {} }, ( $experiment_id )
        );

        my %genotypes;
        my $marker_names_all_have_numbers = 1;
        for my $al ( @$alleles ) {
            $al->{'key'} = join(':', 
                $al->{'div_obs_unit_id'}, 
                $al->{'div_allele_assay_id'}, 
                $al->{'accession'}, 
                $al->{'marker_name'}
            );

            if ( $al->{'marker_name'} =~ /(\d+)/ ) {
                $al->{'marker_name_number'} = $1;
            }
            else {
                $marker_names_all_have_numbers = 0;
            }

            push @{ $genotypes{ $al->{'key'} } }, $al->{'allele_value'};
        }

        my %distinct_alleles = map { $_->{'key'}, $_ } @$alleles;

        my @allele_data;
        for my $al ( values %distinct_alleles ) {
            $al->{'genotype'} = join( $COMMA_SPACE, 
                sort { $a <=> $b } @{ $genotypes{ $al->{'key'} } }
            );

            push @allele_data, $al;
        }

        if ( $order_by eq 'genotype' ) {
            if ( any { $_ =~ /[a-zA-Z]/ } @allele_data ) {
                @allele_data = sort { 
                    $a->{ $order_by } cmp $b->{ $order_by } 
                } @allele_data;
            }
            else {
                @allele_data = sort { 
                    $a->{ $order_by } <=> $b->{ $order_by } 
                } @allele_data;
            }
        }
        elsif ( $order_by eq 'marker_name' ) {
            if ( $marker_names_all_have_numbers ) {
                @allele_data = sort { 
                    $a->{'marker_name_number'} <=> $b->{'marker_name_number'} 
                    ||
                    $a->{'marker_name'} <=> $b->{'marker_name'} 
                } @allele_data;
            }
            else {
                @allele_data = sort { 
                    $a->{'marker_name'} cmp $b->{'marker_name'} 
                    ||
                    $a->{'accession'} cmp $b->{'accession'} 
                } @allele_data;
            }
        }
        elsif ( $order_by ) {
            @allele_data = sort { 
                $a->{ $order_by } cmp $b->{ $order_by } 
            } @allele_data;
        }

        if ( $q->param('download') ) {
            my @headers = (
                [ passport_accename => 'germplasm_accession_name' ],
                [ country           => 'country_of_origin' ],
                [ passport_accenumb => 'accession_number' ],
                [ seed_lot          => 'stock_number' ],
                [ marker_name       => 'locus_name' ],
                [ genotype          => 'genotype' ],
            );

            $html .= join $TAB, ( map { $_->[1] } @headers ), $NL;
            for my $a ( @allele_data ) {
                $html .= join $TAB, ( map { $a->{ $_->[0] } } @headers ), $NL;
            } 

            $output_type = 'text/plain';
        }
        else {
            my $pager    = Data::Page->new(
                scalar @allele_data, $ITEMS_PER_PAGE, $page_num
            );
            @allele_data = $pager->splice( \@allele_data );

            $t->process(
                'show-allele-data.tmpl',
                {
                    experiment => $experiment,
                    passport   => $passport,
                    marker     => $marker,
                    pager      => $pager,
                    alleles    => \@allele_data,
                },
                \$html
            ) or $html = $t->error;
        }
    }
    elsif ( $action eq 'download_phenotypes' ) {
        my $div_experiment_id = $q->param('div_experiment_id') 
                                or die 'No div_experiment_id';
        my $exp = GDPDM::CDBI::DivExperiment->retrieve($div_experiment_id)
                  or die "Bad experiment id ($div_experiment_id)\n";;

        my @phenotypes;
        for my $phen ( $exp->div_obs_unit ) {
            my $locality = join(', ', map { $_ || () } 
                $phen->div_locality->locality_name,
                $phen->div_locality->state_province,
            );

            push @phenotypes, {
                locality         => $locality,
                block            => $phen->block,
                rep              => $phen->rep,
                name             => $phen->name,
                trait_value      => { map { 
                    $_->div_trait_uom->id => $_->value
                } $phen->div_trait }
            };
        }

        if ( @phenotypes ) {
            @phenotypes = sort {
                   $a->{'locality'} cmp $b->{'locality'}
                || $a->{'block'}    cmp $b->{'block'}
                || $a->{'rep'}      cmp $b->{'rep'}
                || $a->{'name'}     cmp $b->{'name'}
            } @phenotypes;

            my @traits = $exp->get_related( 
                'div_trait_uom', { order_by => 'local_trait_name' }
            );

            $html = join($TAB, 
                qw[ locality block rep name ], 
                map { $_->local_trait_name } @traits
            ) . $NL;

            for my $p ( @phenotypes ) {
                $html .= join($TAB,
                    ( map { $p->{ $_ } } qw[ locality block rep name ] ),
                    ( map { $p->{'trait_value'}{ $_->id } } @traits ),
                ) . $NL;
            }

            $output_type = 'text/plain';
        }
        else {
            die 'No phenotype data available';
        }
    }
    elsif ( 
        $action eq 'list' 
        && 
        ( $q->param('search_for') || $q->param('object') ) 
    ) {
        my @search_objects = split /,/, $q->param('object');
        my $search_value   = $q->param('search_for')   || '';
        my $related_to     = $q->param('related_to')   || '';
        my $order_by       = $q->param('order_by')     || '';
        my $where          = $q->param('where')        || '';
        my $template       = $q->param('template')     || 'list.tmpl';

        if ( $template !~ / \.tmpl \z/xms ) {
            $template .= '.tmpl';
        }

        my $search_results = [];
        for my $i ( 1..2 ) {
            if ( !@$search_results && $i == 2 && $search_value !~ /\*$/ ) {
                $search_value .= '*';
            }

            $search_results = search( 
                db                 => $db,
                db_name            => $db_name,
                search_objects     => \@search_objects, 
                search_value       => $search_value,
                related_to         => $related_to,
                where              => $where,
                order_by           => $order_by,
                search_type        => $q->param('search_type') || '',
                table_display_name => $TABLE_DISPLAY_NAME,
                download           => $q->param('download') || 0,
                page_num           => $q->param('page') || $q->param('page_no'),
            );
        }

        if ( @$search_results == 1 && $q->param('download') ) {
            $output_type = 'text/plain';
            my $basket   = $search_results->[0];
            my @headers  = @{ $basket->{'columns'} };
            
            $html = join($TAB, @headers) . $NL;
            for my $r ( @{ $basket->{'items'} } ) {
                $html .= join($TAB, map { $r->$_() } @headers ) . $NL;
            }
        }
        elsif ( 
            scalar @$search_results == 1 
            && 
            scalar @{ $search_results->[0]{'items'} } == 1
        ) {
            my $basket = shift @$search_results;
            my $item   = shift @{ $basket->{'items'} };
            my $object = $basket->{'object'};

            if ( $object eq 'div_synonym' || $object eq 'div_stock' ) {
                $object = 'div_passport';
                $item   = $item->div_passport;
            }

            return $q->redirect( 
                $q->url . 
                "?action=view&object=$object&id=" . $item->id .
                "&db_name=$db_name"
            );
        }
        else {
            $t->process(
                $template,
                {
                    search_results      => $search_results,
                    column_display_name => $column_display_name,
                    table_display_name  => $TABLE_DISPLAY_NAME,
                },
                \$html
            ) or $html = $t->error;
        }
    }
    elsif ( $action eq 'view' ) {
        my $object    = $q->param('object') or die 'No object name';
        my $id        = $q->param('id')     or die 'No id';
        my $class     = table_name_to_class( $object )     
                        or die "Invalid object ($object)";
        my $pk_col    = $class->columns('Primary');
        my @columns   = grep { $_ ne $pk_col } $class->columns('Ordered');
        my $item      = $class->retrieve( $id ) or die "Bad id '$id'"; 
        my %has_a     = meta_parse( $class->meta_info('has_a') );
        my $has_many  = $class->meta_info('has_many');

        my @link_baskets;
        LINK_TABLE:
        for my $link_table ( keys %$has_many ) {
            my $link_class   = table_name_to_class( $link_table );
            my $fk_field     = $has_many->{$link_table}{'args'}{'foreign_key'};
            my $pk_col       = $link_class->columns('Primary');
            my @link_columns = grep { $_ ne $pk_col } 
                               $link_class->columns('Essential');
            my %link_has_a   = meta_parse( $link_class->meta_info('has_a') );
            my $pager        = $link_class->pager( $ITEMS_PER_PAGE, 1 );
            my @items        = $pager->search( $fk_field => $id );

            next LINK_TABLE if scalar @items == 0;

            my $url = $q->param('url') . "?action=list&object=$link_table"
                    . "&where=$fk_field:" . $item->id . "&db_name=$db_name";

            push @link_baskets, {
                object          => $link_table,
                items           => \@items,
                pager           => $pager,
                pager_url       => $url,
                pager_item_name => class_name_to_display_name( $link_table ),
                columns         => \@link_columns,
                has_a           => \%link_has_a,
                url             => $url,
            };
        }

        my $view_template =  "view-${object}.tmpl";
        my $template      = -e catfile( $template_dir, $view_template )
                             ? $view_template : 'view.tmpl';

        my %extra_data;
        if ( $object eq 'div_experiment' ) {
            %extra_data = get_div_experiment_extra_data( 
                db             => $db,
                cgi            => $q,
                div_experiment => $item 
            );
        }

        $t->process(
            $template,
            {
                item         => $item,
                columns      => \@columns,
                has_a        => \%has_a,
                link_baskets => \@link_baskets,
                extra_data   => \%extra_data,
            },
            \$html
        ) or $html = $t->error;
    }
    else {
        $t->process( 'home.tmpl', {}, \$html ) or $html = $t->error;
    }
};

#
# Error handler
#
if ( $@ ) {
    if ( $t ) {
        $t->process(
            'error.tmpl',
            {
                title   => 'Error',
                err_msg => $@,
            },
            \$html
        ) or $html = $t->error;
    }
    else {
        $html = $@;
    }
}

my %headers = ( -content_type => $output_type );

if ( $q->param('db_name') ) {
    $headers{'-cookie'} = $q->cookie( 
        -name  => 'db_name',
        -value => $q->param('db_name'),
    );
}

print $q->header( %headers ), $html;
exit 0;

# ----------------------------------------------------
sub search {
    my %args           = @_;
    my $db             = $args{'db'};
    my $gdpdm_config   = $args{'gdpdm_config'};
    my $search_objects = $args{'search_objects'} || [];
    my $search_value   = $args{'search_value'};
    my $related_to     = $args{'related_to'};
    my $where          = $args{'where'};
    my $page_num       = $args{'page_num'} 
                      || $args{'page'} 
                      || $args{'page_no'} 
                      || 1;
    my $order_by       = $args{'order_by'};
    my $download       = $args{'download'}    || 0;
    my $search_type    = $args{'search_type'} || 'regular';
    my $db_name        = $args{'db_name'}     || '';

    $search_value =~ s/%/*/g; # change SQL wildcard to asterisk for FULLTEXT

    if ( !@$search_objects ) {
        if ( $search_value =~ /\A [\s*]* \z /xms ) {
            die "Please provide a search value or domain\n";
        }
        else {
            $search_objects = \@Objects;
        }
    }

    if ( $search_value ) {
        my $max = max(
            map { s/[^[:alnum:]]//; length $_ } split /\s+/, $search_value
        );

        if ( $max < $MIN_WORD_LENGTH ) {
            die "No search term long enough ($MIN_WORD_LENGTH) to be indexed\n";
        }
    }

    my $sql = sprintf(
        qq[
            select record_id 
            from   gdpdm_search
            where  table_name=?
            and    match(record_text) against ('%s'%s)
        ],
        $search_value,
        $search_value =~ /[*+.><()~"'-]/ ? ' in boolean mode' : ''
    );

    my $entries_per_page = @$search_objects > 1 ? 10 : $ITEMS_PER_PAGE;
    my @baskets;

    my %list_columns;
    while ( my ( $k, $v ) = each %{ $gdpdm_config->{'list_columns'} || {} } ) {
        $list_columns{ $k } = [ split /,/, $v ];
    }

    OBJECT:
    for my $object ( @$search_objects ) {
        my @items;
        my $class    = table_name_to_class( $object );
        my $pk_col   = $class->columns('Primary');
        my @columns  = grep { $_ ne $pk_col }
                       $class->columns('Essential');
        my %has_a    = meta_parse( $class->meta_info('has_a') );
        my %has_many = map { $_, 1 } 
                       keys %{ $class->meta_info('has_many') || {} };

        my $url 
            = $q->url . "?action=list&object=$object"
            . "&where=$where"
            . "&related_to=$related_to"
            . "&search_for=$search_value"
            . "&db_name=$db_name";

        my $item_name = class_name_to_display_name( $object );
        my $num_found;

        my $pager;
        if ( $search_value ) {
            my $matches = [];
            if ( $search_type eq 'similarity' ) {
                my $data = $db->selectall_arrayref(
                    'select * from gdpdm_search where table_name=?',
                    { Columns => {} },
                    ( $object )
                );

                if ( @$data ) {
                    $matches = [ map { $_->{'record_id'} } @{
                        similarity_search(
                            config        => $gdpdm_config,
                            data          => $data,
                            search_fields => [ 'record_text' ],
                            search_values => [ $search_value ],
                            threshold     => 0.3,
                        )
                    } ];
                }
            }
            else {
                $matches = $db->selectcol_arrayref( $sql, {}, $object );
            }

            next OBJECT if !@$matches;
        
            for my $id ( @$matches ) {
                my $item = $class->retrieve( $id );
                push @items, $item;
            }

            if ( $order_by ) {
                @items = sort { 
                    $a->{ $order_by } cmp $b->{ $order_by } 
                } @items;
            }

            if ( !$download ) {
                $pager = Data::Page->new(
                    scalar @items, $ITEMS_PER_PAGE, $page_num
                );
                @items = $pager->splice( \@items );
            }
        }
        elsif ( $related_to =~ / \A (\w+) [:] (\d+) \Z /xms ) {
            my ( $table, $id ) = ( $1, $2 );
            my $class          = table_name_to_class( $table );
            my $related_object = $class->retrieve( $id );
            @items             = $related_object->get_related( $object );

            if ( $order_by ) {
                @items = sort { 
                    $a->{ $order_by } cmp $b->{ $order_by } 
                } @items;
            }
            
            if ( !$download ) {
                $pager = Data::Page->new(
                    scalar @items, $ITEMS_PER_PAGE, $page_num
                );
                @items = $pager->splice( \@items );
            }
        }
        else {
            $pager = $class->pager( $ITEMS_PER_PAGE, $page_num );

            my %params;

            if ( $where ) {
                my ( $where_field, $where_value ) = split /:/, $where;
                $params{ $where_field } = $where_value;
            }

            if ( %params ) {
                @items = $pager->search( %params, { order_by => $order_by });
            }
            else {
                if ( $order_by ) {
                    @items = $pager->retrieve_all_sorted_by( $order_by );
                }
                else {
                    @items = $pager->retrieve_all;
                }
            }
        }

        push @baskets, {
            object          => $object,
            items           => \@items,
            pager           => $pager,
            pager_url       => $url,
            pager_item_name => class_name_to_display_name( $item_name ),
            columns         => $list_columns{ $object } || \@columns,
            has_a           => \%has_a,
            has_many        => \%has_many,
        };
    }

    return \@baskets;
}

# ----------------------------------------------------
sub class_name_to_display_name {
    my $item_name = shift;
    if ( my $alt_name = $TABLE_DISPLAY_NAME->{ $item_name } ) {
        $item_name = $alt_name;
    }
    else {
        $item_name =~ s/^[a-z]{3}_//;
        $item_name =~ s/_/ /g;
        $item_name = ucfirst $item_name;
    }

    return $item_name;
#    return 
#          $item_name =~ /[yns]ms$/ ? $item_name
#        : $item_name =~ /[yns]m$/  ? "${item_name}s" 
#        : PL_N( $item_name )
#    ;
}

# ----------------------------------------------------
sub meta_parse {
    my $meta = shift;
    my %return;
    while ( my ( $fk_field, $meta ) = each %$meta ) {
        my $fk_class = $meta->{'foreign_class'};
        $return{ $fk_field } = $fk_class->table;
    }

    return %return;
}

# ----------------------------------------------------
sub decimal_to_dm {
    my $context     = shift;
    my $lat_or_long = shift || 'latitude';

    return sub {
        my $decimal = shift;
        if ( defined $decimal && $decimal ne '' ) {
            my $direction = 
                $lat_or_long eq 'latitude' 
                ? $decimal >= 0 ? 'N' : 'S'
                : $decimal >= 0 ? 'E' : 'W'
            ;
            my ( $d, $m )   = decimal2dm( abs($decimal) );
            $m = sprintf '%d', $m;
            return "$d&deg; $m' $direction";
        }
        else {
            return 'N/A';
        }
    }
}

# ----------------------------------------------------
sub get_div_experiment_extra_data {
    my %arg = @_;
    my $exp = $arg{'div_experiment'};
    my $q   = $arg{'cgi'};
    my $db  = $arg{'db'};

    my %extra_data;
    $extra_data{'xrefs'} = [
        map { 
            $_->{'url'} 
                = $_->{'url_template'}
                ? sprintf( $_->{'url_template'}, $_->{'xref_value'} )
                : ''
            ;
            $_
        }
        @{ $db->selectall_arrayref(
            q[
                select x.xref_value, x.comments, 
                       xt.xref_type, xt.url_template
                from   xref x, xref_type xt
                where  x.table_name=?
                and    x.record_id=?
                and    x.xref_type_id=xt.xref_type_id
            ],
            { Columns => {} },
            ( 'div_experiment', $exp->id )
        ) }
    ];

    $extra_data{'lit_ids'} = [
        map  { $_->{'xref_value'} }
        grep { $_->{'xref_type'} =~ /^Gramene Literature/ }
        @{ $extra_data{'xrefs'} || [] }
    ];

    if ( @{ $extra_data{'lit_ids'} } ) {
        my $qdb  = Gramene::QTL::DB->new;
        $extra_data{'qtls'} = $qdb->search( lit_id => $extra_data{'lit_ids'} );
    }

    return %extra_data;
}

# ----------------------------------------------------

=pod

=head1 NAME

diversity_view - CGI search interface for diversity/GDPDM

=head1 DESCRIPTION

A basic CGI search interface for diversity data stored in the GDPDM schema.

=head1 SEE ALSO

GDPDM.

=head1 AUTHOR

Ken Youens-Clark E<lt>kclark@cshl.eduE<gt>.

=head1 COPYRIGHT

Copyright (c) 2006 Cold Spring Harbor Laboratory

This library is free software;  you can redistribute it and/or modify 
it under the same terms as Perl itself.

=cut
