[Gmod-gbrowse-cmts] Generic-Genome-Browser/lib/Bio/Graphics Browser.pm, 1.167.4.34.2.32.2.27, 1.167.4.34.2.32.2.28 FeatureFile.pm, 1.1.2.3, 1.1.2.4

[Sheldon M. <she...@us...>]

Update of /cvsroot/gmod/Generic-Genome-Browser/lib/Bio/Graphics
In directory sc8-pr-cvs2.sourceforge.net:/tmp/cvs-serv6514/lib/Bio/Graphics

Modified Files:
      Tag: stable
	Browser.pm FeatureFile.pm 
Log Message:
Changes to render_panels method and panel caching to support
the PrimerDesigner plugin, gbrowse_karyotype and gbrowse_syn


Index: Browser.pm
===================================================================
RCS file: /cvsroot/gmod/Generic-Genome-Browser/lib/Bio/Graphics/Browser.pm,v
retrieving revision 1.167.4.34.2.32.2.27
retrieving revision 1.167.4.34.2.32.2.28
diff -C2 -d -r1.167.4.34.2.32.2.27 -r1.167.4.34.2.32.2.28
*** Browser.pm	13 Sep 2007 21:00:41 -0000	1.167.4.34.2.32.2.27
--- Browser.pm	28 Sep 2007 08:03:31 -0000	1.167.4.34.2.32.2.28
***************
*** 66,69 ****
--- 66,72 ----
  use Bio::Graphics::Browser::I18n;
  use Bio::Graphics::Browser::Util 'modperl_request','is_safari';
+ use Storable qw/store retrieve/;
+ 
+ use Data::Dumper;
  
  require Exporter;
***************
*** 256,260 ****
    $value = $browser->setting('stylesheet');
  
! The setting() method returns the value of one of the current source's
  configuration settings.  setting() takes two arguments.  The first
  argument is the name of the stanza in which the configuration option
--- 259,263 ----
    $value = $browser->setting('stylesheet');
  
! The setting() method returns the value of one of the current source
  configuration settings.  setting() takes two arguments.  The first
  argument is the name of the stanza in which the configuration option
***************
*** 343,347 ****
    my ($last_name)    = $caller_package =~ /(\w+)$/;
    my $option_name    = "${last_name}:plugin";
-   #warn "$option_name @_ ".$self->setting($option_name => @_);
    $self->setting($option_name => @_);
  }
--- 346,349 ----
***************
*** 790,793 ****
--- 792,801 ----
    hilite_callback     Callback for performing hilighting
  
+   image_and_map       This argument will cause render_panels to emulate 
+                         the legacy method image_and_map() and return a 
+                         GD::Image object and a 'boxes' array reference rather
+                         than rendered html.  This argument applies only to composite
+                         (non-draggable) panel images.  
+ 
  Any arguments names that begin with an initial - (hyphen) are passed
  through to Bio::Graphics::Panel->new() directly
***************
*** 955,965 ****
    my ($args,$panel) = @_;
  
!   my $section = $args->{section};
    $section    =~ s/^\?//;
    my $button  = $args->{image_button};
  
!   my $url             = $panel->{image};
!   my $map             = $panel->{map} || '';
!   my ($width,$height) = @{$panel}{'width','height'};
    my $map_name = "${section}_map";
  
--- 963,978 ----
    my ($args,$panel) = @_;
  
!   my $section = $args->{section} || '?detail';
    $section    =~ s/^\?//;
    my $button  = $args->{image_button};
  
!   my ($width,$height,$url,$map,$gd,$boxes) = @{$panel}{qw/width height image map gd boxes/};
! 
!   if ($args->{image_and_map}) {
!     my $map_array = $self->map_array($boxes);
!     return $gd, $map_array;
!   }
! 
!   $map ||= '';
    my $map_name = "${section}_map";
  
***************
*** 1069,1072 ****
--- 1082,1086 ----
    unless ($cached{$panel_key}) {
      $panels{$panel_key}      = Bio::Graphics::Panel->new(@panel_args);
+ 
      $panels{$panel_key}->add_track($segment      => 'arrow',
  				   -double       => 1,
***************
*** 1169,1173 ****
  			    file       => $file,
  			    panel      => $panels{$panel_key},
! 			    position   => $feature_file_offsets{$l} || 1,
  			    options    => $options,
  			    select     => $featurefile_select,
--- 1183,1187 ----
  			    file       => $file,
  			    panel      => $panels{$panel_key},
! 			    position   => $feature_file_offsets{$l} || 0,
  			    options    => $options,
  			    select     => $featurefile_select,
***************
*** 1181,1205 ****
    $args->{scale_map_type} ||= 'centering_map';
    (my $map_name = $section) =~ s/^\?//;
    for my $l (keys %panels) {
      my $gd = $panels{$l}->gd;
!     my $map    =   !$do_map            ? undef
! 	           : $l eq '__pad__'   ? undef
! 	           : $l eq '__scale__' ? $self->make_centering_map(shift @{$panels{$l}->boxes},
! 								   $args->{flip},
! 								   $l,
! 								   $args->{scale_map_type},
! 								  )
! 		   : $l eq '__all__'   ? $self->make_map(scalar $panels{$l}->boxes,
! 							 $panels{$l},
! 							 $map_name,
! 							 \%trackmap,
! 							 $args->{scale_map_type})
! 		   :                     $self->make_map(scalar $panels{$l}->boxes,
! 							 $panels{$l},
! 							 $l,
! 							 \%trackmap,
! 							 0);
      my $key = $drag_n_drop ? $cache_key{$l} : $cache_key{'__all__'};
!     @{$results{$l}}{qw(image map width height file)} = $self->set_cached_panel($key,$gd,$map);
      eval {$panels{$l}->finished};
    }
--- 1195,1221 ----
    $args->{scale_map_type} ||= 'centering_map';
    (my $map_name = $section) =~ s/^\?//;
+ 
    for my $l (keys %panels) {
      my $gd = $panels{$l}->gd;
!     my $map  = !$do_map          ? (undef,undef)
! 	     : $l eq '__pad__'   ? (undef,undef)
! 	     : $l eq '__scale__' ? $self->make_centering_map(shift @{$panels{$l}->boxes},
! 							     $args->{flip},
! 							     $l,
! 							     $args->{scale_map_type},
! 							     )
! 	     : $l eq '__all__'   ? $self->make_map(scalar $panels{$l}->boxes,
! 						   $panels{$l},
! 						   $map_name,
! 						   \%trackmap,
! 						   $args->{scale_map_type})
! 	     : $self->make_map(scalar $panels{$l}->boxes,
! 			       $panels{$l},
! 			       $l,
! 			       \%trackmap,
! 			       0);
!     
      my $key = $drag_n_drop ? $cache_key{$l} : $cache_key{'__all__'};
!     $self->set_cached_panel($key,$gd,$map);
      eval {$panels{$l}->finished};
    }
***************
*** 1207,1211 ****
    # cached panels need to be retrieved
    for my $l (keys %cached) {
!     @{$results{$l}}{qw(image map width height file)} = $self->get_cached_panel($cache_key{$l});
    }
  
--- 1223,1227 ----
    # cached panels need to be retrieved
    for my $l (keys %cached) {
!     @{$results{$l}}{qw(image map width height file gd boxes)} = $self->get_cached_panel($cache_key{$l});
    }
  
***************
*** 1548,1555 ****
  }
  
  sub make_map {
    my $self = shift;
    my ($boxes,$panel,$map_name,$trackmap,$first_box_is_scale) = @_;
!   my $map = qq(<map name="${map_name}_map" id="${map_name}_map">\n);
  
    my $flip = $panel->flip;
--- 1564,1572 ----
  }
  
+ 
  sub make_map {
    my $self = shift;
    my ($boxes,$panel,$map_name,$trackmap,$first_box_is_scale) = @_;
!   my @map = ($map_name);
  
    my $flip = $panel->flip;
***************
*** 1561,1565 ****
    local $^W = 0; # avoid uninit variable warnings due to poor coderefs
  
!   $map .= $self->make_centering_map(shift @$boxes,$flip,0,$first_box_is_scale) if $first_box_is_scale;
  
    foreach (@$boxes){
--- 1578,1584 ----
    local $^W = 0; # avoid uninit variable warnings due to poor coderefs
  
!   if ($first_box_is_scale) {
!     push @map, $self->make_centering_map(shift @$boxes,$flip,0,$first_box_is_scale);
!   }
  
    foreach (@$boxes){
***************
*** 1568,1616 ****
      my $label  = $_->[5] ? $trackmap->{$_->[5]} : '';
  
!     my $href       = $self->make_href($_->[0],$panel,$label,$_->[5]);
!     my $titletext  = unescape($self->make_title($_->[0],$panel,$label,$_->[5]));
!     my $target     = $self->config->make_link_target($_->[0],$panel,$label,$_->[5]);
!     my $t          = defined($target) ? qq(target="$target") : '';
! 
!     $href         = qq(href="$href");
!     my $title     = qq(title="$titletext");
  
!     my ($mouseover,$mousedown);
      if ($tips) {
        #retrieve the content of the balloon from configuration files
        # if it looks like a URL, we treat it as a URL.
!       my ($balloon_ht,$balloonhover)	     = $self->config->balloon_tip_setting('balloon hover',$label,$_->[0],$panel,$_->[5]);
!       my ($balloon_ct,$balloonclick)	     = $self->config->balloon_tip_setting('balloon click',$label,$_->[0],$panel,$_->[5]);
        # balloon_ht = type of balloon to use for hovering -- usually "balloon"
        # balloon_ct = type of balloon to use for clicking -- usually "balloon"
        my $sticky             = $self->setting($label,'balloon sticky');
        my $height             = $self->setting($label,'balloon height') || 300;
! 
        if ($use_titles_for_balloons) {
! 	  $balloonhover ||= $titletext;
! 	  $balloon_ht   ||= 'balloon';
        }
  
        if ($balloonhover) {
! 	my $stick = defined $sticky ? $sticky : 0;
! 	$mouseover = $balloonhover =~ /^(https?|ftp):/
! 	  ? qq(onmouseover="$balloon_ht.showTooltip(event,'<iframe width='+$balloon_ct.maxWidth+' height=$height frameborder=0 src=$balloonhover></iframe>',$stick)")
! 	    : qq(onmouseover="$balloon_ht.showTooltip(event,'$balloonhover',$stick)");
  	undef $title;
        }
        if ($balloonclick) {
  	my $stick = defined $sticky ? $sticky : 1;
! 	my $style = qq(style="cursor:pointer");
  	$mousedown = $balloonclick =~ /^(http|ftp):/
! 	  ? qq(onmousedown="$balloon_ct.delayTime=0; $balloon_ct.showTooltip(event,'<iframe width='+$balloon_ct.maxWidth+' height=$height frameborder=0 src=$balloonclick></iframe>',$stick,$balloon_ct.maxWidth)" $style)
! 	    : qq(onmousedown="$balloon_ct.delayTime=0; $balloon_ct.showTooltip(event,'$balloonclick',$stick)" $style);
  	undef $href;
        }
      }
  
!     $map .= qq(<area $href $mouseover $mousedown coords="$_->[1],$_->[2],$_->[3],$_->[4]" $t $title/>);
    }
!   $map .= "</map>\n";
!   $map;
  }
  
--- 1587,1656 ----
      my $label  = $_->[5] ? $trackmap->{$_->[5]} : '';
  
!     my $href   = $self->make_href($_->[0],$panel,$label,$_->[5]);
!     my $title  = unescape($self->make_title($_->[0],$panel,$label,$_->[5]));
!     my $target = $self->config->make_link_target($_->[0],$panel,$label,$_->[5]);
  
!     my ($mouseover,$mousedown,$style);
      if ($tips) {
        #retrieve the content of the balloon from configuration files
        # if it looks like a URL, we treat it as a URL.
!       my ($balloon_ht,$balloonhover)     = $self->config->balloon_tip_setting('balloon hover',$label,$_->[0],$panel,$_->[5]);
!       my ($balloon_ct,$balloonclick)     = $self->config->balloon_tip_setting('balloon click',$label,$_->[0],$panel,$_->[5]);
        # balloon_ht = type of balloon to use for hovering -- usually "balloon"
        # balloon_ct = type of balloon to use for clicking -- usually "balloon"
        my $sticky             = $self->setting($label,'balloon sticky');
        my $height             = $self->setting($label,'balloon height') || 300;
!       
        if ($use_titles_for_balloons) {
! 	$balloonhover ||= $title;
        }
  
+       $balloon_ht ||= 'balloon';
+       $balloon_ct ||= 'balloon';;
+ 
        if ($balloonhover) {
!         my $stick = defined $sticky ? $sticky : 0;
!         $mouseover = $balloonhover =~ /^(https?|ftp):/
! 	    ? "$balloon_ht.showTooltip(event,'<iframe width='+$balloon_ct.maxWidth+' height=$height frameborder=0 " .
! 	      "src=$balloonhover></iframe>',$stick)"
! 	    : "$balloon_ht.showTooltip(event,'$balloonhover',$stick)";
  	undef $title;
        }
        if ($balloonclick) {
  	my $stick = defined $sticky ? $sticky : 1;
!         $style = "cursor:pointer";
  	$mousedown = $balloonclick =~ /^(http|ftp):/
! 	    ? "$balloon_ct.delayTime=0; $balloon_ct.showTooltip(event,'<iframe width='+$balloon_ct.maxWidth+' height=$height " .
! 	      "frameborder=0 src=$balloonclick></iframe>',$stick,$balloon_ct.maxWidth)"
! 	    : "$balloon_ct.delayTime=0; $balloon_ct.showTooltip(event,'$balloonclick',$stick)";
  	undef $href;
        }
      }
+     
+     
+     my %attributes = (
+ 		      title       => $title,
+ 		      href        => $href,
+ 		      target      => $target,
+ 		      onmouseover => $mouseover,
+ 		      onmousedown => $mousedown,
+ 		      style       => $style
+ 		      );
  
!     my $ftype = $_->[0]->primary_tag || 'feature';
!     my $fname = $_->[0]->display_name if $_->[0]->can('display_name');
!     $fname  ||= $_->[0]->name if $_->[0]->can('name');
!     $fname  ||= 'unnamed';
!     $ftype = "$ftype:$fname";
!     my $line = join("\t",$ftype,@{$_}[1..4]);
!     for my $att (keys %attributes) {
!       next unless defined $attributes{$att};
!       $line .= "\t$att\t$attributes{$att}";
!     }
!     push @map, $line;
    }
! 
!   return \@map;
! 
  }
  
***************
*** 1620,1623 ****
--- 1660,1664 ----
    my $self   = shift;
    my ($ruler,$flip,$label,$scale_map_type)  = @_;
+   my @map = $label ? ($label) : ();
  
    return if $ruler->[3]-$ruler->[1] == 0;
***************
*** 1641,1645 ****
    my $source = $self->source;
  
-   my @lines;
    for my $i (0..$ruler_intervals-1) {
      my $x1 = int($portion * $i+0.5);
--- 1682,1685 ----
***************
*** 1664,1673 ****
      my $url = "?ref=$ref;start=$start;stop=$stop";
      $url .= ";flip=1" if $flip;
!     push @lines,
!       qq(<area shape="rect" coords="$x1,$ruler->[2],$x2,$ruler->[4]" href="$url" title="recenter" alt="recenter" />\n);
    }
!   my $map = join '',@lines;
!   $map    = qq(<map name="${label}_map" id="${label}_map">\n).$map."</map>\n" if $label;
!   return $map;
  }
  
--- 1704,1713 ----
      my $url = "?ref=$ref;start=$start;stop=$stop";
      $url .= ";flip=1" if $flip;
!     
!     push @map, join("\t",'ruler',$x2, $ruler->[2], $x2, $ruler->[4], 
! 		    href  => $url, title => 'recenter', alt   => 'recenter');
    }
!   
!   return $label ? \@map : @map;
  }
  
***************
*** 2523,2530 ****
  
    # get map data
!   my $map_data;
    if (-e $map_file) {
      my $f = IO::File->new($map_file) or return;
!     $map_data = join '',$f->getlines;
      $f->close;
    }
--- 2563,2572 ----
  
    # get map data
!   my $map_data = [];
    if (-e $map_file) {
      my $f = IO::File->new($map_file) or return;
!     while (my $line = $f->getline) {
!       push @$map_data, $line;
!     }   
      $f->close;
    }
***************
*** 2539,2543 ****
    }
  
- 
    my $base = -e "$image_file.png" ? '.png'
             : -e "$image_file.jpg" ? '.jpg'
--- 2581,2584 ----
***************
*** 2546,2550 ****
    $image_uri  .= $base;
    $image_file .= $base;
!   return ($image_uri,$map_data,$width,$height,$image_file);
  }
  
--- 2587,2636 ----
    $image_uri  .= $base;
    $image_file .= $base;
!   
!   my $gd = GD::Image->new($image_file) unless $image_file =~ /svg$/;
!   my $map_html  = $self->map_html($map_data);
!   return ($image_uri,$map_html,$width,$height,$image_file,$gd,$map_data);
! }
! 
! # Convert the cached image map data
! # into an array structure analogous to
! # Bio::Graphics::Panel->boxes
! sub map_array {
!   my $self = shift;
!   my $data = shift;
!   chomp @$data;
!   my $name = shift @$data or return;
!   my $map = [$name];
! 
!   for (@$data) {
!     my ($type,$x1,$y1,$x2,$y2,%atts) = split "\t";
!     push @$map, [$type,$x1,$y1,$x2,$y2,\%atts];    
!   }
!   return $map;
! }
! 
! # Convert the cached image map data
! # into HTML. 
! sub map_html {
!   my $self = shift;
!   my $data = shift;
!   chomp @$data;
!   my $name = shift @$data or return '';
! 
!   my $html  = qq(\n<map name="${name}_map" id="${name}_map">\n);
!   
!   for (@$data) {
!     my (undef,$x1,$y1,$x2,$y2,%atts) = split "\t";
!     $x1 or next;
!     my $coords = join(',',$x1,$y1,$x2,$y2);
!     $html .= qq(<area shape="rect" coords="$coords" );
!     for my $att (keys %atts) {
!       $html .= qq($att="$atts{$att}" );
!     }
!     $html .= qq(/>\n);
!   }
!   
!   $html .= qq(</map>\n);
!   return $html;
  }
  
***************
*** 2557,2564 ****
    my ($image_file,$image_uri) = $self->get_cache_base($key,'image') or return;
  
!   # write the map data
    if ($map_data) {
      my $f = IO::File->new(">$map_file") or die "$map_file: $!";
!     $f->print($map_data);
      $f->close;
    }
--- 2643,2650 ----
    my ($image_file,$image_uri) = $self->get_cache_base($key,'image') or return;
  
!   # write the map data 
    if ($map_data) {
      my $f = IO::File->new(">$map_file") or die "$map_file: $!";
!     $f->print(join("\n", @$map_data),"\n");
      $f->close;
    }

Index: FeatureFile.pm
===================================================================
RCS file: /cvsroot/gmod/Generic-Genome-Browser/lib/Bio/Graphics/FeatureFile.pm,v
retrieving revision 1.1.2.3
retrieving revision 1.1.2.4
diff -C2 -d -r1.1.2.3 -r1.1.2.4
*** FeatureFile.pm	27 Aug 2007 21:00:28 -0000	1.1.2.3
--- FeatureFile.pm	28 Sep 2007 08:03:31 -0000	1.1.2.4
***************
*** 1386,1392 ****
    my $n;
    $linkrule ||= ''; # prevent uninit warning
    $linkrule =~ s/\$(\w+)/
      CGI::escape(
!     $1 eq 'ref'              ? (($n = $feature->location->seq_id) && "$n") || ''
        : $1 eq 'name'         ? (($n = $feature->display_name) && "$n")     || ''
        : $1 eq 'class'        ? eval {$feature->class}  || ''
--- 1386,1393 ----
    my $n;
    $linkrule ||= ''; # prevent uninit warning
+   my $seq_id = $feature->can('location') ? $feature->location->seq_id : $feature->seq_id;
    $linkrule =~ s/\$(\w+)/
      CGI::escape(
!     $1 eq 'ref'              ? (($n = $seq_id) && "$n") || ''
        : $1 eq 'name'         ? (($n = $feature->display_name) && "$n")     || ''
        : $1 eq 'class'        ? eval {$feature->class}  || ''