view release on metacpan or  search on metacpan

lib/Legacy/Graphics/Browser/Util.pm  view on Meta::CPAN

	      -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            = qw/buttons.js prototype.js balloon.config.js balloon.js rubber.js overviewSelect.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');