Generic Model Organism Database Project

Update of /cvsroot/gmod/Generic-Genome-Browser/ajax/server
In directory sc8-pr-cvs2.sourceforge.net:/tmp/cvs-serv21495

Modified Files:
	BatchTiledImage.pm TiledImage.pm 
Log Message:
intercept drawing primitives with closures rather than AUTOLOAD

Index: TiledImage.pm
===================================================================
RCS file: /cvsroot/gmod/Generic-Genome-Browser/ajax/server/TiledImage.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** TiledImage.pm	3 Feb 2007 02:21:23 -0000	1.2
--- TiledImage.pm	8 Feb 2007 22:32:43 -0000	1.3
***************
*** 115,122 ****
       'stringFTcircle' => {'translator' => $stringFTTranslate, 'boundsGetter' => \&GDStringFTBounds},
  
-      'setBrush' => 1,
- 
      );
  
  # List of unimplemented functions:-- these will throw an error if called
  # (all others are silently passed to a dummy GD object)
--- 115,123 ----
       'stringFTcircle' => {'translator' => $stringFTTranslate, 'boundsGetter' => \&GDStringFTBounds},
  
      );
  
+ @globalPrimNames = qw(colorAllocate setBrush rgb);
+ @dummyGDMethods = qw(getBounds);
+ 
  # List of unimplemented functions:-- these will throw an error if called
  # (all others are silently passed to a dummy GD object)
***************
*** 128,131 ****
--- 129,196 ----
  			     fill fillToBorder));
  
+ foreach my $sub (keys %intercept) {
+     no strict "refs";
+     *$sub = sub  {
+ 	my ($self, @args) = @_;
+ 	
+ 	# check for intercept: if so, get bounding box & store any images
+ 	my @bb = $self->getBoundingBox ($sub, @args);
+ 	
+ 	# update global bounding box
+ 	if (@bb) {
+ 	    $self->xmin ($bb[0]) if !defined ($self->xmin) || $bb[0] < $self->xmin;
+ 	    $self->ymin ($bb[1]) if !defined ($self->ymin) || $bb[1] < $self->ymin;
+ 	    $self->xmax ($bb[2]) if !defined ($self->xmax) || $bb[2] >= $self->xmax;
+ 	    $self->ymax ($bb[3]) if !defined ($self->ymax) || $bb[3] >= $self->ymax;
+ 	}
+ 	
+ 	# record primitive
+ 	$self->primstorage->GDRecordPrimitive ($sub, \@args, @bb);
+ 	
+ 	# log primitive
+ 	warn "Recorded $sub (@args) with ", (@bb>0 ? "bounding box (@bb)" : "no bounding box"), "\n" if $self->verbose == 2;
+     }
+ }
+ 
+ foreach my $sub (@globalPrimNames) {
+     no strict "refs";
+     *$sub = sub  {
+ 	my ($self, @args) = @_;
+ 
+ 	# record primitive
+ 	$self->primstorage->GDRecordPrimitive ($sub, \@args);
+ 
+ 	# log primitive
+ 	warn "Recorded global primitive $sub (@args)\n" if $self->verbose == 2;
+ 
+ 	# delegate
+ 	$self->im->$sub (@args);
+     }
+ }
+ 
+ foreach my $sub (@dummyGDMethods) {
+     no strict "refs";
+     *$sub = sub  {
+ 	my ($self, @args) = @_;
+ 	# delegate
+ 	$self->im->$sub (@args);
+     }
+ }
+ 
+ foreach my $sub (keys %unimplemented) {
+     no strict "refs";
+     *$sub = sub {
+ 	croak "Subroutine $sub unimplemented";
+     }
+ }
+ 
+ foreach my $field (qw(im width height xmin xmax ymin ymax verbose persistent primstorage)) {
+     *$field = sub {
+ 	my $self = shift;
+ 	$self->{$field} = shift if @_;
+ 	return $self->{$field};
+     }
+ }
+ 
  # Subroutine interceptions.
  # Each of the following can take a ($subroutine, @argument_list) array,
***************
*** 189,193 ****
  sub AUTOLOAD {
      my ($self, @args) = @_;
-     my @originalArgs = @args;
  
      # get subroutine name
--- 254,257 ----
***************
*** 198,237 ****
      return if $sub eq "DESTROY";
  
!     # check for unimplemented methods
!     if ($unimplemented{$sub}) {
! 	croak "Subroutine $sub unimplemented";
!     }
! 
!     # check for accessors
!     if (exists $self->{$sub}) {
! 	croak "Usage: $sub() or $sub(newValue)" if @args > 1;
! 	return
! 	    @args
! 	    ? $self->{$sub} = $args[0]
! 	    : $self->{$sub};
!     }
! 
!     # check for intercept: if so, get bounding box & store any images
!     my @bb;
!     if ($self->intercepts($sub)) {
! 	@bb =  $self->getBoundingBox ($sub, @args);
! 
! 	# update global bounding box
! 	if (@bb) {
! 	    $self->xmin ($bb[0]) if !defined ($self->xmin) || $bb[0] < $self->xmin;
! 	    $self->ymin ($bb[1]) if !defined ($self->ymin) || $bb[1] < $self->ymin;
! 	    $self->xmax ($bb[2]) if !defined ($self->xmax) || $bb[2] >= $self->xmax;
! 	    $self->ymax ($bb[3]) if !defined ($self->ymax) || $bb[3] >= $self->ymax;
! 	}
!     }
  
      # record primitive
!     $self->primstorage->GDRecordPrimitive ($sub, \@args, @bb);
! 
!     # log primitive
!     warn "Recorded $sub (@originalArgs) with ", (@bb>0 ? "bounding box (@bb)" : "no bounding box"), "\n" if $self->verbose == 2;
  
      # delegate
!     $self->im->$sub (@originalArgs);
  }
  
--- 262,274 ----
      return if $sub eq "DESTROY";
  
!     warn "unhandled sub $sub";
  
      # record primitive
!     # we don't need to worry about the bounding box here because
!     # all of the primitives with bounding boxes are handled above.
!     $self->primstorage->GDRecordPrimitive ($sub, \@args);
  
      # delegate
!     $self->im->$sub (@args);
  }
  

Index: BatchTiledImage.pm
===================================================================
RCS file: /cvsroot/gmod/Generic-Genome-Browser/ajax/server/BatchTiledImage.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** BatchTiledImage.pm	5 Feb 2007 23:21:05 -0000	1.4
--- BatchTiledImage.pm	8 Feb 2007 22:32:43 -0000	1.5
***************
*** 9,12 ****
--- 9,20 ----
  @ISA = qw(TiledImage);
  
+ foreach my $field (qw(renderTiles tileWidth renderWidth firstTile lastTile lastTileRendered tilePrefix annotate htmlOutdir trackNum)) {
+     *$field = sub {
+ 	my $self = shift;
+ 	$self->{$field} = shift if @_;
+ 	return $self->{$field};
+     }
+ }
+ 
  # Constructor
  sub new {