view release on metacpan or  search on metacpan

lib/PostgreSQL/PLPerl/Call.pm  view on Meta::CPAN

=head2 Limitations and Caveats

Requires PostgreSQL 9.0 or later.

Types that contain a comma can't be used in the call signature. That's not a
problem in practice as it only affects 'C<numeric(p,s)>' and 'C<decimal(p,s)>'
and the 'C<,s>' part isn't needed. Typically the 'C<(p,s)>' portion isn't used in
signatures.

The return value of functions that have a C<void> return type should not be
relied upon, naturally.

=head2 Author and Copyright

Tim Bunce L<http://www.tim.bunce.name>

Copyright (c) Tim Bunce, Ireland, 2010. All rights reserved.
You may use and distribute on the same terms as Perl 5.10.1.

With thanks to L<http://www.TigerLead.com> for sponsoring development.

=cut

use strict;
use warnings;
use Exporter;
use Carp;

our @ISA = qw(Exporter);
our @EXPORT = qw(call PG);

my %sig_cache;
our $debug = 0;

# encapsulated package to provide an AUTOLOAD interface to call()
use constant PG => do { 
    package PostgreSQL::PLPerl::Call::PG;
our $VERSION = '1.007';

    sub AUTOLOAD {
        #(my $function = our $AUTOLOAD) =~ s/.*:://;
        our $AUTOLOAD =~ s/.*:://;
        shift;
        return PostgreSQL::PLPerl::Call::call($AUTOLOAD, @_);
    }

    __PACKAGE__;
};


sub call {
    my $sig = shift;

    my $arity = scalar @_; # argument count to handle variadic subs

    my $how = $sig_cache{"$sig.$arity"} ||= do {

        # get a normalized signature to recheck the cache with
        # and also extract the SP name and argument types
        my ($stdsig, $fullspname, $spname, $arg_types) = _parse_signature($sig, $arity)
            or croak "Can't parse '$sig'";
        warn "parsed call($sig) => $stdsig\n"
            if $debug;

        # recheck the cache with with the normalized signature
        $sig_cache{"$stdsig.$arity"} ||= [ # else a new entry (for both caches)
            $spname,     # is name of column for single column results
            scalar _mk_process_args($arg_types),
            scalar _mk_process_call($fullspname, $arity, $arg_types),
            $fullspname, # is name used in SQL to make the call
            $stdsig,
        ];
    };

    my ($spname, $prepargs, $callsub) = @$how;

    my $rv = $callsub->( $prepargs ? $prepargs->(@_) : @_ );

    my $rows = $rv->{rows};
    my $row1 = $rows->[0] # peek at first row
        or return;        # no row: undef in scalar context else empty list

    my $is_single_column = (keys %$row1 == 1 and exists $row1->{$spname});

    if (wantarray) {                   # list context - all rows

        return map { $_->{$spname} } @$rows if $is_single_column;
        return @$rows;
    }
    elsif (defined wantarray) {        # scalar context - single row

        croak "$sig was called in scalar context but returned more than one row"
            if @$rows > 1;

        return $row1->{$spname} if $is_single_column;
        return $row1;
    }
    # else void context - nothing to do
    return;
}


sub _parse_signature {
    my ($sig, $arity) = @_;

    # extract types from signature, if any
    my $arg_types;
    if ($sig =~ s/\s*\((.*?)\)\s*$//) {
        $arg_types = [ split(/\s*,\s*/, lc($1), -1) ];
        s/^\s+// for @$arg_types;
        s/\s+$// for @$arg_types;

        # if variadic, replace '...' marker with the appropriate number
        # of copies of the preceding type name
        if (@$arg_types and $arg_types->[-1] =~ s/\s*\.\.\.//) {
            my $variadic_type = pop @$arg_types;
            push @$arg_types, $variadic_type
                until @$arg_types >= $arity;
        }
    }

    # the full name is what's left in sig
    my $fullspname = $sig;

    # extract the function name and un-escape it to get the column name
    (my $spname = $fullspname) =~ s/.*\.//; # remove schema, if any
    if ($spname =~ s/^"(.*)"$/$1/) { # unescape
        $spname =~ s/""/"/;
    }

    # compose a normalized signature
    my $stdsig = "$fullspname".
        ($arg_types ? "(".join(",",@$arg_types).")" : "");

    return ($stdsig, $fullspname, $spname, $arg_types);
}


sub _mk_process_args {
    my ($arg_types) = @_;

    return undef unless $arg_types;

    # return a closure that pre-processes the arguments of the call
    # else undef if no argument pre-processing is required

    my $hooks;
    my $i = 0;
    for my $type (@$arg_types) {
        if ($type =~ /\[/) {    # ARRAY
            $hooks->{$i} = sub { return ::encode_array_literal(shift) };
        }
        ++$i;
    }

    return undef unless $hooks;

    my $sub = sub {
        my @args = @_;
        while ( my ($argidx, $preproc) = each %$hooks ) {
            $args[$argidx] = $preproc->($args[$argidx]);
        }
        return @args;
    };

    return $sub;
}


sub _mk_process_call {
    my ($fullspname, $arity, $arg_types) = @_;

    # return a closure that will execute the query and return result ref

    my $placeholders = join ",", map { '$'.$_ } 1..$arity;
    my $sql = "select * from $fullspname($placeholders)";
    my $plan = eval { ::spi_prepare($sql, $arg_types ? @$arg_types : ()) };
    if ($@) { # internal error, should never happen
        chomp $@;
        croak "$@ while preparing $sql";
    }

    my $sub = sub {
        # XXX need to catch exceptions from here and rethrow using croak
        # to appear to come from the callers location (outside this package)
        warn "calling $sql(@_) [@{$arg_types||[]}]"
            if $debug;
        return ::spi_exec_prepared($plan, @_)
    };

    return $sub;
}

1;