Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

470 lines (386 sloc) 12.769 kB
# MiniDBD::Pg.pm6
use NativeCall; # from project 'zavolaj'
use MiniDBD; # roles for drivers
#module MiniDBD:auth<mberends>:ver<0.0.1>;
#------------ Pg library functions in alphabetical order ------------
sub PQexec (OpaquePointer $conn, Str $statement)
returns OpaquePointer
is native('libpq')
{ ... }
sub PQprepare (OpaquePointer $conn, Str $statement_name, Str $query, Int $n_params, OpaquePointer $paramTypes)
returns OpaquePointer
is native('libpq')
{ ... }
sub PQexecPrepared(
OpaquePointer $conn,
Str $statement_name,
Int $n_params,
CArray[Str] $param_values,
CArray[int] $param_length,
CArray[int] $param_formats,
Int $resultFormat
)
returns OpaquePointer
is native('libpq')
{ ... }
sub PQresultStatus (OpaquePointer $result)
returns Int
is native('libpq')
{ ... }
sub PQerrorMessage (OpaquePointer $conn)
returns Str
is native('libpq')
{ ... }
sub PQresultErrorMessage (OpaquePointer $result)
returns Str
is native('libpq')
{ ... }
sub PQconnectdb (Str $conninfo)
returns OpaquePointer
is native('libpq')
{ ... }
sub PQstatus (OpaquePointer $conn)
returns Int
is native('libpq')
{ ... }
sub PQnfields (OpaquePointer $result)
returns Int
is native('libpq')
{ ... }
sub PQntuples (OpaquePointer $result)
returns Int
is native('libpq')
{ ... }
sub PQcmdTuples (OpaquePointer $result)
returns Str
is native('libpq')
{ ... }
sub PQgetvalue (OpaquePointer $result, Int $row, Int $col)
returns Str
is native('libpq')
{ ... }
sub PQfname (OpaquePointer $result, Int $col)
returns Str
is native('libpq')
{ ... }
sub PQclear (OpaquePointer $result)
is native('libpq')
{ ... }
constant CONNECTION_OK = 0;
constant CONNECTION_BAD = 1;
constant PGRES_EMPTY_QUERY = 0;
constant PGRES_COMMAND_OK = 1;
constant PGRES_TUPLES_OK = 2;
constant PGRES_COPY_OUT = 3;
constant PGRES_COPY_IN = 4;
#-----------------------------------------------------------------------
class MiniDBD::Pg::StatementHandle does MiniDBD::StatementHandle {
has $!pg_conn;
has $.RaiseError;
has Str $!statement_name;
has $!statement;
has $.dbh;
has $!result;
has $!affected_rows;
has @!column_names;
has Int $!row_count;
has $!field_count;
has $!current_row;
method !handle-errors {
my $status = PQresultStatus($!result);
if $status != PGRES_EMPTY_QUERY | PGRES_COMMAND_OK | PGRES_TUPLES_OK | PGRES_COPY_OUT | PGRES_COPY_IN {
self!set_errstr(PQresultErrorMessage($!result));
if $!RaiseError { die self!errstr; }
}
self!set_errstr(Any);
}
method !munge_statement {
my $count = 0;
my $munged = $!statement.subst(:g, '?', { '$' ~ ++$count});
return ($munged, $count);
}
submethod BUILD(:$!statement, :$!pg_conn) {
state $statement_postfix = 0;
$!statement_name = join '_', 'pg', $*PID, $statement_postfix++;
my ($munged, $nparams) = self!munge_statement;
$!result = PQprepare(
$!pg_conn,
$!statement_name,
$munged,
$nparams,
OpaquePointer
);
self!handle-errors;
True;
}
method execute(*@params is copy) {
$!current_row = 0;
my @param_values := CArray[Str].new;
for @params.kv -> $k, $v {
@param_values[$k] = $v.Str;
}
$!result = PQexecPrepared($!pg_conn, $!statement_name, @params.elems,
@param_values,
OpaquePointer, # ParamLengths, NULL pointer == all text
OpaquePointer, # ParamFormats, NULL pointer == all text
0, # Resultformat, 0 == text
);
self!handle-errors;
$!row_count = PQntuples($!result);
my $rows = self.rows;
return ($rows == 0) ?? "0E0" !! $rows;
}
# do() and execute() return the number of affected rows directly or:
# rows() is called on the statement handle $sth.
method rows() {
unless defined $!affected_rows {
$!affected_rows = PQcmdTuples($!result);
self!handle-errors;
}
if defined $!affected_rows {
return +$!affected_rows;
}
}
method fetchrow_array() {
my @row_array;
return if $!current_row >= $!row_count;
unless defined $!field_count {
$!field_count = PQnfields($!result);
}
if defined $!result {
self!errstr = Any;
for ^$!field_count {
@row_array.push(PQgetvalue($!result, $!current_row, $_));
}
$!current_row++;
self!handle-errors;
if ! @row_array { self.finish; }
}
return @row_array;
}
method fetchrow_arrayref() {
my $row_arrayref;
return if $!current_row >= $!row_count;
unless defined $!field_count {
$!field_count = PQnfields($!result);
}
if defined $!result {
self!set_errstr(Any);
my @row = self!get_row();
my $errstr = PQresultErrorMessage ($!result);
if $errstr ne '' {
self!errstr = $errstr;
if $!RaiseError { die $errstr; }
return;
}
if @row {
$row_arrayref = @row;
}
else { self.finish; }
}
return $row_arrayref;
}
method fetch() { self.fetchrow_arrayref(); } # alias according to perldoc DBI
method fetchall_arrayref() {
my $all_arrayref;
return if $!current_row >= $!row_count;
unless defined $!field_count {
$!field_count = PQnfields($!result);
}
if defined $!result {
self!set_errstr(Any);
my @all_array;
for ^$!row_count {
my @row = self!get_row();
my $errstr = PQresultErrorMessage ($!result);
if $errstr ne '' {
self!errstr = $errstr;
if $!RaiseError { die $errstr; }
return;
}
if @row {
my $row_arrayref = @row;
push @all_array, $row_arrayref;
}
else { self.finish; }
}
$all_arrayref = @all_array;
}
return $all_arrayref;
}
method fetchrow_hashref () {
my $row_hashref;
my %row_hash;
return if $!current_row >= $!row_count;
unless defined $!field_count {
$!field_count = PQnfields($!result);
}
if defined $!result {
self!set_errstr(Any);
my $errstr = PQresultErrorMessage ($!result);
if $errstr ne '' {
self!errstr = $errstr;
if $!RaiseError { die $errstr; }
return;
}
my @row = self!get_row();
unless @!column_names {
for ^$!field_count {
my $column_name = PQfname($!result, $_);
@!column_names.push($column_name);
}
}
if @row && @!column_names {
for @row Z @!column_names -> $column_value, $column_name {
%row_hash{$column_name} = $column_value;
}
} else {
self.finish;
}
$row_hashref = %row_hash;
}
return $row_hashref;
}
method fetchall_hashref(Str $key) {
my %results;
return if $!current_row >= $!row_count;
while my $row = self.fetchrow_hashref {
%results{$row{$key}} = $row;
}
my $results_ref = %results;
return $results_ref;
}
method finish() {
if defined($!result) {
PQclear($!result);
$!result = Any;
@!column_names = ();
}
return Bool::True;
}
method !get_row {
my @data;
for ^$!field_count {
@data.push(PQgetvalue($!result, $!current_row, $_));
}
$!current_row++;
return @data;
}
}
class MiniDBD::Pg::Connection does MiniDBD::Connection {
has $!pg_conn;
has $.RaiseError;
has $.AutoCommit is rw = 1;
has $.in_transaction is rw;
method BUILD(:$!pg_conn) { }
method prepare(Str $statement, $attr?) {
my $statement_handle = MiniDBD::Pg::StatementHandle.bless(
MiniDBD::Pg::StatementHandle.CREATE(),
:$!pg_conn,
:$statement,
:$!RaiseError,
:dbh(self),
);
return $statement_handle;
}
method do(Str $statement, $attr?, *@bind is copy) {
my $sth = self.prepare($statement);
$sth.execute(@bind);
my $rows = $sth.rows;
return ($rows == 0) ?? "0E0" !! $rows;
}
method selectrow_arrayref(Str $statement, $attr?, *@bind is copy) {
my $sth = self.prepare($statement, $attr);
$sth.execute(@bind);
return $sth.fetchrow_arrayref;
}
method selectrow_hashref(Str $statement, $attr?, *@bind is copy) {
my $sth = self.prepare($statement, $attr);
$sth.execute(@bind);
return $sth.fetchrow_hashref;
}
method selectall_arrayref(Str $statement, $attr?, *@bind is copy) {
my $sth = self.prepare($statement, $attr);
$sth.execute(@bind);
return $sth.fetchall_arrayref;
}
method selectall_hashref(Str $statement, Str $key, $attr?, *@bind is copy) {
my $sth = self.prepare($statement, $attr);
$sth.execute(@bind);
return $sth.fetchall_hashref($key);
}
method selectcol_arrayref(Str $statement, $attr?, *@bind is copy) {
my @results;
my $sth = self.prepare($statement, $attr);
$sth.execute(@bind);
while (my $row = $sth.fetchrow_arrayref) {
@results.push($row[0]);
}
my $aref = @results;
return $aref;
}
method commit {
if $!AutoCommit {
warn "Commit ineffective while AutoCommit is on";
return;
};
PQexec($!pg_conn, "COMMIT");
$.in_transaction = 0;
}
method rollback {
if $!AutoCommit {
warn "Rollback ineffective while AutoCommit is on";
return;
};
PQexec($!pg_conn, "ROLLBACK");
$.in_transaction = 0;
}
method ping {
PQstatus($!pg_conn) == CONNECTION_OK
}
}
class MiniDBD::Pg:auth<mberends>:ver<0.0.1> {
has $.Version = 0.01;
has $!errstr;
method !errstr() is rw { $!errstr }
#------------------ methods to be called from MiniDBI ------------------
method connect(*%params) {
my $host = %params<host> // 'localhost';
my $port = %params<port> // 5432;
my $database = %params<dbname> // %params<database> // 'postgres';
my $user = %params<user> // die 'Missing <user> config';
my $password = %params<password> // die 'Missing <password> config';
my $conninfo = "host=$host port=$port dbname=$database user=$user password=$password";
my $pg_conn = PQconnectdb($conninfo);
my $status = PQstatus($pg_conn);
my $connection;
if $status eq CONNECTION_OK {
$connection = MiniDBD::Pg::Connection.bless(*,
:$pg_conn,
:RaiseError(%params<RaiseError>),
);
}
else {
$!errstr = PQerrorMessage($pg_conn);
if %params<RaiseError> { die $!errstr; }
}
return $connection;
}
}
=begin pod
=head1 DESCRIPTION
# 'zavolaj' is a Native Call Interface for Rakudo/Parrot. 'MiniDBI' and
# 'MiniDBD::Pg' are Perl 6 modules that use 'zavolaj' to use the
# standard libpq library. There is a long term Parrot based
# project to develop a new, comprehensive DBI architecture for Parrot
# and Perl 6. MiniDBI is not that, it is a naive rewrite of the
# similarly named Perl 5 modules. Hence the 'Mini' part of the name.
=head1 CLASSES
The MiniDBD::Pg module contains the same classes and methods as every
database driver. Therefore read the main documentation of usage in
L<doc:MiniDBI> and internal architecture in L<doc:MiniDBD>. Below are
only notes about code unique to the MiniDBD::Pg implementation.
=head1 SEE ALSO
The Postgres 8.4 Documentation, C Library.
L<http://www.postgresql.org/docs/8.4/static/libpq.html>
=end pod
Jump to Line
Something went wrong with that request. Please try again.