#!/usr/bin/perl -w

###################################################################
# Non-modperl users should change this variable if needed to point
# to the directory in which the configuration files are stored.
#
$CONF_DIR  = '/bio/argos/gmod/in01/conf/gbrowse.conf';
#
###################################################################
$VERSION   = 1.67;

use lib '/bio/argos/gmod/in01/lib';
# $Id: gbrowse_details.PLS,v 1.28.4.2.2.12.2.1 2007/03/22 02:24:24 scottcain Exp $

use strict;
use CGI qw(:standard *table *TR escape);
use Bio::DB::GFF;
use Bio::Graphics::Browser;
use Bio::Graphics::Browser::Markup;
use Bio::Graphics::Browser::Util;
use Bio::Graphics::Browser::Realign 'align';
use vars qw($CONFIG $VERSION $CONF_DIR $LANG @COLORS $INDEX %strands %COLORS %URLS %formatterCache);

use constant DEBUG=>0;

@COLORS = qw(none lightgrey yellow pink orange brown
	     tan teal cyan lime green blue gray);

$CONF_DIR  = conf_dir($CONF_DIR);  # conf_dir() is exported from Util.pm
$CONFIG = open_config($CONF_DIR);  # open_config() is exported from Util.pm

$INDEX  = 0;
%COLORS = ();
%URLS   = ();
%formatterCache = ();

my $src   = param('src') || param('source');
my $name  = param('name');
my $class = param('class');
my $ref   = param('ref');
my $start = param('start');
my $end   = param('end');
my $f_id  = param('feature_id');

# Migrate from 1.56 way of specifying source to 1.57 way
# This may cause a redirect and exit 0 at this point!
redirect_legacy_url($src);
$CONFIG->source(get_source());

# This populates the %URLS global with link rules from the config file.
getLinkURLs(\%URLS);

my $head_name = $class eq 'Sequence' ? $name : "$class:$name";  # gff3 compatibility

print_top("GBrowse Details: $head_name");
print $CONFIG->header || h1("$head_name Details");

my $db = open_database();

my @features;
if ($f_id) {
  @features = $CONFIG->_feature_get($db,$name,$class,$start,$end,1,0,$f_id);
}
else {
  @features = sort {$b->length<=>$a->length} $CONFIG->_feature_get($db,$name,$class);
  @features    = sort {$b->length<=>$a->length} $CONFIG->_feature_get($db,$ref,$class,$start,$end,1)
    unless @features;
}

warn "features = @features" if DEBUG;

warn "segments = ",join ' ',$features[0]->segments if (DEBUG && @features);

if (@features) {
  # dgg: test gbrowse_edit
  # print h4("Test <a href='../gbrowse_edit/$src?name=$name'>Gbrowse_Chado_Editor</a>");
  print print_features(\@features);
} else {
  print p({-class=>'error'},'Requested feature not found in database.');
}

# footer
print_bottom($VERSION);
exit 0;

######################

sub print_features {
  my $features   = shift;
  my $subf       = shift || 0;
  my $string;
  for my $f (@$features) {
    my $method = $f->primary_tag . $subf;
    warn "index = $INDEX, method = $method" if DEBUG;
    $COLORS{$method} ||= $COLORS[$INDEX++ % @COLORS];
    my $options = {-bgcolor => $COLORS{$method}} unless $COLORS{$method} eq 'none';

    $string .= start_table({-cellspacing=>0});
    unless ($subf) {
      $string .= PrintMultiple($f,$options,'Name',$f->name);
      $string .= PrintMultiple($f,$options,'Class',$f->class) unless $f->class eq 'Sequence';
    }
    $string .= PrintMultiple($f,$options,'Type',$f->primary_tag);
    $string .= PrintMultiple($f,$options,'Source',$f->source_tag) if $f->source_tag;
    $string .= PrintMultiple($f,$options,"Position",$f);
    $string .= PrintMultiple($f,$options,"Length",$f->length);
    if ($f->can('target') && $f->target) {
      # try to correct for common GFF2 error of indicating a -/- alignment
      # using a (-) src strand and a target_start > target_end
      my $bug = $f->abs_strand < 0 && $f->target->abs_strand < 0;
      $string .= PrintMultiple($f,$options,'Target',$f->target->seq_id);
      $string .= PrintMultiple($f,$options,"Matches",$f);
      $string .= PrintMultiple($f,$options,'',print_matches($f,$f->target,$bug)) if $subf;

    }
    $string .= PrintMultiple($f,$options,"Score",$f->score) if $f->can('score') && defined $f->score;
    my %attributes = $f->attributes if $f->can('attributes');
    for my $a (sort grep {!/Target/} keys %attributes) {
      $string .= PrintMultiple($f,$options,$a,$f->attributes($a));
    }
    $string   .= TR({-valign=>'top',-class=>'databody'},th({-height=>3},''),td({-height=>3},''));

    my @subfeatures;
    # sort features with targets so that target is in order
    if ($f->can('target') && $f->target) {
      @subfeatures  = sort {$a->target->start <=> $b->target->start} $f->get_SeqFeatures;
    } else {
      @subfeatures = sort {$a->start <=> $b->start} $f->get_SeqFeatures;
    }

    my $subtable = PrintMultiple($f,$options,'Parts',print_features(\@subfeatures,$subf+1)) if @subfeatures;
    $string .= $subtable || '';  # prevent uninit variable warning
    $string .= end_table();

    if ($subtable or $subf==0) {
      my $dna = $f->seq;
      $dna    = $dna->seq if ref $dna;  # compensate for API changes
      $string .= print_dna($f,$dna,$f->abs_start,$f->strand,\@subfeatures,$subf+1) if $dna;
   }

  }
  $string;
}

sub print_dna {
  my ($feature,$dna,$start,$strand,$features,$subf) = @_;
  my %seenit;
  warn "dna=$dna" if DEBUG;

  my $markup = Bio::Graphics::Browser::Markup->new;
  for my $f (@$features) {
    warn "f = $f" if DEBUG;
    my $method = $f->primary_tag . $subf;
    warn "$method => $COLORS{$method}" if DEBUG;
    next if $COLORS{$method} eq 'none';
    $markup->add_style($method => "BGCOLOR $COLORS{$method}");
  }
  # add a newline every 80 positions
  $markup->add_style('newline',"\n");
  # add a space every 10 positions
  $markup->add_style('space'," ");

  my @markup;
  for my $f (@$features) {
    my ($s,$e);
    if ($strand >=0) {
      $s   = $f->low  - $start;
      $e   = $f->high - $start;
    } else {
      if ($start - $f->high < 0) { #how much of a hack is this!
                                   #it fixes chado feature differences
        $s   = $start + length($dna) - $f->low  -1;
        $e   = $start + length($dna) - $f->high -1;
      } else {
        $s   = $start - $f->low;
        $e   = $start - $f->high;
      }
    }

    ($s,$e) = ($e,$s) if $s > $e;
    my $method = $f->primary_tag . $subf;
    next if $COLORS{$method} eq 'none';
    push @markup,[$method,$s,$e+1];  # Duelling off-by-one errors....
  }
  push @markup,map {['newline',80*$_]} (1..length($dna)/80);
  push @markup,map {['space',10*$_]}   grep {$_ % 8} (1..length($dna)/10);

  $markup->markup(\$dna,\@markup);
  my $position = position($feature);
  my $name     = $feature->name;
  my $class    = $feature->class;
  return pre(">$name class=$class position=$position\n".$dna);
}

sub print_matches {
  my ($src,$tgt,$bug) = @_;

  my $sdna = $src->dna or return '';
  my $tdna = $tgt->dna or return '';

  my $top_label = $src->abs_ref;
  my $bot_label = $tgt->abs_ref;

  my $src_x = $src->abs_start;
  my $src_y = $src->abs_end;
  my $tgt_x = $tgt->abs_start;
  my $tgt_y = $tgt->abs_end;
#  my $tdir  = $tgt->abs_strand || +1;
#  my $sdir  = $src->abs_strand || +1;
  my $tdir  = $tgt->strand || +1;
  my $sdir  = $src->strand || +1;

  if ($bug) { # correct for buggy data files that show -/- alignments; really -/+
    $tdir = +1;
    ($tgt_x,$tgt_y) = ($tgt_y,$tgt_x);
    $tdna =~ tr/gatcGATC/ctagCTAG/;
    $tdna = reverse $tdna;
  }
  warn ("sdir = $sdir, $src_x -> $src_y / $tgt_x -> $tgt_y") if DEBUG;
  my ($top,$middle,$bottom) = align($sdna,$tdna);

  my $m = max(length($top_label),length($bot_label));
  my $p = max(length($src_x),length($src_y),length($tgt_x),length($tgt_y));
  my $l  = ' ' x ($m+$p+2);  # adjusting for HTML

  my $string;
  my @top    = $top    =~ /(.{1,60})/g;
  my @middle = $middle =~ /(.{1,60})/g;
  my @bottom = $bottom =~ /(.{1,60})/g;

  $src_x = $src_y if $sdir < 0;

  for (my $i=0; $i<@top; $i++) {
    my $src_delta = $sdir * (length($top[$i]) - $top[$i]=~tr/-/-/);
    my $tgt_delta = $tdir * (length($bottom[$i]) - $bottom[$i]=~tr/-/-/);

    $string .= sprintf("%${m}s %${p}d %s %d\n$l%s\n%${m}s %${p}d %s %d\n\n",
		       $top_label,$src_x,$top[$i],$src_x + $src_delta - $sdir,
		       $middle[$i],
		       $bot_label,$tgt_x,$bottom[$i],$tgt_x + $tgt_delta - $tdir);

    $src_x  += $src_delta;
    $tgt_x  += $tgt_delta;

  }
  return pre($string);
}

sub max {
  if (@_ == 2) {
    return $_[0] > $_[1] ? $_[0] : $_[1];
  } else {
    return (sort {$b<=>$a} @_)[0];
  }
}

sub PrintMultiple {
  local $^W = 0;  # get rid of uninit variable warnings

  my $feature = shift;
  my $options = shift;
  my $label   = shift;

  $options ||= {};

  my @a = formatValues($feature,$label,@_);
  return '' unless @a;

  my $LINK = "";
  my $isFirst=1;
  my $string = ' ' ;

  for my $obj (@a) {
    if ($URLS{$label}){
      $LINK = $URLS{$label};
      if ( ref ($LINK)   eq 'CODE' ){ #Testing subs
	$LINK= eval { $LINK->($label,$obj)};
	$LINK = $LINK ? "<a href='$LINK'>$obj</a>" : $obj;
      }
      else { #end testing subs
	$LINK =~ s/\$tag/$label/;
	$LINK=~ s/\$value/$obj/;
	$LINK = "<a href='$LINK'>$obj</a>";
      } # testing subs
    }

    # for EST alignment features, create a link to get the orignal EST sequence
    if (($label eq 'Target') && ($URLS{'alignment'}) && ($obj =~ /alignment/i)){
      my $name = shift @a;
      $LINK = $URLS{'alignment'};
      $LINK=~ s/\$value/$name/;
      $LINK = "$obj : (<a href='$LINK'>Aligned Sequence</a>)";
    }

    $obj =~ s/([^<>\s'"\/;&]{60})/$1 /g;  # wrap way long lines. Note : ading '" prevent this regexp from wrapping html tags

    if ($isFirst) {
      $isFirst =0 ;
      $string .= join '',TR({-valign=>'top',-class=>'databody'},
			    th({-align=>'LEFT',-valign=>'top',-class=>'datatitle',-width=>100},length $label>0 ? "$label: " : ''),
			    td($options, $LINK ? $LINK : $obj)
			   );
    } else {

      $string .= join '', TR({-class=>'databody'},
			     th({-align=>'RIGHT',-class=>'datatitle',-width=>100},'&nbsp;'),
			     td($options,$LINK?$LINK:$obj)
			    );
    }
    $LINK='';
  }
  $string;
}

sub position {
  my $f      = shift;
  my $simple = shift;
  my $bug    = shift; # for (-) (-) alignments

  my $ref = $f->abs_ref;
  my $start = $f->abs_start;
  my $end   = $f->abs_end;
  if ($simple) {
    ($start,$end) = ($end,$start) if $f->strand < 0;
    return "<b>$ref</b> $start..$end";
  }
  my $s = $f->strand;
  if ($bug) {  # data bug
    ($start,$end) = ($end,$start);
    $s *= -1;
  }
  my $strand = $s > 0 ? '+' : $s < 0 ? '-' : '';

  my $src = escape($CONFIG->source);
  my $url = "../gbrowse/$src?name=$ref:$start..$end";
  return a({-href=>$url},$strand ? "$ref:$start..$end ($strand strand)" : "$ref:$start..$end");
}

sub getLinkURLs {
  my $urls = shift;
  my $THIS_CONFIG = $CONFIG->config;
  $THIS_CONFIG->safe(0);
  my @LINK_CONFIGS = map{$_=~/\:DETAILS$/?$_:undef} $THIS_CONFIG->setting;
  foreach (@LINK_CONFIGS){
    next unless $_;
    next unless $_=~/(.*?)\:DETAILS/;
    next unless $1;
    my $URL = $THIS_CONFIG->setting("$_", 'url');
    next unless $URL;
    $urls->{$1}=$URL;
  }
}

sub formatValues {
  my ($feature,$tag,@values) = @_;
  my $formatter    = getFormatter($feature,$tag);
  return @values unless $formatter;
  if (ref $formatter eq 'CODE') {
    return map {$formatter->($_,$tag,$feature)} @values;
  }
  my $name   = $feature->display_name;
  my $start  = $feature->start || '';
  my $end    = $feature->end   || '';
  my $strand = $feature->strand || '';
  my $method = $feature->primary_tag || '';
  my $source = $feature->source_tag || '';
  my $type   = eval {$feature->type} || $method || '';
  my $class  = eval {$feature->class} || '';
  my $description = eval { join ' ',$feature->notes } || '';
  $formatter =~ s/\$tag/$tag/g;
  $formatter =~ s/\$name/$name/g;
  $formatter =~ s/\$start/$start/g;
  $formatter =~ s/\$end/$end/g;
  $formatter =~ s/\$stop/$end/g;
  $formatter =~ s/\$strand/$strand/g;
  $formatter =~ s/\$method/$method/g;
  $formatter =~ s/\$source/$source/g;
  $formatter =~ s/\$type/$type/g;
  $formatter =~ s/\$class/$class/g;
  $formatter =~ s/\$description/$description/g;
  return map {$formatter =~ s/\$value/$_/g; $formatter} @values;
}

sub getFormatter {
  my ($feature,$tag) = @_;
  my $method  = $feature->primary_tag;
  my $source  = $feature->source_tag;
  my $key     = join ':',$method,$source,$tag;

  return $formatterCache{$key} if exists $formatterCache{$key};

  my $config = $CONFIG->config;
  my $s;

  # implement simple search path for formatters
 SEARCH:
  for my $base ("$method:$source",$method,'default') {
    for my $option ($tag,'default') {
      $s ||= $config->code_setting("$base:details" => lc $option);
      $s ||= $config->code_setting("$base:DETAILS" => lc $option);
      last SEARCH if defined $s;
    }
  }

  unless (defined $s) {
    $s = \&format_position if $tag eq 'Position';
    $s = \&format_matches  if $tag eq 'Matches';
    $s = \&format_name     if $tag eq 'Name';
  }
  return $formatterCache{$key} = $s;
}

sub get_source {
  my $new_source = param('source') || param('src') || path_info();
  $new_source    =~ s!^/!!;  # get rid of leading / from path_info()
  my $old_source = cookie('gbrowse_source') unless $new_source && request_method() eq 'GET';

  my $source   = $new_source || $old_source;
  $source ||= $CONFIG->source;  # the default, whatever it is
  return ($source,$old_source);
}

sub format_position {
  my (undef,undef,$feature) = @_;
  position($feature);
}

sub format_matches {
  my (undef,undef,$feature) = @_;
  # try to correct for common GFF2 error of indicating a -/- alignment
  # using a (-) src strand and a target_start > target_end
  my $bug = $feature->abs_strand < 0 && $feature->target->abs_strand < 0;
  position($feature->target,undef,$bug)
}

sub format_name {
  my $name = shift;
  b($name)
}