[Dbix-class] Pg patch from konobi - can people test please?

[Jesper Krogh]

Hi.

The patch is probably correct (copied from the Rails-counterpart), but this
functionality is in Perl coded directly in DBD::Pg.

I still think that it's migrating code from DBD::Pg that shouldn't be
there. There is a bug in the code, but thats fixed by this (much simpler)
patch.

The bug is that the sequence-lookup does not supply the fully qualified
sequence so when the table is not in the search_path it fails to get the
"insert_id" from the sequence.


Index: t/run/12pg.tl
===================================================================
--- t/run/12pg.tl       (revision 1522)
+++ t/run/12pg.tl       (working copy)
@@ -50,7 +50,7 @@
 my $type_info = PgTest->schema->storage->columns_info_for('artist');
 my $artistid_defval = delete $type_info->{artistid}->{default_value};
 like($artistid_defval,
-     qr/^nextval\('public\.artist_artistid_seq'::(?:text|regclass)\)/,
+    
qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
      'columns_info_for - sequence matches Pg get_autoinc_seq expectations');
 is_deeply($type_info, $test_type_info,
           'columns_info_for - column data types');
Index: lib/DBIx/Class/Storage/DBI/Pg.pm
===================================================================
--- lib/DBIx/Class/Storage/DBI/Pg.pm    (revision 1522)
+++ lib/DBIx/Class/Storage/DBI/Pg.pm    (working copy)
@@ -21,11 +21,11 @@
   my ($schema,$table) = $source->name =~ /^(.+)\.(.+)$/ ? ($1,$2)
     : (undef,$source->name);
   while (my $col = shift @pri) {
-    my $info =
$dbh->column_info(undef,$schema,$table,$col)->fetchrow_arrayref;
-    if (defined $info->[12] and $info->[12] =~
+    my $info =
$dbh->column_info(undef,$schema,$table,$col)->fetchrow_hashref;
+    if (defined $info->{COLUMN_DEF} and $info->{COLUMN_DEF} =~
       /^nextval\(+'([^']+)'::(?:text|regclass)\)/)
     {
-      return $1; # may need to strip quotes -- see if this works
+      return $info->{TABLE_SCHEM} . "." . $1; # may need to strip quotes
-- see if this works
     }
   }
 }


This is sample output fom the $info;

#           'DECIMAL_DIGITS' => undef,
#          'COLUMN_DEF' => 'nextval(\'other4.testtable_id_seq\'::regclass)',
#          'TABLE_CAT' => undef,
#          'NUM_PREC_RADIX' => undef,
#          'TABLE_SCHEM' => 'other4',
#          'BUFFER_LENGTH' => undef,
#          'CHAR_OCTET_LENGTH' => undef,
#          'pg_constraint' => undef,
#          'IS_NULLABLE' => 'NO',
#          'REMARKS' => undef,
#          'COLUMN_SIZE' => 4,
#          'ORDINAL_POSITION' => '1',
#          'COLUMN_NAME' => 'id',
#          'TYPE_NAME' => 'integer',
#          'pg_type' => 'integer',
#          'NULLABLE' => '0',
#          'DATA_TYPE' => 4,
#          'TABLE_NAME' => 'testtable',
#          'SQL_DATA_TYPE' => undef,
#          'SQL_DATETIME_SUB' => undef


> konobi's lobbed together a patch for Storage::DBI::Pg that hopefully
> improves sequence etc. support - can people who know/use such things more
> than I have a look over and say whether it's suitable for inclusion?
>
> === Pg.pm
> ==================================================================
> --- Pg.pm       (revision 1247)
> +++ Pg.pm       (local)
> @@ -20,14 +20,50 @@
> my $dbh = $self->_dbh; my ($schema,$table) = $source->name =~
> /^(.+)\.(.+)$/ ? ($1,$2)
> : (undef,$source->name);
> -  while (my $col = shift @pri) {
> -    my $info =
> $dbh->column_info(undef,$schema,$table,$col)->fetchrow_arrayref;
> -    if (defined $info->[12] and $info->[12] =~
> -      /^nextval\(+'([^']+)'::(?:text|regclass)\)/)
> -    {
> -      return $1; # may need to strip quotes -- see if this works
> -    }
> +
> +  # First try looking for a sequence with a dependency on the
> +  # given table's primary key.
> +  my $sql = qq{
> +    SELECT attr.attname, name.nspname, seq.relname
> +    FROM pg_class      seq,
> +         pg_attribute  attr,
> +         pg_depend     dep,
> +         pg_namespace  name,
> +         pg_constraint cons
> +    WHERE seq.oid           = dep.objid
> +      AND seq.relnamespace  = name.oid
> +      AND seq.relkind       = 'S'
> +      AND attr.attrelid     = dep.refobjid
> +      AND attr.attnum       = dep.refobjsubid
> +      AND attr.attrelid     = cons.conrelid
> +      AND attr.attnum       = cons.conkey[1]
> +      AND cons.contype      = 'p'
> +      AND dep.refobjid      = '$table'::regclass
> +  };
> +  my %hash_details;
> +  @hash_details{qw(name namespace seqname)} =
> $dbh->selectrow_array($sql);
> +
> +  if( !scalar(values(%hash_details)) ){
> +    # If that fails, try parsing the primary key's default value.
> +    # Support the 7.x and 8.0 nextval('foo'::text) as well as
> +    # the 8.1+ nextval('foo'::regclass).
> +    # TODO: assumes sequence is in same schema as table.
> +    my $sql2 = qq{
> +        SELECT attr.attname, name.nspname, split_part(def.adsrc, '\\\'',
> 2)
> +        FROM pg_class       t
> +        JOIN pg_namespace   name ON (t.relnamespace = name.oid)
> +        JOIN pg_attribute   attr ON (t.oid = attrelid)
> +        JOIN pg_attrdef     def  ON (adrelid = attrelid AND adnum =
> attnum) +        JOIN pg_constraint  cons ON (conrelid = adrelid AND adnum
> = conkey[1])
> +        WHERE t.oid = '$table'::regclass
> +        AND cons.contype = 'p'
> +        AND def.adsrc ~* 'nextval'
> +    };
> +    @hash_details{qw(name namespace seqname)} =
> $dbh->selectrow_array($sql2);
>
>
> }
> +
> +  # check for existence of . in sequence name as in public.foo_sequence.
> if it does not exist, join the current namespace +  return
> $hash_details{seqname} =~ m{\.} ? $hash_details{seqname} :
> $hash_details{namespace} .q{.}. $hash_details{seqname};
> }
>
>
> sub sqlt_type {
>
> --
> Matt S Trout       Offering custom development, consultancy and support
> Technical Director    contracts for Catalyst, DBIx::Class and BAST.
> Contact
> Shadowcat Systems Ltd.  mst (at) shadowcatsystems.co.uk for more
> information
>
> + Help us build a better perl ORM:
> http://dbix-class.shadowcatsystems.co.uk/ +
>
>
> _______________________________________________
> List: http://lists.rawmode.org/cgi-bin/mailman/listinfo/dbix-class
> Wiki: http://dbix-class.shadowcatsystems.co.uk/
> IRC: irc.perl.org#dbix-class
> SVN: http://dev.catalyst.perl.org/repos/bast/trunk/DBIx-Class/
>
>


-- 
Jesper Krogh