[dbsrgits/DBIx-Class.git] / t / 72pg.t

use strict;
use warnings;

use Test::More;
use Test::Exception;
use lib qw(t/lib);
use DBICTest;


my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};

plan skip_all => <<EOM unless $dsn && $user;
Set \$ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test
( NOTE: This test drops and creates tables called 'artist', 'casecheck',
  'array_test' and 'sequence_test' as well as following sequences:
  'pkid1_seq', 'pkid2_seq' and 'nonpkid_seq''.  as well as following
  schemas: 'dbic_t_schema', 'dbic_t_schema_2', 'dbic_t_schema_3',
  'dbic_t_schema_4', and 'dbic_t_schema_5'
)
EOM

### load any test classes that are defined further down in the file

our @test_classes; #< array that will be pushed into by test classes defined in this file
DBICTest::Schema->load_classes( map {s/.+:://;$_} @test_classes ) if @test_classes;


###  pre-connect tests
{
  my $s = DBICTest::Schema->connect($dsn, $user, $pass);

  ok (!$s->storage->_dbh, 'definitely not connected');

  # Check that datetime_parser returns correctly before we explicitly connect.
 SKIP: {
      eval { require DateTime::Format::Pg };
      skip "DateTime::Format::Pg required", 2 if $@;

      my $store = ref $s->storage;
      is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage');

      my $parser = $s->storage->datetime_parser;
      is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected');
  }


  # make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
  is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection');
}

### connect, create postgres-specific test schema

my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
my $dbh = $schema->storage->dbh;

drop_test_schema($schema, 'no warn');
create_test_schema($schema);

### begin main tests


# run a BIG bunch of tests for last-insert-id / Auto-PK / sequence
# discovery
run_apk_tests($schema); #< older set of auto-pk tests
run_extended_apk_tests($schema); #< new extended set of auto-pk tests

### type_info tests

my $test_type_info = {
    'artistid' => {
        'data_type' => 'integer',
        'is_nullable' => 0,
        'size' => 4,
    },
    'name' => {
        'data_type' => 'character varying',
        'is_nullable' => 1,
        'size' => 100,
        'default_value' => undef,
    },
    'rank' => {
        'data_type' => 'integer',
        'is_nullable' => 0,
        'size' => 4,
        'default_value' => 13,

    },
    'charfield' => {
        'data_type' => 'character',
        'is_nullable' => 1,
        'size' => 10,
        'default_value' => undef,
    },
    'arrayfield' => {
        'data_type' => 'integer[]',
        'is_nullable' => 1,
        'size' => undef,
        'default_value' => undef,
    },
};

my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist');
my $artistid_defval = delete $type_info->{artistid}->{default_value};
like($artistid_defval,
     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');


####### Array tests

BEGIN {
  package DBICTest::Schema::ArrayTest;
  push @main::test_classes, __PACKAGE__;

  use strict;
  use warnings;
  use base 'DBIx::Class';

  __PACKAGE__->load_components(qw/Core/);
  __PACKAGE__->table('dbic_t_schema.array_test');
  __PACKAGE__->add_columns(qw/id arrayfield/);
  __PACKAGE__->column_info_from_storage(1);
  __PACKAGE__->set_primary_key('id');

}
SKIP: {
  skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002;

  lives_ok {
    $schema->resultset('ArrayTest')->create({
      arrayfield => [1, 2],
    });
  } 'inserting arrayref as pg array data';

  lives_ok {
    $schema->resultset('ArrayTest')->update({
      arrayfield => [3, 4],
    });
  } 'updating arrayref as pg array data';

  $schema->resultset('ArrayTest')->create({
    arrayfield => [5, 6],
  });

  my $count;
  lives_ok {
    $count = $schema->resultset('ArrayTest')->search({
      arrayfield => \[ '= ?' => [arrayfield => [3, 4]] ],   #Todo anything less ugly than this?
    })->count;
  } 'comparing arrayref to pg array data does not blow up';
  is($count, 1, 'comparing arrayref to pg array data gives correct result');
}


########## Case check

BEGIN {
  package DBICTest::Schema::Casecheck;
  push @main::test_classes, __PACKAGE__;

  use strict;
  use warnings;
  use base 'DBIx::Class';

  __PACKAGE__->load_components(qw/Core/);
  __PACKAGE__->table('dbic_t_schema.casecheck');
  __PACKAGE__->add_columns(qw/id name NAME uc_name storecolumn/);
  __PACKAGE__->column_info_from_storage(1);
  __PACKAGE__->set_primary_key('id');

  sub store_column {
    my ($self, $name, $value) = @_;
    $value = '#'.$value if($name eq "storecolumn");
    $self->maybe::next::method($name, $value);
  }
}

# store_column is called once for create() for non sequence columns
ok(my $storecolumn = $schema->resultset('Casecheck')->create({'storecolumn' => 'a'}));
is($storecolumn->storecolumn, '#a'); # was '##a'

my $name_info = $schema->source('Casecheck')->column_info( 'name' );
is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );

my $NAME_info = $schema->source('Casecheck')->column_info( 'NAME' );
is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" );

my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' );
is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );


## Test SELECT ... FOR UPDATE

my $HaveSysSigAction = eval "require Sys::SigAction" && !$@;
if( $HaveSysSigAction ) {
    Sys::SigAction->import( 'set_sig_handler' );
}
SKIP: {
    skip "Sys::SigAction is not available", 3 unless $HaveSysSigAction;
    # create a new schema
    my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
    $schema2->source("Artist")->name("dbic_t_schema.artist");

    $schema->txn_do( sub {
        my $artist = $schema->resultset('Artist')->search(
            {
                artistid => 1
            },
            {
                for => 'update'
            }
        )->first;
        is($artist->artistid, 1, "select for update returns artistid = 1");

        my $artist_from_schema2;
        my $error_ok = 0;
        eval {
            my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
            alarm(2);
            $artist_from_schema2 = $schema2->resultset('Artist')->find(1);
            $artist_from_schema2->name('fooey');
            $artist_from_schema2->update;
            alarm(0);
        };
        if (my $e = $@) {
            $error_ok = $e =~ /DBICTestTimeout/;
        }

        # Make sure that an error was raised, and that the update failed
        ok($error_ok, "update from second schema times out");
        ok($artist_from_schema2->is_column_changed('name'), "'name' column is still dirty from second schema");
    });
}

SKIP: {
    skip "Sys::SigAction is not available", 3 unless $HaveSysSigAction;
    # create a new schema
    my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
    $schema2->source("Artist")->name("dbic_t_schema.artist");

    $schema->txn_do( sub {
        my $artist = $schema->resultset('Artist')->search(
            {
                artistid => 1
            },
        )->first;
        is($artist->artistid, 1, "select for update returns artistid = 1");

        my $artist_from_schema2;
        my $error_ok = 0;
        eval {
            my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
            alarm(2);
            $artist_from_schema2 = $schema2->resultset('Artist')->find(1);
            $artist_from_schema2->name('fooey');
            $artist_from_schema2->update;
            alarm(0);
        };
        if (my $e = $@) {
            $error_ok = $e =~ /DBICTestTimeout/;
        }

        # Make sure that an error was NOT raised, and that the update succeeded
        ok(! $error_ok, "update from second schema DOES NOT timeout");
        ok(! $artist_from_schema2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
    });
}


######## other older Auto-pk tests

$schema->source("SequenceTest")->name("dbic_t_schema.sequence_test");
for (1..5) {
    my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
    is($st->pkid1, $_, "Oracle Auto-PK without trigger: First primary key");
    is($st->pkid2, $_ + 9, "Oracle Auto-PK without trigger: Second primary key");
    is($st->nonpkid, $_ + 19, "Oracle Auto-PK without trigger: Non-primary key");
}
my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");

done_testing;

exit;
END { drop_test_schema($schema) }


######### SUBROUTINES

sub create_test_schema {
    my $schema = shift;
    $schema->storage->dbh_do(sub {
      my (undef,$dbh) = @_;

      local $dbh->{Warn} = 0;

      my $std_artist_table = <<EOS;
(
  artistid serial PRIMARY KEY
  , name VARCHAR(100)
  , rank INTEGER NOT NULL DEFAULT '13'
  , charfield CHAR(10)
  , arrayfield INTEGER[]
)
EOS

      $dbh->do("CREATE SCHEMA dbic_t_schema");
      $dbh->do("CREATE TABLE dbic_t_schema.artist $std_artist_table");
      $dbh->do(<<EOS);
CREATE TABLE dbic_t_schema.sequence_test (
    pkid1 integer
    , pkid2 integer
    , nonpkid integer
    , name VARCHAR(100)
    , CONSTRAINT pk PRIMARY KEY(pkid1, pkid2)
)
EOS
      $dbh->do("CREATE SEQUENCE pkid1_seq START 1 MAXVALUE 999999 MINVALUE 0");
      $dbh->do("CREATE SEQUENCE pkid2_seq START 10 MAXVALUE 999999 MINVALUE 0");
      $dbh->do("CREATE SEQUENCE nonpkid_seq START 20 MAXVALUE 999999 MINVALUE 0");
      $dbh->do(<<EOS);
CREATE TABLE dbic_t_schema.casecheck (
    id serial PRIMARY KEY
    , "name" VARCHAR(1)
    , "NAME" VARCHAR(2)
    , "UC_NAME" VARCHAR(3)
    , "storecolumn" VARCHAR(10)
)
EOS
      $dbh->do(<<EOS);
CREATE TABLE dbic_t_schema.array_test (
    id serial PRIMARY KEY
    , arrayfield INTEGER[]
)
EOS
      $dbh->do("CREATE SCHEMA dbic_t_schema_2");
      $dbh->do("CREATE TABLE dbic_t_schema_2.artist $std_artist_table");
      $dbh->do("CREATE SCHEMA dbic_t_schema_3");
      $dbh->do("CREATE TABLE dbic_t_schema_3.artist $std_artist_table");
      $dbh->do('set search_path=dbic_t_schema,public');
      $dbh->do("CREATE SCHEMA dbic_t_schema_4");
      $dbh->do("CREATE SCHEMA dbic_t_schema_5");
      $dbh->do(<<EOS);
 CREATE TABLE dbic_t_schema_4.artist
 (
   artistid integer not null default nextval('artist_artistid_seq'::regclass) PRIMARY KEY
   , name VARCHAR(100)
   , rank INTEGER NOT NULL DEFAULT '13'
   , charfield CHAR(10)
   , arrayfield INTEGER[]
 );
EOS
      $dbh->do('set search_path=public,dbic_t_schema,dbic_t_schema_3');
      $dbh->do('create sequence public.artist_artistid_seq'); #< in the public schema
      $dbh->do(<<EOS);
 CREATE TABLE dbic_t_schema_5.artist
 (
   artistid integer not null default nextval('public.artist_artistid_seq'::regclass) PRIMARY KEY
   , name VARCHAR(100)
   , rank INTEGER NOT NULL DEFAULT '13'
   , charfield CHAR(10)
   , arrayfield INTEGER[]
 );
EOS
      $dbh->do('set search_path=dbic_t_schema,public');
  });
}


sub drop_test_schema {
    my ( $schema, $no_warn ) = @_;

    $schema->storage->dbh_do(sub {
        my (undef,$dbh) = @_;

        local $dbh->{Warn} = 0;

        for my $stat (
                      'DROP SCHEMA dbic_t_schema_5 CASCADE',
                      'DROP SEQUENCE public.artist_artistid_seq',
                      'DROP SCHEMA dbic_t_schema_4 CASCADE',
                      'DROP SCHEMA dbic_t_schema CASCADE',
                      'DROP SEQUENCE pkid1_seq',
                      'DROP SEQUENCE pkid2_seq',
                      'DROP SEQUENCE nonpkid_seq',
                      'DROP SCHEMA dbic_t_schema_2 CASCADE',
                      'DROP SCHEMA dbic_t_schema_3 CASCADE',
                     ) {
            eval { $dbh->do ($stat) };
            diag $@ if $@ && !$no_warn;
        }
    });
}


###  auto-pk / last_insert_id / sequence discovery
sub run_apk_tests {
    my $schema = shift;

    # This is in Core now, but it's here just to test that it doesn't break
    $schema->class('Artist')->load_components('PK::Auto');
    cmp_ok( $schema->resultset('Artist')->count, '==', 0, 'this should start with an empty artist table');

    # test that auto-pk also works with the defined search path by
    # un-schema-qualifying the table name
    apk_t_set($schema,'artist');

    my $unq_new;
    lives_ok {
        $unq_new = $schema->resultset('Artist')->create({ name => 'baz' });
    } 'insert into unqualified, shadowed table succeeds';

    is($unq_new && $unq_new->artistid, 1, "and got correct artistid");

    my @test_schemas = ( [qw| dbic_t_schema_2    1  |],
                         [qw| dbic_t_schema_3    1  |],
                         [qw| dbic_t_schema_4    2  |],
                         [qw| dbic_t_schema_5    1  |],
                       );
    foreach my $t ( @test_schemas ) {
        my ($sch_name, $start_num) = @$t;
        #test with dbic_t_schema_2
        apk_t_set($schema,"$sch_name.artist");
        my $another_new;
        lives_ok {
            $another_new = $schema->resultset('Artist')->create({ name => 'Tollbooth Willy'});
            is( $another_new->artistid,$start_num, "got correct artistid for $sch_name")
                or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>');
        } "$sch_name liid 1 did not die"
            or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>');
        lives_ok {
            $another_new = $schema->resultset('Artist')->create({ name => 'Adam Sandler'});
            is( $another_new->artistid,$start_num+1, "got correct artistid for $sch_name")
                or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>');
        } "$sch_name liid 2 did not die"
            or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>');

    }

    lives_ok {
        apk_t_set($schema,'dbic_t_schema.artist');
        my $new = $schema->resultset('Artist')->create({ name => 'foo' });
        is($new->artistid, 4, "Auto-PK worked");
        $new = $schema->resultset('Artist')->create({ name => 'bar' });
        is($new->artistid, 5, "Auto-PK worked");
    } 'old auto-pk tests did not die either';


}


# sets the artist table name and clears sequence name cache
sub apk_t_set {
    my ( $s, $n ) = @_;
    $s->source("Artist")->name($n);
    $s->source('Artist')->column_info('artistid')->{sequence} = undef; #< clear sequence name cache
}


sub run_extended_apk_tests {
    my $schema = shift;

    drop_ext_apk_test_schema($schema);
    create_ext_apk_test_schema($schema);


    # drop our auto-pk test schema
    drop_ext_apk_test_schema($schema);
}

sub create_ext_apk_test_schema {
    my $schema = shift;
    $schema->storage->dbh_do(sub {
      my (undef,$dbh) = @_;

      local $dbh->{Warn} = 0;

    });
}

sub drop_ext_apk_test_schema {
    my ( $schema, $no_warn ) = @_;

    $schema->storage->dbh_do(sub {
        my (undef,$dbh) = @_;

        local $dbh->{Warn} = 0;

        for my $stat (
                      ()
                     ) {
            eval { $dbh->do ($stat) };
            diag $@ if $@ && !$no_warn;
        }
    });
}
Commit	Line	Data
70350518	1	use strict;
4617b792	2	use warnings;
70350518	3
70350518	4	use Test::More;
9ba627e3	5	use Test::Exception;
70350518	6	use lib qw(t/lib);
	7	use DBICTest;
	8
89add887	9
0567538f	10	my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
0567538f	11
609c5f1b	12	plan skip_all => <<EOM unless $dsn && $user;
	13	Set \$ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test
	14	( NOTE: This test drops and creates tables called 'artist', 'casecheck',
	15	'array_test' and 'sequence_test' as well as following sequences:
	16	'pkid1_seq', 'pkid2_seq' and 'nonpkid_seq''. as well as following
881def48	17	schemas: 'dbic_t_schema', 'dbic_t_schema_2', 'dbic_t_schema_3',
881def48	18	'dbic_t_schema_4', and 'dbic_t_schema_5'
609c5f1b	19	)
609c5f1b	20	EOM
0567538f	21
70a201a5	22	### load any test classes that are defined further down in the file
efd38994	23
70a201a5	24	our @test_classes; #< array that will be pushed into by test classes defined in this file
70a201a5	25	DBICTest::Schema->load_classes( map {s/.+:://;$_} @test_classes ) if @test_classes;
efd38994	26
efd38994	27
70a201a5	28	### pre-connect tests
eabde904	29	{
70a201a5	30	my $s = DBICTest::Schema->connect($dsn, $user, $pass);
eabde904	31
70a201a5	32	ok (!$s->storage->_dbh, 'definitely not connected');
eabde904	33
70a201a5	34	# Check that datetime_parser returns correctly before we explicitly connect.
	35	SKIP: {
	36	eval { require DateTime::Format::Pg };
	37	skip "DateTime::Format::Pg required", 2 if $@;
114780ee	38
70a201a5	39	my $store = ref $s->storage;
70a201a5	40	is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage');
114780ee	41
70a201a5	42	my $parser = $s->storage->datetime_parser;
	43	is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected');
	44	}
114780ee	45
609c5f1b	46
70a201a5	47	# make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
70a201a5	48	is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection');
bb452615	49	}
0567538f	50
70a201a5	51	### connect, create postgres-specific test schema
c3af542a	52
70a201a5	53	my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
70a201a5	54	my $dbh = $schema->storage->dbh;
c3af542a	55
2fbf50ff	56	drop_test_schema($schema, 'no warn');
2fbf50ff	57	create_test_schema($schema);
609c5f1b	58
70a201a5	59	### begin main tests
4617b792	60
b6b65a3e	61
372da819	62	# run a BIG bunch of tests for last-insert-id / Auto-PK / sequence
	63	# discovery
	64	run_apk_tests($schema); #< older set of auto-pk tests
	65	run_extended_apk_tests($schema); #< new extended set of auto-pk tests
70a201a5	66
	67	### type_info tests
	68
a953d8d9	69	my $test_type_info = {
a953d8d9	70	'artistid' => {
103e3e03	71	'data_type' => 'integer',
103e3e03	72	'is_nullable' => 0,
fc22fbac	73	'size' => 4,
a953d8d9	74	},
a953d8d9	75	'name' => {
103e3e03	76	'data_type' => 'character varying',
103e3e03	77	'is_nullable' => 1,
ae515736	78	'size' => 100,
fc22fbac	79	'default_value' => undef,
103e3e03	80	},
85df19d7	81	'rank' => {
	82	'data_type' => 'integer',
	83	'is_nullable' => 0,
	84	'size' => 4,
	85	'default_value' => 13,
	86
	87	},
103e3e03	88	'charfield' => {
103e3e03	89	'data_type' => 'character',
a953d8d9	90	'is_nullable' => 1,
fc22fbac	91	'size' => 10,
fc22fbac	92	'default_value' => undef,
103e3e03	93	},
9ba627e3	94	'arrayfield' => {
	95	'data_type' => 'integer[]',
	96	'is_nullable' => 1,
	97	'size' => undef,
	98	'default_value' => undef,
	99	},
a953d8d9	100	};
a953d8d9	101
881def48	102	my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist');
fc22fbac	103	my $artistid_defval = delete $type_info->{artistid}->{default_value};
fc22fbac	104	like($artistid_defval,
4d272ce5	105	qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text\|regclass)\)/,
fc22fbac	106	'columns_info_for - sequence matches Pg get_autoinc_seq expectations');
	107	is_deeply($type_info, $test_type_info,
	108	'columns_info_for - column data types');
a953d8d9	109
70a201a5	110
	111
	112
	113	####### Array tests
	114
	115	BEGIN {
	116	package DBICTest::Schema::ArrayTest;
	117	push @main::test_classes, __PACKAGE__;
	118
	119	use strict;
	120	use warnings;
	121	use base 'DBIx::Class';
	122
	123	__PACKAGE__->load_components(qw/Core/);
881def48	124	__PACKAGE__->table('dbic_t_schema.array_test');
70a201a5	125	__PACKAGE__->add_columns(qw/id arrayfield/);
	126	__PACKAGE__->column_info_from_storage(1);
	127	__PACKAGE__->set_primary_key('id');
	128
	129	}
ac45262b	130	SKIP: {
	131	skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002;
	132
9ba627e3	133	lives_ok {
	134	$schema->resultset('ArrayTest')->create({
	135	arrayfield => [1, 2],
	136	});
	137	} 'inserting arrayref as pg array data';
	138
	139	lives_ok {
	140	$schema->resultset('ArrayTest')->update({
	141	arrayfield => [3, 4],
	142	});
	143	} 'updating arrayref as pg array data';
c224117b	144
	145	$schema->resultset('ArrayTest')->create({
	146	arrayfield => [5, 6],
	147	});
	148
	149	my $count;
	150	lives_ok {
	151	$count = $schema->resultset('ArrayTest')->search({
aab0d3b7	152	arrayfield => \[ '= ?' => [arrayfield => [3, 4]] ], #Todo anything less ugly than this?
c224117b	153	})->count;
	154	} 'comparing arrayref to pg array data does not blow up';
	155	is($count, 1, 'comparing arrayref to pg array data gives correct result');
9ba627e3	156	}
	157
	158
70a201a5	159
	160	########## Case check
	161
	162	BEGIN {
	163	package DBICTest::Schema::Casecheck;
	164	push @main::test_classes, __PACKAGE__;
	165
	166	use strict;
	167	use warnings;
	168	use base 'DBIx::Class';
	169
	170	__PACKAGE__->load_components(qw/Core/);
881def48	171	__PACKAGE__->table('dbic_t_schema.casecheck');
70a201a5	172	__PACKAGE__->add_columns(qw/id name NAME uc_name storecolumn/);
	173	__PACKAGE__->column_info_from_storage(1);
	174	__PACKAGE__->set_primary_key('id');
	175
	176	sub store_column {
	177	my ($self, $name, $value) = @_;
	178	$value = '#'.$value if($name eq "storecolumn");
	179	$self->maybe::next::method($name, $value);
	180	}
	181	}
	182
efd38994	183	# store_column is called once for create() for non sequence columns
	184	ok(my $storecolumn = $schema->resultset('Casecheck')->create({'storecolumn' => 'a'}));
	185	is($storecolumn->storecolumn, '#a'); # was '##a'
	186
3ff5b740	187	my $name_info = $schema->source('Casecheck')->column_info( 'name' );
ae515736	188	is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
ae515736	189
3ff5b740	190	my $NAME_info = $schema->source('Casecheck')->column_info( 'NAME' );
ae515736	191	is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" );
ae515736	192
3ff5b740	193	my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' );
ae515736	194	is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
ae515736	195
70a201a5	196
	197
	198
	199	## Test SELECT ... FOR UPDATE
	200
95ba7ee4	201	my $HaveSysSigAction = eval "require Sys::SigAction" && !$@;
70a201a5	202	if( $HaveSysSigAction ) {
95ba7ee4	203	Sys::SigAction->import( 'set_sig_handler' );
95ba7ee4	204	}
95ba7ee4	205	SKIP: {
	206	skip "Sys::SigAction is not available", 3 unless $HaveSysSigAction;
	207	# create a new schema
	208	my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
881def48	209	$schema2->source("Artist")->name("dbic_t_schema.artist");
95ba7ee4	210
	211	$schema->txn_do( sub {
	212	my $artist = $schema->resultset('Artist')->search(
	213	{
	214	artistid => 1
	215	},
	216	{
	217	for => 'update'
	218	}
	219	)->first;
	220	is($artist->artistid, 1, "select for update returns artistid = 1");
	221
	222	my $artist_from_schema2;
	223	my $error_ok = 0;
	224	eval {
	225	my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
	226	alarm(2);
	227	$artist_from_schema2 = $schema2->resultset('Artist')->find(1);
	228	$artist_from_schema2->name('fooey');
	229	$artist_from_schema2->update;
	230	alarm(0);
	231	};
	232	if (my $e = $@) {
	233	$error_ok = $e =~ /DBICTestTimeout/;
	234	}
	235
	236	# Make sure that an error was raised, and that the update failed
	237	ok($error_ok, "update from second schema times out");
	238	ok($artist_from_schema2->is_column_changed('name'), "'name' column is still dirty from second schema");
	239	});
	240	}
	241
	242	SKIP: {
	243	skip "Sys::SigAction is not available", 3 unless $HaveSysSigAction;
	244	# create a new schema
	245	my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
881def48	246	$schema2->source("Artist")->name("dbic_t_schema.artist");
95ba7ee4	247
	248	$schema->txn_do( sub {
	249	my $artist = $schema->resultset('Artist')->search(
	250	{
	251	artistid => 1
	252	},
	253	)->first;
	254	is($artist->artistid, 1, "select for update returns artistid = 1");
	255
	256	my $artist_from_schema2;
	257	my $error_ok = 0;
	258	eval {
	259	my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
	260	alarm(2);
	261	$artist_from_schema2 = $schema2->resultset('Artist')->find(1);
	262	$artist_from_schema2->name('fooey');
	263	$artist_from_schema2->update;
	264	alarm(0);
	265	};
	266	if (my $e = $@) {
	267	$error_ok = $e =~ /DBICTestTimeout/;
	268	}
	269
	270	# Make sure that an error was NOT raised, and that the update succeeded
	271	ok(! $error_ok, "update from second schema DOES NOT timeout");
	272	ok(! $artist_from_schema2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
	273	});
	274	}
	275
70a201a5	276
372da819	277	######## other older Auto-pk tests
70a201a5	278
881def48	279	$schema->source("SequenceTest")->name("dbic_t_schema.sequence_test");
d093d3eb	280	for (1..5) {
39b8d119	281	my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
	282	is($st->pkid1, $_, "Oracle Auto-PK without trigger: First primary key");
	283	is($st->pkid2, $_ + 9, "Oracle Auto-PK without trigger: Second primary key");
	284	is($st->nonpkid, $_ + 19, "Oracle Auto-PK without trigger: Non-primary key");
d093d3eb	285	}
	286	my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
	287	is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
	288
2fbf50ff	289	done_testing;
609c5f1b	290
70a201a5	291	exit;
2fbf50ff	292	END { drop_test_schema($schema) }
70a201a5	293
	294
	295	######### SUBROUTINES
	296
	297	sub create_test_schema {
2fbf50ff	298	my $schema = shift;
	299	$schema->storage->dbh_do(sub {
	300	my (undef,$dbh) = @_;
70a201a5	301
2fbf50ff	302	local $dbh->{Warn} = 0;
70a201a5	303
2fbf50ff	304	my $std_artist_table = <<EOS;
70a201a5	305	(
	306	artistid serial PRIMARY KEY
	307	, name VARCHAR(100)
	308	, rank INTEGER NOT NULL DEFAULT '13'
	309	, charfield CHAR(10)
	310	, arrayfield INTEGER[]
	311	)
	312	EOS
	313
881def48	314	$dbh->do("CREATE SCHEMA dbic_t_schema");
881def48	315	$dbh->do("CREATE TABLE dbic_t_schema.artist $std_artist_table");
2fbf50ff	316	$dbh->do(<<EOS);
881def48	317	CREATE TABLE dbic_t_schema.sequence_test (
70a201a5	318	pkid1 integer
	319	, pkid2 integer
	320	, nonpkid integer
	321	, name VARCHAR(100)
	322	, CONSTRAINT pk PRIMARY KEY(pkid1, pkid2)
	323	)
	324	EOS
2fbf50ff	325	$dbh->do("CREATE SEQUENCE pkid1_seq START 1 MAXVALUE 999999 MINVALUE 0");
	326	$dbh->do("CREATE SEQUENCE pkid2_seq START 10 MAXVALUE 999999 MINVALUE 0");
	327	$dbh->do("CREATE SEQUENCE nonpkid_seq START 20 MAXVALUE 999999 MINVALUE 0");
	328	$dbh->do(<<EOS);
881def48	329	CREATE TABLE dbic_t_schema.casecheck (
70a201a5	330	id serial PRIMARY KEY
	331	, "name" VARCHAR(1)
	332	, "NAME" VARCHAR(2)
	333	, "UC_NAME" VARCHAR(3)
	334	, "storecolumn" VARCHAR(10)
	335	)
	336	EOS
2fbf50ff	337	$dbh->do(<<EOS);
881def48	338	CREATE TABLE dbic_t_schema.array_test (
70a201a5	339	id serial PRIMARY KEY
	340	, arrayfield INTEGER[]
	341	)
	342	EOS
881def48	343	$dbh->do("CREATE SCHEMA dbic_t_schema_2");
	344	$dbh->do("CREATE TABLE dbic_t_schema_2.artist $std_artist_table");
	345	$dbh->do("CREATE SCHEMA dbic_t_schema_3");
	346	$dbh->do("CREATE TABLE dbic_t_schema_3.artist $std_artist_table");
	347	$dbh->do('set search_path=dbic_t_schema,public');
	348	$dbh->do("CREATE SCHEMA dbic_t_schema_4");
	349	$dbh->do("CREATE SCHEMA dbic_t_schema_5");
2fbf50ff	350	$dbh->do(<<EOS);
881def48	351	CREATE TABLE dbic_t_schema_4.artist
70a201a5	352	(
	353	artistid integer not null default nextval('artist_artistid_seq'::regclass) PRIMARY KEY
	354	, name VARCHAR(100)
	355	, rank INTEGER NOT NULL DEFAULT '13'
	356	, charfield CHAR(10)
	357	, arrayfield INTEGER[]
	358	);
	359	EOS
881def48	360	$dbh->do('set search_path=public,dbic_t_schema,dbic_t_schema_3');
2fbf50ff	361	$dbh->do('create sequence public.artist_artistid_seq'); #< in the public schema
2fbf50ff	362	$dbh->do(<<EOS);
881def48	363	CREATE TABLE dbic_t_schema_5.artist
70a201a5	364	(
	365	artistid integer not null default nextval('public.artist_artistid_seq'::regclass) PRIMARY KEY
	366	, name VARCHAR(100)
	367	, rank INTEGER NOT NULL DEFAULT '13'
	368	, charfield CHAR(10)
	369	, arrayfield INTEGER[]
	370	);
	371	EOS
881def48	372	$dbh->do('set search_path=dbic_t_schema,public');
2fbf50ff	373	});
70a201a5	374	}
	375
	376
	377
	378	sub drop_test_schema {
2fbf50ff	379	my ( $schema, $no_warn ) = @_;
	380
	381	$schema->storage->dbh_do(sub {
	382	my (undef,$dbh) = @_;
	383
	384	local $dbh->{Warn} = 0;
	385
	386	for my $stat (
881def48	387	'DROP SCHEMA dbic_t_schema_5 CASCADE',
2fbf50ff	388	'DROP SEQUENCE public.artist_artistid_seq',
881def48	389	'DROP SCHEMA dbic_t_schema_4 CASCADE',
881def48	390	'DROP SCHEMA dbic_t_schema CASCADE',
2fbf50ff	391	'DROP SEQUENCE pkid1_seq',
	392	'DROP SEQUENCE pkid2_seq',
	393	'DROP SEQUENCE nonpkid_seq',
881def48	394	'DROP SCHEMA dbic_t_schema_2 CASCADE',
881def48	395	'DROP SCHEMA dbic_t_schema_3 CASCADE',
2fbf50ff	396	) {
	397	eval { $dbh->do ($stat) };
	398	diag $@ if $@ && !$no_warn;
	399	}
	400	});
3ff5b740	401	}
7603d2a5	402
372da819	403
ee9f372c	404	### auto-pk / last_insert_id / sequence discovery
	405	sub run_apk_tests {
	406	my $schema = shift;
	407
	408	# This is in Core now, but it's here just to test that it doesn't break
	409	$schema->class('Artist')->load_components('PK::Auto');
	410	cmp_ok( $schema->resultset('Artist')->count, '==', 0, 'this should start with an empty artist table');
	411
	412	# test that auto-pk also works with the defined search path by
	413	# un-schema-qualifying the table name
	414	apk_t_set($schema,'artist');
	415
	416	my $unq_new;
	417	lives_ok {
	418	$unq_new = $schema->resultset('Artist')->create({ name => 'baz' });
	419	} 'insert into unqualified, shadowed table succeeds';
	420
	421	is($unq_new && $unq_new->artistid, 1, "and got correct artistid");
	422
	423	my @test_schemas = ( [qw\| dbic_t_schema_2 1 \|],
	424	[qw\| dbic_t_schema_3 1 \|],
	425	[qw\| dbic_t_schema_4 2 \|],
	426	[qw\| dbic_t_schema_5 1 \|],
	427	);
	428	foreach my $t ( @test_schemas ) {
	429	my ($sch_name, $start_num) = @$t;
	430	#test with dbic_t_schema_2
	431	apk_t_set($schema,"$sch_name.artist");
	432	my $another_new;
	433	lives_ok {
	434	$another_new = $schema->resultset('Artist')->create({ name => 'Tollbooth Willy'});
	435	is( $another_new->artistid,$start_num, "got correct artistid for $sch_name")
	436	or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} \|\| '<none>');
	437	} "$sch_name liid 1 did not die"
	438	or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} \|\| '<none>');
	439	lives_ok {
	440	$another_new = $schema->resultset('Artist')->create({ name => 'Adam Sandler'});
	441	is( $another_new->artistid,$start_num+1, "got correct artistid for $sch_name")
	442	or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} \|\| '<none>');
	443	} "$sch_name liid 2 did not die"
	444	or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} \|\| '<none>');
	445
	446	}
	447
	448	lives_ok {
	449	apk_t_set($schema,'dbic_t_schema.artist');
	450	my $new = $schema->resultset('Artist')->create({ name => 'foo' });
	451	is($new->artistid, 4, "Auto-PK worked");
	452	$new = $schema->resultset('Artist')->create({ name => 'bar' });
	453	is($new->artistid, 5, "Auto-PK worked");
	454	} 'old auto-pk tests did not die either';
372da819	455
372da819	456
ee9f372c	457	}
	458
	459
	460	# sets the artist table name and clears sequence name cache
	461	sub apk_t_set {
	462	my ( $s, $n ) = @_;
	463	$s->source("Artist")->name($n);
	464	$s->source('Artist')->column_info('artistid')->{sequence} = undef; #< clear sequence name cache
	465	}
	466
372da819	467
	468	sub run_extended_apk_tests {
	469	my $schema = shift;
	470
	471	drop_ext_apk_test_schema($schema);
	472	create_ext_apk_test_schema($schema);
	473
	474
	475
	476	# drop our auto-pk test schema
	477	drop_ext_apk_test_schema($schema);
	478	}
	479
	480	sub create_ext_apk_test_schema {
	481	my $schema = shift;
	482	$schema->storage->dbh_do(sub {
	483	my (undef,$dbh) = @_;
	484
	485	local $dbh->{Warn} = 0;
	486
	487	});
	488	}
	489
	490	sub drop_ext_apk_test_schema {
	491	my ( $schema, $no_warn ) = @_;
	492
	493	$schema->storage->dbh_do(sub {
	494	my (undef,$dbh) = @_;
	495
	496	local $dbh->{Warn} = 0;
	497
	498	for my $stat (
	499	()
	500	) {
	501	eval { $dbh->do ($stat) };
	502	diag $@ if $@ && !$no_warn;
	503	}
	504	});
	505	}