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 {
|