POC Dynamic types

lib/DBDish.pm6

@@ -19,6 +19,17 @@ role Driver does DBDish::ErrorHandling {
     #method new() { nextsame; }
 }
 
+role Type {
+    has Sub %!Conversions{Str};
+
+    method set(Str $name, Sub $convert) {
+        %!Conversions{$name} = $convert;
+    }
+    method get(Str $name) {
+        %!Conversions{$name} || sub (Str :$str, Str :$type-name) { $type-name($str) };
+    }
+}
+
 =begin pod
 =head1 DESCRIPTION
 The DBDish module loads the generic code needed by every DBDish driver of the
@@ -59,6 +70,10 @@ The minimal declaration of a driver Foo typically start like:
 
 - See L<DBDish::StatementHandle>
 
+=head2 DBDish::Type
+
+This role defines the API for dynamic handling of the types of a DB system
+
 =head1 SEE ALSO
 
 The Perl 5 L<DBI::DBD>.

lib/DBDish/Pg/Connection.pm6

@@ -2,6 +2,7 @@ use v6;
 need DBDish;
 
 unit class DBDish::Pg::Connection does DBDish::Connection;
+use DBDish::Pg::Types;
 use DBDish::Pg::Native;
 need DBDish::Pg::StatementHandle;
 need DBDish::TestMock;
@@ -13,8 +14,19 @@ has PGconn $!pg_conn is required handles <
     pg-port pg-options quote>;
 has $.AutoCommit is rw = True;
 has $.in_transaction is rw = False;
-
-submethod BUILD(:$!pg_conn, :$!parent!, :$!AutoCommit) { }
+has $.types;
+
+submethod BUILD(:$!pg_conn, :$!parent!, :$!AutoCommit) {
+	$!types = DBDish::Pg::Types.new;
+$!types.set('Int',  sub (Str :$str, Str :$type-name) { Int($str) });
+$!types.set('Rat',  sub (Str :$str, Str :$type-name) { Rat($str) });
+    $!types.set('Str',  sub (Str :$str, Str :$type-name) { $str });
+    $!types.set('Date', sub (Str :$str, Str :$type-name) { Date.new($str) });
+    $!types.set('DateTime',  sub (Str :$str, Str :$type-name) { DateTime.new($str.split(' ').join('T')) });
+    $!types.set('Array',  sub (Str :$str, Str :$type-name) { $str });
+    $!types.set('Bool',  sub (Str :$str, Str :$type-name) { $str eq 't' });
+    $!types.set('Buf',  &str-to-blob);
+}
 
 method prepare(Str $statement, *%args) {
     state $statement_postfix = 0;

lib/DBDish/Pg/Native.pm6

@@ -15,6 +15,14 @@ sub PQlibVersion(-->uint32) is native(LIB) is export { * }
 sub PQfreemem(Pointer) is native(LIB) { * }
 sub PQunescapeBytea(str, size_t is rw --> Pointer) is native(LIB) { * }
 
+sub str-to-blob(Str :str($value), Str :$type-name) is export {
+    my \ptr = PQunescapeBytea($value, my size_t $elems);
+    LEAVE { PQfreemem(ptr) if ptr }
+    with ptr {
+        blob-from-pointer(ptr, :$elems, :type(Buf))
+    } else { die "Can't allocate memory!" };
+}
+
 class PGresult	is export is repr('CPointer') {
     method PQclear is native(LIB) { * }
     method PQcmdTuples(--> Str) is native(LIB) { * }
@@ -36,44 +44,8 @@ class PGresult	is export is repr('CPointer') {
     method is-ok {
 	self.PQresultStatus ~~ (0 .. 4);
     }
-
-    method get-value(Int $row, Int $col, Mu $t) {
-	#given self.PQfformat($col) {
-	#    when 0 { #Text
-		my $str = self.PQgetvalue($row,$col);
-		given $t {
-		    when Str { $str } # Done
-		    when Date { Date.new($str) }
-		    when DateTime { DateTime.new($str.split(' ').join('T')) }
-		    when Array { $str } # External process
-		    when Bool { $str eq 't' }
-		    when Blob {
-			my \ptr = PQunescapeBytea($str, my size_t $elems);
-			LEAVE { PQfreemem(ptr) if ptr }
-			with ptr {
-			    blob-from-pointer(ptr, :$elems, :type($t))
-			} else { die "Can't allocate memory!" };
-		    }
-		    when * === Any { $str }
-		    default { $t($str) } # Cast
-		}
-	#   }
-	#   when 1 { # Binary
-	#	my $size = self.PQgetlength($row, $col);
-	#	my \ptr = self.PQgetvaluePtr($row, $col);
-	#	# TODO This is certainly incomplete
-	#	given $t {
-	#	    when Str { nativecast(Str, ptr) }
-	#	    when Blob {
-	#		blob-from-pointer(ptr, :elems($size));
-	#	    }
-	#	}
-	#    }
-	#}
-    }
 }
 
-
 class pg-notify is export {
     has Str   $.relname;
     has int32 $.be_pid;

lib/DBDish/Pg/StatementHandle.pm6

@@ -2,6 +2,7 @@ use v6;
 need DBDish;
 
 unit class DBDish::Pg::StatementHandle does DBDish::StatementHandle;
+use DBDish::Pg::Types;
 use DBDish::Pg::Native;
 
 has PGconn $!pg_conn;
@@ -87,12 +88,16 @@ method _row() {
     my $l = ();
     if $!Executed && $!field_count && $!current_row < $!row_count {
         my $col = 0;
+        my $types = $!parent.types;
         $l = do for @!column-type -> \ct {
             my $value = ct;
             unless $!result.PQgetisnull($!current_row, $col) {
-                $value = $!result.get-value($!current_row, $col, $value);
+                my $str = $!result.PQgetvalue($!current_row, $col);
                 if ct ~~ Array {
-                    $value = _pg-to-array($value, ct.of);
+                    $value = _pg-to-array($str, ct.of);
+                } else {
+                    my $sub = $types.get(ct.^name);
+                    $value = &$sub(:$str, :type-name(ct.^name));
                 }
             }
             $col++;

lib/DBDish/Pg/Types.pm6

@@ -0,0 +1,4 @@
+use v6;
+
+need DBDish;
+unit class DBDish::Pg::Types does DBDish::Type;

t/06-types.t

@@ -0,0 +1,22 @@
+use v6;
+use Test;
+use DBDish;
+plan 9;
+
+class type-test does DBDish::Type {
+	submethod BUILD {
+		%!Conversions{'Int'} = sub (Str $value) { Int($value) };
+		self.set('Str', sub (Str $value) { $value });
+	}
+}
+
+ok my $test = type-test.new;
+ok my $sub = $test.get('Int');
+is $sub('123'), 123;
+my $int =  sub ($) {1};
+ok $test.set('Int', $int);
+ok $sub = $test.get('Int');
+is $sub.WHAT, Sub;
+is $sub('123'), 1;
+ok $sub = $test.get('Str');
+is $sub('test'), 'test';

t/34-pg-types.t

@@ -0,0 +1,56 @@
+use v6;
+use Test;
+use DBIish;
+
+plan 10;
+
+my %con-parms;
+# If env var set, no parameter needed.
+%con-parms<database> = 'dbdishtest' unless %*ENV<PGDATABASE>;
+%con-parms<user> = 'postgres' unless %*ENV<PGUSER>;
+my $dbh;
+
+try {
+  $dbh = DBIish.connect('Pg', |%con-parms);
+  CATCH {
+	    when X::DBIish::LibraryMissing | X::DBDish::ConnectionFailed {
+		diag "$_\nCan't continue.";
+	    }
+            default { .throw; }
+  }
+}
+without $dbh {
+    skip-rest 'prerequisites failed';
+    exit;
+}
+
+ok $dbh,    'Connected';
+
+# Be less verbose;
+$dbh.do('SET client_min_messages TO WARNING');
+lives-ok { $dbh.do('DROP TABLE IF EXISTS test') }, 'Clean';
+lives-ok {
+    $dbh.do(q|
+    CREATE TABLE test (
+	col1 text
+    )|)
+}, 'Table created';
+
+my $sth = $dbh.prepare('INSERT INTO test (col1) VALUES(?)');
+lives-ok {
+    $sth.execute('test');
+}, 'Insert Perl6 values';
+$sth.dispose;
+$sth = $dbh.prepare('SELECT col1 FROM test');
+my @coltype = $sth.column-types;
+ok @coltype eqv [Str],	    'Column-types';
+
+is $sth.execute, 1,			    '1 row';
+my ($col1) = $sth.row;
+isa-ok $col1, Str;
+is $col1, 'test',			    'Test';
+$dbh.types.set('Str',  sub (Str :$str, Str :$type-name) { 'changed' });
+is $sth.execute, 1,			    '1 row';
+($col1) = $sth.row;
+is $col1, 'changed',		    'Changed';
+$dbh.do('DROP TABLE IF EXISTS test');