Pg now uses typed handlers and native methods

DBDish::Pg revamped to use 'is native' methods of typed CPointer classes at the native call interface level. A lot of needless 'return' removed and general cleanup.
raku-community-modules · Feb 25, 2016 · 5288b6b · 5288b6b
1 parent 5250f2a
commit 5288b6b
Show file tree

Hide file tree

Showing 4 changed files with 110 additions and 205 deletions.
diff --git a/lib/DBDish/Pg.pm6 b/lib/DBDish/Pg.pm6
@@ -78,32 +78,31 @@ method connect(*%params) {
         my $translated = %keymap{ $key } // $key;
         take "$translated={quote-and-escape $value}"
     }
-    my $conninfo = ~@connection_parameters;
-    my $pg_conn = PQconnectdb($conninfo);
-    my $status = PQstatus($pg_conn);
+    my $pg_conn = PGconn.new(~@connection_parameters);
+    my $status = $pg_conn.PQstatus;
     my $connection;
-    if $status eq CONNECTION_OK {
+    if $status == CONNECTION_OK {
         $connection = DBDish::Pg::Connection.new(
             :$pg_conn,
             :RaiseError(%params<RaiseError>),
         );
     }
     else {
-        $!errstr = PQerrorMessage($pg_conn);
+        $!errstr = $pg_conn.PQerrorMessage;
         if %params<RaiseError> { die $!errstr; }
     }
-    return $connection;
+    $connection;
 }
 
 =begin pod
 
 =head1 DESCRIPTION
-# 'zavolaj' is a Native Call Interface for Rakudo/Parrot. 'DBIish' and
-# 'DBDish::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.  DBIish is not that, it is a naive rewrite of the
-# similarly named Perl 5 modules.  Hence the 'Mini' part of the name.
+# 'DBIish' and # 'DBDish::Pg' are Perl 6 modules that use Rakudo's
+# NativeCall to use the standard libpq library.
+# There is a long term Rakudo based project to develop a new,
+# comprehensive DBI architecture for Rakudo and Perl 6.
+# DBIish 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 DBDish::Pg module contains the same classes and methods as every

diff --git a/lib/DBDish/Pg/Connection.pm6 b/lib/DBDish/Pg/Connection.pm6
@@ -16,20 +16,18 @@ method prepare(Str $statement, $attr?) {
     state $statement_postfix = 0;
     my $statement_name = join '_', 'pg', $*PID, $statement_postfix++;
     my $munged = DBDish::Pg::pg-replace-placeholder($statement);
-    my $result = PQprepare(
-            $!pg_conn,
+    my $result = $!pg_conn.PQprepare(
             $statement_name,
             $munged,
             0, Oid
     );
-    my $status = PQresultStatus($result);
-    unless status-is-ok($status) {
-        self!set_errstr(PQresultErrorMessage($result));
+    unless $result.is-ok {
+        self!set_errstr($result.PQresultErrorMessage);
         die self.errstr if $.RaiseError;
         return Nil;
     }
-    my $info = PQdescribePrepared($!pg_conn, $statement_name);
-    my $param_count = PQnparams($info);
+    my $info = $!pg_conn.PQdescribePrepared($statement_name);
+    my $param_count = $info.PQnparams;
 
     my $statement_handle = DBDish::Pg::StatementHandle.new(
         :$!pg_conn,
@@ -40,38 +38,38 @@ method prepare(Str $statement, $attr?) {
         :$result,
         :$param_count,
     );
-    return $statement_handle;
+    $statement_handle;
 }
 
 method do(Str $statement, *@bind is copy) {
     my $sth = self.prepare($statement);
     $sth.execute(@bind);
     my $rows = $sth.rows;
-    return ($rows == 0) ?? "0E0" !! $rows;
+    ($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;
+    $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;
+    $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;
+    $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);
+    $sth.fetchall_hashref($key);
 }
 
 method selectcol_arrayref(Str $statement, $attr?, *@bind is copy) {
@@ -84,15 +82,15 @@ method selectcol_arrayref(Str $statement, $attr?, *@bind is copy) {
     }
 
     my $aref = @results;
-    return $aref;
+    $aref;
 }
 
 method commit {
     if $!AutoCommit {
         warn "Commit ineffective while AutoCommit is on";
         return;
     };
-    PQexec($!pg_conn, "COMMIT");
+    $!pg_conn.PQexec("COMMIT");
     $.in_transaction = 0;
 }
 
@@ -101,15 +99,15 @@ method rollback {
         warn "Rollback ineffective while AutoCommit is on";
         return;
     };
-    PQexec($!pg_conn, "ROLLBACK");
+    $!pg_conn.PQexec("ROLLBACK");
     $.in_transaction = 0;
 }
 
 method ping {
-    PQstatus($!pg_conn) == CONNECTION_OK
+    $!pg_conn.PQstatus == CONNECTION_OK
 }
 
-method disconnect() {
-    PQfinish($!pg_conn);
+method disconnect {
+    $!pg_conn.PQfinish;
     True;
 }
diff --git a/lib/DBDish/Pg/Native.pm6 b/lib/DBDish/Pg/Native.pm6
@@ -10,132 +10,51 @@ constant LIB = &MyLibName;
 
 #------------ My Visible Pointers
 
-class PGconn is export is repr('CPointer') { };
-class PGresult	is export is repr('CPointer') { };
-class Oid	is export is repr('CPointer') { };
-
-#------------ Pg library functions in alphabetical order ------------
-
-sub PQexec (PGconn $conn, str $statement)
-    returns PGresult
-    is native(LIB)
-    is export
-    { ... }
+class PGresult	is export is repr('CPointer') {
+    method PQclear is native(LIB) { * }
+    method PQcmdTuples(--> str) is native(LIB) { * }
+    method PQfname(int32 --> str) is native(LIB) { * }
+    method PQftype(int32 --> int32) is native(LIB) { * };
+    method PQgetisnull(int32, int32 --> int32) is native(LIB) { * }
+    method PQgetvalue(int32, int32 --> str) is native(LIB) { * }
+    method PQnfields(--> int32) is native(LIB) { * }
+    method PQnparams(--> int32) is native(LIB) { * }
+    method PQntuples(--> int32) is native(LIB) { * }
+    method PQresultErrorMessage(--> str) is native(LIB) { * }
+    method PQresultStatus(--> int32) is native(LIB) { * }
+
+    method is-ok {
+	self.PQresultStatus ~~ (0 .. 4);
+    }
+}
 
-sub PQprepare (PGconn $conn, str $statement_name, str $query, int32 $n_params, Oid $paramTypes)
-    returns PGresult
-    is native(LIB)
-    is export
-    { ... }
+class Oid is export is repr('CPointer') { }
 
-sub PQexecPrepared(
-        PGconn $conn,
+class PGconn is export is repr('CPointer') {
+    method PQexec(--> PGresult) is native(LIB) { * }
+    method PQexecPrepared(
         str $statement_name,
         int32 $n_params,
         CArray[Str] $param_values,
         CArray[int32] $param_length,
         CArray[int32] $param_formats,
         int32 $resultFormat
-    )
-    returns PGresult
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQnparams (OpaquePointer)
-    returns int32
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQdescribePrepared (PGconn, str)
-    returns OpaquePointer
-    is native(LIB)
-    is export
-    { ... }
-
-
-sub PQresultStatus (PGresult $result)
-    returns int32
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQerrorMessage (PGconn $conn)
-    returns str
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQresultErrorMessage (PGresult $result)
-    returns str
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQconnectdb (str $conninfo)
-    returns PGconn
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQstatus (PGconn $conn)
-    returns int32
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQnfields (PGresult $result)
-    returns int32
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQntuples (PGresult $result)
-    returns int32
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQcmdTuples (PGresult $result)
-    returns str
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQgetvalue (PGresult $result, int32 $row, int32 $col)
-    returns Str
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQgetisnull (PGresult $result, int32 $row, int32 $col)
-    returns int32
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQfname (PGresult $result, int32 $col)
-    returns str
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQclear (PGresult $result)
-    is native(LIB)
-    is export
-    { ... }
-
-sub PQfinish(PGconn)
-    is native(LIB)
-    is export
-    { ... }
+    ) returns PGresult is native(LIB) { * }
+
+    method PQerrorMessage(--> str) is native(LIB) { * }
+    method PQdescribePrepared(str --> PGresult) is native(LIB) { * }
+    method PQstatus(--> int32) is native(LIB) { * }
+    method PQprepare(str $sth_name, str $query, int32 $n_params, Oid $paramTypes --> PGresult)
+	is native(LIB) { * }
+    method PQfinish is native(LIB) { * }
+
+    method new(Str $conninfo) { # Our constructor
+	sub PQconnectdb(str --> PGconn) is native(LIB) { * };
+	PQconnectdb($conninfo);
+    }
+}
 
-sub PQftype(PGresult, int32)
-    is native(LIB)
-    is export
-    returns int32
-    { ... }
+constant Null => Pointer;
 
 # from pg_type.h
 constant %oid-to-type-name is export = (
@@ -165,7 +84,6 @@ constant %oid-to-type-name is export = (
       2951  => 'Str',   # _uuid
 ).hash;
 
-
 constant CONNECTION_OK         is export = 0;
 constant CONNECTION_BAD        is export = 1;
 
@@ -174,7 +92,3 @@ constant PGRES_COMMAND_OK  = 1;
 constant PGRES_TUPLES_OK   = 2;
 constant PGRES_COPY_OUT    = 3;
 constant PGRES_COPY_IN     = 4;
-
-sub status-is-ok($status)    is export { $status ~~ (0..4) }
-
-#-----------------------------------------------------------------------