lib/Legacy/Graphics/Browser/Util.pm

package Legacy::Graphics::Browser::Util;

# a package of useful internal routines for GBrowse

use strict;
use Legacy::Graphics::Browser;
use Legacy::Graphics::Browser::I18n;
use CGI qw(:standard);
use CGI::Toggle;
use Carp 'carp','cluck';
use Text::ParseWords ();

use vars qw(@ISA @EXPORT $CONFIG $LANG %DB $HEADER $HTML $ADDED_FEATURES);
require Exporter;
@ISA = 'Exporter';
@EXPORT = qw(conf_dir open_config open_database
	     print_header print_top print_bottom html_frag
	     error fatal_error redirect_legacy_url
	     parse_feature_str url2file modperl_request is_safari
             shellwords
	    );

use constant DEBUG => 0;
use constant JS    => '/gbrowse2/js';

sub conf_dir {
  my $default = shift;
  if (my $request = modperl_request()) {
    my $conf  = $request->dir_config('GBrowseConf') or return $default;
    return $conf if $conf =~ m!^/!;                # return absolute
    return (exists $ENV{MOD_PERL_API_VERSION} &&
	    $ENV{MOD_PERL_API_VERSION} >= 2)
      ? Apache2::ServerUtil::server_root() . "/$conf"
      : Apache->server_root_relative($conf);
  }
  return $default;
}

sub url2file {
  my $url = shift;
  my $request = modperl_request();

  for my $l ((map {"$url.$_"} $CONFIG->language->language), $url) {
    my $file = $request ? $request->lookup_uri($l)->filename
                        : "$ENV{DOCUMENT_ROOT}/$l";
    return $file if -e $file;
  }
  return;
}

sub modperl_request {
  return unless $ENV{MOD_PERL};
  (exists $ENV{MOD_PERL_API_VERSION} &&
   $ENV{MOD_PERL_API_VERSION} >= 2 ) ? Apache2::RequestUtil->request
                                     : Apache->request;
}


sub open_config {
  my $dir    = shift;
  my $suffix = shift;
  $CONFIG ||= Legacy::Graphics::Browser->new;
  $CONFIG->read_configuration($dir,$suffix) or die "Can't read configuration files: $!";
  $LANG    ||= Legacy::Graphics::Browser::I18n->new("$dir/languages");
  # $CONFIG->source or early_error($LANG,'NO_SOURCES');

  set_language($CONFIG,$LANG);
  $CONFIG->language($LANG);
  $CONFIG->dir($dir);

  # initialize some variables
  $HEADER=0;
  $HTML=0;
  $ADDED_FEATURES = 0;

  $CONFIG;
}

sub open_database {
  my $config  = shift || $CONFIG;
  my $source  = $config->source;
  return $DB{$source} if $DB{$source};
  my ($adaptor,@argv) = eval{$config->db_settings};
  unless ($adaptor) {
    warn "gbrowse: trying to reload config, cache must be stale";
    my $dir = $config->dir;
    $config = Legacy::Graphics::Browser->new;
    $config->read_configuration($dir) or fatal_error("Can't read configuration files: $!");
    $config->source($source);
    ($adaptor,@argv) = $config->db_settings;
  }

  ################################################
  # HACK ALERT
  patch_old_versions_of_bioperl($adaptor,@argv);
  ################################################

  $DB{$source} = eval {$adaptor->new(@argv)} or warn $@;
  fatal_error('Could not open database.',pre("$@")) unless $DB{$source};

  if (my $refclass = $config->setting('reference class')) {
    eval {$DB{$source}->default_class($refclass)};
  }

  $DB{$source}->strict_bounds_checking(1) if $DB{$source}->can('strict_bounds_checking');
  $DB{$source}->absolute(1)               if $DB{$source}->can('absolute');

  return $DB{$source};
}

sub print_header {
  print header(@_) unless $HEADER++;
}

sub parse_added_feature {
  my $f      = shift;
  my $fcount = shift;
  my $zero   = 0;
  $fcount    ||= \$zero;
  my ($reference,$type,$name,@position);
  my @args = shellwords($f||'');
  if (@args > 3) {
    ($reference,$type,$name,@position) = @args;
  } elsif (@args > 2) {
    ($reference,$name,@position) = @args;
    $type = 'Your Features';
  } elsif (@args > 1) {
    ($reference,@position) = @args;
    ($type,$name) = ('Your Features',"Feature ".++$$fcount);
  }
  my @segments = map { [/(-?\d+)(?:-|\.\.)(-?\d+)/]} map {split ','} @position;
  ($reference,$type,$name,@segments);
}

sub print_top {
  my $title     = shift;
  my $reset_all = shift;
  my $alert     = shift;
  local $^W = 0;  # to avoid a warning from CGI.pm

  my $titlebar    = is_safari() ? 'titlebar-safari.css' : 'titlebar-default.css';

  my @extra_headers;
  my @stylesheets = shellwords($CONFIG->setting('stylesheet') || '/gbrowse2/css/gbrowse.css');
  for my $ss (@stylesheets) {
      my ($url,$media) = $ss =~ /^([^(]+)(?:\((.+)\))?/;
      $media ||= 'all';
      push @extra_headers,CGI::Link({-rel=>'stylesheet',
				     -type=>'text/css',
				     -href=>$CONFIG->relative_path($url),
				     -media=>$media});
  }

  push @extra_headers,$CONFIG->setting('head') if $CONFIG->setting('head');

  print_header(-expires=>'now');
  my @args = (-title => $title,
	      -style  => [{src=>$CONFIG->relative_path('tracks.css')},
			  {src=>$CONFIG->relative_path($titlebar)}],
	      -encoding=>$CONFIG->tr('CHARSET'),
	     );
  push @args,(-lang=>($CONFIG->language_code)[0]) if $CONFIG->language_code;
  push @args,(-gbrowse_images => $CONFIG->globals->button_url  || '/gbrowse2/images/buttons');
  push @args,(-gbrowse_js     => $CONFIG->globals->js_url      || '/gbrowse2/js');
  push @args,(-reset_toggle   => 1)               if $reset_all;

  my @onload;
  push @onload, $CONFIG->setting('onload') if $CONFIG->setting('onload');
  push @onload, "alert('$alert')"          if $alert;

  # push all needed javascript files onto top of page
  my $drag_and_drop = $CONFIG->drag_and_drop;
  my $b_tips        = $CONFIG->setting('balloon tips') || $drag_and_drop;
  my $js            = $CONFIG->relative_path_setting('js')||JS;
  my @js            = ('buttons.js','prototype.js');
  push @js, qw(yahoo-dom-event.js balloon.config.js balloon.js)     if $b_tips;
  push @js, qw(rubber.js overviewSelect.js detailSelect.js);
  #push @js, 'scriptaculous.js' if $drag_and_drop;
  #push @js, 'bookmark.js';
  push @onload, 'Overview.prototype.initialize()';
  push @onload, 'Details.prototype.initialize()';

  if ($CONFIG->setting('region segment')) {
    push @js, 'regionSelect.js';
    push @onload, 'Region.prototype.initialize()';
  }


  my @scripts = map { {src=> "$js/$_" } } @js;
  push @args, (-script => \@scripts);
  push @args, (-onLoad => join('; ',@onload));
  push @args, (-head   => \@extra_headers);

  print start_html(@args) unless $HTML++;
  print_balloon_settings()  if $b_tips;
  print_select_menu($_) for (qw/DETAIL OVERVIEW REGION/);
}

# prepare custom menu(s) for rubber-band selection
sub print_select_menu {
  my $view = shift || 'DETAIL';
  my $config_label = uc($view).' SELECT MENU';

  # HTML for the custom menu is required
  my $menu_html =  $CONFIG->setting($config_label => 'HTML') 
                || $CONFIG->setting($config_label => 'html') 
                || return;

  # should not be visible
  my %style = (display => 'none');
  # optional style attributes
  for my $att (qw/width font background background-color border/) {
    my $val = $CONFIG->setting($config_label => $att) || next;
    $style{$att} = $val;
  } 
  $style{width} .= 'px';
  my $style = join('; ', map {"$_:$style{$_}"} keys %style);

  # clean up the HTML just a bit
  $menu_html =~ s/\</\n\</g;

  print div( { -style => $style, 
	       -id    => lc($view).'SelectMenu' }, 
	     $menu_html );
}

sub print_balloon_settings {
  my $custom_balloons    = $CONFIG->setting('custom balloons');
  my $images             = $CONFIG->relative_path('images');
  my %config_values = $custom_balloons =~ /\[([^]]+)\]([^[]+)/g;
  $config_values{'balloon'} ||= <<END;
images    =  $images/balloons
delayTime =  500
END

  my $balloon_settings;

  for my $balloon (keys %config_values) {
    my %config = $config_values{$balloon} =~ /(\w+)\s*=\s*(\S+)/g;
    my $img    = $config{images} || "$images/balloons";
    $balloon_settings .= <<END;
var $balloon = new Balloon;
BalloonConfig($balloon);
$balloon.images              = '$img';
$balloon.balloonImage        = 'balloon.png';
$balloon.ieImage             = 'balloon_ie.png';
$balloon.upLeftStem          = 'up_left.png';
$balloon.downLeftStem        = 'down_left.png';
$balloon.upRightStem         = 'up_right.png';
$balloon.downRightStem       = 'down_right.png';
$balloon.closeButton         = 'close.png';
END
    for my $option (keys %config) {
      next if $option eq 'images';
      my $value = $config{$option} =~ /^[\d.-]+$/ ? $config{$option} : "'$config{$option}'";
      $balloon_settings .= "$balloon.$option = $value;\n";
    }
  }
  print "<script>\n$balloon_settings\n</script>\n";
}

sub print_bottom {
  my ($version) = @_;
  print
    $CONFIG->footer || '',
      p(i(font({-size=>'small'},
	       $CONFIG->tr('Footer_1'))),br,
	tt(font({-size=>'small'},$CONFIG->tr('Footer_2',$version)))),
	  end_html;
}

sub error {
  my @msg = @_;
  cluck "@_" if DEBUG;
  print_top();
  print h2({-class=>'error'},@msg);
}

sub fatal_error {
  my @msg = @_;
  warn "@_" if DEBUG;
  print_top($CONFIG,'GBrowse Error');
  print h2('An internal error has occurred');
  print p({-class=>'error'},@msg);
  my $webmaster = $ENV{SERVER_ADMIN} ?
   "maintainer (".a({-href=>"mailto:$ENV{SERVER_ADMIN}"},$ENV{SERVER_ADMIN}).')'
     : 'maintainer';
  print p("Please contact this site's $webmaster for assistance.");
  print_bottom($CONFIG);
  exit 0;
}


sub early_error {
  my $lang = shift;
  my $msg  = shift;
  $msg     = $lang->tr($msg);
  warn "@_" if DEBUG;
  local $^W = 0;  # to avoid a warning from CGI.pm
  print_header(-expires=>'+1m');
  my @args = (-title  => 'GBrowse Error');
  push @args,(-lang=>$lang->language);
  print start_html();
  print b($msg);
  print end_html;
  exit 0;
}

sub set_language {
  my ($config,$lang) = @_;
  my $default_language   = $config->setting('language');
  my $accept         = http('Accept-language') || '';
  my @languages    = $accept =~ /([a-z]{2}-?[a-z]*)/ig;
  push @languages,$default_language if $default_language;
  warn "languages = ",join(',',@languages) if DEBUG;
  return unless @languages;
  $lang->language(@languages);
}

sub html_frag {
  my $fragname = shift;
  my $a = $CONFIG->config->setting(general => $fragname);
  return $a->(@_) if ref $a eq 'CODE';
  return $a || '';
}

sub patch_old_versions_of_bioperl {
  my $adaptor = shift;
  my %argv    = @_;
  local $^W = 0;
  require Bio::Perl;
  if ($adaptor eq 'Bio::DB::GFF' && $Bio::Perl::VERSION == 1.5) {
  eval <<'END';
use Bio::DB::GFF;
sub Bio::DB::GFF::load_gff {
  my $self              = shift;
  my $file_or_directory = shift || '.';
  my $verbose           = shift;

  local $self->{__verbose__} = $verbose;
  return $self->do_load_gff($file_or_directory) if ref($file_or_directory) 
                                                   && tied *$file_or_directory;

  my $tied_stdin = tied(*STDIN);
  open SAVEIN,"<&STDIN" unless $tied_stdin;
  local @ARGV = $self->setup_argv($file_or_directory,'gff','gff3') or return;  # to play tricks with reader
  my $result = $self->do_load_gff('ARGV');
  open STDIN,"<&SAVEIN" unless $tied_stdin;  # restore STDIN
  return $result;
}
sub Bio::DB::GFF::_load_gff_line {
  my $self = shift;
  my $line = shift;
  my $lineend = $self->{load_data}{lineend};

  $self->{load_data}{gff3_flag}++           if $line =~ /^\#\#\s*gff-version\s+3/;
  $self->preferred_groups(split(/\s+/,$1))  if $line =~ /^\#\#\s*group-tags?\s+(.+)/;

  if ($line =~ /^\#\#\s*sequence-region\s+(\S+)\s+(\d+)\s+(\d+)/i) { # header line
    $self->load_gff_line(
			 {
			  ref    => $1,
			  class  => 'Sequence',
			  source => 'reference',
			  method => 'Component',
			  start  => $2,
			  stop   => $3,
			  score  => undef,
			  strand => undef,
			  phase  => undef,
			  gclass => 'Sequence',
			  gname  => $1,
			  tstart => undef,
			  tstop  => undef,
			  attributes  => [],
			 }
			);
    return $self->{load_data}{count}++;
  }

  return if /^#/;

  my ($ref,$source,$method,$start,$stop,$score,$strand,$phase,$group) = split "\t",$line;
  return unless defined($ref) && defined($method) && defined($start) && defined($stop);
  foreach (\$score,\$strand,\$phase) {
    undef $$_ if $$_ eq '.';
  }

  print STDERR $self->{load_data}{count}," records$lineend" 
    if $self->{__verbose__} && $self->{load_data}{count} % 1000 == 0;

  my ($gclass,$gname,$tstart,$tstop,$attributes) = $self->split_group($group,$self->{load_data}{gff3_flag});

  # no standard way in the GFF file to denote the class of the reference sequence -- drat!
  # so we invoke the factory to do it
  my $class = $self->refclass($ref);

  # call subclass to do the dirty work
  if ($start > $stop) {
    ($start,$stop) = ($stop,$start);
    if ($strand eq '+') {
      $strand = '-';
    } elsif ($strand eq '-') {
      $strand = '+';
    }
  }
  # GFF2/3 transition stuff
  $gclass = [$gclass] unless ref $gclass;
  $gname  = [$gname]  unless ref $gname;
  for (my $i=0; $i<@$gname;$i++) {
    $self->load_gff_line({ref    => $ref,
			  class  => $class,
			  source => $source,
			  method => $method,
			  start  => $start,
			  stop   => $stop,
			  score  => $score,
			  strand => $strand,
			  phase  => $phase,
			  gclass => $gclass->[$i],
			  gname  => $gname->[$i],
			  tstart => $tstart,
			  tstop  => $tstop,
			  attributes  => $attributes}
			);
    $self->{load_data}{count}++;
  }
}
END
  warn $@ if $@;
  }

  if ($adaptor eq 'Bio::DB::GFF' && $argv{-adaptor} eq 'memory' && $Bio::Perl::VERSION <= 1.5) {
    # patch memory.pm inability to handle missing gclass fields
    eval <<'END';
use Bio::DB::GFF::Adaptor::memory;
sub Bio::DB::GFF::Adaptor::memory::load_gff_line {
  my $self = shift;
  my $feature_hash  = shift;
  $feature_hash->{strand} = '' if $feature_hash->{strand} && $feature_hash->{strand} eq '.';
  $feature_hash->{phase}  = ''  if $feature_hash->{phase}  && $feature_hash->{phase} eq '.';
  $feature_hash->{gclass} = 'Sequence' unless length $feature_hash->{gclass} > 0;
  # sort by group please
  push @{$self->{tmp}{$feature_hash->{gclass},$feature_hash->{gname}}},$feature_hash;
}
END
  warn $@ if $@;
  }
}

sub redirect_legacy_url {
  my $source      = shift;
  my @more_args   = @_;

  if ($source && path_info() ne "/$source/") {

    my $q = new CGI '';
    if (request_method() eq 'GET') {
      foreach (param()) {
	next if $_ eq 'source';
	$q->param($_=>param($_)) if defined param($_);
      }
    }

    # This is infinitely more difficult due to horrible bug in Apache version 2
    # It is fixed in CGI.pm versions 3.11 and higher, but this version is not guaranteed
    # to be available.
    my ($script_name,$path_info) = _broken_apache_hack();
    my $query_string = $q->query_string;
    my $protocol     = $q->protocol;

    my $new_url      = $script_name;
    $new_url        .= "/$source/";
    $new_url        .= "?$query_string" if $query_string;

    print redirect(-uri=>$new_url,-status=>"301 Moved Permanently");
    exit 0;
  }
}

sub parse_feature_str {
  my $f      = shift;
  my ($reference,$type,$name,@position);
  my @args = shellwords($f||'');
  if (@args > 3) {
    ($reference,$type,$name,@position) = @args;
  } elsif (@args > 2) {
    ($reference,$name,@position) = @args;
  } elsif (@args > 1) {
    ($reference,@position)       = @args;
  } elsif ($f =~ /^(.+):(\d+.+)$/) {
    ($reference,@position) = ($1,$2);
  } elsif ($f =~ /^(.+)/) {
    $reference = $1;
    @position  = '1..1';
  }
  return unless $reference;

  $type = 'Your_Features'              unless defined $type;
  $name = "Feature ".++$ADDED_FEATURES unless defined $name;

  my @segments = map { [/(-?\d+)(?:-|\.\.)(-?\d+)/]} map {split ','} @position;
  ($reference,$type,$name,@segments);
}

# workaround for broken Apache 2 and CGI.pm <= 3.10
sub _broken_apache_hack {
  my $raw_script_name = $ENV{SCRIPT_NAME} || '';
  my $raw_path_info   = $ENV{PATH_INFO}   || '';
  my $uri             = $ENV{REQUEST_URI} || '';

   ## dgg patch; need for what versions? apache 1.x; 
  if ($raw_script_name =~ m/$raw_path_info$/) {
    $raw_script_name =~ s/$raw_path_info$//;
  }

  my @uri_double_slashes  = $uri =~ m^(/{2,}?)^g;
  my @path_double_slashes = "$raw_script_name $raw_path_info" =~ m^(/{2,}?)^g;

  my $apache_bug      = @uri_double_slashes != @path_double_slashes;
  return ($raw_script_name,$raw_path_info) unless $apache_bug;

  my $path_info_search = $raw_path_info;
  # these characters will not (necessarily) be escaped
  $path_info_search    =~ s/([^a-zA-Z0-9$()':_.,+*\/;?=&-])/uc sprintf("%%%02x",ord($1))/eg;
  $path_info_search    = quotemeta($path_info_search);
  $path_info_search    =~ s!/!/+!g;
  if ($uri =~ m/^(.+)($path_info_search)/) {
    return ($1,$2);
  } else {
    return ($raw_script_name,$raw_path_info);
  }
}

sub is_safari {
  return CGI::user_agent =~ /safari/i;
}

# work around an annoying uninit variable warning from Text::Parsewords
sub shellwords {
    my @args = @_;
    return unless @args;
    foreach(@args) {
	s/^\s+//;
	s/\s+$//;
	$_ = '' unless defined $_;
    }
    my @result = Text::ParseWords::shellwords(@args);
    return @result;
}
1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)