GD.pd

#
# GD.pd
#
# PDL interface to the GD c library
#   ('cos looping over an ndarray in perl and using the perl GD lib is too slow...)
#
# Judd Taylor, USF IMaRS
# 13 March 2003
#

use strict;
use warnings;
#use PDL;
use vars qw( $VERSION );

$VERSION = "2.103";

#####################################
# Start the General Interface Docs: #
#####################################

pp_addpm({ At => 'Top' }, <<'ENDPM');
use strict;
use warnings;

=head1 NAME

PDL::IO::GD - Interface to the GD image library.

=head1 SYNOPSIS

 my $pdl = sequence(byte, 30, 30);
 write_png($pdl, load_lut($lutfile), "test.png");

 write_true_png(sequence(100, 100, 3), "test_true.png");

 my $image = read_png("test.png");

 my $image = read_true_png("test_true_read.png");
 write_true_png($image, "test_true_read.out.png");

 my $lut = read_png_lut("test.png");

 $pdl = sequence(byte, 30, 30);
 write_png_ex($pdl, load_lut($lutfile), "test_nocomp.png", 0);
 write_png_ex($pdl, load_lut($lutfile), "test_bestcomp1.png", 9);
 write_png_best($pdl, load_lut($lutfile), "test_bestcomp2.png");

 $pdl = sequence(100, 100, 3);
 write_true_png_ex($pdl, "test_true_nocomp.png", 0);
 write_true_png_ex($pdl, "test_true_bestcomp1.png", 9);
 write_true_png_best($pdl, "test_true_bestcomp2.png");

 recompress_png_best("test_recomp_best.png");

=head1 DESCRIPTION

This is the "General Interface" for the PDL::IO::GD library, and is actually several
years old at this point (read: stable). If you're feeling frisky, try the new OO 
interface described below.

The general version just provides several image IO utility functions you can use with
ndarray variables. It's deceptively useful, however.

=cut


ENDPM


###########################
# General Interface Code: #
###########################


# needed header files:
pp_addhdr(<<'EOH');

#include "gd.h"

#include "gdfontl.h"
#include "gdfonts.h"
#include "gdfontmb.h"
#include "gdfontg.h"
#include "gdfontt.h"

#include <stdio.h>

#define PKG "PDL::IO::GD"

EOH

my %gdi_from_pngfile = (
  OtherPars => 'char* filename',
  Comp => 'gdImagePtr im',
  MakeComp => '
    FILE *fh = fopen($COMP(filename), "rb");
    if (!fh) $CROAK("Error opening %s\n", $COMP(filename));
    $COMP(im) = gdImageCreateFromPng(fh);
    fclose(fh);
    if (!$COMP(im)) $CROAK("Error reading PNG data\n");
  ',
  CompFreeCodeComp => 'gdImageDestroy($COMP(im));',
);
my %gdi_from_args = (
  OtherPars => 'gdImagePtr im',
);
my %lu_dim_check = (
  RedoDimsCode => <<'EOF',
if ($SIZE(j) > 256)
    $CROAK("Wrong LUT dimensions (%"IND_FLAG", %"IND_FLAG")! (should be (3, X), where X <= 256)\n",
            $SIZE(i), $SIZE(j) );
EOF
);
my %level_check = (
  RedoDimsCode => <<'EOF',
if( $COMP(level) < -1 || $COMP(level) > 9 )
    $CROAK("Invalid compression level %d, should be [-1,9]\n",
        $COMP(level) );
EOF
);
my %lu_dim_level_check = (
  RedoDimsCode => $lu_dim_check{RedoDimsCode}.$level_check{RedoDimsCode},
);
my $gdi_from_dims = "gdImagePtr im = gdImageCreate(\$SIZE(x), \$SIZE(y));\n";
my $gdi_to_file = <<'EOF';
FILE *out = fopen($COMP(filename), "wb");
if (!out) $CROAK("Error opening %s\n", $COMP(filename));
gdImagePng(im, out);
fclose(out);
gdImageDestroy(im);
EOF
my $gdi_to_fileEx = <<'EOF';
FILE *out = fopen($COMP(filename), "wb");
if (!out) $CROAK("Error opening %s\n", $COMP(filename));
gdImagePngEx(im, out, $COMP(level));
fclose(out);
gdImageDestroy(im);
EOF
my $gdiTrue_from_dims = "gdImagePtr im = gdImageCreateTrueColor(\$SIZE(x), \$SIZE(y));\n";
my $lut_allocate = <<'EOF';
loop(j) %{
  int tmp = gdImageColorAllocate(im, $lut(i=>0), $lut(i=>1), $lut(i=>2));
  if (tmp != j)
    $CROAK("palette mismatch on index %"IND_FLAG" (mapped to %d)\n", j, tmp);
%}
EOF
my $img_to_gdi = 'loop(y,x) %{
  if ($img() >= $SIZE(j))
    $CROAK("Pixel value=%d exceeded LUT size", (int)$img());
  gdImageSetPixel(im, x, y, $img());
%}';
my $img_to_gdiTrue = <<'EOF';
loop(y,x) %{
  gdImageSetPixel(im, x, y,
    gdImageColorResolve(im, $img(z=>0), $img(z=>1), $img(z=>2))
  );
%}
EOF
my $gdi_to_img_tpl = 'loop(y,x) %%{ $img() = gdImageGetPixel($COMP(im), x, %sy); %%}';
my $gdi_to_img = sprintf $gdi_to_img_tpl, '';
my $gdi_to_img_inv = sprintf $gdi_to_img_tpl, '$SIZE(y)-1-';
my $gdiTrue_to_img_tpl = <<'EOF';
if (!$COMP(im)->trueColor) $CROAK("Tried to read a non-truecolour image as truecolour");
loop(y,x) %%{
  int tpixel = gdImageTrueColorPixel($COMP(im), x, %sy);
  $img(z=>0) = gdTrueColorGetRed(tpixel);
  $img(z=>1) = gdTrueColorGetGreen(tpixel);
  $img(z=>2) = gdTrueColorGetBlue(tpixel);
%%}
EOF
my $gdiTrue_to_img = sprintf $gdiTrue_to_img_tpl, '';
my $gdiTrue_to_img_inv = sprintf $gdiTrue_to_img_tpl, '$SIZE(y)-1-';
my $gdi_to_ptr = '$img_ptr() = PTR2IV(im);';

# Function to write a PNG image from an ndarray variable:
pp_def( 'write_png',
        Pars => 'img(x,y); lut(i=3,j);',
        GenericTypes => ['B'],
        OtherPars => 'char* filename',
        Doc => <<'ENDDOC',
Writes a 2-d PDL variable out to a PNG file, using the supplied color look-up-table ndarray
(hereafter referred to as a LUT).

The LUT contains a line for each value 0-255 with a corresponding R, G, and B value.
ENDDOC
        %lu_dim_check,
        Code => $gdi_from_dims . $lut_allocate . $img_to_gdi . $gdi_to_file,
);

# Function to write a PNG image from an ndarray variable, accepting a compression
#    level argument:
pp_def( 'write_png_ex',
        Pars => 'img(x,y); lut(i=3,j);',
        GenericTypes => ['B'],
        OtherPars => 'char* filename; int level',
        Doc => <<'ENDDOC',
Same as write_png(), except you can specify the compression level (0-9) as the last argument.
ENDDOC
        %lu_dim_level_check,
        Code => $gdi_from_dims . $lut_allocate . $img_to_gdi . $gdi_to_fileEx,
);

# Function to write a TRUE COLOR PNG image from an ndarray variable:
pp_def( 'write_true_png',
        Pars => 'img(x,y,z=3);',
        GenericTypes => ['B'],
        OtherPars => 'char* filename',
        Doc => <<'ENDDOC',
Writes an (x, y, z(3)) PDL variable out to a PNG file, using a true color format.

This means a larger file on disk, but can contain more than 256 colors.
ENDDOC
        Code => $gdiTrue_from_dims . $img_to_gdiTrue . $gdi_to_file,
);

# Function to write a TRUE COLOR PNG image from an ndarray variable, 
#    with the specified compression level:
pp_def( 'write_true_png_ex',
        Pars => 'img(x,y,z=3);',
        GenericTypes => ['B'],
        OtherPars => 'char* filename; int level',
        Doc => <<'ENDDOC',
Same as write_true_png(), except you can specify the compression level (0-9) as the last argument.
ENDDOC
        %level_check,
        Code => $gdiTrue_from_dims . $img_to_gdiTrue . $gdi_to_fileEx,
);

#
# Add some perl level alias functions to automatically use the best compression
#
pp_addpm(<<'ENDPM');

=head2 write_png_best

Like write_png(), but it assumes the best PNG compression (9).

=for example

  write_png_best( $img(ndarray), $lut(ndarray), $filename )

=cut


sub write_png_best
{
    my $img = shift;
    my $lut = shift;
    my $filename = shift;
    return write_png_ex( $img, $lut, $filename, 9 );
} # End of write_png_best()...

=head2 write_true_png_best

Like write_true_png(), but it assumes the best PNG compression (9).

=for example

  write_true_png_best( $img(ndarray), $filename )

=cut


sub write_true_png_best
{
    my $img = shift;
    my $filename = shift;
    return write_true_png_ex( $img, $filename, 9 );
} # End of write_true_png_best()...

ENDPM
# End of best copression aliases
pp_add_exported( '', 'write_png_best write_true_png_best' );

#
# Function to recompress PNG files with the best compression available:
#    NOTE: libgd doesn't return anything, so there's nothing to check!
pp_addpm( '', <<'ENDPM' );
=head2 recompress_png_best( $filename )

Recompresses the given PNG file using the best compression (9).

=cut


ENDPM
pp_addxs( '', <<'ENDXS' );

void
recompress_png_best(char* filename)
    CODE:
        gdImagePtr im;
        FILE* file = fopen(filename, "rb");
        if (!file) croak("Error opening %s\n", filename);
        im = gdImageCreateFromPng(file);
        fclose(file);
        file = fopen(filename, "wb");
        if (!file) croak("Error opening %s\n", filename);
        gdImagePngEx( im, file, 9 );
        fclose(file);
        gdImageDestroy(im);

ENDXS
pp_add_exported( '', 'recompress_png_best' );
# End of recompress_png_best() XS code...

pp_addpm(<<'EOPM');
=head2 load_lut( $filename )

Loads a color look up table from an ASCII file. returns an ndarray

=cut

sub load_lut {
    xchg(byte(cat(rcols(shift))), 0, 1);
}
EOPM

pp_add_exported('', 'load_lut');

pp_def( 'read_true_png',
        Pars => '[o] img(x=CALC(gdImageSX($COMP(im))),y=CALC(gdImageSY($COMP(im))),z=3);',
        GenericTypes => ['B'],
        %gdi_from_pngfile,
        Doc => "=for ref\n\nReads a true colour PNG image into a (new) PDL variable.\n",
        Code => $gdiTrue_to_img,
);

pp_def( 'read_png',
        Pars => '[o] img(x=CALC(gdImageSX($COMP(im))),y=CALC(gdImageSY($COMP(im))));',
        GenericTypes => ['L'],
        %gdi_from_pngfile,
        Doc => "=for ref\n\nReads a (palette) PNG image into a (new) PDL variable.\n",
        Code => $gdi_to_img,
);

pp_def( '_gd_image_to_pdl_true',
        Pars => '[o] img(x=CALC(gdImageSX($COMP(im))),y=CALC(gdImageSY($COMP(im))),z=3);',
        GenericTypes => ['B'],
        %gdi_from_args,
        Doc => undef,
        Code => $gdiTrue_to_img,
);

pp_def( '_gd_image_to_rpic_true',
        Pars => '[o] img(z=3,x=CALC(gdImageSX($COMP(im))),y=CALC(gdImageSY($COMP(im))));',
        GenericTypes => ['B'],
        %gdi_from_args,
        Doc => undef,
        Code => $gdiTrue_to_img_inv,
);

pp_def( '_gd_image_to_pdl',
        Pars => '[o] img(x=CALC(gdImageSX($COMP(im))),y=CALC(gdImageSY($COMP(im))));',
        GenericTypes => ['L'],
        %gdi_from_args,
        Doc => undef,
        Code => $gdi_to_img,
);

pp_def( '_gd_image_to_rpic',
        Pars => '[o] img(x=CALC(gdImageSX($COMP(im))),y=CALC(gdImageSY($COMP(im))));',
        GenericTypes => ['L'],
        %gdi_from_args,
        Doc => undef,
        Code => $gdi_to_img_inv,
);

pp_def( '_pdl_to_gd_image_true',
        Pars => 'img(x,y,z=3); indx [o] img_ptr()',
        GenericTypes => ['B'],
        Doc => undef,
        Code => $gdiTrue_from_dims . $img_to_gdiTrue . $gdi_to_ptr,
);

pp_def( '_pdl_to_gd_image_lut',
        Pars => 'img(x,y); lut(i=3,j); indx [o] img_ptr()',
        GenericTypes => ['B'],
        Doc => undef,
        %lu_dim_check,
        Code => $gdi_from_dims . $lut_allocate . $img_to_gdi . $gdi_to_ptr,
);

pp_def( 'read_png_lut',
        Pars => '[o] lut(c=3,i=256);',
        GenericTypes => ['B'],
        %gdi_from_pngfile,
        Doc => "=for ref\n\nReads a color LUT from an already-existing palette PNG file.\n",
        Code => <<'EOC',
loop(i) %{
  $lut(c=>0) = gdImageRed($COMP(im), i);
  $lut(c=>1) = gdImageGreen($COMP(im), i);
  $lut(c=>2) = gdImageBlue($COMP(im), i);
%}
EOC
);

pp_def( 'write_gif_anim',
        Pars => 'img(c=3,x,y,n)',
        GenericTypes => ['B'],
        OtherPars => 'char* filename; int Loops; int Delay',
        OtherParsDefaults => {Loops=>0, Delay=>4},
        NoPthread => 1,
        Doc => <<'EOF',
=for ref

Writes an image cube to a file as an animated GIF.

RGB dimension is first. y=0 is at bottom. 0 loops = infinite (default).
Delay in 100ths of a second, default 4.
EOF
        Code => <<'EOF',
FILE *fh = fopen($COMP(filename), "wb");
if (!fh) $CROAK("Error opening %s\n", $COMP(filename));
gdImagePtr im = gdImageCreateTrueColor($SIZE(x), $SIZE(y)), im_prev = NULL;
if (!im) $CROAK("Error creating gdImage\n");
loop (n=0:1) %{
  loop (y,x) %{
    gdImageSetPixel(im, x, $SIZE(y)-1-y,
      gdImageColorResolve(im, $img(c=>0), $img(c=>1), $img(c=>2))
    );
  %}
%}
gdImageGifAnimBegin(im, fh, 0, $COMP(Loops));
gdImageGifAnimAdd(im, fh, 1, 0, 0, $COMP(Delay), gdDisposalNone, im_prev);
im_prev = im;
loop (n=1) %{
  im = gdImageCreateTrueColor($SIZE(x), $SIZE(y));
  if (!im) $CROAK("Error creating gdImage\n");
  loop (y,x) %{
    gdImageSetPixel(im, x, $SIZE(y)-1-y,
      gdImageColorResolve(im, $img(c=>0), $img(c=>1), $img(c=>2))
    );
  %}
  gdImageGifAnimAdd(im, fh, 1, 0, 0, $COMP(Delay), gdDisposalNone, im_prev);
  gdImageDestroy(im_prev);
  im_prev = im;
%}
gdImageDestroy(im_prev);
gdImageGifAnimEnd(fh);
fclose(fh);
EOF
);

pp_addxs( <<'ENDXS' );
void 
_gdImageDestroy( im )
                gdImagePtr              im
        CODE:
                 /* fprintf( stderr, "_gdImageDestroy(): gdImagePtr = %p (d=%d x=%x l=%ld ll=%lld)\n", im, im, im, im, im);*/ 
                 gdImageDestroy ( im );
        OUTPUT:
ENDXS


####################
# NEW OO Interface #
####################

##############################################
# Autogeneration of the low level interface: #
##############################################

##################################################
# Process functions to create images from files: #
##################################################

#########################################
# Start the PDL::IO::GD OO module code: #
#########################################
pp_addpm( { At => 'Bot' }, <<'ENDPM' );

=head1 OO INTERFACE
 
Object Oriented interface to the GD image library.

=head1 SYNOPSIS

 # Open an existing file:
 # 
 my $gd = PDL::IO::GD->new( { filename => "test.png" } );
 
 # Query the x and y sizes:
 my $x = $gd->SX();
 my $y = $gd->SY();

 # Grab the PDL of the data:
 my $pdl = $gd->to_pdl; # (x,y,3) y=0 at top

 # Grab the PDL of the data:
 my $pdl = $gd->to_rpic; # (3,x,y) y=0 at bottom

 # Kill this thing:
 $gd->DESTROY();

 # Create a new object:
 # 
 my $im = PDL::IO::GD->new( { x => 300, y => 300 } );

 # Allocate some colors:
 #
 my $black = $im->ColorAllocate( 0, 0, 0 );
 my $red = $im->ColorAllocate( 255, 0, 0 );
 my $green = $im->ColorAllocate( 0, 255, 0 );
 my $blue = $im->ColorAllocate( 0, 0, 255 );

 # Draw a rectangle:
 $im->Rectangle( 10, 10, 290, 290, $red );

 # Add some text:
 $im->String( gdFontGetLarge(), 20, 20, "Test Large Font!", $green );

 # Write the output file:
 $im->write_Png( "test2.png" );

=head1 DESCRIPTION

This is the Object-Oriented interface from PDL to the GD image library.

See L<http://www.boutell.com/gd/> for more information on the GD library and how it works.

=head2 IMPLEMENTATION NOTES

Surprisingly enough, this interface has nothing to do with the other Perl->GD interface module, 
aka 'GD' (as in 'use GD;'). This is done from scratch over the years.

Requires at least version 2.0.22 of the GD library, but it's only been thoroughly tested with
gd-2.0.33, so it would be best to use that. The 2.0.22 requirement has to do with a change in
GD's font handling functions, so if you don't use those, then don't worry about it.

I should also add, the statement about "thoroughly tested" above is mostly a joke. This OO 
interface is very young, and it has I<barely> been tested at all, so if something 
breaks, email me and I'll get it fixed ASAP (for me).

Functions that manipulate and query the image objects generally have a 'gdImage' prefix on the
function names (ex: gdImageString()). I've created aliases here for all of those member 
functions so you don't have to keep typing 'gdImage' in your code, but the long version are in 
there as well.

=head1 METHODS

=cut

use PDL;
use PDL::Slices;
use PDL::IO::Misc;

#
# Some helper functions:
#
sub _pkg_name
    { return "PDL::IO::GD::" . (shift) . "()"; }

# ID a file type from it's filename:
sub _id_image_file
{
    my $filename = shift;
    
    return 'png'
        if( $filename =~ /\.png$/ );
    
    return 'jpg'
        if( $filename =~ /\.jpe?g$/ );
    
    return 'wbmp'
        if( $filename =~ /\.w?bmp$/ );
    
    return 'gd'
        if( $filename =~ /\.gd$/ );
    
    return 'gd2'
        if( $filename =~ /\.gd2$/ );
    
    return 'gif'
        if( $filename =~ /\.gif$/ );
    
    return 'xbm'
        if( $filename =~ /\.xbm$/ );
        
    return undef;
} # End of _id_image_file()...

# Load a new file up (don't read it yet):
sub _img_ptr_from_file
{
    my $filename = shift;
    my $type = shift;
    
    return _gdImageCreateFromPng( $filename )
        if( $type eq 'png' );
    
    return _gdImageCreateFromJpeg( $filename )
        if( $type eq 'jpg' );
        
    return _gdImageCreateFromWBMP( $filename )
        if( $type eq 'wbmp' );
        
    return _gdImageCreateFromGd( $filename )
        if( $type eq 'gd' );
    
    return _gdImageCreateFromGd2( $filename )
        if( $type eq 'gd2' );
    
    return _gdImageCreateFromGif( $filename )
        if( $type eq 'gif' );
            
    return _gdImageCreateFromXbm( $filename )
        if( $type eq 'xbm' );
    
    return undef;
} # End of _img_ptr_from_file()...

# ID a file type from it's "magic" header in the image data:
sub _id_image_data 
{
    my $data = shift;
    my $magic = substr($data,0,4);
    
    return 'png'
        if( $magic eq "\x89PNG" );
    
    return 'jpg'
        if( $magic eq "\377\330\377\340" );
    return 'jpg'
        if( $magic eq "\377\330\377\341" );
    return 'jpg'
        if( $magic eq "\377\330\377\356" );
        
    return 'gif'
        if( $magic eq "GIF8" );
    
    return 'gd2'
        if( $magic eq "gd2\000" );
        
    # Still need filters for WBMP and .gd!
    
    return undef;
} # End of _id_image_data()...


# Load a new data scalar up:
sub _img_ptr_from_data
{
    my $data = shift;
    my $type = shift;
    
    return _gdImageCreateFromPngPtr( $data )
        if( $type eq 'png' );
    
    return _gdImageCreateFromJpegPtr( $data )
        if( $type eq 'jpg' );
        
    return _gdImageCreateFromWBMPPtr( $data )
        if( $type eq 'wbmp' );
        
    return _gdImageCreateFromGdPtr( $data )
        if( $type eq 'gd' );
    
    return _gdImageCreateFromGd2Ptr( $data )
        if( $type eq 'gd2' );
    
    return _gdImageCreateFromGifPtr( $data )
        if( $type eq 'gif' );
    
    return undef;
} # End of _img_ptr_from_data()...


=head2 new

Creates a new PDL::IO::GD object.

Accepts a hash describing how to create the object. Accepts a single hash ( with
curly braces ), an inline hash (the same, but without the braces) or a single
string interpreted as a filename. Thus the following are all equivalent:

 PDL::IO::GD->new( {filename => 'image.png'} );
 PDL::IO::GD->new( filename => 'image.png' );
 PDL::IO::GD->new( 'image.png' );

If the hash has:

 pdl => $pdl_var (lut => $lut_ndarray)
    Then a new GD is created from that PDL variable.

 filename => $file
    Then a new GD is created from the image file.
    
 x => $num, y => $num
    Then a new GD is created as a palette image, with size x, y
    
 x => $num, y => $num, true_color => 1
    Then a new GD is created as a true color image, with size x, y

 data => $scalar (type => $typename)
    Then a new GD is created from the file data stored in $scalar. 
    If no type is given, then it will try to guess the type of the data, but 
        this will not work for WBMP and gd image types. For those types, you 
        _must_ specify the type of the data, or the operation will fail.
    Valid types are: 'jpg', 'png', 'gif', 'gd', 'gd2', 'wbmp'.
    
Example:
 
 my $gd = PDL::IO::GD->new({ pdl => $pdl_var });
    
 my $gd = PDL::IO::GD->new({ pdl => $pdl_var, lut => $lut_ndarray });
 
 my $gd = PDL::IO::GD->new({ filename => "image.png" });
 
 my $gd = PDL::IO::GD->new({ x => 100, y => 100 });
 
 my $gd = PDL::IO::GD->new({ x => 100, y => 100, true_color => 1 });
 
 my $gd = PDL::IO::GD->new({ data => $imageData });
 
 my $gd = PDL::IO::GD->new({ data => $imageData, type => 'wbmp' });

=cut

sub new
{
    my $proto = shift;
    my $class = ref($proto) || $proto;
    #my $self  = $class->SUPER::new( @_ );
    my $self = {};
    
    my $sub = _pkg_name( "new" );
    
    # Figure out our options:

    # I want a single hash. I handle several cases here
    my $options;
    if( @_ == 1 && ref $_[0] eq 'HASH' ) {
      # single hash argument. Just take it
      $options = shift;
    }
    elsif( @_ == 1 && ! ref $_[0] ) {
      # single scalar argument. Treat it as a filename by default
      my $filename = shift;
      $options = { filename => $filename };
    }
    else {
      # the only other acceptable option is an inline hash. This is valid if I
      # have an even number of arguments, and the even-indexed ones (the keys)
      # are scalars
      if( @_ % 2 == 0 ) {
        my @pairs = @_;
        my $Npairs = scalar(@pairs)/2;

        use List::Util 'none';
        if( none { ref $pairs[2*$_] } 0..$Npairs-1 ) {
          # treat the arguments as a hash
          $options = { @pairs }
        }
      }
    }

    if( !defined $options ) {
      die <<EOF;
PDL::IO::GD::new couldn't parse its arguments.
Expected a hash-ref or an inline hash or just a filename
EOF
    }


    
    if( defined( $options->{pdl} ) )
    {   # Create it from a PDL variable:
        my $pdl = $options->{pdl};
        $pdl->make_physical();
        my $num_dims = scalar( $pdl->dims() );
        if( $num_dims == 2 )
        {
            if( defined( $options->{lut} ) )
            {
                die "$sub: _pdl_to_gd_image_lut() failed\n" unless
                  $self->{IMG_PTR} = _pdl_to_gd_image_lut( $pdl, $options->{lut} )->sclr;
            }
            else
            {
                my $lut = sequence(byte, 256)->slice("*3,:");
                die "$sub: _pdl_to_gd_image_lut() failed\n" unless
                  $self->{IMG_PTR} = _pdl_to_gd_image_lut( $pdl, $lut )->sclr;
            }
        }
        elsif( $num_dims == 3 )
        {
            die "$sub: _pdl_to_gd_image_true() failed\n" unless
              $self->{IMG_PTR} = _pdl_to_gd_image_true( $pdl )->sclr;
        }
        else
        {
            die "Can't create a PDL::IO::GD from a PDL with bad dims\n";
        }
    }
    elsif( exists( $options->{filename} ) )
    {   # Create it from a file:

        if( !defined $options->{filename} ) {
          die "PDL::IO::GD::new got an undefined filename. Giving up.\n";
        }

        # Figure out what type of file it is:
        $self->{input_type} = _id_image_file( $options->{filename} )
            or die "$sub: Can't determine image type of filename => \'$options->{filename}\'\n";
        
        # Read in the file:
        $self->{IMG_PTR} = _img_ptr_from_file( $options->{filename}, $self->{input_type} )
            or die "$sub: Can't read in the input file\n";
    }
    elsif( defined( $options->{x} ) && defined( $options->{y} ) )
    {   # Create an empty image:
        my $done = 0;
        if( $options->{true_color} )
        {   # Create an empty true color image:
            die "$sub: _gdImageCreateTrueColor() failed\n" unless
              $self->{IMG_PTR} = _gdImageCreateTrueColor( $options->{x}, $options->{y} );
            $done = 1;
        }
        unless( $done )
        {   # Create an empty palette image:
            die "$sub: _gdImageCreatePalette() failed\n" unless
              $self->{IMG_PTR} = _gdImageCreatePalette( $options->{x}, $options->{y} );
        }
    }
    elsif( defined( $options->{data} ) )
    {   # Create an image from the given image data:
    
        # Figure out what type of file it is:
        if( defined( $options->{type} ) && 
            (      $options->{type} eq 'jpg'
                || $options->{type} eq 'png'
                || $options->{type} eq 'gif'
                || $options->{type} eq 'wbmp'
                || $options->{type} eq 'gd'
                || $options->{type} eq 'gd2' ) )
        {
            $self->{input_type} = $options->{type};
        }
        else
        {
            $self->{input_type} = _id_image_data( $options->{data} )
                or die "$sub: Can't determine image type given data\n";
        }
        
        # Load the data:
        $self->{IMG_PTR} = _img_ptr_from_data( $options->{data}, $self->{input_type} )
            or die "$sub: Can't load the input image data\n";
    }
    
    # Bless and return:
    #
    bless ($self, $class);    
    return $self;
} # End of new()...

=head2 to_pdl

When you're done playing with your GDImage and want an ndarray back, use this function to return one.
For true-colour, RGB dim is highest (x,y,3).
To get it in the lowest dim (and with y=0 is the bottom), use L</to_rpic>.

=cut

sub to_pdl {
    my $self = shift;
    $self->gdImageTrueColor() ? _gd_image_to_pdl_true( $self->{IMG_PTR} )
      : _gd_image_to_pdl( $self->{IMG_PTR} );
}

=head2 to_rpic

When you're done playing with your GDImage and want an ndarray back, use this function to return one.
For true-colour, RGB dim is lowest (3,x,y).
To get it in the highest dim (and with y=0 is the top), use L</to_pdl>.

=cut

sub to_rpic {
    my $self = shift;
    $self->gdImageTrueColor() ? _gd_image_to_rpic_true( $self->{IMG_PTR} )
      : _gd_image_to_rpic( $self->{IMG_PTR} );
}

=head2 apply_lut( $lut(ndarray) )

Does a $im->ColorAllocate() for an entire LUT ndarray at once.

The LUT ndarray format is the same as for the general interface above.

=cut


sub apply_lut
{
    my $self = shift;
    my $lut = shift;
    
    # Let the PDL broadcasting engine sort this out:
    $self->ColorAllocates( $lut->slice("(0),:"), $lut->slice("(1),:"), $lut->slice("(2),:") );
} # End of apply_lut()...

sub DESTROY
{
    my $self = shift;
    my $sub = _pkg_name( "DESTROY" );
 
    #print STDERR sprintf("$sub: destroying gdImagePtr: 0x%p (%d) (%ld) (%lld)\n", $self->{IMG_PTR}, $self->{IMG_PTR},$self->{IMG_PTR},$self->{IMG_PTR});
    
    if( defined( $self->{IMG_PTR} ) )
    {
        _gdImageDestroy( $self->{IMG_PTR} );
        delete( $self->{IMG_PTR} );
    }
} # End of DESTROY()...

=head2 WARNING:

All of the docs below this point are auto-generated (not to mention the actual code), 
so read with a grain of salt, and B<always> check the main GD documentation about how 
that function works and what it does.

=cut

ENDPM

generate_create_functions( <<'ENDCREATE' );
gdImagePtr gdImageCreateFromPng (FILE * fd);
gdImagePtr gdImageCreateFromWBMP (FILE * inFile);
gdImagePtr gdImageCreateFromJpeg (FILE * infile);
gdImagePtr gdImageCreateFromGd (FILE * in);
gdImagePtr gdImageCreateFromGd2 (FILE * in);
gdImagePtr gdImageCreateFromXbm (FILE * in);
gdImagePtr gdImageCreateFromGif (FILE * fd);
gdImagePtr gdImageCreate (int sx, int sy);
gdImagePtr gdImageCreatePalette (int sx, int sy);
gdImagePtr gdImageCreateTrueColor (int sx, int sy);
ENDCREATE

generate_create_from_data_functions( <<'ENDCDATA' );
gdImagePtr gdImageCreateFromPngPtr  (int size, void * data);
gdImagePtr gdImageCreateFromWBMPPtr (int size, void * data);
gdImagePtr gdImageCreateFromJpegPtr (int size, void * data);
gdImagePtr gdImageCreateFromGdPtr   (int size, void * data);
gdImagePtr gdImageCreateFromGd2Ptr  (int size, void * data);
gdImagePtr gdImageCreateFromGifPtr  (int size, void * data);
ENDCDATA


generate_write_functions( <<'ENDWRITE' );
void gdImagePng (gdImagePtr im, FILE * out);
void gdImagePngEx (gdImagePtr im, FILE * out, int level);
void gdImageWBMP (gdImagePtr image, int fg, FILE * out);
void gdImageJpeg (gdImagePtr im, FILE * out, int quality);
void gdImageGd (gdImagePtr im, FILE * out);
void gdImageGd2 (gdImagePtr im, FILE * out, int cs, int fmt);
void gdImageGif (gdImagePtr im, FILE * out);
ENDWRITE


generate_data_ptr_functions( <<'ENDDATAPTR' );
void *gdImagePngPtr (gdImagePtr im, int *size);
void *gdImagePngPtrEx (gdImagePtr im, int *size, int level);
void *gdImageWBMPPtr (gdImagePtr im, int *size, int fg);
void *gdImageJpegPtr (gdImagePtr im, int *size, int quality);
void *gdImageGdPtr (gdImagePtr im, int *size);
void *gdImageGd2Ptr (gdImagePtr im, int cs, int fmt, int *size);
ENDDATAPTR


#void gdImageDestroy (gdImagePtr im);
generate_member_functions( <<'ENDMEMBERS' );
void gdImageSetPixel (gdImagePtr im, int x, int y, int color);
int gdImageGetPixel (gdImagePtr im, int x, int y);
void gdImageAABlend (gdImagePtr im);
void gdImageLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color);
void gdImageDashedLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color);
void gdImageRectangle (gdImagePtr im, int x1, int y1, int x2, int y2, int color);
void gdImageFilledRectangle (gdImagePtr im, int x1, int y1, int x2, int y2, int color);
void gdImageSetClip(gdImagePtr im, int x1, int y1, int x2, int y2);
void gdImageGetClip(gdImagePtr im, int *x1P, int *y1P, int *x2P, int *y2P);
int gdImageBoundsSafe (gdImagePtr im, int x, int y);
void gdImageChar (gdImagePtr im, gdFontPtr f, int x, int y, int c, int color);
void gdImageCharUp (gdImagePtr im, gdFontPtr f, int x, int y, int c, int color);
void gdImageString (gdImagePtr im, gdFontPtr f, int x, int y, unsigned char *s, int color);
void gdImageStringUp (gdImagePtr im, gdFontPtr f, int x, int y, unsigned char *s, int color);
void gdImageString16 (gdImagePtr im, gdFontPtr f, int x, int y, unsigned short *s, int color);
void gdImageStringUp16 (gdImagePtr im, gdFontPtr f, int x, int y, unsigned short *s, int color);
void gdImagePolygon (gdImagePtr im, gdPointPtr p, int n, int c);
void gdImageFilledPolygon (gdImagePtr im, gdPointPtr p, int n, int c);
int gdImageColorAllocate (gdImagePtr im, int r, int g, int b);
int gdImageColorAllocateAlpha (gdImagePtr im, int r, int g, int b, int a);
int gdImageColorClosest (gdImagePtr im, int r, int g, int b);
int gdImageColorClosestAlpha (gdImagePtr im, int r, int g, int b, int a);
int gdImageColorClosestHWB (gdImagePtr im, int r, int g, int b);
int gdImageColorExact (gdImagePtr im, int r, int g, int b);
int gdImageColorExactAlpha (gdImagePtr im, int r, int g, int b, int a);
int gdImageColorResolve (gdImagePtr im, int r, int g, int b);
int gdImageColorResolveAlpha (gdImagePtr im, int r, int g, int b, int a);
void gdImageColorDeallocate (gdImagePtr im, int color);
void gdImageTrueColorToPalette (gdImagePtr im, int ditherFlag, int colorsWanted);
void gdImageColorTransparent (gdImagePtr im, int color);
void gdImageFilledArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e, int color, int style);
void gdImageArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e, int color);
void gdImageFilledEllipse (gdImagePtr im, int cx, int cy, int w, int h, int color);
void gdImageFillToBorder (gdImagePtr im, int x, int y, int border, int color);
void gdImageFill (gdImagePtr im, int x, int y, int color);
void gdImageCopyRotated (gdImagePtr dst, gdImagePtr src, double dstX, double dstY, int srcX, int srcY, int srcWidth, int srcHeight, int angle);
void gdImageSetBrush (gdImagePtr im, gdImagePtr brush);
void gdImageSetTile (gdImagePtr im, gdImagePtr tile);
void gdImageSetAntiAliased (gdImagePtr im, int c);
void gdImageSetAntiAliasedDontBlend (gdImagePtr im, int c, int dont_blend);
void gdImageSetStyle (gdImagePtr im, int *style, int noOfPixels);
void gdImageSetThickness (gdImagePtr im, int thickness);
void gdImageInterlace (gdImagePtr im, int interlaceArg);
void gdImageAlphaBlending (gdImagePtr im, int alphaBlendingArg);
void gdImageSaveAlpha (gdImagePtr im, int saveAlphaArg);
int gdImageTrueColor (gdImagePtr im);
int gdImageColorsTotal (gdImagePtr im);
int gdImageRed (gdImagePtr im, int c);
int gdImageGreen (gdImagePtr im, int c);
int gdImageBlue (gdImagePtr im, int c);
int gdImageAlpha (gdImagePtr im, int c);
int gdImageGetTransparent (gdImagePtr im);
int gdImageGetInterlaced (gdImagePtr im);
int gdImageSX (gdImagePtr im);
int gdImageSY (gdImagePtr im);
ENDMEMBERS
#char* gdImageStringTTF (gdImagePtr im, int *brect, int fg, char *fontlist, double ptsize, double angle, int x, int y, char *string);
#char* gdImageStringFT (gdImagePtr im, int *brect, int fg, char *fontlist, double ptsize, double angle, int x, int y, char *string);
#ENDMEMBERS

# Allow operation on these member function on ndarrays as well:
#int gdImageGetPixel (gdImagePtr im, int x, int y);
generate_pp_def_members( <<'ENDMEMBERS' );
int gdImageColorAllocate (gdImagePtr im, int r, int g, int b);
int gdImageColorAllocateAlpha (gdImagePtr im, int r, int g, int b, int a);
void gdImageSetPixel (gdImagePtr im, int x, int y, int color);
void gdImageLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color);
void gdImageDashedLine (gdImagePtr im, int x1, int y1, int x2, int y2, int color);
void gdImageRectangle (gdImagePtr im, int x1, int y1, int x2, int y2, int color);
void gdImageFilledRectangle (gdImagePtr im, int x1, int y1, int x2, int y2, int color);
void gdImageFilledArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e, int color, int style);
void gdImageArc (gdImagePtr im, int cx, int cy, int w, int h, int s, int e, int color);
void gdImageFilledEllipse (gdImagePtr im, int cx, int cy, int w, int h, int color);
ENDMEMBERS

generate_class_functions( <<'ENDCLASS' );
void gdImageCopy (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX, int srcY, int w, int h);
void gdImageCopyMerge (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX, int srcY, int w, int h, int pct);
void gdImageCopyMergeGray (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX, int srcY, int w, int h, int pct);
void gdImageCopyResized (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX, int srcY, int dstW, int dstH, int srcW, int srcH);
void gdImageCopyResampled (gdImagePtr dst, gdImagePtr src, int dstX, int dstY, int srcX, int srcY, int dstW, int dstH, int srcW, int srcH);
int gdImageCompare (gdImagePtr im1, gdImagePtr im2);
void gdImagePaletteCopy (gdImagePtr dst, gdImagePtr src);
ENDCLASS

generate_general_functions( <<'ENDGENERAL' );
int gdAlphaBlend (int dest, int src);
int gdTrueColor (int r, int g, int b);
int gdTrueColorAlpha (int r, int g, int b, int a);
void gdFree (void *m);
gdFontPtr gdFontGetLarge ( );
gdFontPtr gdFontGetSmall ( );
gdFontPtr gdFontGetMediumBold ( );
gdFontPtr gdFontGetGiant ( );
gdFontPtr gdFontGetTiny ( );
ENDGENERAL

#
# Keep these in here for later:
#
my $unused_funcs = <<'ENDUNUSED';
# These have disappeared in later versions of GD:
void gdFreeFontCache ();
void gdImageEllipse (gdImagePtr im, int cx, int cy, int w, int h, int color);
BGD_DECLARE(gdImagePtr) gdImageCreateFromGifPtr (int size, void *data);
BGD_DECLARE(gdImagePtr) gdImageCreateFromGifCtx (gdIOCtxPtr in);
void gdImagePngCtx (gdImagePtr im, gdIOCtx * out);
void gdImagePngCtxEx (gdImagePtr im, gdIOCtx * out, int level);
void gdImageWBMPCtx (gdImagePtr image, int fg, gdIOCtx * out);
void gdImageJpegCtx (gdImagePtr im, gdIOCtx * out, int quality);
void gdImagePngToSink (gdImagePtr im, gdSinkPtr out);
gdIOCtx *gdNewFileCtx (FILE *);
gdIOCtx *gdNewDynamicCtx (int, void *);
gdIOCtx *gdNewSSCtx (gdSourcePtr in, gdSinkPtr out);
void *gdDPExtractData (struct gdIOCtx *ctx, int *size);
gdImagePtr gdImageCreateFromPngSource (gdSourcePtr in);
gdImagePtr gdImageCreateFromGd2Part (FILE * in, int srcx, int srcy, int w, int h);
char* gdImageStringFTEx (gdImage * im, int *brect, int fg, char *fontlist, double ptsize, double angle, int x, int y, char *string, gdFTStringExtraPtr strex);
ENDUNUSED

# Add functions that the code gen doesn't handle properly:
#
#char* gdImageStringTTF (gdImagePtr im, int *brect, int fg, char *fontlist, double ptsize, double angle, int x, int y, char *string);
pp_addxs( <<"ENDXS" );
char*
_gdImageStringTTF( im, brect, fg, fontlist, ptsize, angle, x, y, string )
		gdImagePtr		im
		int *		brect
		int		fg
		char *		fontlist
		double		ptsize
		double		angle
		int		x
		int		y
		char *		string
	CODE:
		int c_brect[8];
		RETVAL = gdImageStringTTF ( im, c_brect, fg, fontlist, ptsize, angle, x, y, string );
                brect = c_brect;
	OUTPUT:
		RETVAL
		brect
ENDXS

pp_addpm( { At => 'Bot' }, <<'ENDPM' );
=head2 StringTTF

$image->StringTTF( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string )

Alias for gdImageStringTTF.

=cut


sub StringTTF
{
    return gdImageStringTTF ( @_ );
} # End of StringTTF()...


=head2 gdImageStringTTF

$image->gdImageStringTTF( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string )

=cut


sub gdImageStringTTF
{
    my $self = shift;
    return _gdImageStringTTF ( $self->{IMG_PTR}, @_ );
} # End of gdImageStringTTF()...
ENDPM


#char* gdImageStringFT (gdImagePtr im, int *brect, int fg, char *fontlist, double ptsize, double angle, int x, int y, char *string);=
pp_addxs(<<"ENDXS");
char*
_gdImageStringFT( im, brect, fg, fontlist, ptsize, angle, x, y, string )
		gdImagePtr		im
		int *		brect
		int		fg
		char *		fontlist
		double		ptsize
		double		angle
		int		x
		int		y
		char *		string
	CODE:
		int c_brect[8];
		RETVAL = gdImageStringFT ( im, c_brect, fg, fontlist, ptsize, angle, x, y, string );
		brect = c_brect;
	OUTPUT:
		RETVAL
		brect
ENDXS

pp_addpm({At => 'Bot'}, <<'ENDPM' );
=head2 StringFT

$image->StringFT( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string )

Alias for gdImageStringFT.

=cut


sub StringFT
{
    return gdImageStringFT ( @_ );
} # End of StringFT()...


=head2 gdImageStringFT

$image->gdImageStringFT( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string )

=cut


sub gdImageStringFT
{
    my $self = shift;
    return _gdImageStringFT ( $self->{IMG_PTR}, @_ );
} # End of gdImageStringFT()...
ENDPM

# Add the final docs:
#
pp_addpm({At => 'Bot'}, <<'ENDPM');

=head1 AUTHOR

Judd Taylor, Orbital Systems, Ltd.
judd dot t at orbitalsystems dot com

=cut

ENDPM

pp_done();

#########
# SUBS: #
#########

use Data::Dumper;

#
# Member functions to create a new object (or populate it from data):
#
sub generate_create_functions
{
    my @funcs = split( /\n/, shift );
    my $sub = "generate_create_functions()";
    
    foreach my $func ( @funcs )
    {
        #print "$sub: Generating read function for $func...\n";
    
        my $info = parse_prototype( $func )
            or die "$sub: Couldn't parse prototype\n";
         
        # If it wants a FILE*, we need to do something different in the XS code:   
        if( $info->{ARGS}->{1}->{TYPE} =~ /FILE\s*\*/ )
        {
            my $function_name = $info->{NAME};
            my $return_type = $info->{RETURN_TYPE};
        
            pp_addxs(<<"ENDXS");
$return_type
_$function_name( char* filename )
    CODE:
        FILE *file = fopen( filename, "rb");
        if (!file) croak("Error opening %s\\n", filename);
        RETVAL = $function_name( file );
        fclose(file);
    OUTPUT:
        RETVAL
ENDXS
        }
        # Otherwise, it should be pretty easy:
        else
        {
            add_basic_xs( $info, '_' );
        }
    }
} # End of generate_create_functions()...


#
# Member functions to create a new object from a data scalar:
#
# gdImagePtr gdImageCreateFromPngPtr  (int size, void * data);
#
sub generate_create_from_data_functions
{
    my @funcs = split( /\n/, shift );
    my $sub = "generate_create_from_data_functions()";
    
    foreach my $func ( @funcs )
    {
        #print "$sub: Generating read function for $func...\n";
    
        my $info = parse_prototype( $func )
            or die "$sub: Couldn't parse prototype\n";
        
        my $function_name = $info->{NAME};
        my $return_type = $info->{RETURN_TYPE};
         
        pp_addxs(<<"ENDXS");
$return_type
_$function_name( imageData )
        SV *    imageData
    PREINIT:
        char*   data;
        STRLEN  len;
    CODE:
        data = SvPV( imageData, len );
        RETVAL = $function_name( len, (void*)data );
    OUTPUT:
        RETVAL
        
ENDXS
    }
} # End of generate_create_from_data_functions()...



#void gdImagePng (gdImagePtr im, FILE * out);
#void gdImageWBMP (gdImagePtr image, int fg, FILE * out);
sub generate_write_functions
{
    my @funcs = split( /\n/, shift );
    my $sub = "generate_write_functions()";
    
    foreach my $func ( @funcs )
    {
        #print "$sub: Generating write function for $func...\n";
    
        my $info = parse_prototype( $func )
            or die "$sub: Couldn't parse prototype\n";
        
        my $function_name = $info->{NAME};
        my $return_type = $info->{RETURN_TYPE};
        
        my @arg_names = ();
        my @call_args = ();
        my $arg_decl_string = "";
        foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } )
        {
            my $type = $info->{ARGS}->{$num}->{TYPE};
            my $name = $info->{ARGS}->{$num}->{NAME};
            if( $type =~ /FILE/ )
            {
                push( @arg_names, "filename" );
                push( @call_args, "file" );
                $arg_decl_string.= "\t\tchar *\t\tfilename\n";
                next;
            }
            push(@arg_names, $name );
            push(@call_args, $name );
            $arg_decl_string .= "\t\t$type\t\t$name\n";
        }
        my $arg_list = join(", ", @arg_names);
        my $call_arg_list = join(", ", @call_args);
        
        pp_addxs(<<"ENDXS");
$return_type
_$function_name ( $arg_list )
$arg_decl_string
    CODE:
        FILE *file = fopen( filename, "wb");
        if (!file) croak("Error opening %s\\n", filename);
        $function_name ( $call_arg_list );
        fclose( file );
ENDXS
        
        # Add the OO code:
        #
        
        # Use template method here to avoid escaping everything:
        my $pmcode = <<'ENDPM';
=head2 INSERT_NAME_HERE

$image->INSERT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE )

=cut


sub INSERT_NAME_HERE
{
    my $self = shift;
    return INSERT_XS_FUNC_HERE ( $self->{IMG_PTR}, @_ );
} # End of INSERT_NAME_HERE()...
ENDPM
        my $name = "write_" . $function_name;
        $name =~ s/gdimage//;
        $name =~ s/gdImage//;
        $pmcode =~ s/INSERT_NAME_HERE/$name/sg;
        $pmcode =~ s/INSERT_XS_FUNC_HERE/_$function_name/sg;
        
        my @arg_names2;
        my @doc_args;
        foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } )
        { 
            next if ( $info->{ARGS}->{$num}->{TYPE} eq 'gdImagePtr' );
            
            if( $info->{ARGS}->{$num}->{TYPE} =~ /FILE/ )
            {
                push( @arg_names2, "filename" );
                push(@doc_args, "\$filename" );
                next;
            }
            push(@arg_names2, $info->{ARGS}->{$num}->{NAME}); 
            push(@doc_args, "\$" . $info->{ARGS}->{$num}->{NAME} );
        }
        my $arg_list2 = join( ", ", @arg_names2 );
        $pmcode =~ s/INSERT_ARG_LIST_HERE/$arg_list2/sg;
        
        my $doc_arg_list = join( ", ", @doc_args );
        $pmcode =~ s/INSERT_DOC_ARG_LIST_HERE/$doc_arg_list/sg;
        
        pp_addpm( { At => 'Bot' }, $pmcode );
    }
}  # End of generate_write_functions()...

#
# The functions allow you to get a pointer to a formatted region of memory
#   that contains image data in the specified format. This is useful, among
#   other things, because PerlQt has almost no other way to import any image
#   data from PDL!
#
#void *gdImageWBMPPtr (gdImagePtr im, int *size, int fg);
#void *gdImageJpegPtr (gdImagePtr im, int *size, int quality);
#void *gdImagePngPtr (gdImagePtr im, int *size);
#void *gdImageGdPtr (gdImagePtr im, int *size);
#void *gdImageGd2Ptr (gdImagePtr im, int cs, int fmt, int *size);
#void *gdImagePngPtrEx (gdImagePtr im, int *size, int level);
#
sub generate_data_ptr_functions
{
    my @funcs = split( /\n/, shift );
    my $sub = "generate_data_ptr_functions()";
    
    foreach my $func ( @funcs )
    {
        #print "$sub: Generating data_ptr function for $func...\n";
        my $info = parse_prototype( $func )
            or die "$sub: Couldn't parse prototype\n";
        
        #use Data::Dumper;
        #print Data::Dumper->Dump([$info], ['info']);
            
        my $function_name = $info->{NAME};
        my $return_type = $info->{RETURN_TYPE};
        
        my @arg_names = ();
        my @call_args = ();
        my $arg_decl_string = "";
        foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } )
        {
            my $type = $info->{ARGS}->{$num}->{TYPE};
            my $name = $info->{ARGS}->{$num}->{NAME};
            
            if( $name =~ /size/ )
            {
                push( @call_args, "\&$name" );
                next;
            }
            
            push(@arg_names, $name );
            push(@call_args, $name );
            $arg_decl_string .= "\t\t$type\t\t$name\n";
        }
        my $arg_list = join(", ", @arg_names);
        my $call_arg_list = join(", ", @call_args);
        
        # Add the low level functions we'll need:
        #
        pp_addxs(<<"ENDXS");
SV *
_$function_name( $arg_list )
$arg_decl_string
    CODE:
        char* imdata;
        int size;
        imdata = (char *)$function_name( $call_arg_list );
        RETVAL = newSVpv( imdata, size );
        gdFree( imdata );
    OUTPUT:
        RETVAL
ENDXS

        # Add the object code for this function:
        #
        # Use template method here to avoid escaping everything:
        my $pmcode = <<'ENDPM';
=head2 INSERT_NAME_HERE

$image->INSERT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE )

=cut


sub INSERT_NAME_HERE
{
    my $self = shift;
    return INSERT_XS_FUNC_HERE ( $self->{IMG_PTR}, @_ );
} # End of INSERT_NAME_HERE()...
ENDPM

        my $format = $function_name;
        $format =~ s/gdImage//;
        $format =~ s/Ptr//;
        my $name = "get_$format" . "_data";
        
        $pmcode =~ s/INSERT_NAME_HERE/$name/sg;
        $pmcode =~ s/INSERT_XS_FUNC_HERE/_$function_name/sg;
        
        my @arg_names2;
        my @doc_args;
        foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } )
        { 
            next if ( $info->{ARGS}->{$num}->{TYPE} eq 'gdImagePtr' );
            next if ( $info->{ARGS}->{$num}->{NAME} eq 'size' );
            push(@arg_names2, $info->{ARGS}->{$num}->{NAME}); 
            push(@doc_args, "\$" . $info->{ARGS}->{$num}->{NAME} );
        }
        my $arg_list2 = join( ", ", @arg_names2 );
        $pmcode =~ s/INSERT_ARG_LIST_HERE/$arg_list2/sg;
        
        my $doc_arg_list = join( ", ", @doc_args );
        $pmcode =~ s/INSERT_DOC_ARG_LIST_HERE/$doc_arg_list/sg;
        
        pp_addpm( { At => 'Bot' }, $pmcode );
    } # foreach func...

} # End of generate_data_ptr_functions()...



#
# Here, we also need to add PM code for the OO side:
#
sub generate_member_functions
{
    my @funcs = split( /\n/, shift );
    my $sub = "generate_member_functions()";
    
    foreach my $func ( @funcs )
    {
        #print "$sub: Generating member function for $func...\n";
    
        my $info = parse_prototype( $func )
            or die "$sub: Couldn't parse prototype\n";
        
        # Add the XS portion of the code:
        my @macro_list = qw(
            gdImageSX
            gdImageSY
            gdImageTrueColor
        );
        if( scalar( grep( /$info->{NAME}/, @macro_list ) ) )
        {   # Special functions that are actually definitions:
            add_basic_def_xs( $info, '_' );
        }
        else
        {   # Normal function
            add_basic_xs( $info, '_' );
        }
        
        # Add the OO code:
        
        # Use template method here to avoid escaping everything:
        my $pmcode = <<'ENDPM';
INSERT_SHORT_CODE_HERE

=head2 INSERT_NAME_HERE

$image->INSERT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE )

=cut


sub INSERT_NAME_HERE
{
    my $self = shift;
    return INSERT_XS_FUNC_HERE ( $self->{IMG_PTR}, @_ );
} # End of INSERT_NAME_HERE()...
ENDPM

        my $short_code_template = <<'ENDSHORTCODE';
=head2 INSERT_SHORT_NAME_HERE

$image->INSERT_SHORT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE )

Alias for INSERT_NAME_HERE.

=cut


sub INSERT_SHORT_NAME_HERE
{
    return INSERT_NAME_HERE ( @_ );
} # End of INSERT_SHORT_NAME_HERE()...
ENDSHORTCODE

        my $name = $info->{NAME};
        my $short_name = $name;
        $short_name =~ s/gdImage//;
        my $short_code = '';
        if( $short_name ne $name )
        {
            $short_code = $short_code_template;
            $short_code =~ s/INSERT_SHORT_NAME_HERE/$short_name/sg;
        }
        $pmcode =~ s/INSERT_SHORT_CODE_HERE/$short_code/sg;
        
        $pmcode =~ s/INSERT_NAME_HERE/$name/sg;
        $pmcode =~ s/INSERT_XS_FUNC_HERE/_$name/sg;
        
        my @arg_names;
        my @doc_args;
        foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } )
        { 
            next if ( $info->{ARGS}->{$num}->{TYPE} eq 'gdImagePtr' );
            push(@arg_names, $info->{ARGS}->{$num}->{NAME}); 
            push( @doc_args, "\$" . $info->{ARGS}->{$num}->{NAME} );
        }
        my $arg_list = join( ", ", @arg_names );
        $pmcode =~ s/INSERT_ARG_LIST_HERE/$arg_list/sg;
        my $doc_arg_list = join( ", ", @doc_args );
        $pmcode =~ s/INSERT_DOC_ARG_LIST_HERE/$doc_arg_list/sg;
        
        pp_addpm( { At => 'Bot' }, $pmcode );
    }
} # End of generate_member_functions()...

#
# Add some member functions that can function on ndarrays:
#
sub generate_pp_def_members
{
    my @funcs = split( /\n/, shift );
    my $sub = "generate_pp_def_members()";
    
    foreach my $func ( @funcs )
    {
        #print "$sub: Generating member function for $func...\n";
    
        my $info = parse_prototype( $func )
            or die "$sub: Couldn't parse prototype\n";
        
        my $orig_name = $info->{NAME};
        my $name = $orig_name . "s";
        my $short_name = $name;
        $short_name =~ s/gdImage//;
        my $pdlpp_name = "_$name";
        
        my @arg_names;
        my @doc_args;
        my $pdlpp_arg_list = "";
        foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } )
        { 
            my $type = $info->{ARGS}->{$num}->{TYPE};
            my $arg_name = $info->{ARGS}->{$num}->{NAME};
            next if ( $type eq 'gdImagePtr' );
            push(@arg_names, $arg_name ); 
            push( @doc_args, "\$" . $arg_name . "(pdl)" );
            $pdlpp_arg_list .= "$type $arg_name(); ";
        }
        my $arg_list = join( ", ", @arg_names );
        my $doc_arg_list = join( ", ", @doc_args );
        my $pdlpp_call_arg_list = "\$" . join( "(), \$", @arg_names ) . "()";
        
        # Add the PDL::PP code:
        #
        pp_def( $pdlpp_name,
            Pars => $pdlpp_arg_list,
            GenericTypes => ['B'],
            OtherPars => 'gdImagePtr img_ptr',
            Doc => undef,
            Code => "$orig_name( \$COMP(img_ptr), $pdlpp_call_arg_list );" );

        # Add the OO code:
        
        # Use template method here to avoid escaping everything:
        my $pmcode = <<'ENDPM';
INSERT_SHORT_CODE_HERE

=head2 INSERT_NAME_HERE

$image->INSERT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE )

=cut


sub INSERT_NAME_HERE
{
    my $self = shift;
    return INSERT_PP_FUNC_HERE ( @_, $self->{IMG_PTR} );
} # End of INSERT_NAME_HERE()...
ENDPM

        my $short_code_template = <<'ENDSHORTCODE';
=head2 INSERT_SHORT_NAME_HERE

$image->INSERT_SHORT_NAME_HERE( INSERT_DOC_ARG_LIST_HERE )

Alias for INSERT_NAME_HERE.

=cut


sub INSERT_SHORT_NAME_HERE
{
    return INSERT_NAME_HERE ( @_ );
} # End of INSERT_SHORT_NAME_HERE()...
ENDSHORTCODE

        my $short_code = '';
        if( $short_name ne $name )
        {
            $short_code = $short_code_template;
            $short_code =~ s/INSERT_SHORT_NAME_HERE/$short_name/sg;
        }
        $pmcode =~ s/INSERT_SHORT_CODE_HERE/$short_code/sg;
        
        $pmcode =~ s/INSERT_NAME_HERE/$name/sg;
        $pmcode =~ s/INSERT_PP_FUNC_HERE/$pdlpp_name/sg;
        
       
        $pmcode =~ s/INSERT_ARG_LIST_HERE/$arg_list/sg;
        
        $pmcode =~ s/INSERT_DOC_ARG_LIST_HERE/$doc_arg_list/sg;
        
        pp_addpm( { At => 'Bot' }, $pmcode );
    }
} # End of generate_pp_def_members...

#
# Functions not specific to one object, but that need to take objects as arguments:
#
sub generate_class_functions
{
    my @funcs = split( /\n/, shift );
    my $sub = "generate_class_functions()";
    
    pp_addpm( {At => 'Bot'}, <<'ENDPM' );
=head1 CLASS FUNCTIONS

=cut


ENDPM
    
    foreach my $func ( @funcs )
    {
        #print "$sub: Generating class function for $func...\n";
    
        my $info = parse_prototype( $func )
            or die "$sub: Couldn't parse prototype\n";

        # Add the XS portion of the code:
        add_basic_xs( $info, '_' );
        
        # Add the Class functions code:
        
        # Figure out the perl arg list where it needs PDL::IO::GDImage objects:
        #
        my @perl_arg_names;
        my @arg_names;
        my @doc_args;
        my $arg_shift_string = "";
        foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } )
        { 
            my $type = $info->{ARGS}->{$num}->{TYPE};
            my $name = $info->{ARGS}->{$num}->{NAME};
            
            push(@arg_names, $name);
            $arg_shift_string .= "    my \$$name = shift;\n";
            
            if ( $type eq 'gdImagePtr' )
            {
                push(@perl_arg_names, "\$" . $name . "->{IMG_PTR}" );
                push(@doc_args, "\$" . $name . "(PDL::IO::GD)" );
                next;
            }
            push(@doc_args, "\$" . $name);
            push(@perl_arg_names, "\$" . $name);
        }
        
        # Use template method here to avoid escaping everything:
        my $pmcode = <<'ENDPM';
=head2 INSERT_NAME_HERE

INSERT_NAME_HERE ( INSERT_DOC_ARG_LIST_HERE )

=cut


sub INSERT_NAME_HERE
{
INSERT_ARG_SHIFT_HERE
    return INSERT_XS_FUNC_HERE ( INSERT_PERL_ARG_LIST_HERE );
} # End of INSERT_NAME_HERE()...
ENDPM
        my $function_name = $info->{NAME};
        $pmcode =~ s/INSERT_NAME_HERE/$function_name/sg;
        $pmcode =~ s/INSERT_XS_FUNC_HERE/_$function_name/sg;
        $pmcode =~ s/INSERT_ARG_SHIFT_HERE/$arg_shift_string/sg;
        
        my $perl_arg_list = join(", ", @perl_arg_names);
        $pmcode =~ s/INSERT_PERL_ARG_LIST_HERE/$perl_arg_list/sg;
        
        my $doc_arg_list = join( ", ", @doc_args );
        $pmcode =~ s/INSERT_DOC_ARG_LIST_HERE/$doc_arg_list/sg;
        
        pp_addpm( { At => 'Bot' }, $pmcode );
    }

} # End of generate_class_functions()...

# 
# These functions are not specific to and object instance:
#
sub generate_general_functions
{
    my @funcs = split( /\n/, shift );
    my $sub = "generate_general_functions()";
    
    foreach my $func ( @funcs )
    {
        #print "$sub: Generating general function for $func...\n";
    
        my $info = parse_prototype( $func )
            or die "$sub: Couldn't parse prototype\n";

        # Add the XS portion of the code:
        my @macro_list = qw(
            gdTrueColor
            gdTrueColorAlpha
        );
        
        if( scalar( grep( /$info->{NAME}/, @macro_list ) ) )
        {   # Special functions that are actually definitions:
            add_basic_def_xs( $info );
        }
        else
        {   # Normal function
            add_basic_xs( $info );
        }
        
        pp_add_exported(" $info->{NAME} ");
    }
} # End of generate_general_functions()...

sub add_basic_xs
{
    my $info = shift;
    my $prefix = shift || '';
    
    my $return_type = $info->{RETURN_TYPE};
    
    my $orig_name = $info->{NAME};
    my $name = $prefix . $orig_name;
    my @arg_names;
    my @arg_call_names;
    my @out_arg_names;
    my $arg_decl_string = "";
    foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } )
    {
        my $name = $info->{ARGS}{$num}{NAME};
        my $type = $info->{ARGS}{$num}{TYPE};
        
        # Handle perl's handling of pointers:
        my $call_name = $name;
        if( $type =~ /((\S+\s*?)+)\s*\*/ 
            && $type !~ /void/ 
            && $type !~ /char/ )
        {
            $type = $1;
            $call_name = "&$name";
            push( @out_arg_names, $name );
        }
        
        push(@arg_names, $name );
        push(@arg_call_names, $call_name );
        $arg_decl_string .= "\t\t$type\t\t$name\n";
    }
    chomp( $arg_decl_string );
    my $arg_string = join(", ", @arg_names );
    
    my $arg_call_string = join(", ", @arg_call_names);
    
    my $retval_output = "\t\tRETVAL\n";
    my $retval_input = "RETVAL =";
    if( $return_type =~ /void/ )
    {
        $retval_output = '';
        $retval_input = '';
    }
    
    my $arg_output_string = $retval_output . "\t\t" . join("\n\t\t", @out_arg_names);
    
    pp_addxs( <<"ENDXS" );
$return_type
$name( $arg_string )
$arg_decl_string
\tCODE:
\t\t$retval_input $orig_name ( $arg_call_string );
\tOUTPUT:
$arg_output_string
ENDXS
} # End of add_basic_xs()...

sub add_basic_def_xs
{
    my $info = shift;
    my $prefix = shift || '';
    
    my $return_type = $info->{RETURN_TYPE};
    my $orig_name = $info->{NAME};
    my $name = $prefix . $orig_name;
    my @arg_names;
    my $arg_decl_string = "";
    foreach my $num ( sort {$a <=> $b} keys %{ $info->{ARGS} } )
    {
        my $name = $info->{ARGS}->{$num}->{NAME};
        my $type = $info->{ARGS}->{$num}->{TYPE};
        push(@arg_names, $name );
        $arg_decl_string .= "\t\t$type\t\t$name\n";
    }
    chomp( $arg_decl_string );
    my $arg_string = join(", ", @arg_names );
    
    pp_addxs( <<"ENDXS" );
$return_type
$name( $arg_string )
$arg_decl_string
\tCODE:
\t\tRETVAL = $orig_name ( $arg_string );
\tOUTPUT:
\t\tRETVAL
ENDXS
} # End of add_basic_def_xs()...

sub parse_prototype
{
    my $proto = shift;
    
    return undef
        unless( $proto =~ /(\w+\s*\*?)\s*(\w+)\s*\((.*)\)/ );
    
    my $args = $3;
    
    my $hash = {
        RETURN_TYPE => $1,    
        NAME => $2,
    };
    
    # Figure out the args:
    my $arg_count = 1;
    foreach my $arg ( grep /\w/, split /,/, $args ) 
    {
        my ($name) = ($arg =~ /(\w+)$/);
        $arg =~ s/$name$//; # arg now contains the full C type
        $arg =~ s/const //;  # get rid of 'const' in C type
        $arg =~ s/^\s+//;
        $arg =~ s/\s+$//;    # pare off the variable type from 'arg'
        $hash->{ARGS}->{$arg_count} = {
            NAME => $name,
            TYPE => $arg,
        };
        $arg_count++;
    }
    
    #use Data::Dumper;
    #my $dd = Data::Dumper->new( [$hash], [ 'hash' ] );
    #$dd->Indent(1);
    #print STDERR $dd->Dump();
    
    return $hash;
} # End of parse_prototype()...