Merge pull request #83 from kaare/master

Dynamic types handling

lib/DBDish.pm6

@@ -19,6 +19,19 @@ role Driver does DBDish::ErrorHandling {
     #method new() { nextsame; }
 }
 
+role TypeConverter does Associative {
+    has Callable %!Conversions{Mu:U} handles <AT-KEY EXISTS-KEY>;
+
+    # The role implements the conversion
+    method convert (::?CLASS:D: Str $datum, Mu:U $typ) {
+        with %!Conversions{$typ} -> &converter {
+            converter($datum, $typ);
+        } else { # Common case
+            $typ($datum);
+        }
+    }
+}
+
 =begin pod
 =head1 DESCRIPTION
 The DBDish module loads the generic code needed by every DBDish driver of the
@@ -59,6 +72,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

@@ -13,8 +13,16 @@ 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 %.Converter is DBDish::TypeConverter;
+has %.dynamic-types = %oid-to-type;
+
+submethod BUILD(:$!pg_conn, :$!parent!, :$!AutoCommit) {
+    %!Converter{Str} =  sub (Str $str, Mu:U $type-name) { $str };
+    %!Converter{Date} = sub (Str $str, Mu:U $type-name) { Date.new($str) };
+    %!Converter{DateTime} =  sub (Str $str, Mu:U $type-name) { DateTime.new($str.split(' ').join('T')) };
+    %!Converter{Bool} =  sub (Str $str, Mu:U $type-name) { $str eq 't' };
+    %!Converter{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 $value, Mu:U $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($type-name))
+    } 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

@@ -27,7 +27,7 @@ submethod !get-meta($result) {
             @!column-name.push: $result.PQfname($_);
             @!column-type.push: do {
                 my $pt = $result.PQftype($_);
-                if (my \t = %oid-to-type{$pt}) === Nil {
+                if (my \t = $!parent.dynamic-types{$pt}) === Nil {
                     warn "No type map defined for postgresql type $pt at column $_";
                     Str;
                 } else { t }
@@ -41,7 +41,7 @@ submethod BUILD(:$!parent!, :$!pg_conn, # Per protocol
 ) {
     if $!statement_name { # Prepared
         with $!pg_conn.PQdescribePrepared($!statement_name) -> $info {
-            @!param_type.push(%oid-to-type{$info.PQparamtype($_)}) for ^$info.PQnparams;
+            @!param_type.push($!parent.dynamic-types{$info.PQparamtype($_)}) for ^$info.PQnparams;
             self!get-meta($info);
             $info.PQclear;
         }
@@ -87,12 +87,15 @@ method _row() {
     my $l = ();
     if $!Executed && $!field_count && $!current_row < $!row_count {
         my $col = 0;
+        my %Converter := $!parent.Converter;
         $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 {
+                    $value = %Converter.convert($str, ct);
                 }
             }
             $col++;

t/06-types.t

@@ -0,0 +1,33 @@
+use v6;
+use Test;
+need DBDish;
+
+plan 11;
+
+class type-test {
+	has %.Converter is DBDish::TypeConverter;
+
+	method test-str(Str $value) {
+		$value.flip;
+	}
+
+	submethod BUILD {
+		%!Converter{Int} = sub (Str $value, $typ) { Int($value) };
+		%!Converter{Str} = self.^find_method('test-str');
+	}
+}
+
+ok my $test = type-test.new;
+ok my $res = $test.Converter.convert('123', Int), 'Get the result (Int)';
+is $res, 123, 'Check it';
+
+ok my $sub = $test.Converter{Int}, 'Get the converter sub (Int)';
+is $sub('123', Int), 123, 'and then convert';
+my $int =  sub ($) {1};
+ok ($test.Converter{Int} = $int), 'Change the Int converter';
+ok $sub = $test.Converter{Int}, 'Get it back';
+is $sub.WHAT, Sub, 'Is it a sub?';
+is $sub('123'), 1, 'Does it do its job?';
+
+ok $sub = $test.Converter{Str}, 'get the Str method';
+is $test.$sub('test'), 'tset', 'and try it';

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.Converter{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');