<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package DBPrimStorage;

# TODO:
# - doesn't clean up 'image' table when 'persistent' set to off, but should

use strict;
use Data::Dumper;
use DBI;
use Carp;

BEGIN {
    foreach my $field (qw(gdtile global_sth bb_sth id image_cache n_primitives)) {
	no strict "refs";
	*$field = sub {
	    my $self = shift;
	    $self-&gt;{$field} = shift if @_;
	    return $self-&gt;{$field};
	}
    }
}

# Global table of TiledImage's for cleanup
my %tiledImageCleanup;

my %storeImagePrims = (
     'copy' =&gt; 1,
     'copyMerge' =&gt; 1,
     'copyMergeGray' =&gt; 1,
     'copyResized' =&gt; 1,
     'copyResampled' =&gt; 1,
     'copyRotated' =&gt; 1,
     'setBrush' =&gt; 1,
);

# $self-&gt;storeImages ($subroutine, @argument_list)
# stores any GD::Image objects in the argument list, and replaces them with database image IDs.
sub storeImages {
    my ($self, $sub, @args) = @_;
    @args = GDStoreImage($self, @args) if defined $storeImagePrims{$sub};
    return @args;
}

# $self-&gt;retrieveImages ($subroutine, @argument_list)
# replaces any database image IDs the argument list with references to GD::Image objects.
sub retrieveImages {
    my ($self, $sub, @args) = @_;
    @args = GDRetrieveImage($self, @args) if defined $storeImagePrims{$sub};
    return @args;
}

# Database access
sub GDConnect {
    my $gdtile_database = shift;
    my $gdtile = DBI-&gt;connect ($gdtile_database, "") or die "Couldn't connect to database: " . DBI-&gt;errstr;
    return $gdtile;
}

sub GDFetchExistingTiledImage {
  my ($gdtile, $tiledimage_name) = @_;
  my $query = "SELECT tiledimage_id FROM tiledimage WHERE tiledimage_name = '$tiledimage_name'";
  my $sth = $gdtile-&gt;prepare ($query);
  $sth-&gt;execute () or die "Couldn't execute statement: " . $sth-&gt;errstr;
  my ($tiledimage_id) = $sth-&gt;fetchrow_array;
  return $tiledimage_id;
}

sub GDFetchTiledImageDimensions {
    my ($gdtile, $tiledimage_id) = @_;
    my $sth = $gdtile-&gt;prepare("SELECT width, height FROM tiledimage WHERE tiledimage_id = " . $tiledimage_id);
    $sth-&gt;execute()
	or die "Couldn't execute statement: " . $sth-&gt;errstr;
    my ($width, $height) = $sth-&gt;fetchrow_array;
    return ($width, $height);
}

sub GDCreateTiledImage {
    my ($gdtile, $tiledimage_name, $width, $height) = @_;
    $gdtile-&gt;do ("INSERT INTO tiledimage (tiledimage_name, width, height) VALUES ('$tiledimage_name', $width, $height)");
    my $sth = $gdtile-&gt;prepare("SELECT LAST_INSERT_ID()");
    $sth-&gt;execute()
	or die "Couldn't execute statement: " . $sth-&gt;errstr;
    my ($tiledimage_id) = $sth-&gt;fetchrow_array;
    return $tiledimage_id;
}

sub GDPrepareQueries {
    my ($gdtile) = @_;
    my $global_sth = $gdtile-&gt;prepare('SELECT command_order, command FROM global_primitive WHERE tiledimage_id = ?')
	or die ("Couldn't prepare statement: " . $gdtile-&gt;errstr);

    my $bb_sth = $gdtile-&gt;prepare('SELECT command_order, command FROM primitive WHERE x0 &lt;= ? AND y0 &lt;= ? AND x1 &gt;= ? AND y1 &gt;= ? AND tiledimage_id = ?')
	or die ("Couldn't prepare statement: " . $gdtile-&gt;errstr);
    return ($global_sth, $bb_sth);
}
sub GDDeletePrimitives {
    my ($self) = @_;
    # use explicit hashrefs instead of AUTOLOAD'ed accessors,
    # so that this method can be called by the signal handlers
    $self-&gt;{'gdtile'}-&gt;do ("DELETE FROM primitive WHERE tiledimage_id = " . $self-&gt;{'id'});
    $self-&gt;{'gdtile'}-&gt;do ("DELETE FROM global_primitive WHERE tiledimage_id = " . $self-&gt;{'id'});
    $self-&gt;{'gdtile'}-&gt;do ("DELETE FROM tiledimage WHERE tiledimage_id = " . $self-&gt;{'id'});
}

sub GDDisconnect {
    my ($self) = @_;
    # use explicit hashrefs instead of AUTOLOAD'ed accessors,
    # so that this method can be called by the signal handlers
    $self-&gt;{'gdtile'}-&gt;disconnect if defined $self-&gt;{'gdtile'};
}

sub GDStoreImage {
    my ($self, $image, @otherArgs) = @_;

    # get PNG data
    croak "Not a GD::Image" unless ref($image) eq "GD::Image";
    my $image_data = $image-&gt;png;
    croak "Bad image data" unless defined $image_data;

    # INSERT PNG data into image table
    my $sth = $self-&gt;gdtile-&gt;prepare("INSERT INTO image (image_data) VALUES (?)")
	or die "Couldn't prepare statement: " . $self-&gt;gdtile-&gt;errstr;

    $sth-&gt;execute ($image_data)
	or die "Couldn't execute statement: " . $sth-&gt;errstr;

    # get image ID
    my $id_sth = $self-&gt;gdtile-&gt;prepare("SELECT LAST_INSERT_ID()");
    $id_sth-&gt;execute()
	or die "Couldn't execute statement: " . $id_sth-&gt;errstr;
    my ($image_id) = $id_sth-&gt;fetchrow_array;

    # return
    return ($image_id, @otherArgs);
}

sub GDRetrieveImage {
    my ($self, $image_id, @otherArgs) = @_;

    # get PNG data from image table
    my $sth = $self-&gt;gdtile-&gt;prepare("SELECT image_data FROM image WHERE image_id = $image_id")
	or die "Couldn't prepare statement: " . $self-&gt;gdtile-&gt;errstr;

    $sth-&gt;execute()
	or die "Couldn't execute statement: " . $sth-&gt;errstr;

    # create image from PNG data &amp; remember it in image_cache.
    # NB if we just create a GD::Image object here, bugs occur in setBrush,
    # maybe cos Perl thinks it can safely delete the brush image (due to absence of refs to object?)
    # keeping the image in image_cache seems to work (because it fool Perls into keeping the GD::Image around?)
    while (my ($image_data) = $sth-&gt;fetchrow_array) {
	$self-&gt;image_cache-&gt;{$image_id} = GD::Image-&gt;newFromPngData ($image_data);
    }

    # return
    return ($self-&gt;image_cache-&gt;{$image_id}, @otherArgs);
}

sub GDRecordPrimitive {
    my ($self, $sub, $subargs, @bb) = @_;

    my @args = $self-&gt;storeImages ($sub, @$subargs);

    # get string representation and store in SQL database
    my $dumper = Data::Dumper-&gt;new ([[$sub,@args]]);
    $dumper-&gt;Indent(0)-&gt;Terse(1)-&gt;Purity(1);
    my $command = $dumper-&gt;Dump;
    $command =~ s/\\/\\\\/g;  # escape backslashes
    $command =~ s/\"/\\\"/g;  # escape quotes

    # which table should this go into?
    my @cols = qw(tiledimage_id command_order command);
    my $table;
    if (@bb) {
	push @cols, qw(x0 y0 x1 y1);
	$table = 'primitive';
    } else {
	$table = 'global_primitive';
    }

    # INSERT subroutine &amp; argument list into table
    my $command_order = $self-&gt;n_primitives ($self-&gt;n_primitives + 1);
    $self-&gt;gdtile-&gt;do ("INSERT INTO $table ("
		       . join (',', @cols)
		       . ") VALUES ("
		       . join (',', $self-&gt;id, $command_order, "\"$command\"", @bb)
		       . ")");
}

sub GDEraseLeftmostPrimitives {
    my ($self, $x) = @_;
    $self-&gt;gdtile-&gt;do ("DELETE FROM primitive WHERE x1 &lt; $x");
}

sub deserializePrims {
    my ($self, $primarray) = @_;

    my @prims = map {
	my $command_order = int($_-&gt;[0]);
	my $command = $_-&gt;[1];

	# recreate [$subroutine,@argument_list] primitive using 'eval' on Data::Dumper string
	my ($sub, @args) = @{eval $command};
	unless (defined $sub) {  # check subroutine is defined
	    warn $!;
	    die "Offending 'eval': $command\n";
	}

	# retrieve images
	@args = $self-&gt;retrieveImages ($sub, @args);
	[$command_order, $sub, @args];
    } @{$primarray};

    return @prims;
}

# The following two methods for querying tables of GD primitives both
# return a coderef that's an iterator over (command_order, command) pairs
sub GDGetGlobalPrimitives {
    my ($self) = @_;
    $self-&gt;global_sth-&gt;execute ($self-&gt;id)
	or die "Couldn't execute statement: " . $self-&gt;global_sth-&gt;errstr;
    
    return ($self-&gt;deserializePrims($self-&gt;global_sth-&gt;fetchall_arrayref));
}

sub GDGetBoundedPrimitives {
    my ($self, $xmin, $ymin, $xmax, $ymax) = @_;
    $self-&gt;bb_sth-&gt;execute($xmax,$ymax,$xmin,$ymin,$self-&gt;id)
	or die "Couldn't execute statement: " . $self-&gt;bb_sth-&gt;errstr;

    return ($self-&gt;deserializePrims($self-&gt;bb_sth-&gt;fetchall_arrayref));
}

sub perTileCleanup {
    my $self = shift;

    # flush image cache
    $self-&gt;image_cache ({});
}

# cleanup:--
# disconnects from the database
sub cleanup {
    my $self = shift;
    $self-&gt;GDDisconnect;
}

# Public methods.
# Constructor
sub new {
    my ($class, %args) = @_;
    my ($verbose, $tiledimage_name) = ($args{'-verbose'}, $args{'-tiledimage_name'});
    my ($width, $height, $tiledimage_id);

    warn "connecting to prim database " . $args{'-primdb'} . "\n" if $verbose;

    # connect to database
    my $gdtile = GDConnect ($args{'-primdb'});

    if ($tiledimage_id = GDFetchExistingTiledImage ($gdtile, $tiledimage_name))
    {
      # we already have stuff for this TiledImage, so use its dimensions
      ($width, $height) = GDFetchTiledImageDimensions ($gdtile, $tiledimage_id);
      warn "reusing existing TiledImage (id = $tiledimage_id)\n" if $verbose;
    }
    else
    {
      # need to create new TiledImage
      ($width, $height) = ($args{'-width'}, $args{'-height'});
      $tiledimage_id = GDCreateTiledImage ($gdtile, $tiledimage_name, $width, $height);
      warn "creating new TiledImage (id = $tiledimage_id)\n" if $verbose;
    }

    # prepare SQL queries
    my ($global_sth, $bb_sth) = GDPrepareQueries ($gdtile);

    my $self = { 'gdtile' =&gt; $gdtile,
		 'global_sth' =&gt; $global_sth,
		 'bb_sth' =&gt; $bb_sth,

		 'id' =&gt; $tiledimage_id,
		 'name' =&gt; $tiledimage_name,

		 'verbose' =&gt; $verbose,

		 'width' =&gt; $width,
		 'height' =&gt; $height,

		 'image_cache' =&gt; {},

		 'n_primitives' =&gt; 0,
    };

    bless $self, $class;
    return $self;
}

1;
</pre></body></html>