Codebase list libdbix-class-perl / ba87cba
[svn-upgrade] Integrating new upstream version, libdbix-class-perl (0.08121) Jonathan Yu 14 years ago
305 changed file(s) with 14510 addition(s) and 11814 deletion(s). Raw diff Collapse all Expand all
+35
-0
Changes less more
00 Revision history for DBIx::Class
1
2 0.08121 2010-04-11 18:43:00 (UTC)
3 - Support for Firebird RDBMS with DBD::InterBase and ODBC
4 - Add core support for INSERT RETURNING (for storages that
5 supports this syntax, currently PostgreSQL and Firebird)
6 - Fix spurious warnings on multiple UTF8Columns component loads
7 - DBIx::Class::UTF8Columns entered deprecated state
8 - DBIx::Class::InflateColumn::File entered deprecated state
9 - DBIx::Class::Optional::Dependencies left experimental state
10 - Add req_group_list to Opt::Deps (RT#55211)
11 - Add support for mysql-specific STRAIGHT_JOIN (RT#55579)
12 - Cascading delete/update are now wrapped in a transaction
13 for atomicity
14 - Fix accidental autovivification of ENV vars
15 - Fix update_all and delete_all to be wrapped in a transaction
16 - Fix multiple deficiencies when using MultiCreate with
17 data-encoder components (e.g. ::EncodedColumn)
18 - Fix regression where SQL files with comments were not
19 handled properly by ::Schema::Versioned.
20 - Fix regression on not properly throwing when $obj->relationship
21 is unresolvable
22 - Fix the join-optimiser to consider unqualified column names
23 whenever possible
24 - Fix an issue with multiple same-table joins confusing the join
25 optimizier
26 - Add has_relationship method to row objects
27 - Fix regression in set_column on PK-less objects
28 - Better error text on malformed/missing relationships
29 - Add POD about the significance of PK columns
30 - Fix for SQLite to ignore the (unsupported) { for => ... }
31 attribute
32 - Fix ambiguity in default directory handling of create_ddl_dir
33 (RT#54063)
34 - Support add_columns('+colname' => { ... }) to augment column
35 definitions.
136
237 0.08120 2010-02-24 08:58:00 (UTC)
338 - Make sure possibly overwritten deployment_statements methods in
+12
-0
MANIFEST less more
110110 lib/DBIx/Class/SQLAHacks/MSSQL.pm
111111 lib/DBIx/Class/SQLAHacks/MySQL.pm
112112 lib/DBIx/Class/SQLAHacks/OracleJoins.pm
113 lib/DBIx/Class/SQLAHacks/SQLite.pm
113114 lib/DBIx/Class/StartupCheck.pm
114115 lib/DBIx/Class/Storage.pm
115116 lib/DBIx/Class/Storage/DBI.pm
119120 lib/DBIx/Class/Storage/DBI/Cursor.pm
120121 lib/DBIx/Class/Storage/DBI/DB2.pm
121122 lib/DBIx/Class/Storage/DBI/Informix.pm
123 lib/DBIx/Class/Storage/DBI/InterBase.pm
122124 lib/DBIx/Class/Storage/DBI/MSSQL.pm
123125 lib/DBIx/Class/Storage/DBI/MultiColumnIn.pm
124126 lib/DBIx/Class/Storage/DBI/mysql.pm
126128 lib/DBIx/Class/Storage/DBI/ODBC.pm
127129 lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm
128130 lib/DBIx/Class/Storage/DBI/ODBC/DB2_400_SQL.pm
131 lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm
129132 lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm
130133 lib/DBIx/Class/Storage/DBI/ODBC/SQL_Anywhere.pm
131134 lib/DBIx/Class/Storage/DBI/Oracle.pm
150153 lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm
151154 lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server/NoBindVars.pm
152155 lib/DBIx/Class/Storage/DBI/Sybase/MSSQL.pm
156 lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm
153157 lib/DBIx/Class/Storage/DBIHacks.pm
154158 lib/DBIx/Class/Storage/Statistics.pm
155159 lib/DBIx/Class/Storage/TxnScopeGuard.pm
214218 t/748informix.t
215219 t/749sybase_asa.t
216220 t/74mssql.t
221 t/750firebird.t
217222 t/75limit.t
218223 t/76joins.t
219224 t/76select.t
325330 t/inflate/core.t
326331 t/inflate/datetime.t
327332 t/inflate/datetime_determine_parser.t
333 t/inflate/datetime_firebird.t
334 t/inflate/datetime_informix.t
328335 t/inflate/datetime_mssql.t
329336 t/inflate/datetime_mysql.t
330337 t/inflate/datetime_oracle.t
414421 t/lib/DBICTest/Schema/SequenceTest.pm
415422 t/lib/DBICTest/Schema/Serialized.pm
416423 t/lib/DBICTest/Schema/Tag.pm
424 t/lib/DBICTest/Schema/TimestampPrimaryKey.pm
417425 t/lib/DBICTest/Schema/Track.pm
418426 t/lib/DBICTest/Schema/TreeLike.pm
419427 t/lib/DBICTest/Schema/TwoKeys.pm
459467 t/relationship/after_update.t
460468 t/relationship/core.t
461469 t/relationship/doesnt_exist.t
470 t/relationship/unresolvable.t
462471 t/relationship/update_or_create_multi.t
463472 t/relationship/update_or_create_single.t
464473 t/resultset/as_query.t
470479 t/resultset/update_delete.t
471480 t/resultset_class.t
472481 t/resultset_overload.t
482 t/row/inflate_result.t
483 t/row/pkless.t
473484 t/schema/anon.t
474485 t/schema/clone.t
475486 t/search/preserve_original_rs.t
481492 t/sqlahacks/quotes/quotes_newstyle.t
482493 t/sqlahacks/sql_maker/sql_maker.t
483494 t/sqlahacks/sql_maker/sql_maker_quote.t
495 t/sqlahacks/sqlite.t
484496 t/storage/base.t
485497 t/storage/dbh_do.t
486498 t/storage/dbi_coderef.t
+3
-3
META.yml less more
1111 configure_requires:
1212 ExtUtils::MakeMaker: 6.42
1313 distribution_type: module
14 generated_by: 'Module::Install version 0.93'
14 generated_by: 'Module::Install version 0.95'
1515 license: perl
1616 meta-spec:
1717 url: http://module-build.sourceforge.net/META-spec-v1.4.html
4141 MRO::Compat: 0.09
4242 Module::Find: 0.06
4343 Path::Class: 0.18
44 SQL::Abstract: 1.61
44 SQL::Abstract: 1.64
4545 SQL::Abstract::Limit: 0.13
4646 Scope::Guard: 0.03
4747 Sub::Name: 0.04
5151 MailingList: http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class
5252 license: http://dev.perl.org/licenses/
5353 repository: http://dev.catalyst.perl.org/repos/bast/DBIx-Class/
54 version: 0.08120
54 version: 0.08121
+2
-2
Makefile.PL less more
4444 'MRO::Compat' => '0.09',
4545 'Module::Find' => '0.06',
4646 'Path::Class' => '0.18',
47 'SQL::Abstract' => '1.61',
47 'SQL::Abstract' => '1.64',
4848 'SQL::Abstract::Limit' => '0.13',
4949 'Sub::Name' => '0.04',
5050 'Data::Dumper::Concise' => '1.000',
7777 require DBIx::Class::Optional::Dependencies;
7878 $reqs->{test_requires} = {
7979 %{$reqs->{test_requires}},
80 %{DBIx::Class::Optional::Dependencies->_all_optional_requirements},
80 map { %$_ } (values %{DBIx::Class::Optional::Dependencies->req_group_list}),
8181 };
8282 }
8383
+9
-2
README less more
33 GETTING HELP/SUPPORT
44 The community can be found via:
55
6 * IRC: <irc.perl.org#dbix-class (click for instant chatroom login) >
6 * IRC: irc.perl.org#dbix-class (click for instant chatroom login)
7 <http://mibbit.com/chat/#dbix-class@irc.perl.org>
78
89 * Mailing list: <http://lists.scsys.co.uk/mailman/listinfo/dbix-class>
910
159160 heading is traditional :)
160161
161162 CONTRIBUTORS
162 abraxxa: Alexander Hartmaier <alex_hartmaier@hotmail.com>
163 abraxxa: Alexander Hartmaier <abraxxa@cpan.org>
163164
164165 aherzog: Adam Herzog <adam@herzogdesigns.com>
165166
167 amoore: Andrew Moore <amoore@cpan.org>
168
166169 andyg: Andy Grundman <andy@hybridized.org>
167170
168171 ank: Andres Kievsky
201204
202205 dnm: Justin Wheeler <jwheeler@datademons.com>
203206
207 dpetrov: Dimitar Petrov <mitakaa@gmail.com>
208
204209 dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
205210
206211 dyfrgi: Michael Leuchtenburg <michael@slashhome.org>
212217 gphat: Cory G Watson <gphat@cpan.org>
213218
214219 groditi: Guillermo Roditi <groditi@cpan.org>
220
221 hobbs: Andrew Rodland <arodland@cpan.org>
215222
216223 ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
217224
+5
-5
examples/Schema/MyDatabase/Main.pm less more
0 package MyDatabase::Main;
1 use base qw/DBIx::Class::Schema/;
2 __PACKAGE__->load_namespaces;
3
4 1;
0 package MyDatabase::Main;
1 use base qw/DBIx::Class::Schema/;
2 __PACKAGE__->load_namespaces;
3
4 1;
+59
-59
examples/Schema/insertdb.pl less more
0 #!/usr/bin/perl -w
1
2 use MyDatabase::Main;
3 use strict;
4
5 my $schema = MyDatabase::Main->connect('dbi:SQLite:db/example.db');
6
7 # here's some of the sql that is going to be generated by the schema
8 # INSERT INTO artist VALUES (NULL,'Michael Jackson');
9 # INSERT INTO artist VALUES (NULL,'Eminem');
10
11 my @artists = (['Michael Jackson'], ['Eminem']);
12 $schema->populate('Artist', [
13 [qw/name/],
14 @artists,
15 ]);
16
17 my %albums = (
18 'Thriller' => 'Michael Jackson',
19 'Bad' => 'Michael Jackson',
20 'The Marshall Mathers LP' => 'Eminem',
21 );
22
23 my @cds;
24 foreach my $lp (keys %albums) {
25 my $artist = $schema->resultset('Artist')->find({
26 name => $albums{$lp}
27 });
28 push @cds, [$lp, $artist->id];
29 }
30
31 $schema->populate('Cd', [
32 [qw/title artist/],
33 @cds,
34 ]);
35
36
37 my %tracks = (
38 'Beat It' => 'Thriller',
39 'Billie Jean' => 'Thriller',
40 'Dirty Diana' => 'Bad',
41 'Smooth Criminal' => 'Bad',
42 'Leave Me Alone' => 'Bad',
43 'Stan' => 'The Marshall Mathers LP',
44 'The Way I Am' => 'The Marshall Mathers LP',
45 );
46
47 my @tracks;
48 foreach my $track (keys %tracks) {
49 my $cd = $schema->resultset('Cd')->find({
50 title => $tracks{$track},
51 });
52 push @tracks, [$cd->id, $track];
53 }
54
55 $schema->populate('Track',[
56 [qw/cd title/],
57 @tracks,
58 ]);
0 #!/usr/bin/perl -w
1
2 use MyDatabase::Main;
3 use strict;
4
5 my $schema = MyDatabase::Main->connect('dbi:SQLite:db/example.db');
6
7 # here's some of the sql that is going to be generated by the schema
8 # INSERT INTO artist VALUES (NULL,'Michael Jackson');
9 # INSERT INTO artist VALUES (NULL,'Eminem');
10
11 my @artists = (['Michael Jackson'], ['Eminem']);
12 $schema->populate('Artist', [
13 [qw/name/],
14 @artists,
15 ]);
16
17 my %albums = (
18 'Thriller' => 'Michael Jackson',
19 'Bad' => 'Michael Jackson',
20 'The Marshall Mathers LP' => 'Eminem',
21 );
22
23 my @cds;
24 foreach my $lp (keys %albums) {
25 my $artist = $schema->resultset('Artist')->find({
26 name => $albums{$lp}
27 });
28 push @cds, [$lp, $artist->id];
29 }
30
31 $schema->populate('Cd', [
32 [qw/title artist/],
33 @cds,
34 ]);
35
36
37 my %tracks = (
38 'Beat It' => 'Thriller',
39 'Billie Jean' => 'Thriller',
40 'Dirty Diana' => 'Bad',
41 'Smooth Criminal' => 'Bad',
42 'Leave Me Alone' => 'Bad',
43 'Stan' => 'The Marshall Mathers LP',
44 'The Way I Am' => 'The Marshall Mathers LP',
45 );
46
47 my @tracks;
48 foreach my $track (keys %tracks) {
49 my $cd = $schema->resultset('Cd')->find({
50 title => $tracks{$track},
51 });
52 push @tracks, [$cd->id, $track];
53 }
54
55 $schema->populate('Track',[
56 [qw/cd title/],
57 @tracks,
58 ]);
+122
-122
examples/Schema/testdb.pl less more
0 #!/usr/bin/perl -w
1
2 use MyDatabase::Main;
3 use strict;
4
5 my $schema = MyDatabase::Main->connect('dbi:SQLite:db/example.db');
6 # for other DSNs, e.g. MySql, see the perldoc for the relevant dbd
7 # driver, e.g perldoc L<DBD::mysql>.
8
9 get_tracks_by_cd('Bad');
10 get_tracks_by_artist('Michael Jackson');
11
12 get_cd_by_track('Stan');
13 get_cds_by_artist('Michael Jackson');
14
15 get_artist_by_track('Dirty Diana');
16 get_artist_by_cd('The Marshall Mathers LP');
17
18
19 sub get_tracks_by_cd {
20 my $cdtitle = shift;
21 print "get_tracks_by_cd($cdtitle):\n";
22 my $rs = $schema->resultset('Track')->search(
23 {
24 'cd.title' => $cdtitle
25 },
26 {
27 join => [qw/ cd /],
28 }
29 );
30 while (my $track = $rs->next) {
31 print $track->title . "\n";
32 }
33 print "\n";
34 }
35
36 sub get_tracks_by_artist {
37 my $artistname = shift;
38 print "get_tracks_by_artist($artistname):\n";
39 my $rs = $schema->resultset('Track')->search(
40 {
41 'artist.name' => $artistname
42 },
43 {
44 join => {
45 'cd' => 'artist'
46 },
47 }
48 );
49 while (my $track = $rs->next) {
50 print $track->title . "\n";
51 }
52 print "\n";
53 }
54
55
56 sub get_cd_by_track {
57 my $tracktitle = shift;
58 print "get_cd_by_track($tracktitle):\n";
59 my $rs = $schema->resultset('Cd')->search(
60 {
61 'tracks.title' => $tracktitle
62 },
63 {
64 join => [qw/ tracks /],
65 }
66 );
67 my $cd = $rs->first;
68 print $cd->title . "\n\n";
69 }
70
71 sub get_cds_by_artist {
72 my $artistname = shift;
73 print "get_cds_by_artist($artistname):\n";
74 my $rs = $schema->resultset('Cd')->search(
75 {
76 'artist.name' => $artistname
77 },
78 {
79 join => [qw/ artist /],
80 }
81 );
82 while (my $cd = $rs->next) {
83 print $cd->title . "\n";
84 }
85 print "\n";
86 }
87
88
89
90 sub get_artist_by_track {
91 my $tracktitle = shift;
92 print "get_artist_by_track($tracktitle):\n";
93 my $rs = $schema->resultset('Artist')->search(
94 {
95 'tracks.title' => $tracktitle
96 },
97 {
98 join => {
99 'cds' => 'tracks'
100 }
101 }
102 );
103 my $artist = $rs->first;
104 print $artist->name . "\n\n";
105 }
106
107
108 sub get_artist_by_cd {
109 my $cdtitle = shift;
110 print "get_artist_by_cd($cdtitle):\n";
111 my $rs = $schema->resultset('Artist')->search(
112 {
113 'cds.title' => $cdtitle
114 },
115 {
116 join => [qw/ cds /],
117 }
118 );
119 my $artist = $rs->first;
120 print $artist->name . "\n\n";
121 }
0 #!/usr/bin/perl -w
1
2 use MyDatabase::Main;
3 use strict;
4
5 my $schema = MyDatabase::Main->connect('dbi:SQLite:db/example.db');
6 # for other DSNs, e.g. MySql, see the perldoc for the relevant dbd
7 # driver, e.g perldoc L<DBD::mysql>.
8
9 get_tracks_by_cd('Bad');
10 get_tracks_by_artist('Michael Jackson');
11
12 get_cd_by_track('Stan');
13 get_cds_by_artist('Michael Jackson');
14
15 get_artist_by_track('Dirty Diana');
16 get_artist_by_cd('The Marshall Mathers LP');
17
18
19 sub get_tracks_by_cd {
20 my $cdtitle = shift;
21 print "get_tracks_by_cd($cdtitle):\n";
22 my $rs = $schema->resultset('Track')->search(
23 {
24 'cd.title' => $cdtitle
25 },
26 {
27 join => [qw/ cd /],
28 }
29 );
30 while (my $track = $rs->next) {
31 print $track->title . "\n";
32 }
33 print "\n";
34 }
35
36 sub get_tracks_by_artist {
37 my $artistname = shift;
38 print "get_tracks_by_artist($artistname):\n";
39 my $rs = $schema->resultset('Track')->search(
40 {
41 'artist.name' => $artistname
42 },
43 {
44 join => {
45 'cd' => 'artist'
46 },
47 }
48 );
49 while (my $track = $rs->next) {
50 print $track->title . "\n";
51 }
52 print "\n";
53 }
54
55
56 sub get_cd_by_track {
57 my $tracktitle = shift;
58 print "get_cd_by_track($tracktitle):\n";
59 my $rs = $schema->resultset('Cd')->search(
60 {
61 'tracks.title' => $tracktitle
62 },
63 {
64 join => [qw/ tracks /],
65 }
66 );
67 my $cd = $rs->first;
68 print $cd->title . "\n\n";
69 }
70
71 sub get_cds_by_artist {
72 my $artistname = shift;
73 print "get_cds_by_artist($artistname):\n";
74 my $rs = $schema->resultset('Cd')->search(
75 {
76 'artist.name' => $artistname
77 },
78 {
79 join => [qw/ artist /],
80 }
81 );
82 while (my $cd = $rs->next) {
83 print $cd->title . "\n";
84 }
85 print "\n";
86 }
87
88
89
90 sub get_artist_by_track {
91 my $tracktitle = shift;
92 print "get_artist_by_track($tracktitle):\n";
93 my $rs = $schema->resultset('Artist')->search(
94 {
95 'tracks.title' => $tracktitle
96 },
97 {
98 join => {
99 'cds' => 'tracks'
100 }
101 }
102 );
103 my $artist = $rs->first;
104 print $artist->name . "\n\n";
105 }
106
107
108 sub get_artist_by_cd {
109 my $cdtitle = shift;
110 print "get_artist_by_cd($cdtitle):\n";
111 my $rs = $schema->resultset('Artist')->search(
112 {
113 'cds.title' => $cdtitle
114 },
115 {
116 join => [qw/ cds /],
117 }
118 );
119 my $artist = $rs->first;
120 print $artist->name . "\n\n";
121 }
+1
-1
inc/Module/Install/AutoInstall.pm less more
55
66 use vars qw{$VERSION @ISA $ISCORE};
77 BEGIN {
8 $VERSION = '0.93';
8 $VERSION = '0.95';
99 @ISA = 'Module::Install::Base';
1010 $ISCORE = 1;
1111 }
+1
-1
inc/Module/Install/Base.pm less more
33 use strict 'vars';
44 use vars qw{$VERSION};
55 BEGIN {
6 $VERSION = '0.93';
6 $VERSION = '0.95';
77 }
88
99 # Suspend handler for "redefined" warnings
+1
-1
inc/Module/Install/Can.pm less more
88
99 use vars qw{$VERSION @ISA $ISCORE};
1010 BEGIN {
11 $VERSION = '0.93';
11 $VERSION = '0.95';
1212 @ISA = 'Module::Install::Base';
1313 $ISCORE = 1;
1414 }
+1
-1
inc/Module/Install/Fetch.pm less more
55
66 use vars qw{$VERSION @ISA $ISCORE};
77 BEGIN {
8 $VERSION = '0.93';
8 $VERSION = '0.95';
99 @ISA = 'Module::Install::Base';
1010 $ISCORE = 1;
1111 }
+1
-1
inc/Module/Install/Include.pm less more
55
66 use vars qw{$VERSION @ISA $ISCORE};
77 BEGIN {
8 $VERSION = '0.93';
8 $VERSION = '0.95';
99 @ISA = 'Module::Install::Base';
1010 $ISCORE = 1;
1111 }
+113
-17
inc/Module/Install/Makefile.pm less more
66
77 use vars qw{$VERSION @ISA $ISCORE};
88 BEGIN {
9 $VERSION = '0.93';
9 $VERSION = '0.95';
1010 @ISA = 'Module::Install::Base';
1111 $ISCORE = 1;
1212 }
2424 die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
2525 }
2626
27 # In automated testing, always use defaults
28 if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
27 # In automated testing or non-interactive session, always use defaults
28 if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
2929 local $ENV{PERL_MM_USE_DEFAULT} = 1;
3030 goto &ExtUtils::MakeMaker::prompt;
3131 } else {
4444 ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
4545 }
4646
47 # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
48 # as we only need to know here whether the attribute is an array
49 # or a hash or something else (which may or may not be appendable).
50 my %makemaker_argtype = (
51 C => 'ARRAY',
52 CONFIG => 'ARRAY',
53 # CONFIGURE => 'CODE', # ignore
54 DIR => 'ARRAY',
55 DL_FUNCS => 'HASH',
56 DL_VARS => 'ARRAY',
57 EXCLUDE_EXT => 'ARRAY',
58 EXE_FILES => 'ARRAY',
59 FUNCLIST => 'ARRAY',
60 H => 'ARRAY',
61 IMPORTS => 'HASH',
62 INCLUDE_EXT => 'ARRAY',
63 LIBS => 'ARRAY', # ignore ''
64 MAN1PODS => 'HASH',
65 MAN3PODS => 'HASH',
66 META_ADD => 'HASH',
67 META_MERGE => 'HASH',
68 PL_FILES => 'HASH',
69 PM => 'HASH',
70 PMLIBDIRS => 'ARRAY',
71 PMLIBPARENTDIRS => 'ARRAY',
72 PREREQ_PM => 'HASH',
73 CONFIGURE_REQUIRES => 'HASH',
74 SKIP => 'ARRAY',
75 TYPEMAPS => 'ARRAY',
76 XS => 'HASH',
77 # VERSION => ['version',''], # ignore
78 # _KEEP_AFTER_FLUSH => '',
79
80 clean => 'HASH',
81 depend => 'HASH',
82 dist => 'HASH',
83 dynamic_lib=> 'HASH',
84 linkext => 'HASH',
85 macro => 'HASH',
86 postamble => 'HASH',
87 realclean => 'HASH',
88 test => 'HASH',
89 tool_autosplit => 'HASH',
90
91 # special cases where you can use makemaker_append
92 CCFLAGS => 'APPENDABLE',
93 DEFINE => 'APPENDABLE',
94 INC => 'APPENDABLE',
95 LDDLFLAGS => 'APPENDABLE',
96 LDFROM => 'APPENDABLE',
97 );
98
4799 sub makemaker_args {
48 my $self = shift;
100 my ($self, %new_args) = @_;
49101 my $args = ( $self->{makemaker_args} ||= {} );
50 %$args = ( %$args, @_ );
102 foreach my $key (keys %new_args) {
103 if ($makemaker_argtype{$key} eq 'ARRAY') {
104 $args->{$key} = [] unless defined $args->{$key};
105 unless (ref $args->{$key} eq 'ARRAY') {
106 $args->{$key} = [$args->{$key}]
107 }
108 push @{$args->{$key}},
109 ref $new_args{$key} eq 'ARRAY'
110 ? @{$new_args{$key}}
111 : $new_args{$key};
112 }
113 elsif ($makemaker_argtype{$key} eq 'HASH') {
114 $args->{$key} = {} unless defined $args->{$key};
115 foreach my $skey (keys %{ $new_args{$key} }) {
116 $args->{$key}{$skey} = $new_args{$key}{$skey};
117 }
118 }
119 elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
120 $self->makemaker_append($key => $new_args{$key});
121 }
122 else {
123 if (defined $args->{$key}) {
124 warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
125 }
126 $args->{$key} = $new_args{$key};
127 }
128 }
51129 return $args;
52130 }
53131
57135 my $self = shift;
58136 my $name = shift;
59137 my $args = $self->makemaker_args;
60 $args->{name} = defined $args->{$name}
61 ? join( ' ', $args->{name}, @_ )
138 $args->{$name} = defined $args->{$name}
139 ? join( ' ', $args->{$name}, @_ )
62140 : join( ' ', @_ );
63141 }
64142
117195 %test_dir = ();
118196 require File::Find;
119197 File::Find::find( \&_wanted_t, $dir );
120 if ( -d 'xt' and ($ENV{RELEASE_TESTING} or $self->author) ) {
198 if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
121199 File::Find::find( \&_wanted_t, 'xt' );
122200 }
123201 $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
157235 my $args = $self->makemaker_args;
158236 $args->{DISTNAME} = $self->name;
159237 $args->{NAME} = $self->module_name || $self->name;
160 $args->{VERSION} = $self->version;
161238 $args->{NAME} =~ s/-/::/g;
239 $args->{VERSION} = $self->version or die <<'EOT';
240 ERROR: Can't determine distribution version. Please specify it
241 explicitly via 'version' in Makefile.PL, or set a valid $VERSION
242 in a module, and provide its file path via 'version_from' (or
243 'all_from' if you prefer) in Makefile.PL.
244 EOT
245
162246 $DB::single = 1;
163247 if ( $self->tests ) {
164 $args->{test} = { TESTS => $self->tests };
165 } elsif ( -d 'xt' and ($self->author or $ENV{RELEASE_TESTING}) ) {
248 my @tests = split ' ', $self->tests;
249 my %seen;
250 $args->{test} = {
251 TESTS => (join ' ', grep {!$seen{$_}++} @tests),
252 };
253 } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
166254 $args->{test} = {
167255 TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
168256 };
169257 }
170258 if ( $] >= 5.005 ) {
171259 $args->{ABSTRACT} = $self->abstract;
172 $args->{AUTHOR} = $self->author;
260 $args->{AUTHOR} = join ', ', @{$self->author || []};
173261 }
174262 if ( $self->makemaker(6.10) ) {
175263 $args->{NO_META} = 1;
180268 }
181269 unless ( $self->is_admin ) {
182270 delete $args->{SIGN};
271 }
272 if ( $self->makemaker(6.31) and $self->license ) {
273 $args->{LICENSE} = $self->license;
183274 }
184275
185276 my $prereq = ($args->{PREREQ_PM} ||= {});
230321 }
231322 }
232323
233 $args->{INSTALLDIRS} = $self->installdirs;
234
235 my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
324 if ($self->installdirs) {
325 warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
326 $args->{INSTALLDIRS} = $self->installdirs;
327 }
328
329 my %args = map {
330 ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
331 } keys %$args;
236332
237333 my $user_preop = delete $args{dist}->{PREOP};
238 if (my $preop = $self->admin->preop($user_preop)) {
334 if ( my $preop = $self->admin->preop($user_preop) ) {
239335 foreach my $key ( keys %$preop ) {
240336 $args{dist}->{$key} = $preop->{$key};
241337 }
305401
306402 __END__
307403
308 #line 435
404 #line 531
+89
-43
inc/Module/Install/Metadata.pm less more
55
66 use vars qw{$VERSION @ISA $ISCORE};
77 BEGIN {
8 $VERSION = '0.93';
8 $VERSION = '0.95';
99 @ISA = 'Module::Install::Base';
1010 $ISCORE = 1;
1111 }
1818 name
1919 module_name
2020 abstract
21 author
2221 version
2322 distribution_type
2423 tests
4241
4342 my @array_keys = qw{
4443 keywords
44 author
4545 };
46
47 *authors = \&author;
4648
4749 sub Meta { shift }
4850 sub Meta_BooleanKeys { @boolean_keys }
241243 $self->name_from($file) unless $self->name;
242244 $self->version_from($file) unless $self->version;
243245 $self->perl_version_from($file) unless $self->perl_version;
244 $self->author_from($pod) unless $self->author;
246 $self->author_from($pod) unless @{$self->author || []};
245247 $self->license_from($pod) unless $self->license;
246248 $self->abstract_from($pod) unless $self->abstract;
247249
427429 ([^\n]*)
428430 /ixms) {
429431 my $author = $1 || $2;
430 $author =~ s{E<lt>}{<}g;
431 $author =~ s{E<gt>}{>}g;
432
433 # XXX: ugly but should work anyway...
434 if (eval "require Pod::Escapes; 1") {
435 # Pod::Escapes has a mapping table.
436 # It's in core of perl >= 5.9.3, and should be installed
437 # as one of the Pod::Simple's prereqs, which is a prereq
438 # of Pod::Text 3.x (see also below).
439 $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
440 {
441 defined $2
442 ? chr($2)
443 : defined $Pod::Escapes::Name2character_number{$1}
444 ? chr($Pod::Escapes::Name2character_number{$1})
445 : do {
446 warn "Unknown escape: E<$1>";
447 "E<$1>";
448 };
449 }gex;
450 }
451 elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
452 # Pod::Text < 3.0 has yet another mapping table,
453 # though the table name of 2.x and 1.x are different.
454 # (1.x is in core of Perl < 5.6, 2.x is in core of
455 # Perl < 5.9.3)
456 my $mapping = ($Pod::Text::VERSION < 2)
457 ? \%Pod::Text::HTML_Escapes
458 : \%Pod::Text::ESCAPES;
459 $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
460 {
461 defined $2
462 ? chr($2)
463 : defined $mapping->{$1}
464 ? $mapping->{$1}
465 : do {
466 warn "Unknown escape: E<$1>";
467 "E<$1>";
468 };
469 }gex;
470 }
471 else {
472 $author =~ s{E<lt>}{<}g;
473 $author =~ s{E<gt>}{>}g;
474 }
432475 $self->author($author);
433476 } else {
434477 warn "Cannot determine author info from $_[0]\n";
436479 }
437480
438481 sub _extract_license {
439 if (
440 $_[0] =~ m/
441 (
442 =head \d \s+
443 (?:licen[cs]e|licensing|copyrights?|legal)\b
444 .*?
445 )
446 (=head\\d.*|=cut.*|)
447 \z
448 /ixms ) {
449 my $license_text = $1;
450 my @phrases = (
451 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1,
452 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
453 'Artistic and GPL' => 'perl', 1,
454 'GNU general public license' => 'gpl', 1,
455 'GNU public license' => 'gpl', 1,
456 'GNU lesser general public license' => 'lgpl', 1,
457 'GNU lesser public license' => 'lgpl', 1,
458 'GNU library general public license' => 'lgpl', 1,
459 'GNU library public license' => 'lgpl', 1,
460 'BSD license' => 'bsd', 1,
461 'Artistic license' => 'artistic', 1,
462 'GPL' => 'gpl', 1,
463 'LGPL' => 'lgpl', 1,
464 'BSD' => 'bsd', 1,
465 'Artistic' => 'artistic', 1,
466 'MIT' => 'mit', 1,
467 'proprietary' => 'proprietary', 0,
468 );
469 while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
470 $pattern =~ s#\s+#\\s+#gs;
471 if ( $license_text =~ /\b$pattern\b/i ) {
472 return $license;
473 }
474 }
475 } else {
476 return;
482 my $pod = shift;
483 my $matched;
484 return __extract_license(
485 ($matched) = $pod =~ m/
486 (=head \d \s+ (?:licen[cs]e|licensing)\b.*?)
487 (=head \d.*|=cut.*|)\z
488 /ixms
489 ) || __extract_license(
490 ($matched) = $pod =~ m/
491 (=head \d \s+ (?:copyrights?|legal)\b.*?)
492 (=head \d.*|=cut.*|)\z
493 /ixms
494 );
495 }
496
497 sub __extract_license {
498 my $license_text = shift or return;
499 my @phrases = (
500 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1,
501 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
502 'Artistic and GPL' => 'perl', 1,
503 'GNU general public license' => 'gpl', 1,
504 'GNU public license' => 'gpl', 1,
505 'GNU lesser general public license' => 'lgpl', 1,
506 'GNU lesser public license' => 'lgpl', 1,
507 'GNU library general public license' => 'lgpl', 1,
508 'GNU library public license' => 'lgpl', 1,
509 'BSD license' => 'bsd', 1,
510 'Artistic license' => 'artistic', 1,
511 'GPL' => 'gpl', 1,
512 'LGPL' => 'lgpl', 1,
513 'BSD' => 'bsd', 1,
514 'Artistic' => 'artistic', 1,
515 'MIT' => 'mit', 1,
516 'proprietary' => 'proprietary', 0,
517 );
518 while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
519 $pattern =~ s#\s+#\\s+#gs;
520 if ( $license_text =~ /\b$pattern\b/i ) {
521 return $license;
522 }
477523 }
478524 }
479525
+1
-1
inc/Module/Install/Scripts.pm less more
55
66 use vars qw{$VERSION @ISA $ISCORE};
77 BEGIN {
8 $VERSION = '0.93';
8 $VERSION = '0.95';
99 @ISA = 'Module::Install::Base';
1010 $ISCORE = 1;
1111 }
+1
-1
inc/Module/Install/Win32.pm less more
55
66 use vars qw{$VERSION @ISA $ISCORE};
77 BEGIN {
8 $VERSION = '0.93';
8 $VERSION = '0.95';
99 @ISA = 'Module::Install::Base';
1010 $ISCORE = 1;
1111 }
+5
-2
inc/Module/Install/WriteAll.pm less more
55
66 use vars qw{$VERSION @ISA $ISCORE};
77 BEGIN {
8 $VERSION = '0.93';;
8 $VERSION = '0.95';;
99 @ISA = qw{Module::Install::Base};
1010 $ISCORE = 1;
1111 }
2525
2626 $self->check_nmake if $args{check_nmake};
2727 unless ( $self->makemaker_args->{PL_FILES} ) {
28 $self->makemaker_args( PL_FILES => {} );
28 # XXX: This still may be a bit over-defensive...
29 unless ($self->makemaker(6.25)) {
30 $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
31 }
2932 }
3033
3134 # Until ExtUtils::MakeMaker support MYMETA.yml, make sure
+82
-86
inc/Module/Install.pm less more
1818
1919 use 5.005;
2020 use strict 'vars';
21 use Cwd ();
22 use File::Find ();
23 use File::Path ();
24 use FindBin;
2125
2226 use vars qw{$VERSION $MAIN};
2327 BEGIN {
2731 # This is not enforced yet, but will be some time in the next few
2832 # releases once we can make sure it won't clash with custom
2933 # Module::Install extensions.
30 $VERSION = '0.93';
34 $VERSION = '0.95';
3135
3236 # Storage for the pseudo-singleton
3337 $MAIN = undef;
3741
3842 }
3943
40
41
42
43
44 # Whether or not inc::Module::Install is actually loaded, the
45 # $INC{inc/Module/Install.pm} is what will still get set as long as
46 # the caller loaded module this in the documented manner.
47 # If not set, the caller may NOT have loaded the bundled version, and thus
48 # they may not have a MI version that works with the Makefile.PL. This would
49 # result in false errors or unexpected behaviour. And we don't want that.
50 my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
51 unless ( $INC{$file} ) { die <<"END_DIE" }
44 sub import {
45 my $class = shift;
46 my $self = $class->new(@_);
47 my $who = $self->_caller;
48
49 #-------------------------------------------------------------
50 # all of the following checks should be included in import(),
51 # to allow "eval 'require Module::Install; 1' to test
52 # installation of Module::Install. (RT #51267)
53 #-------------------------------------------------------------
54
55 # Whether or not inc::Module::Install is actually loaded, the
56 # $INC{inc/Module/Install.pm} is what will still get set as long as
57 # the caller loaded module this in the documented manner.
58 # If not set, the caller may NOT have loaded the bundled version, and thus
59 # they may not have a MI version that works with the Makefile.PL. This would
60 # result in false errors or unexpected behaviour. And we don't want that.
61 my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
62 unless ( $INC{$file} ) { die <<"END_DIE" }
5263
5364 Please invoke ${\__PACKAGE__} with:
5465
6071
6172 END_DIE
6273
63
64
65
66
67 # If the script that is loading Module::Install is from the future,
68 # then make will detect this and cause it to re-run over and over
69 # again. This is bad. Rather than taking action to touch it (which
70 # is unreliable on some platforms and requires write permissions)
71 # for now we should catch this and refuse to run.
72 if ( -f $0 ) {
73 my $s = (stat($0))[9];
74
75 # If the modification time is only slightly in the future,
76 # sleep briefly to remove the problem.
77 my $a = $s - time;
78 if ( $a > 0 and $a < 5 ) { sleep 5 }
79
80 # Too far in the future, throw an error.
81 my $t = time;
82 if ( $s > $t ) { die <<"END_DIE" }
74 # This reportedly fixes a rare Win32 UTC file time issue, but
75 # as this is a non-cross-platform XS module not in the core,
76 # we shouldn't really depend on it. See RT #24194 for detail.
77 # (Also, this module only supports Perl 5.6 and above).
78 eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
79
80 # If the script that is loading Module::Install is from the future,
81 # then make will detect this and cause it to re-run over and over
82 # again. This is bad. Rather than taking action to touch it (which
83 # is unreliable on some platforms and requires write permissions)
84 # for now we should catch this and refuse to run.
85 if ( -f $0 ) {
86 my $s = (stat($0))[9];
87
88 # If the modification time is only slightly in the future,
89 # sleep briefly to remove the problem.
90 my $a = $s - time;
91 if ( $a > 0 and $a < 5 ) { sleep 5 }
92
93 # Too far in the future, throw an error.
94 my $t = time;
95 if ( $s > $t ) { die <<"END_DIE" }
8396
8497 Your installer $0 has a modification time in the future ($s > $t).
8598
88101 Please correct this, then run $0 again.
89102
90103 END_DIE
91 }
92
93
94
95
96
97 # Build.PL was formerly supported, but no longer is due to excessive
98 # difficulty in implementing every single feature twice.
99 if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
104 }
105
106
107 # Build.PL was formerly supported, but no longer is due to excessive
108 # difficulty in implementing every single feature twice.
109 if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
100110
101111 Module::Install no longer supports Build.PL.
102112
106116
107117 END_DIE
108118
109
110
111
112
113 # To save some more typing in Module::Install installers, every...
114 # use inc::Module::Install
115 # ...also acts as an implicit use strict.
116 $^H |= strict::bits(qw(refs subs vars));
117
118
119
120
121
122 use Cwd ();
123 use File::Find ();
124 use File::Path ();
125 use FindBin;
119 #-------------------------------------------------------------
120
121 # To save some more typing in Module::Install installers, every...
122 # use inc::Module::Install
123 # ...also acts as an implicit use strict.
124 $^H |= strict::bits(qw(refs subs vars));
125
126 #-------------------------------------------------------------
127
128 unless ( -f $self->{file} ) {
129 require "$self->{path}/$self->{dispatch}.pm";
130 File::Path::mkpath("$self->{prefix}/$self->{author}");
131 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
132 $self->{admin}->init;
133 @_ = ($class, _self => $self);
134 goto &{"$self->{name}::import"};
135 }
136
137 *{"${who}::AUTOLOAD"} = $self->autoload;
138 $self->preload;
139
140 # Unregister loader and worker packages so subdirs can use them again
141 delete $INC{"$self->{file}"};
142 delete $INC{"$self->{path}.pm"};
143
144 # Save to the singleton
145 $MAIN = $self;
146
147 return 1;
148 }
126149
127150 sub autoload {
128151 my $self = shift;
151174 };
152175 }
153176
154 sub import {
155 my $class = shift;
156 my $self = $class->new(@_);
157 my $who = $self->_caller;
158
159 unless ( -f $self->{file} ) {
160 require "$self->{path}/$self->{dispatch}.pm";
161 File::Path::mkpath("$self->{prefix}/$self->{author}");
162 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
163 $self->{admin}->init;
164 @_ = ($class, _self => $self);
165 goto &{"$self->{name}::import"};
166 }
167
168 *{"${who}::AUTOLOAD"} = $self->autoload;
169 $self->preload;
170
171 # Unregister loader and worker packages so subdirs can use them again
172 delete $INC{"$self->{file}"};
173 delete $INC{"$self->{path}.pm"};
174
175 # Save to the singleton
176 $MAIN = $self;
177
178 return 1;
179 }
180
181177 sub preload {
182178 my $self = shift;
183179 unless ( $self->{extensions} ) {
+1
-0
lib/DBIx/Class/Admin/Usage.pm less more
5959 foreach my $opt (@options) {
6060 my $spec = $opt->{spec};
6161 my $desc = $opt->{desc};
62 next if ($desc eq 'hidden');
6263 if ($desc eq 'spacer') {
6364 $string .= "=back\n\n=head2 $spec\n\n=cut\n\n=over\n\n";
6465 next;
+68
-68
lib/DBIx/Class/CDBICompat/AccessorMapping.pm less more
0 package # hide from PAUSE Indexer
1 DBIx::Class::CDBICompat::AccessorMapping;
2
3 use strict;
4 use warnings;
5
6 sub mk_group_accessors {
7 my ($class, $group, @cols) = @_;
8
9 foreach my $col (@cols) {
10 my($accessor, $col) = ref $col ? @$col : (undef, $col);
11
12 my($ro_meth, $wo_meth);
13 if( defined $accessor and ($accessor ne $col)) {
14 $ro_meth = $wo_meth = $accessor;
15 }
16 else {
17 $ro_meth = $class->accessor_name_for($col);
18 $wo_meth = $class->mutator_name_for($col);
19 }
20
21 # warn "class: $class / col: $col / ro: $ro_meth / wo: $wo_meth\n";
22 if ($ro_meth eq $wo_meth or # they're the same
23 $wo_meth eq $col) # or only the accessor is custom
24 {
25 $class->next::method($group => [ $ro_meth => $col ]);
26 }
27 else {
28 $class->mk_group_ro_accessors($group => [ $ro_meth => $col ]);
29 $class->mk_group_wo_accessors($group => [ $wo_meth => $col ]);
30 }
31 }
32 }
33
34
35 sub accessor_name_for {
36 my ($class, $column) = @_;
37 if ($class->can('accessor_name')) {
38 return $class->accessor_name($column)
39 }
40
41 return $column;
42 }
43
44 sub mutator_name_for {
45 my ($class, $column) = @_;
46 if ($class->can('mutator_name')) {
47 return $class->mutator_name($column)
48 }
49
50 return $column;
51 }
52
53
54 sub new {
55 my ($class, $attrs, @rest) = @_;
56 $class->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH';
57 foreach my $col ($class->columns) {
58 my $acc = $class->accessor_name_for($col);
59 $attrs->{$col} = delete $attrs->{$acc} if exists $attrs->{$acc};
60
61 my $mut = $class->mutator_name_for($col);
62 $attrs->{$col} = delete $attrs->{$mut} if exists $attrs->{$mut};
63 }
64 return $class->next::method($attrs, @rest);
65 }
66
67 1;
0 package # hide from PAUSE Indexer
1 DBIx::Class::CDBICompat::AccessorMapping;
2
3 use strict;
4 use warnings;
5
6 sub mk_group_accessors {
7 my ($class, $group, @cols) = @_;
8
9 foreach my $col (@cols) {
10 my($accessor, $col) = ref $col ? @$col : (undef, $col);
11
12 my($ro_meth, $wo_meth);
13 if( defined $accessor and ($accessor ne $col)) {
14 $ro_meth = $wo_meth = $accessor;
15 }
16 else {
17 $ro_meth = $class->accessor_name_for($col);
18 $wo_meth = $class->mutator_name_for($col);
19 }
20
21 # warn "class: $class / col: $col / ro: $ro_meth / wo: $wo_meth\n";
22 if ($ro_meth eq $wo_meth or # they're the same
23 $wo_meth eq $col) # or only the accessor is custom
24 {
25 $class->next::method($group => [ $ro_meth => $col ]);
26 }
27 else {
28 $class->mk_group_ro_accessors($group => [ $ro_meth => $col ]);
29 $class->mk_group_wo_accessors($group => [ $wo_meth => $col ]);
30 }
31 }
32 }
33
34
35 sub accessor_name_for {
36 my ($class, $column) = @_;
37 if ($class->can('accessor_name')) {
38 return $class->accessor_name($column)
39 }
40
41 return $column;
42 }
43
44 sub mutator_name_for {
45 my ($class, $column) = @_;
46 if ($class->can('mutator_name')) {
47 return $class->mutator_name($column)
48 }
49
50 return $column;
51 }
52
53
54 sub new {
55 my ($class, $attrs, @rest) = @_;
56 $class->throw_exception( "create needs a hashref" ) unless ref $attrs eq 'HASH';
57 foreach my $col ($class->columns) {
58 my $acc = $class->accessor_name_for($col);
59 $attrs->{$col} = delete $attrs->{$acc} if exists $attrs->{$acc};
60
61 my $mut = $class->mutator_name_for($col);
62 $attrs->{$col} = delete $attrs->{$mut} if exists $attrs->{$mut};
63 }
64 return $class->next::method($attrs, @rest);
65 }
66
67 1;
+36
-36
lib/DBIx/Class/CDBICompat/AttributeAPI.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::AttributeAPI;
2
3 use strict;
4 use warnings;
5
6 sub _attrs {
7 my ($self, @atts) = @_;
8 return @{$self->{_column_data}}{@atts};
9 }
10
11 *_attr = \&_attrs;
12
13 sub _attribute_store {
14 my $self = shift;
15 my $vals = @_ == 1 ? shift: {@_};
16 $self->store_column($_, $vals->{$_}) for keys %{$vals};
17 }
18
19 sub _attribute_set {
20 my $self = shift;
21 my $vals = @_ == 1 ? shift: {@_};
22 $self->set_column($_, $vals->{$_}) for keys %{$vals};
23 }
24
25 sub _attribute_delete {
26 my ($self, $attr) = @_;
27 delete $self->{_column_data}{$attr};
28 }
29
30 sub _attribute_exists {
31 my ($self, $attr) = @_;
32 $self->has_column_loaded($attr);
33 }
34
35 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::AttributeAPI;
2
3 use strict;
4 use warnings;
5
6 sub _attrs {
7 my ($self, @atts) = @_;
8 return @{$self->{_column_data}}{@atts};
9 }
10
11 *_attr = \&_attrs;
12
13 sub _attribute_store {
14 my $self = shift;
15 my $vals = @_ == 1 ? shift: {@_};
16 $self->store_column($_, $vals->{$_}) for keys %{$vals};
17 }
18
19 sub _attribute_set {
20 my $self = shift;
21 my $vals = @_ == 1 ? shift: {@_};
22 $self->set_column($_, $vals->{$_}) for keys %{$vals};
23 }
24
25 sub _attribute_delete {
26 my ($self, $attr) = @_;
27 delete $self->{_column_data}{$attr};
28 }
29
30 sub _attribute_exists {
31 my ($self, $attr) = @_;
32 $self->has_column_loaded($attr);
33 }
34
35 1;
+40
-40
lib/DBIx/Class/CDBICompat/AutoUpdate.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::AutoUpdate;
2
3 use strict;
4 use warnings;
5
6 use base qw/Class::Data::Inheritable/;
7
8 __PACKAGE__->mk_classdata('__AutoCommit');
9
10 sub set_column {
11 my $self = shift;
12 my $ret = $self->next::method(@_);
13 $self->update if ($self->autoupdate && $self->{_in_storage});
14 return $ret;
15 }
16
17 sub autoupdate {
18 my $proto = shift;
19 ref $proto
20 ? $proto->_obj_autoupdate(@_)
21 : $proto->_class_autoupdate(@_) ;
22 }
23
24 sub _obj_autoupdate {
25 my ($self, $set) = @_;
26 my $class = ref $self;
27 $self->{__AutoCommit} = $set if defined $set;
28 defined $self->{__AutoCommit}
29 ? $self->{__AutoCommit}
30 : $class->_class_autoupdate;
31 }
32
33 sub _class_autoupdate {
34 my ($class, $set) = @_;
35 $class->__AutoCommit($set) if defined $set;
36 return $class->__AutoCommit;
37 }
38
39 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::AutoUpdate;
2
3 use strict;
4 use warnings;
5
6 use base qw/Class::Data::Inheritable/;
7
8 __PACKAGE__->mk_classdata('__AutoCommit');
9
10 sub set_column {
11 my $self = shift;
12 my $ret = $self->next::method(@_);
13 $self->update if ($self->autoupdate && $self->{_in_storage});
14 return $ret;
15 }
16
17 sub autoupdate {
18 my $proto = shift;
19 ref $proto
20 ? $proto->_obj_autoupdate(@_)
21 : $proto->_class_autoupdate(@_) ;
22 }
23
24 sub _obj_autoupdate {
25 my ($self, $set) = @_;
26 my $class = ref $self;
27 $self->{__AutoCommit} = $set if defined $set;
28 defined $self->{__AutoCommit}
29 ? $self->{__AutoCommit}
30 : $class->_class_autoupdate;
31 }
32
33 sub _class_autoupdate {
34 my ($class, $set) = @_;
35 $class->__AutoCommit($set) if defined $set;
36 return $class->__AutoCommit;
37 }
38
39 1;
+98
-98
lib/DBIx/Class/CDBICompat/ColumnCase.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::ColumnCase;
2
3 use strict;
4 use warnings;
5
6 sub _register_column_group {
7 my ($class, $group, @cols) = @_;
8 return $class->next::method($group => map lc, @cols);
9 }
10
11 sub add_columns {
12 my ($class, @cols) = @_;
13 return $class->result_source_instance->add_columns(map lc, @cols);
14 }
15
16 sub has_a {
17 my($self, $col, @rest) = @_;
18
19 $self->_declare_has_a(lc $col, @rest);
20 $self->_mk_inflated_column_accessor($col);
21
22 return 1;
23 }
24
25 sub has_many {
26 my ($class, $rel, $f_class, $f_key, @rest) = @_;
27 return $class->next::method($rel, $f_class, ( ref($f_key) ?
28 $f_key :
29 lc($f_key) ), @rest);
30 }
31
32 sub get_inflated_column {
33 my ($class, $get, @rest) = @_;
34 return $class->next::method(lc($get), @rest);
35 }
36
37 sub store_inflated_column {
38 my ($class, $set, @rest) = @_;
39 return $class->next::method(lc($set), @rest);
40 }
41
42 sub set_inflated_column {
43 my ($class, $set, @rest) = @_;
44 return $class->next::method(lc($set), @rest);
45 }
46
47 sub get_column {
48 my ($class, $get, @rest) = @_;
49 return $class->next::method(lc($get), @rest);
50 }
51
52 sub set_column {
53 my ($class, $set, @rest) = @_;
54 return $class->next::method(lc($set), @rest);
55 }
56
57 sub store_column {
58 my ($class, $set, @rest) = @_;
59 return $class->next::method(lc($set), @rest);
60 }
61
62 sub find_column {
63 my ($class, $col) = @_;
64 return $class->next::method(lc($col));
65 }
66
67 # _build_query
68 #
69 # Build a query hash for find, et al. Overrides Retrieve::_build_query.
70
71 sub _build_query {
72 my ($self, $query) = @_;
73
74 my %new_query;
75 $new_query{lc $_} = $query->{$_} for keys %$query;
76
77 return \%new_query;
78 }
79
80 sub _deploy_accessor {
81 my($class, $name, $accessor) = @_;
82
83 return if $class->_has_custom_accessor($name);
84
85 $class->next::method(lc $name => $accessor);
86 return $class->next::method($name => $accessor);
87 }
88
89
90 sub new {
91 my ($class, $attrs, @rest) = @_;
92 my %att;
93 $att{lc $_} = $attrs->{$_} for keys %$attrs;
94 return $class->next::method(\%att, @rest);
95 }
96
97 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::ColumnCase;
2
3 use strict;
4 use warnings;
5
6 sub _register_column_group {
7 my ($class, $group, @cols) = @_;
8 return $class->next::method($group => map lc, @cols);
9 }
10
11 sub add_columns {
12 my ($class, @cols) = @_;
13 return $class->result_source_instance->add_columns(map lc, @cols);
14 }
15
16 sub has_a {
17 my($self, $col, @rest) = @_;
18
19 $self->_declare_has_a(lc $col, @rest);
20 $self->_mk_inflated_column_accessor($col);
21
22 return 1;
23 }
24
25 sub has_many {
26 my ($class, $rel, $f_class, $f_key, @rest) = @_;
27 return $class->next::method($rel, $f_class, ( ref($f_key) ?
28 $f_key :
29 lc($f_key) ), @rest);
30 }
31
32 sub get_inflated_column {
33 my ($class, $get, @rest) = @_;
34 return $class->next::method(lc($get), @rest);
35 }
36
37 sub store_inflated_column {
38 my ($class, $set, @rest) = @_;
39 return $class->next::method(lc($set), @rest);
40 }
41
42 sub set_inflated_column {
43 my ($class, $set, @rest) = @_;
44 return $class->next::method(lc($set), @rest);
45 }
46
47 sub get_column {
48 my ($class, $get, @rest) = @_;
49 return $class->next::method(lc($get), @rest);
50 }
51
52 sub set_column {
53 my ($class, $set, @rest) = @_;
54 return $class->next::method(lc($set), @rest);
55 }
56
57 sub store_column {
58 my ($class, $set, @rest) = @_;
59 return $class->next::method(lc($set), @rest);
60 }
61
62 sub find_column {
63 my ($class, $col) = @_;
64 return $class->next::method(lc($col));
65 }
66
67 # _build_query
68 #
69 # Build a query hash for find, et al. Overrides Retrieve::_build_query.
70
71 sub _build_query {
72 my ($self, $query) = @_;
73
74 my %new_query;
75 $new_query{lc $_} = $query->{$_} for keys %$query;
76
77 return \%new_query;
78 }
79
80 sub _deploy_accessor {
81 my($class, $name, $accessor) = @_;
82
83 return if $class->_has_custom_accessor($name);
84
85 $class->next::method(lc $name => $accessor);
86 return $class->next::method($name => $accessor);
87 }
88
89
90 sub new {
91 my ($class, $attrs, @rest) = @_;
92 my %att;
93 $att{lc $_} = $attrs->{$_} for keys %$attrs;
94 return $class->next::method(\%att, @rest);
95 }
96
97 1;
+172
-172
lib/DBIx/Class/CDBICompat/ColumnGroups.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::ColumnGroups;
2
3 use strict;
4 use warnings;
5 use Sub::Name ();
6 use Storable 'dclone';
7
8 use base qw/DBIx::Class::Row/;
9
10 __PACKAGE__->mk_classdata('_column_groups' => { });
11
12 sub columns {
13 my $proto = shift;
14 my $class = ref $proto || $proto;
15 my $group = shift || "All";
16 $class->_init_result_source_instance();
17
18 $class->_add_column_group($group => @_) if @_;
19 return $class->all_columns if $group eq "All";
20 return $class->primary_column if $group eq "Primary";
21 return keys %{$class->_column_groups->{$group}};
22 }
23
24 sub _add_column_group {
25 my ($class, $group, @cols) = @_;
26 $class->mk_group_accessors(column => @cols);
27 $class->add_columns(@cols);
28 $class->_register_column_group($group => @cols);
29 }
30
31 sub add_columns {
32 my ($class, @cols) = @_;
33 $class->result_source_instance->add_columns(@cols);
34 }
35
36 sub _register_column_group {
37 my ($class, $group, @cols) = @_;
38
39 # Must do a complete deep copy else column groups
40 # might accidentally be shared.
41 my $groups = dclone $class->_column_groups;
42
43 if ($group eq 'Primary') {
44 $class->set_primary_key(@cols);
45 $groups->{'Essential'}{$_} ||= 1 for @cols;
46 }
47
48 if ($group eq 'All') {
49 unless (exists $class->_column_groups->{'Primary'}) {
50 $groups->{'Primary'}{$cols[0]} = 1;
51 $class->set_primary_key($cols[0]);
52 }
53 unless (exists $class->_column_groups->{'Essential'}) {
54 $groups->{'Essential'}{$cols[0]} = 1;
55 }
56 }
57
58 $groups->{$group}{$_} ||= 1 for @cols;
59
60 $class->_column_groups($groups);
61 }
62
63 # CDBI will never overwrite an accessor, but it only uses one
64 # accessor for all column types. DBIC uses many different
65 # accessor types so, for example, if you declare a column()
66 # and then a has_a() for that same column it must overwrite.
67 #
68 # To make this work CDBICompat has decide if an accessor
69 # method was put there by itself and only then overwrite.
70 {
71 my %our_accessors;
72
73 sub _has_custom_accessor {
74 my($class, $name) = @_;
75
76 no strict 'refs';
77 my $existing_accessor = *{$class .'::'. $name}{CODE};
78 return $existing_accessor && !$our_accessors{$existing_accessor};
79 }
80
81 sub _deploy_accessor {
82 my($class, $name, $accessor) = @_;
83
84 return if $class->_has_custom_accessor($name);
85
86 {
87 no strict 'refs';
88 no warnings 'redefine';
89 my $fullname = join '::', $class, $name;
90 *$fullname = Sub::Name::subname $fullname, $accessor;
91 }
92
93 $our_accessors{$accessor}++;
94
95 return 1;
96 }
97 }
98
99 sub _mk_group_accessors {
100 my ($class, $type, $group, @fields) = @_;
101
102 # So we don't have to do lots of lookups inside the loop.
103 my $maker = $class->can($type) unless ref $type;
104
105 # warn "$class $type $group\n";
106 foreach my $field (@fields) {
107 if( $field eq 'DESTROY' ) {
108 carp("Having a data accessor named DESTROY in ".
109 "'$class' is unwise.");
110 }
111
112 my $name = $field;
113
114 ($name, $field) = @$field if ref $field;
115
116 my $accessor = $class->$maker($group, $field);
117 my $alias = "_${name}_accessor";
118
119 # warn " $field $alias\n";
120 {
121 no strict 'refs';
122
123 $class->_deploy_accessor($name, $accessor);
124 $class->_deploy_accessor($alias, $accessor);
125 }
126 }
127 }
128
129 sub all_columns { return shift->result_source_instance->columns; }
130
131 sub primary_column {
132 my ($class) = @_;
133 my @pri = $class->primary_columns;
134 return wantarray ? @pri : $pri[0];
135 }
136
137 sub _essential {
138 return shift->columns("Essential");
139 }
140
141 sub find_column {
142 my ($class, $col) = @_;
143 return $col if $class->has_column($col);
144 }
145
146 sub __grouper {
147 my ($class) = @_;
148 my $grouper = { class => $class };
149 return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
150 }
151
152 sub _find_columns {
153 my ($class, @col) = @_;
154 return map { $class->find_column($_) } @col;
155 }
156
157 package # hide from PAUSE (should be harmless, no POD no Version)
158 DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
159
160 sub groups_for {
161 my ($self, @cols) = @_;
162 my %groups;
163 foreach my $col (@cols) {
164 foreach my $group (keys %{$self->{class}->_column_groups}) {
165 $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col};
166 }
167 }
168 return keys %groups;
169 }
170
171 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::ColumnGroups;
2
3 use strict;
4 use warnings;
5 use Sub::Name ();
6 use Storable 'dclone';
7
8 use base qw/DBIx::Class::Row/;
9
10 __PACKAGE__->mk_classdata('_column_groups' => { });
11
12 sub columns {
13 my $proto = shift;
14 my $class = ref $proto || $proto;
15 my $group = shift || "All";
16 $class->_init_result_source_instance();
17
18 $class->_add_column_group($group => @_) if @_;
19 return $class->all_columns if $group eq "All";
20 return $class->primary_column if $group eq "Primary";
21 return keys %{$class->_column_groups->{$group}};
22 }
23
24 sub _add_column_group {
25 my ($class, $group, @cols) = @_;
26 $class->mk_group_accessors(column => @cols);
27 $class->add_columns(@cols);
28 $class->_register_column_group($group => @cols);
29 }
30
31 sub add_columns {
32 my ($class, @cols) = @_;
33 $class->result_source_instance->add_columns(@cols);
34 }
35
36 sub _register_column_group {
37 my ($class, $group, @cols) = @_;
38
39 # Must do a complete deep copy else column groups
40 # might accidentally be shared.
41 my $groups = dclone $class->_column_groups;
42
43 if ($group eq 'Primary') {
44 $class->set_primary_key(@cols);
45 $groups->{'Essential'}{$_} ||= 1 for @cols;
46 }
47
48 if ($group eq 'All') {
49 unless (exists $class->_column_groups->{'Primary'}) {
50 $groups->{'Primary'}{$cols[0]} = 1;
51 $class->set_primary_key($cols[0]);
52 }
53 unless (exists $class->_column_groups->{'Essential'}) {
54 $groups->{'Essential'}{$cols[0]} = 1;
55 }
56 }
57
58 $groups->{$group}{$_} ||= 1 for @cols;
59
60 $class->_column_groups($groups);
61 }
62
63 # CDBI will never overwrite an accessor, but it only uses one
64 # accessor for all column types. DBIC uses many different
65 # accessor types so, for example, if you declare a column()
66 # and then a has_a() for that same column it must overwrite.
67 #
68 # To make this work CDBICompat has decide if an accessor
69 # method was put there by itself and only then overwrite.
70 {
71 my %our_accessors;
72
73 sub _has_custom_accessor {
74 my($class, $name) = @_;
75
76 no strict 'refs';
77 my $existing_accessor = *{$class .'::'. $name}{CODE};
78 return $existing_accessor && !$our_accessors{$existing_accessor};
79 }
80
81 sub _deploy_accessor {
82 my($class, $name, $accessor) = @_;
83
84 return if $class->_has_custom_accessor($name);
85
86 {
87 no strict 'refs';
88 no warnings 'redefine';
89 my $fullname = join '::', $class, $name;
90 *$fullname = Sub::Name::subname $fullname, $accessor;
91 }
92
93 $our_accessors{$accessor}++;
94
95 return 1;
96 }
97 }
98
99 sub _mk_group_accessors {
100 my ($class, $type, $group, @fields) = @_;
101
102 # So we don't have to do lots of lookups inside the loop.
103 my $maker = $class->can($type) unless ref $type;
104
105 # warn "$class $type $group\n";
106 foreach my $field (@fields) {
107 if( $field eq 'DESTROY' ) {
108 carp("Having a data accessor named DESTROY in ".
109 "'$class' is unwise.");
110 }
111
112 my $name = $field;
113
114 ($name, $field) = @$field if ref $field;
115
116 my $accessor = $class->$maker($group, $field);
117 my $alias = "_${name}_accessor";
118
119 # warn " $field $alias\n";
120 {
121 no strict 'refs';
122
123 $class->_deploy_accessor($name, $accessor);
124 $class->_deploy_accessor($alias, $accessor);
125 }
126 }
127 }
128
129 sub all_columns { return shift->result_source_instance->columns; }
130
131 sub primary_column {
132 my ($class) = @_;
133 my @pri = $class->primary_columns;
134 return wantarray ? @pri : $pri[0];
135 }
136
137 sub _essential {
138 return shift->columns("Essential");
139 }
140
141 sub find_column {
142 my ($class, $col) = @_;
143 return $col if $class->has_column($col);
144 }
145
146 sub __grouper {
147 my ($class) = @_;
148 my $grouper = { class => $class };
149 return bless($grouper, 'DBIx::Class::CDBICompat::ColumnGroups::GrouperShim');
150 }
151
152 sub _find_columns {
153 my ($class, @col) = @_;
154 return map { $class->find_column($_) } @col;
155 }
156
157 package # hide from PAUSE (should be harmless, no POD no Version)
158 DBIx::Class::CDBICompat::ColumnGroups::GrouperShim;
159
160 sub groups_for {
161 my ($self, @cols) = @_;
162 my %groups;
163 foreach my $col (@cols) {
164 foreach my $group (keys %{$self->{class}->_column_groups}) {
165 $groups{$group} = 1 if $self->{class}->_column_groups->{$group}->{$col};
166 }
167 }
168 return keys %groups;
169 }
170
171 1;
+51
-51
lib/DBIx/Class/CDBICompat/Constraints.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Constraints;
2
3 use strict;
4 use warnings;
5
6 sub constrain_column {
7 my $class = shift;
8 my $col = $class->find_column(+shift)
9 or return $class->throw_exception("constraint_column needs a valid column");
10 my $how = shift
11 or return $class->throw_exception("constrain_column needs a constraint");
12 if (ref $how eq "ARRAY") {
13 my %hash = map { $_ => 1 } @$how;
14 $class->add_constraint(list => $col => sub { exists $hash{ +shift } });
15 } elsif (ref $how eq "Regexp") {
16 $class->add_constraint(regexp => $col => sub { shift =~ $how });
17 } else {
18 $how =~ m/([^:]+)$/;
19 my $try_method = sprintf '_constrain_by_%s', lc $1; # $how->moniker;
20 if (my $dispatch = $class->can($try_method)) {
21 $class->$dispatch($col => ($how, @_));
22 } else {
23 $class->throw_exception("Don't know how to constrain $col with $how");
24 }
25 }
26 }
27
28 sub add_constraint {
29 my $class = shift;
30 $class->_invalid_object_method('add_constraint()') if ref $class;
31 my $name = shift or return $class->throw_exception("Constraint needs a name");
32 my $column = $class->find_column(+shift)
33 or return $class->throw_exception("Constraint $name needs a valid column");
34 my $code = shift
35 or return $class->throw_exception("Constraint $name needs a code reference");
36 return $class->throw_exception("Constraint $name '$code' is not a code reference")
37 unless ref($code) eq "CODE";
38
39 #$column->is_constrained(1);
40 $class->add_trigger(
41 "before_set_$column" => sub {
42 my ($self, $value, $column_values) = @_;
43 $code->($value, $self, $column, $column_values)
44 or return $self->throw_exception(
45 "$class $column fails '$name' constraint with '$value'");
46 }
47 );
48 }
49
50 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Constraints;
2
3 use strict;
4 use warnings;
5
6 sub constrain_column {
7 my $class = shift;
8 my $col = $class->find_column(+shift)
9 or return $class->throw_exception("constraint_column needs a valid column");
10 my $how = shift
11 or return $class->throw_exception("constrain_column needs a constraint");
12 if (ref $how eq "ARRAY") {
13 my %hash = map { $_ => 1 } @$how;
14 $class->add_constraint(list => $col => sub { exists $hash{ +shift } });
15 } elsif (ref $how eq "Regexp") {
16 $class->add_constraint(regexp => $col => sub { shift =~ $how });
17 } else {
18 $how =~ m/([^:]+)$/;
19 my $try_method = sprintf '_constrain_by_%s', lc $1; # $how->moniker;
20 if (my $dispatch = $class->can($try_method)) {
21 $class->$dispatch($col => ($how, @_));
22 } else {
23 $class->throw_exception("Don't know how to constrain $col with $how");
24 }
25 }
26 }
27
28 sub add_constraint {
29 my $class = shift;
30 $class->_invalid_object_method('add_constraint()') if ref $class;
31 my $name = shift or return $class->throw_exception("Constraint needs a name");
32 my $column = $class->find_column(+shift)
33 or return $class->throw_exception("Constraint $name needs a valid column");
34 my $code = shift
35 or return $class->throw_exception("Constraint $name needs a code reference");
36 return $class->throw_exception("Constraint $name '$code' is not a code reference")
37 unless ref($code) eq "CODE";
38
39 #$column->is_constrained(1);
40 $class->add_trigger(
41 "before_set_$column" => sub {
42 my ($self, $value, $column_values) = @_;
43 $code->($value, $self, $column, $column_values)
44 or return $self->throw_exception(
45 "$class $column fails '$name' constraint with '$value'");
46 }
47 );
48 }
49
50 1;
+15
-15
lib/DBIx/Class/CDBICompat/DestroyWarning.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::DestroyWarning;
2
3 use strict;
4 use warnings;
5
6 sub DESTROY {
7 my ($self) = @_;
8 my $class = ref $self;
9 warn "$class $self destroyed without saving changes to "
10 .join(', ', keys %{$self->{_dirty_columns} || {}})
11 if keys %{$self->{_dirty_columns} || {}};
12 }
13
14 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::DestroyWarning;
2
3 use strict;
4 use warnings;
5
6 sub DESTROY {
7 my ($self) = @_;
8 my $class = ref $self;
9 warn "$class $self destroyed without saving changes to "
10 .join(', ', keys %{$self->{_dirty_columns} || {}})
11 if keys %{$self->{_dirty_columns} || {}};
12 }
13
14 1;
+32
-32
lib/DBIx/Class/CDBICompat/GetSet.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::GetSet;
2
3 use strict;
4 use warnings;
5
6 #use base qw/Class::Accessor/;
7
8 sub get {
9 my ($self, @cols) = @_;
10 if (@cols > 1) {
11 return map { $self->get_column($_) } @cols;
12 } else {
13 return $self->get_column($_[1]);
14 }
15 }
16
17 sub set {
18 my($self, %data) = @_;
19
20 # set_columns() is going to do a string comparison before setting.
21 # This breaks on DateTime objects (whose comparison is arguably broken)
22 # so we stringify anything first.
23 for my $key (keys %data) {
24 next unless ref $data{$key};
25 $data{$key} = "$data{$key}";
26 }
27
28 return shift->set_columns(\%data);
29 }
30
31 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::GetSet;
2
3 use strict;
4 use warnings;
5
6 #use base qw/Class::Accessor/;
7
8 sub get {
9 my ($self, @cols) = @_;
10 if (@cols > 1) {
11 return map { $self->get_column($_) } @cols;
12 } else {
13 return $self->get_column($_[1]);
14 }
15 }
16
17 sub set {
18 my($self, %data) = @_;
19
20 # set_columns() is going to do a string comparison before setting.
21 # This breaks on DateTime objects (whose comparison is arguably broken)
22 # so we stringify anything first.
23 for my $key (keys %data) {
24 next unless ref $data{$key};
25 $data{$key} = "$data{$key}";
26 }
27
28 return shift->set_columns(\%data);
29 }
30
31 1;
+144
-144
lib/DBIx/Class/CDBICompat/ImaDBI.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::ImaDBI;
2
3 use strict;
4 use warnings;
5 use DBIx::ContextualFetch;
6 use Sub::Name ();
7
8 use base qw(Class::Data::Inheritable);
9
10 __PACKAGE__->mk_classdata('sql_transformer_class' =>
11 'DBIx::Class::CDBICompat::SQLTransformer');
12
13 __PACKAGE__->mk_classdata('_transform_sql_handler_order'
14 => [ qw/TABLE ESSENTIAL JOIN IDENTIFIER/ ] );
15
16 __PACKAGE__->mk_classdata('_transform_sql_handlers' =>
17 {
18 'TABLE' =>
19 sub {
20 my ($self, $class, $data) = @_;
21 return $class->result_source_instance->name unless $data;
22 my ($f_class, $alias) = split(/=/, $data);
23 $f_class ||= $class;
24 $self->{_classes}{$alias} = $f_class;
25 return $f_class->result_source_instance->name." ${alias}";
26 },
27 'ESSENTIAL' =>
28 sub {
29 my ($self, $class, $data) = @_;
30 $class = $data ? $self->{_classes}{$data} : $class;
31 return join(', ', $class->columns('Essential'));
32 },
33 'IDENTIFIER' =>
34 sub {
35 my ($self, $class, $data) = @_;
36 $class = $data ? $self->{_classes}{$data} : $class;
37 return join ' AND ', map "$_ = ?", $class->primary_columns;
38 },
39 'JOIN' =>
40 sub {
41 my ($self, $class, $data) = @_;
42 my ($from, $to) = split(/ /, $data);
43 my ($from_class, $to_class) = @{$self->{_classes}}{$from, $to};
44 my ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
45 map { $from_class->relationship_info($_) }
46 $from_class->relationships;
47 unless ($rel_obj) {
48 ($from, $to) = ($to, $from);
49 ($from_class, $to_class) = ($to_class, $from_class);
50 ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
51 map { $from_class->relationship_info($_) }
52 $from_class->relationships;
53 }
54 $self->throw_exception( "No relationship to JOIN from ${from_class} to ${to_class}" )
55 unless $rel_obj;
56 my $join = $from_class->storage->sql_maker->_join_condition(
57 $from_class->result_source_instance->_resolve_condition(
58 $rel_obj->{cond}, $to, $from) );
59 return $join;
60 }
61
62 } );
63
64 sub db_Main {
65 return $_[0]->storage->dbh;
66 }
67
68 sub connection {
69 my ($class, @info) = @_;
70 $info[3] = { %{ $info[3] || {}} };
71 $info[3]->{RootClass} = 'DBIx::ContextualFetch';
72 return $class->next::method(@info);
73 }
74
75 sub __driver {
76 return $_[0]->storage->dbh->{Driver}->{Name};
77 }
78
79 sub set_sql {
80 my ($class, $name, $sql) = @_;
81 no strict 'refs';
82 my $sql_name = "sql_${name}";
83 my $full_sql_name = join '::', $class, $sql_name;
84 *$full_sql_name = Sub::Name::subname $full_sql_name,
85 sub {
86 my $sql = $sql;
87 my $class = shift;
88 return $class->storage->sth($class->transform_sql($sql, @_));
89 };
90 if ($sql =~ /select/i) {
91 my $search_name = "search_${name}";
92 my $full_search_name = join '::', $class, $search_name;
93 *$full_search_name = Sub::Name::subname $full_search_name,
94 sub {
95 my ($class, @args) = @_;
96 my $sth = $class->$sql_name;
97 return $class->sth_to_objects($sth, \@args);
98 };
99 }
100 }
101
102 sub sth_to_objects {
103 my ($class, $sth, $execute_args) = @_;
104
105 $sth->execute(@$execute_args);
106
107 my @ret;
108 while (my $row = $sth->fetchrow_hashref) {
109 push(@ret, $class->inflate_result($class->result_source_instance, $row));
110 }
111
112 return @ret;
113 }
114
115 sub transform_sql {
116 my ($class, $sql, @args) = @_;
117
118 my $tclass = $class->sql_transformer_class;
119 $class->ensure_class_loaded($tclass);
120 my $t = $tclass->new($class, $sql, @args);
121
122 return sprintf($t->sql, $t->args);
123 }
124
125 package
126 DBIx::ContextualFetch::st; # HIDE FROM PAUSE THIS IS NOT OUR CLASS
127
128 no warnings 'redefine';
129
130 sub _untaint_execute {
131 my $sth = shift;
132 my $old_value = $sth->{Taint};
133 $sth->{Taint} = 0;
134 my $ret;
135 {
136 no warnings 'uninitialized';
137 $ret = $sth->SUPER::execute(@_);
138 }
139 $sth->{Taint} = $old_value;
140 return $ret;
141 }
142
143 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::ImaDBI;
2
3 use strict;
4 use warnings;
5 use DBIx::ContextualFetch;
6 use Sub::Name ();
7
8 use base qw(Class::Data::Inheritable);
9
10 __PACKAGE__->mk_classdata('sql_transformer_class' =>
11 'DBIx::Class::CDBICompat::SQLTransformer');
12
13 __PACKAGE__->mk_classdata('_transform_sql_handler_order'
14 => [ qw/TABLE ESSENTIAL JOIN IDENTIFIER/ ] );
15
16 __PACKAGE__->mk_classdata('_transform_sql_handlers' =>
17 {
18 'TABLE' =>
19 sub {
20 my ($self, $class, $data) = @_;
21 return $class->result_source_instance->name unless $data;
22 my ($f_class, $alias) = split(/=/, $data);
23 $f_class ||= $class;
24 $self->{_classes}{$alias} = $f_class;
25 return $f_class->result_source_instance->name." ${alias}";
26 },
27 'ESSENTIAL' =>
28 sub {
29 my ($self, $class, $data) = @_;
30 $class = $data ? $self->{_classes}{$data} : $class;
31 return join(', ', $class->columns('Essential'));
32 },
33 'IDENTIFIER' =>
34 sub {
35 my ($self, $class, $data) = @_;
36 $class = $data ? $self->{_classes}{$data} : $class;
37 return join ' AND ', map "$_ = ?", $class->primary_columns;
38 },
39 'JOIN' =>
40 sub {
41 my ($self, $class, $data) = @_;
42 my ($from, $to) = split(/ /, $data);
43 my ($from_class, $to_class) = @{$self->{_classes}}{$from, $to};
44 my ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
45 map { $from_class->relationship_info($_) }
46 $from_class->relationships;
47 unless ($rel_obj) {
48 ($from, $to) = ($to, $from);
49 ($from_class, $to_class) = ($to_class, $from_class);
50 ($rel_obj) = grep { $_->{class} && $_->{class} eq $to_class }
51 map { $from_class->relationship_info($_) }
52 $from_class->relationships;
53 }
54 $self->throw_exception( "No relationship to JOIN from ${from_class} to ${to_class}" )
55 unless $rel_obj;
56 my $join = $from_class->storage->sql_maker->_join_condition(
57 $from_class->result_source_instance->_resolve_condition(
58 $rel_obj->{cond}, $to, $from) );
59 return $join;
60 }
61
62 } );
63
64 sub db_Main {
65 return $_[0]->storage->dbh;
66 }
67
68 sub connection {
69 my ($class, @info) = @_;
70 $info[3] = { %{ $info[3] || {}} };
71 $info[3]->{RootClass} = 'DBIx::ContextualFetch';
72 return $class->next::method(@info);
73 }
74
75 sub __driver {
76 return $_[0]->storage->dbh->{Driver}->{Name};
77 }
78
79 sub set_sql {
80 my ($class, $name, $sql) = @_;
81 no strict 'refs';
82 my $sql_name = "sql_${name}";
83 my $full_sql_name = join '::', $class, $sql_name;
84 *$full_sql_name = Sub::Name::subname $full_sql_name,
85 sub {
86 my $sql = $sql;
87 my $class = shift;
88 return $class->storage->sth($class->transform_sql($sql, @_));
89 };
90 if ($sql =~ /select/i) {
91 my $search_name = "search_${name}";
92 my $full_search_name = join '::', $class, $search_name;
93 *$full_search_name = Sub::Name::subname $full_search_name,
94 sub {
95 my ($class, @args) = @_;
96 my $sth = $class->$sql_name;
97 return $class->sth_to_objects($sth, \@args);
98 };
99 }
100 }
101
102 sub sth_to_objects {
103 my ($class, $sth, $execute_args) = @_;
104
105 $sth->execute(@$execute_args);
106
107 my @ret;
108 while (my $row = $sth->fetchrow_hashref) {
109 push(@ret, $class->inflate_result($class->result_source_instance, $row));
110 }
111
112 return @ret;
113 }
114
115 sub transform_sql {
116 my ($class, $sql, @args) = @_;
117
118 my $tclass = $class->sql_transformer_class;
119 $class->ensure_class_loaded($tclass);
120 my $t = $tclass->new($class, $sql, @args);
121
122 return sprintf($t->sql, $t->args);
123 }
124
125 package
126 DBIx::ContextualFetch::st; # HIDE FROM PAUSE THIS IS NOT OUR CLASS
127
128 no warnings 'redefine';
129
130 sub _untaint_execute {
131 my $sth = shift;
132 my $old_value = $sth->{Taint};
133 $sth->{Taint} = 0;
134 my $ret;
135 {
136 no warnings 'uninitialized';
137 $ret = $sth->SUPER::execute(@_);
138 }
139 $sth->{Taint} = $old_value;
140 return $ret;
141 }
142
143 1;
+115
-115
lib/DBIx/Class/CDBICompat/LazyLoading.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::LazyLoading;
2
3 use strict;
4 use warnings;
5
6 sub resultset_instance {
7 my $self = shift;
8 my $rs = $self->next::method(@_);
9 $rs = $rs->search(undef, { columns => [ $self->columns('Essential') ] });
10 return $rs;
11 }
12
13
14 # Emulate that CDBI throws out all changed columns and reloads them on
15 # request in case the database modifies the new value (say, via a trigger)
16 sub update {
17 my $self = shift;
18
19 my @dirty_columns = keys %{$self->{_dirty_columns}};
20
21 my $ret = $self->next::method(@_);
22 $self->_clear_column_data(@dirty_columns);
23
24 return $ret;
25 }
26
27
28 # And again for create
29 sub create {
30 my $class = shift;
31 my($data) = @_;
32
33 my @columns = keys %$data;
34
35 my $obj = $class->next::method(@_);
36 return $obj unless defined $obj;
37
38 my %primary_cols = map { $_ => 1 } $class->primary_columns;
39 my @data_cols = grep !$primary_cols{$_}, @columns;
40 $obj->_clear_column_data(@data_cols);
41
42 return $obj;
43 }
44
45
46 sub _clear_column_data {
47 my $self = shift;
48
49 delete $self->{_column_data}{$_} for @_;
50 delete $self->{_inflated_column}{$_} for @_;
51 }
52
53
54 sub get_column {
55 my ($self, $col) = @_;
56 if ((ref $self) && (!exists $self->{'_column_data'}{$col})
57 && $self->{'_in_storage'}) {
58 $self->_flesh(grep { exists $self->_column_groups->{$_}{$col}
59 && $_ ne 'All' }
60 keys %{ $self->_column_groups || {} });
61 }
62 $self->next::method(@_[1..$#_]);
63 }
64
65 # CDBI does not explicitly declare auto increment columns, so
66 # we just clear out our primary columns before copying.
67 sub copy {
68 my($self, $changes) = @_;
69
70 for my $col ($self->primary_columns) {
71 $changes->{$col} = undef unless exists $changes->{$col};
72 }
73
74 return $self->next::method($changes);
75 }
76
77 sub discard_changes {
78 my($self) = shift;
79
80 delete $self->{_column_data}{$_} for $self->is_changed;
81 delete $self->{_dirty_columns};
82 delete $self->{_relationship_data};
83
84 return $self;
85 }
86
87 sub _ident_cond {
88 my ($class) = @_;
89 return join(" AND ", map { "$_ = ?" } $class->primary_columns);
90 }
91
92 sub _flesh {
93 my ($self, @groups) = @_;
94 @groups = ('All') unless @groups;
95 my %want;
96 $want{$_} = 1 for map { keys %{$self->_column_groups->{$_}} } @groups;
97 if (my @want = grep { !exists $self->{'_column_data'}{$_} } keys %want) {
98 my $cursor = $self->result_source->storage->select(
99 $self->result_source->name, \@want,
100 \$self->_ident_cond, { bind => [ $self->_ident_values ] });
101 #my $sth = $self->storage->select($self->_table_name, \@want,
102 # $self->ident_condition);
103 # Not sure why the first one works and this doesn't :(
104 my @val = $cursor->next;
105
106 return unless @val; # object must have been deleted from the database
107
108 foreach my $w (@want) {
109 $self->{'_column_data'}{$w} = shift @val;
110 }
111 }
112 }
113
114 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::LazyLoading;
2
3 use strict;
4 use warnings;
5
6 sub resultset_instance {
7 my $self = shift;
8 my $rs = $self->next::method(@_);
9 $rs = $rs->search(undef, { columns => [ $self->columns('Essential') ] });
10 return $rs;
11 }
12
13
14 # Emulate that CDBI throws out all changed columns and reloads them on
15 # request in case the database modifies the new value (say, via a trigger)
16 sub update {
17 my $self = shift;
18
19 my @dirty_columns = keys %{$self->{_dirty_columns}};
20
21 my $ret = $self->next::method(@_);
22 $self->_clear_column_data(@dirty_columns);
23
24 return $ret;
25 }
26
27
28 # And again for create
29 sub create {
30 my $class = shift;
31 my($data) = @_;
32
33 my @columns = keys %$data;
34
35 my $obj = $class->next::method(@_);
36 return $obj unless defined $obj;
37
38 my %primary_cols = map { $_ => 1 } $class->primary_columns;
39 my @data_cols = grep !$primary_cols{$_}, @columns;
40 $obj->_clear_column_data(@data_cols);
41
42 return $obj;
43 }
44
45
46 sub _clear_column_data {
47 my $self = shift;
48
49 delete $self->{_column_data}{$_} for @_;
50 delete $self->{_inflated_column}{$_} for @_;
51 }
52
53
54 sub get_column {
55 my ($self, $col) = @_;
56 if ((ref $self) && (!exists $self->{'_column_data'}{$col})
57 && $self->{'_in_storage'}) {
58 $self->_flesh(grep { exists $self->_column_groups->{$_}{$col}
59 && $_ ne 'All' }
60 keys %{ $self->_column_groups || {} });
61 }
62 $self->next::method(@_[1..$#_]);
63 }
64
65 # CDBI does not explicitly declare auto increment columns, so
66 # we just clear out our primary columns before copying.
67 sub copy {
68 my($self, $changes) = @_;
69
70 for my $col ($self->primary_columns) {
71 $changes->{$col} = undef unless exists $changes->{$col};
72 }
73
74 return $self->next::method($changes);
75 }
76
77 sub discard_changes {
78 my($self) = shift;
79
80 delete $self->{_column_data}{$_} for $self->is_changed;
81 delete $self->{_dirty_columns};
82 delete $self->{_relationship_data};
83
84 return $self;
85 }
86
87 sub _ident_cond {
88 my ($class) = @_;
89 return join(" AND ", map { "$_ = ?" } $class->primary_columns);
90 }
91
92 sub _flesh {
93 my ($self, @groups) = @_;
94 @groups = ('All') unless @groups;
95 my %want;
96 $want{$_} = 1 for map { keys %{$self->_column_groups->{$_}} } @groups;
97 if (my @want = grep { !exists $self->{'_column_data'}{$_} } keys %want) {
98 my $cursor = $self->result_source->storage->select(
99 $self->result_source->name, \@want,
100 \$self->_ident_cond, { bind => [ $self->_ident_values ] });
101 #my $sth = $self->storage->select($self->_table_name, \@want,
102 # $self->ident_condition);
103 # Not sure why the first one works and this doesn't :(
104 my @val = $cursor->next;
105
106 return unless @val; # object must have been deleted from the database
107
108 foreach my $w (@want) {
109 $self->{'_column_data'}{$w} = shift @val;
110 }
111 }
112 }
113
114 1;
+34
-34
lib/DBIx/Class/CDBICompat/NoObjectIndex.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::NoObjectIndex;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 DBIx::Class::CDBICompat::NoObjectIndex - Defines empty methods for object indexing. They do nothing
9
10 =head1 SYNOPSIS
11
12 Part of CDBICompat
13
14 =head1 DESCRIPTION
15
16 Defines empty methods for object indexing. They do nothing.
17
18 Using NoObjectIndex instead of LiveObjectIndex and nocache(1) is a little
19 faster because it removes code from the object insert and retrieve chains.
20
21 =cut
22
23 sub nocache { return 1 }
24
25 sub purge_object_index_every {}
26
27 sub purge_dead_from_object_index {}
28
29 sub remove_from_object_index {}
30
31 sub clear_object_index {}
32
33 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::NoObjectIndex;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 DBIx::Class::CDBICompat::NoObjectIndex - Defines empty methods for object indexing. They do nothing
9
10 =head1 SYNOPSIS
11
12 Part of CDBICompat
13
14 =head1 DESCRIPTION
15
16 Defines empty methods for object indexing. They do nothing.
17
18 Using NoObjectIndex instead of LiveObjectIndex and nocache(1) is a little
19 faster because it removes code from the object insert and retrieve chains.
20
21 =cut
22
23 sub nocache { return 1 }
24
25 sub purge_object_index_every {}
26
27 sub purge_dead_from_object_index {}
28
29 sub remove_from_object_index {}
30
31 sub clear_object_index {}
32
33 1;
+19
-19
lib/DBIx/Class/CDBICompat/Pager.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Pager;
2
3 use strict;
4 use warnings FATAL => 'all';
5
6 *pager = \&page;
7
8 sub page {
9 my $class = shift;
10
11 my $rs = $class->search(@_);
12 unless ($rs->{attrs}{page}) {
13 $rs = $rs->page(1);
14 }
15 return ( $rs->pager, $rs );
16 }
17
18 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Pager;
2
3 use strict;
4 use warnings FATAL => 'all';
5
6 *pager = \&page;
7
8 sub page {
9 my $class = shift;
10
11 my $rs = $class->search(@_);
12 unless ($rs->{attrs}{page}) {
13 $rs = $rs->page(1);
14 }
15 return ( $rs->pager, $rs );
16 }
17
18 1;
+14
-14
lib/DBIx/Class/CDBICompat/ReadOnly.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::ReadOnly;
2
3 use strict;
4 use warnings;
5
6 sub make_read_only {
7 my $proto = shift;
8 $proto->add_trigger("before_$_" => sub { shift->throw_exception("$proto is read only") })
9 foreach qw/create delete update/;
10 return $proto;
11 }
12
13 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::ReadOnly;
2
3 use strict;
4 use warnings;
5
6 sub make_read_only {
7 my $proto = shift;
8 $proto->add_trigger("before_$_" => sub { shift->throw_exception("$proto is read only") })
9 foreach qw/create delete update/;
10 return $proto;
11 }
12
13 1;
+42
-42
lib/DBIx/Class/CDBICompat/Relationship.pm less more
0 package
1 DBIx::Class::CDBICompat::Relationship;
2
3 use strict;
4 use warnings;
5 use Sub::Name ();
6
7 =head1 NAME
8
9 DBIx::Class::CDBICompat::Relationship - Emulate the Class::DBI::Relationship object returned from meta_info()
10
11 =head1 DESCRIPTION
12
13 Emulate the Class::DBI::Relationship object returned from C<meta_info()>.
14
15 =cut
16
17 my %method2key = (
18 name => 'type',
19 class => 'self_class',
20 accessor => 'accessor',
21 foreign_class => 'class',
22 args => 'args',
23 );
24
25 sub new {
26 my($class, $args) = @_;
27
28 return bless $args, $class;
29 }
30
31 for my $method (keys %method2key) {
32 my $key = $method2key{$method};
33 my $code = sub {
34 $_[0]->{$key};
35 };
36
37 no strict 'refs';
38 *{$method} = Sub::Name::subname $method, $code;
39 }
40
41 1;
0 package
1 DBIx::Class::CDBICompat::Relationship;
2
3 use strict;
4 use warnings;
5 use Sub::Name ();
6
7 =head1 NAME
8
9 DBIx::Class::CDBICompat::Relationship - Emulate the Class::DBI::Relationship object returned from meta_info()
10
11 =head1 DESCRIPTION
12
13 Emulate the Class::DBI::Relationship object returned from C<meta_info()>.
14
15 =cut
16
17 my %method2key = (
18 name => 'type',
19 class => 'self_class',
20 accessor => 'accessor',
21 foreign_class => 'class',
22 args => 'args',
23 );
24
25 sub new {
26 my($class, $args) = @_;
27
28 return bless $args, $class;
29 }
30
31 for my $method (keys %method2key) {
32 my $key = $method2key{$method};
33 my $code = sub {
34 $_[0]->{$key};
35 };
36
37 no strict 'refs';
38 *{$method} = Sub::Name::subname $method, $code;
39 }
40
41 1;
+203
-203
lib/DBIx/Class/CDBICompat/Relationships.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Relationships;
2
3 use strict;
4 use warnings;
5 use Sub::Name ();
6 use base qw/Class::Data::Inheritable/;
7
8 use Clone;
9 use DBIx::Class::CDBICompat::Relationship;
10
11 __PACKAGE__->mk_classdata('__meta_info' => {});
12
13
14 =head1 NAME
15
16 DBIx::Class::CDBICompat::Relationships - Emulate has_a(), has_many(), might_have() and meta_info()
17
18 =head1 DESCRIPTION
19
20 Emulate C<has_a>, C<has_many>, C<might_have> and C<meta_info>.
21
22 =cut
23
24 sub has_a {
25 my($self, $col, @rest) = @_;
26
27 $self->_declare_has_a($col, @rest);
28 $self->_mk_inflated_column_accessor($col);
29
30 return 1;
31 }
32
33
34 sub _declare_has_a {
35 my ($self, $col, $f_class, %args) = @_;
36 $self->throw_exception( "No such column ${col}" )
37 unless $self->has_column($col);
38 $self->ensure_class_loaded($f_class);
39
40 my $rel_info;
41
42 if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
43 if (!ref $args{'inflate'}) {
44 my $meth = $args{'inflate'};
45 $args{'inflate'} = sub { $f_class->$meth(shift); };
46 }
47 if (!ref $args{'deflate'}) {
48 my $meth = $args{'deflate'};
49 $args{'deflate'} = sub { shift->$meth; };
50 }
51 $self->inflate_column($col, \%args);
52
53 $rel_info = {
54 class => $f_class
55 };
56 }
57 else {
58 $self->belongs_to($col, $f_class);
59 $rel_info = $self->result_source_instance->relationship_info($col);
60 }
61
62 $rel_info->{args} = \%args;
63
64 $self->_extend_meta(
65 has_a => $col,
66 $rel_info
67 );
68
69 return 1;
70 }
71
72 sub _mk_inflated_column_accessor {
73 my($class, $col) = @_;
74
75 return $class->mk_group_accessors('inflated_column' => $col);
76 }
77
78 sub has_many {
79 my ($class, $rel, $f_class, $f_key, $args) = @_;
80
81 my @f_method;
82
83 if (ref $f_class eq 'ARRAY') {
84 ($f_class, @f_method) = @$f_class;
85 }
86
87 if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; };
88
89 $args ||= {};
90 my $cascade = delete $args->{cascade} || '';
91 if (delete $args->{no_cascade_delete} || $cascade eq 'None') {
92 $args->{cascade_delete} = 0;
93 }
94 elsif( $cascade eq 'Delete' ) {
95 $args->{cascade_delete} = 1;
96 }
97 elsif( length $cascade ) {
98 warn "Unemulated cascade option '$cascade' in $class->has_many($rel => $f_class)";
99 }
100
101 if( !$f_key and !@f_method ) {
102 $class->ensure_class_loaded($f_class);
103 my $f_source = $f_class->result_source_instance;
104 ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class }
105 $f_source->relationships;
106 }
107
108 $class->next::method($rel, $f_class, $f_key, $args);
109
110 my $rel_info = $class->result_source_instance->relationship_info($rel);
111 $args->{mapping} = \@f_method;
112 $args->{foreign_key} = $f_key;
113 $rel_info->{args} = $args;
114
115 $class->_extend_meta(
116 has_many => $rel,
117 $rel_info
118 );
119
120 if (@f_method) {
121 no strict 'refs';
122 no warnings 'redefine';
123 my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
124 my $name = join '::', $class, $rel;
125 *$name = Sub::Name::subname $name,
126 sub {
127 my $rs = shift->search_related($rel => @_);
128 $rs->{attrs}{record_filter} = $post_proc;
129 return (wantarray ? $rs->all : $rs);
130 };
131 return 1;
132 }
133
134 }
135
136
137 sub might_have {
138 my ($class, $rel, $f_class, @columns) = @_;
139
140 my $ret;
141 if (ref $columns[0] || !defined $columns[0]) {
142 $ret = $class->next::method($rel, $f_class, @columns);
143 } else {
144 $ret = $class->next::method($rel, $f_class, undef,
145 { proxy => \@columns });
146 }
147
148 my $rel_info = $class->result_source_instance->relationship_info($rel);
149 $rel_info->{args}{import} = \@columns;
150
151 $class->_extend_meta(
152 might_have => $rel,
153 $rel_info
154 );
155
156 return $ret;
157 }
158
159
160 sub _extend_meta {
161 my ($class, $type, $rel, $val) = @_;
162 my %hash = %{ Clone::clone($class->__meta_info || {}) };
163
164 $val->{self_class} = $class;
165 $val->{type} = $type;
166 $val->{accessor} = $rel;
167
168 $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val);
169 $class->__meta_info(\%hash);
170 }
171
172
173 sub meta_info {
174 my ($class, $type, $rel) = @_;
175 my $meta = $class->__meta_info;
176 return $meta unless $type;
177
178 my $type_meta = $meta->{$type};
179 return $type_meta unless $rel;
180 return $type_meta->{$rel};
181 }
182
183
184 sub search {
185 my $self = shift;
186 my $attrs = {};
187 if (@_ > 1 && ref $_[$#_] eq 'HASH') {
188 $attrs = { %{ pop(@_) } };
189 }
190 my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift)
191 : {@_})
192 : undef());
193 if (ref $where eq 'HASH') {
194 foreach my $key (keys %$where) { # has_a deflation hack
195 $where->{$key} = ''.$where->{$key}
196 if eval { $where->{$key}->isa('DBIx::Class') };
197 }
198 }
199 $self->next::method($where, $attrs);
200 }
201
202 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Relationships;
2
3 use strict;
4 use warnings;
5 use Sub::Name ();
6 use base qw/Class::Data::Inheritable/;
7
8 use Clone;
9 use DBIx::Class::CDBICompat::Relationship;
10
11 __PACKAGE__->mk_classdata('__meta_info' => {});
12
13
14 =head1 NAME
15
16 DBIx::Class::CDBICompat::Relationships - Emulate has_a(), has_many(), might_have() and meta_info()
17
18 =head1 DESCRIPTION
19
20 Emulate C<has_a>, C<has_many>, C<might_have> and C<meta_info>.
21
22 =cut
23
24 sub has_a {
25 my($self, $col, @rest) = @_;
26
27 $self->_declare_has_a($col, @rest);
28 $self->_mk_inflated_column_accessor($col);
29
30 return 1;
31 }
32
33
34 sub _declare_has_a {
35 my ($self, $col, $f_class, %args) = @_;
36 $self->throw_exception( "No such column ${col}" )
37 unless $self->has_column($col);
38 $self->ensure_class_loaded($f_class);
39
40 my $rel_info;
41
42 if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
43 if (!ref $args{'inflate'}) {
44 my $meth = $args{'inflate'};
45 $args{'inflate'} = sub { $f_class->$meth(shift); };
46 }
47 if (!ref $args{'deflate'}) {
48 my $meth = $args{'deflate'};
49 $args{'deflate'} = sub { shift->$meth; };
50 }
51 $self->inflate_column($col, \%args);
52
53 $rel_info = {
54 class => $f_class
55 };
56 }
57 else {
58 $self->belongs_to($col, $f_class);
59 $rel_info = $self->result_source_instance->relationship_info($col);
60 }
61
62 $rel_info->{args} = \%args;
63
64 $self->_extend_meta(
65 has_a => $col,
66 $rel_info
67 );
68
69 return 1;
70 }
71
72 sub _mk_inflated_column_accessor {
73 my($class, $col) = @_;
74
75 return $class->mk_group_accessors('inflated_column' => $col);
76 }
77
78 sub has_many {
79 my ($class, $rel, $f_class, $f_key, $args) = @_;
80
81 my @f_method;
82
83 if (ref $f_class eq 'ARRAY') {
84 ($f_class, @f_method) = @$f_class;
85 }
86
87 if (ref $f_key eq 'HASH' && !$args) { $args = $f_key; undef $f_key; };
88
89 $args ||= {};
90 my $cascade = delete $args->{cascade} || '';
91 if (delete $args->{no_cascade_delete} || $cascade eq 'None') {
92 $args->{cascade_delete} = 0;
93 }
94 elsif( $cascade eq 'Delete' ) {
95 $args->{cascade_delete} = 1;
96 }
97 elsif( length $cascade ) {
98 warn "Unemulated cascade option '$cascade' in $class->has_many($rel => $f_class)";
99 }
100
101 if( !$f_key and !@f_method ) {
102 $class->ensure_class_loaded($f_class);
103 my $f_source = $f_class->result_source_instance;
104 ($f_key) = grep { $f_source->relationship_info($_)->{class} eq $class }
105 $f_source->relationships;
106 }
107
108 $class->next::method($rel, $f_class, $f_key, $args);
109
110 my $rel_info = $class->result_source_instance->relationship_info($rel);
111 $args->{mapping} = \@f_method;
112 $args->{foreign_key} = $f_key;
113 $rel_info->{args} = $args;
114
115 $class->_extend_meta(
116 has_many => $rel,
117 $rel_info
118 );
119
120 if (@f_method) {
121 no strict 'refs';
122 no warnings 'redefine';
123 my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
124 my $name = join '::', $class, $rel;
125 *$name = Sub::Name::subname $name,
126 sub {
127 my $rs = shift->search_related($rel => @_);
128 $rs->{attrs}{record_filter} = $post_proc;
129 return (wantarray ? $rs->all : $rs);
130 };
131 return 1;
132 }
133
134 }
135
136
137 sub might_have {
138 my ($class, $rel, $f_class, @columns) = @_;
139
140 my $ret;
141 if (ref $columns[0] || !defined $columns[0]) {
142 $ret = $class->next::method($rel, $f_class, @columns);
143 } else {
144 $ret = $class->next::method($rel, $f_class, undef,
145 { proxy => \@columns });
146 }
147
148 my $rel_info = $class->result_source_instance->relationship_info($rel);
149 $rel_info->{args}{import} = \@columns;
150
151 $class->_extend_meta(
152 might_have => $rel,
153 $rel_info
154 );
155
156 return $ret;
157 }
158
159
160 sub _extend_meta {
161 my ($class, $type, $rel, $val) = @_;
162 my %hash = %{ Clone::clone($class->__meta_info || {}) };
163
164 $val->{self_class} = $class;
165 $val->{type} = $type;
166 $val->{accessor} = $rel;
167
168 $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val);
169 $class->__meta_info(\%hash);
170 }
171
172
173 sub meta_info {
174 my ($class, $type, $rel) = @_;
175 my $meta = $class->__meta_info;
176 return $meta unless $type;
177
178 my $type_meta = $meta->{$type};
179 return $type_meta unless $rel;
180 return $type_meta->{$rel};
181 }
182
183
184 sub search {
185 my $self = shift;
186 my $attrs = {};
187 if (@_ > 1 && ref $_[$#_] eq 'HASH') {
188 $attrs = { %{ pop(@_) } };
189 }
190 my $where = (@_ ? ((@_ == 1) ? ((ref $_[0] eq "HASH") ? { %{+shift} } : shift)
191 : {@_})
192 : undef());
193 if (ref $where eq 'HASH') {
194 foreach my $key (keys %$where) { # has_a deflation hack
195 $where->{$key} = ''.$where->{$key}
196 if eval { $where->{$key}->isa('DBIx::Class') };
197 }
198 }
199 $self->next::method($where, $attrs);
200 }
201
202 1;
+94
-94
lib/DBIx/Class/CDBICompat/Retrieve.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Retrieve;
2
3 use strict;
4 use warnings FATAL => 'all';
5
6
7 sub retrieve {
8 my $self = shift;
9 die "No args to retrieve" unless @_ > 0;
10
11 my @cols = $self->primary_columns;
12
13 my $query;
14 if (ref $_[0] eq 'HASH') {
15 $query = { %{$_[0]} };
16 }
17 elsif (@_ == @cols) {
18 $query = {};
19 @{$query}{@cols} = @_;
20 }
21 else {
22 $query = {@_};
23 }
24
25 $query = $self->_build_query($query);
26 $self->find($query);
27 }
28
29 sub find_or_create {
30 my $self = shift;
31 my $query = ref $_[0] eq 'HASH' ? shift : {@_};
32
33 $query = $self->_build_query($query);
34 $self->next::method($query);
35 }
36
37 # _build_query
38 #
39 # Build a query hash. Defaults to a no-op; ColumnCase overrides.
40
41 sub _build_query {
42 my ($self, $query) = @_;
43
44 return $query;
45 }
46
47 sub retrieve_from_sql {
48 my ($class, $cond, @rest) = @_;
49
50 $cond =~ s/^\s*WHERE//i;
51
52 # Need to parse the SQL clauses after WHERE in reverse
53 # order of appearance.
54
55 my %attrs;
56
57 if( $cond =~ s/\bLIMIT\s+(\d+)\s*$//i ) {
58 $attrs{rows} = $1;
59 }
60
61 if ( $cond =~ s/\bORDER\s+BY\s+(.*)\s*$//i ) {
62 $attrs{order_by} = $1;
63 }
64
65 if( $cond =~ s/\bGROUP\s+BY\s+(.*)\s*$//i ) {
66 $attrs{group_by} = $1;
67 }
68
69 return $class->search_literal($cond, @rest, ( %attrs ? \%attrs : () ) );
70 }
71
72 sub construct {
73 my $class = shift;
74 my $obj = $class->resultset_instance->new_result(@_);
75 $obj->in_storage(1);
76
77 return $obj;
78 }
79
80 sub retrieve_all { shift->search }
81 sub count_all { shift->count }
82
83 sub maximum_value_of {
84 my($class, $col) = @_;
85 return $class->resultset_instance->get_column($col)->max;
86 }
87
88 sub minimum_value_of {
89 my($class, $col) = @_;
90 return $class->resultset_instance->get_column($col)->min;
91 }
92
93 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Retrieve;
2
3 use strict;
4 use warnings FATAL => 'all';
5
6
7 sub retrieve {
8 my $self = shift;
9 die "No args to retrieve" unless @_ > 0;
10
11 my @cols = $self->primary_columns;
12
13 my $query;
14 if (ref $_[0] eq 'HASH') {
15 $query = { %{$_[0]} };
16 }
17 elsif (@_ == @cols) {
18 $query = {};
19 @{$query}{@cols} = @_;
20 }
21 else {
22 $query = {@_};
23 }
24
25 $query = $self->_build_query($query);
26 $self->find($query);
27 }
28
29 sub find_or_create {
30 my $self = shift;
31 my $query = ref $_[0] eq 'HASH' ? shift : {@_};
32
33 $query = $self->_build_query($query);
34 $self->next::method($query);
35 }
36
37 # _build_query
38 #
39 # Build a query hash. Defaults to a no-op; ColumnCase overrides.
40
41 sub _build_query {
42 my ($self, $query) = @_;
43
44 return $query;
45 }
46
47 sub retrieve_from_sql {
48 my ($class, $cond, @rest) = @_;
49
50 $cond =~ s/^\s*WHERE//i;
51
52 # Need to parse the SQL clauses after WHERE in reverse
53 # order of appearance.
54
55 my %attrs;
56
57 if( $cond =~ s/\bLIMIT\s+(\d+)\s*$//i ) {
58 $attrs{rows} = $1;
59 }
60
61 if ( $cond =~ s/\bORDER\s+BY\s+(.*)\s*$//i ) {
62 $attrs{order_by} = $1;
63 }
64
65 if( $cond =~ s/\bGROUP\s+BY\s+(.*)\s*$//i ) {
66 $attrs{group_by} = $1;
67 }
68
69 return $class->search_literal($cond, @rest, ( %attrs ? \%attrs : () ) );
70 }
71
72 sub construct {
73 my $class = shift;
74 my $obj = $class->resultset_instance->new_result(@_);
75 $obj->in_storage(1);
76
77 return $obj;
78 }
79
80 sub retrieve_all { shift->search }
81 sub count_all { shift->count }
82
83 sub maximum_value_of {
84 my($class, $col) = @_;
85 return $class->resultset_instance->get_column($col)->max;
86 }
87
88 sub minimum_value_of {
89 my($class, $col) = @_;
90 return $class->resultset_instance->get_column($col)->min;
91 }
92
93 1;
+104
-104
lib/DBIx/Class/CDBICompat/SQLTransformer.pm less more
0 package DBIx::Class::CDBICompat::SQLTransformer;
1
2 use strict;
3 use warnings;
4
5 =head1 NAME
6
7 DBIx::Class::CDBICompat::SQLTransformer - Transform SQL
8
9 =head1 DESCRIPTION
10
11 This is a copy of L<Class::DBI::SQL::Transformer> from Class::DBI 3.0.17.
12 It is here so we can be compatible with L<Class::DBI> without having it
13 installed.
14
15 =cut
16
17 sub new {
18 my ($me, $caller, $sql, @args) = @_;
19 bless {
20 _caller => $caller,
21 _sql => $sql,
22 _args => [@args],
23 _transformed => 0,
24 } => $me;
25 }
26
27 sub sql {
28 my $self = shift;
29 $self->_do_transformation if !$self->{_transformed};
30 return $self->{_transformed_sql};
31 }
32
33 sub args {
34 my $self = shift;
35 $self->_do_transformation if !$self->{_transformed};
36 return @{ $self->{_transformed_args} };
37 }
38
39 sub _expand_table {
40 my $self = shift;
41 my ($class, $alias) = split /=/, shift, 2;
42 my $caller = $self->{_caller};
43 my $table = $class ? $class->table : $caller->table;
44 $self->{cmap}{ $alias || $table } = $class || ref $caller || $caller;
45 ($alias ||= "") &&= " $alias";
46 return $table . $alias;
47 }
48
49 sub _expand_join {
50 my $self = shift;
51 my $joins = shift;
52 my @table = split /\s+/, $joins;
53
54 my $caller = $self->{_caller};
55 my %tojoin = map { $table[$_] => $table[ $_ + 1 ] } 0 .. $#table - 1;
56 my @sql;
57 while (my ($t1, $t2) = each %tojoin) {
58 my ($c1, $c2) = map $self->{cmap}{$_}
59 || $caller->_croak("Don't understand table '$_' in JOIN"), ($t1, $t2);
60
61 my $join_col = sub {
62 my ($c1, $c2) = @_;
63 my $meta = $c1->meta_info('has_a');
64 my ($col) = grep $meta->{$_}->foreign_class eq $c2, keys %$meta;
65 $col;
66 };
67
68 my $col = $join_col->($c1 => $c2) || do {
69 ($c1, $c2) = ($c2, $c1);
70 ($t1, $t2) = ($t2, $t1);
71 $join_col->($c1 => $c2);
72 };
73
74 $caller->_croak("Don't know how to join $c1 to $c2") unless $col;
75 push @sql, sprintf " %s.%s = %s.%s ", $t1, $col, $t2, $c2->primary_column;
76 }
77 return join " AND ", @sql;
78 }
79
80 sub _do_transformation {
81 my $me = shift;
82 my $sql = $me->{_sql};
83 my @args = @{ $me->{_args} };
84 my $caller = $me->{_caller};
85
86 $sql =~ s/__TABLE\(?(.*?)\)?__/$me->_expand_table($1)/eg;
87 $sql =~ s/__JOIN\((.*?)\)__/$me->_expand_join($1)/eg;
88 $sql =~ s/__ESSENTIAL__/join ", ", $caller->_essential/eg;
89 $sql =~
90 s/__ESSENTIAL\((.*?)\)__/join ", ", map "$1.$_", $caller->_essential/eg;
91 if ($sql =~ /__IDENTIFIER__/) {
92 my $key_sql = join " AND ", map "$_=?", $caller->primary_columns;
93 $sql =~ s/__IDENTIFIER__/$key_sql/g;
94 }
95
96 $me->{_transformed_sql} = $sql;
97 $me->{_transformed_args} = [@args];
98 $me->{_transformed} = 1;
99 return 1;
100 }
101
102 1;
103
0 package DBIx::Class::CDBICompat::SQLTransformer;
1
2 use strict;
3 use warnings;
4
5 =head1 NAME
6
7 DBIx::Class::CDBICompat::SQLTransformer - Transform SQL
8
9 =head1 DESCRIPTION
10
11 This is a copy of L<Class::DBI::SQL::Transformer> from Class::DBI 3.0.17.
12 It is here so we can be compatible with L<Class::DBI> without having it
13 installed.
14
15 =cut
16
17 sub new {
18 my ($me, $caller, $sql, @args) = @_;
19 bless {
20 _caller => $caller,
21 _sql => $sql,
22 _args => [@args],
23 _transformed => 0,
24 } => $me;
25 }
26
27 sub sql {
28 my $self = shift;
29 $self->_do_transformation if !$self->{_transformed};
30 return $self->{_transformed_sql};
31 }
32
33 sub args {
34 my $self = shift;
35 $self->_do_transformation if !$self->{_transformed};
36 return @{ $self->{_transformed_args} };
37 }
38
39 sub _expand_table {
40 my $self = shift;
41 my ($class, $alias) = split /=/, shift, 2;
42 my $caller = $self->{_caller};
43 my $table = $class ? $class->table : $caller->table;
44 $self->{cmap}{ $alias || $table } = $class || ref $caller || $caller;
45 ($alias ||= "") &&= " $alias";
46 return $table . $alias;
47 }
48
49 sub _expand_join {
50 my $self = shift;
51 my $joins = shift;
52 my @table = split /\s+/, $joins;
53
54 my $caller = $self->{_caller};
55 my %tojoin = map { $table[$_] => $table[ $_ + 1 ] } 0 .. $#table - 1;
56 my @sql;
57 while (my ($t1, $t2) = each %tojoin) {
58 my ($c1, $c2) = map $self->{cmap}{$_}
59 || $caller->_croak("Don't understand table '$_' in JOIN"), ($t1, $t2);
60
61 my $join_col = sub {
62 my ($c1, $c2) = @_;
63 my $meta = $c1->meta_info('has_a');
64 my ($col) = grep $meta->{$_}->foreign_class eq $c2, keys %$meta;
65 $col;
66 };
67
68 my $col = $join_col->($c1 => $c2) || do {
69 ($c1, $c2) = ($c2, $c1);
70 ($t1, $t2) = ($t2, $t1);
71 $join_col->($c1 => $c2);
72 };
73
74 $caller->_croak("Don't know how to join $c1 to $c2") unless $col;
75 push @sql, sprintf " %s.%s = %s.%s ", $t1, $col, $t2, $c2->primary_column;
76 }
77 return join " AND ", @sql;
78 }
79
80 sub _do_transformation {
81 my $me = shift;
82 my $sql = $me->{_sql};
83 my @args = @{ $me->{_args} };
84 my $caller = $me->{_caller};
85
86 $sql =~ s/__TABLE\(?(.*?)\)?__/$me->_expand_table($1)/eg;
87 $sql =~ s/__JOIN\((.*?)\)__/$me->_expand_join($1)/eg;
88 $sql =~ s/__ESSENTIAL__/join ", ", $caller->_essential/eg;
89 $sql =~
90 s/__ESSENTIAL\((.*?)\)__/join ", ", map "$1.$_", $caller->_essential/eg;
91 if ($sql =~ /__IDENTIFIER__/) {
92 my $key_sql = join " AND ", map "$_=?", $caller->primary_columns;
93 $sql =~ s/__IDENTIFIER__/$key_sql/g;
94 }
95
96 $me->{_transformed_sql} = $sql;
97 $me->{_transformed_args} = [@args];
98 $me->{_transformed} = 1;
99 return 1;
100 }
101
102 1;
103
+21
-21
lib/DBIx/Class/CDBICompat/Stringify.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Stringify;
2
3 use strict;
4 use warnings;
5
6 use Scalar::Util;
7
8 use overload
9 '""' => sub { return shift->stringify_self; },
10 fallback => 1;
11
12 sub stringify_self {
13 my $self = shift;
14 my @cols = $self->columns('Stringify');
15 @cols = $self->primary_column unless @cols;
16 my $ret = join "/", map { $self->get_column($_) || '' } @cols;
17 return $ret || ref $self;
18 }
19
20 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Stringify;
2
3 use strict;
4 use warnings;
5
6 use Scalar::Util;
7
8 use overload
9 '""' => sub { return shift->stringify_self; },
10 fallback => 1;
11
12 sub stringify_self {
13 my $self = shift;
14 my @cols = $self->columns('Stringify');
15 @cols = $self->primary_column unless @cols;
16 my $ret = join "/", map { $self->get_column($_) || '' } @cols;
17 return $ret || ref $self;
18 }
19
20 1;
+94
-94
lib/DBIx/Class/CDBICompat/TempColumns.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::TempColumns;
2
3 use strict;
4 use warnings;
5 use base qw/Class::Data::Inheritable/;
6
7 use Carp;
8
9 __PACKAGE__->mk_classdata('_temp_columns' => { });
10
11 sub _add_column_group {
12 my ($class, $group, @cols) = @_;
13
14 return $class->next::method($group, @cols) unless $group eq 'TEMP';
15
16 my %new_cols = map { $_ => 1 } @cols;
17 my %tmp_cols = %{$class->_temp_columns};
18
19 for my $existing_col ( grep $new_cols{$_}, $class->columns ) {
20 # Already been declared TEMP
21 next if $tmp_cols{$existing_col};
22
23 carp "Declaring column $existing_col as TEMP but it already exists";
24 }
25
26 $class->_register_column_group($group => @cols);
27 $class->mk_group_accessors('temp' => @cols);
28
29 $class->_temp_columns({ %tmp_cols, %new_cols });
30 }
31
32 sub new {
33 my ($class, $attrs, @rest) = @_;
34
35 my $temp = $class->_extract_temp_data($attrs);
36
37 my $new = $class->next::method($attrs, @rest);
38
39 $new->set_temp($_, $temp->{$_}) for keys %$temp;
40
41 return $new;
42 }
43
44 sub _extract_temp_data {
45 my($self, $data) = @_;
46
47 my %temp;
48 foreach my $key (keys %$data) {
49 $temp{$key} = delete $data->{$key} if $self->_temp_columns->{$key};
50 }
51
52 return \%temp;
53 }
54
55 sub find_column {
56 my ($class, $col, @rest) = @_;
57 return $col if $class->_temp_columns->{$col};
58 return $class->next::method($col, @rest);
59 }
60
61 sub set {
62 my($self, %data) = @_;
63
64 my $temp_data = $self->_extract_temp_data(\%data);
65
66 $self->set_temp($_, $temp_data->{$_}) for keys %$temp_data;
67
68 return $self->next::method(%data);
69 }
70
71 sub get_temp {
72 my ($self, $column) = @_;
73 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
74 $self->throw_exception( "No such TEMP column '${column}'" ) unless $self->_temp_columns->{$column} ;
75 return $self->{_temp_column_data}{$column}
76 if exists $self->{_temp_column_data}{$column};
77 return undef;
78 }
79
80 sub set_temp {
81 my ($self, $column, $value) = @_;
82 $self->throw_exception( "No such TEMP column '${column}'" )
83 unless $self->_temp_columns->{$column};
84 $self->throw_exception( "set_temp called for ${column} without value" )
85 if @_ < 3;
86 return $self->{_temp_column_data}{$column} = $value;
87 }
88
89 sub has_real_column {
90 return 1 if shift->has_column(shift);
91 }
92
93 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::TempColumns;
2
3 use strict;
4 use warnings;
5 use base qw/Class::Data::Inheritable/;
6
7 use Carp;
8
9 __PACKAGE__->mk_classdata('_temp_columns' => { });
10
11 sub _add_column_group {
12 my ($class, $group, @cols) = @_;
13
14 return $class->next::method($group, @cols) unless $group eq 'TEMP';
15
16 my %new_cols = map { $_ => 1 } @cols;
17 my %tmp_cols = %{$class->_temp_columns};
18
19 for my $existing_col ( grep $new_cols{$_}, $class->columns ) {
20 # Already been declared TEMP
21 next if $tmp_cols{$existing_col};
22
23 carp "Declaring column $existing_col as TEMP but it already exists";
24 }
25
26 $class->_register_column_group($group => @cols);
27 $class->mk_group_accessors('temp' => @cols);
28
29 $class->_temp_columns({ %tmp_cols, %new_cols });
30 }
31
32 sub new {
33 my ($class, $attrs, @rest) = @_;
34
35 my $temp = $class->_extract_temp_data($attrs);
36
37 my $new = $class->next::method($attrs, @rest);
38
39 $new->set_temp($_, $temp->{$_}) for keys %$temp;
40
41 return $new;
42 }
43
44 sub _extract_temp_data {
45 my($self, $data) = @_;
46
47 my %temp;
48 foreach my $key (keys %$data) {
49 $temp{$key} = delete $data->{$key} if $self->_temp_columns->{$key};
50 }
51
52 return \%temp;
53 }
54
55 sub find_column {
56 my ($class, $col, @rest) = @_;
57 return $col if $class->_temp_columns->{$col};
58 return $class->next::method($col, @rest);
59 }
60
61 sub set {
62 my($self, %data) = @_;
63
64 my $temp_data = $self->_extract_temp_data(\%data);
65
66 $self->set_temp($_, $temp_data->{$_}) for keys %$temp_data;
67
68 return $self->next::method(%data);
69 }
70
71 sub get_temp {
72 my ($self, $column) = @_;
73 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
74 $self->throw_exception( "No such TEMP column '${column}'" ) unless $self->_temp_columns->{$column} ;
75 return $self->{_temp_column_data}{$column}
76 if exists $self->{_temp_column_data}{$column};
77 return undef;
78 }
79
80 sub set_temp {
81 my ($self, $column, $value) = @_;
82 $self->throw_exception( "No such TEMP column '${column}'" )
83 unless $self->_temp_columns->{$column};
84 $self->throw_exception( "set_temp called for ${column} without value" )
85 if @_ < 3;
86 return $self->{_temp_column_data}{$column} = $value;
87 }
88
89 sub has_real_column {
90 return 1 if shift->has_column(shift);
91 }
92
93 1;
+44
-44
lib/DBIx/Class/CDBICompat/Triggers.pm less more
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Triggers;
2
3 use strict;
4 use warnings;
5 use Class::Trigger;
6
7 sub insert {
8 my $self = shift;
9
10 return $self->create(@_) unless ref $self;
11
12 $self->call_trigger('before_create');
13 $self->next::method(@_);
14 $self->call_trigger('after_create');
15 return $self;
16 }
17
18 sub update {
19 my $self = shift;
20 $self->call_trigger('before_update');
21 my @to_update = keys %{$self->{_dirty_columns} || {}};
22 return -1 unless @to_update;
23 $self->next::method(@_);
24 $self->call_trigger('after_update');
25 return $self;
26 }
27
28 sub delete {
29 my $self = shift;
30 $self->call_trigger('before_delete') if ref $self;
31 $self->next::method(@_);
32 $self->call_trigger('after_delete') if ref $self;
33 return $self;
34 }
35
36 sub store_column {
37 my ($self, $column, $value, @rest) = @_;
38 my $vals = { $column => $value };
39 $self->call_trigger("before_set_${column}", $value, $vals);
40 return $self->next::method($column, $vals->{$column});
41 }
42
43 1;
0 package # hide from PAUSE
1 DBIx::Class::CDBICompat::Triggers;
2
3 use strict;
4 use warnings;
5 use Class::Trigger;
6
7 sub insert {
8 my $self = shift;
9
10 return $self->create(@_) unless ref $self;
11
12 $self->call_trigger('before_create');
13 $self->next::method(@_);
14 $self->call_trigger('after_create');
15 return $self;
16 }
17
18 sub update {
19 my $self = shift;
20 $self->call_trigger('before_update');
21 my @to_update = keys %{$self->{_dirty_columns} || {}};
22 return -1 unless @to_update;
23 $self->next::method(@_);
24 $self->call_trigger('after_update');
25 return $self;
26 }
27
28 sub delete {
29 my $self = shift;
30 $self->call_trigger('before_delete') if ref $self;
31 $self->next::method(@_);
32 $self->call_trigger('after_delete') if ref $self;
33 return $self;
34 }
35
36 sub store_column {
37 my ($self, $column, $value, @rest) = @_;
38 my $vals = { $column => $value };
39 $self->call_trigger("before_set_${column}", $value, $vals);
40 return $self->next::method($column, $vals->{$column});
41 }
42
43 1;
+12
-12
lib/DBIx/Class/ClassResolver/PassThrough.pm less more
0 package # hide from PAUSE
1 DBIx::Class::ClassResolver::PassThrough;
2
3 use strict;
4 use warnings;
5
6 sub class {
7 shift;
8 return shift;
9 }
10
11 1;
0 package # hide from PAUSE
1 DBIx::Class::ClassResolver::PassThrough;
2
3 use strict;
4 use warnings;
5
6 sub class {
7 shift;
8 return shift;
9 }
10
11 1;
+49
-14
lib/DBIx/Class/Componentised.pm less more
77 use Carp::Clan qw/^DBIx::Class|^Class::C3::Componentised/;
88 use mro 'c3';
99
10 my $warned;
11
1012 # this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column
13 # if and only if it is placed before something overriding store_column
1114 sub inject_base {
1215 my $class = shift;
13 my $target = shift;
16 my ($target, @complist) = @_;
1417
15 my @present_components = (@{mro::get_linear_isa ($target)||[]});
18 # we already did load the component
19 my $keep_checking = ! (
20 $target->isa ('DBIx::Class::UTF8Columns')
21 ||
22 $target->isa ('DBIx::Class::ForceUTF8')
23 );
1624
17 no strict 'refs';
18 for my $comp (reverse @_) {
25 my @target_isa;
1926
20 if ($comp->isa ('DBIx::Class::UTF8Columns') ) {
21 require B;
27 while ($keep_checking && @complist) {
28
29 @target_isa = do { no strict 'refs'; @{"$target\::ISA"} }
30 unless @target_isa;
31
32 my $comp = pop @complist;
33
34 # warn here on use of either component, as we have no access to ForceUTF8,
35 # the author does not respond, and the Catalyst wiki used to recommend it
36 for (qw/DBIx::Class::UTF8Columns DBIx::Class::ForceUTF8/) {
37 if ($comp->isa ($_) ) {
38 $keep_checking = 0; # no use to check from this point on
39 carp "Use of $_ is strongly discouraged. See documentationm of DBIx::Class::UTF8Columns for more info\n"
40 unless ($warned->{UTF8Columns}++ || $ENV{DBIC_UTF8COLUMNS_OK});
41 last;
42 }
43 }
44
45 # something unset $keep_checking - we got a unicode mangler
46 if (! $keep_checking) {
47
48 my $base_store_column = do { require DBIx::Class::Row; DBIx::Class::Row->can ('store_column') };
49
2250 my @broken;
51 for my $existing_comp (@target_isa) {
52 my $sc = $existing_comp->can ('store_column')
53 or next;
2354
24 for (@present_components) {
25 my $cref = $_->can ('store_column')
26 or next;
27 push @broken, $_ if B::svref_2object($cref)->STASH->NAME ne 'DBIx::Class::Row';
55 if ($sc ne $base_store_column) {
56 require B;
57 my $definer = B::svref_2object($sc)->STASH->NAME;
58 push @broken, ($definer eq $existing_comp)
59 ? $existing_comp
60 : "$existing_comp (via $definer)"
61 ;
62 }
2863 }
2964
30 carp "Incorrect loading order of $comp by ${target} will affect other components overriding store_column ("
65 carp "Incorrect loading order of $comp by $target will affect other components overriding 'store_column' ("
3166 . join (', ', @broken)
3267 .'). Refer to the documentation of DBIx::Class::UTF8Columns for more info'
33 if @broken;
68 if @broken;
3469 }
3570
36 unshift @present_components, $comp;
71 unshift @target_isa, $comp;
3772 }
3873
39 $class->next::method($target, @_);
74 $class->next::method(@_);
4075 }
4176
4277 1;
+79
-79
lib/DBIx/Class/Cursor.pm less more
0 package DBIx::Class::Cursor;
1
2 use strict;
3 use warnings;
4
5 use base qw/DBIx::Class/;
6
7 =head1 NAME
8
9 DBIx::Class::Cursor - Abstract object representing a query cursor on a
10 resultset.
11
12 =head1 SYNOPSIS
13
14 my $cursor = $schema->resultset('CD')->cursor();
15 my $first_cd = $cursor->next;
16
17 =head1 DESCRIPTION
18
19 A Cursor represents a query cursor on a L<DBIx::Class::ResultSet> object. It
20 allows for traversing the result set with L</next>, retrieving all results with
21 L</all> and resetting the cursor with L</reset>.
22
23 Usually, you would use the cursor methods built into L<DBIx::Class::ResultSet>
24 to traverse it. See L<DBIx::Class::ResultSet/next>,
25 L<DBIx::Class::ResultSet/reset> and L<DBIx::Class::ResultSet/all> for more
26 information.
27
28 =head1 METHODS
29
30 =head2 new
31
32 Virtual method. Returns a new L<DBIx::Class::Cursor> object.
33
34 =cut
35
36 sub new {
37 die "Virtual method!";
38 }
39
40 =head2 next
41
42 Virtual method. Advances the cursor to the next row. Returns an array of
43 column values (the result of L<DBI/fetchrow_array> method).
44
45 =cut
46
47 sub next {
48 die "Virtual method!";
49 }
50
51 =head2 reset
52
53 Virtual method. Resets the cursor to the beginning.
54
55 =cut
56
57 sub reset {
58 die "Virtual method!";
59 }
60
61 =head2 all
62
63 Virtual method. Returns all rows in the L<DBIx::Class::ResultSet>.
64
65 =cut
66
67 sub all {
68 my ($self) = @_;
69 $self->reset;
70 my @all;
71 while (my @row = $self->next) {
72 push(@all, \@row);
73 }
74 $self->reset;
75 return @all;
76 }
77
78 1;
0 package DBIx::Class::Cursor;
1
2 use strict;
3 use warnings;
4
5 use base qw/DBIx::Class/;
6
7 =head1 NAME
8
9 DBIx::Class::Cursor - Abstract object representing a query cursor on a
10 resultset.
11
12 =head1 SYNOPSIS
13
14 my $cursor = $schema->resultset('CD')->cursor();
15 my $first_cd = $cursor->next;
16
17 =head1 DESCRIPTION
18
19 A Cursor represents a query cursor on a L<DBIx::Class::ResultSet> object. It
20 allows for traversing the result set with L</next>, retrieving all results with
21 L</all> and resetting the cursor with L</reset>.
22
23 Usually, you would use the cursor methods built into L<DBIx::Class::ResultSet>
24 to traverse it. See L<DBIx::Class::ResultSet/next>,
25 L<DBIx::Class::ResultSet/reset> and L<DBIx::Class::ResultSet/all> for more
26 information.
27
28 =head1 METHODS
29
30 =head2 new
31
32 Virtual method. Returns a new L<DBIx::Class::Cursor> object.
33
34 =cut
35
36 sub new {
37 die "Virtual method!";
38 }
39
40 =head2 next
41
42 Virtual method. Advances the cursor to the next row. Returns an array of
43 column values (the result of L<DBI/fetchrow_array> method).
44
45 =cut
46
47 sub next {
48 die "Virtual method!";
49 }
50
51 =head2 reset
52
53 Virtual method. Resets the cursor to the beginning.
54
55 =cut
56
57 sub reset {
58 die "Virtual method!";
59 }
60
61 =head2 all
62
63 Virtual method. Returns all rows in the L<DBIx::Class::ResultSet>.
64
65 =cut
66
67 sub all {
68 my ($self) = @_;
69 $self->reset;
70 my @all;
71 while (my @row = $self->next) {
72 push(@all, \@row);
73 }
74 $self->reset;
75 return @all;
76 }
77
78 1;
+231
-231
lib/DBIx/Class/DB.pm less more
0 package DBIx::Class::DB;
1
2 use strict;
3 use warnings;
4
5 use base qw/DBIx::Class/;
6 use DBIx::Class::Schema;
7 use DBIx::Class::Storage::DBI;
8 use DBIx::Class::ClassResolver::PassThrough;
9 use DBI;
10 use Scalar::Util;
11
12 unless ($INC{"DBIx/Class/CDBICompat.pm"}) {
13 warn "IMPORTANT: DBIx::Class::DB is DEPRECATED AND *WILL* BE REMOVED. DO NOT USE.\n";
14 }
15
16 __PACKAGE__->load_components(qw/ResultSetProxy/);
17
18 {
19 no warnings 'once';
20 *dbi_commit = \&txn_commit;
21 *dbi_rollback = \&txn_rollback;
22 }
23
24 sub storage { shift->schema_instance(@_)->storage; }
25
26 =head1 NAME
27
28 DBIx::Class::DB - (DEPRECATED) classdata schema component
29
30 =head1 DESCRIPTION
31
32 This class is designed to support the Class::DBI connection-as-classdata style
33 for DBIx::Class. You are *strongly* recommended to use a DBIx::Class::Schema
34 instead; DBIx::Class::DB will not undergo new development and will be moved
35 to being a CDBICompat-only component before 1.0. In order to discourage further
36 use, documentation has been removed as of 0.08000
37
38 =begin HIDE_BECAUSE_THIS_CLASS_IS_DEPRECATED
39
40 =head1 METHODS
41
42 =head2 storage
43
44 Sets or gets the storage backend. Defaults to L<DBIx::Class::Storage::DBI>.
45
46 =head2 class_resolver
47
48 ****DEPRECATED****
49
50 Sets or gets the class to use for resolving a class. Defaults to
51 L<DBIx::Class::ClassResolver::Passthrough>, which returns whatever you give
52 it. See resolve_class below.
53
54 =cut
55
56 __PACKAGE__->mk_classdata('class_resolver' =>
57 'DBIx::Class::ClassResolver::PassThrough');
58
59 =head2 connection
60
61 __PACKAGE__->connection($dsn, $user, $pass, $attrs);
62
63 Specifies the arguments that will be passed to DBI->connect(...) to
64 instantiate the class dbh when required.
65
66 =cut
67
68 sub connection {
69 my ($class, @info) = @_;
70 $class->setup_schema_instance unless $class->can('schema_instance');
71 $class->schema_instance->connection(@info);
72 }
73
74 =head2 setup_schema_instance
75
76 Creates a class method ->schema_instance which contains a DBIx::Class::Schema;
77 all class-method operations are proxies through to this object. If you don't
78 call ->connection in your DBIx::Class::DB subclass at load time you *must*
79 call ->setup_schema_instance in order for subclasses to find the schema and
80 register themselves with it.
81
82 =cut
83
84 sub setup_schema_instance {
85 my $class = shift;
86 my $schema = {};
87 bless $schema, 'DBIx::Class::Schema';
88 $class->mk_classdata('schema_instance' => $schema);
89 }
90
91 =head2 txn_begin
92
93 Begins a transaction (does nothing if AutoCommit is off).
94
95 =cut
96
97 sub txn_begin { shift->schema_instance->txn_begin(@_); }
98
99 =head2 txn_commit
100
101 Commits the current transaction.
102
103 =cut
104
105 sub txn_commit { shift->schema_instance->txn_commit(@_); }
106
107 =head2 txn_rollback
108
109 Rolls back the current transaction.
110
111 =cut
112
113 sub txn_rollback { shift->schema_instance->txn_rollback(@_); }
114
115 =head2 txn_do
116
117 Executes a block of code transactionally. If this code reference
118 throws an exception, the transaction is rolled back and the exception
119 is rethrown. See L<DBIx::Class::Schema/"txn_do"> for more details.
120
121 =cut
122
123 sub txn_do { shift->schema_instance->txn_do(@_); }
124
125 {
126 my $warn;
127
128 sub resolve_class {
129 warn "resolve_class deprecated as of 0.04999_02" unless $warn++;
130 return shift->class_resolver->class(@_);
131 }
132 }
133
134 =head2 resultset_instance
135
136 Returns an instance of a resultset for this class - effectively
137 mapping the L<Class::DBI> connection-as-classdata paradigm into the
138 native L<DBIx::Class::ResultSet> system.
139
140 =cut
141
142 sub resultset_instance {
143 $_[0]->result_source_instance->resultset
144 }
145
146 =head2 result_source_instance
147
148 Returns an instance of the result source for this class
149
150 =cut
151
152 __PACKAGE__->mk_classdata('_result_source_instance' => []);
153
154 # Yep. this is horrific. Basically what's happening here is that
155 # (with good reason) DBIx::Class::Schema copies the result source for
156 # registration. Because we have a retarded setup order forced on us we need
157 # to actually make our ->result_source_instance -be- the source used, and we
158 # need to get the source name and schema into ourselves. So this makes it
159 # happen.
160
161 sub _maybe_attach_source_to_schema {
162 my ($class, $source) = @_;
163 if (my $meth = $class->can('schema_instance')) {
164 if (my $schema = $class->$meth) {
165 $schema->register_class($class, $class);
166 my $new_source = $schema->source($class);
167 %$source = %$new_source;
168 $schema->source_registrations->{$class} = $source;
169 }
170 }
171 }
172
173 sub result_source_instance {
174 my $class = shift;
175 $class = ref $class || $class;
176
177 if (@_) {
178 my $source = $_[0];
179 $class->_result_source_instance([$source, $class]);
180 $class->_maybe_attach_source_to_schema($source);
181 return $source;
182 }
183
184 my($source, $result_class) = @{$class->_result_source_instance};
185 return unless Scalar::Util::blessed($source);
186
187 if ($result_class ne $class) { # new class
188 # Give this new class its own source and register it.
189 $source = $source->new({
190 %$source,
191 source_name => $class,
192 result_class => $class
193 } );
194 $class->_result_source_instance([$source, $class]);
195 $class->_maybe_attach_source_to_schema($source);
196 }
197 return $source;
198 }
199
200 =head2 resolve_class
201
202 ****DEPRECATED****
203
204 See L<class_resolver>
205
206 =head2 dbi_commit
207
208 ****DEPRECATED****
209
210 Alias for L<txn_commit>
211
212 =head2 dbi_rollback
213
214 ****DEPRECATED****
215
216 Alias for L<txn_rollback>
217
218 =end HIDE_BECAUSE_THIS_CLASS_IS_DEPRECATED
219
220 =head1 AUTHORS
221
222 Matt S. Trout <mst@shadowcatsystems.co.uk>
223
224 =head1 LICENSE
225
226 You may distribute this code under the same terms as Perl itself.
227
228 =cut
229
230 1;
0 package DBIx::Class::DB;
1
2 use strict;
3 use warnings;
4
5 use base qw/DBIx::Class/;
6 use DBIx::Class::Schema;
7 use DBIx::Class::Storage::DBI;
8 use DBIx::Class::ClassResolver::PassThrough;
9 use DBI;
10 use Scalar::Util;
11
12 unless ($INC{"DBIx/Class/CDBICompat.pm"}) {
13 warn "IMPORTANT: DBIx::Class::DB is DEPRECATED AND *WILL* BE REMOVED. DO NOT USE.\n";
14 }
15
16 __PACKAGE__->load_components(qw/ResultSetProxy/);
17
18 {
19 no warnings 'once';
20 *dbi_commit = \&txn_commit;
21 *dbi_rollback = \&txn_rollback;
22 }
23
24 sub storage { shift->schema_instance(@_)->storage; }
25
26 =head1 NAME
27
28 DBIx::Class::DB - (DEPRECATED) classdata schema component
29
30 =head1 DESCRIPTION
31
32 This class is designed to support the Class::DBI connection-as-classdata style
33 for DBIx::Class. You are *strongly* recommended to use a DBIx::Class::Schema
34 instead; DBIx::Class::DB will not undergo new development and will be moved
35 to being a CDBICompat-only component before 1.0. In order to discourage further
36 use, documentation has been removed as of 0.08000
37
38 =begin HIDE_BECAUSE_THIS_CLASS_IS_DEPRECATED
39
40 =head1 METHODS
41
42 =head2 storage
43
44 Sets or gets the storage backend. Defaults to L<DBIx::Class::Storage::DBI>.
45
46 =head2 class_resolver
47
48 ****DEPRECATED****
49
50 Sets or gets the class to use for resolving a class. Defaults to
51 L<DBIx::Class::ClassResolver::Passthrough>, which returns whatever you give
52 it. See resolve_class below.
53
54 =cut
55
56 __PACKAGE__->mk_classdata('class_resolver' =>
57 'DBIx::Class::ClassResolver::PassThrough');
58
59 =head2 connection
60
61 __PACKAGE__->connection($dsn, $user, $pass, $attrs);
62
63 Specifies the arguments that will be passed to DBI->connect(...) to
64 instantiate the class dbh when required.
65
66 =cut
67
68 sub connection {
69 my ($class, @info) = @_;
70 $class->setup_schema_instance unless $class->can('schema_instance');
71 $class->schema_instance->connection(@info);
72 }
73
74 =head2 setup_schema_instance
75
76 Creates a class method ->schema_instance which contains a DBIx::Class::Schema;
77 all class-method operations are proxies through to this object. If you don't
78 call ->connection in your DBIx::Class::DB subclass at load time you *must*
79 call ->setup_schema_instance in order for subclasses to find the schema and
80 register themselves with it.
81
82 =cut
83
84 sub setup_schema_instance {
85 my $class = shift;
86 my $schema = {};
87 bless $schema, 'DBIx::Class::Schema';
88 $class->mk_classdata('schema_instance' => $schema);
89 }
90
91 =head2 txn_begin
92
93 Begins a transaction (does nothing if AutoCommit is off).
94
95 =cut
96
97 sub txn_begin { shift->schema_instance->txn_begin(@_); }
98
99 =head2 txn_commit
100
101 Commits the current transaction.
102
103 =cut
104
105 sub txn_commit { shift->schema_instance->txn_commit(@_); }
106
107 =head2 txn_rollback
108
109 Rolls back the current transaction.
110
111 =cut
112
113 sub txn_rollback { shift->schema_instance->txn_rollback(@_); }
114
115 =head2 txn_do
116
117 Executes a block of code transactionally. If this code reference
118 throws an exception, the transaction is rolled back and the exception
119 is rethrown. See L<DBIx::Class::Schema/"txn_do"> for more details.
120
121 =cut
122
123 sub txn_do { shift->schema_instance->txn_do(@_); }
124
125 {
126 my $warn;
127
128 sub resolve_class {
129 warn "resolve_class deprecated as of 0.04999_02" unless $warn++;
130 return shift->class_resolver->class(@_);
131 }
132 }
133
134 =head2 resultset_instance
135
136 Returns an instance of a resultset for this class - effectively
137 mapping the L<Class::DBI> connection-as-classdata paradigm into the
138 native L<DBIx::Class::ResultSet> system.
139
140 =cut
141
142 sub resultset_instance {
143 $_[0]->result_source_instance->resultset
144 }
145
146 =head2 result_source_instance
147
148 Returns an instance of the result source for this class
149
150 =cut
151
152 __PACKAGE__->mk_classdata('_result_source_instance' => []);
153
154 # Yep. this is horrific. Basically what's happening here is that
155 # (with good reason) DBIx::Class::Schema copies the result source for
156 # registration. Because we have a retarded setup order forced on us we need
157 # to actually make our ->result_source_instance -be- the source used, and we
158 # need to get the source name and schema into ourselves. So this makes it
159 # happen.
160
161 sub _maybe_attach_source_to_schema {
162 my ($class, $source) = @_;
163 if (my $meth = $class->can('schema_instance')) {
164 if (my $schema = $class->$meth) {
165 $schema->register_class($class, $class);
166 my $new_source = $schema->source($class);
167 %$source = %$new_source;
168 $schema->source_registrations->{$class} = $source;
169 }
170 }
171 }
172
173 sub result_source_instance {
174 my $class = shift;
175 $class = ref $class || $class;
176
177 if (@_) {
178 my $source = $_[0];
179 $class->_result_source_instance([$source, $class]);
180 $class->_maybe_attach_source_to_schema($source);
181 return $source;
182 }
183
184 my($source, $result_class) = @{$class->_result_source_instance};
185 return unless Scalar::Util::blessed($source);
186
187 if ($result_class ne $class) { # new class
188 # Give this new class its own source and register it.
189 $source = $source->new({
190 %$source,
191 source_name => $class,
192 result_class => $class
193 } );
194 $class->_result_source_instance([$source, $class]);
195 $class->_maybe_attach_source_to_schema($source);
196 }
197 return $source;
198 }
199
200 =head2 resolve_class
201
202 ****DEPRECATED****
203
204 See L<class_resolver>
205
206 =head2 dbi_commit
207
208 ****DEPRECATED****
209
210 Alias for L<txn_commit>
211
212 =head2 dbi_rollback
213
214 ****DEPRECATED****
215
216 Alias for L<txn_rollback>
217
218 =end HIDE_BECAUSE_THIS_CLASS_IS_DEPRECATED
219
220 =head1 AUTHORS
221
222 Matt S. Trout <mst@shadowcatsystems.co.uk>
223
224 =head1 LICENSE
225
226 You may distribute this code under the same terms as Perl itself.
227
228 =cut
229
230 1;
+92
-92
lib/DBIx/Class/Exception.pm less more
0 package DBIx::Class::Exception;
1
2 use strict;
3 use warnings;
4
5 use Carp::Clan qw/^DBIx::Class/;
6 use Scalar::Util qw/blessed/;
7
8 use overload
9 '""' => sub { shift->{msg} },
10 fallback => 1;
11
12 =head1 NAME
13
14 DBIx::Class::Exception - Exception objects for DBIx::Class
15
16 =head1 DESCRIPTION
17
18 Exception objects of this class are used internally by
19 the default error handling of L<DBIx::Class::Schema/throw_exception>
20 to prevent confusing and/or redundant re-application of L<Carp>'s
21 stack trace information.
22
23 These objects stringify to the contained error message, and use
24 overload fallback to give natural boolean/numeric values.
25
26 =head1 METHODS
27
28 =head2 throw
29
30 =over 4
31
32 =item Arguments: $exception_scalar, $stacktrace
33
34 =back
35
36 This is meant for internal use by L<DBIx::Class>'s C<throw_exception>
37 code, and shouldn't be used directly elsewhere.
38
39 Expects a scalar exception message. The optional argument
40 C<$stacktrace> tells it to use L<Carp/longmess> instead of
41 L<Carp::Clan/croak>.
42
43 DBIx::Class::Exception->throw('Foo');
44 eval { ... }; DBIx::Class::Exception->throw($@) if $@;
45
46 =cut
47
48 sub throw {
49 my ($class, $msg, $stacktrace) = @_;
50
51 # Don't re-encapsulate exception objects of any kind
52 die $msg if blessed($msg);
53
54 # use Carp::Clan's croak if we're not stack tracing
55 if(!$stacktrace) {
56 local $@;
57 eval { croak $msg };
58 $msg = $@
59 }
60 else {
61 $msg = Carp::longmess($msg);
62 }
63
64 my $self = { msg => $msg };
65 bless $self => $class;
66
67 die $self;
68 }
69
70 =head2 rethrow
71
72 This method provides some syntactic sugar in order to
73 re-throw exceptions.
74
75 =cut
76
77 sub rethrow {
78 die shift;
79 }
80
81 =head1 AUTHORS
82
83 Brandon L. Black <blblack@gmail.com>
84
85 =head1 LICENSE
86
87 You may distribute this code under the same terms as Perl itself.
88
89 =cut
90
91 1;
0 package DBIx::Class::Exception;
1
2 use strict;
3 use warnings;
4
5 use Carp::Clan qw/^DBIx::Class/;
6 use Scalar::Util qw/blessed/;
7
8 use overload
9 '""' => sub { shift->{msg} },
10 fallback => 1;
11
12 =head1 NAME
13
14 DBIx::Class::Exception - Exception objects for DBIx::Class
15
16 =head1 DESCRIPTION
17
18 Exception objects of this class are used internally by
19 the default error handling of L<DBIx::Class::Schema/throw_exception>
20 to prevent confusing and/or redundant re-application of L<Carp>'s
21 stack trace information.
22
23 These objects stringify to the contained error message, and use
24 overload fallback to give natural boolean/numeric values.
25
26 =head1 METHODS
27
28 =head2 throw
29
30 =over 4
31
32 =item Arguments: $exception_scalar, $stacktrace
33
34 =back
35
36 This is meant for internal use by L<DBIx::Class>'s C<throw_exception>
37 code, and shouldn't be used directly elsewhere.
38
39 Expects a scalar exception message. The optional argument
40 C<$stacktrace> tells it to use L<Carp/longmess> instead of
41 L<Carp::Clan/croak>.
42
43 DBIx::Class::Exception->throw('Foo');
44 eval { ... }; DBIx::Class::Exception->throw($@) if $@;
45
46 =cut
47
48 sub throw {
49 my ($class, $msg, $stacktrace) = @_;
50
51 # Don't re-encapsulate exception objects of any kind
52 die $msg if blessed($msg);
53
54 # use Carp::Clan's croak if we're not stack tracing
55 if(!$stacktrace) {
56 local $@;
57 eval { croak $msg };
58 $msg = $@
59 }
60 else {
61 $msg = Carp::longmess($msg);
62 }
63
64 my $self = { msg => $msg };
65 bless $self => $class;
66
67 die $self;
68 }
69
70 =head2 rethrow
71
72 This method provides some syntactic sugar in order to
73 re-throw exceptions.
74
75 =cut
76
77 sub rethrow {
78 die shift;
79 }
80
81 =head1 AUTHORS
82
83 Brandon L. Black <blblack@gmail.com>
84
85 =head1 LICENSE
86
87 You may distribute this code under the same terms as Perl itself.
88
89 =cut
90
91 1;
+22
-1
lib/DBIx/Class/InflateColumn/File.pm less more
55 use File::Path;
66 use File::Copy;
77 use Path::Class;
8
9 use Carp::Clan qw/^DBIx::Class/;
10 carp 'InflateColumn::File has entered a deprecation cycle. This component '
11 .'has a number of architectural deficiencies that can quickly drive '
12 .'your filesystem and database out of sync and is not recommended '
13 .'for further use. It will be retained for backwards '
14 .'compatibility, but no new functionality patches will be accepted. '
15 .'Please consider using the much more mature and actively maintained '
16 .'DBIx::Class::InflateColumn::FS. You can set the environment variable '
17 .'DBIC_IC_FILE_NOWARN to a true value to disable this warning.'
18 unless $ENV{DBIC_IC_FILE_NOWARN};
819
920 __PACKAGE__->load_components(qw/InflateColumn/);
1021
106117
107118 =head1 NAME
108119
109 DBIx::Class::InflateColumn::File - map files from the Database to the filesystem.
120 DBIx::Class::InflateColumn::File - DEPRECATED (superseded by DBIx::Class::InflateColumn::FS)
121
122 =head2 Deprecation Notice
123
124 This component has a number of architectural deficiencies that can quickly
125 drive your filesystem and database out of sync and is not recommended for
126 further use. It will be retained for backwards compatibility, but no new
127 functionality patches will be accepted. Please consider using the much more
128 mature and actively supported DBIx::Class::InflateColumn::FS. You can set
129 the environment variable DBIC_IC_FILE_NOWARN to a true value to disable
130 this warning.
110131
111132 =head1 SYNOPSIS
112133
+114
-7
lib/DBIx/Class/Manual/Cookbook.pod less more
366366
367367 =head2 Predefined searches
368368
369 You can write your own L<DBIx::Class::ResultSet> class by inheriting from it
370 and defining often used searches as methods:
369 You can define frequently used searches as methods by subclassing
370 L<DBIx::Class::ResultSet>:
371371
372372 package My::DBIC::ResultSet::CD;
373373 use strict;
413413 supports indexes on expressions - including return values of functions - and
414414 you create an index on the return value of the function in question.) However,
415415 it can be accomplished with C<DBIx::Class> when necessary.
416
417 Your approach for doing so will depend on whether you have turned
418 quoting on via the C<quote_char> and C<name_sep> attributes. If you
419 explicitly defined C<quote_char> and C<name_sep> in your
420 C<connect_info> (see L<DBIx::Class::Storage::DBI/"connect_info">) then
421 you are using quoting, otherwise not.
416422
417423 If you do not have quoting on, simply include the function in your search
418424 specification as you would any column:
12161222
12171223 =head1 TRANSACTIONS
12181224
1225 =head2 Transactions with txn_do
1226
12191227 As of version 0.04001, there is improved transaction support in
12201228 L<DBIx::Class::Storage> and L<DBIx::Class::Schema>. Here is an
12211229 example of the recommended way to use it:
12471255 deal_with_failed_transaction();
12481256 }
12491257
1258 Note: by default C<txn_do> will re-run the coderef one more time if an
1259 error occurs due to client disconnection (e.g. the server is bounced).
1260 You need to make sure that your coderef can be invoked multiple times
1261 without terrible side effects.
1262
12501263 Nested transactions will work as expected. That is, only the outermost
12511264 transaction will actually issue a commit to the $dbh, and a rollback
12521265 at any level of any transaction will cause the entire nested
12531266 transaction to fail.
1254
1267
12551268 =head2 Nested transactions and auto-savepoints
12561269
12571270 If savepoints are supported by your RDBMS, it is possible to achieve true
13431356 the C<eval>-block around C<txn_do> fails, a rollback is issued. If the C<eval>
13441357 succeeds, the transaction is committed (or the savepoint released).
13451358
1346 While you can get more fine-grained controll using C<svp_begin>, C<svp_release>
1359 While you can get more fine-grained control using C<svp_begin>, C<svp_release>
13471360 and C<svp_rollback>, it is strongly recommended to use C<txn_do> with coderefs.
1361
1362 =head2 Simple Transactions with DBIx::Class::Storage::TxnScopeGuard
1363
1364 An easy way to use transactions is with
1365 L<DBIx::Class::Storage::TxnScopeGuard>. See L</Automatically creating
1366 related objects> for an example.
1367
1368 Note that unlike txn_do, TxnScopeGuard will only make sure the connection is
1369 alive when issuing the C<BEGIN> statement. It will not (and really can not)
1370 retry if the server goes away mid-operations, unlike C<txn_do>.
13481371
13491372 =head1 SQL
13501373
17221745 the bind values (the C<[1, 2, 3]> arrayref in the above example) wrapped in
17231746 arrayrefs together with the column name, like this: C<< [column_name => value]
17241747 >>.
1748
1749 =head2 Using Unicode
1750
1751 When using unicode character data there are two alternatives -
1752 either your database supports unicode characters (including setting
1753 the utf8 flag on the returned string), or you need to encode/decode
1754 data appropriately each time a string field is inserted into or
1755 retrieved from the database. It is better to avoid
1756 encoding/decoding data and to use your database's own unicode
1757 capabilities if at all possible.
1758
1759 The L<DBIx::Class::UTF8Columns> component handles storing selected
1760 unicode columns in a database that does not directly support
1761 unicode. If used with a database that does correctly handle unicode
1762 then strange and unexpected data corrupt B<will> occur.
1763
1764 The Catalyst Wiki Unicode page at
1765 L<http://wiki.catalystframework.org/wiki/tutorialsandhowtos/using_unicode>
1766 has additional information on the use of Unicode with Catalyst and
1767 DBIx::Class.
1768
1769 The following databases do correctly handle unicode data:-
1770
1771 =head3 MySQL
1772
1773 MySQL supports unicode, and will correctly flag utf8 data from the
1774 database if the C<mysql_enable_utf8> is set in the connect options.
1775
1776 my $schema = My::Schema->connection('dbi:mysql:dbname=test',
1777 $user, $pass,
1778 { mysql_enable_utf8 => 1} );
1779
1780
1781 When set, a data retrieved from a textual column type (char,
1782 varchar, etc) will have the UTF-8 flag turned on if necessary. This
1783 enables character semantics on that string. You will also need to
1784 ensure that your database / table / column is configured to use
1785 UTF8. See Chapter 10 of the mysql manual for details.
1786
1787 See L<DBD::mysql> for further details.
1788
1789 =head3 Oracle
1790
1791 Information about Oracle support for unicode can be found in
1792 L<DBD::Oracle/Unicode>.
1793
1794 =head3 PostgreSQL
1795
1796 PostgreSQL supports unicode if the character set is correctly set
1797 at database creation time. Additionally the C<pg_enable_utf8>
1798 should be set to ensure unicode data is correctly marked.
1799
1800 my $schema = My::Schema->connection('dbi:Pg:dbname=test',
1801 $user, $pass,
1802 { pg_enable_utf8 => 1} );
1803
1804 Further information can be found in L<DBD::Pg>.
1805
1806 =head3 SQLite
1807
1808 SQLite version 3 and above natively use unicode internally. To
1809 correctly mark unicode strings taken from the database, the
1810 C<sqlite_unicode> flag should be set at connect time (in versions
1811 of L<DBD::SQLite> prior to 1.27 this attribute was named
1812 C<unicode>).
1813
1814 my $schema = My::Schema->connection('dbi:SQLite:/tmp/test.db',
1815 '', '',
1816 { sqlite_unicode => 1} );
17251817
17261818 =head1 BOOTSTRAPPING/MIGRATING
17271819
18201912 sub insert {
18211913 my ( $self, @args ) = @_;
18221914 $self->next::method(@args);
1823 $self->cds->new({})->fill_from_artist($self)->insert;
1915 $self->create_related ('cds', \%initial_cd_data );
18241916 return $self;
18251917 }
18261918
1827 where C<fill_from_artist> is a method you specify in C<CD> which sets
1828 values in C<CD> based on the data in the C<Artist> object you pass in.
1919 If you want to wrap the two inserts in a transaction (for consistency,
1920 an excellent idea), you can use the awesome
1921 L<DBIx::Class::Storage::TxnScopeGuard>:
1922
1923 sub insert {
1924 my ( $self, @args ) = @_;
1925
1926 my $guard = $self->result_source->schema->txn_scope_guard;
1927
1928 $self->next::method(@args);
1929 $self->create_related ('cds', \%initial_cd_data );
1930
1931 $guard->commit;
1932
1933 return $self
1934 }
1935
18291936
18301937 =head2 Wrapping/overloading a column accessor
18311938
+69
-69
lib/DBIx/Class/Manual/DocMap.pod less more
0 =head1 NAME
1
2 DBIx::Class::Manual::DocMap - What documentation do we have?
3
4 =head1 Manuals
5
6 =over 4
7
8 =item L<DBIx::Class::Manual> - User's Manual overview.
9
10 =item L<DBIx::Class::Manual::FAQ> - Frequently Asked Questions, gathered from IRC and the mailing list.
11
12 =item L<DBIx::Class::Manual::Intro> - Introduction to setting up and using DBIx::Class.
13
14 =item L<DBIx::Class::Manual::Example> - Full example Schema.
15
16 =item L<DBIx::Class::Manual::Cookbook> - Various short recipes on how to do things.
17
18 =item L<DBIx::Class::Manual::Troubleshooting> - What to do if things go wrong (diagnostics of known error messages).
19
20 =item L<DBIx::Class::Manual::Component> - How to write your own DBIx::Class components.
21
22 =item L<DBIx::Class::Manual::Glossary> - What do all those terms mean?
23
24 =back
25
26 =head1 Setting up
27
28 =over 4
29
30 =item L<DBIx::Class::Schema> - Overall schemas, and connection container.
31
32 =item L<DBIx::Class::ResultSource> - Source/Table definition functions.
33
34 =item L<DBIx::Class::Relationship> - Simple relationships.
35
36 =item L<DBIx::Class::Relationship::Base> - Relationship details.
37
38 =item L<DBIx::Class::PK::Auto> - Magically retrieve auto-incrementing fields.
39
40 =item L<DBIx::Class::Core> - Set of standard components to load.
41
42 =item L<DBIx::Class::InflateColumn> - Making objects out of your columns.
43
44 =item L<DBIx::Class::InflateColumn::DateTime> - Magically turn your datetime or timestamp columns into DateTime objects.
45
46 =item L<DBIx::Class::PK> - Dealing with primary keys.
47
48 =item L<DBIx::Class::ResultSourceProxy::Table> - Turns the resultsource into a table.
49
50 =item L<DBIx::Class::AccessorGroup> - Accessor grouping.
51
52 =back
53
54 =head1 Retrieving and creating data
55
56 =over 4
57
58 =item L<DBIx::Class::ResultSet> - Selecting and manipulating sets.
59
60 =item L<DBIx::Class::ResultSetColumn> - Perform operations on entire columns of a ResultSet.
61
62 =item L<DBIx::Class::Row> - Dealing with actual data.
63
64 =item L<DBIx::Class::Storage> - Basic Storage stuff.
65
66 =item L<DBIx::Class::Storage::DBI> - Storage using L<DBI> and L<SQL::Abstract>.
67
68 =back
0 =head1 NAME
1
2 DBIx::Class::Manual::DocMap - What documentation do we have?
3
4 =head1 Manuals
5
6 =over 4
7
8 =item L<DBIx::Class::Manual> - User's Manual overview.
9
10 =item L<DBIx::Class::Manual::FAQ> - Frequently Asked Questions, gathered from IRC and the mailing list.
11
12 =item L<DBIx::Class::Manual::Intro> - Introduction to setting up and using DBIx::Class.
13
14 =item L<DBIx::Class::Manual::Example> - Full example Schema.
15
16 =item L<DBIx::Class::Manual::Cookbook> - Various short recipes on how to do things.
17
18 =item L<DBIx::Class::Manual::Troubleshooting> - What to do if things go wrong (diagnostics of known error messages).
19
20 =item L<DBIx::Class::Manual::Component> - How to write your own DBIx::Class components.
21
22 =item L<DBIx::Class::Manual::Glossary> - What do all those terms mean?
23
24 =back
25
26 =head1 Setting up
27
28 =over 4
29
30 =item L<DBIx::Class::Schema> - Overall schemas, and connection container.
31
32 =item L<DBIx::Class::ResultSource> - Source/Table definition functions.
33
34 =item L<DBIx::Class::Relationship> - Simple relationships.
35
36 =item L<DBIx::Class::Relationship::Base> - Relationship details.
37
38 =item L<DBIx::Class::PK::Auto> - Magically retrieve auto-incrementing fields.
39
40 =item L<DBIx::Class::Core> - Set of standard components to load.
41
42 =item L<DBIx::Class::InflateColumn> - Making objects out of your columns.
43
44 =item L<DBIx::Class::InflateColumn::DateTime> - Magically turn your datetime or timestamp columns into DateTime objects.
45
46 =item L<DBIx::Class::PK> - Dealing with primary keys.
47
48 =item L<DBIx::Class::ResultSourceProxy::Table> - Turns the resultsource into a table.
49
50 =item L<DBIx::Class::AccessorGroup> - Accessor grouping.
51
52 =back
53
54 =head1 Retrieving and creating data
55
56 =over 4
57
58 =item L<DBIx::Class::ResultSet> - Selecting and manipulating sets.
59
60 =item L<DBIx::Class::ResultSetColumn> - Perform operations on entire columns of a ResultSet.
61
62 =item L<DBIx::Class::Row> - Dealing with actual data.
63
64 =item L<DBIx::Class::Storage> - Basic Storage stuff.
65
66 =item L<DBIx::Class::Storage::DBI> - Storage using L<DBI> and L<SQL::Abstract>.
67
68 =back
+11
-19
lib/DBIx/Class/Manual/FAQ.pod less more
5555 L<DBIx::Class::Schema/deploy>. See there for details, or the
5656 L<DBIx::Class::Manual::Cookbook>.
5757
58 =item .. store/retrieve Unicode data in my database?
59
60 Make sure you database supports Unicode and set the connect
61 attributes appropriately - see
62 L<DBIx::Class::Manual::Cookbook/Using Unicode>
63
5864 =item .. connect to my database?
5965
6066 Once you have created all the appropriate table/source classes, and an
125131 the tables are to be joined. The condition may contain as many fields
126132 as you like. See L<DBIx::Class::Relationship::Base>.
127133
128 =item .. define a relatiopnship across an intermediate table? (many-to-many)
134 =item .. define a relationship across an intermediate table? (many-to-many)
129135
130136 Read the documentation on L<DBIx::Class::Relationship/many_to_many>.
131137
181187
182188 =item .. sort my results based on fields I've aliased using C<as>?
183189
184 You don't. You'll need to supply the same functions/expressions to
185 C<order_by>, as you did to C<select>.
186
187 To get "fieldname AS alias" in your SQL, you'll need to supply a
188 literal chunk of SQL in your C<select> attribute, such as:
189
190 ->search({}, { select => [ \'now() AS currenttime'] })
191
192 Then you can use the alias in your C<order_by> attribute.
190 You didn't alias anything, since L<as|DBIx::Class::ResultSet/as>
191 B<has nothing to do> with the produced SQL. See
192 L<DBIx::Class::ResultSet/select> for details.
193193
194194 =item .. group the results of my search?
195195
198198
199199 =item .. group my results based on fields I've aliased using C<as>?
200200
201 You don't. You'll need to supply the same functions/expressions to
202 C<group_by>, as you did to C<select>.
203
204 To get "fieldname AS alias" in your SQL, you'll need to supply a
205 literal chunk of SQL in your C<select> attribute, such as:
206
207 ->search({}, { select => [ \'now() AS currenttime'] })
208
209 Then you can use the alias in your C<group_by> attribute.
201 You don't. See the explanation on ordering by an alias above.
210202
211203 =item .. filter the results of my search?
212204
+94
-94
lib/DBIx/Class/Manual/Glossary.pod less more
0 =head1 NAME
1
2 DBIx::Class::Manual::Glossary - Clarification of terms used.
3
4 =head1 INTRODUCTION
5
6 This document lists various terms used in DBIx::Class and attempts to
7 explain them.
8
9 =head1 TERMS
10
11 =head2 DB schema
12
13 Refers to a single physical schema within an RDBMS. Synonymous with the terms
14 'database', for MySQL; and 'schema', for most other RDBMS(s).
15
16 In other words, it's the 'xyz' _thing_ you're connecting to when using any of
17 the following L<DSN|DBI/connect>(s):
18
19 dbi:DriverName:xyz@hostname:port
20 dbi:DriverName:database=xyz;host=hostname;port=port
21
22 =head2 Inflation
23
24 The act of turning database row data into objects in
25 language-space. DBIx::Class further allows you to inflate your data
26 into perl objects which more usefully represent their contents. For
27 example: L<DBIx::Class::InflateColumn::DateTime> for datetime or
28 timestamp column data.
29
30 =head2 Join
31
32 This is an SQL keyword that gets mentioned a lot. It is used to fetch
33 data from more than one table at once, by C<join>ing the tables on
34 fields where they have common data.
35
36 =head2 Normalisation
37
38 A normalised database is a sane database. Each table contains only
39 data belonging to one concept, related tables refer to the key field
40 or fields of each other. Some links to webpages about normalisation
41 can be found in L<DBIx::Class::Manual::FAQ|the FAQ>.
42
43 =head2 ORM
44
45 Object-relational mapping, or Object-relationship modelling. Either
46 way it's a method of mapping the contents of database tables (rows),
47 to objects in programming-language-space. DBIx::Class is an ORM.
48
49 =head2 Relationship
50
51 In DBIx::Class a relationship defines the connection between exactly
52 two tables. The relationship condition lists the columns in each table
53 that contain the same values. It is used to output an SQL JOIN
54 condition between the tables.
55
56 =head2 Relationship bridge
57
58 A relationship bridge, such as C<many_to_many> defines an accessor to
59 retrieve row contents across multiple relationships.
60
61 =head2 ResultSet
62
63 This is an object representing a set of data. It can either be an
64 entire table, or the results of a query. The actual data is not held
65 in the ResultSet, it is only a description of how to fetch the data.
66
67 See also: L<DBIx::Class::ResultSet/METHODS>
68
69 =head2 ResultSource
70
71 ResultSource objects represent the source of your data, they are also known as
72 a table objects.
73
74 See also: L<DBIx::Class::ResultSource/METHODS>
75
76 =head2 Record
77
78 See Row.
79
80 =head2 Row
81
82 Row objects contain your actual data. They are returned from ResultSet objects.
83
84 =head2 Object
85
86 See Row.
87
88 =head2 Schema
89
90 A Schema object represents your entire table collection, plus the
91 connection to the database. You can create one or more schema objects,
92 connected to various databases, with various users, using the same set
93 of table (ResultSource) definitions.
0 =head1 NAME
1
2 DBIx::Class::Manual::Glossary - Clarification of terms used.
3
4 =head1 INTRODUCTION
5
6 This document lists various terms used in DBIx::Class and attempts to
7 explain them.
8
9 =head1 TERMS
10
11 =head2 DB schema
12
13 Refers to a single physical schema within an RDBMS. Synonymous with the terms
14 'database', for MySQL; and 'schema', for most other RDBMS(s).
15
16 In other words, it's the 'xyz' _thing_ you're connecting to when using any of
17 the following L<DSN|DBI/connect>(s):
18
19 dbi:DriverName:xyz@hostname:port
20 dbi:DriverName:database=xyz;host=hostname;port=port
21
22 =head2 Inflation
23
24 The act of turning database row data into objects in
25 language-space. DBIx::Class further allows you to inflate your data
26 into perl objects which more usefully represent their contents. For
27 example: L<DBIx::Class::InflateColumn::DateTime> for datetime or
28 timestamp column data.
29
30 =head2 Join
31
32 This is an SQL keyword that gets mentioned a lot. It is used to fetch
33 data from more than one table at once, by C<join>ing the tables on
34 fields where they have common data.
35
36 =head2 Normalisation
37
38 A normalised database is a sane database. Each table contains only
39 data belonging to one concept, related tables refer to the key field
40 or fields of each other. Some links to webpages about normalisation
41 can be found in L<DBIx::Class::Manual::FAQ|the FAQ>.
42
43 =head2 ORM
44
45 Object-relational mapping, or Object-relationship modelling. Either
46 way it's a method of mapping the contents of database tables (rows),
47 to objects in programming-language-space. DBIx::Class is an ORM.
48
49 =head2 Relationship
50
51 In DBIx::Class a relationship defines the connection between exactly
52 two tables. The relationship condition lists the columns in each table
53 that contain the same values. It is used to output an SQL JOIN
54 condition between the tables.
55
56 =head2 Relationship bridge
57
58 A relationship bridge, such as C<many_to_many> defines an accessor to
59 retrieve row contents across multiple relationships.
60
61 =head2 ResultSet
62
63 This is an object representing a set of data. It can either be an
64 entire table, or the results of a query. The actual data is not held
65 in the ResultSet, it is only a description of how to fetch the data.
66
67 See also: L<DBIx::Class::ResultSet/METHODS>
68
69 =head2 ResultSource
70
71 ResultSource objects represent the source of your data, they are also known as
72 a table objects.
73
74 See also: L<DBIx::Class::ResultSource/METHODS>
75
76 =head2 Record
77
78 See Row.
79
80 =head2 Row
81
82 Row objects contain your actual data. They are returned from ResultSet objects.
83
84 =head2 Object
85
86 See Row.
87
88 =head2 Schema
89
90 A Schema object represents your entire table collection, plus the
91 connection to the database. You can create one or more schema objects,
92 connected to various databases, with various users, using the same set
93 of table (ResultSource) definitions.
+52
-1
lib/DBIx/Class/Manual/Intro.pod less more
112112
113113 __PACKAGE__->load_components(qw/ Ordered /);
114114 __PACKAGE__->position_column('rank');
115
116 Ordered will refer to a field called 'position' unless otherwise directed. Here you are defining
117 the ordering field to be named 'rank'. (NOTE: Insert errors may occur if you use the Ordered
118 component, but have not defined a position column or have a 'position' field in your row.)
115119
116120 Set the table for your class:
117121
235239 { on_connect_do => \@on_connect_sql_statments }
236240 );
237241
238 See L<DBIx::Class::Schema::Storage::DBI/connect_info> for more information about
242 See L<DBIx::Class::Storage::DBI/connect_info> for more information about
239243 this and other special C<connect>-time options.
240244
241245 =head3 Via a database handle
396400
397401 =head1 NOTES
398402
403 =head2 The Significance and Importance of Primary Keys
404
405 The concept of a L<primary key|DBIx::Class::ResultSource/set_primary_key> in
406 DBIx::Class warrants special discussion. The formal definition (which somewhat
407 resembles that of a classic RDBMS) is I<a unique constraint that is least
408 likely to change after initial row creation>. However this is where the
409 similarity ends. Any time you call a CRUD operation on a row (e.g.
410 L<delete|DBIx::Class::Row/delete>,
411 L<update|DBIx::Class::Row/update>,
412 L<discard_changes|DBIx::Class::Row/discard_changes>,
413 etc.) DBIx::Class will use the values of of the
414 L<primary key|DBIx::Class::ResultSource/set_primary_key> columns to populate
415 the C<WHERE> clause necessary to accomplish the operation. This is why it is
416 important to declare a L<primary key|DBIx::Class::ResultSource/set_primary_key>
417 on all your result sources B<even if the underlying RDBMS does not have one>.
418 In a pinch one can always declare each row identifiable by all its columns:
419
420 __PACKAGE__->set_primary_keys (__PACKAGE__->columns);
421
422 Note that DBIx::Class is smart enough to store a copy of the PK values before
423 any row-object changes take place, so even if you change the values of PK
424 columns the C<WHERE> clause will remain correct.
425
426 If you elect not to declare a C<primary key>, DBIx::Class will behave correctly
427 by throwing exceptions on any row operation that relies on unique identifiable
428 rows. If you inherited datasets with multiple identical rows in them, you can
429 still operate with such sets provided you only utilize
430 L<DBIx::Class::ResultSet> CRUD methods:
431 L<search|DBIx::Class::ResultSet/search>,
432 L<update|DBIx::Class::ResultSet/update>,
433 L<delete|DBIx::Class::ResultSet/delete>
434
435 For example, the following would not work (assuming C<People> does not have
436 a declared PK):
437
438 my $row = $schema->resultset('People')
439 ->search({ last_name => 'Dantes' })
440 ->next;
441 $row->update({ children => 2 }); # <-- exception thrown because $row isn't
442 # necessarily unique
443
444 So instead the following should be done:
445
446 $schema->resultset('People')
447 ->search({ last_name => 'Dantes' })
448 ->update({ children => 2 }); # <-- update's ALL Dantes to have children of 2
449
399450 =head2 Problems on RHEL5/CentOS5
400451
401452 There used to be an issue with the system perl on Red Hat Enterprise
+8
-0
lib/DBIx/Class/Manual/Troubleshooting.pod less more
157157
158158 The solution is to use the smallest practical value for LongReadLen.
159159
160 =head2 create_ddl_dir does not produce DDL for MySQL views
161
162 L<SQL::Translator> does not create DDL for MySQL views if it doesn't know you
163 are using mysql version 5.000001 or higher. To explicity set this version, add
164 C<mysql_version> to the C<producer_args> in the C<%sqlt> options.
165
166 $schema->create_ddl_dir(['MySQL'], '1.0', './sql/', undef, { producer_args => { mysql_version => 5.000058 } })
167
160168 =cut
161169
+51
-51
lib/DBIx/Class/Manual.pod less more
0 =head1 NAME
1
2 DBIx::Class::Manual - Index of the Manual
3
4 =head1 DESCRIPTION
5
6 This is the L<DBIx::Class> users manual. DBIx::Class is a SQL->OOP mapper.
7 This means that it can represent your SQL tables as perl classes, and give
8 you convenient accessors and methods for retrieving and updating information
9 from your SQL database.
10
11 =head1 SECTIONS
12
13 =head2 L<DBIx::Class::Manual::FAQ>
14
15 Short answers and doc pointers to questions.
16
17 =head2 L<DBIx::Class::Manual::Intro>
18
19 Beginner guide to using DBIx::Class.
20
21 =head2 L<DBIx::Class::Manual::Example>
22
23 An example of slightly more complex usage.
24
25 =head2 L<DBIx::Class::Manual::Joining>
26
27 How to translate known SQL JOINs into DBIx-Class-ish.
28
29 =head2 L<DBIx::Class::Manual::Cookbook>
30
31 Convenient recipes for DBIC usage.
32
33 =head2 L<DBIx::Class::Manual::DocMap>
34
35 Lists of modules by task to help you find the correct document.
36
37 =head2 L<DBIx::Class::Manual::Troubleshooting>
38
39 Got trouble? Let us shoot it for you.
40
41 If you're using the CDBI Compat layer, we suggest reading the L<Class::DBI>
42 documentation. It should behave the same way.
43
44 =head2 L<DBIx::Class::Manual::Component>
45
46 Existing components, and documentation and example on how to
47 develop new ones.
48
49 =cut
50
0 =head1 NAME
1
2 DBIx::Class::Manual - Index of the Manual
3
4 =head1 DESCRIPTION
5
6 This is the L<DBIx::Class> users manual. DBIx::Class is a SQL->OOP mapper.
7 This means that it can represent your SQL tables as perl classes, and give
8 you convenient accessors and methods for retrieving and updating information
9 from your SQL database.
10
11 =head1 SECTIONS
12
13 =head2 L<DBIx::Class::Manual::FAQ>
14
15 Short answers and doc pointers to questions.
16
17 =head2 L<DBIx::Class::Manual::Intro>
18
19 Beginner guide to using DBIx::Class.
20
21 =head2 L<DBIx::Class::Manual::Example>
22
23 An example of slightly more complex usage.
24
25 =head2 L<DBIx::Class::Manual::Joining>
26
27 How to translate known SQL JOINs into DBIx-Class-ish.
28
29 =head2 L<DBIx::Class::Manual::Cookbook>
30
31 Convenient recipes for DBIC usage.
32
33 =head2 L<DBIx::Class::Manual::DocMap>
34
35 Lists of modules by task to help you find the correct document.
36
37 =head2 L<DBIx::Class::Manual::Troubleshooting>
38
39 Got trouble? Let us shoot it for you.
40
41 If you're using the CDBI Compat layer, we suggest reading the L<Class::DBI>
42 documentation. It should behave the same way.
43
44 =head2 L<DBIx::Class::Manual::Component>
45
46 Existing components, and documentation and example on how to
47 develop new ones.
48
49 =cut
50
+27
-16
lib/DBIx/Class/Optional/Dependencies.pm less more
8989
9090 test_notabs => {
9191 req => {
92 #'Test::NoTabs' => '0.9',
92 'Test::NoTabs' => '0.9',
9393 },
9494 },
9595
9696 test_eol => {
9797 req => {
98 #'Test::EOL' => '0.6',
98 'Test::EOL' => '0.6',
9999 },
100100 },
101101
175175
176176 rdbms_asa => {
177177 req => {
178 (scalar grep $_, @ENV{qw/DBICTEST_SYBASE_ASA_DSN DBICTEST_SYBASE_ASA_ODBC_DSN/})
178 (scalar grep { $ENV{$_} } (qw/DBICTEST_SYBASE_ASA_DSN DBICTEST_SYBASE_ASA_ODBC_DSN/) )
179179 ? (
180180 'DateTime::Format::Strptime' => 0,
181181 ) : ()
193193
194194 };
195195
196
197 sub _all_optional_requirements {
198 return { map { %{ $reqs->{$_}{req} || {} } } (keys %$reqs) };
199 }
200196
201197 sub req_list_for {
202198 my ($class, $group) = @_;
280276 }
281277 }
282278
283 # This is to be called by the author onbly (automatically in Makefile.PL)
279 sub req_group_list {
280 return { map { $_ => { %{ $reqs->{$_}{req} || {} } } } (keys %$reqs) };
281 }
282
283 # This is to be called by the author only (automatically in Makefile.PL)
284284 sub _gen_pod {
285285 my $class = shift;
286286 my $modfn = __PACKAGE__ . '.pm';
288288
289289 require DBIx::Class;
290290 my $distver = DBIx::Class->VERSION;
291 my $sqltver = $class->req_list_for ('deploy')->{'SQL::Translator'}
292 or die "Hrmm? No sqlt dep?";
291293
292294 my @chunks = (
293295 <<"EOC",
302304 EOC
303305 '=head1 NAME',
304306 "$class - Optional module dependency specifications (for module authors)",
305 '=head1 SYNOPSIS (EXPERIMENTAL)',
307 '=head1 SYNOPSIS',
306308 <<EOS,
307 B<THE USAGE SHOWN HERE IS EXPERIMENTAL>
308
309309 Somewhere in your build-file (e.g. L<Module::Install>'s Makefile.PL):
310310
311311 ...
365365
366366 push @chunks, (
367367 '=head1 METHODS',
368 '=head2 req_group_list',
369 '=over',
370 '=item Arguments: $none',
371 '=item Returns: \%list_of_requirement_groups',
372 '=back',
373 <<EOD,
374 This method should be used by DBIx::Class packagers, to get a hashref of all
375 dependencies keyed by dependency group. Each key (group name) can be supplied
376 to one of the group-specific methods below.
377 EOD
378
368379 '=head2 req_list_for',
369380 '=over',
370381 '=item Arguments: $group_name',
373384 <<EOD,
374385 This method should be used by DBIx::Class extension authors, to determine the
375386 version of modules a specific feature requires in the B<current> version of
376 DBIx::Class. See the L<SYNOPSIS|/SYNOPSIS (EXPERIMENTAL)> for a real-world
387 DBIx::Class. See the L</SYNOPSIS> for a real-world
377388 example.
378389 EOD
379390
395406 indicate to the user that he needs to install specific modules before he will
396407 be able to use a specific feature.
397408
398 For example if the requirements for C<replicated> are not available, the
399 returned string would look like:
400
401 Moose >= 0.98, MooseX::Types >= 0.21, namespace::clean (see $class for details)
409 For example if some of the requirements for C<deploy> are not available,
410 the returned string could look like:
411
412 SQL::Translator >= $sqltver (see $class for details)
402413
403414 The author is expected to prepend the necessary text to this message before
404415 returning the actual error seen by the user.
+22
-9
lib/DBIx/Class/Optional/Dependencies.pod less more
1111
1212 DBIx::Class::Optional::Dependencies - Optional module dependency specifications (for module authors)
1313
14 =head1 SYNOPSIS (EXPERIMENTAL)
15
16 B<THE USAGE SHOWN HERE IS EXPERIMENTAL>
14 =head1 SYNOPSIS
1715
1816 Somewhere in your build-file (e.g. L<Module::Install>'s Makefile.PL):
1917
2018 ...
2119
22 configure_requires 'DBIx::Class' => '0.08120';
20 configure_requires 'DBIx::Class' => '0.08121';
2321
2422 require DBIx::Class::Optional::Dependencies;
2523
134132
135133 =head1 METHODS
136134
135 =head2 req_group_list
136
137 =over
138
139 =item Arguments: $none
140
141 =item Returns: \%list_of_requirement_groups
142
143 =back
144
145 This method should be used by DBIx::Class packagers, to get a hashref of all
146 dependencies keyed by dependency group. Each key (group name) can be supplied
147 to one of the group-specific methods below.
148
149
137150 =head2 req_list_for
138151
139152 =over
146159
147160 This method should be used by DBIx::Class extension authors, to determine the
148161 version of modules a specific feature requires in the B<current> version of
149 DBIx::Class. See the L<SYNOPSIS|/SYNOPSIS (EXPERIMENTAL)> for a real-world
162 DBIx::Class. See the L</SYNOPSIS> for a real-world
150163 example.
151164
152165
177190 indicate to the user that he needs to install specific modules before he will
178191 be able to use a specific feature.
179192
180 For example if the requirements for C<replicated> are not available, the
181 returned string would look like:
182
183 Moose >= 0.98, MooseX::Types >= 0.21, namespace::clean (see DBIx::Class::Optional::Dependencies for details)
193 For example if some of the requirements for C<deploy> are not available,
194 the returned string could look like:
195
196 SQL::Translator >= 0.11005 (see DBIx::Class::Optional::Dependencies for details)
184197
185198 The author is expected to prepend the necessary text to this message before
186199 returning the actual error seen by the user.
+29
-29
lib/DBIx/Class/PK/Auto/DB2.pm less more
0 package # hide package from pause
1 DBIx::Class::PK::Auto::DB2;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::DB2 - (DEPRECATED) Automatic primary key class for DB2
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
0 package # hide package from pause
1 DBIx::Class::PK::Auto::DB2;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::DB2 - (DEPRECATED) Automatic primary key class for DB2
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
+29
-29
lib/DBIx/Class/PK/Auto/MSSQL.pm less more
0 package # hide package from pause
1 DBIx::Class::PK::Auto::MSSQL;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::MSSQL - (DEPRECATED) Automatic primary key class for MSSQL
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
0 package # hide package from pause
1 DBIx::Class::PK::Auto::MSSQL;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::MSSQL - (DEPRECATED) Automatic primary key class for MSSQL
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
+29
-29
lib/DBIx/Class/PK/Auto/MySQL.pm less more
0 package # hide package from pause
1 DBIx::Class::PK::Auto::MySQL;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::MySQL - (DEPRECATED) Automatic primary key class for MySQL
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
0 package # hide package from pause
1 DBIx::Class::PK::Auto::MySQL;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::MySQL - (DEPRECATED) Automatic primary key class for MySQL
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
+29
-29
lib/DBIx/Class/PK/Auto/Oracle.pm less more
0 package # hide package from pause
1 DBIx::Class::PK::Auto::Oracle;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::Oracle - (DEPRECATED) Automatic primary key class for Oracle
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
0 package # hide package from pause
1 DBIx::Class::PK::Auto::Oracle;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::Oracle - (DEPRECATED) Automatic primary key class for Oracle
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
+29
-29
lib/DBIx/Class/PK/Auto/Pg.pm less more
0 package # hide package from pause
1 DBIx::Class::PK::Auto::Pg;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::Pg - (DEPRECATED) Automatic primary key class for Pg
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
0 package # hide package from pause
1 DBIx::Class::PK::Auto::Pg;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::Pg - (DEPRECATED) Automatic primary key class for Pg
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
+29
-29
lib/DBIx/Class/PK/Auto/SQLite.pm less more
0 package # hide package from pause
1 DBIx::Class::PK::Auto::SQLite;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::SQLite - (DEPRECATED) Automatic primary key class for SQLite
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
0 package # hide package from pause
1 DBIx::Class::PK::Auto::SQLite;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/PK::Auto/);
9
10 1;
11
12 =head1 NAME
13
14 DBIx::Class::PK::Auto::SQLite - (DEPRECATED) Automatic primary key class for SQLite
15
16 =head1 SYNOPSIS
17
18 Just load PK::Auto instead; auto-inc is now handled by Storage.
19
20 =head1 AUTHORS
21
22 Matt S Trout <mst@shadowcatsystems.co.uk>
23
24 =head1 LICENSE
25
26 You may distribute this code under the same terms as Perl itself.
27
28 =cut
+1
-0
lib/DBIx/Class/PK.pm less more
3636
3737 sub _ident_values {
3838 my ($self) = @_;
39
3940 my (@ids, @missing);
4041
4142 for ($self->_pri_cols) {
+10
-6
lib/DBIx/Class/Relationship/Base.pm less more
201201 my $source = $self->result_source;
202202
203203 # condition resolution may fail if an incomplete master-object prefetch
204 # is encountered
205 my $cond =
206 eval { $source->_resolve_condition( $rel_info->{cond}, $rel, $self ) }
207 ||
208 $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION
209 ;
204 # is encountered - that is ok during prefetch construction (not yet in_storage)
205 my $cond = eval { $source->_resolve_condition( $rel_info->{cond}, $rel, $self ) };
206 if (my $err = $@) {
207 if ($self->in_storage) {
208 $self->throw_exception ($err);
209 }
210 else {
211 $cond = $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION;
212 }
213 }
210214
211215 if ($cond eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
212216 my $reverse = $source->reverse_relationship_info($rel);
+35
-17
lib/DBIx/Class/Relationship/CascadeActions.pm less more
1515 # be handling this anyway. Assuming we have joins we probably actually
1616 # *could* do them, but I'd rather not.
1717
18 my $ret = $self->next::method(@rest);
19
2018 my $source = $self->result_source;
2119 my %rels = map { $_ => $source->relationship_info($_) } $source->relationships;
2220 my @cascade = grep { $rels{$_}{attrs}{cascade_delete} } keys %rels;
23 foreach my $rel (@cascade) {
24 $self->search_related($rel)->delete_all;
21
22 if (@cascade) {
23 my $guard = $source->schema->txn_scope_guard;
24
25 my $ret = $self->next::method(@rest);
26
27 foreach my $rel (@cascade) {
28 $self->search_related($rel)->delete_all;
29 }
30
31 $guard->commit;
32 return $ret;
2533 }
26 return $ret;
34
35 $self->next::method(@rest);
2736 }
2837
2938 sub update {
3140 return $self->next::method(@rest) unless ref $self;
3241 # Because update cascades on a class *really* don't make sense!
3342
34 my $ret = $self->next::method(@rest);
35
3643 my $source = $self->result_source;
3744 my %rels = map { $_ => $source->relationship_info($_) } $source->relationships;
3845 my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels;
39 foreach my $rel (@cascade) {
40 next if (
41 $rels{$rel}{attrs}{accessor}
42 &&
43 $rels{$rel}{attrs}{accessor} eq 'single'
44 &&
45 !exists($self->{_relationship_data}{$rel})
46 );
47 $_->update for grep defined, $self->$rel;
46
47 if (@cascade) {
48 my $guard = $source->schema->txn_scope_guard;
49
50 my $ret = $self->next::method(@rest);
51
52 foreach my $rel (@cascade) {
53 next if (
54 $rels{$rel}{attrs}{accessor}
55 &&
56 $rels{$rel}{attrs}{accessor} eq 'single'
57 &&
58 !exists($self->{_relationship_data}{$rel})
59 );
60 $_->update for grep defined, $self->$rel;
61 }
62
63 $guard->commit;
64 return $ret;
4865 }
49 return $ret;
66
67 $self->next::method(@rest);
5068 }
5169
5270 1;
+4
-2
lib/DBIx/Class/Relationship/HasOne.pm less more
4646 ) if $f_class_loaded && !$f_class->has_column($f_key);
4747 $cond = { "foreign.${f_key}" => "self.${pri}" };
4848 }
49 $class->_validate_cond($cond);
49 $class->_validate_has_one_condition($cond);
5050 $class->add_relationship($rel, $f_class,
5151 $cond,
5252 { accessor => 'single',
7171 return $pri;
7272 }
7373
74 sub _validate_cond {
74 sub _validate_has_one_condition {
7575 my ($class, $cond ) = @_;
7676
7777 return if $ENV{DBIC_DONT_VALIDATE_RELS};
8383 # warning
8484 return unless $self_id =~ /^self\.(.*)$/;
8585 my $key = $1;
86 $class->throw_exception("Defining rel on ${class} that includes ${key} but no such column defined here yet")
87 unless $class->has_column($key);
8688 my $column_info = $class->column_info($key);
8789 if ( $column_info->{is_nullable} ) {
8890 carp(qq'"might_have/has_one" must not be on columns with is_nullable set to true ($class/$key). This might indicate an incorrect use of those relationship helpers instead of belongs_to.');
+16
-16
lib/DBIx/Class/Relationship/Helpers.pm less more
0 package # hide from PAUSE
1 DBIx::Class::Relationship::Helpers;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/
9 Relationship::HasMany
10 Relationship::HasOne
11 Relationship::BelongsTo
12 Relationship::ManyToMany
13 /);
14
15 1;
0 package # hide from PAUSE
1 DBIx::Class::Relationship::Helpers;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 __PACKAGE__->load_components(qw/
9 Relationship::HasMany
10 Relationship::HasOne
11 Relationship::BelongsTo
12 Relationship::ManyToMany
13 /);
14
15 1;
+42
-42
lib/DBIx/Class/Relationship/ProxyMethods.pm less more
0 package # hide from PAUSE
1 DBIx::Class::Relationship::ProxyMethods;
2
3 use strict;
4 use warnings;
5 use Sub::Name ();
6 use base qw/DBIx::Class/;
7
8 our %_pod_inherit_config =
9 (
10 class_map => { 'DBIx::Class::Relationship::ProxyMethods' => 'DBIx::Class::Relationship' }
11 );
12
13 sub register_relationship {
14 my ($class, $rel, $info) = @_;
15 if (my $proxy_list = $info->{attrs}{proxy}) {
16 $class->proxy_to_related($rel,
17 (ref $proxy_list ? @$proxy_list : $proxy_list));
18 }
19 $class->next::method($rel, $info);
20 }
21
22 sub proxy_to_related {
23 my ($class, $rel, @proxy) = @_;
24 no strict 'refs';
25 no warnings 'redefine';
26 foreach my $proxy (@proxy) {
27 my $name = join '::', $class, $proxy;
28 *$name = Sub::Name::subname $name,
29 sub {
30 my $self = shift;
31 my $val = $self->$rel;
32 if (@_ && !defined $val) {
33 $val = $self->create_related($rel, { $proxy => $_[0] });
34 @_ = ();
35 }
36 return ($val ? $val->$proxy(@_) : undef);
37 }
38 }
39 }
40
41 1;
0 package # hide from PAUSE
1 DBIx::Class::Relationship::ProxyMethods;
2
3 use strict;
4 use warnings;
5 use Sub::Name ();
6 use base qw/DBIx::Class/;
7
8 our %_pod_inherit_config =
9 (
10 class_map => { 'DBIx::Class::Relationship::ProxyMethods' => 'DBIx::Class::Relationship' }
11 );
12
13 sub register_relationship {
14 my ($class, $rel, $info) = @_;
15 if (my $proxy_list = $info->{attrs}{proxy}) {
16 $class->proxy_to_related($rel,
17 (ref $proxy_list ? @$proxy_list : $proxy_list));
18 }
19 $class->next::method($rel, $info);
20 }
21
22 sub proxy_to_related {
23 my ($class, $rel, @proxy) = @_;
24 no strict 'refs';
25 no warnings 'redefine';
26 foreach my $proxy (@proxy) {
27 my $name = join '::', $class, $proxy;
28 *$name = Sub::Name::subname $name,
29 sub {
30 my $self = shift;
31 my $val = $self->$rel;
32 if (@_ && !defined $val) {
33 $val = $self->create_related($rel, { $proxy => $_[0] });
34 @_ = ();
35 }
36 return ($val ? $val->$proxy(@_) : undef);
37 }
38 }
39 }
40
41 1;
+136
-136
lib/DBIx/Class/ResultClass/HashRefInflator.pm less more
0 package DBIx::Class::ResultClass::HashRefInflator;
1
2 use strict;
3 use warnings;
4
5 =head1 NAME
6
7 DBIx::Class::ResultClass::HashRefInflator - Get raw hashrefs from a resultset
8
9 =head1 SYNOPSIS
10
11 use DBIx::Class::ResultClass::HashRefInflator;
12
13 my $rs = $schema->resultset('CD');
14 $rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
15 while (my $hashref = $rs->next) {
16 ...
17 }
18
19 =head1 DESCRIPTION
20
21 DBIx::Class is faster than older ORMs like Class::DBI but it still isn't
22 designed primarily for speed. Sometimes you need to quickly retrieve the data
23 from a massive resultset, while skipping the creation of fancy row objects.
24 Specifying this class as a C<result_class> for a resultset will change C<< $rs->next >>
25 to return a plain data hash-ref (or a list of such hash-refs if C<< $rs->all >> is used).
26
27 There are two ways of applying this class to a resultset:
28
29 =over
30
31 =item *
32
33 Specify C<< $rs->result_class >> on a specific resultset to affect only that
34 resultset (and any chained off of it); or
35
36 =item *
37
38 Specify C<< __PACKAGE__->result_class >> on your source object to force all
39 uses of that result source to be inflated to hash-refs - this approach is not
40 recommended.
41
42 =back
43
44 =cut
45
46 ##############
47 # NOTE
48 #
49 # Generally people use this to gain as much speed as possible. If a new &mk_hash is
50 # implemented, it should be benchmarked using the maint/benchmark_hashrefinflator.pl
51 # script (in addition to passing all tests of course :). Additional instructions are
52 # provided in the script itself.
53 #
54
55 # This coderef is a simple recursive function
56 # Arguments: ($me, $prefetch) from inflate_result() below
57 my $mk_hash;
58 $mk_hash = sub {
59 if (ref $_[0] eq 'ARRAY') { # multi relationship
60 return [ map { $mk_hash->(@$_) || () } (@_) ];
61 }
62 else {
63 my $hash = {
64 # the main hash could be an undef if we are processing a skipped-over join
65 $_[0] ? %{$_[0]} : (),
66
67 # the second arg is a hash of arrays for each prefetched relation
68 map
69 { $_ => $mk_hash->( @{$_[1]->{$_}} ) }
70 ( $_[1] ? (keys %{$_[1]}) : () )
71 };
72
73 # if there is at least one defined column consider the resultset real
74 # (and not an emtpy has_many rel containing one empty hashref)
75 # an empty arrayref is an empty multi-sub-prefetch - don't consider
76 # those either
77 for (values %$hash) {
78 if (ref $_ eq 'ARRAY') {
79 return $hash if @$_;
80 }
81 elsif (defined $_) {
82 return $hash;
83 }
84 }
85
86 return undef;
87 }
88 };
89
90 =head1 METHODS
91
92 =head2 inflate_result
93
94 Inflates the result and prefetched data into a hash-ref (invoked by L<DBIx::Class::ResultSet>)
95
96 =cut
97
98 ##################################################################################
99 # inflate_result is invoked as:
100 # HRI->inflate_result ($resultsource_instance, $main_data_hashref, $prefetch_data_hashref)
101 sub inflate_result {
102 return $mk_hash->($_[2], $_[3]);
103 }
104
105
106 =head1 CAVEATS
107
108 =over
109
110 =item *
111
112 This will not work for relationships that have been prefetched. Consider the
113 following:
114
115 my $artist = $artitsts_rs->search({}, {prefetch => 'cds' })->first;
116
117 my $cds = $artist->cds;
118 $cds->result_class('DBIx::Class::ResultClass::HashRefInflator');
119 my $first = $cds->first;
120
121 C<$first> will B<not> be a hashref, it will be a normal CD row since
122 HashRefInflator only affects resultsets at inflation time, and prefetch causes
123 relations to be inflated when the master C<$artist> row is inflated.
124
125 =item *
126
127 Column value inflation, e.g., using modules like
128 L<DBIx::Class::InflateColumn::DateTime>, is not performed.
129 The returned hash contains the raw database values.
130
131 =back
132
133 =cut
134
135 1;
0 package DBIx::Class::ResultClass::HashRefInflator;
1
2 use strict;
3 use warnings;
4
5 =head1 NAME
6
7 DBIx::Class::ResultClass::HashRefInflator - Get raw hashrefs from a resultset
8
9 =head1 SYNOPSIS
10
11 use DBIx::Class::ResultClass::HashRefInflator;
12
13 my $rs = $schema->resultset('CD');
14 $rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
15 while (my $hashref = $rs->next) {
16 ...
17 }
18
19 =head1 DESCRIPTION
20
21 DBIx::Class is faster than older ORMs like Class::DBI but it still isn't
22 designed primarily for speed. Sometimes you need to quickly retrieve the data
23 from a massive resultset, while skipping the creation of fancy row objects.
24 Specifying this class as a C<result_class> for a resultset will change C<< $rs->next >>
25 to return a plain data hash-ref (or a list of such hash-refs if C<< $rs->all >> is used).
26
27 There are two ways of applying this class to a resultset:
28
29 =over
30
31 =item *
32
33 Specify C<< $rs->result_class >> on a specific resultset to affect only that
34 resultset (and any chained off of it); or
35
36 =item *
37
38 Specify C<< __PACKAGE__->result_class >> on your source object to force all
39 uses of that result source to be inflated to hash-refs - this approach is not
40 recommended.
41
42 =back
43
44 =cut
45
46 ##############
47 # NOTE
48 #
49 # Generally people use this to gain as much speed as possible. If a new &mk_hash is
50 # implemented, it should be benchmarked using the maint/benchmark_hashrefinflator.pl
51 # script (in addition to passing all tests of course :). Additional instructions are
52 # provided in the script itself.
53 #
54
55 # This coderef is a simple recursive function
56 # Arguments: ($me, $prefetch) from inflate_result() below
57 my $mk_hash;
58 $mk_hash = sub {
59 if (ref $_[0] eq 'ARRAY') { # multi relationship
60 return [ map { $mk_hash->(@$_) || () } (@_) ];
61 }
62 else {
63 my $hash = {
64 # the main hash could be an undef if we are processing a skipped-over join
65 $_[0] ? %{$_[0]} : (),
66
67 # the second arg is a hash of arrays for each prefetched relation
68 map
69 { $_ => $mk_hash->( @{$_[1]->{$_}} ) }
70 ( $_[1] ? (keys %{$_[1]}) : () )
71 };
72
73 # if there is at least one defined column consider the resultset real
74 # (and not an emtpy has_many rel containing one empty hashref)
75 # an empty arrayref is an empty multi-sub-prefetch - don't consider
76 # those either
77 for (values %$hash) {
78 if (ref $_ eq 'ARRAY') {
79 return $hash if @$_;
80 }
81 elsif (defined $_) {
82 return $hash;
83 }
84 }
85
86 return undef;
87 }
88 };
89
90 =head1 METHODS
91
92 =head2 inflate_result
93
94 Inflates the result and prefetched data into a hash-ref (invoked by L<DBIx::Class::ResultSet>)
95
96 =cut
97
98 ##################################################################################
99 # inflate_result is invoked as:
100 # HRI->inflate_result ($resultsource_instance, $main_data_hashref, $prefetch_data_hashref)
101 sub inflate_result {
102 return $mk_hash->($_[2], $_[3]);
103 }
104
105
106 =head1 CAVEATS
107
108 =over
109
110 =item *
111
112 This will not work for relationships that have been prefetched. Consider the
113 following:
114
115 my $artist = $artitsts_rs->search({}, {prefetch => 'cds' })->first;
116
117 my $cds = $artist->cds;
118 $cds->result_class('DBIx::Class::ResultClass::HashRefInflator');
119 my $first = $cds->first;
120
121 C<$first> will B<not> be a hashref, it will be a normal CD row since
122 HashRefInflator only affects resultsets at inflation time, and prefetch causes
123 relations to be inflated when the master C<$artist> row is inflated.
124
125 =item *
126
127 Column value inflation, e.g., using modules like
128 L<DBIx::Class::InflateColumn::DateTime>, is not performed.
129 The returned hash contains the raw database values.
130
131 =back
132
133 =cut
134
135 1;
+37
-35
lib/DBIx/Class/ResultSet.pm less more
2424 =head1 SYNOPSIS
2525
2626 my $users_rs = $schema->resultset('User');
27 while( $user = $users_rs->next) {
28 print $user->username;
29 }
30
2731 my $registered_users_rs = $schema->resultset('User')->search({ registered => 1 });
2832 my @cds_in_2005 = $schema->resultset('CD')->search({ year => 2005 })->all();
2933
10021006 # without having to contruct the full hash
10031007
10041008 if (keys %collapse) {
1005 my %pri = map { ($_ => 1) } $self->result_source->primary_columns;
1009 my %pri = map { ($_ => 1) } $self->result_source->_pri_cols;
10061010 foreach my $i (0 .. $#construct_as) {
10071011 next if defined($construct_as[$i][0]); # only self table
10081012 if (delete $pri{$construct_as[$i][1]}) {
15081512 my ($self, $values) = @_;
15091513 $self->throw_exception('Values for update_all must be a hash')
15101514 unless ref $values eq 'HASH';
1511 foreach my $obj ($self->all) {
1512 $obj->set_columns($values)->update;
1513 }
1515
1516 my $guard = $self->result_source->schema->txn_scope_guard;
1517 $_->update($values) for $self->all;
1518 $guard->commit;
15141519 return 1;
15151520 }
15161521
15281533 will not run DBIC cascade triggers. See L</delete_all> if you need triggers
15291534 to run. See also L<DBIx::Class::Row/delete>.
15301535
1531 Return value will be the amount of rows deleted; exact type of return value
1536 Return value will be the number of rows deleted; exact type of return value
15321537 is storage-dependent.
15331538
15341539 =cut
15611566 $self->throw_exception('delete_all does not accept any arguments')
15621567 if @_;
15631568
1569 my $guard = $self->result_source->schema->txn_scope_guard;
15641570 $_->delete for $self->all;
1571 $guard->commit;
15651572 return 1;
15661573 }
15671574
32543261 select => [
32553262 'name',
32563263 { count => 'employeeid' },
3257 { sum => 'salary' }
3264 { max => { length => 'name' }, -as => 'longest_name' }
32583265 ]
32593266 });
32603267
3261 When you use function/stored procedure names and do not supply an C<as>
3262 attribute, the column names returned are storage-dependent. E.g. MySQL would
3263 return a column named C<count(employeeid)> in the above example.
3264
3265 B<NOTE:> You will almost always need a corresponding 'as' entry when you use
3266 'select'.
3268 # Equivalent SQL
3269 SELECT name, COUNT( employeeid ), MAX( LENGTH( name ) ) AS longest_name FROM employee
3270
3271 B<NOTE:> You will almost always need a corresponding L</as> attribute when you
3272 use L</select>, to instruct DBIx::Class how to store the result of the column.
3273 Also note that the L</as> attribute has nothing to do with the SQL-side 'AS'
3274 identifier aliasing. You can however alias a function, so you can use it in
3275 e.g. an C<ORDER BY> clause. This is done via the C<-as> B<select function
3276 attribute> supplied as shown in the example above.
32673277
32683278 =head2 +select
32693279
32703280 =over 4
32713281
32723282 Indicates additional columns to be selected from storage. Works the same as
3273 L</select> but adds columns to the selection.
3283 L</select> but adds columns to the default selection, instead of specifying
3284 an explicit list.
32743285
32753286 =back
32763287
32903301
32913302 =back
32923303
3293 Indicates column names for object inflation. That is, C<as>
3294 indicates the name that the column can be accessed as via the
3295 C<get_column> method (or via the object accessor, B<if one already
3296 exists>). It has nothing to do with the SQL code C<SELECT foo AS bar>.
3297
3298 The C<as> attribute is used in conjunction with C<select>,
3299 usually when C<select> contains one or more function or stored
3300 procedure names:
3304 Indicates column names for object inflation. That is L</as> indicates the
3305 slot name in which the column value will be stored within the
3306 L<Row|DBIx::Class::Row> object. The value will then be accessible via this
3307 identifier by the C<get_column> method (or via the object accessor B<if one
3308 with the same name already exists>) as shown below. The L</as> attribute has
3309 B<nothing to do> with the SQL-side C<AS>. See L</select> for details.
33013310
33023311 $rs = $schema->resultset('Employee')->search(undef, {
33033312 select => [
33043313 'name',
3305 { count => 'employeeid' }
3314 { count => 'employeeid' },
3315 { max => { length => 'name' }, -as => 'longest_name' }
33063316 ],
3307 as => ['name', 'employee_count'],
3317 as => [qw/
3318 name
3319 employee_count
3320 max_name_length
3321 /],
33083322 });
3309
3310 my $employee = $rs->first(); # get the first Employee
33113323
33123324 If the object against which the search is performed already has an accessor
33133325 matching a column name specified in C<as>, the value can be retrieved using
33223334
33233335 You can create your own accessors if required - see
33243336 L<DBIx::Class::Manual::Cookbook> for details.
3325
3326 Please note: This will NOT insert an C<AS employee_count> into the SQL
3327 statement produced, it is used for internal access only. Thus
3328 attempting to use the accessor in an C<order_by> clause or similar
3329 will fail miserably.
3330
3331 To get around this limitation, you can supply literal SQL to your
3332 C<select> attribute that contains the C<AS alias> text, e.g.
3333
3334 select => [\'myfield AS alias']
33353337
33363338 =head2 join
33373339
+7
-12
lib/DBIx/Class/ResultSetColumn.pm less more
4444 $rs->throw_exception('column must be supplied') unless $column;
4545
4646 my $orig_attrs = $rs->_resolved_attrs;
47 my $alias = $rs->current_source_alias;
4748
4849 # If $column can be found in the 'as' list of the parent resultset, use the
4950 # corresponding element of its 'select' list (to keep any custom column
5859 # analyze the order_by, and see if it is done over a function/nonexistentcolumn
5960 # if this is the case we will need to wrap a subquery since the result of RSC
6061 # *must* be a single column select
61 my %collist = map { $_ => 1 } ($rs->result_source->columns, $column);
62 my %collist = map
63 { $_ => 1, ($_ =~ /\./) ? () : ( "$alias.$_" => 1 ) }
64 ($rs->result_source->columns, $column)
65 ;
6266 if (
6367 scalar grep
6468 { ! $collist{$_} }
6569 ( $rs->result_source->schema->storage->_parse_order_by ($orig_attrs->{order_by} ) )
6670 ) {
67 my $alias = $rs->current_source_alias;
6871 # nuke the prefetch before collapsing to sql
6972 my $subq_rs = $rs->search;
7073 $subq_rs->{attrs}{join} = $subq_rs->_merge_attr( $subq_rs->{attrs}{join}, delete $subq_rs->{attrs}{prefetch} );
71
72 $new_parent_rs = $rs->result_source->resultset->search ( {}, {
73 alias => $alias,
74 from => [{
75 $alias => $subq_rs->as_query,
76 -alias => $alias,
77 -source_handle => $rs->result_source->handle,
78 }]
79 });
74 $new_parent_rs = $subq_rs->as_subselect_rs;
8075 }
8176
8277 $new_parent_rs ||= $rs->search_rs;
9085
9186 # {collapse} would mean a has_many join was injected, which in turn means
9287 # we need to group *IF WE CAN* (only if the column in question is unique)
93 if (!$new_attrs->{group_by} && keys %{$orig_attrs->{collapse}}) {
88 if (!$orig_attrs->{group_by} && keys %{$orig_attrs->{collapse}}) {
9489
9590 # scan for a constraint that would contain our column only - that'd be proof
9691 # enough it is unique
+91
-91
lib/DBIx/Class/ResultSetManager.pm less more
0 package DBIx::Class::ResultSetManager;
1 use strict;
2 use warnings;
3 use base 'DBIx::Class';
4 use Sub::Name ();
5 use Class::Inspector;
6
7 warn "DBIx::Class::ResultSetManager never left experimental status and
8 has now been DEPRECATED. This module will be deleted in 09000 so please
9 migrate any and all code using it to explicit resultset classes using either
10 __PACKAGE__->resultset_class(...) calls or by switching from using
11 DBIx::Class::Schema->load_classes() to load_namespaces() and creating
12 appropriate My::Schema::ResultSet::* classes for it to pick up.";
13
14 =head1 NAME
15
16 DBIx::Class::ResultSetManager - scheduled for deletion in 09000
17
18 =head1 DESCRIPTION
19
20 DBIx::Class::ResultSetManager never left experimental status and
21 has now been DEPRECATED. This module will be deleted in 09000 so please
22 migrate any and all code using it to explicit resultset classes using either
23 __PACKAGE__->resultset_class(...) calls or by switching from using
24 DBIx::Class::Schema->load_classes() to load_namespaces() and creating
25 appropriate My::Schema::ResultSet::* classes for it to pick up.";
26
27 =cut
28
29 __PACKAGE__->mk_classdata($_)
30 for qw/ base_resultset_class table_resultset_class_suffix /;
31 __PACKAGE__->base_resultset_class('DBIx::Class::ResultSet');
32 __PACKAGE__->table_resultset_class_suffix('::_resultset');
33
34 sub table {
35 my ($self,@rest) = @_;
36 my $ret = $self->next::method(@rest);
37 if (@rest) {
38 $self->_register_attributes;
39 $self->_register_resultset_class;
40 }
41 return $ret;
42 }
43
44 sub load_resultset_components {
45 my ($self,@comp) = @_;
46 my $resultset_class = $self->_setup_resultset_class;
47 $resultset_class->load_components(@comp);
48 }
49
50 sub _register_attributes {
51 my $self = shift;
52 my $cache = $self->_attr_cache;
53 return if keys %$cache == 0;
54
55 foreach my $meth (@{Class::Inspector->methods($self) || []}) {
56 my $attrs = $cache->{$self->can($meth)};
57 next unless $attrs;
58 if ($attrs->[0] eq 'ResultSet') {
59 no strict 'refs';
60 my $resultset_class = $self->_setup_resultset_class;
61 my $name = join '::',$resultset_class, $meth;
62 *$name = Sub::Name::subname $name, $self->can($meth);
63 delete ${"${self}::"}{$meth};
64 }
65 }
66 }
67
68 sub _setup_resultset_class {
69 my $self = shift;
70 my $resultset_class = $self . $self->table_resultset_class_suffix;
71 no strict 'refs';
72 unless (@{"$resultset_class\::ISA"}) {
73 @{"$resultset_class\::ISA"} = ($self->base_resultset_class);
74 }
75 return $resultset_class;
76 }
77
78 sub _register_resultset_class {
79 my $self = shift;
80 my $resultset_class = $self . $self->table_resultset_class_suffix;
81 no strict 'refs';
82 if (@{"$resultset_class\::ISA"}) {
83 $self->result_source_instance->resultset_class($resultset_class);
84 } else {
85 $self->result_source_instance->resultset_class
86 ($self->base_resultset_class);
87 }
88 }
89
90 1;
0 package DBIx::Class::ResultSetManager;
1 use strict;
2 use warnings;
3 use base 'DBIx::Class';
4 use Sub::Name ();
5 use Class::Inspector;
6
7 warn "DBIx::Class::ResultSetManager never left experimental status and
8 has now been DEPRECATED. This module will be deleted in 09000 so please
9 migrate any and all code using it to explicit resultset classes using either
10 __PACKAGE__->resultset_class(...) calls or by switching from using
11 DBIx::Class::Schema->load_classes() to load_namespaces() and creating
12 appropriate My::Schema::ResultSet::* classes for it to pick up.";
13
14 =head1 NAME
15
16 DBIx::Class::ResultSetManager - scheduled for deletion in 09000
17
18 =head1 DESCRIPTION
19
20 DBIx::Class::ResultSetManager never left experimental status and
21 has now been DEPRECATED. This module will be deleted in 09000 so please
22 migrate any and all code using it to explicit resultset classes using either
23 __PACKAGE__->resultset_class(...) calls or by switching from using
24 DBIx::Class::Schema->load_classes() to load_namespaces() and creating
25 appropriate My::Schema::ResultSet::* classes for it to pick up.";
26
27 =cut
28
29 __PACKAGE__->mk_classdata($_)
30 for qw/ base_resultset_class table_resultset_class_suffix /;
31 __PACKAGE__->base_resultset_class('DBIx::Class::ResultSet');
32 __PACKAGE__->table_resultset_class_suffix('::_resultset');
33
34 sub table {
35 my ($self,@rest) = @_;
36 my $ret = $self->next::method(@rest);
37 if (@rest) {
38 $self->_register_attributes;
39 $self->_register_resultset_class;
40 }
41 return $ret;
42 }
43
44 sub load_resultset_components {
45 my ($self,@comp) = @_;
46 my $resultset_class = $self->_setup_resultset_class;
47 $resultset_class->load_components(@comp);
48 }
49
50 sub _register_attributes {
51 my $self = shift;
52 my $cache = $self->_attr_cache;
53 return if keys %$cache == 0;
54
55 foreach my $meth (@{Class::Inspector->methods($self) || []}) {
56 my $attrs = $cache->{$self->can($meth)};
57 next unless $attrs;
58 if ($attrs->[0] eq 'ResultSet') {
59 no strict 'refs';
60 my $resultset_class = $self->_setup_resultset_class;
61 my $name = join '::',$resultset_class, $meth;
62 *$name = Sub::Name::subname $name, $self->can($meth);
63 delete ${"${self}::"}{$meth};
64 }
65 }
66 }
67
68 sub _setup_resultset_class {
69 my $self = shift;
70 my $resultset_class = $self . $self->table_resultset_class_suffix;
71 no strict 'refs';
72 unless (@{"$resultset_class\::ISA"}) {
73 @{"$resultset_class\::ISA"} = ($self->base_resultset_class);
74 }
75 return $resultset_class;
76 }
77
78 sub _register_resultset_class {
79 my $self = shift;
80 my $resultset_class = $self . $self->table_resultset_class_suffix;
81 no strict 'refs';
82 if (@{"$resultset_class\::ISA"}) {
83 $self->result_source_instance->resultset_class($resultset_class);
84 } else {
85 $self->result_source_instance->resultset_class
86 ($self->base_resultset_class);
87 }
88 }
89
90 1;
+20
-20
lib/DBIx/Class/ResultSetProxy.pm less more
0 package # hide from PAUSE
1 DBIx::Class::ResultSetProxy;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 sub search { shift->resultset_instance->search(@_); }
9 sub search_literal { shift->resultset_instance->search_literal(@_); }
10 sub search_like { shift->resultset_instance->search_like(@_); }
11 sub count { shift->resultset_instance->count(@_); }
12 sub count_literal { shift->resultset_instance->count_literal(@_); }
13 sub find { shift->resultset_instance->find(@_); }
14 sub create { shift->resultset_instance->create(@_); }
15 sub find_or_create { shift->resultset_instance->find_or_create(@_); }
16 sub find_or_new { shift->resultset_instance->find_or_new(@_); }
17 sub update_or_create { shift->resultset_instance->update_or_create(@_); }
18
19 1;
0 package # hide from PAUSE
1 DBIx::Class::ResultSetProxy;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class/;
7
8 sub search { shift->resultset_instance->search(@_); }
9 sub search_literal { shift->resultset_instance->search_literal(@_); }
10 sub search_like { shift->resultset_instance->search_like(@_); }
11 sub count { shift->resultset_instance->count(@_); }
12 sub count_literal { shift->resultset_instance->count_literal(@_); }
13 sub find { shift->resultset_instance->find(@_); }
14 sub create { shift->resultset_instance->create(@_); }
15 sub find_or_create { shift->resultset_instance->find_or_create(@_); }
16 sub find_or_new { shift->resultset_instance->find_or_new(@_); }
17 sub update_or_create { shift->resultset_instance->update_or_create(@_); }
18
19 1;
+35
-16
lib/DBIx/Class/ResultSource.pm less more
138138 L<DBIx::Class::Row> objects. You can change the name of the accessor
139139 by supplying an L</accessor> in the column_info hash.
140140
141 If a column name beginning with a plus sign ('+col1') is provided, the
142 attributes provided will be merged with any existing attributes for the
143 column, with the new attributes taking precedence in the case that an
144 attribute already exists. Using this without a hashref
145 (C<< $source->add_columns(qw/+col1 +col2/) >>) is legal, but useless --
146 it does the same thing it would do without the plus.
147
141148 The contents of the column_info are not set in stone. The following
142149 keys are currently recognised/used by DBIx::Class:
143150
249256 L</sequence> value as well.
250257
251258 Also set this for MSSQL columns with the 'uniqueidentifier'
252 L<DBIx::Class::ResultSource/data_type> whose values you want to automatically
253 generate using C<NEWID()>, unless they are a primary key in which case this will
254 be done anyway.
259 L<data_type|DBIx::Class::ResultSource/data_type> whose values you want to
260 automatically generate using C<NEWID()>, unless they are a primary key in which
261 case this will be done anyway.
255262
256263 =item extra
257264
287294 my @added;
288295 my $columns = $self->_columns;
289296 while (my $col = shift @cols) {
297 my $column_info = {};
298 if ($col =~ s/^\+//) {
299 $column_info = $self->column_info($col);
300 }
301
290302 # If next entry is { ... } use that for the column info, if not
291303 # use an empty hashref
292 my $column_info = ref $cols[0] ? shift(@cols) : {};
304 if (ref $cols[0]) {
305 my $new_info = shift(@cols);
306 %$column_info = (%$column_info, %$new_info);
307 }
293308 push(@added, $col) unless exists $columns->{$col};
294309 $columns->{$col} = $column_info;
295310 }
464479 Additionally, defines a L<unique constraint|add_unique_constraint>
465480 named C<primary>.
466481
467 The primary key columns are used by L<DBIx::Class::PK::Auto> to
468 retrieve automatically created values from the database. They are also
469 used as default joining columns when specifying relationships, see
470 L<DBIx::Class::Relationship>.
482 Note: you normally do want to define a primary key on your sources
483 B<even if the underlying database table does not have a primary key>.
484 See
485 L<DBIx::Class::Intro/The Significance and Importance of Primary Keys>
486 for more info.
471487
472488 =cut
473489
502518 return @{shift->_primaries||[]};
503519 }
504520
521 # a helper method that will automatically die with a descriptive message if
522 # no pk is defined on the source in question. For internal use to save
523 # on if @pks... boilerplate
505524 sub _pri_cols {
506525 my $self = shift;
507526 my @pcols = $self->primary_columns
508527 or $self->throw_exception (sprintf(
509 'Operation requires a primary key to be declared on %s via set_primary_key',
510 ref $self,
528 "Operation requires a primary key to be declared on '%s' via set_primary_key",
529 $self->source_name,
511530 ));
512531 return @pcols;
513532 }
12251244 for my $rel (keys %$join) {
12261245
12271246 my $rel_info = $self->relationship_info($rel)
1228 or $self->throw_exception("No such relationship ${rel}");
1247 or $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
12291248
12301249 my $force_left = $parent_force_left;
12311250 $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left';
12551274 );
12561275
12571276 my $rel_info = $self->relationship_info($join)
1258 or $self->throw_exception("No such relationship ${join}");
1277 or $self->throw_exception("No such relationship $join on " . $self->source_name);
12591278
12601279 my $rel_src = $self->related_source($join);
12611280 return [ { $as => $rel_src->from,
14231442 my $as = shift @{$p->{-join_aliases}};
14241443
14251444 my $rel_info = $self->relationship_info( $pre );
1426 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
1445 $self->throw_exception( $self->source_name . " has no such relationship '$pre'" )
14271446 unless $rel_info;
14281447 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
14291448 my $rel_source = $self->related_source($pre);
14481467 }
14491468 #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
14501469 # values %{$rel_info->{cond}};
1451 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
1470 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->_pri_cols ];
14521471 # action at a distance. prepending the '.' allows simpler code
14531472 # in ResultSet->_collapse_result
14541473 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
14841503 sub related_source {
14851504 my ($self, $rel) = @_;
14861505 if( !$self->has_relationship( $rel ) ) {
1487 $self->throw_exception("No such relationship '$rel'");
1506 $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
14881507 }
14891508 return $self->schema->source($self->relationship_info($rel)->{source});
14901509 }
15061525 sub related_class {
15071526 my ($self, $rel) = @_;
15081527 if( !$self->has_relationship( $rel ) ) {
1509 $self->throw_exception("No such relationship '$rel'");
1528 $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
15101529 }
15111530 return $self->schema->class($self->relationship_info($rel)->{source});
15121531 }
+140
-140
lib/DBIx/Class/ResultSourceProxy/Table.pm less more
0 package DBIx::Class::ResultSourceProxy::Table;
1
2 use strict;
3 use warnings;
4
5 use base qw/DBIx::Class::ResultSourceProxy/;
6
7 use DBIx::Class::ResultSource::Table;
8 use Scalar::Util ();
9
10 __PACKAGE__->mk_classdata(table_class => 'DBIx::Class::ResultSource::Table');
11
12 __PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do
13 # anything yet!
14
15 sub _init_result_source_instance {
16 my $class = shift;
17
18 $class->mk_classdata('result_source_instance')
19 unless $class->can('result_source_instance');
20
21 my $table = $class->result_source_instance;
22 my $class_has_table_instance = ($table and $table->result_class eq $class);
23 return $table if $class_has_table_instance;
24
25 my $table_class = $class->table_class;
26 $class->ensure_class_loaded($table_class);
27
28 if( $table ) {
29 $table = $table_class->new({
30 %$table,
31 result_class => $class,
32 source_name => undef,
33 schema => undef
34 });
35 }
36 else {
37 $table = $table_class->new({
38 name => undef,
39 result_class => $class,
40 source_name => undef,
41 });
42 }
43
44 $class->result_source_instance($table);
45
46 return $table;
47 }
48
49 =head1 NAME
50
51 DBIx::Class::ResultSourceProxy::Table - provides a classdata table
52 object and method proxies
53
54 =head1 SYNOPSIS
55
56 __PACKAGE__->table('cd');
57 __PACKAGE__->add_columns(qw/cdid artist title year/);
58 __PACKAGE__->set_primary_key('cdid');
59
60 =head1 METHODS
61
62 =head2 add_columns
63
64 __PACKAGE__->add_columns(qw/cdid artist title year/);
65
66 Adds columns to the current class and creates accessors for them.
67
68 =cut
69
70 =head2 table
71
72 __PACKAGE__->table('tbl_name');
73
74 Gets or sets the table name.
75
76 =cut
77
78 sub table {
79 my ($class, $table) = @_;
80 return $class->result_source_instance->name unless $table;
81
82 unless (Scalar::Util::blessed($table) && $table->isa($class->table_class)) {
83
84 my $table_class = $class->table_class;
85 $class->ensure_class_loaded($table_class);
86
87 $table = $table_class->new({
88 $class->can('result_source_instance') ?
89 %{$class->result_source_instance||{}} : (),
90 name => $table,
91 result_class => $class,
92 source_name => undef,
93 });
94 }
95
96 $class->mk_classdata('result_source_instance')
97 unless $class->can('result_source_instance');
98
99 $class->result_source_instance($table);
100
101 return $class->result_source_instance->name;
102 }
103
104 =head2 has_column
105
106 if ($obj->has_column($col)) { ... }
107
108 Returns 1 if the class has a column of this name, 0 otherwise.
109
110 =cut
111
112 =head2 column_info
113
114 my $info = $obj->column_info($col);
115
116 Returns the column metadata hashref for a column. For a description of
117 the various types of column data in this hashref, see
118 L<DBIx::Class::ResultSource/add_column>
119
120 =cut
121
122 =head2 columns
123
124 my @column_names = $obj->columns;
125
126 =cut
127
128 1;
129
130 =head1 AUTHORS
131
132 Matt S. Trout <mst@shadowcatsystems.co.uk>
133
134 =head1 LICENSE
135
136 You may distribute this code under the same terms as Perl itself.
137
138 =cut
139
0 package DBIx::Class::ResultSourceProxy::Table;
1
2 use strict;
3 use warnings;
4
5 use base qw/DBIx::Class::ResultSourceProxy/;
6
7 use DBIx::Class::ResultSource::Table;
8 use Scalar::Util ();
9
10 __PACKAGE__->mk_classdata(table_class => 'DBIx::Class::ResultSource::Table');
11
12 __PACKAGE__->mk_classdata('table_alias'); # FIXME: Doesn't actually do
13 # anything yet!
14
15 sub _init_result_source_instance {
16 my $class = shift;
17
18 $class->mk_classdata('result_source_instance')
19 unless $class->can('result_source_instance');
20
21 my $table = $class->result_source_instance;
22 my $class_has_table_instance = ($table and $table->result_class eq $class);
23 return $table if $class_has_table_instance;
24
25 my $table_class = $class->table_class;
26 $class->ensure_class_loaded($table_class);
27
28 if( $table ) {
29 $table = $table_class->new({
30 %$table,
31 result_class => $class,
32 source_name => undef,
33 schema => undef
34 });
35 }
36 else {
37 $table = $table_class->new({
38 name => undef,
39 result_class => $class,
40 source_name => undef,
41 });
42 }
43
44 $class->result_source_instance($table);
45
46 return $table;
47 }
48
49 =head1 NAME
50
51 DBIx::Class::ResultSourceProxy::Table - provides a classdata table
52 object and method proxies
53
54 =head1 SYNOPSIS
55
56 __PACKAGE__->table('cd');
57 __PACKAGE__->add_columns(qw/cdid artist title year/);
58 __PACKAGE__->set_primary_key('cdid');
59
60 =head1 METHODS
61
62 =head2 add_columns
63
64 __PACKAGE__->add_columns(qw/cdid artist title year/);
65
66 Adds columns to the current class and creates accessors for them.
67
68 =cut
69
70 =head2 table
71
72 __PACKAGE__->table('tbl_name');
73
74 Gets or sets the table name.
75
76 =cut
77
78 sub table {
79 my ($class, $table) = @_;
80 return $class->result_source_instance->name unless $table;
81
82 unless (Scalar::Util::blessed($table) && $table->isa($class->table_class)) {
83
84 my $table_class = $class->table_class;
85 $class->ensure_class_loaded($table_class);
86
87 $table = $table_class->new({
88 $class->can('result_source_instance') ?
89 %{$class->result_source_instance||{}} : (),
90 name => $table,
91 result_class => $class,
92 source_name => undef,
93 });
94 }
95
96 $class->mk_classdata('result_source_instance')
97 unless $class->can('result_source_instance');
98
99 $class->result_source_instance($table);
100
101 return $class->result_source_instance->name;
102 }
103
104 =head2 has_column
105
106 if ($obj->has_column($col)) { ... }
107
108 Returns 1 if the class has a column of this name, 0 otherwise.
109
110 =cut
111
112 =head2 column_info
113
114 my $info = $obj->column_info($col);
115
116 Returns the column metadata hashref for a column. For a description of
117 the various types of column data in this hashref, see
118 L<DBIx::Class::ResultSource/add_column>
119
120 =cut
121
122 =head2 columns
123
124 my @column_names = $obj->columns;
125
126 =cut
127
128 1;
129
130 =head1 AUTHORS
131
132 Matt S. Trout <mst@shadowcatsystems.co.uk>
133
134 =head1 LICENSE
135
136 You may distribute this code under the same terms as Perl itself.
137
138 =cut
139
+6
-0
lib/DBIx/Class/ResultSourceProxy.pm less more
3636 my $source = $class->result_source_instance;
3737 $source->add_columns(@cols);
3838 foreach my $c (grep { !ref } @cols) {
39 # If this is an augment definition get the real colname.
40 $c =~ s/^\+//;
41
3942 $class->register_column($c => $source->column_info($c));
4043 }
4144 }
109112 shift->result_source_instance->relationship_info(@_);
110113 }
111114
115 sub has_relationship {
116 shift->result_source_instance->has_relationship(@_);
117 }
112118 1;
+124
-64
lib/DBIx/Class/Row.pm less more
104104
105105 sub __new_related_find_or_new_helper {
106106 my ($self, $relname, $data) = @_;
107 if ($self->__their_pk_needs_us($relname, $data)) {
107
108 # create a mock-object so all new/set_column component overrides will run:
109 my $rel_rs = $self->result_source
110 ->related_source($relname)
111 ->resultset;
112 my $new_rel_obj = $rel_rs->new_result($data);
113 my $proc_data = { $new_rel_obj->get_columns };
114
115 if ($self->__their_pk_needs_us($relname)) {
108116 MULTICREATE_DEBUG and warn "MC $self constructing $relname via new_result";
109 return $self->result_source
110 ->related_source($relname)
111 ->resultset
112 ->new_result($data);
113 }
114 if ($self->result_source->_pk_depends_on($relname, $data)) {
115 MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new";
116 return $self->result_source
117 ->related_source($relname)
118 ->resultset
119 ->find_or_new($data);
120 }
121 MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new_related";
122 return $self->find_or_new_related($relname, $data);
117 return $new_rel_obj;
118 }
119 elsif ($self->result_source->_pk_depends_on($relname, $proc_data )) {
120 if (! keys %$proc_data) {
121 # there is nothing to search for - blind create
122 MULTICREATE_DEBUG and warn "MC $self constructing default-insert $relname";
123 }
124 else {
125 MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new";
126 # this is not *really* find or new, as we don't want to double-new the
127 # data (thus potentially double encoding or whatever)
128 my $exists = $rel_rs->find ($proc_data);
129 return $exists if $exists;
130 }
131 return $new_rel_obj;
132 }
133 else {
134 my $us = $self->source_name;
135 $self->throw_exception ("'$us' neither depends nor is depended on by '$relname', something is wrong...");
136 }
123137 }
124138
125139 sub __their_pk_needs_us { # this should maybe be in resultsource.
126 my ($self, $relname, $data) = @_;
140 my ($self, $relname) = @_;
127141 my $source = $self->result_source;
128142 my $reverse = $source->reverse_relationship_info($relname);
129143 my $rel_source = $source->related_source($relname);
300314 MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
301315
302316 my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_inflated_columns };
303 my $re = $self->result_source
304 ->related_source($relname)
305 ->resultset
306 ->find_or_create($them);
307
308 %{$rel_obj} = %{$re};
317 my $existing;
318
319 # if there are no keys - nothing to search for
320 if (keys %$them and $existing = $self->result_source
321 ->related_source($relname)
322 ->resultset
323 ->find($them)
324 ) {
325 %{$rel_obj} = %{$existing};
326 }
327 else {
328 $rel_obj->insert;
329 }
330
309331 $self->{_rel_in_storage}{$relname} = 1;
310332 }
311333
319341 $rollback_guard ||= $source->storage->txn_scope_guard
320342 }
321343
344 ## PK::Auto
345 my %auto_pri;
346 my $auto_idx = 0;
347 for ($self->primary_columns) {
348 if (
349 not defined $self->get_column($_)
350 ||
351 (ref($self->get_column($_)) eq 'SCALAR')
352 ) {
353 my $col_info = $source->column_info($_);
354 $auto_pri{$_} = $auto_idx++ unless $col_info->{auto_nextval}; # auto_nextval's are pre-fetched in the storage
355 }
356 }
357
322358 MULTICREATE_DEBUG and do {
323359 no warnings 'uninitialized';
324360 warn "MC $self inserting (".join(', ', $self->get_columns).")\n";
325361 };
326 my $updated_cols = $source->storage->insert($source, { $self->get_columns });
362 my $updated_cols = $source->storage->insert(
363 $source,
364 { $self->get_columns },
365 (keys %auto_pri) && $source->storage->_supports_insert_returning
366 ? { returning => [ sort { $auto_pri{$a} <=> $auto_pri{$b} } keys %auto_pri ] }
367 : ()
368 ,
369 );
370
327371 foreach my $col (keys %$updated_cols) {
328372 $self->store_column($col, $updated_cols->{$col});
329 }
330
331 ## PK::Auto
332 my @auto_pri = grep {
333 (not defined $self->get_column($_))
334 ||
335 (ref($self->get_column($_)) eq 'SCALAR')
336 } $self->primary_columns;
337
338 if (@auto_pri) {
339 MULTICREATE_DEBUG and warn "MC $self fetching missing PKs ".join(', ', @auto_pri)."\n";
373 delete $auto_pri{$col};
374 }
375
376 if (keys %auto_pri) {
377 my @missing = sort { $auto_pri{$a} <=> $auto_pri{$b} } keys %auto_pri;
378 MULTICREATE_DEBUG and warn "MC $self fetching missing PKs ".join(', ', @missing )."\n";
340379 my $storage = $self->result_source->storage;
341380 $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
342381 unless $storage->can('last_insert_id');
343 my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
382 my @ids = $storage->last_insert_id($self->result_source, @missing);
344383 $self->throw_exception( "Can't get last insert id" )
345 unless (@ids == @auto_pri);
346 $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
347 }
348
384 unless (@ids == @missing);
385 $self->store_column($missing[$_] => $ids[$_]) for 0 .. $#missing;
386 }
349387
350388 $self->{_dirty_columns} = {};
351389 $self->{related_resultsets} = {};
366404 foreach my $obj (@cands) {
367405 $obj->set_from_related($_, $self) for keys %$reverse;
368406 my $them = { %{$obj->{_relationship_data} || {} }, $obj->get_inflated_columns };
369 if ($self->__their_pk_needs_us($relname, $them)) {
407 if ($self->__their_pk_needs_us($relname)) {
370408 if (exists $self->{_ignore_at_insert}{$relname}) {
371409 MULTICREATE_DEBUG and warn "MC $self skipping post-insert on $relname";
372410 } else {
439477 according to L</in_storage>.
440478
441479 This method issues an SQL UPDATE query to commit any changes to the
442 object to the database if required.
443
444 Also takes an optional hashref of C<< column_name => value> >> pairs
480 object to the database if required (see L</get_dirty_columns>).
481 It throws an exception if a proper WHERE clause uniquely identifying
482 the database row can not be constructed (see
483 L<significance of primary keys|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
484 for more details).
485
486 Also takes an optional hashref of C<< column_name => value >> pairs
445487 to update on the object first. Be aware that the hashref will be
446488 passed to C<set_inflated_columns>, which might edit it in place, so
447489 don't rely on it being the same after a call to C<update>. If you
476518 sub update {
477519 my ($self, $upd) = @_;
478520 $self->throw_exception( "Not in database" ) unless $self->in_storage;
479 my $ident_cond = $self->ident_condition;
480 $self->throw_exception("Cannot safely update a row in a PK-less table")
521
522 my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
523
524 $self->throw_exception('Unable to update a row with incomplete or no identity')
481525 if ! keys %$ident_cond;
482526
483527 $self->set_inflated_columns($upd) if $upd;
484528 my %to_update = $self->get_dirty_columns;
485529 return $self unless keys %to_update;
486530 my $rows = $self->result_source->storage->update(
487 $self->result_source, \%to_update,
488 $self->{_orig_ident} || $ident_cond
489 );
531 $self->result_source, \%to_update, $ident_cond
532 );
490533 if ($rows == 0) {
491534 $self->throw_exception( "Can't update ${self}: row not found" );
492535 } elsif ($rows > 1) {
494537 }
495538 $self->{_dirty_columns} = {};
496539 $self->{related_resultsets} = {};
497 undef $self->{_orig_ident};
540 delete $self->{_orig_ident};
498541 return $self;
499542 }
500543
511554 =back
512555
513556 Throws an exception if the object is not in the database according to
514 L</in_storage>. Runs an SQL DELETE statement using the primary key
515 values to locate the row.
557 L</in_storage>. Also throws an exception if a proper WHERE clause
558 uniquely identifying the database row can not be constructed (see
559 L<significance of primary keys|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
560 for more details).
516561
517562 The object is still perfectly usable, but L</in_storage> will
518563 now return 0 and the object must be reinserted using L</insert>
543588 my $self = shift;
544589 if (ref $self) {
545590 $self->throw_exception( "Not in database" ) unless $self->in_storage;
591
546592 my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
547 $self->throw_exception("Cannot safely delete a row in a PK-less table")
593 $self->throw_exception('Unable to delete a row with incomplete or no identity')
548594 if ! keys %$ident_cond;
549 foreach my $column (keys %$ident_cond) {
550 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
551 unless exists $self->{_column_data}{$column};
552 }
595
553596 $self->result_source->storage->delete(
554 $self->result_source, $ident_cond);
597 $self->result_source, $ident_cond
598 );
599
600 delete $self->{_orig_ident};
555601 $self->in_storage(undef);
556 } else {
602 }
603 else {
557604 $self->throw_exception("Can't do class delete without a ResultSource instance")
558605 unless $self->can('result_source_instance');
559606 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
811858 sub set_column {
812859 my ($self, $column, $new_value) = @_;
813860
814 $self->{_orig_ident} ||= $self->ident_condition;
861 # if we can't get an ident condition on first try - mark the object as unidentifiable
862 $self->{_orig_ident} ||= (eval { $self->ident_condition }) || {};
863
815864 my $old_value = $self->get_column($column);
816
817865 $new_value = $self->store_column($column, $new_value);
818866
819867 my $dirty;
12711319 =back
12721320
12731321 Fetches a fresh copy of the Row object from the database and returns it.
1274
1275 If passed the \%attrs argument, will first apply these attributes to
1322 Throws an exception if a proper WHERE clause identifying the database row
1323 can not be constructed (i.e. if the original object does not contain its
1324 entire
1325 L<primary key|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
1326 ). If passed the \%attrs argument, will first apply these attributes to
12761327 the resultset used to find the row.
12771328
12781329 This copy can then be used to compare to an existing row object, to
12961347 $resultset = $resultset->search(undef, $attrs);
12971348 }
12981349
1299 return $resultset->find($self->{_orig_ident} || $self->ident_condition);
1350 my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
1351
1352 $self->throw_exception('Unable to requery a row with incomplete or no identity')
1353 if ! keys %$ident_cond;
1354
1355 return $resultset->find($ident_cond);
13001356 }
13011357
13021358 =head2 discard_changes ($attrs)
13031359
13041360 Re-selects the row from the database, losing any changes that had
1305 been made.
1361 been made. Throws an exception if a proper WHERE clause identifying
1362 the database row can not be constructed (i.e. if the original object
1363 does not contain its entire
1364 L<primary key|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
1365 ).
13061366
13071367 This method can also be used to refresh from storage, retrieving any
13081368 changes made since the row was last read from storage.
+10
-0
lib/DBIx/Class/SQLAHacks/MySQL.pm less more
2020 return $self->SUPER::insert (@_);
2121 }
2222
23 # Allow STRAIGHT_JOIN's
24 sub _generate_join_clause {
25 my ($self, $join_type) = @_;
26
27 if( $join_type && $join_type =~ /^STRAIGHT\z/i ) {
28 return ' STRAIGHT_JOIN '
29 }
30
31 return $self->SUPER::_generate_join_clause( $join_type );
32 }
2333 1;
+17
-0
lib/DBIx/Class/SQLAHacks/SQLite.pm less more
0 package # Hide from PAUSE
1 DBIx::Class::SQLAHacks::SQLite;
2
3 use base qw( DBIx::Class::SQLAHacks );
4 use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
5
6 #
7 # SQLite does not understand SELECT ... FOR UPDATE
8 # Adjust SQL here instead
9 #
10 sub select {
11 my $self = shift;
12 local $self->{_dbic_rs_attrs}{for} = undef;
13 return $self->SUPER::select (@_);
14 }
15
16 1;
+34
-5
lib/DBIx/Class/SQLAHacks.pm less more
101101 );
102102 }
103103
104 # Firebird specific limit, reverse of _SkipFirst for Informix
105 sub _FirstSkip {
106 my ($self, $sql, $order, $rows, $offset) = @_;
107
108 $sql =~ s/^ \s* SELECT \s+ //ix
109 or croak "Unrecognizable SELECT: $sql";
110
111 return sprintf ('SELECT %s%s%s%s',
112 sprintf ('FIRST %d ', $rows),
113 $offset
114 ? sprintf ('SKIP %d ', $offset)
115 : ''
116 ,
117 $sql,
118 $self->_order_by ($order),
119 );
120 }
121
104122 # Crappy Top based Limit/Offset support. Legacy from MSSQL.
105123 sub _Top {
106124 my ( $self, $sql, $order, $rows, $offset ) = @_;
341359 # which is sadly understood only by MySQL. Change default behavior here,
342360 # until SQLA2 comes with proper dialect support
343361 if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
344 return "INSERT INTO ${table} DEFAULT VALUES"
362 my $sql = "INSERT INTO ${table} DEFAULT VALUES";
363
364 if (my $ret = ($_[1]||{})->{returning} ) {
365 $sql .= $self->_insert_returning ($ret);
366 }
367
368 return $sql;
345369 }
346370
347371 $self->SUPER::insert($table, @_);
484508 }
485509 }
486510
511 sub _generate_join_clause {
512 my ($self, $join_type) = @_;
513
514 return sprintf ('%s JOIN ',
515 $join_type ? ' ' . uc($join_type) : ''
516 );
517 }
518
487519 sub _recurse_from {
488520 my ($self, $from, @join) = @_;
489521 my @sqlf;
502534
503535 $join_type = $self->{_default_jointype} if not defined $join_type;
504536
505 my $join_clause = sprintf ('%s JOIN ',
506 $join_type ? ' ' . uc($join_type) : ''
507 );
508 push @sqlf, $join_clause;
537 push @sqlf, $self->_generate_join_clause( $join_type );
509538
510539 if (ref $to eq 'ARRAY') {
511540 push(@sqlf, '(', $self->_recurse_from(@$to), ')');
+6
-6
lib/DBIx/Class/Schema/Versioned.pm less more
708708 my @data = split /\n/, join '', <$fh>;
709709 close $fh;
710710
711 @data = grep {
712 $_ &&
713 !/^--/ &&
714 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
715 } split /;/,
716 join '', @data;
711 @data = split /;/,
712 join '',
713 grep { $_ &&
714 !/^--/ &&
715 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/mi }
716 @data;
717717
718718 return \@data;
719719 }
+6
-6
lib/DBIx/Class/Schema.pm less more
668668
669669 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
670670 calling $schema->storage->txn_begin. See
671 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
671 L<DBIx::Class::Storage/"txn_begin"> for more information.
672672
673673 =cut
674674
684684 =head2 txn_commit
685685
686686 Commits the current transaction. Equivalent to calling
687 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
687 $schema->storage->txn_commit. See L<DBIx::Class::Storage/"txn_commit">
688688 for more information.
689689
690690 =cut
702702
703703 Rolls back the current transaction. Equivalent to calling
704704 $schema->storage->txn_rollback. See
705 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
705 L<DBIx::Class::Storage/"txn_rollback"> for more information.
706706
707707 =cut
708708
926926
927927 Creates a new savepoint (does nothing outside a transaction).
928928 Equivalent to calling $schema->storage->svp_begin. See
929 L<DBIx::Class::Storage::DBI/"svp_begin"> for more information.
929 L<DBIx::Class::Storage/"svp_begin"> for more information.
930930
931931 =cut
932932
943943
944944 Releases a savepoint (does nothing outside a transaction).
945945 Equivalent to calling $schema->storage->svp_release. See
946 L<DBIx::Class::Storage::DBI/"svp_release"> for more information.
946 L<DBIx::Class::Storage/"svp_release"> for more information.
947947
948948 =cut
949949
960960
961961 Rollback to a savepoint (does nothing outside a transaction).
962962 Equivalent to calling $schema->storage->svp_rollback. See
963 L<DBIx::Class::Storage::DBI/"svp_rollback"> for more information.
963 L<DBIx::Class::Storage/"svp_rollback"> for more information.
964964
965965 =cut
966966
+78
-78
lib/DBIx/Class/Serialize/Storable.pm less more
0 package DBIx::Class::Serialize::Storable;
1 use strict;
2 use warnings;
3 use Storable;
4
5 sub STORABLE_freeze {
6 my ($self, $cloning) = @_;
7 my $to_serialize = { %$self };
8
9 # The source is either derived from _source_handle or is
10 # reattached in the thaw handler below
11 delete $to_serialize->{result_source};
12
13 # Dynamic values, easy to recalculate
14 delete $to_serialize->{$_} for qw/related_resultsets _inflated_column/;
15
16 return (Storable::freeze($to_serialize));
17 }
18
19 sub STORABLE_thaw {
20 my ($self, $cloning, $serialized) = @_;
21
22 %$self = %{ Storable::thaw($serialized) };
23
24 # if the handle went missing somehow, reattach
25 $self->result_source($self->result_source_instance)
26 if !$self->_source_handle && $self->can('result_source_instance');
27 }
28
29 1;
30
31 __END__
32
33 =head1 NAME
34
35 DBIx::Class::Serialize::Storable - hooks for Storable freeze/thaw
36
37 =head1 SYNOPSIS
38
39 # in a table class definition
40 __PACKAGE__->load_components(qw/Serialize::Storable/);
41
42 # meanwhile, in a nearby piece of code
43 my $cd = $schema->resultset('CD')->find(12);
44 # if the cache uses Storable, this will work automatically
45 $cache->set($cd->ID, $cd);
46
47 =head1 DESCRIPTION
48
49 This component adds hooks for Storable so that row objects can be
50 serialized. It assumes that your row object class (C<result_class>) is
51 the same as your table class, which is the normal situation.
52
53 =head1 HOOKS
54
55 The following hooks are defined for L<Storable> - see the
56 documentation for L<Storable/Hooks> for detailed information on these
57 hooks.
58
59 =head2 STORABLE_freeze
60
61 The serializing hook, called on the object during serialization. It
62 can be inherited, or defined in the class itself, like any other
63 method.
64
65 =head2 STORABLE_thaw
66
67 The deserializing hook called on the object during deserialization.
68
69 =head1 AUTHORS
70
71 David Kamholz <dkamholz@cpan.org>
72
73 =head1 LICENSE
74
75 You may distribute this code under the same terms as Perl itself.
76
77 =cut
0 package DBIx::Class::Serialize::Storable;
1 use strict;
2 use warnings;
3 use Storable;
4
5 sub STORABLE_freeze {
6 my ($self, $cloning) = @_;
7 my $to_serialize = { %$self };
8
9 # The source is either derived from _source_handle or is
10 # reattached in the thaw handler below
11 delete $to_serialize->{result_source};
12
13 # Dynamic values, easy to recalculate
14 delete $to_serialize->{$_} for qw/related_resultsets _inflated_column/;
15
16 return (Storable::freeze($to_serialize));
17 }
18
19 sub STORABLE_thaw {
20 my ($self, $cloning, $serialized) = @_;
21
22 %$self = %{ Storable::thaw($serialized) };
23
24 # if the handle went missing somehow, reattach
25 $self->result_source($self->result_source_instance)
26 if !$self->_source_handle && $self->can('result_source_instance');
27 }
28
29 1;
30
31 __END__
32
33 =head1 NAME
34
35 DBIx::Class::Serialize::Storable - hooks for Storable freeze/thaw
36
37 =head1 SYNOPSIS
38
39 # in a table class definition
40 __PACKAGE__->load_components(qw/Serialize::Storable/);
41
42 # meanwhile, in a nearby piece of code
43 my $cd = $schema->resultset('CD')->find(12);
44 # if the cache uses Storable, this will work automatically
45 $cache->set($cd->ID, $cd);
46
47 =head1 DESCRIPTION
48
49 This component adds hooks for Storable so that row objects can be
50 serialized. It assumes that your row object class (C<result_class>) is
51 the same as your table class, which is the normal situation.
52
53 =head1 HOOKS
54
55 The following hooks are defined for L<Storable> - see the
56 documentation for L<Storable/Hooks> for detailed information on these
57 hooks.
58
59 =head2 STORABLE_freeze
60
61 The serializing hook, called on the object during serialization. It
62 can be inherited, or defined in the class itself, like any other
63 method.
64
65 =head2 STORABLE_thaw
66
67 The deserializing hook called on the object during deserialization.
68
69 =head1 AUTHORS
70
71 David Kamholz <dkamholz@cpan.org>
72
73 =head1 LICENSE
74
75 You may distribute this code under the same terms as Perl itself.
76
77 =cut
+3
-2
lib/DBIx/Class/Storage/DBI/AutoCast.pm less more
2828
2929 CAST(? as $mapped_type)
3030
31 This option can also be enabled in L<DBIx::Class::Storage::DBI/connect_info> as:
31 This option can also be enabled in
32 L<connect_info|DBIx::Class::Storage::DBI/connect_info> as:
3233
3334 on_connect_call => ['set_auto_cast']
3435
7576
7677 on_connect_call => ['set_auto_cast']
7778
78 in L<DBIx::Class::Storage::DBI/connect_info>.
79 in L<connect_info|DBIx::Class::Storage::DBI/connect_info>.
7980
8081 =cut
8182
+183
-183
lib/DBIx/Class/Storage/DBI/Cursor.pm less more
0 package DBIx::Class::Storage::DBI::Cursor;
1
2 use strict;
3 use warnings;
4
5 use base qw/DBIx::Class::Cursor/;
6
7 __PACKAGE__->mk_group_accessors('simple' =>
8 qw/sth/
9 );
10
11 =head1 NAME
12
13 DBIx::Class::Storage::DBI::Cursor - Object representing a query cursor on a
14 resultset.
15
16 =head1 SYNOPSIS
17
18 my $cursor = $schema->resultset('CD')->cursor();
19 my $first_cd = $cursor->next;
20
21 =head1 DESCRIPTION
22
23 A Cursor represents a query cursor on a L<DBIx::Class::ResultSet> object. It
24 allows for traversing the result set with L</next>, retrieving all results with
25 L</all> and resetting the cursor with L</reset>.
26
27 Usually, you would use the cursor methods built into L<DBIx::Class::ResultSet>
28 to traverse it. See L<DBIx::Class::ResultSet/next>,
29 L<DBIx::Class::ResultSet/reset> and L<DBIx::Class::ResultSet/all> for more
30 information.
31
32 =head1 METHODS
33
34 =head2 new
35
36 Returns a new L<DBIx::Class::Storage::DBI::Cursor> object.
37
38 =cut
39
40 sub new {
41 my ($class, $storage, $args, $attrs) = @_;
42 $class = ref $class if ref $class;
43
44 my $new = {
45 storage => $storage,
46 args => $args,
47 pos => 0,
48 attrs => $attrs,
49 _dbh_gen => $storage->{_dbh_gen},
50 };
51
52 return bless ($new, $class);
53 }
54
55 =head2 next
56
57 =over 4
58
59 =item Arguments: none
60
61 =item Return Value: \@row_columns
62
63 =back
64
65 Advances the cursor to the next row and returns an array of column
66 values (the result of L<DBI/fetchrow_array> method).
67
68 =cut
69
70 sub _dbh_next {
71 my ($storage, $dbh, $self) = @_;
72
73 $self->_check_dbh_gen;
74 if (
75 $self->{attrs}{software_limit}
76 && $self->{attrs}{rows}
77 && $self->{pos} >= $self->{attrs}{rows}
78 ) {
79 $self->sth->finish if $self->sth->{Active};
80 $self->sth(undef);
81 $self->{done} = 1;
82 }
83 return if $self->{done};
84 unless ($self->sth) {
85 $self->sth(($storage->_select(@{$self->{args}}))[1]);
86 if ($self->{attrs}{software_limit}) {
87 if (my $offset = $self->{attrs}{offset}) {
88 $self->sth->fetch for 1 .. $offset;
89 }
90 }
91 }
92 my @row = $self->sth->fetchrow_array;
93 if (@row) {
94 $self->{pos}++;
95 } else {
96 $self->sth(undef);
97 $self->{done} = 1;
98 }
99 return @row;
100 }
101
102 sub next {
103 my ($self) = @_;
104 $self->{storage}->dbh_do($self->can('_dbh_next'), $self);
105 }
106
107 =head2 all
108
109 =over 4
110
111 =item Arguments: none
112
113 =item Return Value: \@row_columns+
114
115 =back
116
117 Returns a list of arrayrefs of column values for all rows in the
118 L<DBIx::Class::ResultSet>.
119
120 =cut
121
122 sub _dbh_all {
123 my ($storage, $dbh, $self) = @_;
124
125 $self->_check_dbh_gen;
126 $self->sth->finish if $self->sth && $self->sth->{Active};
127 $self->sth(undef);
128 my ($rv, $sth) = $storage->_select(@{$self->{args}});
129 return @{$sth->fetchall_arrayref};
130 }
131
132 sub all {
133 my ($self) = @_;
134 if ($self->{attrs}{software_limit}
135 && ($self->{attrs}{offset} || $self->{attrs}{rows})) {
136 return $self->next::method;
137 }
138
139 $self->{storage}->dbh_do($self->can('_dbh_all'), $self);
140 }
141
142 =head2 reset
143
144 Resets the cursor to the beginning of the L<DBIx::Class::ResultSet>.
145
146 =cut
147
148 sub reset {
149 my ($self) = @_;
150
151 # No need to care about failures here
152 eval { $self->sth->finish if $self->sth && $self->sth->{Active} };
153 $self->_soft_reset;
154 return undef;
155 }
156
157 sub _soft_reset {
158 my ($self) = @_;
159
160 $self->sth(undef);
161 delete $self->{done};
162 $self->{pos} = 0;
163 }
164
165 sub _check_dbh_gen {
166 my ($self) = @_;
167
168 if($self->{_dbh_gen} != $self->{storage}->{_dbh_gen}) {
169 $self->{_dbh_gen} = $self->{storage}->{_dbh_gen};
170 $self->_soft_reset;
171 }
172 }
173
174 sub DESTROY {
175 my ($self) = @_;
176
177 # None of the reasons this would die matter if we're in DESTROY anyways
178 local $@;
179 eval { $self->sth->finish if $self->sth && $self->sth->{Active} };
180 }
181
182 1;
0 package DBIx::Class::Storage::DBI::Cursor;
1
2 use strict;
3 use warnings;
4
5 use base qw/DBIx::Class::Cursor/;
6
7 __PACKAGE__->mk_group_accessors('simple' =>
8 qw/sth/
9 );
10
11 =head1 NAME
12
13 DBIx::Class::Storage::DBI::Cursor - Object representing a query cursor on a
14 resultset.
15
16 =head1 SYNOPSIS
17
18 my $cursor = $schema->resultset('CD')->cursor();
19 my $first_cd = $cursor->next;
20
21 =head1 DESCRIPTION
22
23 A Cursor represents a query cursor on a L<DBIx::Class::ResultSet> object. It
24 allows for traversing the result set with L</next>, retrieving all results with
25 L</all> and resetting the cursor with L</reset>.
26
27 Usually, you would use the cursor methods built into L<DBIx::Class::ResultSet>
28 to traverse it. See L<DBIx::Class::ResultSet/next>,
29 L<DBIx::Class::ResultSet/reset> and L<DBIx::Class::ResultSet/all> for more
30 information.
31
32 =head1 METHODS
33
34 =head2 new
35
36 Returns a new L<DBIx::Class::Storage::DBI::Cursor> object.
37
38 =cut
39
40 sub new {
41 my ($class, $storage, $args, $attrs) = @_;
42 $class = ref $class if ref $class;
43
44 my $new = {
45 storage => $storage,
46 args => $args,
47 pos => 0,
48 attrs => $attrs,
49 _dbh_gen => $storage->{_dbh_gen},
50 };
51
52 return bless ($new, $class);
53 }
54
55 =head2 next
56
57 =over 4
58
59 =item Arguments: none
60
61 =item Return Value: \@row_columns
62
63 =back
64
65 Advances the cursor to the next row and returns an array of column
66 values (the result of L<DBI/fetchrow_array> method).
67
68 =cut
69
70 sub _dbh_next {
71 my ($storage, $dbh, $self) = @_;
72
73 $self->_check_dbh_gen;
74 if (
75 $self->{attrs}{software_limit}
76 && $self->{attrs}{rows}
77 && $self->{pos} >= $self->{attrs}{rows}
78 ) {
79 $self->sth->finish if $self->sth->{Active};
80 $self->sth(undef);
81 $self->{done} = 1;
82 }
83 return if $self->{done};
84 unless ($self->sth) {
85 $self->sth(($storage->_select(@{$self->{args}}))[1]);
86 if ($self->{attrs}{software_limit}) {
87 if (my $offset = $self->{attrs}{offset}) {
88 $self->sth->fetch for 1 .. $offset;
89 }
90 }
91 }
92 my @row = $self->sth->fetchrow_array;
93 if (@row) {
94 $self->{pos}++;
95 } else {
96 $self->sth(undef);
97 $self->{done} = 1;
98 }
99 return @row;
100 }
101
102 sub next {
103 my ($self) = @_;
104 $self->{storage}->dbh_do($self->can('_dbh_next'), $self);
105 }
106
107 =head2 all
108
109 =over 4
110
111 =item Arguments: none
112
113 =item Return Value: \@row_columns+
114
115 =back
116
117 Returns a list of arrayrefs of column values for all rows in the
118 L<DBIx::Class::ResultSet>.
119
120 =cut
121
122 sub _dbh_all {
123 my ($storage, $dbh, $self) = @_;
124
125 $self->_check_dbh_gen;
126 $self->sth->finish if $self->sth && $self->sth->{Active};
127 $self->sth(undef);
128 my ($rv, $sth) = $storage->_select(@{$self->{args}});
129 return @{$sth->fetchall_arrayref};
130 }
131
132 sub all {
133 my ($self) = @_;
134 if ($self->{attrs}{software_limit}
135 && ($self->{attrs}{offset} || $self->{attrs}{rows})) {
136 return $self->next::method;
137 }
138
139 $self->{storage}->dbh_do($self->can('_dbh_all'), $self);
140 }
141
142 =head2 reset
143
144 Resets the cursor to the beginning of the L<DBIx::Class::ResultSet>.
145
146 =cut
147
148 sub reset {
149 my ($self) = @_;
150
151 # No need to care about failures here
152 eval { $self->sth->finish if $self->sth && $self->sth->{Active} };
153 $self->_soft_reset;
154 return undef;
155 }
156
157 sub _soft_reset {
158 my ($self) = @_;
159
160 $self->sth(undef);
161 delete $self->{done};
162 $self->{pos} = 0;
163 }
164
165 sub _check_dbh_gen {
166 my ($self) = @_;
167
168 if($self->{_dbh_gen} != $self->{storage}->{_dbh_gen}) {
169 $self->{_dbh_gen} = $self->{storage}->{_dbh_gen};
170 $self->_soft_reset;
171 }
172 }
173
174 sub DESTROY {
175 my ($self) = @_;
176
177 # None of the reasons this would die matter if we're in DESTROY anyways
178 local $@;
179 eval { $self->sth->finish if $self->sth && $self->sth->{Active} };
180 }
181
182 1;
+147
-15
lib/DBIx/Class/Storage/DBI/Informix.pm less more
22 use warnings;
33
44 use base qw/DBIx::Class::Storage::DBI/;
5
65 use mro 'c3';
76
7 use Scope::Guard ();
8 use Context::Preserve ();
9
810 __PACKAGE__->mk_group_accessors('simple' => '__last_insert_id');
11
12 =head1 NAME
13
14 DBIx::Class::Storage::DBI::Informix - Base Storage Class for Informix Support
15
16 =head1 DESCRIPTION
17
18 This class implements storage-specific support for the Informix RDBMS
19
20 =head1 METHODS
21
22 =cut
923
1024 sub _execute {
1125 my $self = shift;
3145 return { limit_dialect => 'SkipFirst', %{$self->{_sql_maker_opts}||{}} };
3246 }
3347
48 sub _svp_begin {
49 my ($self, $name) = @_;
50
51 $self->_get_dbh->do("SAVEPOINT $name");
52 }
53
54 # can't release savepoints
55 sub _svp_release { 1 }
56
57 sub _svp_rollback {
58 my ($self, $name) = @_;
59
60 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
61 }
62
63 sub with_deferred_fk_checks {
64 my ($self, $sub) = @_;
65
66 my $txn_scope_guard = $self->txn_scope_guard;
67
68 $self->_do_query('SET CONSTRAINTS ALL DEFERRED');
69
70 my $sg = Scope::Guard->new(sub {
71 $self->_do_query('SET CONSTRAINTS ALL IMMEDIATE');
72 });
73
74 return Context::Preserve::preserve_context(sub { $sub->() },
75 after => sub { $txn_scope_guard->commit });
76 }
77
78 =head2 connect_call_datetime_setup
79
80 Used as:
81
82 on_connect_call => 'datetime_setup'
83
84 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the C<DATE> and
85 C<DATETIME> formats.
86
87 Sets the following environment variables:
88
89 GL_DATE="%m/%d/%Y"
90 GL_DATETIME="%Y-%m-%d %H:%M:%S%F5"
91
92 The C<DBDATE> and C<DBCENTURY> environment variables are cleared.
93
94 B<NOTE:> setting the C<GL_DATE> environment variable seems to have no effect
95 after the process has started, so the default format is used. The C<GL_DATETIME>
96 setting does take effect however.
97
98 The C<DATETIME> data type supports up to 5 digits after the decimal point for
99 second precision, depending on how you have declared your column. The full
100 possible precision is used.
101
102 The column declaration for a C<DATETIME> with maximum precision is:
103
104 column_name DATETIME YEAR TO FRACTION(5)
105
106 The C<DATE> data type stores the date portion only, and it B<MUST> be declared
107 with:
108
109 data_type => 'date'
110
111 in your Result class.
112
113 You will need the L<DateTime::Format::Strptime> module for inflation to work.
114
115 =cut
116
117 sub connect_call_datetime_setup {
118 my $self = shift;
119
120 delete @ENV{qw/DBDATE DBCENTURY/};
121
122 $ENV{GL_DATE} = "%m/%d/%Y";
123 $ENV{GL_DATETIME} = "%Y-%m-%d %H:%M:%S%F5";
124 }
125
126 sub datetime_parser_type {
127 'DBIx::Class::Storage::DBI::Informix::DateTime::Format'
128 }
129
130 package # hide from PAUSE
131 DBIx::Class::Storage::DBI::Informix::DateTime::Format;
132
133 my $timestamp_format = '%Y-%m-%d %H:%M:%S.%5N'; # %F %T
134 my $date_format = '%m/%d/%Y';
135
136 my ($timestamp_parser, $date_parser);
137
138 sub parse_datetime {
139 shift;
140 require DateTime::Format::Strptime;
141 $timestamp_parser ||= DateTime::Format::Strptime->new(
142 pattern => $timestamp_format,
143 on_error => 'croak',
144 );
145 return $timestamp_parser->parse_datetime(shift);
146 }
147
148 sub format_datetime {
149 shift;
150 require DateTime::Format::Strptime;
151 $timestamp_parser ||= DateTime::Format::Strptime->new(
152 pattern => $timestamp_format,
153 on_error => 'croak',
154 );
155 return $timestamp_parser->format_datetime(shift);
156 }
157
158 sub parse_date {
159 shift;
160 require DateTime::Format::Strptime;
161 $date_parser ||= DateTime::Format::Strptime->new(
162 pattern => $date_format,
163 on_error => 'croak',
164 );
165 return $date_parser->parse_datetime(shift);
166 }
167
168 sub format_date {
169 shift;
170 require DateTime::Format::Strptime;
171 $date_parser ||= DateTime::Format::Strptime->new(
172 pattern => $date_format,
173 on_error => 'croak',
174 );
175 return $date_parser->format_datetime(shift);
176 }
177
34178 1;
35179
36 __END__
180 =head1 AUTHOR
37181
38 =head1 NAME
39
40 DBIx::Class::Storage::DBI::Informix - Base Storage Class for INFORMIX Support
41
42 =head1 SYNOPSIS
43
44 =head1 DESCRIPTION
45
46 This class implements storage-specific support for Informix
47
48 =head1 AUTHORS
49
50 See L<DBIx::Class/CONTRIBUTORS>
182 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
51183
52184 =head1 LICENSE
53185
+320
-0
lib/DBIx/Class/Storage/DBI/InterBase.pm less more
0 package DBIx::Class::Storage::DBI::InterBase;
1
2 use strict;
3 use warnings;
4 use base qw/DBIx::Class::Storage::DBI/;
5 use mro 'c3';
6 use List::Util();
7
8 =head1 NAME
9
10 DBIx::Class::Storage::DBI::InterBase - Driver for the Firebird RDBMS
11
12 =head1 DESCRIPTION
13
14 This class implements autoincrements for Firebird using C<RETURNING> as well as
15 L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> sets the limit dialect to
16 C<FIRST X SKIP X> and provides L<DBIx::Class::InflateColumn::DateTime> support.
17
18 You need to use either the
19 L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching> option or
20 L</connect_call_use_softcommit> (see L</CAVEATS>) for your code to function
21 correctly with this driver. Otherwise you will likely get bizarre error messages
22 such as C<no statement executing>. The alternative is to use the
23 L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver, which is more suitable
24 for long running processes such as under L<Catalyst>.
25
26 To turn on L<DBIx::Class::InflateColumn::DateTime> support, see
27 L</connect_call_datetime_setup>.
28
29 =cut
30
31 sub _supports_insert_returning { 1 }
32
33 sub _sequence_fetch {
34 my ($self, $nextval, $sequence) = @_;
35
36 if ($nextval ne 'nextval') {
37 $self->throw_exception("Can only fetch 'nextval' for a sequence");
38 }
39
40 $self->throw_exception('No sequence to fetch') unless $sequence;
41
42 my ($val) = $self->_get_dbh->selectrow_array(
43 'SELECT GEN_ID(' . $self->sql_maker->_quote($sequence) .
44 ', 1) FROM rdb$database');
45
46 return $val;
47 }
48
49 sub _dbh_get_autoinc_seq {
50 my ($self, $dbh, $source, $col) = @_;
51
52 my $table_name = $source->from;
53 $table_name = $$table_name if ref $table_name;
54 $table_name = $self->sql_maker->quote_char ? $table_name : uc($table_name);
55
56 local $dbh->{LongReadLen} = 100000;
57 local $dbh->{LongTruncOk} = 1;
58
59 my $sth = $dbh->prepare(<<'EOF');
60 SELECT t.rdb$trigger_source
61 FROM rdb$triggers t
62 WHERE t.rdb$relation_name = ?
63 AND t.rdb$system_flag = 0 -- user defined
64 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
65 EOF
66 $sth->execute($table_name);
67
68 while (my ($trigger) = $sth->fetchrow_array) {
69 my @trig_cols = map {
70 /^"([^"]+)/ ? $1 : uc($1)
71 } $trigger =~ /new\.("?\w+"?)/ig;
72
73 my ($quoted, $generator) = $trigger =~
74 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
75
76 if ($generator) {
77 $generator = uc $generator unless $quoted;
78
79 return $generator
80 if List::Util::first {
81 $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
82 } @trig_cols;
83 }
84 }
85
86 return undef;
87 }
88
89 # this sub stolen from DB2
90
91 sub _sql_maker_opts {
92 my ( $self, $opts ) = @_;
93
94 if ( $opts ) {
95 $self->{_sql_maker_opts} = { %$opts };
96 }
97
98 return { limit_dialect => 'FirstSkip', %{$self->{_sql_maker_opts}||{}} };
99 }
100
101 sub _svp_begin {
102 my ($self, $name) = @_;
103
104 $self->_get_dbh->do("SAVEPOINT $name");
105 }
106
107 sub _svp_release {
108 my ($self, $name) = @_;
109
110 $self->_get_dbh->do("RELEASE SAVEPOINT $name");
111 }
112
113 sub _svp_rollback {
114 my ($self, $name) = @_;
115
116 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
117 }
118
119 sub _ping {
120 my $self = shift;
121
122 my $dbh = $self->_dbh or return 0;
123
124 local $dbh->{RaiseError} = 1;
125 local $dbh->{PrintError} = 0;
126
127 eval {
128 $dbh->do('select 1 from rdb$database');
129 };
130
131 return $@ ? 0 : 1;
132 }
133
134 # We want dialect 3 for new features and quoting to work, DBD::InterBase uses
135 # dialect 1 (interbase compat) by default.
136 sub _init {
137 my $self = shift;
138 $self->_set_sql_dialect(3);
139 }
140
141 sub _set_sql_dialect {
142 my $self = shift;
143 my $val = shift || 3;
144
145 my $dsn = $self->_dbi_connect_info->[0];
146
147 return if ref($dsn) eq 'CODE';
148
149 if ($dsn !~ /ib_dialect=/) {
150 $self->_dbi_connect_info->[0] = "$dsn;ib_dialect=$val";
151 my $connected = defined $self->_dbh;
152 $self->disconnect;
153 $self->ensure_connected if $connected;
154 }
155 }
156
157 sub _get_server_version {
158 my $self = shift;
159
160 return $self->next::method(@_) if ref $self ne __PACKAGE__;
161
162 local $SIG{__WARN__} = sub {}; # silence warning due to bug in DBD::InterBase
163
164 return $self->next::method(@_);
165 }
166
167 =head2 connect_call_use_softcommit
168
169 Used as:
170
171 on_connect_call => 'use_softcommit'
172
173 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the
174 L<DBD::InterBase> C<ib_softcommit> option.
175
176 You need either this option or C<< disable_sth_caching => 1 >> for
177 L<DBIx::Class> code to function correctly (otherwise you may get C<no statement
178 executing> errors.) Or use the L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird>
179 driver.
180
181 The downside of using this option is that your process will B<NOT> see UPDATEs,
182 INSERTs and DELETEs from other processes for already open statements.
183
184 =cut
185
186 sub connect_call_use_softcommit {
187 my $self = shift;
188
189 $self->_dbh->{ib_softcommit} = 1;
190 }
191
192 =head2 connect_call_datetime_setup
193
194 Used as:
195
196 on_connect_call => 'datetime_setup'
197
198 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the date and
199 timestamp formats using:
200
201 $dbh->{ib_time_all} = 'ISO';
202
203 See L<DBD::InterBase> for more details.
204
205 The C<TIMESTAMP> data type supports up to 4 digits after the decimal point for
206 second precision. The full precision is used.
207
208 The C<DATE> data type stores the date portion only, and it B<MUST> be declared
209 with:
210
211 data_type => 'date'
212
213 in your Result class.
214
215 Timestamp columns can be declared with either C<datetime> or C<timestamp>.
216
217 You will need the L<DateTime::Format::Strptime> module for inflation to work.
218
219 For L<DBIx::Class::Storage::DBI::ODBC::Firebird>, this is a noop and sub-second
220 precision is not currently available.
221
222 =cut
223
224 sub connect_call_datetime_setup {
225 my $self = shift;
226
227 $self->_get_dbh->{ib_time_all} = 'ISO';
228 }
229
230 sub datetime_parser_type {
231 'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
232 }
233
234 package # hide from PAUSE
235 DBIx::Class::Storage::DBI::InterBase::DateTime::Format;
236
237 my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T
238 my $date_format = '%Y-%m-%d';
239
240 my ($timestamp_parser, $date_parser);
241
242 sub parse_datetime {
243 shift;
244 require DateTime::Format::Strptime;
245 $timestamp_parser ||= DateTime::Format::Strptime->new(
246 pattern => $timestamp_format,
247 on_error => 'croak',
248 );
249 return $timestamp_parser->parse_datetime(shift);
250 }
251
252 sub format_datetime {
253 shift;
254 require DateTime::Format::Strptime;
255 $timestamp_parser ||= DateTime::Format::Strptime->new(
256 pattern => $timestamp_format,
257 on_error => 'croak',
258 );
259 return $timestamp_parser->format_datetime(shift);
260 }
261
262 sub parse_date {
263 shift;
264 require DateTime::Format::Strptime;
265 $date_parser ||= DateTime::Format::Strptime->new(
266 pattern => $date_format,
267 on_error => 'croak',
268 );
269 return $date_parser->parse_datetime(shift);
270 }
271
272 sub format_date {
273 shift;
274 require DateTime::Format::Strptime;
275 $date_parser ||= DateTime::Format::Strptime->new(
276 pattern => $date_format,
277 on_error => 'croak',
278 );
279 return $date_parser->format_datetime(shift);
280 }
281
282 1;
283
284 =head1 CAVEATS
285
286 =over 4
287
288 =item *
289
290 with L</connect_call_use_softcommit>, you will not be able to see changes made
291 to data in other processes. If this is an issue, use
292 L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching> as a
293 workaround for the C<no statement executing> errors, this of course adversely
294 affects performance.
295
296 Alternately, use the L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver.
297
298 =item *
299
300 C<last_insert_id> support by default only works for Firebird versions 2 or
301 greater, L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> however should
302 work with earlier versions.
303
304 =item *
305
306 Sub-second precision for TIMESTAMPs is not currently available when using the
307 L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver.
308
309 =back
310
311 =head1 AUTHOR
312
313 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
314
315 =head1 LICENSE
316
317 You may distribute this code under the same terms as Perl itself.
318
319 =cut
+20
-48
lib/DBIx/Class/Storage/DBI/MSSQL.pm less more
22 use strict;
33 use warnings;
44
5 use base qw/DBIx::Class::Storage::DBI/;
5 use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/;
66 use mro 'c3';
77
88 use List::Util();
6565 }
6666 }
6767
68 # support MSSQL GUID column types
69
7068 sub insert {
7169 my $self = shift;
7270 my ($source, $to_insert) = @_;
7371
7472 my $supplied_col_info = $self->_resolve_column_info($source, [keys %$to_insert] );
75
76 my %guid_cols;
77 my @pk_cols = $source->primary_columns;
78 my %pk_cols;
79 @pk_cols{@pk_cols} = ();
80
81 my @pk_guids = grep {
82 $source->column_info($_)->{data_type}
83 &&
84 $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
85 } @pk_cols;
86
87 my @auto_guids = grep {
88 $source->column_info($_)->{data_type}
89 &&
90 $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
91 &&
92 $source->column_info($_)->{auto_nextval}
93 } grep { not exists $pk_cols{$_} } $source->columns;
94
95 my @get_guids_for =
96 grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
97
98 my $updated_cols = {};
99
100 for my $guid_col (@get_guids_for) {
101 my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT NEWID()');
102 $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
103 }
10473
10574 my $is_identity_insert = (List::Util::first { $_->{is_auto_increment} } (values %$supplied_col_info) )
10675 ? 1
11079 $self->_set_identity_insert ($source->name);
11180 }
11281
113 $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } };
82 my $updated_cols = $self->next::method(@_);
11483
11584 if ($is_identity_insert) {
11685 $self->_unset_identity_insert ($source->name);
11786 }
118
11987
12088 return $updated_cols;
12189 }
231199
232200 sub sqlt_type { 'SQLServer' }
233201
234 sub _get_mssql_version {
235 my $self = shift;
236
237 my $data = $self->_get_dbh->selectrow_hashref('xp_msver ProductVersion');
238
239 if ($data->{Character_Value} =~ /^(\d+)\./) {
240 return $1;
241 } else {
242 $self->throw_exception(q{Your ProductVersion's Character_Value is missing or malformed!});
243 }
244 }
245
246202 sub sql_maker {
247203 my $self = shift;
248204
249205 unless ($self->_sql_maker) {
250206 unless ($self->{_sql_maker_opts}{limit_dialect}) {
251 my $version = eval { $self->_get_mssql_version; } || 0;
207
208 my $version = $self->_server_info->{normalized_dbms_version} || 0;
252209
253210 $self->{_sql_maker_opts} = {
254211 limit_dialect => ($version >= 9 ? 'RowNumberOver' : 'Top'),
260217 }
261218
262219 return $self->_sql_maker;
220 }
221
222 sub _ping {
223 my $self = shift;
224
225 my $dbh = $self->_dbh or return 0;
226
227 local $dbh->{RaiseError} = 1;
228 local $dbh->{PrintError} = 0;
229
230 eval {
231 $dbh->do('select 1');
232 };
233
234 return $@ ? 0 : 1;
263235 }
264236
265237 1;
357329
358330 =head1 AUTHOR
359331
360 See L<DBIx::Class/CONTRIBUTORS>.
332 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
361333
362334 =head1 LICENSE
363335
+120
-120
lib/DBIx/Class/Storage/DBI/NoBindVars.pm less more
0 package DBIx::Class::Storage::DBI::NoBindVars;
1
2 use strict;
3 use warnings;
4
5 use base 'DBIx::Class::Storage::DBI';
6 use mro 'c3';
7
8 =head1 NAME
9
10 DBIx::Class::Storage::DBI::NoBindVars - Sometime DBDs have poor to no support for bind variables
11
12 =head1 DESCRIPTION
13
14 This class allows queries to work when the DBD or underlying library does not
15 support the usual C<?> placeholders, or at least doesn't support them very
16 well, as is the case with L<DBD::Sybase>
17
18 =head1 METHODS
19
20 =head2 connect_info
21
22 We can't cache very effectively without bind variables, so force the C<disable_sth_caching> setting to be turned on when the connect info is set.
23
24 =cut
25
26 sub connect_info {
27 my $self = shift;
28 my $retval = $self->next::method(@_);
29 $self->disable_sth_caching(1);
30 $retval;
31 }
32
33 =head2 _prep_for_execute
34
35 Manually subs in the values for the usual C<?> placeholders.
36
37 =cut
38
39 sub _prep_for_execute {
40 my $self = shift;
41
42 my ($sql, $bind) = $self->next::method(@_);
43
44 # stringify bind args, quote via $dbh, and manually insert
45 #my ($op, $extra_bind, $ident, $args) = @_;
46 my $ident = $_[2];
47
48 my @sql_part = split /\?/, $sql;
49 my $new_sql;
50
51 my $col_info = $self->_resolve_column_info($ident, [ map $_->[0], @$bind ]);
52
53 foreach my $bound (@$bind) {
54 my $col = shift @$bound;
55
56 my $datatype = $col_info->{$col}{data_type};
57
58 foreach my $data (@$bound) {
59 $data = ''.$data if ref $data;
60
61 $data = $self->_prep_interpolated_value($datatype, $data)
62 if $datatype;
63
64 $data = $self->_dbh->quote($data)
65 unless $self->interpolate_unquoted($datatype, $data);
66
67 $new_sql .= shift(@sql_part) . $data;
68 }
69 }
70 $new_sql .= join '', @sql_part;
71
72 return ($new_sql, []);
73 }
74
75 =head2 interpolate_unquoted
76
77 This method is called by L</_prep_for_execute> for every column in
78 order to determine if its value should be quoted or not. The arguments
79 are the current column data type and the actual bind value. The return
80 value is interpreted as: true - do not quote, false - do quote. You should
81 override this in you Storage::DBI::<database> subclass, if your RDBMS
82 does not like quotes around certain datatypes (e.g. Sybase and integer
83 columns). The default method always returns false (do quote).
84
85 WARNING!!!
86
87 Always validate that the bind-value is valid for the current datatype.
88 Otherwise you may very well open the door to SQL injection attacks.
89
90 =cut
91
92 sub interpolate_unquoted {
93 #my ($self, $datatype, $value) = @_;
94 return 0;
95 }
96
97 =head2 _prep_interpolated_value
98
99 Given a datatype and the value to be inserted directly into a SQL query, returns
100 the necessary string to represent that value (by e.g. adding a '$' sign)
101
102 =cut
103
104 sub _prep_interpolated_value {
105 #my ($self, $datatype, $value) = @_;
106 return $_[2];
107 }
108
109 =head1 AUTHORS
110
111 See L<DBIx::Class/CONTRIBUTORS>
112
113 =head1 LICENSE
114
115 You may distribute this code under the same terms as Perl itself.
116
117 =cut
118
119 1;
0 package DBIx::Class::Storage::DBI::NoBindVars;
1
2 use strict;
3 use warnings;
4
5 use base 'DBIx::Class::Storage::DBI';
6 use mro 'c3';
7
8 =head1 NAME
9
10 DBIx::Class::Storage::DBI::NoBindVars - Sometime DBDs have poor to no support for bind variables
11
12 =head1 DESCRIPTION
13
14 This class allows queries to work when the DBD or underlying library does not
15 support the usual C<?> placeholders, or at least doesn't support them very
16 well, as is the case with L<DBD::Sybase>
17
18 =head1 METHODS
19
20 =head2 connect_info
21
22 We can't cache very effectively without bind variables, so force the C<disable_sth_caching> setting to be turned on when the connect info is set.
23
24 =cut
25
26 sub connect_info {
27 my $self = shift;
28 my $retval = $self->next::method(@_);
29 $self->disable_sth_caching(1);
30 $retval;
31 }
32
33 =head2 _prep_for_execute
34
35 Manually subs in the values for the usual C<?> placeholders.
36
37 =cut
38
39 sub _prep_for_execute {
40 my $self = shift;
41
42 my ($sql, $bind) = $self->next::method(@_);
43
44 # stringify bind args, quote via $dbh, and manually insert
45 #my ($op, $extra_bind, $ident, $args) = @_;
46 my $ident = $_[2];
47
48 my @sql_part = split /\?/, $sql;
49 my $new_sql;
50
51 my $col_info = $self->_resolve_column_info($ident, [ map $_->[0], @$bind ]);
52
53 foreach my $bound (@$bind) {
54 my $col = shift @$bound;
55
56 my $datatype = $col_info->{$col}{data_type};
57
58 foreach my $data (@$bound) {
59 $data = ''.$data if ref $data;
60
61 $data = $self->_prep_interpolated_value($datatype, $data)
62 if $datatype;
63
64 $data = $self->_dbh->quote($data)
65 unless $self->interpolate_unquoted($datatype, $data);
66
67 $new_sql .= shift(@sql_part) . $data;
68 }
69 }
70 $new_sql .= join '', @sql_part;
71
72 return ($new_sql, []);
73 }
74
75 =head2 interpolate_unquoted
76
77 This method is called by L</_prep_for_execute> for every column in
78 order to determine if its value should be quoted or not. The arguments
79 are the current column data type and the actual bind value. The return
80 value is interpreted as: true - do not quote, false - do quote. You should
81 override this in you Storage::DBI::<database> subclass, if your RDBMS
82 does not like quotes around certain datatypes (e.g. Sybase and integer
83 columns). The default method always returns false (do quote).
84
85 WARNING!!!
86
87 Always validate that the bind-value is valid for the current datatype.
88 Otherwise you may very well open the door to SQL injection attacks.
89
90 =cut
91
92 sub interpolate_unquoted {
93 #my ($self, $datatype, $value) = @_;
94 return 0;
95 }
96
97 =head2 _prep_interpolated_value
98
99 Given a datatype and the value to be inserted directly into a SQL query, returns
100 the necessary string to represent that value (by e.g. adding a '$' sign)
101
102 =cut
103
104 sub _prep_interpolated_value {
105 #my ($self, $datatype, $value) = @_;
106 return $_[2];
107 }
108
109 =head1 AUTHORS
110
111 See L<DBIx::Class/CONTRIBUTORS>
112
113 =head1 LICENSE
114
115 You may distribute this code under the same terms as Perl itself.
116
117 =cut
118
119 1;
+95
-0
lib/DBIx/Class/Storage/DBI/ODBC/Firebird.pm less more
0 package DBIx::Class::Storage::DBI::ODBC::Firebird;
1
2 use strict;
3 use warnings;
4 use base qw/DBIx::Class::Storage::DBI::InterBase/;
5 use mro 'c3';
6
7 =head1 NAME
8
9 DBIx::Class::Storage::DBI::ODBC::Firebird - Driver for using the Firebird RDBMS
10 through ODBC
11
12 =head1 DESCRIPTION
13
14 Most functionality is provided by L<DBIx::Class::Storage::DBI::Interbase>, see
15 that module for details.
16
17 To build the ODBC driver for Firebird on Linux for unixODBC, see:
18
19 L<http://www.firebirdnews.org/?p=1324>
20
21 This driver does not suffer from the nested statement handles across commits
22 issue that the L<DBD::InterBase|DBIx::Class::Storage::DBI::InterBase> based
23 driver does. This makes it more suitable for long running processes such as
24 under L<Catalyst>.
25
26 =cut
27
28 # XXX seemingly no equivalent to ib_time_all from DBD::InterBase via ODBC
29 sub connect_call_datetime_setup { 1 }
30
31 # we don't need DBD::InterBase-specific initialization
32 sub _init { 1 }
33
34 # ODBC uses dialect 3 by default, good
35 sub _set_sql_dialect { 1 }
36
37 # releasing savepoints doesn't work, but that shouldn't matter
38 sub _svp_release { 1 }
39
40 sub datetime_parser_type {
41 'DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format'
42 }
43
44 package # hide from PAUSE
45 DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format;
46
47 # inherit parse/format date
48 our @ISA = 'DBIx::Class::Storage::DBI::InterBase::DateTime::Format';
49
50 my $timestamp_format = '%Y-%m-%d %H:%M:%S'; # %F %T, no fractional part
51 my $timestamp_parser;
52
53 sub parse_datetime {
54 shift;
55 require DateTime::Format::Strptime;
56 $timestamp_parser ||= DateTime::Format::Strptime->new(
57 pattern => $timestamp_format,
58 on_error => 'croak',
59 );
60 return $timestamp_parser->parse_datetime(shift);
61 }
62
63 sub format_datetime {
64 shift;
65 require DateTime::Format::Strptime;
66 $timestamp_parser ||= DateTime::Format::Strptime->new(
67 pattern => $timestamp_format,
68 on_error => 'croak',
69 );
70 return $timestamp_parser->format_datetime(shift);
71 }
72
73 1;
74
75 =head1 CAVEATS
76
77 =over 4
78
79 =item *
80
81 This driver (unlike L<DBD::InterBase>) does not currently support reading or
82 writing C<TIMESTAMP> values with sub-second precision.
83
84 =back
85
86 =head1 AUTHOR
87
88 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
89
90 =head1 LICENSE
91
92 You may distribute this code under the same terms as Perl itself.
93
94 =cut
+1
-9
lib/DBIx/Class/Storage/DBI/ODBC/Microsoft_SQL_Server.pm less more
3636
3737 on_connect_call => 'use_dynamic_cursors'
3838
39 in your L<DBIx::Class::Storage::DBI/connect_info> as one way to enable multiple
39 in your L<connect_info|DBIx::Class::Storage::DBI/connect_info> as one way to enable multiple
4040 concurrent statements.
4141
4242 Will add C<< odbc_cursortype => 2 >> to your DBI connection attributes. See
174174 }
175175 }
176176
177 sub _get_mssql_version {
178 my $self = shift;
179
180 my ($version) = $self->_get_dbh->get_info(18) =~ /^(\d+)/;
181
182 return $version;
183 }
184
185177 1;
186178
187179 =head1 AUTHOR
+7
-6
lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm less more
109109 my $dbh = $self->_dbh or return 0;
110110
111111 local $dbh->{RaiseError} = 1;
112 local $dbh->{PrintError} = 0;
112113
113114 eval {
114 $dbh->do("select 1 from dual");
115 $dbh->do('select 1 from dual');
115116 };
116117
117118 return $@ ? 0 : 1;
148149
149150 $self->throw_exception($exception) if $exception;
150151
151 wantarray ? @res : $res[0]
152 $wantarray ? @res : $res[0]
152153 }
153154
154155 =head2 get_autoinc_seq
191192
192193 on_connect_call => 'datetime_setup'
193194
194 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
195 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
196 necessary environment variables for L<DateTime::Format::Oracle>, which is used
197 by it.
195 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
196 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
197 and the necessary environment variables for L<DateTime::Format::Oracle>, which
198 is used by it.
198199
199200 Maximum allowable precision is used, unless the environment variables have
200201 already been set.
+39
-19
lib/DBIx/Class/Storage/DBI/Pg.pm less more
22 use strict;
33 use warnings;
44
5 use base qw/DBIx::Class::Storage::DBI::MultiColumnIn/;
5 use base qw/
6 DBIx::Class::Storage::DBI::MultiColumnIn
7 /;
68 use mro 'c3';
79
810 use DBD::Pg qw(:pg_types);
11 use Scope::Guard ();
12 use Context::Preserve ();
913
1014 # Ask for a DBD::Pg with array support
1115 warn __PACKAGE__.": DBD::Pg 2.9.2 or greater is strongly recommended\n"
1216 if ($DBD::Pg::VERSION < 2.009002); # pg uses (used?) version::qv()
1317
18 sub _supports_insert_returning {
19 my $self = shift;
20
21 return 1
22 if $self->_server_info->{normalized_dbms_version} >= 8.002;
23
24 return 0;
25 }
26
1427 sub with_deferred_fk_checks {
1528 my ($self, $sub) = @_;
1629
17 $self->_get_dbh->do('SET CONSTRAINTS ALL DEFERRED');
18 $sub->();
19 }
20
30 my $txn_scope_guard = $self->txn_scope_guard;
31
32 $self->_do_query('SET CONSTRAINTS ALL DEFERRED');
33
34 my $sg = Scope::Guard->new(sub {
35 $self->_do_query('SET CONSTRAINTS ALL IMMEDIATE');
36 });
37
38 return Context::Preserve::preserve_context(sub { $sub->() },
39 after => sub { $txn_scope_guard->commit });
40 }
41
42 # only used when INSERT ... RETURNING is disabled
2143 sub last_insert_id {
2244 my ($self,$source,@cols) = @_;
2345
3153 $col,
3254 ));
3355
34 push @values, $self->_dbh_last_insert_id ($self->_dbh, $seq);
56 push @values, $self->_dbh->last_insert_id(undef, undef, undef, undef, {sequence => $seq});
3557 }
3658
3759 return @values;
3860 }
3961
40 # there seems to be absolutely no reason to have this as a separate method,
41 # but leaving intact in case someone is already overriding it
42 sub _dbh_last_insert_id {
43 my ($self, $dbh, $seq) = @_;
44 $dbh->last_insert_id(undef, undef, undef, undef, {sequence => $seq});
45 }
46
62 sub _sequence_fetch {
63 my ($self, $function, $sequence) = @_;
64
65 $self->throw_exception('No sequence to fetch') unless $sequence;
66
67 my ($val) = $self->_get_dbh->selectrow_array(
68 sprintf ("select %s('%s')", $function, $sequence)
69 );
70
71 return $val;
72 }
4773
4874 sub _dbh_get_autoinc_seq {
4975 my ($self, $dbh, $source, $col) = @_;
154180 }
155181 }
156182
157 sub _sequence_fetch {
158 my ( $self, $type, $seq ) = @_;
159 my ($id) = $self->_get_dbh->selectrow_array("SELECT nextval('${seq}')");
160 return $id;
161 }
162
163183 sub _svp_begin {
164184 my ($self, $name) = @_;
165185
+93
-93
lib/DBIx/Class/Storage/DBI/Replicated/Balancer/Random.pm less more
0 package DBIx::Class::Storage::DBI::Replicated::Balancer::Random;
1
2 use Moose;
3 with 'DBIx::Class::Storage::DBI::Replicated::Balancer';
4 use DBIx::Class::Storage::DBI::Replicated::Types 'Weight';
5 use namespace::clean -except => 'meta';
6
7 =head1 NAME
8
9 DBIx::Class::Storage::DBI::Replicated::Balancer::Random - A 'random' Balancer
10
11 =head1 SYNOPSIS
12
13 This class is used internally by L<DBIx::Class::Storage::DBI::Replicated>. You
14 shouldn't need to create instances of this class.
15
16 =head1 DESCRIPTION
17
18 Given a pool (L<DBIx::Class::Storage::DBI::Replicated::Pool>) of replicated
19 database's (L<DBIx::Class::Storage::DBI::Replicated::Replicant>), defines a
20 method by which query load can be spread out across each replicant in the pool.
21
22 This Balancer uses L<List::Util> keyword 'shuffle' to randomly pick an active
23 replicant from the associated pool. This may or may not be random enough for
24 you, patches welcome.
25
26 =head1 ATTRIBUTES
27
28 This class defines the following attributes.
29
30 =head2 master_read_weight
31
32 A number greater than 0 that specifies what weight to give the master when
33 choosing which backend to execute a read query on. A value of 0, which is the
34 default, does no reads from master, while a value of 1 gives it the same
35 priority as any single replicant.
36
37 For example: if you have 2 replicants, and a L</master_read_weight> of C<0.5>,
38 the chance of reading from master will be C<20%>.
39
40 You can set it to a value higher than 1, making master have higher weight than
41 any single replicant, if for example you have a very powerful master.
42
43 =cut
44
45 has master_read_weight => (is => 'rw', isa => Weight, default => sub { 0 });
46
47 =head1 METHODS
48
49 This class defines the following methods.
50
51 =head2 next_storage
52
53 Returns an active replicant at random. Please note that due to the nature of
54 the word 'random' this means it's possible for a particular active replicant to
55 be requested several times in a row.
56
57 =cut
58
59 sub next_storage {
60 my $self = shift @_;
61
62 my @replicants = $self->pool->active_replicants;
63
64 if (not @replicants) {
65 # will fall back to master anyway
66 return;
67 }
68
69 my $master = $self->master;
70
71 my $rnd = $self->_random_number(@replicants + $self->master_read_weight);
72
73 return $rnd >= @replicants ? $master : $replicants[int $rnd];
74 }
75
76 sub _random_number {
77 rand($_[1])
78 }
79
80 =head1 AUTHOR
81
82 John Napiorkowski <john.napiorkowski@takkle.com>
83
84 =head1 LICENSE
85
86 You may distribute this code under the same terms as Perl itself.
87
88 =cut
89
90 __PACKAGE__->meta->make_immutable;
91
92 1;
0 package DBIx::Class::Storage::DBI::Replicated::Balancer::Random;
1
2 use Moose;
3 with 'DBIx::Class::Storage::DBI::Replicated::Balancer';
4 use DBIx::Class::Storage::DBI::Replicated::Types 'Weight';
5 use namespace::clean -except => 'meta';
6
7 =head1 NAME
8
9 DBIx::Class::Storage::DBI::Replicated::Balancer::Random - A 'random' Balancer
10
11 =head1 SYNOPSIS
12
13 This class is used internally by L<DBIx::Class::Storage::DBI::Replicated>. You
14 shouldn't need to create instances of this class.
15
16 =head1 DESCRIPTION
17
18 Given a pool (L<DBIx::Class::Storage::DBI::Replicated::Pool>) of replicated
19 database's (L<DBIx::Class::Storage::DBI::Replicated::Replicant>), defines a
20 method by which query load can be spread out across each replicant in the pool.
21
22 This Balancer uses L<List::Util> keyword 'shuffle' to randomly pick an active
23 replicant from the associated pool. This may or may not be random enough for
24 you, patches welcome.
25
26 =head1 ATTRIBUTES
27
28 This class defines the following attributes.
29
30 =head2 master_read_weight
31
32 A number greater than 0 that specifies what weight to give the master when
33 choosing which backend to execute a read query on. A value of 0, which is the
34 default, does no reads from master, while a value of 1 gives it the same
35 priority as any single replicant.
36
37 For example: if you have 2 replicants, and a L</master_read_weight> of C<0.5>,
38 the chance of reading from master will be C<20%>.
39
40 You can set it to a value higher than 1, making master have higher weight than
41 any single replicant, if for example you have a very powerful master.
42
43 =cut
44
45 has master_read_weight => (is => 'rw', isa => Weight, default => sub { 0 });
46
47 =head1 METHODS
48
49 This class defines the following methods.
50
51 =head2 next_storage
52
53 Returns an active replicant at random. Please note that due to the nature of
54 the word 'random' this means it's possible for a particular active replicant to
55 be requested several times in a row.
56
57 =cut
58
59 sub next_storage {
60 my $self = shift @_;
61
62 my @replicants = $self->pool->active_replicants;
63
64 if (not @replicants) {
65 # will fall back to master anyway
66 return;
67 }
68
69 my $master = $self->master;
70
71 my $rnd = $self->_random_number(@replicants + $self->master_read_weight);
72
73 return $rnd >= @replicants ? $master : $replicants[int $rnd];
74 }
75
76 sub _random_number {
77 rand($_[1])
78 }
79
80 =head1 AUTHOR
81
82 John Napiorkowski <john.napiorkowski@takkle.com>
83
84 =head1 LICENSE
85
86 You may distribute this code under the same terms as Perl itself.
87
88 =cut
89
90 __PACKAGE__->meta->make_immutable;
91
92 1;
+44
-44
lib/DBIx/Class/Storage/DBI/Replicated/Types.pm less more
0 package # hide from PAUSE
1 DBIx::Class::Storage::DBI::Replicated::Types;
2
3 # DBIx::Class::Storage::DBI::Replicated::Types - Types used internally by
4 # L<DBIx::Class::Storage::DBI::Replicated>
5
6 use MooseX::Types
7 -declare => [qw/BalancerClassNamePart Weight DBICSchema DBICStorageDBI/];
8 use MooseX::Types::Moose qw/ClassName Str Num/;
9
10 class_type 'DBIx::Class::Storage::DBI';
11 class_type 'DBIx::Class::Schema';
12
13 subtype DBICSchema, as 'DBIx::Class::Schema';
14 subtype DBICStorageDBI, as 'DBIx::Class::Storage::DBI';
15
16 subtype BalancerClassNamePart,
17 as ClassName;
18
19 coerce BalancerClassNamePart,
20 from Str,
21 via {
22 my $type = $_;
23 if($type=~m/^::/) {
24 $type = 'DBIx::Class::Storage::DBI::Replicated::Balancer'.$type;
25 }
26 Class::MOP::load_class($type);
27 $type;
28 };
29
30 subtype Weight,
31 as Num,
32 where { $_ >= 0 },
33 message { 'weight must be a decimal greater than 0' };
34
35 # AUTHOR
36 #
37 # John Napiorkowski <john.napiorkowski@takkle.com>
38 #
39 # LICENSE
40 #
41 # You may distribute this code under the same terms as Perl itself.
42
43 1;
0 package # hide from PAUSE
1 DBIx::Class::Storage::DBI::Replicated::Types;
2
3 # DBIx::Class::Storage::DBI::Replicated::Types - Types used internally by
4 # L<DBIx::Class::Storage::DBI::Replicated>
5
6 use MooseX::Types
7 -declare => [qw/BalancerClassNamePart Weight DBICSchema DBICStorageDBI/];
8 use MooseX::Types::Moose qw/ClassName Str Num/;
9
10 class_type 'DBIx::Class::Storage::DBI';
11 class_type 'DBIx::Class::Schema';
12
13 subtype DBICSchema, as 'DBIx::Class::Schema';
14 subtype DBICStorageDBI, as 'DBIx::Class::Storage::DBI';
15
16 subtype BalancerClassNamePart,
17 as ClassName;
18
19 coerce BalancerClassNamePart,
20 from Str,
21 via {
22 my $type = $_;
23 if($type=~m/^::/) {
24 $type = 'DBIx::Class::Storage::DBI::Replicated::Balancer'.$type;
25 }
26 Class::MOP::load_class($type);
27 $type;
28 };
29
30 subtype Weight,
31 as Num,
32 where { $_ >= 0 },
33 message { 'weight must be a decimal greater than 0' };
34
35 # AUTHOR
36 #
37 # John Napiorkowski <john.napiorkowski@takkle.com>
38 #
39 # LICENSE
40 #
41 # You may distribute this code under the same terms as Perl itself.
42
43 1;
+69
-69
lib/DBIx/Class/Storage/DBI/Replicated/WithDSN.pm less more
0 package DBIx::Class::Storage::DBI::Replicated::WithDSN;
1
2 use Moose::Role;
3 use Scalar::Util 'reftype';
4 requires qw/_query_start/;
5
6 use namespace::clean -except => 'meta';
7
8 =head1 NAME
9
10 DBIx::Class::Storage::DBI::Replicated::WithDSN - A DBI Storage Role with DSN
11 information in trace output
12
13 =head1 SYNOPSIS
14
15 This class is used internally by L<DBIx::Class::Storage::DBI::Replicated>.
16
17 =head1 DESCRIPTION
18
19 This role adds C<DSN: > info to storage debugging output.
20
21 =head1 METHODS
22
23 This class defines the following methods.
24
25 =head2 around: _query_start
26
27 Add C<DSN: > to debugging output.
28
29 =cut
30
31 around '_query_start' => sub {
32 my ($method, $self, $sql, @bind) = @_;
33
34 my $dsn = eval { $self->dsn } || $self->_dbi_connect_info->[0];
35
36 my($op, $rest) = (($sql=~m/^(\w+)(.+)$/),'NOP', 'NO SQL');
37 my $storage_type = $self->can('active') ? 'REPLICANT' : 'MASTER';
38
39 my $query = do {
40 if ((reftype($dsn)||'') ne 'CODE') {
41 "$op [DSN_$storage_type=$dsn]$rest";
42 }
43 elsif (my $id = eval { $self->id }) {
44 "$op [$storage_type=$id]$rest";
45 }
46 else {
47 "$op [$storage_type]$rest";
48 }
49 };
50
51 $self->$method($query, @bind);
52 };
53
54 =head1 ALSO SEE
55
56 L<DBIx::Class::Storage::DBI>
57
58 =head1 AUTHOR
59
60 John Napiorkowski <john.napiorkowski@takkle.com>
61
62 =head1 LICENSE
63
64 You may distribute this code under the same terms as Perl itself.
65
66 =cut
67
68 1;
0 package DBIx::Class::Storage::DBI::Replicated::WithDSN;
1
2 use Moose::Role;
3 use Scalar::Util 'reftype';
4 requires qw/_query_start/;
5
6 use namespace::clean -except => 'meta';
7
8 =head1 NAME
9
10 DBIx::Class::Storage::DBI::Replicated::WithDSN - A DBI Storage Role with DSN
11 information in trace output
12
13 =head1 SYNOPSIS
14
15 This class is used internally by L<DBIx::Class::Storage::DBI::Replicated>.
16
17 =head1 DESCRIPTION
18
19 This role adds C<DSN: > info to storage debugging output.
20
21 =head1 METHODS
22
23 This class defines the following methods.
24
25 =head2 around: _query_start
26
27 Add C<DSN: > to debugging output.
28
29 =cut
30
31 around '_query_start' => sub {
32 my ($method, $self, $sql, @bind) = @_;
33
34 my $dsn = eval { $self->dsn } || $self->_dbi_connect_info->[0];
35
36 my($op, $rest) = (($sql=~m/^(\w+)(.+)$/),'NOP', 'NO SQL');
37 my $storage_type = $self->can('active') ? 'REPLICANT' : 'MASTER';
38
39 my $query = do {
40 if ((reftype($dsn)||'') ne 'CODE') {
41 "$op [DSN_$storage_type=$dsn]$rest";
42 }
43 elsif (my $id = eval { $self->id }) {
44 "$op [$storage_type=$id]$rest";
45 }
46 else {
47 "$op [$storage_type]$rest";
48 }
49 };
50
51 $self->$method($query, @bind);
52 };
53
54 =head1 ALSO SEE
55
56 L<DBIx::Class::Storage::DBI>
57
58 =head1 AUTHOR
59
60 John Napiorkowski <john.napiorkowski@takkle.com>
61
62 =head1 LICENSE
63
64 You may distribute this code under the same terms as Perl itself.
65
66 =cut
67
68 1;
+31
-0
lib/DBIx/Class/Storage/DBI/Replicated.pm less more
305305
306306 backup
307307 is_datatype_numeric
308 _supports_insert_returning
308309 _count_select
309310 _subq_count_select
310311 _subq_update_delete
364365 _do_query
365366 _dbh_sth
366367 _dbh_execute
368 _prefetch_insert_auto_nextvals
369 _server_info_hash
367370 /],
368371 );
372
369373
370374 has _master_connect_info_opts =>
371375 (is => 'rw', isa => HashRef, default => sub { {} });
10051009 return min map $_->_ping, $self->all_storages;
10061010 }
10071011
1012 sub _server_info {
1013 my $self = shift;
1014
1015 if (not $self->_server_info_hash) {
1016 no warnings 'numeric'; # in case dbms_version doesn't normalize
1017
1018 my @infos =
1019 map $_->[1],
1020 sort { $a->[0] <=> $b->[0] }
1021 map [ (defined $_->{normalized_dbms_version} ? $_->{normalized_dbms_version}
1022 : $_->{dbms_version}), $_ ],
1023 map $_->_server_info, $self->all_storages;
1024
1025 my $min_version_info = $infos[0];
1026
1027 $self->_server_info_hash($min_version_info); # on master
1028 }
1029
1030 return $self->_server_info_hash;
1031 }
1032
1033 sub _get_server_version {
1034 my $self = shift;
1035
1036 return $self->_server_info->{dbms_version};
1037 }
1038
10081039 =head1 GOTCHAS
10091040
10101041 Due to the fact that replicants can lag behind a master, you must take care to
+34
-5
lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm less more
11
22 use strict;
33 use warnings;
4 use base qw/DBIx::Class::Storage::DBI/;
4 use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/;
55 use mro 'c3';
66 use List::Util ();
77
3434
3535 sub last_insert_id { shift->_identity }
3636
37 sub _new_uuid { 'UUIDTOSTR(NEWID())' }
38
3739 sub insert {
3840 my $self = shift;
3941 my ($source, $to_insert) = @_;
4547 # user might have an identity PK without is_auto_increment
4648 if (not $identity_col) {
4749 foreach my $pk_col ($source->primary_columns) {
48 if (not exists $to_insert->{$pk_col}) {
50 if (not exists $to_insert->{$pk_col} &&
51 $source->column_info($pk_col)->{data_type} !~ /^uniqueidentifier/i)
52 {
4953 $identity_col = $pk_col;
5054 last;
5155 }
5761 my $table_name = $source->from;
5862 $table_name = $$table_name if ref $table_name;
5963
60 my ($identity) = $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')");
64 my ($identity) = eval {
65 local $@; $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')")
66 };
6167
62 $to_insert->{$identity_col} = $identity;
68 if (defined $identity) {
69 $to_insert->{$identity_col} = $identity;
70 $self->_identity($identity);
71 }
72 }
6373
64 $self->_identity($identity);
74 return $self->next::method(@_);
75 }
76
77 # convert UUIDs to strings in selects
78 sub _select_args {
79 my $self = shift;
80 my ($ident, $select) = @_;
81
82 my $col_info = $self->_resolve_column_info($ident);
83
84 for my $select_idx (0..$#$select) {
85 my $selected = $select->[$select_idx];
86
87 next if ref $selected;
88
89 my $data_type = $col_info->{$selected}{data_type};
90
91 if ($data_type && $data_type =~ /^uniqueidentifier\z/i) {
92 $select->[$select_idx] = { UUIDTOSTR => $selected };
93 }
6594 }
6695
6796 return $self->next::method(@_);
+33
-5
lib/DBIx/Class/Storage/DBI/SQLite.pm less more
88 use POSIX 'strftime';
99 use File::Copy;
1010 use File::Spec;
11
12 __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::SQLite');
1113
1214 sub backup
1315 {
4749
4850 $sqltargs ||= {};
4951
50 my $sqlite_version = $self->_get_dbh->{sqlite_version};
52 # it'd be cool to use the normalized perl-style version but this needs sqlt hacking as well
53 if (my $sqlite_version = $self->_server_info->{dbms_version}) {
54 # numify, SQLT does a numeric comparison
55 $sqlite_version =~ s/^(\d+) \. (\d+) (?: \. (\d+))? .*/${1}.${2}/x;
5156
52 # numify, SQLT does a numeric comparison
53 $sqlite_version =~ s/^(\d+) \. (\d+) (?: \. (\d+))? .*/${1}.${2}/x;
54
55 $sqltargs->{producer_args}{sqlite_version} = $sqlite_version;
57 $sqltargs->{producer_args}{sqlite_version} = $sqlite_version if $sqlite_version;
58 }
5659
5760 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
5861 }
5962
6063 sub datetime_parser_type { return "DateTime::Format::SQLite"; }
64
65 =head2 connect_call_use_foreign_keys
66
67 Used as:
68
69 on_connect_call => 'use_foreign_keys'
70
71 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to turn on foreign key
72 (including cascading) support for recent versions of SQLite and L<DBD::SQLite>.
73
74 Executes:
75
76 PRAGMA foreign_keys = ON
77
78 See L<http://www.sqlite.org/foreignkeys.html> for more information.
79
80 =cut
81
82 sub connect_call_use_foreign_keys {
83 my $self = shift;
84
85 $self->_do_query(
86 'PRAGMA foreign_keys = ON'
87 );
88 }
6189
6290 1;
6391
+8
-7
lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm less more
4848 without doing a C<SELECT MAX(col)>. This is done safely in a transaction
4949 (locking the table.) See L</INSERTS WITH PLACEHOLDERS>.
5050
51 A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
51 A recommended L<connect_info|DBIx::Class::Storage::DBI/connect_info> setting:
5252
5353 on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
5454
845845
846846 on_connect_call => 'datetime_setup'
847847
848 In L<DBIx::Class::Storage::DBI/connect_info> to set:
848 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set:
849849
850850 $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
851851 $dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080
10681068 instead.
10691069
10701070 However, the C<LongReadLen> you pass in
1071 L<DBIx::Class::Storage::DBI/connect_info> is used to execute the equivalent
1072 C<SET TEXTSIZE> command on connection.
1073
1074 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
1075 setting you need to work with C<IMAGE> columns.
1071 L<connect_info|DBIx::Class::Storage::DBI/connect_info> is used to execute the
1072 equivalent C<SET TEXTSIZE> command on connection.
1073
1074 See L</connect_call_blob_setup> for a
1075 L<connect_info|DBIx::Class::Storage::DBI/connect_info> setting you need to work
1076 with C<IMAGE> columns.
10761077
10771078 =head1 BULK API
10781079
+55
-55
lib/DBIx/Class/Storage/DBI/Sybase/MSSQL.pm less more
0 package DBIx::Class::Storage::DBI::Sybase::MSSQL;
1
2 use strict;
3 use warnings;
4
5 use Carp::Clan qw/^DBIx::Class/;
6
7 carp 'Setting of storage_type is redundant as connections through DBD::Sybase'
8 .' are now properly recognized and reblessed into the appropriate subclass'
9 .' (DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server in the'
10 .' case of MSSQL). Please remove the explicit call to'
11 .q/ $schema->storage_type('::DBI::Sybase::MSSQL')/
12 .', as this storage class has been deprecated in favor of the autodetected'
13 .' ::DBI::Sybase::Microsoft_SQL_Server';
14
15
16 use base qw/DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server/;
17 use mro 'c3';
18
19 1;
20
21 =head1 NAME
22
23 DBIx::Class::Storage::DBI::Sybase::MSSQL - (DEPRECATED) Legacy storage class for MSSQL via DBD::Sybase
24
25 =head1 NOTE
26
27 Connections through DBD::Sybase are now correctly recognized and reblessed
28 into the appropriate subclass (L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>
29 in the case of MSSQL). Please remove the explicit storage_type setting from your
30 schema.
31
32 =head1 SYNOPSIS
33
34 This subclass supports MSSQL connected via L<DBD::Sybase>.
35
36 $schema->storage_type('::DBI::Sybase::MSSQL');
37 $schema->connect_info('dbi:Sybase:....', ...);
38
39 =head1 BUGS
40
41 Currently, this doesn't work right unless you call C<Class::C3::reinitialize()>
42 after connecting.
43
44 =head1 AUTHORS
45
46 Brandon L Black <blblack@gmail.com>
47
48 Justin Hunter <justin.d.hunter@gmail.com>
49
50 =head1 LICENSE
51
52 You may distribute this code under the same terms as Perl itself.
53
54 =cut
0 package DBIx::Class::Storage::DBI::Sybase::MSSQL;
1
2 use strict;
3 use warnings;
4
5 use Carp::Clan qw/^DBIx::Class/;
6
7 carp 'Setting of storage_type is redundant as connections through DBD::Sybase'
8 .' are now properly recognized and reblessed into the appropriate subclass'
9 .' (DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server in the'
10 .' case of MSSQL). Please remove the explicit call to'
11 .q/ $schema->storage_type('::DBI::Sybase::MSSQL')/
12 .', as this storage class has been deprecated in favor of the autodetected'
13 .' ::DBI::Sybase::Microsoft_SQL_Server';
14
15
16 use base qw/DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server/;
17 use mro 'c3';
18
19 1;
20
21 =head1 NAME
22
23 DBIx::Class::Storage::DBI::Sybase::MSSQL - (DEPRECATED) Legacy storage class for MSSQL via DBD::Sybase
24
25 =head1 NOTE
26
27 Connections through DBD::Sybase are now correctly recognized and reblessed
28 into the appropriate subclass (L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>
29 in the case of MSSQL). Please remove the explicit storage_type setting from your
30 schema.
31
32 =head1 SYNOPSIS
33
34 This subclass supports MSSQL connected via L<DBD::Sybase>.
35
36 $schema->storage_type('::DBI::Sybase::MSSQL');
37 $schema->connect_info('dbi:Sybase:....', ...);
38
39 =head1 BUGS
40
41 Currently, this doesn't work right unless you call C<Class::C3::reinitialize()>
42 after connecting.
43
44 =head1 AUTHORS
45
46 Brandon L Black <blblack@gmail.com>
47
48 Justin Hunter <justin.d.hunter@gmail.com>
49
50 =head1 LICENSE
51
52 You may distribute this code under the same terms as Perl itself.
53
54 =cut
+15
-0
lib/DBIx/Class/Storage/DBI/Sybase/Microsoft_SQL_Server.pm less more
5454 $dbh->do('ROLLBACK');
5555 }
5656
57 sub _get_server_version {
58 my $self = shift;
59
60 my $product_version = $self->_get_dbh->selectrow_hashref('xp_msver ProductVersion');
61
62 if ((my $version = $product_version->{Character_Value}) =~ /^(\d+)\./) {
63 return $version;
64 }
65 else {
66 $self->throw_exception(
67 "MSSQL Version Retrieval Failed, Your ProductVersion's Character_Value is missing or malformed!"
68 );
69 }
70 }
71
5772 1;
5873
5974 =head1 NAME
+2
-2
lib/DBIx/Class/Storage/DBI/Sybase.pm less more
102102 $dbh->do("SET TEXTSIZE $bytes");
103103
104104 Takes the number of bytes, or uses the C<LongReadLen> value from your
105 L<DBIx::Class/connect_info> if omitted, lastly falls back to the C<32768> which
106 is the L<DBD::Sybase> default.
105 L<connect_info|DBIx::Class::Storage::DBI/connect_info> if omitted, lastly falls
106 back to the C<32768> which is the L<DBD::Sybase> default.
107107
108108 =cut
109109
+83
-0
lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm less more
0 package DBIx::Class::Storage::DBI::UniqueIdentifier;
1
2 use strict;
3 use warnings;
4 use base 'DBIx::Class::Storage::DBI';
5 use mro 'c3';
6
7 =head1 NAME
8
9 DBIx::Class::Storage::DBI::UniqueIdentifier - Storage component for RDBMSes
10 supporting the 'uniqueidentifier' type
11
12 =head1 DESCRIPTION
13
14 This is a storage component for databases that support the C<uniqueidentifier>
15 type and the C<NEWID()> function for generating UUIDs.
16
17 UUIDs are generated automatically for PK columns with the C<uniqueidentifier>
18 L<data_type|DBIx::Class::ResultSource/data_type>, as well as non-PK with this
19 L<data_type|DBIx::Class::ResultSource/data_type> and
20 L<auto_nextval|DBIx::Class::ResultSource/auto_nextval>.
21
22 Currently used by L<DBIx::Class::Storage::DBI::MSSQL> and
23 L<DBIx::Class::Storage::DBI::SQLAnywhere>.
24
25 The composing class can define a C<_new_uuid> method to override the function
26 used to generate a new UUID.
27
28 =cut
29
30 sub _new_uuid { 'NEWID()' }
31
32 sub insert {
33 my $self = shift;
34 my ($source, $to_insert) = @_;
35
36 my $supplied_col_info = $self->_resolve_column_info($source, [keys %$to_insert] );
37
38 my %guid_cols;
39 my @pk_cols = $source->primary_columns;
40 my %pk_cols;
41 @pk_cols{@pk_cols} = ();
42
43 my @pk_guids = grep {
44 $source->column_info($_)->{data_type}
45 &&
46 $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
47 } @pk_cols;
48
49 my @auto_guids = grep {
50 $source->column_info($_)->{data_type}
51 &&
52 $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
53 &&
54 $source->column_info($_)->{auto_nextval}
55 } grep { not exists $pk_cols{$_} } $source->columns;
56
57 my @get_guids_for =
58 grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
59
60 my $updated_cols = {};
61
62 for my $guid_col (@get_guids_for) {
63 my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT '.$self->_new_uuid);
64 $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
65 }
66
67 $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } };
68
69 return $updated_cols;
70 }
71
72 =head1 AUTHOR
73
74 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
75
76 =head1 LICENSE
77
78 You may distribute this code under the same terms as Perl itself.
79
80 =cut
81
82 1;
+6
-1
lib/DBIx/Class/Storage/DBI/mysql.pm less more
9898
9999 =head1 DESCRIPTION
100100
101 This class implements MySQL specific bits of L<DBIx::Class::Storage::DBI>.
101 This class implements MySQL specific bits of L<DBIx::Class::Storage::DBI>,
102 like AutoIncrement column support and savepoints. Also it augments the
103 SQL maker to support the MySQL-specific C<STRAIGHT_JOIN> join type, which
104 you can use by specifying C<< join_type => 'straight' >> in the
105 L<relationship attributes|DBIx::Class::Relationship::Base/join_type>
106
102107
103108 It also provides a one-stop on-connect macro C<set_strict_mode> which sets
104109 session variables such that MySQL behaves more predictably as far as the
+113
-28
lib/DBIx/Class/Storage/DBI.pm less more
1717
1818 __PACKAGE__->mk_group_accessors('simple' =>
1919 qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid
20 _conn_tid transaction_depth _dbh_autocommit _driver_determined savepoints/
20 _conn_tid transaction_depth _dbh_autocommit _driver_determined savepoints
21 _server_info_hash/
2122 );
2223
2324 # the values for these accessors are picked out (and deleted) from
3233 # default cursor class, overridable in connect_info attributes
3334 __PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
3435
35 __PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
36 __PACKAGE__->mk_group_accessors('inherited' => qw/
37 sql_maker_class
38 _supports_insert_returning
39 /);
3640 __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks');
3741
3842
8892 );
8993
9094 $schema->resultset('Book')->search({
91 written_on => $schema->storage->datetime_parser(DateTime->now)
95 written_on => $schema->storage->datetime_parser->format_datetime(DateTime->now)
9296 });
9397
9498 =head1 DESCRIPTION
741745
742746 $self->_dbh_rollback unless $self->_dbh_autocommit;
743747
748 %{ $self->_dbh->{CachedKids} } = ();
744749 $self->_dbh->disconnect;
745750 $self->_dbh(undef);
746751 $self->{_dbh_gen}++;
848853 Returns a C<$dbh> - a data base handle of class L<DBI>. The returned handle
849854 is guaranteed to be healthy by implicitly calling L</connected>, and if
850855 necessary performing a reconnection before returning. Keep in mind that this
851 is very B<expensive> on some database engines. Consider using L<dbh_do>
856 is very B<expensive> on some database engines. Consider using L</dbh_do>
852857 instead.
853858
854859 =cut
902907
903908 my @info = @{$self->_dbi_connect_info || []};
904909 $self->_dbh(undef); # in case ->connected failed we might get sent here
910 $self->_server_info_hash (undef);
905911 $self->_dbh($self->_connect(@info));
906912
907913 $self->_conn_pid($$);
924930 push @actions, $self->_parse_connect_do ('on_connect_do');
925931
926932 $self->_do_connection_actions(connect_call_ => $_) for @actions;
933 }
934
935 sub _server_info {
936 my $self = shift;
937
938 unless ($self->_server_info_hash) {
939
940 my %info;
941
942 my $server_version = $self->_get_server_version;
943
944 if (defined $server_version) {
945 $info{dbms_version} = $server_version;
946
947 my ($numeric_version) = $server_version =~ /^([\d\.]+)/;
948 my @verparts = split (/\./, $numeric_version);
949 if (
950 @verparts
951 &&
952 $verparts[0] <= 999
953 ) {
954 # consider only up to 3 version parts, iff not more than 3 digits
955 my @use_parts;
956 while (@verparts && @use_parts < 3) {
957 my $p = shift @verparts;
958 last if $p > 999;
959 push @use_parts, $p;
960 }
961 push @use_parts, 0 while @use_parts < 3;
962
963 $info{normalized_dbms_version} = sprintf "%d.%03d%03d", @use_parts;
964 }
965 }
966
967 $self->_server_info_hash(\%info);
968 }
969
970 return $self->_server_info_hash
971 }
972
973 sub _get_server_version {
974 eval { shift->_get_dbh->get_info(18) };
927975 }
928976
929977 sub _determine_driver {
948996 else {
949997 # try to use dsn to not require being connected, the driver may still
950998 # force a connection in _rebless to determine version
951 ($driver) = $self->_dbi_connect_info->[0] =~ /dbi:([^:]+):/i;
999 # (dsn may not be supplied at all if all we do is make a mock-schema)
1000 my $dsn = $self->_dbi_connect_info->[0] || '';
1001 ($driver) = $dsn =~ /dbi:([^:]+):/i;
9521002 }
9531003 }
9541004
955 my $storage_class = "DBIx::Class::Storage::DBI::${driver}";
956 if ($self->load_optional_class($storage_class)) {
957 mro::set_mro($storage_class, 'c3');
958 bless $self, $storage_class;
959 $self->_rebless();
1005 if ($driver) {
1006 my $storage_class = "DBIx::Class::Storage::DBI::${driver}";
1007 if ($self->load_optional_class($storage_class)) {
1008 mro::set_mro($storage_class, 'c3');
1009 bless $self, $storage_class;
1010 $self->_rebless();
1011 }
9601012 }
9611013 }
9621014
13571409 $self->dbh_do('_dbh_execute', @_); # retry over disconnects
13581410 }
13591411
1360 sub insert {
1412 sub _prefetch_insert_auto_nextvals {
13611413 my ($self, $source, $to_insert) = @_;
13621414
1363 my $ident = $source->from;
1364 my $bind_attributes = $self->source_bind_attributes($source);
1365
1366 my $updated_cols = {};
1415 my $upd = {};
13671416
13681417 foreach my $col ( $source->columns ) {
13691418 if ( !defined $to_insert->{$col} ) {
13701419 my $col_info = $source->column_info($col);
13711420
13721421 if ( $col_info->{auto_nextval} ) {
1373 $updated_cols->{$col} = $to_insert->{$col} = $self->_sequence_fetch(
1422 $upd->{$col} = $to_insert->{$col} = $self->_sequence_fetch(
13741423 'nextval',
1375 $col_info->{sequence} ||
1376 $self->_dbh_get_autoinc_seq($self->_get_dbh, $source)
1424 $col_info->{sequence} ||=
1425 $self->_dbh_get_autoinc_seq($self->_get_dbh, $source, $col)
13771426 );
13781427 }
13791428 }
13801429 }
13811430
1382 $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
1431 return $upd;
1432 }
1433
1434 sub insert {
1435 my $self = shift;
1436 my ($source, $to_insert, $opts) = @_;
1437
1438 my $updated_cols = $self->_prefetch_insert_auto_nextvals (@_);
1439
1440 my $bind_attributes = $self->source_bind_attributes($source);
1441
1442 my ($rv, $sth) = $self->_execute('insert' => [], $source, $bind_attributes, $to_insert, $opts);
1443
1444 if ($opts->{returning}) {
1445 my @ret_cols = @{$opts->{returning}};
1446
1447 my @ret_vals = eval {
1448 local $SIG{__WARN__} = sub {};
1449 my @r = $sth->fetchrow_array;
1450 $sth->finish;
1451 @r;
1452 };
1453
1454 my %ret;
1455 @ret{@ret_cols} = @ret_vals if (@ret_vals);
1456
1457 $updated_cols = {
1458 %$updated_cols,
1459 %ret,
1460 };
1461 }
13831462
13841463 return $updated_cols;
13851464 }
14661545 # neither _execute_array, nor _execute_inserts_with_no_binds are
14671546 # atomic (even if _execute _array is a single call). Thus a safety
14681547 # scope guard
1469 my $guard = $self->txn_scope_guard unless $self->{transaction_depth} != 0;
1548 my $guard = $self->txn_scope_guard;
14701549
14711550 $self->_query_start( $sql, ['__BULK__'] );
14721551 my $sth = $self->sth($sql);
14831562
14841563 $self->_query_end( $sql, ['__BULK__'] );
14851564
1486
1487 $guard->commit if $guard;
1565 $guard->commit;
14881566
14891567 return (wantarray ? ($rv, $sth, @bind) : $rv);
14901568 }
15131591
15141592 my @data = map { $_->[$data_index] } @$data;
15151593
1516 $sth->bind_param_array( $placeholder_index, [@data], $attributes );
1594 $sth->bind_param_array(
1595 $placeholder_index,
1596 [@data],
1597 (%$attributes ? $attributes : ()),
1598 );
15171599 $placeholder_index++;
15181600 }
15191601
22472329 sub create_ddl_dir {
22482330 my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
22492331
2250 if(!$dir || !-d $dir) {
2332 unless ($dir) {
22512333 carp "No directory given, using ./\n";
2252 $dir = "./";
2253 }
2334 $dir = './';
2335 }
2336
2337 $self->throw_exception ("Directory '$dir' does not exist\n") unless(-d $dir);
2338
22542339 $databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
22552340 $databases = [ $databases ] if(ref($databases) ne 'ARRAY');
22562341
25482633 This hook is to allow specific L<DBIx::Class::Storage> drivers to change the
25492634 way these aliases are named.
25502635
2551 The default behavior is C<"$relname_$join_count" if $join_count > 1>, otherwise
2552 C<"$relname">.
2636 The default behavior is C<< "$relname_$join_count" if $join_count > 1 >>,
2637 otherwise C<"$relname">.
25532638
25542639 =cut
25552640
+100
-40
lib/DBIx/Class/Storage/DBIHacks.pm less more
163163 while (my $j = shift @$from) {
164164 my $alias = $j->[0]{-alias};
165165
166 if ($outer_aliastypes->{select}{$alias}) {
166 if ($outer_aliastypes->{selecting}{$alias}) {
167167 push @outer_from, $j;
168168 }
169 elsif ($outer_aliastypes->{restrict}{$alias}) {
169 elsif ($outer_aliastypes->{restricting}{$alias}) {
170170 push @outer_from, $j;
171171 $outer_attrs->{group_by} ||= $outer_select unless $j->[0]{-is_single};
172172 }
185185 return (\@outer_from, $outer_select, $where, $outer_attrs);
186186 }
187187
188 #
189 # I KNOW THIS SUCKS! GET SQLA2 OUT THE DOOR SO THIS CAN DIE!
190 #
188191 # Due to a lack of SQLA2 we fall back to crude scans of all the
189192 # select/where/order/group attributes, in order to determine what
190193 # aliases are neded to fulfill the query. This information is used
191194 # throughout the code to prune unnecessary JOINs from the queries
192195 # in an attempt to reduce the execution time.
193196 # Although the method is pretty horrific, the worst thing that can
194 # happen is for it to fail due to an unqualified column, which in
195 # turn will result in a vocal exception. Qualifying the column will
196 # invariably solve the problem.
197 # happen is for it to fail due to some scalar SQL, which in turn will
198 # result in a vocal exception.
197199 sub _resolve_aliastypes_from_select_args {
198200 my ( $self, $from, $select, $where, $attrs ) = @_;
199201
216218 unless $j->{-is_single};
217219 }
218220
221 # get a column to source/alias map (including unqualified ones)
222 my $colinfo = $self->_resolve_column_info ($from);
223
219224 # set up a botched SQLA
220225 my $sql_maker = $self->sql_maker;
221226 my $sep = quotemeta ($self->_sql_maker_opts->{name_sep} || '.');
222 local $sql_maker->{quote_char}; # so that we can regex away
223
224
225 my $select_sql = $sql_maker->_recurse_fields ($select);
226 my $where_sql = $sql_maker->where ($where);
227 my $group_by_sql = $sql_maker->_order_by({
228 map { $_ => $attrs->{$_} } qw/group_by having/
227
228 my ($orig_lquote, $orig_rquote) = map { quotemeta $_ } (do {
229 if (ref $sql_maker->{quote_char} eq 'ARRAY') {
230 @{$sql_maker->{quote_char}}
231 }
232 else {
233 ($sql_maker->{quote_char} || '') x 2;
234 }
229235 });
230 my @order_by_chunks = ($self->_parse_order_by ($attrs->{order_by}) );
231
232 # match every alias to the sql chunks above
236
237 local $sql_maker->{quote_char} = "\x00"; # so that we can regex away
238
239 # generate sql chunks
240 my $to_scan = {
241 restricting => [
242 $sql_maker->_recurse_where ($where),
243 $sql_maker->_order_by({
244 map { $_ => $attrs->{$_} } (qw/group_by having/)
245 }),
246 ],
247 selecting => [
248 $self->_parse_order_by ($attrs->{order_by}, $sql_maker),
249 $sql_maker->_recurse_fields ($select),
250 ],
251 };
252
253 # throw away empty chunks
254 $_ = [ map { $_ || () } @$_ ] for values %$to_scan;
255
256 # first loop through all fully qualified columns and get the corresponding
257 # alias (should work even if they are in scalarrefs)
233258 for my $alias (keys %$alias_list) {
234 my $al_re = qr/\b $alias $sep/x;
235
236 for my $piece ($where_sql, $group_by_sql) {
237 $aliases_by_type->{restrict}{$alias} = 1 if ($piece =~ $al_re);
238 }
239
240 for my $piece ($select_sql, @order_by_chunks ) {
241 $aliases_by_type->{select}{$alias} = 1 if ($piece =~ $al_re);
259 my $al_re = qr/
260 \x00 $alias \x00 $sep
261 |
262 \b $alias $sep
263 /x;
264
265 # add matching for possible quoted literal sql
266 $al_re = qr/ $al_re | $orig_lquote $alias $orig_rquote /x
267 if ($orig_lquote && $orig_rquote);
268
269
270 for my $type (keys %$to_scan) {
271 for my $piece (@{$to_scan->{$type}}) {
272 $aliases_by_type->{$type}{$alias} = 1 if ($piece =~ $al_re);
273 }
274 }
275 }
276
277 # now loop through unqualified column names, and try to locate them within
278 # the chunks
279 for my $col (keys %$colinfo) {
280 next if $col =~ $sep; # if column is qualified it was caught by the above
281
282 my $col_re = qr/ \x00 $col \x00 /x;
283
284 $col_re = qr/ $col_re | $orig_lquote $col $orig_rquote /x
285 if ($orig_lquote && $orig_rquote);
286
287 for my $type (keys %$to_scan) {
288 for my $piece (@{$to_scan->{$type}}) {
289 $aliases_by_type->{$type}{$colinfo->{$col}{-source_alias}} = 1 if ($piece =~ $col_re);
290 }
242291 }
243292 }
244293
245294 # Add any non-left joins to the restriction list (such joins are indeed restrictions)
246295 for my $j (values %$alias_list) {
247296 my $alias = $j->{-alias} or next;
248 $aliases_by_type->{restrict}{$alias} = 1 if (
297 $aliases_by_type->{restricting}{$alias} = 1 if (
249298 (not $j->{-join_type})
250299 or
251300 ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi)
257306 for my $type (keys %$aliases_by_type) {
258307 for my $alias (keys %{$aliases_by_type->{$type}}) {
259308 $aliases_by_type->{$type}{$_} = 1
260 for (map { keys %$_ } @{ $alias_list->{$alias}{-join_path} || [] });
309 for (map { values %$_ } @{ $alias_list->{$alias}{-join_path} || [] });
261310 }
262311 }
263312
402451 # anyway, and deep cloning is just too fucking expensive
403452 # So replace the first hashref in the node arrayref manually
404453 my @new_from = ($from->[0]);
405 my $sw_idx = { map { values %$_ => 1 } @$switch_branch };
454 my $sw_idx = { map { (values %$_), 1 } @$switch_branch }; #there's one k/v per join-path
406455
407456 for my $j (@{$from}[1 .. $#$from]) {
408457 my $jalias = $j->[0]{-alias};
484533 }
485534
486535 sub _parse_order_by {
487 my ($self, $order_by) = @_;
488
489 return scalar $self->sql_maker->_order_by_chunks ($order_by)
490 unless wantarray;
491
492 my $sql_maker = $self->sql_maker;
493 local $sql_maker->{quote_char}; #disable quoting
494 my @chunks;
495 for my $chunk (map { ref $_ ? @$_ : $_ } ($sql_maker->_order_by_chunks ($order_by) ) ) {
496 $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
497 push @chunks, $chunk;
498 }
499
500 return @chunks;
536 my ($self, $order_by, $sql_maker) = @_;
537
538 my $parser = sub {
539 my ($sql_maker, $order_by) = @_;
540
541 return scalar $sql_maker->_order_by_chunks ($order_by)
542 unless wantarray;
543
544 my @chunks;
545 for my $chunk (map { ref $_ ? @$_ : $_ } ($sql_maker->_order_by_chunks ($order_by) ) ) {
546 $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
547 push @chunks, $chunk;
548 }
549
550 return @chunks;
551 };
552
553 if ($sql_maker) {
554 return $parser->($sql_maker, $order_by);
555 }
556 else {
557 $sql_maker = $self->sql_maker;
558 local $sql_maker->{quote_char};
559 return $parser->($sql_maker, $order_by);
560 }
501561 }
502562
503563 1;
+201
-201
lib/DBIx/Class/Storage/Statistics.pm less more
0 package DBIx::Class::Storage::Statistics;
1 use strict;
2 use warnings;
3
4 use base qw/DBIx::Class/;
5 use IO::File;
6
7 __PACKAGE__->mk_group_accessors(simple => qw/callback debugfh silence/);
8
9 =head1 NAME
10
11 DBIx::Class::Storage::Statistics - SQL Statistics
12
13 =head1 SYNOPSIS
14
15 =head1 DESCRIPTION
16
17 This class is called by DBIx::Class::Storage::DBI as a means of collecting
18 statistics on its actions. Using this class alone merely prints the SQL
19 executed, the fact that it completes and begin/end notification for
20 transactions.
21
22 To really use this class you should subclass it and create your own method
23 for collecting the statistics as discussed in L<DBIx::Class::Manual::Cookbook>.
24
25 =head1 METHODS
26
27 =cut
28
29 =head2 new
30
31 Returns a new L<DBIx::Class::Storage::Statistics> object.
32
33 =cut
34 sub new {
35 my $self = {};
36 bless $self, (ref($_[0]) || $_[0]);
37
38 return $self;
39 }
40
41 =head2 debugfh
42
43 Sets or retrieves the filehandle used for trace/debug output. This should
44 be an IO::Handle compatible object (only the C<print> method is used). Initially
45 should be set to STDERR - although see information on the
46 L<DBIC_TRACE> environment variable.
47
48 =head2 print
49
50 Prints the specified string to our debugging filehandle, which we will attempt
51 to open if we haven't yet. Provided to save our methods the worry of how
52 to display the message.
53
54 =cut
55 sub print {
56 my ($self, $msg) = @_;
57
58 return if $self->silence;
59
60 if(!defined($self->debugfh())) {
61 my $fh;
62 my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
63 || $ENV{DBIC_TRACE};
64 if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
65 $fh = IO::File->new($1, 'w')
66 or die("Cannot open trace file $1");
67 } else {
68 $fh = IO::File->new('>&STDERR')
69 or die('Duplication of STDERR for debug output failed (perhaps your STDERR is closed?)');
70 }
71
72 $fh->autoflush();
73 $self->debugfh($fh);
74 }
75
76 $self->debugfh->print($msg);
77 }
78
79 =head2 silence
80
81 Turn off all output if set to true.
82
83 =head2 txn_begin
84
85 Called when a transaction begins.
86
87 =cut
88 sub txn_begin {
89 my $self = shift;
90
91 return if $self->callback;
92
93 $self->print("BEGIN WORK\n");
94 }
95
96 =head2 txn_rollback
97
98 Called when a transaction is rolled back.
99
100 =cut
101 sub txn_rollback {
102 my $self = shift;
103
104 return if $self->callback;
105
106 $self->print("ROLLBACK\n");
107 }
108
109 =head2 txn_commit
110
111 Called when a transaction is committed.
112
113 =cut
114 sub txn_commit {
115 my $self = shift;
116
117 return if $self->callback;
118
119 $self->print("COMMIT\n");
120 }
121
122 =head2 svp_begin
123
124 Called when a savepoint is created.
125
126 =cut
127 sub svp_begin {
128 my ($self, $name) = @_;
129
130 return if $self->callback;
131
132 $self->print("SAVEPOINT $name\n");
133 }
134
135 =head2 svp_release
136
137 Called when a savepoint is released.
138
139 =cut
140 sub svp_release {
141 my ($self, $name) = @_;
142
143 return if $self->callback;
144
145 $self->print("RELEASE SAVEPOINT $name\n");
146 }
147
148 =head2 svp_rollback
149
150 Called when rolling back to a savepoint.
151
152 =cut
153 sub svp_rollback {
154 my ($self, $name) = @_;
155
156 return if $self->callback;
157
158 $self->print("ROLLBACK TO SAVEPOINT $name\n");
159 }
160
161 =head2 query_start
162
163 Called before a query is executed. The first argument is the SQL string being
164 executed and subsequent arguments are the parameters used for the query.
165
166 =cut
167 sub query_start {
168 my ($self, $string, @bind) = @_;
169
170 my $message = "$string: ".join(', ', @bind)."\n";
171
172 if(defined($self->callback)) {
173 $string =~ m/^(\w+)/;
174 $self->callback->($1, $message);
175 return;
176 }
177
178 $self->print($message);
179 }
180
181 =head2 query_end
182
183 Called when a query finishes executing. Has the same arguments as query_start.
184
185 =cut
186 sub query_end {
187 my ($self, $string) = @_;
188 }
189
190 1;
191
192 =head1 AUTHORS
193
194 Cory G. Watson <gphat@cpan.org>
195
196 =head1 LICENSE
197
198 You may distribute this code under the same license as Perl itself.
199
200 =cut
0 package DBIx::Class::Storage::Statistics;
1 use strict;
2 use warnings;
3
4 use base qw/DBIx::Class/;
5 use IO::File;
6
7 __PACKAGE__->mk_group_accessors(simple => qw/callback debugfh silence/);
8
9 =head1 NAME
10
11 DBIx::Class::Storage::Statistics - SQL Statistics
12
13 =head1 SYNOPSIS
14
15 =head1 DESCRIPTION
16
17 This class is called by DBIx::Class::Storage::DBI as a means of collecting
18 statistics on its actions. Using this class alone merely prints the SQL
19 executed, the fact that it completes and begin/end notification for
20 transactions.
21
22 To really use this class you should subclass it and create your own method
23 for collecting the statistics as discussed in L<DBIx::Class::Manual::Cookbook>.
24
25 =head1 METHODS
26
27 =cut
28
29 =head2 new
30
31 Returns a new L<DBIx::Class::Storage::Statistics> object.
32
33 =cut
34 sub new {
35 my $self = {};
36 bless $self, (ref($_[0]) || $_[0]);
37
38 return $self;
39 }
40
41 =head2 debugfh
42
43 Sets or retrieves the filehandle used for trace/debug output. This should
44 be an IO::Handle compatible object (only the C<print> method is used). Initially
45 should be set to STDERR - although see information on the
46 L<DBIC_TRACE> environment variable.
47
48 =head2 print
49
50 Prints the specified string to our debugging filehandle, which we will attempt
51 to open if we haven't yet. Provided to save our methods the worry of how
52 to display the message.
53
54 =cut
55 sub print {
56 my ($self, $msg) = @_;
57
58 return if $self->silence;
59
60 if(!defined($self->debugfh())) {
61 my $fh;
62 my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
63 || $ENV{DBIC_TRACE};
64 if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
65 $fh = IO::File->new($1, 'w')
66 or die("Cannot open trace file $1");
67 } else {
68 $fh = IO::File->new('>&STDERR')
69 or die('Duplication of STDERR for debug output failed (perhaps your STDERR is closed?)');
70 }
71
72 $fh->autoflush();
73 $self->debugfh($fh);
74 }
75
76 $self->debugfh->print($msg);
77 }
78
79 =head2 silence
80
81 Turn off all output if set to true.
82
83 =head2 txn_begin
84
85 Called when a transaction begins.
86
87 =cut
88 sub txn_begin {
89 my $self = shift;
90
91 return if $self->callback;
92
93 $self->print("BEGIN WORK\n");
94 }
95
96 =head2 txn_rollback
97
98 Called when a transaction is rolled back.
99
100 =cut
101 sub txn_rollback {
102 my $self = shift;
103
104 return if $self->callback;
105
106 $self->print("ROLLBACK\n");
107 }
108
109 =head2 txn_commit
110
111 Called when a transaction is committed.
112
113 =cut
114 sub txn_commit {
115 my $self = shift;
116
117 return if $self->callback;
118
119 $self->print("COMMIT\n");
120 }
121
122 =head2 svp_begin
123
124 Called when a savepoint is created.
125
126 =cut
127 sub svp_begin {
128 my ($self, $name) = @_;
129
130 return if $self->callback;
131
132 $self->print("SAVEPOINT $name\n");
133 }
134
135 =head2 svp_release
136
137 Called when a savepoint is released.
138
139 =cut
140 sub svp_release {
141 my ($self, $name) = @_;
142
143 return if $self->callback;
144
145 $self->print("RELEASE SAVEPOINT $name\n");
146 }
147
148 =head2 svp_rollback
149
150 Called when rolling back to a savepoint.
151
152 =cut
153 sub svp_rollback {
154 my ($self, $name) = @_;
155
156 return if $self->callback;
157
158 $self->print("ROLLBACK TO SAVEPOINT $name\n");
159 }
160
161 =head2 query_start
162
163 Called before a query is executed. The first argument is the SQL string being
164 executed and subsequent arguments are the parameters used for the query.
165
166 =cut
167 sub query_start {
168 my ($self, $string, @bind) = @_;
169
170 my $message = "$string: ".join(', ', @bind)."\n";
171
172 if(defined($self->callback)) {
173 $string =~ m/^(\w+)/;
174 $self->callback->($1, $message);
175 return;
176 }
177
178 $self->print($message);
179 }
180
181 =head2 query_end
182
183 Called when a query finishes executing. Has the same arguments as query_start.
184
185 =cut
186 sub query_end {
187 my ($self, $string) = @_;
188 }
189
190 1;
191
192 =head1 AUTHORS
193
194 Cory G. Watson <gphat@cpan.org>
195
196 =head1 LICENSE
197
198 You may distribute this code under the same license as Perl itself.
199
200 =cut
+48
-3
lib/DBIx/Class/UTF8Columns.pm less more
66
77 =head1 NAME
88
9 DBIx::Class::UTF8Columns - Force UTF8 (Unicode) flag on columns
9 DBIx::Class::UTF8Columns - Force UTF8 (Unicode) flag on columns (DEPRECATED)
1010
1111 =head1 SYNOPSIS
1212
2222
2323 =head1 DESCRIPTION
2424
25 This module allows you to get columns data that have utf8 (Unicode) flag.
25 This module allows you to get and store utf8 (unicode) column data
26 in a database that does not natively support unicode. It ensures
27 that column data is correctly serialised as a byte stream when
28 stored and de-serialised to unicode strings on retrieval.
2629
27 =head2 Warning
30 THE USE OF THIS MODULE (AND ITS COUSIN DBIx::Class::ForceUTF8) IS VERY
31 STRONGLY DISCOURAGED, PLEASE READ THE WARNINGS BELOW FOR AN EXPLANATION.
32
33 If you want to continue using this module and do not want to recieve
34 further warnings set the environmane variable C<DBIC_UTF8COLUMNS_OK>
35 to a true value.
36
37 =head2 Warning - Module does not function properly on create/insert
38
39 Recently (April 2010) a bug was found deep in the core of L<DBIx::Class>
40 which affects any component attempting to perform encoding/decoding by
41 overloading L<store_column|DBIx::Class::Row/store_column> and
42 L<get_columns|DBIx::Class::Row/get_columns>. As a result of this problem
43 L<create|DBIx::Class::ResultSet/create> sends the original column values
44 to the database, while L<update|DBIx::Class::ResultSet/update> sends the
45 encoded values. L<DBIx::Class::UTF8Columns> and L<DBIx::Class::ForceUTF8>
46 are both affected by ths bug.
47
48 It is unclear how this bug went undetected for so long (it was
49 introduced in March 2006), No attempts to fix it will be made while the
50 implications of changing such a fundamental behavior of DBIx::Class are
51 being evaluated. However in this day and age you should not be using
52 this module anyway as Unicode is properly supported by all major
53 database engines, as explained below.
54
55 If you have specific questions about the integrity of your data in light
56 of this development - please
57 L<join us on IRC or the mailing list|DBIx::Class/GETTING HELP/SUPPORT>
58 to further discuss your concerns with the team.
59
60 =head2 Warning - Native Database Unicode Support
61
62 If your database natively supports Unicode (as does SQLite with the
63 C<sqlite_unicode> connect flag, MySQL with C<mysql_enable_utf8>
64 connect flag or Postgres with the C<pg_enable_utf8> connect flag),
65 then this component should B<not> be used, and will corrupt unicode
66 data in a subtle and unexpected manner.
67
68 It is far better to do Unicode support within the database if
69 possible rather than converting data to and from raw bytes on every
70 database round trip.
71
72 =head2 Warning - Component Overloading
2873
2974 Note that this module overloads L<DBIx::Class::Row/store_column> in a way
3075 that may prevent other components overloading the same method from working
+8
-2
lib/DBIx/Class.pm less more
2626 # Always remember to do all digits for the version even if they're 0
2727 # i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
2828 # brain damage and presumably various other packaging systems too
29 $VERSION = '0.08120';
29 $VERSION = '0.08121';
3030
3131 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
3232
217217
218218 =head1 CONTRIBUTORS
219219
220 abraxxa: Alexander Hartmaier <alex_hartmaier@hotmail.com>
220 abraxxa: Alexander Hartmaier <abraxxa@cpan.org>
221221
222222 aherzog: Adam Herzog <adam@herzogdesigns.com>
223223
224 amoore: Andrew Moore <amoore@cpan.org>
225
224226 andyg: Andy Grundman <andy@hybridized.org>
225227
226228 ank: Andres Kievsky
259261
260262 dnm: Justin Wheeler <jwheeler@datademons.com>
261263
264 dpetrov: Dimitar Petrov <mitakaa@gmail.com>
265
262266 dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
263267
264268 dyfrgi: Michael Leuchtenburg <michael@slashhome.org>
270274 gphat: Cory G Watson <gphat@cpan.org>
271275
272276 groditi: Guillermo Roditi <groditi@cpan.org>
277
278 hobbs: Andrew Rodland <arodland@cpan.org>
273279
274280 ilmari: Dagfinn Ilmari MannsE<aring>ker <ilmari@ilmari.org>
275281
+158
-158
lib/SQL/Translator/Producer/DBIx/Class/File.pm less more
0 package SQL::Translator::Producer::DBIx::Class::File;
1
2 =head1 NAME
3
4 SQL::Translator::Producer::DBIx::Class::File - DBIx::Class file producer
5
6 =head1 SYNOPSIS
7
8 use SQL::Translator;
9
10 my $t = SQL::Translator->new( parser => '...',
11 producer => 'DBIx::Class::File' );
12 print $translator->translate( $file );
13
14 =head1 DESCRIPTION
15
16 Creates a DBIx::Class::Schema for use with DBIx::Class
17
18 =cut
19
20 use strict;
21 use vars qw[ $VERSION $DEBUG $WARN ];
22 $VERSION = '0.1';
23 $DEBUG = 0 unless defined $DEBUG;
24
25 use SQL::Translator::Schema::Constants;
26 use SQL::Translator::Utils qw(header_comment);
27 use Data::Dumper ();
28
29 ## Skip all column type translation, as we want to use whatever the parser got.
30
31 ## Translate parsers -> PK::Auto::Foo, however
32
33 my %parser2PK = (
34 MySQL => 'PK::Auto::MySQL',
35 PostgreSQL => 'PK::Auto::Pg',
36 DB2 => 'PK::Auto::DB2',
37 Oracle => 'PK::Auto::Oracle',
38 );
39
40 sub produce
41 {
42 my ($translator) = @_;
43 $DEBUG = $translator->debug;
44 $WARN = $translator->show_warnings;
45 my $no_comments = $translator->no_comments;
46 my $add_drop_table = $translator->add_drop_table;
47 my $schema = $translator->schema;
48 my $output = '';
49
50 # Steal the XML producers "prefix" arg for our namespace?
51 my $dbixschema = $translator->producer_args()->{prefix} ||
52 $schema->name || 'My::Schema';
53 my $pkclass = $parser2PK{$translator->parser_type} || '';
54
55 my %tt_vars = ();
56 $tt_vars{dbixschema} = $dbixschema;
57 $tt_vars{pkclass} = $pkclass;
58
59 my $schemaoutput .= << "DATA";
60
61 package ${dbixschema};
62 use base 'DBIx::Class::Schema';
63 use strict;
64 use warnings;
65 DATA
66
67 my %tableoutput = ();
68 my %tableextras = ();
69 foreach my $table ($schema->get_tables)
70 {
71 my $tname = $table->name;
72 my $output .= qq{
73
74 package ${dbixschema}::${tname};
75 use base 'DBIx::Class';
76 use strict;
77 use warnings;
78
79 __PACKAGE__->load_components(qw/${pkclass} Core/);
80 __PACKAGE__->table('${tname}');
81
82 };
83
84 my @fields = map
85 { { $_->name => {
86 name => $_->name,
87 is_auto_increment => $_->is_auto_increment,
88 is_foreign_key => $_->is_foreign_key,
89 is_nullable => $_->is_nullable,
90 default_value => $_->default_value,
91 data_type => $_->data_type,
92 size => $_->size,
93 } }
94 } ($table->get_fields);
95
96 $output .= "\n__PACKAGE__->add_columns(";
97 foreach my $f (@fields)
98 {
99 local $Data::Dumper::Terse = 1;
100 $output .= "\n '" . (keys %$f)[0] . "' => " ;
101 my $colinfo =
102 Data::Dumper->Dump([values %$f],
103 [''] # keys %$f]
104 );
105 chomp($colinfo);
106 $output .= $colinfo . ",";
107 }
108 $output .= "\n);\n";
109
110 my $pk = $table->primary_key;
111 if($pk)
112 {
113 my @pk = map { $_->name } ($pk->fields);
114 $output .= "__PACKAGE__->set_primary_key(";
115 $output .= "'" . join("', '", @pk) . "');\n";
116 }
117
118 foreach my $cont ($table->get_constraints)
119 {
120 # print Data::Dumper::Dumper($cont->type);
121 if($cont->type =~ /foreign key/i)
122 {
123 # $output .= "\n__PACKAGE__->belongs_to('" .
124 # $cont->fields->[0]->name . "', '" .
125 # "${dbixschema}::" . $cont->reference_table . "');\n";
126
127 $tableextras{$table->name} .= "\n__PACKAGE__->belongs_to('" .
128 $cont->fields->[0]->name . "', '" .
129 "${dbixschema}::" . $cont->reference_table . "');\n";
130
131 my $other = "\n__PACKAGE__->has_many('" .
132 "get_" . $table->name. "', '" .
133 "${dbixschema}::" . $table->name. "', '" .
134 $cont->fields->[0]->name . "');";
135 $tableextras{$cont->reference_table} .= $other;
136 }
137 }
138
139 $tableoutput{$table->name} .= $output;
140 }
141
142 foreach my $to (keys %tableoutput)
143 {
144 $output .= $tableoutput{$to};
145 $schemaoutput .= "\n__PACKAGE__->register_class('${to}', '${dbixschema}::${to}');\n";
146 }
147
148 foreach my $te (keys %tableextras)
149 {
150 $output .= "\npackage ${dbixschema}::$te;\n";
151 $output .= $tableextras{$te} . "\n";
152 # $tableoutput{$te} .= $tableextras{$te} . "\n";
153 }
154
155 # print "$output\n";
156 return "${output}\n\n${schemaoutput}\n1;\n";
157 }
0 package SQL::Translator::Producer::DBIx::Class::File;
1
2 =head1 NAME
3
4 SQL::Translator::Producer::DBIx::Class::File - DBIx::Class file producer
5
6 =head1 SYNOPSIS
7
8 use SQL::Translator;
9
10 my $t = SQL::Translator->new( parser => '...',
11 producer => 'DBIx::Class::File' );
12 print $translator->translate( $file );
13
14 =head1 DESCRIPTION
15
16 Creates a DBIx::Class::Schema for use with DBIx::Class
17
18 =cut
19
20 use strict;
21 use vars qw[ $VERSION $DEBUG $WARN ];
22 $VERSION = '0.1';
23 $DEBUG = 0 unless defined $DEBUG;
24
25 use SQL::Translator::Schema::Constants;
26 use SQL::Translator::Utils qw(header_comment);
27 use Data::Dumper ();
28
29 ## Skip all column type translation, as we want to use whatever the parser got.
30
31 ## Translate parsers -> PK::Auto::Foo, however
32
33 my %parser2PK = (
34 MySQL => 'PK::Auto::MySQL',
35 PostgreSQL => 'PK::Auto::Pg',
36 DB2 => 'PK::Auto::DB2',
37 Oracle => 'PK::Auto::Oracle',
38 );
39
40 sub produce
41 {
42 my ($translator) = @_;
43 $DEBUG = $translator->debug;
44 $WARN = $translator->show_warnings;
45 my $no_comments = $translator->no_comments;
46 my $add_drop_table = $translator->add_drop_table;
47 my $schema = $translator->schema;
48 my $output = '';
49
50 # Steal the XML producers "prefix" arg for our namespace?
51 my $dbixschema = $translator->producer_args()->{prefix} ||
52 $schema->name || 'My::Schema';
53 my $pkclass = $parser2PK{$translator->parser_type} || '';
54
55 my %tt_vars = ();
56 $tt_vars{dbixschema} = $dbixschema;
57 $tt_vars{pkclass} = $pkclass;
58
59 my $schemaoutput .= << "DATA";
60
61 package ${dbixschema};
62 use base 'DBIx::Class::Schema';
63 use strict;
64 use warnings;
65 DATA
66
67 my %tableoutput = ();
68 my %tableextras = ();
69 foreach my $table ($schema->get_tables)
70 {
71 my $tname = $table->name;
72 my $output .= qq{
73
74 package ${dbixschema}::${tname};
75 use base 'DBIx::Class';
76 use strict;
77 use warnings;
78
79 __PACKAGE__->load_components(qw/${pkclass} Core/);
80 __PACKAGE__->table('${tname}');
81
82 };
83
84 my @fields = map
85 { { $_->name => {
86 name => $_->name,
87 is_auto_increment => $_->is_auto_increment,
88 is_foreign_key => $_->is_foreign_key,
89 is_nullable => $_->is_nullable,
90 default_value => $_->default_value,
91 data_type => $_->data_type,
92 size => $_->size,
93 } }
94 } ($table->get_fields);
95
96 $output .= "\n__PACKAGE__->add_columns(";
97 foreach my $f (@fields)
98 {
99 local $Data::Dumper::Terse = 1;
100 $output .= "\n '" . (keys %$f)[0] . "' => " ;
101 my $colinfo =
102 Data::Dumper->Dump([values %$f],
103 [''] # keys %$f]
104 );
105 chomp($colinfo);
106 $output .= $colinfo . ",";
107 }
108 $output .= "\n);\n";
109
110 my $pk = $table->primary_key;
111 if($pk)
112 {
113 my @pk = map { $_->name } ($pk->fields);
114 $output .= "__PACKAGE__->set_primary_key(";
115 $output .= "'" . join("', '", @pk) . "');\n";
116 }
117
118 foreach my $cont ($table->get_constraints)
119 {
120 # print Data::Dumper::Dumper($cont->type);
121 if($cont->type =~ /foreign key/i)
122 {
123 # $output .= "\n__PACKAGE__->belongs_to('" .
124 # $cont->fields->[0]->name . "', '" .
125 # "${dbixschema}::" . $cont->reference_table . "');\n";
126
127 $tableextras{$table->name} .= "\n__PACKAGE__->belongs_to('" .
128 $cont->fields->[0]->name . "', '" .
129 "${dbixschema}::" . $cont->reference_table . "');\n";
130
131 my $other = "\n__PACKAGE__->has_many('" .
132 "get_" . $table->name. "', '" .
133 "${dbixschema}::" . $table->name. "', '" .
134 $cont->fields->[0]->name . "');";
135 $tableextras{$cont->reference_table} .= $other;
136 }
137 }
138
139 $tableoutput{$table->name} .= $output;
140 }
141
142 foreach my $to (keys %tableoutput)
143 {
144 $output .= $tableoutput{$to};
145 $schemaoutput .= "\n__PACKAGE__->register_class('${to}', '${dbixschema}::${to}');\n";
146 }
147
148 foreach my $te (keys %tableextras)
149 {
150 $output .= "\npackage ${dbixschema}::$te;\n";
151 $output .= $tableextras{$te} . "\n";
152 # $tableoutput{$te} .= $tableextras{$te} . "\n";
153 }
154
155 # print "$output\n";
156 return "${output}\n\n${schemaoutput}\n1;\n";
157 }
+0
-6
script/dbicadmin less more
216216
217217 =cut
218218
219 =item B<--selfinject-pod>
220
221 hidden
222
223 =cut
224
225219 =back
226220
227221 =head2 Arguments
+34
-34
t/04dont_break_c3.t less more
0
1 use strict;
2 use Test::More tests => 2;
3 use MRO::Compat;
4
5 use lib qw(t/lib);
6 use DBICTest; # do not remove even though it is not used
7
8 {
9 package AAA;
10
11 use base "DBIx::Class::Core";
12
13 package BBB;
14
15 use base 'AAA';
16
17 #Injecting a direct parent.
18 __PACKAGE__->inject_base( __PACKAGE__, 'AAA' );
19
20
21 package CCC;
22
23 use base 'AAA';
24
25 #Injecting an indirect parent.
26 __PACKAGE__->inject_base( __PACKAGE__, 'DBIx::Class::Core' );
27 }
28
29 eval { mro::get_linear_isa('BBB'); };
30 ok (! $@, "Correctly skipped injecting a direct parent of class BBB");
31
32 eval { mro::get_linear_isa('CCC'); };
33 ok (! $@, "Correctly skipped injecting an indirect parent of class BBB");
0
1 use strict;
2 use Test::More tests => 2;
3 use MRO::Compat;
4
5 use lib qw(t/lib);
6 use DBICTest; # do not remove even though it is not used
7
8 {
9 package AAA;
10
11 use base "DBIx::Class::Core";
12
13 package BBB;
14
15 use base 'AAA';
16
17 #Injecting a direct parent.
18 __PACKAGE__->inject_base( __PACKAGE__, 'AAA' );
19
20
21 package CCC;
22
23 use base 'AAA';
24
25 #Injecting an indirect parent.
26 __PACKAGE__->inject_base( __PACKAGE__, 'DBIx::Class::Core' );
27 }
28
29 eval { mro::get_linear_isa('BBB'); };
30 ok (! $@, "Correctly skipped injecting a direct parent of class BBB");
31
32 eval { mro::get_linear_isa('CCC'); };
33 ok (! $@, "Correctly skipped injecting an indirect parent of class BBB");
+39
-39
t/05components.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7 use DBICTest::ForeignComponent;
8
9 # Tests if foreign component was loaded by calling foreign's method
10 ok( DBICTest::ForeignComponent->foreign_test_method, 'foreign component' );
11
12 # Test for inject_base to filter out duplicates
13 { package DBICTest::_InjectBaseTest;
14 use base qw/ DBIx::Class /;
15 package DBICTest::_InjectBaseTest::A;
16 package DBICTest::_InjectBaseTest::B;
17 package DBICTest::_InjectBaseTest::C;
18 }
19 DBICTest::_InjectBaseTest->inject_base( 'DBICTest::_InjectBaseTest', qw/
20 DBICTest::_InjectBaseTest::A
21 DBICTest::_InjectBaseTest::B
22 DBICTest::_InjectBaseTest::B
23 DBICTest::_InjectBaseTest::C
24 /);
25 is_deeply( \@DBICTest::_InjectBaseTest::ISA,
26 [qw/
27 DBICTest::_InjectBaseTest::A
28 DBICTest::_InjectBaseTest::B
29 DBICTest::_InjectBaseTest::C
30 DBIx::Class
31 /],
32 'inject_base filters duplicates'
33 );
34
35 use_ok('DBIx::Class::AccessorGroup');
36 use_ok('DBIx::Class::Componentised');
37
38 done_testing;
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7 use DBICTest::ForeignComponent;
8
9 # Tests if foreign component was loaded by calling foreign's method
10 ok( DBICTest::ForeignComponent->foreign_test_method, 'foreign component' );
11
12 # Test for inject_base to filter out duplicates
13 { package DBICTest::_InjectBaseTest;
14 use base qw/ DBIx::Class /;
15 package DBICTest::_InjectBaseTest::A;
16 package DBICTest::_InjectBaseTest::B;
17 package DBICTest::_InjectBaseTest::C;
18 }
19 DBICTest::_InjectBaseTest->inject_base( 'DBICTest::_InjectBaseTest', qw/
20 DBICTest::_InjectBaseTest::A
21 DBICTest::_InjectBaseTest::B
22 DBICTest::_InjectBaseTest::B
23 DBICTest::_InjectBaseTest::C
24 /);
25 is_deeply( \@DBICTest::_InjectBaseTest::ISA,
26 [qw/
27 DBICTest::_InjectBaseTest::A
28 DBICTest::_InjectBaseTest::B
29 DBICTest::_InjectBaseTest::C
30 DBIx::Class
31 /],
32 'inject_base filters duplicates'
33 );
34
35 use_ok('DBIx::Class::AccessorGroup');
36 use_ok('DBIx::Class::Componentised');
37
38 done_testing;
+10
-16
t/06notabs.t less more
44 use lib 't/lib';
55 use DBICTest;
66
7 my @MODULES = (
8 'Test::NoTabs 0.9',
9 );
10
11 plan skip_all => 'Does not work with done_testing, temp disabled';
12
137 # Don't run tests for installs
148 unless ( DBICTest::AuthorCheck->is_author || $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING} ) {
159 plan( skip_all => "Author tests not required for installation" );
1610 }
17 # Load the testing modules
18 foreach my $MODULE ( @MODULES ) {
19 eval "use $MODULE";
20 if ( $@ ) {
21 $ENV{RELEASE_TESTING}
22 ? die( "Failed to load required release-testing module $MODULE" )
23 : plan( skip_all => "$MODULE not available for testing" );
24 }
11
12 require DBIx::Class;
13 unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_notabs') ) {
14 my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_notabs');
15 $ENV{RELEASE_TESTING} || DBICTest::AuthorCheck->is_author
16 ? die ("Failed to load release-testing module requirements: $missing")
17 : plan skip_all => "Test needs: $missing"
2518 }
2619
27 all_perl_files_ok(qw/t lib script maint/);
20 Test::NoTabs::all_perl_files_ok(qw/t lib script maint/);
2821
29 done_testing;
22 # FIXME - need to fix Test::NoTabs
23 #done_testing;
+12
-16
t/07eol.t less more
44 use lib 't/lib';
55 use DBICTest;
66
7 my @MODULES = (
8 'Test::EOL 0.6',
9 );
10
11 plan skip_all => 'Does not work with done_testing, temp disabled';
12
137 # Don't run tests for installs
148 unless ( DBICTest::AuthorCheck->is_author || $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING} ) {
159 plan( skip_all => "Author tests not required for installation" );
1610 }
17 # Load the testing modules
18 foreach my $MODULE ( @MODULES ) {
19 eval "use $MODULE";
20 if ( $@ ) {
21 $ENV{RELEASE_TESTING}
22 ? die( "Failed to load required release-testing module $MODULE" )
23 : plan( skip_all => "$MODULE not available for testing" );
24 }
11
12 plan skip_all => 'Test::EOL very broken';
13
14 require DBIx::Class;
15 unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_eol') ) {
16 my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_eol');
17 $ENV{RELEASE_TESTING} || DBICTest::AuthorCheck->is_author
18 ? die ("Failed to load release-testing module requirements: $missing")
19 : plan skip_all => "Test needs: $missing"
2520 }
2621
2722 TODO: {
2823 local $TODO = 'Do not fix those yet - we have way too many branches out there, merging will be hell';
29 all_perl_files_ok({ trailing_whitespace => 1}, qw/t lib script maint/);
24 Test::EOL::all_perl_files_ok({ trailing_whitespace => 1}, qw/t lib script maint/);
3025 }
3126
32 done_testing;
27 # FIXME - need to fix Test::EOL
28 #done_testing;
+54
-54
t/100extra_source.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 {
8 package DBICTest::ResultSource::OtherSource;
9 use strict;
10 use warnings;
11 use base qw/DBIx::Class::ResultSource::Table/;
12 }
13
14 plan tests => 4;
15
16 my $schema = DBICTest->init_schema();
17 my $artist_source = $schema->source('Artist');
18
19 my $new_source = DBICTest::ResultSource::OtherSource->new({
20 %$artist_source,
21 name => 'artist_preview',
22 _relationships => Storable::dclone( $artist_source->_relationships ),
23 });
24
25 $new_source->add_column('other_col' => { data_type => 'integer', default_value => 1 });
26
27 my $warn = '';
28 local $SIG{__WARN__} = sub { $warn = shift };
29
30 {
31 $schema->register_extra_source( 'artist->extra' => $new_source );
32
33 my $source = $schema->source('DBICTest::Artist');
34 is($source->source_name, 'Artist', 'original source still primary source');
35 }
36
37 {
38 my $source = $schema->source('DBICTest::Artist');
39 $schema->register_source($source->source_name, $source);
40 is($warn, '', "re-registering an existing source under the same name causes no errors");
41 }
42
43 {
44 my $new_source_name = 'Artist->preview(artist_preview)';
45 $schema->register_source( $new_source_name => $new_source );
46
47 ok(($warn =~ /DBICTest::Artist already has a source, use register_extra_source for additional sources/), 'registering extra source causes errors');
48
49 my $source = $schema->source('DBICTest::Artist');
50 is($source->source_name, $new_source_name, 'original source still primary source');
51 }
52
53 1;
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 {
8 package DBICTest::ResultSource::OtherSource;
9 use strict;
10 use warnings;
11 use base qw/DBIx::Class::ResultSource::Table/;
12 }
13
14 plan tests => 4;
15
16 my $schema = DBICTest->init_schema();
17 my $artist_source = $schema->source('Artist');
18
19 my $new_source = DBICTest::ResultSource::OtherSource->new({
20 %$artist_source,
21 name => 'artist_preview',
22 _relationships => Storable::dclone( $artist_source->_relationships ),
23 });
24
25 $new_source->add_column('other_col' => { data_type => 'integer', default_value => 1 });
26
27 my $warn = '';
28 local $SIG{__WARN__} = sub { $warn = shift };
29
30 {
31 $schema->register_extra_source( 'artist->extra' => $new_source );
32
33 my $source = $schema->source('DBICTest::Artist');
34 is($source->source_name, 'Artist', 'original source still primary source');
35 }
36
37 {
38 my $source = $schema->source('DBICTest::Artist');
39 $schema->register_source($source->source_name, $source);
40 is($warn, '', "re-registering an existing source under the same name causes no errors");
41 }
42
43 {
44 my $new_source_name = 'Artist->preview(artist_preview)';
45 $schema->register_source( $new_source_name => $new_source );
46
47 ok(($warn =~ /DBICTest::Artist already has a source, use register_extra_source for additional sources/), 'registering extra source causes errors');
48
49 my $source = $schema->source('DBICTest::Artist');
50 is($source->source_name, $new_source_name, 'original source still primary source');
51 }
52
53 1;
+25
-25
t/102load_classes.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 unshift(@INC, './t/lib');
7
8 plan tests => 4;
9
10 my $warnings;
11 eval {
12 local $SIG{__WARN__} = sub { $warnings .= shift };
13 package DBICTest::Schema;
14 use base qw/DBIx::Class::Schema/;
15 __PACKAGE__->load_classes;
16 };
17 ok(!$@, 'Loaded all loadable classes') or diag $@;
18 like($warnings, qr/Failed to load DBICTest::Schema::NoSuchClass. Can't find source_name method. Is DBICTest::Schema::NoSuchClass really a full DBIC result class?/, 'Warned about broken result class');
19
20 my $source_a = DBICTest::Schema->source('Artist');
21 isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
22 my $rset_a = DBICTest::Schema->resultset('Artist');
23 isa_ok($rset_a, 'DBIx::Class::ResultSet');
24
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 unshift(@INC, './t/lib');
7
8 plan tests => 4;
9
10 my $warnings;
11 eval {
12 local $SIG{__WARN__} = sub { $warnings .= shift };
13 package DBICTest::Schema;
14 use base qw/DBIx::Class::Schema/;
15 __PACKAGE__->load_classes;
16 };
17 ok(!$@, 'Loaded all loadable classes') or diag $@;
18 like($warnings, qr/Failed to load DBICTest::Schema::NoSuchClass. Can't find source_name method. Is DBICTest::Schema::NoSuchClass really a full DBIC result class?/, 'Warned about broken result class');
19
20 my $source_a = DBICTest::Schema->source('Artist');
21 isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
22 my $rset_a = DBICTest::Schema->resultset('Artist');
23 isa_ok($rset_a, 'DBIx::Class::ResultSet');
24
+102
-102
t/103many_to_many_warning.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3
4 use lib qw(t/lib);
5
6 plan tests => 4;
7 my $exp_warn = qr/The many-to-many relationship 'bars' is trying to create/;
8
9 {
10 my @w;
11 local $SIG{__WARN__} = sub { $_[0] =~ $exp_warn ? push @w, $_[0] : warn $_[0] };
12 my $code = gen_code ( suffix => 1 );
13 eval "$code";
14 ok (! $@, 'Eval code without warnings suppression')
15 || diag $@;
16
17 ok (@w, "Warning triggered without DBIC_OVERWRITE_HELPER_METHODS_OK");
18 }
19
20 {
21 my @w;
22 local $SIG{__WARN__} = sub { $_[0] =~ $exp_warn ? push @w, $_[0] : warn $_[0] };
23
24 my $code = gen_code ( suffix => 2 );
25
26 local $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK} = 1;
27 eval "$code";
28 ok (! $@, 'Eval code with warnings suppression')
29 || diag $@;
30
31 ok (! @w, "No warning triggered with DBIC_OVERWRITE_HELPER_METHODS_OK");
32 }
33
34 sub gen_code {
35
36 my $args = { @_ };
37 my $suffix = $args->{suffix};
38
39 return <<EOF;
40 use strict;
41 use warnings;
42
43 {
44 package #
45 DBICTest::Schema::Foo${suffix};
46 use base 'DBIx::Class::Core';
47
48 __PACKAGE__->table('foo');
49 __PACKAGE__->add_columns(
50 'fooid' => {
51 data_type => 'integer',
52 is_auto_increment => 1,
53 },
54 );
55 __PACKAGE__->set_primary_key('fooid');
56
57
58 __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar${suffix}' => 'bar');
59 __PACKAGE__->many_to_many( foos => foo_to_bar => 'bar' );
60 }
61 {
62 package #
63 DBICTest::Schema::FooToBar${suffix};
64
65 use base 'DBIx::Class::Core';
66 __PACKAGE__->table('foo_to_bar');
67 __PACKAGE__->add_columns(
68 'foo' => {
69 data_type => 'integer',
70 },
71 'bar' => {
72 data_type => 'integer',
73 },
74 );
75 __PACKAGE__->belongs_to('foo' => 'DBICTest::Schema::Foo${suffix}');
76 __PACKAGE__->belongs_to('bar' => 'DBICTest::Schema::Foo${suffix}');
77 }
78 {
79 package #
80 DBICTest::Schema::Bar${suffix};
81
82 use base 'DBIx::Class::Core';
83
84 __PACKAGE__->table('bar');
85 __PACKAGE__->add_columns(
86 'barid' => {
87 data_type => 'integer',
88 is_auto_increment => 1,
89 },
90 );
91
92 __PACKAGE__->set_primary_key('barid');
93 __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar${suffix}' => 'foo');
94
95 __PACKAGE__->many_to_many( bars => foo_to_bar => 'foo' );
96
97 sub add_to_bars {}
98 }
99 EOF
100
101 }
0 use strict;
1 use warnings;
2 use Test::More;
3
4 use lib qw(t/lib);
5
6 plan tests => 4;
7 my $exp_warn = qr/The many-to-many relationship 'bars' is trying to create/;
8
9 {
10 my @w;
11 local $SIG{__WARN__} = sub { $_[0] =~ $exp_warn ? push @w, $_[0] : warn $_[0] };
12 my $code = gen_code ( suffix => 1 );
13 eval "$code";
14 ok (! $@, 'Eval code without warnings suppression')
15 || diag $@;
16
17 ok (@w, "Warning triggered without DBIC_OVERWRITE_HELPER_METHODS_OK");
18 }
19
20 {
21 my @w;
22 local $SIG{__WARN__} = sub { $_[0] =~ $exp_warn ? push @w, $_[0] : warn $_[0] };
23
24 my $code = gen_code ( suffix => 2 );
25
26 local $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK} = 1;
27 eval "$code";
28 ok (! $@, 'Eval code with warnings suppression')
29 || diag $@;
30
31 ok (! @w, "No warning triggered with DBIC_OVERWRITE_HELPER_METHODS_OK");
32 }
33
34 sub gen_code {
35
36 my $args = { @_ };
37 my $suffix = $args->{suffix};
38
39 return <<EOF;
40 use strict;
41 use warnings;
42
43 {
44 package #
45 DBICTest::Schema::Foo${suffix};
46 use base 'DBIx::Class::Core';
47
48 __PACKAGE__->table('foo');
49 __PACKAGE__->add_columns(
50 'fooid' => {
51 data_type => 'integer',
52 is_auto_increment => 1,
53 },
54 );
55 __PACKAGE__->set_primary_key('fooid');
56
57
58 __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar${suffix}' => 'bar');
59 __PACKAGE__->many_to_many( foos => foo_to_bar => 'bar' );
60 }
61 {
62 package #
63 DBICTest::Schema::FooToBar${suffix};
64
65 use base 'DBIx::Class::Core';
66 __PACKAGE__->table('foo_to_bar');
67 __PACKAGE__->add_columns(
68 'foo' => {
69 data_type => 'integer',
70 },
71 'bar' => {
72 data_type => 'integer',
73 },
74 );
75 __PACKAGE__->belongs_to('foo' => 'DBICTest::Schema::Foo${suffix}');
76 __PACKAGE__->belongs_to('bar' => 'DBICTest::Schema::Foo${suffix}');
77 }
78 {
79 package #
80 DBICTest::Schema::Bar${suffix};
81
82 use base 'DBIx::Class::Core';
83
84 __PACKAGE__->table('bar');
85 __PACKAGE__->add_columns(
86 'barid' => {
87 data_type => 'integer',
88 is_auto_increment => 1,
89 },
90 );
91
92 __PACKAGE__->set_primary_key('barid');
93 __PACKAGE__->has_many('foo_to_bar' => 'DBICTest::Schema::FooToBar${suffix}' => 'foo');
94
95 __PACKAGE__->many_to_many( bars => foo_to_bar => 'foo' );
96
97 sub add_to_bars {}
98 }
99 EOF
100
101 }
+21
-21
t/30dbicplain.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7
8 plan tests => 3;
9
10 my @warnings;
11
12 {
13 local $SIG{__WARN__} = sub { push(@warnings, $_[0]); };
14 require DBICTest::Plain;
15 }
16
17 like($warnings[0], qr/compose_connection deprecated as of 0\.08000/,
18 'deprecation warning emitted ok');
19 cmp_ok(@warnings, '==', 1, 'no unexpected warnings');
20 cmp_ok(DBICTest::Plain->resultset('Test')->count, '>', 0, 'count is valid');
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7
8 plan tests => 3;
9
10 my @warnings;
11
12 {
13 local $SIG{__WARN__} = sub { push(@warnings, $_[0]); };
14 require DBICTest::Plain;
15 }
16
17 like($warnings[0], qr/compose_connection deprecated as of 0\.08000/,
18 'deprecation warning emitted ok');
19 cmp_ok(@warnings, '==', 1, 'no unexpected warnings');
20 cmp_ok(DBICTest::Plain->resultset('Test')->count, '>', 0, 'count is valid');
+82
-82
t/34exception_action.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 plan tests => 9;
8
9 # Set up the "usual" sqlite for DBICTest
10 my $schema = DBICTest->init_schema;
11
12 # This is how we're generating exceptions in the rest of these tests,
13 # which might need updating at some future time to be some other
14 # exception-generating statement:
15
16 sub throwex { $schema->resultset("Artist")->search(1,1,1); }
17 my $ex_regex = qr/Odd number of arguments to search/;
18
19 # Basic check, normal exception
20 eval { throwex };
21 my $e = $@; # like() seems to stringify $@
22 like($@, $ex_regex);
23
24 # Re-throw the exception with rethrow()
25 eval { $e->rethrow };
26 isa_ok( $@, 'DBIx::Class::Exception' );
27 like($@, $ex_regex);
28
29 # Now lets rethrow via exception_action
30 $schema->exception_action(sub { die @_ });
31 eval { throwex };
32 like($@, $ex_regex);
33
34 # Now lets suppress the error
35 $schema->exception_action(sub { 1 });
36 eval { throwex };
37 ok(!$@, "Suppress exception");
38
39 # Now lets fall through and let croak take back over
40 $schema->exception_action(sub { return });
41 eval { throwex };
42 like($@, $ex_regex);
43
44 # Whacky useless exception class
45 {
46 package DBICTest::Exception;
47 use overload '""' => \&stringify, fallback => 1;
48 sub new {
49 my $class = shift;
50 bless { msg => shift }, $class;
51 }
52 sub throw {
53 my $self = shift;
54 die $self if ref $self eq __PACKAGE__;
55 die $self->new(shift);
56 }
57 sub stringify {
58 "DBICTest::Exception is handling this: " . shift->{msg};
59 }
60 }
61
62 # Try the exception class
63 $schema->exception_action(sub { DBICTest::Exception->throw(@_) });
64 eval { throwex };
65 like($@, qr/DBICTest::Exception is handling this: $ex_regex/);
66
67 # While we're at it, lets throw a custom exception through Storage::DBI
68 eval { $schema->storage->throw_exception('floob') };
69 like($@, qr/DBICTest::Exception is handling this: floob/);
70
71
72 # This usage is a bit unusual but it was actually seen in the wild
73 eval {
74
75 my $dbh = $schema->storage->dbh;
76 undef $schema;
77
78 $dbh->do ('glaring_syntax_error;');
79 };
80 like($@, qr/DBI Exception.+do failed/, 'Exception thrown even after $storage is destroyed');
81
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 plan tests => 9;
8
9 # Set up the "usual" sqlite for DBICTest
10 my $schema = DBICTest->init_schema;
11
12 # This is how we're generating exceptions in the rest of these tests,
13 # which might need updating at some future time to be some other
14 # exception-generating statement:
15
16 sub throwex { $schema->resultset("Artist")->search(1,1,1); }
17 my $ex_regex = qr/Odd number of arguments to search/;
18
19 # Basic check, normal exception
20 eval { throwex };
21 my $e = $@; # like() seems to stringify $@
22 like($@, $ex_regex);
23
24 # Re-throw the exception with rethrow()
25 eval { $e->rethrow };
26 isa_ok( $@, 'DBIx::Class::Exception' );
27 like($@, $ex_regex);
28
29 # Now lets rethrow via exception_action
30 $schema->exception_action(sub { die @_ });
31 eval { throwex };
32 like($@, $ex_regex);
33
34 # Now lets suppress the error
35 $schema->exception_action(sub { 1 });
36 eval { throwex };
37 ok(!$@, "Suppress exception");
38
39 # Now lets fall through and let croak take back over
40 $schema->exception_action(sub { return });
41 eval { throwex };
42 like($@, $ex_regex);
43
44 # Whacky useless exception class
45 {
46 package DBICTest::Exception;
47 use overload '""' => \&stringify, fallback => 1;
48 sub new {
49 my $class = shift;
50 bless { msg => shift }, $class;
51 }
52 sub throw {
53 my $self = shift;
54 die $self if ref $self eq __PACKAGE__;
55 die $self->new(shift);
56 }
57 sub stringify {
58 "DBICTest::Exception is handling this: " . shift->{msg};
59 }
60 }
61
62 # Try the exception class
63 $schema->exception_action(sub { DBICTest::Exception->throw(@_) });
64 eval { throwex };
65 like($@, qr/DBICTest::Exception is handling this: $ex_regex/);
66
67 # While we're at it, lets throw a custom exception through Storage::DBI
68 eval { $schema->storage->throw_exception('floob') };
69 like($@, qr/DBICTest::Exception is handling this: floob/);
70
71
72 # This usage is a bit unusual but it was actually seen in the wild
73 eval {
74
75 my $dbh = $schema->storage->dbh;
76 undef $schema;
77
78 $dbh->do ('glaring_syntax_error;');
79 };
80 like($@, qr/DBI Exception.+do failed/, 'Exception thrown even after $storage is destroyed');
81
+35
-35
t/39load_namespaces_1.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7 use DBICTest; # do not remove even though it is not used
8
9 plan tests => 8;
10
11 my $warnings;
12 eval {
13 local $SIG{__WARN__} = sub { $warnings .= shift };
14 package DBICNSTest;
15 use base qw/DBIx::Class::Schema/;
16 __PACKAGE__->load_namespaces;
17 };
18 ok(!$@) or diag $@;
19 like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
20
21 my $source_a = DBICNSTest->source('A');
22 isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
23 my $rset_a = DBICNSTest->resultset('A');
24 isa_ok($rset_a, 'DBICNSTest::ResultSet::A');
25
26 my $source_b = DBICNSTest->source('B');
27 isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
28 my $rset_b = DBICNSTest->resultset('B');
29 isa_ok($rset_b, 'DBIx::Class::ResultSet');
30
31 for my $moniker (qw/A B/) {
32 my $class = "DBICNSTest::Result::$moniker";
33 ok(!defined($class->result_source_instance->source_name));
34 }
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7 use DBICTest; # do not remove even though it is not used
8
9 plan tests => 8;
10
11 my $warnings;
12 eval {
13 local $SIG{__WARN__} = sub { $warnings .= shift };
14 package DBICNSTest;
15 use base qw/DBIx::Class::Schema/;
16 __PACKAGE__->load_namespaces;
17 };
18 ok(!$@) or diag $@;
19 like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
20
21 my $source_a = DBICNSTest->source('A');
22 isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
23 my $rset_a = DBICNSTest->resultset('A');
24 isa_ok($rset_a, 'DBICNSTest::ResultSet::A');
25
26 my $source_b = DBICNSTest->source('B');
27 isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
28 my $rset_b = DBICNSTest->resultset('B');
29 isa_ok($rset_b, 'DBIx::Class::ResultSet');
30
31 for my $moniker (qw/A B/) {
32 my $class = "DBICNSTest::Result::$moniker";
33 ok(!defined($class->result_source_instance->source_name));
34 }
+33
-33
t/39load_namespaces_2.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7 use DBICTest; # do not remove even though it is not used
8
9 plan tests => 6;
10
11 my $warnings;
12 eval {
13 local $SIG{__WARN__} = sub { $warnings .= shift };
14 package DBICNSTest;
15 use base qw/DBIx::Class::Schema/;
16 __PACKAGE__->load_namespaces(
17 result_namespace => 'Rslt',
18 resultset_namespace => 'RSet',
19 );
20 };
21 ok(!$@) or diag $@;
22 like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
23
24 my $source_a = DBICNSTest->source('A');
25 isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
26 my $rset_a = DBICNSTest->resultset('A');
27 isa_ok($rset_a, 'DBICNSTest::RSet::A');
28
29 my $source_b = DBICNSTest->source('B');
30 isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
31 my $rset_b = DBICNSTest->resultset('B');
32 isa_ok($rset_b, 'DBIx::Class::ResultSet');
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7 use DBICTest; # do not remove even though it is not used
8
9 plan tests => 6;
10
11 my $warnings;
12 eval {
13 local $SIG{__WARN__} = sub { $warnings .= shift };
14 package DBICNSTest;
15 use base qw/DBIx::Class::Schema/;
16 __PACKAGE__->load_namespaces(
17 result_namespace => 'Rslt',
18 resultset_namespace => 'RSet',
19 );
20 };
21 ok(!$@) or diag $@;
22 like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
23
24 my $source_a = DBICNSTest->source('A');
25 isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
26 my $rset_a = DBICNSTest->resultset('A');
27 isa_ok($rset_a, 'DBICNSTest::RSet::A');
28
29 my $source_b = DBICNSTest->source('B');
30 isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
31 my $rset_b = DBICNSTest->resultset('B');
32 isa_ok($rset_b, 'DBIx::Class::ResultSet');
+16
-14
t/39load_namespaces_3.t less more
22 use strict;
33 use warnings;
44 use Test::More;
5 use Test::Exception;
6 use Test::Warn;
57
68 use lib qw(t/lib);
79 use DBICTest; # do not remove even though it is not used
810
9 plan tests => 7;
10
11 my $warnings;
12 eval {
13 local $SIG{__WARN__} = sub { $warnings .= shift };
14 package DBICNSTestOther;
15 use base qw/DBIx::Class::Schema/;
16 __PACKAGE__->load_namespaces(
17 result_namespace => [ '+DBICNSTest::Rslt', '+DBICNSTest::OtherRslt' ],
18 resultset_namespace => '+DBICNSTest::RSet',
19 );
20 };
21 ok(!$@) or diag $@;
22 like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
11 lives_ok (sub {
12 warnings_exist ( sub {
13 package DBICNSTestOther;
14 use base qw/DBIx::Class::Schema/;
15 __PACKAGE__->load_namespaces(
16 result_namespace => [ '+DBICNSTest::Rslt', '+DBICNSTest::OtherRslt' ],
17 resultset_namespace => '+DBICNSTest::RSet',
18 );
19 },
20 qr/load_namespaces found ResultSet class C with no corresponding Result class/,
21 );
22 });
2323
2424 my $source_a = DBICNSTestOther->source('A');
2525 isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
3333
3434 my $source_d = DBICNSTestOther->source('D');
3535 isa_ok($source_d, 'DBIx::Class::ResultSource::Table');
36
37 done_testing;
+30
-30
t/39load_namespaces_4.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7 use DBICTest; # do not remove even though it is not used
8
9 plan tests => 6;
10
11 my $warnings;
12 eval {
13 local $SIG{__WARN__} = sub { $warnings .= shift };
14 package DBICNSTest;
15 use base qw/DBIx::Class::Schema/;
16 __PACKAGE__->load_namespaces( default_resultset_class => 'RSBase' );
17 };
18 ok(!$@) or diag $@;
19 like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
20
21 my $source_a = DBICNSTest->source('A');
22 isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
23 my $rset_a = DBICNSTest->resultset('A');
24 isa_ok($rset_a, 'DBICNSTest::ResultSet::A');
25
26 my $source_b = DBICNSTest->source('B');
27 isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
28 my $rset_b = DBICNSTest->resultset('B');
29 isa_ok($rset_b, 'DBICNSTest::RSBase');
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7 use DBICTest; # do not remove even though it is not used
8
9 plan tests => 6;
10
11 my $warnings;
12 eval {
13 local $SIG{__WARN__} = sub { $warnings .= shift };
14 package DBICNSTest;
15 use base qw/DBIx::Class::Schema/;
16 __PACKAGE__->load_namespaces( default_resultset_class => 'RSBase' );
17 };
18 ok(!$@) or diag $@;
19 like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
20
21 my $source_a = DBICNSTest->source('A');
22 isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
23 my $rset_a = DBICNSTest->resultset('A');
24 isa_ok($rset_a, 'DBICNSTest::ResultSet::A');
25
26 my $source_b = DBICNSTest->source('B');
27 isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
28 my $rset_b = DBICNSTest->resultset('B');
29 isa_ok($rset_b, 'DBICNSTest::RSBase');
+21
-21
t/39load_namespaces_exception.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7 use DBICTest; # do not remove even though it is not used
8
9 plan tests => 1;
10
11 eval {
12 package DBICNSTest;
13 use base qw/DBIx::Class::Schema/;
14 __PACKAGE__->load_namespaces(
15 result_namespace => 'Bogus',
16 resultset_namespace => 'RSet',
17 );
18 };
19
20 like ($@, qr/are you sure this is a real Result Class/, 'Clear exception thrown');
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7 use DBICTest; # do not remove even though it is not used
8
9 plan tests => 1;
10
11 eval {
12 package DBICNSTest;
13 use base qw/DBIx::Class::Schema/;
14 __PACKAGE__->load_namespaces(
15 result_namespace => 'Bogus',
16 resultset_namespace => 'RSet',
17 );
18 };
19
20 like ($@, qr/are you sure this is a real Result Class/, 'Clear exception thrown');
+67
-67
t/39load_namespaces_rt41083.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4
5 use lib 't/lib';
6 use DBICTest; # do not remove even though it is not used
7 use Test::More tests => 8;
8
9 sub _chk_warning {
10 defined $_[0]?
11 $_[0] !~ qr/We found ResultSet class '([^']+)' for '([^']+)', but it seems that you had already set '([^']+)' to use '([^']+)' instead/ :
12 1
13 }
14
15 sub _chk_extra_sources_warning {
16 my $p = qr/already has a source, use register_extra_source for additional sources/;
17 defined $_[0]? $_[0] !~ /$p/ : 1;
18 }
19
20 sub _verify_sources {
21 my @monikers = @_;
22 is_deeply (
23 [ sort DBICNSTest::RtBug41083->sources ],
24 \@monikers,
25 'List of resultsource registrations',
26 );
27 }
28
29 {
30 my $warnings;
31 eval {
32 local $SIG{__WARN__} = sub { $warnings .= shift };
33 package DBICNSTest::RtBug41083;
34 use base 'DBIx::Class::Schema';
35 __PACKAGE__->load_namespaces(
36 result_namespace => 'Schema_A',
37 resultset_namespace => 'ResultSet_A',
38 default_resultset_class => 'ResultSet'
39 );
40 };
41
42 ok(!$@) or diag $@;
43 ok(_chk_warning($warnings), 'expected no resultset complaint');
44 ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings);
45
46 _verify_sources (qw/A A::Sub/);
47 }
48
49 {
50 my $warnings;
51 eval {
52 local $SIG{__WARN__} = sub { $warnings .= shift };
53 package DBICNSTest::RtBug41083;
54 use base 'DBIx::Class::Schema';
55 __PACKAGE__->load_namespaces(
56 result_namespace => 'Schema',
57 resultset_namespace => 'ResultSet',
58 default_resultset_class => 'ResultSet'
59 );
60 };
61 ok(!$@) or diag $@;
62 ok(_chk_warning($warnings), 'expected no resultset complaint') or diag $warnings;
63 ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings);
64
65 _verify_sources (qw/A A::Sub Foo Foo::Sub/);
66 }
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4
5 use lib 't/lib';
6 use DBICTest; # do not remove even though it is not used
7 use Test::More tests => 8;
8
9 sub _chk_warning {
10 defined $_[0]?
11 $_[0] !~ qr/We found ResultSet class '([^']+)' for '([^']+)', but it seems that you had already set '([^']+)' to use '([^']+)' instead/ :
12 1
13 }
14
15 sub _chk_extra_sources_warning {
16 my $p = qr/already has a source, use register_extra_source for additional sources/;
17 defined $_[0]? $_[0] !~ /$p/ : 1;
18 }
19
20 sub _verify_sources {
21 my @monikers = @_;
22 is_deeply (
23 [ sort DBICNSTest::RtBug41083->sources ],
24 \@monikers,
25 'List of resultsource registrations',
26 );
27 }
28
29 {
30 my $warnings;
31 eval {
32 local $SIG{__WARN__} = sub { $warnings .= shift };
33 package DBICNSTest::RtBug41083;
34 use base 'DBIx::Class::Schema';
35 __PACKAGE__->load_namespaces(
36 result_namespace => 'Schema_A',
37 resultset_namespace => 'ResultSet_A',
38 default_resultset_class => 'ResultSet'
39 );
40 };
41
42 ok(!$@) or diag $@;
43 ok(_chk_warning($warnings), 'expected no resultset complaint');
44 ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings);
45
46 _verify_sources (qw/A A::Sub/);
47 }
48
49 {
50 my $warnings;
51 eval {
52 local $SIG{__WARN__} = sub { $warnings .= shift };
53 package DBICNSTest::RtBug41083;
54 use base 'DBIx::Class::Schema';
55 __PACKAGE__->load_namespaces(
56 result_namespace => 'Schema',
57 resultset_namespace => 'ResultSet',
58 default_resultset_class => 'ResultSet'
59 );
60 };
61 ok(!$@) or diag $@;
62 ok(_chk_warning($warnings), 'expected no resultset complaint') or diag $warnings;
63 ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings);
64
65 _verify_sources (qw/A A::Sub Foo Foo::Sub/);
66 }
+31
-31
t/40resultsetmanager.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7
8 BEGIN {
9 eval { require Class::Inspector };
10 if ($@ =~ m{Can.t locate Class/Inspector.pm}) {
11 plan skip_all => "ResultSetManager requires Class::Inspector";
12 } else {
13 plan tests => 4;
14 }
15 }
16
17 BEGIN {
18 local $SIG{__WARN__} = sub {};
19 require DBIx::Class::ResultSetManager;
20 }
21
22 use DBICTest::ResultSetManager; # uses Class::Inspector
23
24 my $schema = DBICTest::ResultSetManager->compose_namespace('DB');
25 my $rs = $schema->resultset('Foo');
26
27 ok( !DB::Foo->can('bar'), 'Foo class does not have bar method' );
28 ok( $rs->can('bar'), 'Foo resultset class has bar method' );
29 isa_ok( $rs, 'DBICTest::ResultSetManager::Foo::_resultset', 'Foo resultset class is correct' );
30 is( $rs->bar, 'good', 'bar method works' );
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 use lib qw(t/lib);
7
8 BEGIN {
9 eval { require Class::Inspector };
10 if ($@ =~ m{Can.t locate Class/Inspector.pm}) {
11 plan skip_all => "ResultSetManager requires Class::Inspector";
12 } else {
13 plan tests => 4;
14 }
15 }
16
17 BEGIN {
18 local $SIG{__WARN__} = sub {};
19 require DBIx::Class::ResultSetManager;
20 }
21
22 use DBICTest::ResultSetManager; # uses Class::Inspector
23
24 my $schema = DBICTest::ResultSetManager->compose_namespace('DB');
25 my $rs = $schema->resultset('Foo');
26
27 ok( !DB::Foo->can('bar'), 'Foo class does not have bar method' );
28 ok( $rs->can('bar'), 'Foo resultset class has bar method' );
29 isa_ok( $rs, 'DBICTest::ResultSetManager::Foo::_resultset', 'Foo resultset class is correct' );
30 is( $rs->bar, 'good', 'bar method works' );
+89
-89
t/41orrible.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use DBIx::Class::SQLAHacks::OracleJoins;
5
6 use lib qw(t/lib);
7 use DBICTest; # do not remove even though it is not used
8 use DBIC::SqlMakerTest;
9
10 plan tests => 4;
11
12 my $sa = new DBIx::Class::SQLAHacks::OracleJoins;
13
14 $sa->limit_dialect('RowNum');
15
16 is($sa->select('rubbish',
17 [ 'foo.id', 'bar.id', \'TO_CHAR(foo.womble, "blah")' ],
18 undef, undef, 1, 3),
19 'SELECT * FROM
20 (
21 SELECT A.*, ROWNUM r FROM
22 (
23 SELECT foo.id AS col1, bar.id AS col2, TO_CHAR(foo.womble, "blah") AS col3 FROM rubbish
24 ) A
25 WHERE ROWNUM < 5
26 ) B
27 WHERE r >= 4
28 ', 'Munged stuff to make Oracle not explode');
29
30 # test WhereJoins
31 # search with undefined or empty $cond
32
33 # my ($self, $table, $fields, $where, $order, @rest) = @_;
34 my ($sql, @bind) = $sa->select(
35 [
36 { me => "cd" },
37 [
38 { "-join_type" => "LEFT", artist => "artist" },
39 { "artist.artistid" => "me.artist" },
40 ],
41 ],
42 [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
43 undef,
44 undef
45 );
46 is_same_sql_bind(
47 $sql, \@bind,
48 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( artist.artistid(+) = me.artist )', [],
49 'WhereJoins search with empty where clause'
50 );
51
52 ($sql, @bind) = $sa->select(
53 [
54 { me => "cd" },
55 [
56 { "-join_type" => "", artist => "artist" },
57 { "artist.artistid" => "me.artist" },
58 ],
59 ],
60 [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
61 { 'artist.artistid' => 3 },
62 undef
63 );
64 is_same_sql_bind(
65 $sql, \@bind,
66 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid = me.artist ) AND ( artist.artistid = ? ) ) )', [3],
67 'WhereJoins search with where clause'
68 );
69
70 ($sql, @bind) = $sa->select(
71 [
72 { me => "cd" },
73 [
74 { "-join_type" => "LEFT", artist => "artist" },
75 { "artist.artistid" => "me.artist" },
76 ],
77 ],
78 [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
79 [{ 'artist.artistid' => 3 }, { 'me.cdid' => 5 }],
80 undef
81 );
82 is_same_sql_bind(
83 $sql, \@bind,
84 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid(+) = me.artist ) AND ( ( ( artist.artistid = ? ) OR ( me.cdid = ? ) ) ) ) )', [3, 5],
85 'WhereJoins search with or in where clause'
86 );
87
88
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use DBIx::Class::SQLAHacks::OracleJoins;
5
6 use lib qw(t/lib);
7 use DBICTest; # do not remove even though it is not used
8 use DBIC::SqlMakerTest;
9
10 plan tests => 4;
11
12 my $sa = new DBIx::Class::SQLAHacks::OracleJoins;
13
14 $sa->limit_dialect('RowNum');
15
16 is($sa->select('rubbish',
17 [ 'foo.id', 'bar.id', \'TO_CHAR(foo.womble, "blah")' ],
18 undef, undef, 1, 3),
19 'SELECT * FROM
20 (
21 SELECT A.*, ROWNUM r FROM
22 (
23 SELECT foo.id AS col1, bar.id AS col2, TO_CHAR(foo.womble, "blah") AS col3 FROM rubbish
24 ) A
25 WHERE ROWNUM < 5
26 ) B
27 WHERE r >= 4
28 ', 'Munged stuff to make Oracle not explode');
29
30 # test WhereJoins
31 # search with undefined or empty $cond
32
33 # my ($self, $table, $fields, $where, $order, @rest) = @_;
34 my ($sql, @bind) = $sa->select(
35 [
36 { me => "cd" },
37 [
38 { "-join_type" => "LEFT", artist => "artist" },
39 { "artist.artistid" => "me.artist" },
40 ],
41 ],
42 [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
43 undef,
44 undef
45 );
46 is_same_sql_bind(
47 $sql, \@bind,
48 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( artist.artistid(+) = me.artist )', [],
49 'WhereJoins search with empty where clause'
50 );
51
52 ($sql, @bind) = $sa->select(
53 [
54 { me => "cd" },
55 [
56 { "-join_type" => "", artist => "artist" },
57 { "artist.artistid" => "me.artist" },
58 ],
59 ],
60 [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
61 { 'artist.artistid' => 3 },
62 undef
63 );
64 is_same_sql_bind(
65 $sql, \@bind,
66 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid = me.artist ) AND ( artist.artistid = ? ) ) )', [3],
67 'WhereJoins search with where clause'
68 );
69
70 ($sql, @bind) = $sa->select(
71 [
72 { me => "cd" },
73 [
74 { "-join_type" => "LEFT", artist => "artist" },
75 { "artist.artistid" => "me.artist" },
76 ],
77 ],
78 [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
79 [{ 'artist.artistid' => 3 }, { 'me.cdid' => 5 }],
80 undef
81 );
82 is_same_sql_bind(
83 $sql, \@bind,
84 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM cd me, artist artist WHERE ( ( ( artist.artistid(+) = me.artist ) AND ( ( ( artist.artistid = ? ) OR ( me.cdid = ? ) ) ) ) )', [3, 5],
85 'WhereJoins search with or in where clause'
86 );
87
88
+84
-84
t/46where_attribute.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6 my $schema = DBICTest->init_schema();
7
8 plan tests => 19;
9
10 # select from a class with resultset_attributes
11 my $resultset = $schema->resultset('BooksInLibrary');
12 is($resultset, 3, "select from a class with resultset_attributes okay");
13
14 # now test out selects through a resultset
15 my $owner = $schema->resultset('Owners')->find({name => "Newton"});
16 my $programming_perl = $owner->books->find_or_create({ title => "Programming Perl" });
17 is($programming_perl->id, 1, 'select from a resultset with find_or_create for existing entry ok');
18
19 # and inserts?
20 my $see_spot;
21 $see_spot = eval { $owner->books->find_or_create({ title => "See Spot Run" }) };
22 if ($@) { print $@ }
23 ok(!$@, 'find_or_create on resultset with attribute for non-existent entry did not throw');
24 ok(defined $see_spot, 'successfully did insert on resultset with attribute for non-existent entry');
25
26 my $see_spot_rs = $owner->books->search({ title => "See Spot Run" });
27 eval { $see_spot_rs->delete(); };
28 if ($@) { print $@ }
29 ok(!$@, 'delete on resultset with attribute did not throw');
30 is($see_spot_rs->count(), 0, 'delete on resultset with attributes succeeded');
31
32 # many_to_many tests
33 my $collection = $schema->resultset('Collection')->search({collectionid => 1});
34 my $pointy_objects = $collection->search_related('collection_object')->search_related('object', { type => "pointy"});
35 my $pointy_count = $pointy_objects->count();
36 is($pointy_count, 2, 'many_to_many explicit query through linking table with query starting from resultset count correct');
37
38 $collection = $schema->resultset('Collection')->find(1);
39 $pointy_objects = $collection->search_related('collection_object')->search_related('object', { type => "pointy"});
40 $pointy_count = $pointy_objects->count();
41 is($pointy_count, 2, 'many_to_many explicit query through linking table with query starting from row count correct');
42
43 # use where on many_to_many query
44 $collection = $schema->resultset('Collection')->find(1);
45 $pointy_objects = $collection->search_related('collection_object')->search_related('object', {}, { where => { 'object.type' => 'pointy' } });
46 is($pointy_objects->count(), 2, 'many_to_many explicit query through linking table with where starting from row count correct');
47
48 $collection = $schema->resultset('Collection')->find(1);
49 $pointy_objects = $collection->pointy_objects();
50 $pointy_count = $pointy_objects->count();
51 is($pointy_count, 2, 'many_to_many resultset with where in resultset attrs count correct');
52
53 # add_to_$rel on many_to_many with where containing a required field
54 eval {$collection->add_to_pointy_objects({ value => "Nail" }) };
55 if ($@) { print $@ }
56 ok( !$@, 'many_to_many add_to_$rel($hash) with where in relationship attrs did not throw');
57 is($pointy_objects->count, $pointy_count+1, 'many_to_many add_to_$rel($hash) with where in relationship attrs count correct');
58 $pointy_count = $pointy_objects->count();
59
60 my $pen = $schema->resultset('TypedObject')->create({ value => "Pen", type => "pointy"});
61 eval {$collection->add_to_pointy_objects($pen)};
62 if ($@) { print $@ }
63 ok( !$@, 'many_to_many add_to_$rel($object) with where in relationship attrs did not throw');
64 is($pointy_objects->count, $pointy_count+1, 'many_to_many add_to_$rel($object) with where in relationship attrs count correct');
65 $pointy_count = $pointy_objects->count();
66
67 my $round_objects = $collection->round_objects();
68 my $round_count = $round_objects->count();
69 eval {$collection->add_to_objects({ value => "Wheel", type => "round" })};
70 if ($@) { print $@ }
71 ok( !$@, 'many_to_many add_to_$rel($hash) did not throw');
72 is($round_objects->count, $round_count+1, 'many_to_many add_to_$rel($hash) count correct');
73
74 # test set_$rel
75 $round_count = $round_objects->count();
76 $pointy_count = $pointy_objects->count();
77 my @all_pointy_objects = $pointy_objects->all;
78 # doing a set on pointy objects with its current set should not change any counts
79 eval {$collection->set_pointy_objects(\@all_pointy_objects)};
80 if ($@) { print $@ }
81 ok( !$@, 'many_to_many set_$rel(\@objects) did not throw');
82 is($pointy_objects->count, $pointy_count, 'many_to_many set_$rel($hash) count correct');
83 is($round_objects->count, $round_count, 'many_to_many set_$rel($hash) other rel count correct');
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6 my $schema = DBICTest->init_schema();
7
8 plan tests => 19;
9
10 # select from a class with resultset_attributes
11 my $resultset = $schema->resultset('BooksInLibrary');
12 is($resultset, 3, "select from a class with resultset_attributes okay");
13
14 # now test out selects through a resultset
15 my $owner = $schema->resultset('Owners')->find({name => "Newton"});
16 my $programming_perl = $owner->books->find_or_create({ title => "Programming Perl" });
17 is($programming_perl->id, 1, 'select from a resultset with find_or_create for existing entry ok');
18
19 # and inserts?
20 my $see_spot;
21 $see_spot = eval { $owner->books->find_or_create({ title => "See Spot Run" }) };
22 if ($@) { print $@ }
23 ok(!$@, 'find_or_create on resultset with attribute for non-existent entry did not throw');
24 ok(defined $see_spot, 'successfully did insert on resultset with attribute for non-existent entry');
25
26 my $see_spot_rs = $owner->books->search({ title => "See Spot Run" });
27 eval { $see_spot_rs->delete(); };
28 if ($@) { print $@ }
29 ok(!$@, 'delete on resultset with attribute did not throw');
30 is($see_spot_rs->count(), 0, 'delete on resultset with attributes succeeded');
31
32 # many_to_many tests
33 my $collection = $schema->resultset('Collection')->search({collectionid => 1});
34 my $pointy_objects = $collection->search_related('collection_object')->search_related('object', { type => "pointy"});
35 my $pointy_count = $pointy_objects->count();
36 is($pointy_count, 2, 'many_to_many explicit query through linking table with query starting from resultset count correct');
37
38 $collection = $schema->resultset('Collection')->find(1);
39 $pointy_objects = $collection->search_related('collection_object')->search_related('object', { type => "pointy"});
40 $pointy_count = $pointy_objects->count();
41 is($pointy_count, 2, 'many_to_many explicit query through linking table with query starting from row count correct');
42
43 # use where on many_to_many query
44 $collection = $schema->resultset('Collection')->find(1);
45 $pointy_objects = $collection->search_related('collection_object')->search_related('object', {}, { where => { 'object.type' => 'pointy' } });
46 is($pointy_objects->count(), 2, 'many_to_many explicit query through linking table with where starting from row count correct');
47
48 $collection = $schema->resultset('Collection')->find(1);
49 $pointy_objects = $collection->pointy_objects();
50 $pointy_count = $pointy_objects->count();
51 is($pointy_count, 2, 'many_to_many resultset with where in resultset attrs count correct');
52
53 # add_to_$rel on many_to_many with where containing a required field
54 eval {$collection->add_to_pointy_objects({ value => "Nail" }) };
55 if ($@) { print $@ }
56 ok( !$@, 'many_to_many add_to_$rel($hash) with where in relationship attrs did not throw');
57 is($pointy_objects->count, $pointy_count+1, 'many_to_many add_to_$rel($hash) with where in relationship attrs count correct');
58 $pointy_count = $pointy_objects->count();
59
60 my $pen = $schema->resultset('TypedObject')->create({ value => "Pen", type => "pointy"});
61 eval {$collection->add_to_pointy_objects($pen)};
62 if ($@) { print $@ }
63 ok( !$@, 'many_to_many add_to_$rel($object) with where in relationship attrs did not throw');
64 is($pointy_objects->count, $pointy_count+1, 'many_to_many add_to_$rel($object) with where in relationship attrs count correct');
65 $pointy_count = $pointy_objects->count();
66
67 my $round_objects = $collection->round_objects();
68 my $round_count = $round_objects->count();
69 eval {$collection->add_to_objects({ value => "Wheel", type => "round" })};
70 if ($@) { print $@ }
71 ok( !$@, 'many_to_many add_to_$rel($hash) did not throw');
72 is($round_objects->count, $round_count+1, 'many_to_many add_to_$rel($hash) count correct');
73
74 # test set_$rel
75 $round_count = $round_objects->count();
76 $pointy_count = $pointy_objects->count();
77 my @all_pointy_objects = $pointy_objects->all;
78 # doing a set on pointy objects with its current set should not change any counts
79 eval {$collection->set_pointy_objects(\@all_pointy_objects)};
80 if ($@) { print $@ }
81 ok( !$@, 'many_to_many set_$rel(\@objects) did not throw');
82 is($pointy_objects->count, $pointy_count, 'many_to_many set_$rel($hash) count correct');
83 is($round_objects->count, $round_count, 'many_to_many set_$rel($hash) other rel count correct');
+102
-102
t/50fork.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3
4 # README: If you set the env var to a number greater than 10,
5 # we will use that many children
6
7 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
8 my $num_children = $ENV{DBICTEST_FORK_STRESS};
9
10 plan skip_all => 'Set $ENV{DBICTEST_FORK_STRESS} to run this test'
11 unless $num_children;
12
13 plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
14 . ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
15
16 if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
17 $num_children = 10;
18 }
19
20 plan tests => $num_children + 6;
21
22 use lib qw(t/lib);
23
24 use_ok('DBICTest::Schema');
25
26 my $schema = DBICTest::Schema->connection($dsn, $user, $pass, { AutoCommit => 1 });
27
28 my $parent_rs;
29
30 eval {
31 my $dbh = $schema->storage->dbh;
32
33 {
34 local $SIG{__WARN__} = sub {};
35 eval { $dbh->do("DROP TABLE cd") };
36 $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(100) NOT NULL UNIQUE, year VARCHAR(100) NOT NULL, genreid INTEGER, single_track INTEGER);");
37 }
38
39 $schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 });
40 $schema->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 });
41
42 $parent_rs = $schema->resultset('CD')->search({ year => 1901 });
43 $parent_rs->next;
44 };
45 ok(!$@) or diag "Creation eval failed: $@";
46
47 {
48 my $pid = fork;
49 if(!defined $pid) {
50 die "fork failed: $!";
51 }
52
53 if (!$pid) {
54 exit $schema->storage->connected ? 1 : 0;
55 }
56
57 if (waitpid($pid, 0) == $pid) {
58 my $ex = $? >> 8;
59 ok($ex == 0, "storage->connected() returns false in child");
60 exit $ex if $ex; # skip remaining tests
61 }
62 }
63
64 my @pids;
65 while(@pids < $num_children) {
66
67 my $pid = fork;
68 if(!defined $pid) {
69 die "fork failed: $!";
70 }
71 elsif($pid) {
72 push(@pids, $pid);
73 next;
74 }
75
76 $pid = $$;
77
78 my $child_rs = $schema->resultset('CD')->search({ year => 1901 });
79 my $row = $parent_rs->next;
80 if($row && $row->get_column('artist') =~ /^(?:123|456)$/) {
81 $schema->resultset('CD')->create({ title => "test success $pid", artist => $pid, year => scalar(@pids) });
82 }
83 sleep(3);
84 exit;
85 }
86
87 ok(1, "past forking");
88
89 waitpid($_,0) for(@pids);
90
91 ok(1, "past waiting");
92
93 while(@pids) {
94 my $pid = pop(@pids);
95 my $rs = $schema->resultset('CD')->search({ title => "test success $pid", artist => $pid, year => scalar(@pids) });
96 is($rs->next->get_column('artist'), $pid, "Child $pid successful");
97 }
98
99 ok(1, "Made it to the end");
100
101 $schema->storage->dbh->do("DROP TABLE cd");
0 use strict;
1 use warnings;
2 use Test::More;
3
4 # README: If you set the env var to a number greater than 10,
5 # we will use that many children
6
7 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
8 my $num_children = $ENV{DBICTEST_FORK_STRESS};
9
10 plan skip_all => 'Set $ENV{DBICTEST_FORK_STRESS} to run this test'
11 unless $num_children;
12
13 plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
14 . ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
15
16 if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
17 $num_children = 10;
18 }
19
20 plan tests => $num_children + 6;
21
22 use lib qw(t/lib);
23
24 use_ok('DBICTest::Schema');
25
26 my $schema = DBICTest::Schema->connection($dsn, $user, $pass, { AutoCommit => 1 });
27
28 my $parent_rs;
29
30 eval {
31 my $dbh = $schema->storage->dbh;
32
33 {
34 local $SIG{__WARN__} = sub {};
35 eval { $dbh->do("DROP TABLE cd") };
36 $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(100) NOT NULL UNIQUE, year VARCHAR(100) NOT NULL, genreid INTEGER, single_track INTEGER);");
37 }
38
39 $schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 });
40 $schema->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 });
41
42 $parent_rs = $schema->resultset('CD')->search({ year => 1901 });
43 $parent_rs->next;
44 };
45 ok(!$@) or diag "Creation eval failed: $@";
46
47 {
48 my $pid = fork;
49 if(!defined $pid) {
50 die "fork failed: $!";
51 }
52
53 if (!$pid) {
54 exit $schema->storage->connected ? 1 : 0;
55 }
56
57 if (waitpid($pid, 0) == $pid) {
58 my $ex = $? >> 8;
59 ok($ex == 0, "storage->connected() returns false in child");
60 exit $ex if $ex; # skip remaining tests
61 }
62 }
63
64 my @pids;
65 while(@pids < $num_children) {
66
67 my $pid = fork;
68 if(!defined $pid) {
69 die "fork failed: $!";
70 }
71 elsif($pid) {
72 push(@pids, $pid);
73 next;
74 }
75
76 $pid = $$;
77
78 my $child_rs = $schema->resultset('CD')->search({ year => 1901 });
79 my $row = $parent_rs->next;
80 if($row && $row->get_column('artist') =~ /^(?:123|456)$/) {
81 $schema->resultset('CD')->create({ title => "test success $pid", artist => $pid, year => scalar(@pids) });
82 }
83 sleep(3);
84 exit;
85 }
86
87 ok(1, "past forking");
88
89 waitpid($_,0) for(@pids);
90
91 ok(1, "past waiting");
92
93 while(@pids) {
94 my $pid = pop(@pids);
95 my $rs = $schema->resultset('CD')->search({ title => "test success $pid", artist => $pid, year => scalar(@pids) });
96 is($rs->next->get_column('artist'), $pid, "Child $pid successful");
97 }
98
99 ok(1, "Made it to the end");
100
101 $schema->storage->dbh->do("DROP TABLE cd");
+5
-3
t/51threads.t less more
00 use strict;
11 use warnings;
2
23 use Test::More;
4 use Test::Exception;
5
36 use Config;
47
58 # README: If you set the env var to a number greater than 10,
3740
3841 my $parent_rs;
3942
40 eval {
43 lives_ok (sub {
4144 my $dbh = $schema->storage->dbh;
4245
4346 {
5154
5255 $parent_rs = $schema->resultset('CD')->search({ year => 1901 });
5356 $parent_rs->next;
54 };
55 ok(!$@) or diag "Creation eval failed: $@";
57 }, 'populate successfull');
5658
5759 my @children;
5860 while(@children < $num_children) {
+45
-45
t/54taint.t less more
0 #!perl -T
1
2 # the above line forces Test::Harness into taint-mode
3
4 use strict;
5 use warnings;
6
7 use Test::More;
8 BEGIN { plan tests => 7 }
9
10 package DBICTest::Taint::Classes;
11
12 use Test::More;
13 use Test::Exception;
14
15 use lib qw(t/lib);
16 use base qw/DBIx::Class::Schema/;
17
18 lives_ok (sub {
19 __PACKAGE__->load_classes(qw/Manual/);
20 ok( __PACKAGE__->source('Manual'), 'The Classes::Manual source has been registered' );
21 __PACKAGE__->_unregister_source (qw/Manual/);
22 }, 'Loading classes with explicit load_classes worked in taint mode' );
23
24 lives_ok (sub {
25 __PACKAGE__->load_classes();
26 ok( __PACKAGE__->source('Auto'), 'The Classes::Auto source has been registered' );
27 ok( __PACKAGE__->source('Auto'), 'The Classes::Manual source has been re-registered' );
28 }, 'Loading classes with Module::Find/load_classes worked in taint mode' );
29
30
31 package DBICTest::Taint::Namespaces;
32
33 use Test::More;
34 use Test::Exception;
35
36 use lib qw(t/lib);
37 use base qw/DBIx::Class::Schema/;
38
39 lives_ok (sub {
40 __PACKAGE__->load_namespaces();
41 ok( __PACKAGE__->source('Test'), 'The Namespaces::Test source has been registered' );
42 }, 'Loading classes with Module::Find/load_namespaces worked in taint mode' );
43
44 1;
0 #!perl -T
1
2 # the above line forces Test::Harness into taint-mode
3
4 use strict;
5 use warnings;
6
7 use Test::More;
8 BEGIN { plan tests => 7 }
9
10 package DBICTest::Taint::Classes;
11
12 use Test::More;
13 use Test::Exception;
14
15 use lib qw(t/lib);
16 use base qw/DBIx::Class::Schema/;
17
18 lives_ok (sub {
19 __PACKAGE__->load_classes(qw/Manual/);
20 ok( __PACKAGE__->source('Manual'), 'The Classes::Manual source has been registered' );
21 __PACKAGE__->_unregister_source (qw/Manual/);
22 }, 'Loading classes with explicit load_classes worked in taint mode' );
23
24 lives_ok (sub {
25 __PACKAGE__->load_classes();
26 ok( __PACKAGE__->source('Auto'), 'The Classes::Auto source has been registered' );
27 ok( __PACKAGE__->source('Auto'), 'The Classes::Manual source has been re-registered' );
28 }, 'Loading classes with Module::Find/load_classes worked in taint mode' );
29
30
31 package DBICTest::Taint::Namespaces;
32
33 use Test::More;
34 use Test::Exception;
35
36 use lib qw(t/lib);
37 use base qw/DBIx::Class::Schema/;
38
39 lives_ok (sub {
40 __PACKAGE__->load_namespaces();
41 ok( __PACKAGE__->source('Test'), 'The Namespaces::Test source has been registered' );
42 }, 'Loading classes with Module::Find/load_namespaces worked in taint mode' );
43
44 1;
+55
-55
t/55storage_stress.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3
4 # XXX obviously, the guts of this test haven't been written yet --blblack
5
6 use lib qw(t/lib);
7
8 plan skip_all => 'Set $ENV{DBICTEST_STORAGE_STRESS} to run this test'
9 . ' (it is very resource intensive!)'
10 unless $ENV{DBICTEST_STORAGE_STRESS};
11
12 my $NKIDS = 20;
13 my $CYCLES = 5;
14 my @KILL_RATES = qw/0 0.001 0.01 0.1 0.2 0.5 0.75 1.0/;
15
16 # Stress the storage with these parameters...
17 sub stress_storage {
18 my ($connect_info, $num_kids, $cycles, $kill_rate) = @_;
19
20 foreach my $cycle (1..$cycles) {
21 my $schema = DBICTest::Schema->connection(@$connect_info, { AutoCommit => 1 });
22 foreach my $kidno (1..$num_kids) {
23 ok(1);
24 }
25 }
26 }
27
28 # Get a set of connection information -
29 # whatever the user has supplied for the vendor-specific tests
30 sub get_connect_infos {
31 my @connect_infos;
32 foreach my $db_prefix (qw/PG MYSQL DB2 MSSQL ORA/) {
33 my @conn_info = @ENV{
34 map { "DBICTEST_${db_prefix}_${_}" } qw/DSN USER PASS/
35 };
36 push(@connect_infos, \@conn_info) if $conn_info[0];
37 }
38 \@connect_infos;
39 }
40
41 my $connect_infos = get_connect_infos();
42
43 plan skip_all => 'This test needs some non-sqlite connect info!'
44 unless @$connect_infos;
45
46 plan tests => (1 * @$connect_infos * $NKIDS * $CYCLES * @KILL_RATES) + 1;
47
48 use_ok('DBICTest::Schema');
49
50 foreach my $connect_info (@$connect_infos) {
51 foreach my $kill_rate (@KILL_RATES) {
52 stress_storage($connect_info, $NKIDS, $CYCLES, $kill_rate);
53 }
54 }
0 use strict;
1 use warnings;
2 use Test::More;
3
4 # XXX obviously, the guts of this test haven't been written yet --blblack
5
6 use lib qw(t/lib);
7
8 plan skip_all => 'Set $ENV{DBICTEST_STORAGE_STRESS} to run this test'
9 . ' (it is very resource intensive!)'
10 unless $ENV{DBICTEST_STORAGE_STRESS};
11
12 my $NKIDS = 20;
13 my $CYCLES = 5;
14 my @KILL_RATES = qw/0 0.001 0.01 0.1 0.2 0.5 0.75 1.0/;
15
16 # Stress the storage with these parameters...
17 sub stress_storage {
18 my ($connect_info, $num_kids, $cycles, $kill_rate) = @_;
19
20 foreach my $cycle (1..$cycles) {
21 my $schema = DBICTest::Schema->connection(@$connect_info, { AutoCommit => 1 });
22 foreach my $kidno (1..$num_kids) {
23 ok(1);
24 }
25 }
26 }
27
28 # Get a set of connection information -
29 # whatever the user has supplied for the vendor-specific tests
30 sub get_connect_infos {
31 my @connect_infos;
32 foreach my $db_prefix (qw/PG MYSQL DB2 MSSQL ORA/) {
33 my @conn_info = @ENV{
34 map { "DBICTEST_${db_prefix}_${_}" } qw/DSN USER PASS/
35 };
36 push(@connect_infos, \@conn_info) if $conn_info[0];
37 }
38 \@connect_infos;
39 }
40
41 my $connect_infos = get_connect_infos();
42
43 plan skip_all => 'This test needs some non-sqlite connect info!'
44 unless @$connect_infos;
45
46 plan tests => (1 * @$connect_infos * $NKIDS * $CYCLES * @KILL_RATES) + 1;
47
48 use_ok('DBICTest::Schema');
49
50 foreach my $connect_info (@$connect_infos) {
51 foreach my $kill_rate (@KILL_RATES) {
52 stress_storage($connect_info, $NKIDS, $CYCLES, $kill_rate);
53 }
54 }
+41
-0
t/60core.t less more
418418 is($en_row->encoded, 'amliw', 'insert does not encode again');
419419 }
420420
421 #make sure multicreate encoding still works
422 {
423 my $empl_rs = $schema->resultset('Employee');
424
425 my $empl = $empl_rs->create ({
426 name => 'Secret holder',
427 secretkey => {
428 encoded => 'CAN HAZ',
429 },
430 });
431 is($empl->secretkey->encoded, 'ZAH NAC', 'correctly encoding on multicreate');
432
433 my $empl2 = $empl_rs->create ({
434 name => 'Same secret holder',
435 secretkey => {
436 encoded => 'CAN HAZ',
437 },
438 });
439 is($empl2->secretkey->encoded, 'ZAH NAC', 'correctly encoding on preexisting multicreate');
440
441 $empl_rs->create ({
442 name => 'cat1',
443 secretkey => {
444 encoded => 'CHEEZBURGER',
445 keyholders => [
446 {
447 name => 'cat2',
448 },
449 {
450 name => 'cat3',
451 },
452 ],
453 },
454 });
455
456 is($empl_rs->find({name => 'cat1'})->secretkey->encoded, 'REGRUBZEEHC', 'correct secret in database for empl1');
457 is($empl_rs->find({name => 'cat2'})->secretkey->encoded, 'REGRUBZEEHC', 'correct secret in database for empl2');
458 is($empl_rs->find({name => 'cat3'})->secretkey->encoded, 'REGRUBZEEHC', 'correct secret in database for empl3');
459
460 }
461
421462 # make sure we got rid of the compat shims
422463 SKIP: {
423464 skip "Remove in 0.082", 3 if $DBIx::Class::VERSION < 0.082;
+63
-63
t/61findnot.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Warn;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 my $schema = DBICTest->init_schema();
9
10 plan tests => 20;
11
12 my $art = $schema->resultset("Artist")->find(4);
13 ok(!defined($art), 'Find on primary id: artist not found');
14 my @cd = $schema->resultset("CD")->find(6);
15 cmp_ok(@cd, '==', 1, 'Return something even in array context');
16 ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
17
18 $art = $schema->resultset("Artist")->find({artistid => '4'});
19 ok(!defined($art), 'Find on unique constraint: artist not found');
20 @cd = $schema->resultset("CD")->find({artist => '2', title => 'Lada-Di Lada-Da'});
21 cmp_ok(@cd, '==', 1, 'Return something even in array context');
22 ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
23
24 $art = $schema->resultset("Artist")->search({name => 'The Jesus And Mary Chain'});
25 isa_ok($art, 'DBIx::Class::ResultSet', 'get a DBIx::Class::ResultSet object');
26 my $next = $art->next;
27 ok(!defined($next), 'Nothing next in ResultSet');
28 my $cd = $schema->resultset("CD")->search({title => 'Rubbersoul'});
29 @cd = $cd->next;
30 cmp_ok(@cd, '==', 1, 'Return something even in array context');
31 ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
32
33 $art = $schema->resultset("Artist")->single({name => 'Bikini Bottom Boys'});
34 ok(!defined($art), 'Find on primary id: artist not found');
35 @cd = $schema->resultset("CD")->single({title => 'The Singles 1962-2006'});
36 cmp_ok(@cd, '==', 1, 'Return something even in array context');
37 ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
38
39 $art = $schema->resultset("Artist")->search({name => 'Random Girl Band'});
40 isa_ok($art, 'DBIx::Class::ResultSet', 'get a DBIx::Class::ResultSet object');
41 $next = $art->single;
42 ok(!defined($next), 'Nothing next in ResultSet');
43 $cd = $schema->resultset("CD")->search({title => 'Call of the West'});
44 @cd = $cd->single;
45 cmp_ok(@cd, '==', 1, 'Return something even in array context');
46 ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
47
48 $cd = $schema->resultset("CD")->first;
49 my $artist_rs = $schema->resultset("Artist")->search({ artistid => $cd->artist->artistid });
50 $art = $artist_rs->find({ name => 'some other name' }, { key => 'primary' });
51 ok($art, 'Artist found by key in the resultset');
52
53 $artist_rs = $schema->resultset("Artist");
54 warning_is {
55 $artist_rs->find({}, { key => 'primary' })
56 } "DBIx::Class::ResultSet::find(): Query returned more than one row. SQL that returns multiple rows is DEPRECATED for ->find and ->single"
57 => "Non-unique find generated a cursor inexhaustion warning";
58
59 $artist_rs = $schema->resultset("Artist")->search({}, { prefetch => 'cds' });
60 warning_is {
61 $artist_rs->find({}, { key => 'primary' })
62 } "DBIx::Class::ResultSet::find(): Query returned more than one row", "Non-unique find generated a cursor inexhaustion warning";
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Warn;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 my $schema = DBICTest->init_schema();
9
10 plan tests => 20;
11
12 my $art = $schema->resultset("Artist")->find(4);
13 ok(!defined($art), 'Find on primary id: artist not found');
14 my @cd = $schema->resultset("CD")->find(6);
15 cmp_ok(@cd, '==', 1, 'Return something even in array context');
16 ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
17
18 $art = $schema->resultset("Artist")->find({artistid => '4'});
19 ok(!defined($art), 'Find on unique constraint: artist not found');
20 @cd = $schema->resultset("CD")->find({artist => '2', title => 'Lada-Di Lada-Da'});
21 cmp_ok(@cd, '==', 1, 'Return something even in array context');
22 ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
23
24 $art = $schema->resultset("Artist")->search({name => 'The Jesus And Mary Chain'});
25 isa_ok($art, 'DBIx::Class::ResultSet', 'get a DBIx::Class::ResultSet object');
26 my $next = $art->next;
27 ok(!defined($next), 'Nothing next in ResultSet');
28 my $cd = $schema->resultset("CD")->search({title => 'Rubbersoul'});
29 @cd = $cd->next;
30 cmp_ok(@cd, '==', 1, 'Return something even in array context');
31 ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
32
33 $art = $schema->resultset("Artist")->single({name => 'Bikini Bottom Boys'});
34 ok(!defined($art), 'Find on primary id: artist not found');
35 @cd = $schema->resultset("CD")->single({title => 'The Singles 1962-2006'});
36 cmp_ok(@cd, '==', 1, 'Return something even in array context');
37 ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
38
39 $art = $schema->resultset("Artist")->search({name => 'Random Girl Band'});
40 isa_ok($art, 'DBIx::Class::ResultSet', 'get a DBIx::Class::ResultSet object');
41 $next = $art->single;
42 ok(!defined($next), 'Nothing next in ResultSet');
43 $cd = $schema->resultset("CD")->search({title => 'Call of the West'});
44 @cd = $cd->single;
45 cmp_ok(@cd, '==', 1, 'Return something even in array context');
46 ok(@cd && !defined($cd[0]), 'Array contains an undef as only element');
47
48 $cd = $schema->resultset("CD")->first;
49 my $artist_rs = $schema->resultset("Artist")->search({ artistid => $cd->artist->artistid });
50 $art = $artist_rs->find({ name => 'some other name' }, { key => 'primary' });
51 ok($art, 'Artist found by key in the resultset');
52
53 $artist_rs = $schema->resultset("Artist");
54 warning_is {
55 $artist_rs->find({}, { key => 'primary' })
56 } "DBIx::Class::ResultSet::find(): Query returned more than one row. SQL that returns multiple rows is DEPRECATED for ->find and ->single"
57 => "Non-unique find generated a cursor inexhaustion warning";
58
59 $artist_rs = $schema->resultset("Artist")->search({}, { prefetch => 'cds' });
60 warning_is {
61 $artist_rs->find({}, { key => 'primary' })
62 } "DBIx::Class::ResultSet::find(): Query returned more than one row", "Non-unique find generated a cursor inexhaustion warning";
+18
-18
t/63register_source.t less more
0 use strict;
1 use warnings;
2
3 use Test::Exception tests => 1;
4 use lib qw(t/lib);
5 use DBICTest;
6 use DBICTest::Schema;
7 use DBIx::Class::ResultSource::Table;
8
9 my $schema = DBICTest->init_schema();
10
11 my $foo = DBIx::Class::ResultSource::Table->new({ name => "foo" });
12 my $bar = DBIx::Class::ResultSource::Table->new({ name => "bar" });
13
14 lives_ok {
15 $schema->register_source(foo => $foo);
16 $schema->register_source(bar => $bar);
17 } 'multiple classless sources can be registered';
0 use strict;
1 use warnings;
2
3 use Test::Exception tests => 1;
4 use lib qw(t/lib);
5 use DBICTest;
6 use DBICTest::Schema;
7 use DBIx::Class::ResultSource::Table;
8
9 my $schema = DBICTest->init_schema();
10
11 my $foo = DBIx::Class::ResultSource::Table->new({ name => "foo" });
12 my $bar = DBIx::Class::ResultSource::Table->new({ name => "bar" });
13
14 lives_ok {
15 $schema->register_source(foo => $foo);
16 $schema->register_source(bar => $bar);
17 } 'multiple classless sources can be registered';
+102
-102
t/64db.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 4;
10
11 # add some rows inside a transaction and commit it
12 # XXX: Is storage->dbh the only way to get a dbh?
13 $schema->storage->txn_begin;
14 for (10..15) {
15 $schema->resultset("Artist")->create( {
16 artistid => $_,
17 name => "artist number $_",
18 } );
19 }
20 $schema->storage->txn_commit;
21 my ($artist) = $schema->resultset("Artist")->find(15);
22 is($artist->name, 'artist number 15', "Commit ok");
23
24 # add some rows inside a transaction and roll it back
25 $schema->storage->txn_begin;
26 for (21..30) {
27 $schema->resultset("Artist")->create( {
28 artistid => $_,
29 name => "artist number $_",
30 } );
31 }
32 $schema->storage->txn_rollback;
33 ($artist) = $schema->resultset("Artist")->search( artistid => 25 );
34 is($artist, undef, "Rollback ok");
35
36 is_deeply (
37 get_storage_column_info ($schema->storage, 'collection', qw/size is_nullable/),
38 {
39 collectionid => {
40 data_type => 'INTEGER',
41 },
42 name => {
43 data_type => 'varchar',
44 },
45 },
46 'Correctly retrieve column info (no size or is_nullable)'
47 );
48
49 TODO: {
50 local $TODO = 'All current versions of SQLite seem to mis-report is_nullable';
51
52 is_deeply (
53 get_storage_column_info ($schema->storage, 'artist', qw/size/),
54 {
55 'artistid' => {
56 'data_type' => 'INTEGER',
57 'is_nullable' => 0,
58 },
59 'name' => {
60 'data_type' => 'varchar',
61 'is_nullable' => 1,
62 },
63 'rank' => {
64 'data_type' => 'integer',
65 'is_nullable' => 0,
66 'default_value' => '13',
67 },
68 'charfield' => {
69 'data_type' => 'char',
70 'is_nullable' => 1,
71 },
72 },
73 'Correctly retrieve column info (mixed null and non-null columns)'
74 );
75 };
76
77
78 # Depending on test we need to strip away certain column info.
79 # - SQLite is known to report the size differently from release to release
80 # - Current DBD::SQLite versions do not implement NULLABLE
81 # - Some SQLite releases report stuff that isn't there as undef
82
83 sub get_storage_column_info {
84 my ($storage, $table, @ignore) = @_;
85
86 my $type_info = $storage->columns_info_for($table);
87
88 for my $col (keys %$type_info) {
89 for my $type (keys %{$type_info->{$col}}) {
90 if (
91 grep { $type eq $_ } (@ignore)
92 or
93 not defined $type_info->{$col}{$type}
94 ) {
95 delete $type_info->{$col}{$type};
96 }
97 }
98 }
99
100 return $type_info;
101 }
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 4;
10
11 # add some rows inside a transaction and commit it
12 # XXX: Is storage->dbh the only way to get a dbh?
13 $schema->storage->txn_begin;
14 for (10..15) {
15 $schema->resultset("Artist")->create( {
16 artistid => $_,
17 name => "artist number $_",
18 } );
19 }
20 $schema->storage->txn_commit;
21 my ($artist) = $schema->resultset("Artist")->find(15);
22 is($artist->name, 'artist number 15', "Commit ok");
23
24 # add some rows inside a transaction and roll it back
25 $schema->storage->txn_begin;
26 for (21..30) {
27 $schema->resultset("Artist")->create( {
28 artistid => $_,
29 name => "artist number $_",
30 } );
31 }
32 $schema->storage->txn_rollback;
33 ($artist) = $schema->resultset("Artist")->search( artistid => 25 );
34 is($artist, undef, "Rollback ok");
35
36 is_deeply (
37 get_storage_column_info ($schema->storage, 'collection', qw/size is_nullable/),
38 {
39 collectionid => {
40 data_type => 'INTEGER',
41 },
42 name => {
43 data_type => 'varchar',
44 },
45 },
46 'Correctly retrieve column info (no size or is_nullable)'
47 );
48
49 TODO: {
50 local $TODO = 'All current versions of SQLite seem to mis-report is_nullable';
51
52 is_deeply (
53 get_storage_column_info ($schema->storage, 'artist', qw/size/),
54 {
55 'artistid' => {
56 'data_type' => 'INTEGER',
57 'is_nullable' => 0,
58 },
59 'name' => {
60 'data_type' => 'varchar',
61 'is_nullable' => 1,
62 },
63 'rank' => {
64 'data_type' => 'integer',
65 'is_nullable' => 0,
66 'default_value' => '13',
67 },
68 'charfield' => {
69 'data_type' => 'char',
70 'is_nullable' => 1,
71 },
72 },
73 'Correctly retrieve column info (mixed null and non-null columns)'
74 );
75 };
76
77
78 # Depending on test we need to strip away certain column info.
79 # - SQLite is known to report the size differently from release to release
80 # - Current DBD::SQLite versions do not implement NULLABLE
81 # - Some SQLite releases report stuff that isn't there as undef
82
83 sub get_storage_column_info {
84 my ($storage, $table, @ignore) = @_;
85
86 my $type_info = $storage->columns_info_for($table);
87
88 for my $col (keys %$type_info) {
89 for my $type (keys %{$type_info->{$col}}) {
90 if (
91 grep { $type eq $_ } (@ignore)
92 or
93 not defined $type_info->{$col}{$type}
94 ) {
95 delete $type_info->{$col}{$type};
96 }
97 }
98 }
99
100 return $type_info;
101 }
+19
-19
t/65multipk.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 5;
10
11 my $artist = $schema->resultset("Artist")->find(1);
12 ok($artist->find_related('twokeys', {cd => 1}), "find multiple pks using relationships + args");
13
14 ok($schema->resultset("FourKeys")->search({ foo => 1, bar => 2 })->find({ hello => 3, goodbye => 4 }), "search on partial key followed by a find");
15 ok($schema->resultset("FourKeys")->find(1,2,3,4), "find multiple pks without hash");
16 ok($schema->resultset("FourKeys")->find(5,4,3,6), "find multiple pks without hash");
17 is($schema->resultset("FourKeys")->find(1,2,3,4)->ID, 'DBICTest::FourKeys|fourkeys|bar=2|foo=1|goodbye=4|hello=3', 'unique object id ok for multiple pks');
18
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 5;
10
11 my $artist = $schema->resultset("Artist")->find(1);
12 ok($artist->find_related('twokeys', {cd => 1}), "find multiple pks using relationships + args");
13
14 ok($schema->resultset("FourKeys")->search({ foo => 1, bar => 2 })->find({ hello => 3, goodbye => 4 }), "search on partial key followed by a find");
15 ok($schema->resultset("FourKeys")->find(1,2,3,4), "find multiple pks without hash");
16 ok($schema->resultset("FourKeys")->find(5,4,3,6), "find multiple pks without hash");
17 is($schema->resultset("FourKeys")->find(1,2,3,4)->ID, 'DBICTest::FourKeys|fourkeys|bar=2|foo=1|goodbye=4|hello=3', 'unique object id ok for multiple pks');
18
+102
-102
t/67pager.t less more
0 use strict;
1 use warnings;
2
3 use Test::More qw(no_plan);
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 # first page
10 my $it = $schema->resultset("CD")->search(
11 {},
12 { order_by => 'title',
13 rows => 3,
14 page => 1 }
15 );
16
17 is( $it->pager->entries_on_this_page, 3, "entries_on_this_page ok" );
18
19 is( $it->pager->next_page, 2, "next_page ok" );
20
21 is( $it->count, 3, "count on paged rs ok" );
22
23 is( $it->pager->total_entries, 5, "total_entries ok" );
24
25 is( $it->next->title, "Caterwaulin' Blues", "iterator->next ok" );
26
27 $it->next;
28 $it->next;
29
30 is( $it->next, undef, "next past end of page ok" );
31
32 # second page, testing with array
33 my @page2 = $schema->resultset("CD")->search(
34 {},
35 { order_by => 'title',
36 rows => 3,
37 page => 2 }
38 );
39
40 is( $page2[0]->title, "Generic Manufactured Singles", "second page first title ok" );
41
42 # page a standard resultset
43 $it = $schema->resultset("CD")->search(
44 {},
45 { order_by => 'title',
46 rows => 3 }
47 );
48 my $page = $it->page(2);
49
50 is( $page->count, 2, "standard resultset paged rs count ok" );
51
52 is( $page->next->title, "Generic Manufactured Singles", "second page of standard resultset ok" );
53
54 # test software-based limit paging
55 $it = $schema->resultset("CD")->search(
56 {},
57 { order_by => 'title',
58 rows => 3,
59 page => 2,
60 software_limit => 1 }
61 );
62 is( $it->pager->entries_on_this_page, 2, "software entries_on_this_page ok" );
63
64 is( $it->pager->previous_page, 1, "software previous_page ok" );
65
66 is( $it->count, 2, "software count on paged rs ok" );
67
68 is( $it->next->title, "Generic Manufactured Singles", "software iterator->next ok" );
69
70 # test paging with chained searches
71 $it = $schema->resultset("CD")->search(
72 {},
73 { rows => 2,
74 page => 2 }
75 )->search( undef, { order_by => 'title' } );
76
77 is( $it->count, 2, "chained searches paging ok" );
78
79 my $p = sub { $schema->resultset("CD")->page(1)->pager->entries_per_page; };
80
81 is($p->(), 10, 'default rows is 10');
82
83 $schema->default_resultset_attributes({ rows => 5 });
84
85 is($p->(), 5, 'default rows is 5');
86
87 # test page with offset
88 $it = $schema->resultset('CD')->search({}, {
89 rows => 2,
90 page => 2,
91 offset => 1,
92 order_by => 'cdid'
93 });
94
95 my $row = $schema->resultset('CD')->search({}, {
96 order_by => 'cdid',
97 offset => 3,
98 rows => 1
99 })->single;
100
101 is($row->cdid, $it->first->cdid, 'page with offset');
0 use strict;
1 use warnings;
2
3 use Test::More qw(no_plan);
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 # first page
10 my $it = $schema->resultset("CD")->search(
11 {},
12 { order_by => 'title',
13 rows => 3,
14 page => 1 }
15 );
16
17 is( $it->pager->entries_on_this_page, 3, "entries_on_this_page ok" );
18
19 is( $it->pager->next_page, 2, "next_page ok" );
20
21 is( $it->count, 3, "count on paged rs ok" );
22
23 is( $it->pager->total_entries, 5, "total_entries ok" );
24
25 is( $it->next->title, "Caterwaulin' Blues", "iterator->next ok" );
26
27 $it->next;
28 $it->next;
29
30 is( $it->next, undef, "next past end of page ok" );
31
32 # second page, testing with array
33 my @page2 = $schema->resultset("CD")->search(
34 {},
35 { order_by => 'title',
36 rows => 3,
37 page => 2 }
38 );
39
40 is( $page2[0]->title, "Generic Manufactured Singles", "second page first title ok" );
41
42 # page a standard resultset
43 $it = $schema->resultset("CD")->search(
44 {},
45 { order_by => 'title',
46 rows => 3 }
47 );
48 my $page = $it->page(2);
49
50 is( $page->count, 2, "standard resultset paged rs count ok" );
51
52 is( $page->next->title, "Generic Manufactured Singles", "second page of standard resultset ok" );
53
54 # test software-based limit paging
55 $it = $schema->resultset("CD")->search(
56 {},
57 { order_by => 'title',
58 rows => 3,
59 page => 2,
60 software_limit => 1 }
61 );
62 is( $it->pager->entries_on_this_page, 2, "software entries_on_this_page ok" );
63
64 is( $it->pager->previous_page, 1, "software previous_page ok" );
65
66 is( $it->count, 2, "software count on paged rs ok" );
67
68 is( $it->next->title, "Generic Manufactured Singles", "software iterator->next ok" );
69
70 # test paging with chained searches
71 $it = $schema->resultset("CD")->search(
72 {},
73 { rows => 2,
74 page => 2 }
75 )->search( undef, { order_by => 'title' } );
76
77 is( $it->count, 2, "chained searches paging ok" );
78
79 my $p = sub { $schema->resultset("CD")->page(1)->pager->entries_per_page; };
80
81 is($p->(), 10, 'default rows is 10');
82
83 $schema->default_resultset_attributes({ rows => 5 });
84
85 is($p->(), 5, 'default rows is 5');
86
87 # test page with offset
88 $it = $schema->resultset('CD')->search({}, {
89 rows => 2,
90 page => 2,
91 offset => 1,
92 order_by => 'cdid'
93 });
94
95 my $row = $schema->resultset('CD')->search({}, {
96 order_by => 'cdid',
97 offset => 3,
98 rows => 1
99 })->single;
100
101 is($row->cdid, $it->first->cdid, 'page with offset');
+22
-22
t/70auto.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 2;
10
11 $schema->class("Artist")->load_components(qw/PK::Auto::SQLite/);
12 # Should just be PK::Auto but this ensures the compat shim works
13
14 # add an artist without primary key to test Auto
15 my $artist = $schema->resultset("Artist")->create( { name => 'Auto' } );
16 $artist->name( 'Auto Change' );
17 ok($artist->update, 'update on object created without PK ok');
18
19 my $copied = $artist->copy({ name => 'Don\'t tell the RIAA', artistid => undef });
20 is($copied->name, 'Don\'t tell the RIAA', "Copied with PKs ok.");
21
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 2;
10
11 $schema->class("Artist")->load_components(qw/PK::Auto::SQLite/);
12 # Should just be PK::Auto but this ensures the compat shim works
13
14 # add an artist without primary key to test Auto
15 my $artist = $schema->resultset("Artist")->create( { name => 'Auto' } );
16 $artist->name( 'Auto Change' );
17 ok($artist->update, 'update on object created without PK ok');
18
19 my $copied = $artist->copy({ name => 'Don\'t tell the RIAA', artistid => undef });
20 is($copied->name, 'Don\'t tell the RIAA', "Copied with PKs ok.");
21
+23
-0
t/71mysql.t less more
193193 );
194194 }
195195
196 {
197 # Test support for straight joins
198 my $cdsrc = $schema->source('CD');
199 my $artrel_info = $cdsrc->relationship_info ('artist');
200 $cdsrc->add_relationship(
201 'straight_artist',
202 $artrel_info->{class},
203 $artrel_info->{cond},
204 { %{$artrel_info->{attrs}}, join_type => 'straight' },
205 );
206 is_same_sql_bind (
207 $cdsrc->resultset->search({}, { prefetch => 'straight_artist' })->as_query,
208 '(
209 SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
210 straight_artist.artistid, straight_artist.name, straight_artist.rank, straight_artist.charfield
211 FROM cd me
212 STRAIGHT_JOIN artist straight_artist ON straight_artist.artistid = me.artist
213 )',
214 [],
215 'straight joins correctly supported for mysql'
216 );
217 }
218
196219 ## Can we properly deal with the null search problem?
197220 ##
198221 ## Only way is to do a SET SQL_AUTO_IS_NULL = 0; on connect
+296
-224
t/72pg.t less more
1010
1111 plan skip_all => <<EOM unless $dsn && $user;
1212 Set \$ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test
13 ( NOTE: This test drops and creates tables called 'artist', 'casecheck',
14 'array_test' and 'sequence_test' as well as following sequences:
15 'pkid1_seq', 'pkid2_seq' and 'nonpkid_seq''. as well as following
16 schemas: 'dbic_t_schema', 'dbic_t_schema_2', 'dbic_t_schema_3',
17 'dbic_t_schema_4', and 'dbic_t_schema_5'
18 )
13 ( NOTE: This test drops and creates tables called 'artist', 'cd',
14 'timestamp_primary_key_test', 'track', 'casecheck', 'array_test' and
15 'sequence_test' as well as following sequences: 'pkid1_seq', 'pkid2_seq' and
16 'nonpkid_seq''. as well as following schemas: 'dbic_t_schema',
17 'dbic_t_schema_2', 'dbic_t_schema_3', 'dbic_t_schema_4', and 'dbic_t_schema_5')
1918 EOM
2019
2120 ### load any test classes that are defined further down in the file via BEGIN blocks
2322 our @test_classes; #< array that will be pushed into by test classes defined in this file
2423 DBICTest::Schema->load_classes( map {s/.+:://;$_} @test_classes ) if @test_classes;
2524
25 my $test_server_supports_insert_returning = do {
26 my $s = DBICTest::Schema->connect($dsn, $user, $pass);
27 $s->storage->_determine_driver;
28 $s->storage->_supports_insert_returning;
29 };
30
31 my $schema;
32
33 for my $use_insert_returning ($test_server_supports_insert_returning
34 ? (0,1)
35 : (0)
36 ) {
37 no warnings qw/redefine once/;
38 local *DBIx::Class::Storage::DBI::Pg::_supports_insert_returning = sub {
39 $use_insert_returning
40 };
2641
2742 ### pre-connect tests (keep each test separate as to make sure rebless() runs)
28 {
29 my $s = DBICTest::Schema->connect($dsn, $user, $pass);
30
31 ok (!$s->storage->_dbh, 'definitely not connected');
32
33 # Check that datetime_parser returns correctly before we explicitly connect.
34 SKIP: {
35 eval { require DateTime::Format::Pg };
36 skip "DateTime::Format::Pg required", 2 if $@;
37
38 my $store = ref $s->storage;
39 is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage');
40
41 my $parser = $s->storage->datetime_parser;
42 is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected');
43 {
44 my $s = DBICTest::Schema->connect($dsn, $user, $pass);
45
46 ok (!$s->storage->_dbh, 'definitely not connected');
47
48 # Check that datetime_parser returns correctly before we explicitly connect.
49 SKIP: {
50 eval { require DateTime::Format::Pg };
51 skip "DateTime::Format::Pg required", 2 if $@;
52
53 my $store = ref $s->storage;
54 is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage');
55
56 my $parser = $s->storage->datetime_parser;
57 is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected');
58 }
59
60 ok (!$s->storage->_dbh, 'still not connected');
4361 }
44
45 ok (!$s->storage->_dbh, 'still not connected');
46 }
47 {
48 my $s = DBICTest::Schema->connect($dsn, $user, $pass);
49 # make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
50 ok (!$s->storage->_dbh, 'definitely not connected');
51 is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection');
52 ok (!$s->storage->_dbh, 'still not connected');
53 }
62 {
63 my $s = DBICTest::Schema->connect($dsn, $user, $pass);
64 # make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
65 ok (!$s->storage->_dbh, 'definitely not connected');
66 is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection');
67 ok (!$s->storage->_dbh, 'still not connected');
68 }
5469
5570 ### connect, create postgres-specific test schema
5671
57 my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
58
59 drop_test_schema($schema);
60 create_test_schema($schema);
72 $schema = DBICTest::Schema->connect($dsn, $user, $pass);
73 $schema->storage->ensure_connected;
74
75 drop_test_schema($schema);
76 create_test_schema($schema);
6177
6278 ### begin main tests
63
6479
6580 # run a BIG bunch of tests for last-insert-id / Auto-PK / sequence
6681 # discovery
67 run_apk_tests($schema); #< older set of auto-pk tests
68 run_extended_apk_tests($schema); #< new extended set of auto-pk tests
69
70
71
72
82 run_apk_tests($schema); #< older set of auto-pk tests
83 run_extended_apk_tests($schema); #< new extended set of auto-pk tests
7384
7485 ### type_info tests
7586
76 my $test_type_info = {
77 'artistid' => {
78 'data_type' => 'integer',
79 'is_nullable' => 0,
80 'size' => 4,
81 },
82 'name' => {
83 'data_type' => 'character varying',
84 'is_nullable' => 1,
85 'size' => 100,
86 'default_value' => undef,
87 },
88 'rank' => {
89 'data_type' => 'integer',
90 'is_nullable' => 0,
91 'size' => 4,
92 'default_value' => 13,
93
94 },
95 'charfield' => {
96 'data_type' => 'character',
97 'is_nullable' => 1,
98 'size' => 10,
99 'default_value' => undef,
100 },
101 'arrayfield' => {
102 'data_type' => 'integer[]',
103 'is_nullable' => 1,
104 'size' => undef,
105 'default_value' => undef,
106 },
107 };
108
109 my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist');
110 my $artistid_defval = delete $type_info->{artistid}->{default_value};
111 like($artistid_defval,
112 qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
113 'columns_info_for - sequence matches Pg get_autoinc_seq expectations');
114 is_deeply($type_info, $test_type_info,
115 'columns_info_for - column data types');
87 my $test_type_info = {
88 'artistid' => {
89 'data_type' => 'integer',
90 'is_nullable' => 0,
91 'size' => 4,
92 },
93 'name' => {
94 'data_type' => 'character varying',
95 'is_nullable' => 1,
96 'size' => 100,
97 'default_value' => undef,
98 },
99 'rank' => {
100 'data_type' => 'integer',
101 'is_nullable' => 0,
102 'size' => 4,
103 'default_value' => 13,
104
105 },
106 'charfield' => {
107 'data_type' => 'character',
108 'is_nullable' => 1,
109 'size' => 10,
110 'default_value' => undef,
111 },
112 'arrayfield' => {
113 'data_type' => 'integer[]',
114 'is_nullable' => 1,
115 'size' => undef,
116 'default_value' => undef,
117 },
118 };
119
120 my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist');
121 my $artistid_defval = delete $type_info->{artistid}->{default_value};
122 like($artistid_defval,
123 qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
124 'columns_info_for - sequence matches Pg get_autoinc_seq expectations');
125 is_deeply($type_info, $test_type_info,
126 'columns_info_for - column data types');
116127
117128
118129
119130
120131 ####### Array tests
121132
122 BEGIN {
123 package DBICTest::Schema::ArrayTest;
124 push @main::test_classes, __PACKAGE__;
125
126 use strict;
127 use warnings;
128 use base 'DBIx::Class::Core';
129
130 __PACKAGE__->table('dbic_t_schema.array_test');
131 __PACKAGE__->add_columns(qw/id arrayfield/);
132 __PACKAGE__->column_info_from_storage(1);
133 __PACKAGE__->set_primary_key('id');
134
135 }
136 SKIP: {
137 skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002;
138
133 BEGIN {
134 package DBICTest::Schema::ArrayTest;
135 push @main::test_classes, __PACKAGE__;
136
137 use strict;
138 use warnings;
139 use base 'DBIx::Class::Core';
140
141 __PACKAGE__->table('dbic_t_schema.array_test');
142 __PACKAGE__->add_columns(qw/id arrayfield/);
143 __PACKAGE__->column_info_from_storage(1);
144 __PACKAGE__->set_primary_key('id');
145
146 }
147 SKIP: {
148 skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002;
149
150 lives_ok {
151 $schema->resultset('ArrayTest')->create({
152 arrayfield => [1, 2],
153 });
154 } 'inserting arrayref as pg array data';
155
156 lives_ok {
157 $schema->resultset('ArrayTest')->update({
158 arrayfield => [3, 4],
159 });
160 } 'updating arrayref as pg array data';
161
162 $schema->resultset('ArrayTest')->create({
163 arrayfield => [5, 6],
164 });
165
166 my $count;
167 lives_ok {
168 $count = $schema->resultset('ArrayTest')->search({
169 arrayfield => \[ '= ?' => [arrayfield => [3, 4]] ], #Todo anything less ugly than this?
170 })->count;
171 } 'comparing arrayref to pg array data does not blow up';
172 is($count, 1, 'comparing arrayref to pg array data gives correct result');
173 }
174
175
176
177 ########## Case check
178
179 BEGIN {
180 package DBICTest::Schema::Casecheck;
181 push @main::test_classes, __PACKAGE__;
182
183 use strict;
184 use warnings;
185 use base 'DBIx::Class::Core';
186
187 __PACKAGE__->table('dbic_t_schema.casecheck');
188 __PACKAGE__->add_columns(qw/id name NAME uc_name/);
189 __PACKAGE__->column_info_from_storage(1);
190 __PACKAGE__->set_primary_key('id');
191 }
192
193 my $name_info = $schema->source('Casecheck')->column_info( 'name' );
194 is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
195
196 my $NAME_info = $schema->source('Casecheck')->column_info( 'NAME' );
197 is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" );
198
199 my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' );
200 is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
201
202
203
204
205 ## Test SELECT ... FOR UPDATE
206
207 SKIP: {
208 if(eval "require Sys::SigAction" && !$@) {
209 Sys::SigAction->import( 'set_sig_handler' );
210 }
211 else {
212 skip "Sys::SigAction is not available", 6;
213 }
214
215 my ($timed_out, $artist2);
216
217 for my $t (
218 {
219 # Make sure that an error was raised, and that the update failed
220 update_lock => 1,
221 test_sub => sub {
222 ok($timed_out, "update from second schema times out");
223 ok($artist2->is_column_changed('name'), "'name' column is still dirty from second schema");
224 },
225 },
226 {
227 # Make sure that an error was NOT raised, and that the update succeeded
228 update_lock => 0,
229 test_sub => sub {
230 ok(! $timed_out, "update from second schema DOES NOT timeout");
231 ok(! $artist2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
232 },
233 },
234 ) {
235 # create a new schema
236 my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
237 $schema2->source("Artist")->name("dbic_t_schema.artist");
238
239 $schema->txn_do( sub {
240 my $artist = $schema->resultset('Artist')->search(
241 {
242 artistid => 1
243 },
244 $t->{update_lock} ? { for => 'update' } : {}
245 )->first;
246 is($artist->artistid, 1, "select returns artistid = 1");
247
248 $timed_out = 0;
249 eval {
250 my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
251 alarm(2);
252 $artist2 = $schema2->resultset('Artist')->find(1);
253 $artist2->name('fooey');
254 $artist2->update;
255 alarm(0);
256 };
257 $timed_out = $@ =~ /DBICTestTimeout/;
258 });
259
260 $t->{test_sub}->();
261 }
262 }
263
264
265 ######## other older Auto-pk tests
266
267 $schema->source("SequenceTest")->name("dbic_t_schema.sequence_test");
268 for (1..5) {
269 my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
270 is($st->pkid1, $_, "Auto-PK for sequence without default: First primary key");
271 is($st->pkid2, $_ + 9, "Auto-PK for sequence without default: Second primary key");
272 is($st->nonpkid, $_ + 19, "Auto-PK for sequence without default: Non-primary key");
273 }
274 my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
275 is($st->pkid1, 55, "Auto-PK for sequence without default: First primary key set manually");
276
277
278 ######## test non-serial auto-pk
279
280 if ($schema->storage->_supports_insert_returning) {
281 $schema->source('TimestampPrimaryKey')->name('dbic_t_schema.timestamp_primary_key_test');
282 my $row = $schema->resultset('TimestampPrimaryKey')->create({});
283 ok $row->id;
284 }
285
286 ######## test with_deferred_fk_checks
287
288 $schema->source('CD')->name('dbic_t_schema.cd');
289 $schema->source('Track')->name('dbic_t_schema.track');
139290 lives_ok {
140 $schema->resultset('ArrayTest')->create({
141 arrayfield => [1, 2],
291 $schema->storage->with_deferred_fk_checks(sub {
292 $schema->resultset('Track')->create({
293 trackid => 999, cd => 999, position => 1, title => 'deferred FK track'
294 });
295 $schema->resultset('CD')->create({
296 artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd'
297 });
142298 });
143 } 'inserting arrayref as pg array data';
144
145 lives_ok {
146 $schema->resultset('ArrayTest')->update({
147 arrayfield => [3, 4],
299 } 'with_deferred_fk_checks code survived';
300
301 is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track',
302 'code in with_deferred_fk_checks worked';
303
304 throws_ok {
305 $schema->resultset('Track')->create({
306 trackid => 1, cd => 9999, position => 1, title => 'Track1'
148307 });
149 } 'updating arrayref as pg array data';
150
151 $schema->resultset('ArrayTest')->create({
152 arrayfield => [5, 6],
153 });
154
155 my $count;
156 lives_ok {
157 $count = $schema->resultset('ArrayTest')->search({
158 arrayfield => \[ '= ?' => [arrayfield => [3, 4]] ], #Todo anything less ugly than this?
159 })->count;
160 } 'comparing arrayref to pg array data does not blow up';
161 is($count, 1, 'comparing arrayref to pg array data gives correct result');
162 }
163
164
165
166 ########## Case check
167
168 BEGIN {
169 package DBICTest::Schema::Casecheck;
170 push @main::test_classes, __PACKAGE__;
171
172 use strict;
173 use warnings;
174 use base 'DBIx::Class::Core';
175
176 __PACKAGE__->table('dbic_t_schema.casecheck');
177 __PACKAGE__->add_columns(qw/id name NAME uc_name/);
178 __PACKAGE__->column_info_from_storage(1);
179 __PACKAGE__->set_primary_key('id');
180 }
181
182 my $name_info = $schema->source('Casecheck')->column_info( 'name' );
183 is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
184
185 my $NAME_info = $schema->source('Casecheck')->column_info( 'NAME' );
186 is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" );
187
188 my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' );
189 is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
190
191
192
193
194 ## Test SELECT ... FOR UPDATE
195
196 SKIP: {
197 if(eval "require Sys::SigAction" && !$@) {
198 Sys::SigAction->import( 'set_sig_handler' );
199 }
200 else {
201 skip "Sys::SigAction is not available", 6;
202 }
203
204 my ($timed_out, $artist2);
205
206 for my $t (
207 {
208 # Make sure that an error was raised, and that the update failed
209 update_lock => 1,
210 test_sub => sub {
211 ok($timed_out, "update from second schema times out");
212 ok($artist2->is_column_changed('name'), "'name' column is still dirty from second schema");
213 },
214 },
215 {
216 # Make sure that an error was NOT raised, and that the update succeeded
217 update_lock => 0,
218 test_sub => sub {
219 ok(! $timed_out, "update from second schema DOES NOT timeout");
220 ok(! $artist2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
221 },
222 },
223 ) {
224 # create a new schema
225 my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
226 $schema2->source("Artist")->name("dbic_t_schema.artist");
227
228 $schema->txn_do( sub {
229 my $artist = $schema->resultset('Artist')->search(
230 {
231 artistid => 1
232 },
233 $t->{update_lock} ? { for => 'update' } : {}
234 )->first;
235 is($artist->artistid, 1, "select returns artistid = 1");
236
237 $timed_out = 0;
238 eval {
239 my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
240 alarm(2);
241 $artist2 = $schema2->resultset('Artist')->find(1);
242 $artist2->name('fooey');
243 $artist2->update;
244 alarm(0);
245 };
246 $timed_out = $@ =~ /DBICTestTimeout/;
247 });
248
249 $t->{test_sub}->();
250 }
251 }
252
253
254 ######## other older Auto-pk tests
255
256 $schema->source("SequenceTest")->name("dbic_t_schema.sequence_test");
257 for (1..5) {
258 my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
259 is($st->pkid1, $_, "Oracle Auto-PK without trigger: First primary key");
260 is($st->pkid2, $_ + 9, "Oracle Auto-PK without trigger: Second primary key");
261 is($st->nonpkid, $_ + 19, "Oracle Auto-PK without trigger: Non-primary key");
262 }
263 my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
264 is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
308 } qr/constraint/i, 'with_deferred_fk_checks is off';
309 }
265310
266311 done_testing;
267
268 exit;
269312
270313 END {
271314 return unless $schema;
295338
296339 $dbh->do("CREATE SCHEMA dbic_t_schema");
297340 $dbh->do("CREATE TABLE dbic_t_schema.artist $std_artist_table");
341
342 $dbh->do(<<EOS);
343 CREATE TABLE dbic_t_schema.timestamp_primary_key_test (
344 id timestamp default current_timestamp
345 )
346 EOS
347 $dbh->do(<<EOS);
348 CREATE TABLE dbic_t_schema.cd (
349 cdid int PRIMARY KEY,
350 artist int,
351 title varchar(255),
352 year varchar(4),
353 genreid int,
354 single_track int
355 )
356 EOS
357 $dbh->do(<<EOS);
358 CREATE TABLE dbic_t_schema.track (
359 trackid int,
360 cd int REFERENCES dbic_t_schema.cd(cdid) DEFERRABLE,
361 position int,
362 title varchar(255),
363 last_updated_on date,
364 last_updated_at date,
365 small_dt date
366 )
367 EOS
368
298369 $dbh->do(<<EOS);
299370 CREATE TABLE dbic_t_schema.sequence_test (
300371 pkid1 integer
477548 my $search_path_save = eapk_get_search_path($schema);
478549
479550 eapk_drop_all($schema);
551 %seqs = ();
480552
481553 # make the test schemas and sequences
482554 $schema->storage->dbh_do(sub {
+87
-87
t/746db2_400.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_400_${_}" } qw/DSN USER PASS/};
8
9 #warn "$dsn $user $pass";
10
11 # Probably best to pass the DBQ option in the DSN to specify a specific
12 # libray. Something like:
13 # DBICTEST_DB2_400_DSN='dbi:ODBC:dsn=MyAS400;DBQ=MYLIB'
14 plan skip_all => 'Set $ENV{DBICTEST_DB2_400_DSN}, _USER and _PASS to run this test'
15 unless ($dsn && $user);
16
17 plan tests => 6;
18
19 my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
20
21 my $dbh = $schema->storage->dbh;
22
23 eval { $dbh->do("DROP TABLE artist") };
24
25 $dbh->do(<<'');
26 CREATE TABLE artist (
27 artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1),
28 name VARCHAR(255),
29 rank INTEGER default 13 not null,
30 charfield CHAR(10)
31 )
32
33 # Just to test loading, already in Core
34 $schema->class('Artist')->load_components('PK::Auto');
35
36 # test primary key handling
37 my $new = $schema->resultset('Artist')->create({ name => 'foo' });
38 ok($new->artistid, "Auto-PK worked");
39
40 # test LIMIT support
41 for (1..6) {
42 $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
43 }
44 my $it = $schema->resultset('Artist')->search( {},
45 { rows => 3,
46 order_by => 'artistid'
47 }
48 );
49 is( $it->count, 3, "LIMIT count ok" );
50 is( $it->next->name, "foo", "iterator->next ok" );
51 $it->next;
52 is( $it->next->name, "Artist 2", "iterator->next ok" );
53 is( $it->next, undef, "next past end of resultset ok" );
54
55 my $test_type_info = {
56 'artistid' => {
57 'data_type' => 'INTEGER',
58 'is_nullable' => 0,
59 'size' => 10
60 },
61 'name' => {
62 'data_type' => 'VARCHAR',
63 'is_nullable' => 1,
64 'size' => 255
65 },
66 'rank' => {
67 'data_type' => 'INTEGER',
68 'is_nullable' => 0,
69 'size' => 10,
70 },
71 'charfield' => {
72 'data_type' => 'CHAR',
73 'is_nullable' => 1,
74 'size' => 10
75 },
76 };
77
78
79 my $type_info = $schema->storage->columns_info_for('artist');
80 is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
81
82 # clean up our mess
83 END {
84 my $dbh = eval { $schema->storage->_dbh };
85 $dbh->do("DROP TABLE artist") if $dbh;
86 }
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_400_${_}" } qw/DSN USER PASS/};
8
9 #warn "$dsn $user $pass";
10
11 # Probably best to pass the DBQ option in the DSN to specify a specific
12 # libray. Something like:
13 # DBICTEST_DB2_400_DSN='dbi:ODBC:dsn=MyAS400;DBQ=MYLIB'
14 plan skip_all => 'Set $ENV{DBICTEST_DB2_400_DSN}, _USER and _PASS to run this test'
15 unless ($dsn && $user);
16
17 plan tests => 6;
18
19 my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
20
21 my $dbh = $schema->storage->dbh;
22
23 eval { $dbh->do("DROP TABLE artist") };
24
25 $dbh->do(<<'');
26 CREATE TABLE artist (
27 artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1),
28 name VARCHAR(255),
29 rank INTEGER default 13 not null,
30 charfield CHAR(10)
31 )
32
33 # Just to test loading, already in Core
34 $schema->class('Artist')->load_components('PK::Auto');
35
36 # test primary key handling
37 my $new = $schema->resultset('Artist')->create({ name => 'foo' });
38 ok($new->artistid, "Auto-PK worked");
39
40 # test LIMIT support
41 for (1..6) {
42 $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
43 }
44 my $it = $schema->resultset('Artist')->search( {},
45 { rows => 3,
46 order_by => 'artistid'
47 }
48 );
49 is( $it->count, 3, "LIMIT count ok" );
50 is( $it->next->name, "foo", "iterator->next ok" );
51 $it->next;
52 is( $it->next->name, "Artist 2", "iterator->next ok" );
53 is( $it->next, undef, "next past end of resultset ok" );
54
55 my $test_type_info = {
56 'artistid' => {
57 'data_type' => 'INTEGER',
58 'is_nullable' => 0,
59 'size' => 10
60 },
61 'name' => {
62 'data_type' => 'VARCHAR',
63 'is_nullable' => 1,
64 'size' => 255
65 },
66 'rank' => {
67 'data_type' => 'INTEGER',
68 'is_nullable' => 0,
69 'size' => 10,
70 },
71 'charfield' => {
72 'data_type' => 'CHAR',
73 'is_nullable' => 1,
74 'size' => 10
75 },
76 };
77
78
79 my $type_info = $schema->storage->columns_info_for('artist');
80 is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
81
82 # clean up our mess
83 END {
84 my $dbh = eval { $schema->storage->_dbh };
85 $dbh->do("DROP TABLE artist") if $dbh;
86 }
+6
-0
t/746mssql.t less more
3131 my $schema2 = $schema->connect ($schema->storage->connect_info);
3232 ok (! $schema2->storage->connected, 'a re-connected cloned schema starts unconnected');
3333 }
34
35 $schema->storage->_dbh->disconnect;
36
37 lives_ok {
38 $schema->storage->dbh_do(sub { $_[1]->do('select 1') })
39 } '_ping works';
3440
3541 $schema->storage->dbh_do (sub {
3642 my ($storage, $dbh) = @_;
+4
-6
t/746sybase.t less more
568568 $row->update({ amount => undef });
569569 } 'updated a money value to NULL';
570570
571 my $null_amount = eval { $rs->find($row->id)->amount };
572 ok(
573 (($null_amount == undef) && (not $@)),
574 'updated money value to NULL round-trip'
575 );
576 diag $@ if $@;
571 lives_and {
572 my $null_amount = $rs->find($row->id)->amount;
573 is $null_amount, undef;
574 } 'updated money value to NULL round-trip';
577575
578576 # Test computed columns and timestamps
579577 $schema->storage->dbh_do (sub {
+67
-3
t/748informix.t less more
1010 #warn "$dsn $user $pass";
1111
1212 plan skip_all => 'Set $ENV{DBICTEST_INFORMIX_DSN}, _USER and _PASS to run this test'
13 unless ($dsn && $user);
13 unless $dsn;
1414
15 my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
15 my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
16 auto_savepoint => 1
17 });
1618
1719 my $dbh = $schema->storage->dbh;
1820
1921 eval { $dbh->do("DROP TABLE artist") };
20
2122 $dbh->do("CREATE TABLE artist (artistid SERIAL, name VARCHAR(255), charfield CHAR(10), rank INTEGER DEFAULT 13);");
23 eval { $dbh->do("DROP TABLE cd") };
24 $dbh->do(<<EOS);
25 CREATE TABLE cd (
26 cdid int PRIMARY KEY,
27 artist int,
28 title varchar(255),
29 year varchar(4),
30 genreid int,
31 single_track int
32 )
33 EOS
34 eval { $dbh->do("DROP TABLE track") };
35 $dbh->do(<<EOS);
36 CREATE TABLE track (
37 trackid int,
38 cd int REFERENCES cd(cdid),
39 position int,
40 title varchar(255),
41 last_updated_on date,
42 last_updated_at date,
43 small_dt date
44 )
45 EOS
2246
2347 my $ars = $schema->resultset('Artist');
2448 is ( $ars->count, 0, 'No rows at first' );
7195 is( $lim->next->artistid, 102, "iterator->next ok" );
7296 is( $lim->next, undef, "next past end of resultset ok" );
7397
98 # test savepoints
99 throws_ok {
100 $schema->txn_do(sub {
101 eval {
102 $schema->txn_do(sub {
103 $ars->create({ name => 'in_savepoint' });
104 die "rolling back savepoint";
105 });
106 };
107 ok ((not $ars->search({ name => 'in_savepoint' })->first),
108 'savepoint rolled back');
109 $ars->create({ name => 'in_outer_txn' });
110 die "rolling back outer txn";
111 });
112 } qr/rolling back outer txn/,
113 'correct exception for rollback';
114
115 ok ((not $ars->search({ name => 'in_outer_txn' })->first),
116 'outer txn rolled back');
117
118 ######## test with_deferred_fk_checks
119 lives_ok {
120 $schema->storage->with_deferred_fk_checks(sub {
121 $schema->resultset('Track')->create({
122 trackid => 999, cd => 999, position => 1, title => 'deferred FK track'
123 });
124 $schema->resultset('CD')->create({
125 artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd'
126 });
127 });
128 } 'with_deferred_fk_checks code survived';
129
130 is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track',
131 'code in with_deferred_fk_checks worked';
132
133 throws_ok {
134 $schema->resultset('Track')->create({
135 trackid => 1, cd => 9999, position => 1, title => 'Track1'
136 });
137 } qr/constraint/i, 'with_deferred_fk_checks is off';
74138
75139 done_testing;
76140
+66
-16
t/749sybase_asa.t less more
22
33 use Test::More;
44 use Test::Exception;
5 use Scope::Guard ();
56 use lib qw(t/lib);
67 use DBICTest;
8
9 DBICTest::Schema->load_classes('ArtistGUID');
710
811 # tests stolen from 748informix.t
912
2023 [ $dsn2, $user2, $pass2 ],
2124 );
2225
23 my @handles_to_clean;
26 my $schema;
2427
2528 foreach my $info (@info) {
2629 my ($dsn, $user, $pass) = @$info;
2730
2831 next unless $dsn;
2932
30 my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
33 $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
3134 auto_savepoint => 1
3235 });
3336
37 my $guard = Scope::Guard->new(\&cleanup);
38
3439 my $dbh = $schema->storage->dbh;
35
36 push @handles_to_clean, $dbh;
3740
3841 eval { $dbh->do("DROP TABLE artist") };
3942
6063 is($new->artistid, 66, 'Explicit PK assigned');
6164
6265 # test savepoints
63 eval {
66 throws_ok {
6467 $schema->txn_do(sub {
6568 eval {
6669 $schema->txn_do(sub {
7376 $ars->create({ name => 'in_outer_txn' });
7477 die "rolling back outer txn";
7578 });
76 };
77
78 like $@, qr/rolling back outer txn/,
79 } qr/rolling back outer txn/,
7980 'correct exception for rollback';
8081
8182 ok ((not $ars->search({ name => 'in_outer_txn' })->first),
161162 ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
162163 }
163164 }
164 }
165
166 done_testing;
167
168 # clean up our mess
169 END {
170 foreach my $dbh (@handles_to_clean) {
171 eval { $dbh->do("DROP TABLE $_") } for qw/artist bindtype_test/;
165
166 my @uuid_types = qw/uniqueidentifier uniqueidentifierstr/;
167
168 # test uniqueidentifiers
169 for my $uuid_type (@uuid_types) {
170 local $schema->source('ArtistGUID')->column_info('artistid')->{data_type}
171 = $uuid_type;
172
173 local $schema->source('ArtistGUID')->column_info('a_guid')->{data_type}
174 = $uuid_type;
175
176 $schema->storage->dbh_do (sub {
177 my ($storage, $dbh) = @_;
178 eval { $dbh->do("DROP TABLE artist") };
179 $dbh->do(<<"SQL");
180 CREATE TABLE artist (
181 artistid $uuid_type NOT NULL,
182 name VARCHAR(100),
183 rank INT NOT NULL DEFAULT '13',
184 charfield CHAR(10) NULL,
185 a_guid $uuid_type,
186 primary key(artistid)
187 )
188 SQL
189 });
190
191 my $row;
192 lives_ok {
193 $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
194 } 'created a row with a GUID';
195
196 ok(
197 eval { $row->artistid },
198 'row has GUID PK col populated',
199 );
200 diag $@ if $@;
201
202 ok(
203 eval { $row->a_guid },
204 'row has a GUID col with auto_nextval populated',
205 );
206 diag $@ if $@;
207
208 my $row_from_db = $schema->resultset('ArtistGUID')
209 ->search({ name => 'mtfnpy' })->first;
210
211 is $row_from_db->artistid, $row->artistid,
212 'PK GUID round trip';
213
214 is $row_from_db->a_guid, $row->a_guid,
215 'NON-PK GUID round trip';
172216 }
173217 }
218
219 done_testing;
220
221 sub cleanup {
222 eval { $schema->storage->dbh->do("DROP TABLE $_") } for qw/artist bindtype_test/;
223 }
+6
-5
t/74mssql.t less more
5151
5252 isa_ok($schema->storage, "DBIx::Class::Storage::$storage_type");
5353
54 # start disconnected to test reconnection
54 # start disconnected to test _ping
5555 $schema->storage->_dbh->disconnect;
5656
57 my $dbh;
58 lives_ok (sub {
59 $dbh = $schema->storage->dbh;
60 }, 'reconnect works');
57 lives_ok {
58 $schema->storage->dbh_do(sub { $_[1]->do('select 1') })
59 } '_ping works';
60
61 my $dbh = $schema->storage->dbh;
6162
6263 $dbh->do("IF OBJECT_ID('artist', 'U') IS NOT NULL
6364 DROP TABLE artist");
+274
-0
t/750firebird.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7 use Scope::Guard ();
8
9 # tests stolen from 749sybase_asa.t
10
11 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_FIREBIRD_${_}" } qw/DSN USER PASS/};
12 my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_FIREBIRD_ODBC_${_}" } qw/DSN USER PASS/};
13
14 plan skip_all => <<'EOF' unless $dsn || $dsn2;
15 Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN},
16 _USER and _PASS to run these tests.
17
18 WARNING: this test creates and drops the tables "artist", "bindtype_test" and
19 "sequence_test"; the generators "gen_artist_artistid", "pkid1_seq", "pkid2_seq"
20 and "nonpkid_seq" and the trigger "artist_bi".
21 EOF
22
23 my @info = (
24 [ $dsn, $user, $pass ],
25 [ $dsn2, $user2, $pass2 ],
26 );
27
28 my $schema;
29
30 foreach my $conn_idx (0..$#info) {
31 my ($dsn, $user, $pass) = @{ $info[$conn_idx] || [] };
32
33 next unless $dsn;
34
35 $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
36 auto_savepoint => 1,
37 quote_char => q["],
38 name_sep => q[.],
39 on_connect_call => 'use_softcommit',
40 });
41 my $dbh = $schema->storage->dbh;
42
43 my $sg = Scope::Guard->new(\&cleanup);
44
45 eval { $dbh->do(q[DROP TABLE "artist"]) };
46 $dbh->do(<<EOF);
47 CREATE TABLE "artist" (
48 "artistid" INT PRIMARY KEY,
49 "name" VARCHAR(255),
50 "charfield" CHAR(10),
51 "rank" INT DEFAULT 13
52 )
53 EOF
54 eval { $dbh->do(q[DROP GENERATOR "gen_artist_artistid"]) };
55 $dbh->do('CREATE GENERATOR "gen_artist_artistid"');
56 eval { $dbh->do('DROP TRIGGER "artist_bi"') };
57 $dbh->do(<<EOF);
58 CREATE TRIGGER "artist_bi" FOR "artist"
59 ACTIVE BEFORE INSERT POSITION 0
60 AS
61 BEGIN
62 IF (NEW."artistid" IS NULL) THEN
63 NEW."artistid" = GEN_ID("gen_artist_artistid",1);
64 END
65 EOF
66 eval { $dbh->do('DROP TABLE "sequence_test"') };
67 $dbh->do(<<EOF);
68 CREATE TABLE "sequence_test" (
69 "pkid1" INT NOT NULL,
70 "pkid2" INT NOT NULL,
71 "nonpkid" INT,
72 "name" VARCHAR(255)
73 )
74 EOF
75 $dbh->do('ALTER TABLE "sequence_test" ADD CONSTRAINT "sequence_test_constraint" PRIMARY KEY ("pkid1", "pkid2")');
76 eval { $dbh->do('DROP GENERATOR "pkid1_seq"') };
77 eval { $dbh->do('DROP GENERATOR "pkid2_seq"') };
78 eval { $dbh->do('DROP GENERATOR "nonpkid_seq"') };
79 $dbh->do('CREATE GENERATOR "pkid1_seq"');
80 $dbh->do('CREATE GENERATOR "pkid2_seq"');
81 $dbh->do('SET GENERATOR "pkid2_seq" TO 9');
82 $dbh->do('CREATE GENERATOR "nonpkid_seq"');
83 $dbh->do('SET GENERATOR "nonpkid_seq" TO 19');
84
85 my $ars = $schema->resultset('Artist');
86 is ( $ars->count, 0, 'No rows at first' );
87
88 # test primary key handling
89 my $new = $ars->create({ name => 'foo' });
90 ok($new->artistid, "Auto-PK worked");
91
92 # test auto increment using generators WITHOUT triggers
93 for (1..5) {
94 my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
95 is($st->pkid1, $_, "Firebird Auto-PK without trigger: First primary key");
96 is($st->pkid2, $_ + 9, "Firebird Auto-PK without trigger: Second primary key");
97 is($st->nonpkid, $_ + 19, "Firebird Auto-PK without trigger: Non-primary key");
98 }
99 my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
100 is($st->pkid1, 55, "Firebird Auto-PK without trigger: First primary key set manually");
101
102 # test savepoints
103 throws_ok {
104 $schema->txn_do(sub {
105 eval {
106 $schema->txn_do(sub {
107 $ars->create({ name => 'in_savepoint' });
108 die "rolling back savepoint";
109 });
110 };
111 ok ((not $ars->search({ name => 'in_savepoint' })->first),
112 'savepoint rolled back');
113 $ars->create({ name => 'in_outer_txn' });
114 die "rolling back outer txn";
115 });
116 } qr/rolling back outer txn/,
117 'correct exception for rollback';
118
119 ok ((not $ars->search({ name => 'in_outer_txn' })->first),
120 'outer txn rolled back');
121
122 # test explicit key spec
123 $new = $ars->create ({ name => 'bar', artistid => 66 });
124 is($new->artistid, 66, 'Explicit PK worked');
125 $new->discard_changes;
126 is($new->artistid, 66, 'Explicit PK assigned');
127
128 # row update
129 lives_ok {
130 $new->update({ name => 'baz' })
131 } 'update survived';
132 $new->discard_changes;
133 is $new->name, 'baz', 'row updated';
134
135 # test populate
136 lives_ok (sub {
137 my @pop;
138 for (1..2) {
139 push @pop, { name => "Artist_$_" };
140 }
141 $ars->populate (\@pop);
142 });
143
144 # test populate with explicit key
145 lives_ok (sub {
146 my @pop;
147 for (1..2) {
148 push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
149 }
150 $ars->populate (\@pop);
151 });
152
153 # count what we did so far
154 is ($ars->count, 6, 'Simple count works');
155
156 # test ResultSet UPDATE
157 lives_and {
158 $ars->search({ name => 'foo' })->update({ rank => 4 });
159
160 is eval { $ars->search({ name => 'foo' })->first->rank }, 4;
161 } 'Can update a column';
162
163 my ($updated) = $schema->resultset('Artist')->search({name => 'foo'});
164 is eval { $updated->rank }, 4, 'and the update made it to the database';
165
166
167 # test LIMIT support
168 my $lim = $ars->search( {},
169 {
170 rows => 3,
171 offset => 4,
172 order_by => 'artistid'
173 }
174 );
175 is( $lim->count, 2, 'ROWS+OFFSET count ok' );
176 is( $lim->all, 2, 'Number of ->all objects matches count' );
177
178 # test iterator
179 $lim->reset;
180 is( eval { $lim->next->artistid }, 101, "iterator->next ok" );
181 is( eval { $lim->next->artistid }, 102, "iterator->next ok" );
182 is( $lim->next, undef, "next past end of resultset ok" );
183
184 # test nested cursors
185 {
186 my $rs1 = $ars->search({}, { order_by => { -asc => 'artistid' }});
187
188 my $rs2 = $ars->search({ artistid => $rs1->next->artistid }, {
189 order_by => { -desc => 'artistid' }
190 });
191
192 is $rs2->next->artistid, 1, 'nested cursors';
193 }
194
195 # test empty insert
196 lives_and {
197 my $row = $ars->create({});
198 ok $row->artistid;
199 } 'empty insert works';
200
201 # test inferring the generator from the trigger source and using it with
202 # auto_nextval
203 {
204 local $ars->result_source->column_info('artistid')->{auto_nextval} = 1;
205
206 lives_and {
207 my $row = $ars->create({ name => 'introspecting generator' });
208 ok $row->artistid;
209 } 'inferring generator from trigger source works';
210 }
211
212 # test blobs (stolen from 73oracle.t)
213 eval { $dbh->do('DROP TABLE "bindtype_test"') };
214 $dbh->do(q[
215 CREATE TABLE "bindtype_test"
216 (
217 "id" INT PRIMARY KEY,
218 "bytea" INT,
219 "blob" BLOB,
220 "clob" BLOB SUB_TYPE TEXT
221 )
222 ]);
223
224 my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
225 $binstr{'large'} = $binstr{'small'} x 1024;
226
227 my $maxloblen = length $binstr{'large'};
228 local $dbh->{'LongReadLen'} = $maxloblen;
229
230 my $rs = $schema->resultset('BindType');
231 my $id = 0;
232
233 foreach my $type (qw( blob clob )) {
234 foreach my $size (qw( small large )) {
235 $id++;
236
237 # turn off horrendous binary DBIC_TRACE output
238 local $schema->storage->{debug} = 0;
239
240 lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
241 "inserted $size $type without dying";
242
243 ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
244 }
245 }
246 }
247
248 done_testing;
249
250 # clean up our mess
251
252 sub cleanup {
253 my $dbh;
254 eval {
255 $schema->storage->disconnect; # to avoid object FOO is in use errors
256 $dbh = $schema->storage->dbh;
257 };
258 return unless $dbh;
259
260 eval { $dbh->do('DROP TRIGGER "artist_bi"') };
261 diag $@ if $@;
262
263 foreach my $generator (qw/gen_artist_artistid pkid1_seq pkid2_seq
264 nonpkid_seq/) {
265 eval { $dbh->do(qq{DROP GENERATOR "$generator"}) };
266 diag $@ if $@;
267 }
268
269 foreach my $table (qw/artist bindtype_test sequence_test/) {
270 eval { $dbh->do(qq[DROP TABLE "$table"]) };
271 diag $@ if $@;
272 }
273 }
+31
-31
t/77join_count.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 eval "use DBD::SQLite";
10 plan skip_all => 'needs DBD::SQLite for testing' if $@;
11 plan tests => 4;
12
13 cmp_ok($schema->resultset("CD")->count({ 'artist.name' => 'Caterwauler McCrae' },
14 { join => 'artist' }),
15 '==', 3, 'Count by has_a ok');
16
17 cmp_ok($schema->resultset("CD")->count({ 'tags.tag' => 'Blue' }, { join => 'tags' }),
18 '==', 4, 'Count by has_many ok');
19
20 cmp_ok($schema->resultset("CD")->count(
21 { 'liner_notes.notes' => { '!=' => undef } },
22 { join => 'liner_notes' }),
23 '==', 3, 'Count by might_have ok');
24
25 cmp_ok($schema->resultset("CD")->count(
26 { 'year' => { '>', 1998 }, 'tags.tag' => 'Cheesy',
27 'liner_notes.notes' => { 'like' => 'Buy%' } },
28 { join => [ qw/tags liner_notes/ ] } ),
29 '==', 2, "Mixed count ok");
30
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 eval "use DBD::SQLite";
10 plan skip_all => 'needs DBD::SQLite for testing' if $@;
11 plan tests => 4;
12
13 cmp_ok($schema->resultset("CD")->count({ 'artist.name' => 'Caterwauler McCrae' },
14 { join => 'artist' }),
15 '==', 3, 'Count by has_a ok');
16
17 cmp_ok($schema->resultset("CD")->count({ 'tags.tag' => 'Blue' }, { join => 'tags' }),
18 '==', 4, 'Count by has_many ok');
19
20 cmp_ok($schema->resultset("CD")->count(
21 { 'liner_notes.notes' => { '!=' => undef } },
22 { join => 'liner_notes' }),
23 '==', 3, 'Count by might_have ok');
24
25 cmp_ok($schema->resultset("CD")->count(
26 { 'year' => { '>', 1998 }, 'tags.tag' => 'Cheesy',
27 'liner_notes.notes' => { 'like' => 'Buy%' } },
28 { join => [ qw/tags liner_notes/ ] } ),
29 '==', 2, "Mixed count ok");
30
+42
-42
t/78self_referencial.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 # this test will check to see if you can have 2 columns
10 # in the same class pointing at the same other class
11 #
12 # example:
13 #
14 # +---------+ +--------------+
15 # | SelfRef | | SelfRefAlias |
16 # +---------+ 1-M +--------------+
17 # | id |-------| self_ref | --+
18 # | name | | alias | --+
19 # +---------+ +--------------+ |
20 # /|\ |
21 # | |
22 # +--------------------------------+
23 #
24 # see http://use.perl.org/~LTjake/journal/24876 for the
25 # issue with CDBI
26
27 plan tests => 4;
28
29 my $item = $schema->resultset("SelfRef")->find( 1 );
30 is( $item->name, 'First', 'proper start item' );
31
32 my @aliases = $item->aliases;
33
34 is( scalar @aliases, 1, 'proper number of aliases' );
35
36 my $orig = $aliases[ 0 ]->self_ref;
37 my $alias = $aliases[ 0 ]->alias;
38
39 is( $orig->name, 'First', 'proper original' );
40 is( $alias->name, 'Second', 'proper alias' );
41
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 # this test will check to see if you can have 2 columns
10 # in the same class pointing at the same other class
11 #
12 # example:
13 #
14 # +---------+ +--------------+
15 # | SelfRef | | SelfRefAlias |
16 # +---------+ 1-M +--------------+
17 # | id |-------| self_ref | --+
18 # | name | | alias | --+
19 # +---------+ +--------------+ |
20 # /|\ |
21 # | |
22 # +--------------------------------+
23 #
24 # see http://use.perl.org/~LTjake/journal/24876 for the
25 # issue with CDBI
26
27 plan tests => 4;
28
29 my $item = $schema->resultset("SelfRef")->find( 1 );
30 is( $item->name, 'First', 'proper start item' );
31
32 my @aliases = $item->aliases;
33
34 is( scalar @aliases, 1, 'proper number of aliases' );
35
36 my $orig = $aliases[ 0 ]->self_ref;
37 my $alias = $aliases[ 0 ]->alias;
38
39 is( $orig->name, 'First', 'proper original' );
40 is( $alias->name, 'Second', 'proper alias' );
41
+4
-2
t/81transactions.t less more
149149 no warnings 'redefine';
150150 no strict 'refs';
151151
152 # die in rollback, but maintain sanity for further tests ...
152 # die in rollback
153153 local *{"DBIx::Class::Storage::DBI::SQLite::txn_rollback"} = sub{
154154 my $storage = shift;
155 $storage->{transaction_depth}--;
156155 die 'FAILED';
157156 };
158157
178177 ok(!defined($cd), q{deleted the failed txn's cd});
179178 $schema->storage->_dbh->rollback;
180179 }
180
181 # reset schema object (the txn_rollback meddling screws it up)
182 $schema = DBICTest->init_schema();
181183
182184 # Test nested failed txn_do()
183185 {
+26
-26
t/82cascade_copy.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 4;
10 my $artist = $schema->resultset('Artist')->find(1);
11 my $artist_cds = $artist->search_related('cds');
12
13 my $cover_band = $artist->copy;
14
15 my $cover_cds = $cover_band->search_related('cds');
16 cmp_ok($cover_band->id, '!=', $artist->id, 'ok got new column id...');
17 is($cover_cds->count, $artist_cds->count, 'duplicated rows count ok');
18
19 #check multi-keyed
20 cmp_ok($cover_band->search_related('twokeys')->count, '>', 0, 'duplicated multiPK ok');
21
22 #and check copying a few relations away
23 cmp_ok($cover_cds->search_related('tags')->count, '==',
24 $artist_cds->search_related('tags')->count , 'duplicated count ok');
25
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 4;
10 my $artist = $schema->resultset('Artist')->find(1);
11 my $artist_cds = $artist->search_related('cds');
12
13 my $cover_band = $artist->copy;
14
15 my $cover_cds = $cover_band->search_related('cds');
16 cmp_ok($cover_band->id, '!=', $artist->id, 'ok got new column id...');
17 is($cover_cds->count, $artist_cds->count, 'duplicated rows count ok');
18
19 #check multi-keyed
20 cmp_ok($cover_band->search_related('twokeys')->count, '>', 0, 'duplicated multiPK ok');
21
22 #and check copying a few relations away
23 cmp_ok($cover_cds->search_related('tags')->count, '==',
24 $artist_cds->search_related('tags')->count , 'duplicated count ok');
25
+193
-193
t/83cache.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 my $queries;
10 my $debugcb = sub{ $queries++ };
11 my $sdebug = $schema->storage->debug;
12
13 plan tests => 23;
14
15 my $rs = $schema->resultset("Artist")->search(
16 { artistid => 1 }
17 );
18
19 my $artist = $rs->first;
20
21 ok( !defined($rs->get_cache), 'cache is not populated without cache attribute' );
22
23 $rs = $schema->resultset('Artist')->search( undef, { cache => 1 } );
24 my $artists = [ $rs->all ];
25
26 is( scalar @{$rs->get_cache}, 3, 'all() populates cache for search with cache attribute' );
27
28 $rs->clear_cache;
29
30 ok( !defined($rs->get_cache), 'clear_cache is functional' );
31
32 $rs->next;
33
34 is( scalar @{$rs->get_cache}, 3, 'next() populates cache for search with cache attribute' );
35
36 pop( @$artists );
37 $rs->set_cache( $artists );
38
39 is( scalar @{$rs->get_cache}, 2, 'set_cache() is functional' );
40
41 my $cd = $schema->resultset('CD')->find(1);
42
43 $rs->clear_cache;
44
45 $queries = 0;
46 $schema->storage->debug(1);
47 $schema->storage->debugcb ($debugcb);
48
49 $rs = $schema->resultset('Artist')->search( undef, { cache => 1 } );
50 while( $artist = $rs->next ) {}
51 $artist = $rs->first();
52
53 is( $queries, 1, 'revisiting a row does not issue a query when cache => 1' );
54
55 $schema->storage->debug($sdebug);
56 $schema->storage->debugcb (undef);
57
58 my @a = $schema->resultset("Artist")->search(
59 { },
60 {
61 join => [ qw/ cds /],
62 prefetch => [qw/ cds /],
63 }
64 );
65
66 is(scalar @a, 3, 'artist with cds: count parent objects');
67
68 $rs = $schema->resultset("Artist")->search(
69 { 'artistid' => 1 },
70 {
71 join => [ qw/ cds /],
72 prefetch => [qw/ cds /],
73 }
74 );
75
76 # start test for prefetch SELECT count
77 $queries = 0;
78 $schema->storage->debug(1);
79 $schema->storage->debugcb ($debugcb);
80
81 $artist = $rs->first;
82 $rs->reset();
83
84 # make sure artist contains a related resultset for cds
85 isa_ok( $artist->{related_resultsets}{cds}, 'DBIx::Class::ResultSet', 'artist has a related_resultset for cds' );
86
87 # check if $artist->cds->get_cache is populated
88 is( scalar @{$artist->cds->get_cache}, 3, 'cache for artist->cds contains correct number of records');
89
90 # ensure that $artist->cds returns correct number of objects
91 is( scalar ($artist->cds), 3, 'artist->cds returns correct number of objects' );
92
93 # ensure that $artist->cds->count returns correct value
94 is( $artist->cds->count, 3, 'artist->cds->count returns correct value' );
95
96 # ensure that $artist->count_related('cds') returns correct value
97 is( $artist->count_related('cds'), 3, 'artist->count_related returns correct value' );
98
99 is($queries, 1, 'only one SQL statement executed');
100
101 $schema->storage->debug($sdebug);
102 $schema->storage->debugcb (undef);
103
104 # make sure related_resultset is deleted after object is updated
105 $artist->set_column('name', 'New Name');
106 $artist->update();
107
108 is( scalar keys %{$artist->{related_resultsets}}, 0, 'related resultsets deleted after update' );
109
110 # todo: make sure caching works with nested prefetch e.g. $artist->cds->tracks
111 $rs = $schema->resultset("Artist")->search(
112 { artistid => 1 },
113 {
114 join => { cds => 'tags' },
115 prefetch => {
116 cds => 'tags'
117 },
118 }
119 );
120 {
121 my $artist_count_before = $schema->resultset('Artist')->count;
122 $schema->resultset("Artist")->create({artistid=>4,name=>qq{Humoungous Hamsters}});
123 is($schema->resultset('Artist')->count, $artist_count_before + 1, 'count() reflects new artist');
124 my $artist = $schema->resultset("Artist")->search(
125 { artistid => 4 },{prefetch=>[qw/cds/]}
126 )->first;
127
128 is($artist->cds, 0, 'No cds for this artist');
129 }
130
131 # SELECT count for nested has_many prefetch
132 $queries = 0;
133 $schema->storage->debug(1);
134 $schema->storage->debugcb ($debugcb);
135
136 $artist = ($rs->all)[0];
137
138 is($queries, 1, 'only one SQL statement executed');
139
140 $schema->storage->debug($sdebug);
141 $schema->storage->debugcb (undef);
142
143 my @objs;
144 #$artist = $rs->find(1);
145
146 $queries = 0;
147 $schema->storage->debug(1);
148 $schema->storage->debugcb ($debugcb);
149
150 my $cds = $artist->cds;
151 my $tags = $cds->next->tags;
152 while( my $tag = $tags->next ) {
153 push @objs, $tag->tagid; #warn "tag:", $tag->ID, " => ", $tag->tag;
154 }
155
156 is_deeply( \@objs, [ 3 ], 'first cd has correct tags' );
157
158 $tags = $cds->next->tags;
159 @objs = ();
160 while( my $tag = $tags->next ) {
161 push @objs, $tag->id; #warn "tag: ", $tag->ID;
162 }
163
164 is_deeply( \@objs, [ 1 ], 'second cd has correct tags' );
165
166 $tags = $cds->next->tags;
167 @objs = ();
168 while( my $tag = $tags->next ) {
169 push @objs, $tag->id; #warn "tag: ", $tag->ID;
170 }
171
172 is_deeply( \@objs, [ 2, 5, 8 ], 'third cd has correct tags' );
173
174 is( $queries, 0, 'no additional SQL statements while checking nested data' );
175
176 # start test for prefetch SELECT count
177 $queries = 0;
178
179 $artist = $schema->resultset('Artist')->find(1, { prefetch => [qw/cds/] });
180
181 is( $queries, 1, 'only one select statement on find with inline has_many prefetch' );
182
183 # start test for prefetch SELECT count
184 $queries = 0;
185
186 $rs = $schema->resultset('Artist')->search(undef, { prefetch => [qw/cds/] });
187 $artist = $rs->find(1);
188
189 is( $queries, 1, 'only one select statement on find with has_many prefetch on resultset' );
190
191 $schema->storage->debug($sdebug);
192 $schema->storage->debugcb (undef);
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 my $queries;
10 my $debugcb = sub{ $queries++ };
11 my $sdebug = $schema->storage->debug;
12
13 plan tests => 23;
14
15 my $rs = $schema->resultset("Artist")->search(
16 { artistid => 1 }
17 );
18
19 my $artist = $rs->first;
20
21 ok( !defined($rs->get_cache), 'cache is not populated without cache attribute' );
22
23 $rs = $schema->resultset('Artist')->search( undef, { cache => 1 } );
24 my $artists = [ $rs->all ];
25
26 is( scalar @{$rs->get_cache}, 3, 'all() populates cache for search with cache attribute' );
27
28 $rs->clear_cache;
29
30 ok( !defined($rs->get_cache), 'clear_cache is functional' );
31
32 $rs->next;
33
34 is( scalar @{$rs->get_cache}, 3, 'next() populates cache for search with cache attribute' );
35
36 pop( @$artists );
37 $rs->set_cache( $artists );
38
39 is( scalar @{$rs->get_cache}, 2, 'set_cache() is functional' );
40
41 my $cd = $schema->resultset('CD')->find(1);
42
43 $rs->clear_cache;
44
45 $queries = 0;
46 $schema->storage->debug(1);
47 $schema->storage->debugcb ($debugcb);
48
49 $rs = $schema->resultset('Artist')->search( undef, { cache => 1 } );
50 while( $artist = $rs->next ) {}
51 $artist = $rs->first();
52
53 is( $queries, 1, 'revisiting a row does not issue a query when cache => 1' );
54
55 $schema->storage->debug($sdebug);
56 $schema->storage->debugcb (undef);
57
58 my @a = $schema->resultset("Artist")->search(
59 { },
60 {
61 join => [ qw/ cds /],
62 prefetch => [qw/ cds /],
63 }
64 );
65
66 is(scalar @a, 3, 'artist with cds: count parent objects');
67
68 $rs = $schema->resultset("Artist")->search(
69 { 'artistid' => 1 },
70 {
71 join => [ qw/ cds /],
72 prefetch => [qw/ cds /],
73 }
74 );
75
76 # start test for prefetch SELECT count
77 $queries = 0;
78 $schema->storage->debug(1);
79 $schema->storage->debugcb ($debugcb);
80
81 $artist = $rs->first;
82 $rs->reset();
83
84 # make sure artist contains a related resultset for cds
85 isa_ok( $artist->{related_resultsets}{cds}, 'DBIx::Class::ResultSet', 'artist has a related_resultset for cds' );
86
87 # check if $artist->cds->get_cache is populated
88 is( scalar @{$artist->cds->get_cache}, 3, 'cache for artist->cds contains correct number of records');
89
90 # ensure that $artist->cds returns correct number of objects
91 is( scalar ($artist->cds), 3, 'artist->cds returns correct number of objects' );
92
93 # ensure that $artist->cds->count returns correct value
94 is( $artist->cds->count, 3, 'artist->cds->count returns correct value' );
95
96 # ensure that $artist->count_related('cds') returns correct value
97 is( $artist->count_related('cds'), 3, 'artist->count_related returns correct value' );
98
99 is($queries, 1, 'only one SQL statement executed');
100
101 $schema->storage->debug($sdebug);
102 $schema->storage->debugcb (undef);
103
104 # make sure related_resultset is deleted after object is updated
105 $artist->set_column('name', 'New Name');
106 $artist->update();
107
108 is( scalar keys %{$artist->{related_resultsets}}, 0, 'related resultsets deleted after update' );
109
110 # todo: make sure caching works with nested prefetch e.g. $artist->cds->tracks
111 $rs = $schema->resultset("Artist")->search(
112 { artistid => 1 },
113 {
114 join => { cds => 'tags' },
115 prefetch => {
116 cds => 'tags'
117 },
118 }
119 );
120 {
121 my $artist_count_before = $schema->resultset('Artist')->count;
122 $schema->resultset("Artist")->create({artistid=>4,name=>qq{Humoungous Hamsters}});
123 is($schema->resultset('Artist')->count, $artist_count_before + 1, 'count() reflects new artist');
124 my $artist = $schema->resultset("Artist")->search(
125 { artistid => 4 },{prefetch=>[qw/cds/]}
126 )->first;
127
128 is($artist->cds, 0, 'No cds for this artist');
129 }
130
131 # SELECT count for nested has_many prefetch
132 $queries = 0;
133 $schema->storage->debug(1);
134 $schema->storage->debugcb ($debugcb);
135
136 $artist = ($rs->all)[0];
137
138 is($queries, 1, 'only one SQL statement executed');
139
140 $schema->storage->debug($sdebug);
141 $schema->storage->debugcb (undef);
142
143 my @objs;
144 #$artist = $rs->find(1);
145
146 $queries = 0;
147 $schema->storage->debug(1);
148 $schema->storage->debugcb ($debugcb);
149
150 my $cds = $artist->cds;
151 my $tags = $cds->next->tags;
152 while( my $tag = $tags->next ) {
153 push @objs, $tag->tagid; #warn "tag:", $tag->ID, " => ", $tag->tag;
154 }
155
156 is_deeply( \@objs, [ 3 ], 'first cd has correct tags' );
157
158 $tags = $cds->next->tags;
159 @objs = ();
160 while( my $tag = $tags->next ) {
161 push @objs, $tag->id; #warn "tag: ", $tag->ID;
162 }
163
164 is_deeply( \@objs, [ 1 ], 'second cd has correct tags' );
165
166 $tags = $cds->next->tags;
167 @objs = ();
168 while( my $tag = $tags->next ) {
169 push @objs, $tag->id; #warn "tag: ", $tag->ID;
170 }
171
172 is_deeply( \@objs, [ 2, 5, 8 ], 'third cd has correct tags' );
173
174 is( $queries, 0, 'no additional SQL statements while checking nested data' );
175
176 # start test for prefetch SELECT count
177 $queries = 0;
178
179 $artist = $schema->resultset('Artist')->find(1, { prefetch => [qw/cds/] });
180
181 is( $queries, 1, 'only one select statement on find with inline has_many prefetch' );
182
183 # start test for prefetch SELECT count
184 $queries = 0;
185
186 $rs = $schema->resultset('Artist')->search(undef, { prefetch => [qw/cds/] });
187 $artist = $rs->find(1);
188
189 is( $queries, 1, 'only one select statement on find with has_many prefetch on resultset' );
190
191 $schema->storage->debug($sdebug);
192 $schema->storage->debugcb (undef);
+75
-75
t/84serialize.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7 use Storable qw(dclone freeze thaw);
8
9 my $schema = DBICTest->init_schema();
10
11 my %stores = (
12 dclone_method => sub { return $schema->dclone($_[0]) },
13 dclone_func => sub { return dclone($_[0]) },
14 "freeze/thaw_method" => sub {
15 my $ice = $schema->freeze($_[0]);
16 return $schema->thaw($ice);
17 },
18 "freeze/thaw_func" => sub {
19 thaw(freeze($_[0]));
20 },
21 );
22
23 plan tests => (11 * keys %stores);
24
25 for my $name (keys %stores) {
26 my $store = $stores{$name};
27 my $copy;
28
29 my $artist = $schema->resultset('Artist')->find(1);
30
31 # Test that the procedural versions will work if there's a registered
32 # schema as with CDBICompat objects and that the methods work
33 # without.
34 if( $name =~ /func/ ) {
35 $artist->result_source_instance->schema($schema);
36 DBICTest::CD->result_source_instance->schema($schema);
37 }
38 else {
39 $artist->result_source_instance->schema(undef);
40 DBICTest::CD->result_source_instance->schema(undef);
41 }
42
43 lives_ok { $copy = $store->($artist) } "serialize row object lives: $name";
44 is_deeply($copy, $artist, "serialize row object works: $name");
45
46 my $cd_rs = $artist->search_related("cds");
47
48 # test that a result source can be serialized as well
49
50 $cd_rs->_resolved_attrs; # this builds up the {from} attr
51
52 lives_ok {
53 $copy = $store->($cd_rs);
54 is_deeply (
55 [ $copy->all ],
56 [ $cd_rs->all ],
57 "serialize resultset works: $name",
58 );
59 } "serialize resultset lives: $name";
60
61 # Test that an object with a related_resultset can be serialized.
62 ok $artist->{related_resultsets}, 'has key: related_resultsets';
63
64 lives_ok { $copy = $store->($artist) } "serialize row object with related_resultset lives: $name";
65 for my $key (keys %$artist) {
66 next if $key eq 'related_resultsets';
67 next if $key eq '_inflated_column';
68 is_deeply($copy->{$key}, $artist->{$key},
69 qq[serialize with related_resultset "$key"]);
70 }
71
72 ok eval { $copy->discard_changes; 1 } or diag $@;
73 is($copy->id, $artist->id, "IDs still match ");
74 }
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7 use Storable qw(dclone freeze thaw);
8
9 my $schema = DBICTest->init_schema();
10
11 my %stores = (
12 dclone_method => sub { return $schema->dclone($_[0]) },
13 dclone_func => sub { return dclone($_[0]) },
14 "freeze/thaw_method" => sub {
15 my $ice = $schema->freeze($_[0]);
16 return $schema->thaw($ice);
17 },
18 "freeze/thaw_func" => sub {
19 thaw(freeze($_[0]));
20 },
21 );
22
23 plan tests => (11 * keys %stores);
24
25 for my $name (keys %stores) {
26 my $store = $stores{$name};
27 my $copy;
28
29 my $artist = $schema->resultset('Artist')->find(1);
30
31 # Test that the procedural versions will work if there's a registered
32 # schema as with CDBICompat objects and that the methods work
33 # without.
34 if( $name =~ /func/ ) {
35 $artist->result_source_instance->schema($schema);
36 DBICTest::CD->result_source_instance->schema($schema);
37 }
38 else {
39 $artist->result_source_instance->schema(undef);
40 DBICTest::CD->result_source_instance->schema(undef);
41 }
42
43 lives_ok { $copy = $store->($artist) } "serialize row object lives: $name";
44 is_deeply($copy, $artist, "serialize row object works: $name");
45
46 my $cd_rs = $artist->search_related("cds");
47
48 # test that a result source can be serialized as well
49
50 $cd_rs->_resolved_attrs; # this builds up the {from} attr
51
52 lives_ok {
53 $copy = $store->($cd_rs);
54 is_deeply (
55 [ $copy->all ],
56 [ $cd_rs->all ],
57 "serialize resultset works: $name",
58 );
59 } "serialize resultset lives: $name";
60
61 # Test that an object with a related_resultset can be serialized.
62 ok $artist->{related_resultsets}, 'has key: related_resultsets';
63
64 lives_ok { $copy = $store->($artist) } "serialize row object with related_resultset lives: $name";
65 for my $key (keys %$artist) {
66 next if $key eq 'related_resultsets';
67 next if $key eq '_inflated_column';
68 is_deeply($copy->{$key}, $artist->{$key},
69 qq[serialize with related_resultset "$key"]);
70 }
71
72 ok eval { $copy->discard_changes; 1 } or diag $@;
73 is($copy->id, $artist->id, "IDs still match ");
74 }
+131
-18
t/85utf8.t less more
55 use lib qw(t/lib);
66 use DBICTest;
77
8 warning_like (
8 {
9 package A::Comp;
10 use base 'DBIx::Class';
11 sub store_column { shift->next::method (@_) };
12 1;
13 }
14
15 {
16 package A::SubComp;
17 use base 'A::Comp';
18
19 1;
20 }
21
22 warnings_are (
923 sub {
10 package A::Comp;
11 use base 'DBIx::Class';
24 local $ENV{DBIC_UTF8COLUMNS_OK} = 1;
25 package A::Test1;
26 use base 'DBIx::Class::Core';
27 __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns));
28 __PACKAGE__->load_components(qw(Ordered +A::SubComp Row UTF8Columns Core));
1229 sub store_column { shift->next::method (@_) };
1330 1;
31 },
32 [],
33 'no spurious warnings issued',
34 );
1435
15 package A::Test;
36 my $test1_mro;
37 my $idx = 0;
38 for (@{mro::get_linear_isa ('A::Test1')} ) {
39 $test1_mro->{$_} = $idx++;
40 }
41
42 cmp_ok ($test1_mro->{'A::SubComp'}, '<', $test1_mro->{'A::Comp'}, 'mro of Test1 correct (A::SubComp before A::Comp)' );
43 cmp_ok ($test1_mro->{'A::Comp'}, '<', $test1_mro->{'DBIx::Class::UTF8Columns'}, 'mro of Test1 correct (A::Comp before UTF8Col)' );
44 cmp_ok ($test1_mro->{'DBIx::Class::UTF8Columns'}, '<', $test1_mro->{'DBIx::Class::Core'}, 'mro of Test1 correct (UTF8Col before Core)' );
45 cmp_ok ($test1_mro->{'DBIx::Class::Core'}, '<', $test1_mro->{'DBIx::Class::Row'}, 'mro of Test1 correct (Core before Row)' );
46
47 warnings_like (
48 sub {
49 package A::Test2;
1650 use base 'DBIx::Class::Core';
1751 __PACKAGE__->load_components(qw(UTF8Columns +A::Comp));
52 sub store_column { shift->next::method (@_) };
1853 1;
1954 },
20 qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding store_column \(A::Comp\)/,
21 'incorrect order warning issued',
55 [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::Comp\)/],
56 'incorrect order warning issued (violator defines)',
57 );
58
59 warnings_like (
60 sub {
61 package A::Test3;
62 use base 'DBIx::Class::Core';
63 __PACKAGE__->load_components(qw(UTF8Columns +A::SubComp));
64 sub store_column { shift->next::method (@_) };
65 1;
66 },
67 [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::SubComp \(via A::Comp\)\)/],
68 'incorrect order warning issued (violator inherits)',
2269 );
2370
2471 my $schema = DBICTest->init_schema();
2673 DBICTest::Schema::CD->utf8_columns('title');
2774 Class::C3->reinitialize();
2875
29 my $cd = $schema->resultset('CD')->create( { artist => 1, title => "weird\x{466}stuff", year => '2048' } );
76 {
77 package DBICTest::UTF8::Debugger;
3078
31 ok( utf8::is_utf8( $cd->title ), 'got title with utf8 flag' );
32 ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store title without utf8' );
79 use base 'DBIx::Class::Storage::Statistics';
3380
34 ok(! utf8::is_utf8( $cd->year ), 'got year without utf8 flag' );
35 ok(! utf8::is_utf8( $cd->{_column_data}{year} ), 'store year without utf8' );
81 __PACKAGE__->mk_group_accessors(simple => 'call_stack');
82
83 sub query_start {
84 my $self = shift;
85 my $sql = shift;
86
87 my @bind = map { substr $_, 1, -1 } (@_); # undo the effect of _fix_bind_params
88
89 $self->call_stack ( [ @{$self->call_stack || [] }, [$sql, @bind] ] );
90 $self->next::method ($sql, @_);
91 }
92 }
93
94 # as per http://search.cpan.org/dist/Test-Simple/lib/Test/More.pm#utf8
95 binmode (Test::More->builder->$_, ':utf8') for qw/output failure_output todo_output/;
96
97 my $bytestream_title = my $utf8_title = "weird \x{466} stuff";
98 utf8::encode($bytestream_title);
99 cmp_ok ($bytestream_title, 'ne', $utf8_title, 'unicode/raw differ (sanity check)');
100
101 my $storage = $schema->storage;
102 $storage->debugobj (DBICTest::UTF8::Debugger->new);
103 $storage->debugobj->silence (1);
104 $storage->debug (1);
105
106 my $cd = $schema->resultset('CD')->create( { artist => 1, title => $utf8_title, year => '2048' } );
107
108 # bind values are always alphabetically ordered by column, thus [2]
109 TODO: {
110 local $TODO = "This has been broken since rev 1191, Mar 2006";
111 is ($storage->debugobj->call_stack->[-1][2], $bytestream_title, 'INSERT: raw bytes sent to the database');
112 }
113
114 # this should be using the cursor directly, no inflation/processing of any sort
115 my ($raw_db_title) = $schema->resultset('CD')
116 ->search ($cd->ident_condition)
117 ->get_column('title')
118 ->_resultset
119 ->cursor
120 ->next;
121
122 is ($raw_db_title, $bytestream_title, 'INSERT: raw bytes retrieved from database');
123
124 for my $reloaded (0, 1) {
125 my $test = $reloaded ? 'reloaded' : 'stored';
126 $cd->discard_changes if $reloaded;
127
128 ok( utf8::is_utf8( $cd->title ), "got $test title with utf8 flag" );
129 ok(! utf8::is_utf8( $cd->{_column_data}{title} ), "in-object $test title without utf8" );
130
131 ok(! utf8::is_utf8( $cd->year ), "got $test year without utf8 flag" );
132 ok(! utf8::is_utf8( $cd->{_column_data}{year} ), "in-object $test year without utf8" );
133 }
36134
37135 $cd->title('nonunicode');
38 ok(! utf8::is_utf8( $cd->title ), 'got title without utf8 flag' );
39 ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less chars' );
136 ok(! utf8::is_utf8( $cd->title ), 'update title without utf8 flag' );
137 ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less title' );
40138
139 $cd->update;
140 $cd->discard_changes;
141 ok(! utf8::is_utf8( $cd->title ), 'reloaded title without utf8 flag' );
142 ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'reloaded utf8-less title' );
41143
42 my $v_utf8 = "\x{219}";
144 $bytestream_title = $utf8_title = "something \x{219} else";
145 utf8::encode($bytestream_title);
43146
44 $cd->update ({ title => $v_utf8 });
45 $cd->title($v_utf8);
147 $cd->update ({ title => $utf8_title });
148 is ($storage->debugobj->call_stack->[-1][1], $bytestream_title, 'UPDATE: raw bytes sent to the database');
149 ($raw_db_title) = $schema->resultset('CD')
150 ->search ($cd->ident_condition)
151 ->get_column('title')
152 ->_resultset
153 ->cursor
154 ->next;
155 is ($raw_db_title, $bytestream_title, 'UPDATE: raw bytes retrieved from database');
156
157 $cd->discard_changes;
158 $cd->title($utf8_title);
46159 ok( !$cd->is_column_changed('title'), 'column is not dirty after setting the same unicode value' );
47160
48 $cd->update ({ title => $v_utf8 });
161 $cd->update ({ title => $utf8_title });
49162 $cd->title('something_else');
50163 ok( $cd->is_column_changed('title'), 'column is dirty after setting to something completely different');
51164
52165 TODO: {
53166 local $TODO = 'There is currently no way to propagate aliases to inflate_result()';
54 $cd = $schema->resultset('CD')->find ({ title => $v_utf8 }, { select => 'title', as => 'name' });
167 $cd = $schema->resultset('CD')->find ({ title => $utf8_title }, { select => 'title', as => 'name' });
55168 ok (utf8::is_utf8( $cd->get_column ('name') ), 'utf8 flag propagates via as');
56169 }
57170
+11
-11
t/87ordered.t less more
6363 $employee->group_id(1);
6464 $employee->update;
6565 ok(
66 check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
67 "overloaded update 3"
66 check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
67 "overloaded update 3"
6868 );
6969 $employee = $employees->search({group_id=>4})->first;
7070 $employee->update({group_id=>2});
7171 ok(
72 check_rs($employees->search_rs({group_id=>2})) && check_rs($employees->search_rs({group_id=>4})),
73 "overloaded update 4"
72 check_rs($employees->search_rs({group_id=>2})) && check_rs($employees->search_rs({group_id=>4})),
73 "overloaded update 4"
7474 );
7575 $employee = $employees->search({group_id=>4})->first;
7676 $employee->group_id(1);
7777 $employee->position(3);
7878 $employee->update;
7979 ok(
80 check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
81 "overloaded update 5"
80 check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
81 "overloaded update 5"
8282 );
8383 $employee = $employees->search({group_id=>4})->first;
8484 $employee->group_id(2);
8585 $employee->position(undef);
8686 $employee->update;
8787 ok(
88 check_rs($employees->search_rs({group_id=>2})) && check_rs($employees->search_rs({group_id=>4})),
89 "overloaded update 6"
88 check_rs($employees->search_rs({group_id=>2})) && check_rs($employees->search_rs({group_id=>4})),
89 "overloaded update 6"
9090 );
9191 $employee = $employees->search({group_id=>4})->first;
9292 $employee->update({group_id=>1,position=>undef});
9393 ok(
94 check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
95 "overloaded update 7"
94 check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
95 "overloaded update 7"
9696 );
9797
9898 # multicol tests begin here
153153 $employee = $employees->search({group_id_2=>4, group_id_3=>1})->first;
154154 $employee->group_id_2(1);
155155 $employee->update;
156 ok(
156 ok(
157157 check_rs($employees->search_rs({group_id_2=>4, group_id_3=>1}))
158158 && check_rs($employees->search_rs({group_id_2=>1, group_id_3=>1})),
159159 "overloaded multicol update 1"
+131
-131
t/90ensure_class_loaded.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6 use Class::Inspector;
7
8 BEGIN {
9 package TestPackage::A;
10 sub some_method {}
11 }
12
13 my $schema = DBICTest->init_schema();
14
15 plan tests => 28;
16
17 # Test ensure_class_found
18 ok( $schema->ensure_class_found('DBIx::Class::Schema'),
19 'loaded package DBIx::Class::Schema was found' );
20 ok( !Class::Inspector->loaded('DBICTest::FakeComponent'),
21 'DBICTest::FakeComponent not loaded yet' );
22 ok( $schema->ensure_class_found('DBICTest::FakeComponent'),
23 'package DBICTest::FakeComponent was found' );
24 ok( !Class::Inspector->loaded('DBICTest::FakeComponent'),
25 'DBICTest::FakeComponent not loaded by ensure_class_found()' );
26 ok( $schema->ensure_class_found('TestPackage::A'),
27 'anonymous package TestPackage::A found' );
28 ok( !$schema->ensure_class_found('FAKE::WONT::BE::FOUND'),
29 'fake package not found' );
30
31 # Test load_optional_class
32 my $retval = eval { $schema->load_optional_class('ANOTHER::FAKE::PACKAGE') };
33 ok( !$@, 'load_optional_class on a nonexistent class did not throw' );
34 ok( !$retval, 'nonexistent package not loaded' );
35 $retval = eval { $schema->load_optional_class('DBICTest::OptionalComponent') };
36 ok( !$@, 'load_optional_class on an existing class did not throw' );
37 ok( $retval, 'DBICTest::OptionalComponent loaded' );
38 eval { $schema->load_optional_class('DBICTest::ErrorComponent') };
39 like( $@, qr/did not return a true value/,
40 'DBICTest::ErrorComponent threw ok' );
41
42 # Simulate a PAR environment
43 {
44 my @code;
45 local @INC = @INC;
46 unshift @INC, sub {
47 if ($_[1] eq 'VIRTUAL/PAR/PACKAGE.pm') {
48 return (sub { return 0 unless @code; $_ = shift @code; 1; } );
49 }
50 else {
51 return ();
52 }
53 };
54
55 $retval = eval { $schema->load_optional_class('FAKE::PAR::PACKAGE') };
56 ok( !$@, 'load_optional_class on a nonexistent PAR class did not throw' );
57 ok( !$retval, 'nonexistent PAR package not loaded' );
58
59
60 # simulate a class which does load but does not return true
61 @code = (
62 q/package VIRTUAL::PAR::PACKAGE;/,
63 q/0;/,
64 );
65
66 $retval = eval { $schema->load_optional_class('VIRTUAL::PAR::PACKAGE') };
67 ok( $@, 'load_optional_class of a no-true-returning PAR module did throw' );
68 ok( !$retval, 'no-true-returning PAR package not loaded' );
69
70 # simulate a normal class (no one adjusted %INC so it will be tried again
71 @code = (
72 q/package VIRTUAL::PAR::PACKAGE;/,
73 q/1;/,
74 );
75
76 $retval = eval { $schema->load_optional_class('VIRTUAL::PAR::PACKAGE') };
77 ok( !$@, 'load_optional_class of a PAR module did not throw' );
78 ok( $retval, 'PAR package "loaded"' );
79
80 # see if we can still load stuff with the coderef present
81 $retval = eval { $schema->load_optional_class('DBIx::Class::ResultClass::HashRefInflator') };
82 ok( !$@, 'load_optional_class did not throw' ) || diag $@;
83 ok( $retval, 'DBIx::Class::ResultClass::HashRefInflator loaded' );
84 }
85
86 # Test ensure_class_loaded
87 ok( Class::Inspector->loaded('TestPackage::A'), 'anonymous package exists' );
88 eval { $schema->ensure_class_loaded('TestPackage::A'); };
89 ok( !$@, 'ensure_class_loaded detected an anon. class' );
90 eval { $schema->ensure_class_loaded('FakePackage::B'); };
91 like( $@, qr/Can't locate/,
92 'ensure_class_loaded threw exception for nonexistent class' );
93 ok( !Class::Inspector->loaded('DBICTest::FakeComponent'),
94 'DBICTest::FakeComponent not loaded yet' );
95 eval { $schema->ensure_class_loaded('DBICTest::FakeComponent'); };
96 ok( !$@, 'ensure_class_loaded detected an existing but non-loaded class' );
97 ok( Class::Inspector->loaded('DBICTest::FakeComponent'),
98 'DBICTest::FakeComponent now loaded' );
99
100 {
101 # Squash warnings about syntax errors in SytaxErrorComponent.pm
102 local $SIG{__WARN__} = sub {
103 my $warning = shift;
104 warn $warning unless (
105 $warning =~ /String found where operator expected/ or
106 $warning =~ /Missing operator before/
107 );
108 };
109
110 eval { $schema->ensure_class_loaded('DBICTest::SyntaxErrorComponent1') };
111 like( $@, qr/syntax error/,
112 'ensure_class_loaded(DBICTest::SyntaxErrorComponent1) threw ok' );
113 eval { $schema->load_optional_class('DBICTest::SyntaxErrorComponent2') };
114 like( $@, qr/syntax error/,
115 'load_optional_class(DBICTest::SyntaxErrorComponent2) threw ok' );
116 }
117
118
119 eval {
120 package Fake::ResultSet;
121
122 use base 'DBIx::Class::ResultSet';
123
124 __PACKAGE__->load_components('+DBICTest::SyntaxErrorComponent3');
125 };
126
127 # Make sure the errors in components of resultset classes are reported right.
128 like($@, qr!\Qsyntax error at t/lib/DBICTest/SyntaxErrorComponent3.pm!, "Errors from RS components reported right");
129
130 1;
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6 use Class::Inspector;
7
8 BEGIN {
9 package TestPackage::A;
10 sub some_method {}
11 }
12
13 my $schema = DBICTest->init_schema();
14
15 plan tests => 28;
16
17 # Test ensure_class_found
18 ok( $schema->ensure_class_found('DBIx::Class::Schema'),
19 'loaded package DBIx::Class::Schema was found' );
20 ok( !Class::Inspector->loaded('DBICTest::FakeComponent'),
21 'DBICTest::FakeComponent not loaded yet' );
22 ok( $schema->ensure_class_found('DBICTest::FakeComponent'),
23 'package DBICTest::FakeComponent was found' );
24 ok( !Class::Inspector->loaded('DBICTest::FakeComponent'),
25 'DBICTest::FakeComponent not loaded by ensure_class_found()' );
26 ok( $schema->ensure_class_found('TestPackage::A'),
27 'anonymous package TestPackage::A found' );
28 ok( !$schema->ensure_class_found('FAKE::WONT::BE::FOUND'),
29 'fake package not found' );
30
31 # Test load_optional_class
32 my $retval = eval { $schema->load_optional_class('ANOTHER::FAKE::PACKAGE') };
33 ok( !$@, 'load_optional_class on a nonexistent class did not throw' );
34 ok( !$retval, 'nonexistent package not loaded' );
35 $retval = eval { $schema->load_optional_class('DBICTest::OptionalComponent') };
36 ok( !$@, 'load_optional_class on an existing class did not throw' );
37 ok( $retval, 'DBICTest::OptionalComponent loaded' );
38 eval { $schema->load_optional_class('DBICTest::ErrorComponent') };
39 like( $@, qr/did not return a true value/,
40 'DBICTest::ErrorComponent threw ok' );
41
42 # Simulate a PAR environment
43 {
44 my @code;
45 local @INC = @INC;
46 unshift @INC, sub {
47 if ($_[1] eq 'VIRTUAL/PAR/PACKAGE.pm') {
48 return (sub { return 0 unless @code; $_ = shift @code; 1; } );
49 }
50 else {
51 return ();
52 }
53 };
54
55 $retval = eval { $schema->load_optional_class('FAKE::PAR::PACKAGE') };
56 ok( !$@, 'load_optional_class on a nonexistent PAR class did not throw' );
57 ok( !$retval, 'nonexistent PAR package not loaded' );
58
59
60 # simulate a class which does load but does not return true
61 @code = (
62 q/package VIRTUAL::PAR::PACKAGE;/,
63 q/0;/,
64 );
65
66 $retval = eval { $schema->load_optional_class('VIRTUAL::PAR::PACKAGE') };
67 ok( $@, 'load_optional_class of a no-true-returning PAR module did throw' );
68 ok( !$retval, 'no-true-returning PAR package not loaded' );
69
70 # simulate a normal class (no one adjusted %INC so it will be tried again
71 @code = (
72 q/package VIRTUAL::PAR::PACKAGE;/,
73 q/1;/,
74 );
75
76 $retval = eval { $schema->load_optional_class('VIRTUAL::PAR::PACKAGE') };
77 ok( !$@, 'load_optional_class of a PAR module did not throw' );
78 ok( $retval, 'PAR package "loaded"' );
79
80 # see if we can still load stuff with the coderef present
81 $retval = eval { $schema->load_optional_class('DBIx::Class::ResultClass::HashRefInflator') };
82 ok( !$@, 'load_optional_class did not throw' ) || diag $@;
83 ok( $retval, 'DBIx::Class::ResultClass::HashRefInflator loaded' );
84 }
85
86 # Test ensure_class_loaded
87 ok( Class::Inspector->loaded('TestPackage::A'), 'anonymous package exists' );
88 eval { $schema->ensure_class_loaded('TestPackage::A'); };
89 ok( !$@, 'ensure_class_loaded detected an anon. class' );
90 eval { $schema->ensure_class_loaded('FakePackage::B'); };
91 like( $@, qr/Can't locate/,
92 'ensure_class_loaded threw exception for nonexistent class' );
93 ok( !Class::Inspector->loaded('DBICTest::FakeComponent'),
94 'DBICTest::FakeComponent not loaded yet' );
95 eval { $schema->ensure_class_loaded('DBICTest::FakeComponent'); };
96 ok( !$@, 'ensure_class_loaded detected an existing but non-loaded class' );
97 ok( Class::Inspector->loaded('DBICTest::FakeComponent'),
98 'DBICTest::FakeComponent now loaded' );
99
100 {
101 # Squash warnings about syntax errors in SytaxErrorComponent.pm
102 local $SIG{__WARN__} = sub {
103 my $warning = shift;
104 warn $warning unless (
105 $warning =~ /String found where operator expected/ or
106 $warning =~ /Missing operator before/
107 );
108 };
109
110 eval { $schema->ensure_class_loaded('DBICTest::SyntaxErrorComponent1') };
111 like( $@, qr/syntax error/,
112 'ensure_class_loaded(DBICTest::SyntaxErrorComponent1) threw ok' );
113 eval { $schema->load_optional_class('DBICTest::SyntaxErrorComponent2') };
114 like( $@, qr/syntax error/,
115 'load_optional_class(DBICTest::SyntaxErrorComponent2) threw ok' );
116 }
117
118
119 eval {
120 package Fake::ResultSet;
121
122 use base 'DBIx::Class::ResultSet';
123
124 __PACKAGE__->load_components('+DBICTest::SyntaxErrorComponent3');
125 };
126
127 # Make sure the errors in components of resultset classes are reported right.
128 like($@, qr!\Qsyntax error at t/lib/DBICTest/SyntaxErrorComponent3.pm!, "Errors from RS components reported right");
129
130 1;
+40
-11
t/90join_torture.t less more
00 use strict;
1 use warnings;
1 use warnings;
22
33 use Test::More;
4 use Test::Exception;
45 use lib qw(t/lib);
56 use DBICTest;
7 use DBIC::SqlMakerTest;
68 my $schema = DBICTest->init_schema();
7
8 plan tests => 22;
99
1010 {
1111 my $rs = $schema->resultset( 'CD' )->search(
2424 ],
2525 }
2626 );
27
28 eval {
27
28 lives_ok {
2929 my @rows = $rs->all();
3030 };
31 is( $@, '' );
3231 }
3332
3433
105104 is(scalar(@{$merge_rs_2->{attrs}->{join}}), 1, 'only one join kept when inherited');
106105 my $merge_rs_2_cd = $merge_rs_2->next;
107106
108 eval {
107 lives_ok (sub {
109108
110109 my @rs_with_prefetch = $schema->resultset('TreeLike')
111110 ->search(
114113 prefetch => [ 'parent', { 'children' => 'parent' } ],
115114 });
116115
117 };
118
119 ok(!$@, "pathological prefetch ok");
116 }, 'pathological prefetch ok');
120117
121118 my $rs = $schema->resultset("Artist")->search({}, { join => 'twokeys' });
122119 my $second_search_rs = $rs->search({ 'cds_2.cdid' => '2' }, { join =>
124121 is(scalar(@{$second_search_rs->{attrs}->{join}}), 3, 'both joins kept');
125122 ok($second_search_rs->next, 'query on double joined rel runs okay');
126123
127 1;
124 # test joinmap pruner
125 lives_ok ( sub {
126 my $rs = $schema->resultset('Artwork')->search (
127 {
128 },
129 {
130 distinct => 1,
131 join => [
132 { artwork_to_artist => 'artist' },
133 { cd => 'artist' },
134 ],
135 },
136 );
137
138 is_same_sql_bind (
139 $rs->count_rs->as_query,
140 '(
141 SELECT COUNT( * )
142 FROM (
143 SELECT me.cd_id
144 FROM cd_artwork me
145 JOIN cd cd ON cd.cdid = me.cd_id
146 JOIN artist artist_2 ON artist_2.artistid = cd.artist
147 GROUP BY me.cd_id
148 ) count_subq
149 )',
150 [],
151 );
152
153 ok (defined $rs->count);
154 });
155
156 done_testing;
+135
-135
t/91merge_attr.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6 use Test::More;
7
8 plan tests => 15;
9
10 my $schema = DBICTest->init_schema();
11 my $rs = $schema->resultset( 'CD' );
12
13 {
14 my $a = 'artist';
15 my $b = 'cd';
16 my $expected = [ 'artist', 'cd' ];
17 my $result = $rs->_merge_attr($a, $b);
18 is_deeply( $result, $expected );
19 }
20
21 {
22 my $a = [ 'artist' ];
23 my $b = [ 'cd' ];
24 my $expected = [ 'artist', 'cd' ];
25 my $result = $rs->_merge_attr($a, $b);
26 is_deeply( $result, $expected );
27 }
28
29 {
30 my $a = [ 'artist', 'cd' ];
31 my $b = [ 'cd' ];
32 my $expected = [ 'artist', 'cd' ];
33 my $result = $rs->_merge_attr($a, $b);
34 is_deeply( $result, $expected );
35 }
36
37 {
38 my $a = [ 'artist', 'artist' ];
39 my $b = [ 'artist', 'cd' ];
40 my $expected = [ 'artist', 'artist', 'cd' ];
41 my $result = $rs->_merge_attr($a, $b);
42 is_deeply( $result, $expected );
43 }
44
45 {
46 my $a = [ 'artist', 'cd' ];
47 my $b = [ 'artist', 'artist' ];
48 my $expected = [ 'artist', 'cd', 'artist' ];
49 my $result = $rs->_merge_attr($a, $b);
50 is_deeply( $result, $expected );
51 }
52
53 {
54 my $a = [ 'twokeys' ];
55 my $b = [ 'cds', 'cds' ];
56 my $expected = [ 'twokeys', 'cds', 'cds' ];
57 my $result = $rs->_merge_attr($a, $b);
58 is_deeply( $result, $expected );
59 }
60
61 {
62 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
63 my $b = 'artist';
64 my $expected = [ 'artist', 'cd', { 'artist' => 'manager' } ];
65 my $result = $rs->_merge_attr($a, $b);
66 is_deeply( $result, $expected );
67 }
68
69 {
70 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
71 my $b = [ 'artist', 'cd' ];
72 my $expected = [ 'artist', 'cd', { 'artist' => 'manager' } ];
73 my $result = $rs->_merge_attr($a, $b);
74 is_deeply( $result, $expected );
75 }
76
77 {
78 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
79 my $b = { 'artist' => 'manager' };
80 my $expected = [ 'artist', 'cd', { 'artist' => [ 'manager' ] } ];
81 my $result = $rs->_merge_attr($a, $b);
82 is_deeply( $result, $expected );
83 }
84
85 {
86 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
87 my $b = { 'artist' => 'agent' };
88 my $expected = [ { 'artist' => 'agent' }, 'cd', { 'artist' => 'manager' } ];
89 my $result = $rs->_merge_attr($a, $b);
90 is_deeply( $result, $expected );
91 }
92
93 {
94 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
95 my $b = { 'artist' => { 'manager' => 'artist' } };
96 my $expected = [ 'artist', 'cd', { 'artist' => [ { 'manager' => 'artist' } ] } ];
97 my $result = $rs->_merge_attr($a, $b);
98 is_deeply( $result, $expected );
99 }
100
101 {
102 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
103 my $b = { 'artist' => { 'manager' => [ 'artist', 'label' ] } };
104 my $expected = [ 'artist', 'cd', { 'artist' => [ { 'manager' => [ 'artist', 'label' ] } ] } ];
105 my $result = $rs->_merge_attr($a, $b);
106 is_deeply( $result, $expected );
107 }
108
109 {
110 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
111 my $b = { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } };
112 my $expected = [ { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } }, 'cd', { 'artist' => 'manager' } ];
113 my $result = $rs->_merge_attr($a, $b);
114 is_deeply( $result, $expected );
115 }
116
117 {
118 my $a = [ 'artist', 'cd' ];
119 my $b = { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } };
120 my $expected = [ { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } }, 'cd' ];
121 my $result = $rs->_merge_attr($a, $b);
122 is_deeply( $result, $expected );
123 }
124
125 {
126 my $a = [ { 'artist' => 'manager' }, 'cd' ];
127 my $b = [ 'artist', { 'artist' => 'manager' } ];
128 my $expected = [ { 'artist' => 'manager' }, 'cd', { 'artist' => 'manager' } ];
129 my $result = $rs->_merge_attr($a, $b);
130 is_deeply( $result, $expected );
131 }
132
133
134 1;
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6 use Test::More;
7
8 plan tests => 15;
9
10 my $schema = DBICTest->init_schema();
11 my $rs = $schema->resultset( 'CD' );
12
13 {
14 my $a = 'artist';
15 my $b = 'cd';
16 my $expected = [ 'artist', 'cd' ];
17 my $result = $rs->_merge_attr($a, $b);
18 is_deeply( $result, $expected );
19 }
20
21 {
22 my $a = [ 'artist' ];
23 my $b = [ 'cd' ];
24 my $expected = [ 'artist', 'cd' ];
25 my $result = $rs->_merge_attr($a, $b);
26 is_deeply( $result, $expected );
27 }
28
29 {
30 my $a = [ 'artist', 'cd' ];
31 my $b = [ 'cd' ];
32 my $expected = [ 'artist', 'cd' ];
33 my $result = $rs->_merge_attr($a, $b);
34 is_deeply( $result, $expected );
35 }
36
37 {
38 my $a = [ 'artist', 'artist' ];
39 my $b = [ 'artist', 'cd' ];
40 my $expected = [ 'artist', 'artist', 'cd' ];
41 my $result = $rs->_merge_attr($a, $b);
42 is_deeply( $result, $expected );
43 }
44
45 {
46 my $a = [ 'artist', 'cd' ];
47 my $b = [ 'artist', 'artist' ];
48 my $expected = [ 'artist', 'cd', 'artist' ];
49 my $result = $rs->_merge_attr($a, $b);
50 is_deeply( $result, $expected );
51 }
52
53 {
54 my $a = [ 'twokeys' ];
55 my $b = [ 'cds', 'cds' ];
56 my $expected = [ 'twokeys', 'cds', 'cds' ];
57 my $result = $rs->_merge_attr($a, $b);
58 is_deeply( $result, $expected );
59 }
60
61 {
62 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
63 my $b = 'artist';
64 my $expected = [ 'artist', 'cd', { 'artist' => 'manager' } ];
65 my $result = $rs->_merge_attr($a, $b);
66 is_deeply( $result, $expected );
67 }
68
69 {
70 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
71 my $b = [ 'artist', 'cd' ];
72 my $expected = [ 'artist', 'cd', { 'artist' => 'manager' } ];
73 my $result = $rs->_merge_attr($a, $b);
74 is_deeply( $result, $expected );
75 }
76
77 {
78 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
79 my $b = { 'artist' => 'manager' };
80 my $expected = [ 'artist', 'cd', { 'artist' => [ 'manager' ] } ];
81 my $result = $rs->_merge_attr($a, $b);
82 is_deeply( $result, $expected );
83 }
84
85 {
86 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
87 my $b = { 'artist' => 'agent' };
88 my $expected = [ { 'artist' => 'agent' }, 'cd', { 'artist' => 'manager' } ];
89 my $result = $rs->_merge_attr($a, $b);
90 is_deeply( $result, $expected );
91 }
92
93 {
94 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
95 my $b = { 'artist' => { 'manager' => 'artist' } };
96 my $expected = [ 'artist', 'cd', { 'artist' => [ { 'manager' => 'artist' } ] } ];
97 my $result = $rs->_merge_attr($a, $b);
98 is_deeply( $result, $expected );
99 }
100
101 {
102 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
103 my $b = { 'artist' => { 'manager' => [ 'artist', 'label' ] } };
104 my $expected = [ 'artist', 'cd', { 'artist' => [ { 'manager' => [ 'artist', 'label' ] } ] } ];
105 my $result = $rs->_merge_attr($a, $b);
106 is_deeply( $result, $expected );
107 }
108
109 {
110 my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
111 my $b = { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } };
112 my $expected = [ { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } }, 'cd', { 'artist' => 'manager' } ];
113 my $result = $rs->_merge_attr($a, $b);
114 is_deeply( $result, $expected );
115 }
116
117 {
118 my $a = [ 'artist', 'cd' ];
119 my $b = { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } };
120 my $expected = [ { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } }, 'cd' ];
121 my $result = $rs->_merge_attr($a, $b);
122 is_deeply( $result, $expected );
123 }
124
125 {
126 my $a = [ { 'artist' => 'manager' }, 'cd' ];
127 my $b = [ 'artist', { 'artist' => 'manager' } ];
128 my $expected = [ { 'artist' => 'manager' }, 'cd', { 'artist' => 'manager' } ];
129 my $result = $rs->_merge_attr($a, $b);
130 is_deeply( $result, $expected );
131 }
132
133
134 1;
+70
-70
t/93nobindvars.t less more
0 use strict;
1 use warnings;
2
3 # Copied from 71mysql.t, manually using NoBindVars. This is to give that code
4 # wider testing, since virtually nobody who regularly runs the test suite
5 # is using DBD::Sybase+FreeTDS+MSSQL -- blblack
6
7 use Test::More;
8 use lib qw(t/lib);
9 use DBICTest;
10 use DBI::Const::GetInfoType;
11
12 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
13
14 #warn "$dsn $user $pass";
15
16 plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
17 unless ($dsn && $user);
18
19 plan tests => 4;
20
21 { # Fake storage driver for mysql + no bind variables
22 package DBIx::Class::Storage::DBI::MySQLNoBindVars;
23 use Class::C3;
24 use base qw/
25 DBIx::Class::Storage::DBI::NoBindVars
26 DBIx::Class::Storage::DBI::mysql
27 /;
28 $INC{'DBIx/Class/Storage/DBI/MySQLNoBindVars.pm'} = 1;
29 }
30
31 # XXX Class::C3 doesn't like some of the Storage stuff happening late...
32 Class::C3::reinitialize();
33
34 my $schema = DBICTest::Schema->clone;
35 $schema->storage_type('::DBI::MySQLNoBindVars');
36 $schema->connection($dsn, $user, $pass);
37
38 my $dbh = $schema->storage->dbh;
39
40 $dbh->do("DROP TABLE IF EXISTS artist;");
41
42 $dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10));");
43
44 $schema->class('Artist')->load_components('PK::Auto');
45
46 # test primary key handling
47 my $new = $schema->resultset('Artist')->create({ name => 'foo' });
48 ok($new->artistid, "Auto-PK worked");
49
50 # test LIMIT support
51 for (1..6) {
52 $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
53 }
54 my $it = $schema->resultset('Artist')->search( {},
55 { rows => 3,
56 offset => 2,
57 order_by => 'artistid' }
58 );
59 is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 7 artists
60 is( $it->next->name, "Artist 2", "iterator->next ok" );
61 $it->next;
62 $it->next;
63 is( $it->next, undef, "next past end of resultset ok" );
64
65 # clean up our mess
66 END {
67 my $dbh = eval { $schema->storage->_dbh };
68 $dbh->do("DROP TABLE artist") if $dbh;
69 }
0 use strict;
1 use warnings;
2
3 # Copied from 71mysql.t, manually using NoBindVars. This is to give that code
4 # wider testing, since virtually nobody who regularly runs the test suite
5 # is using DBD::Sybase+FreeTDS+MSSQL -- blblack
6
7 use Test::More;
8 use lib qw(t/lib);
9 use DBICTest;
10 use DBI::Const::GetInfoType;
11
12 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
13
14 #warn "$dsn $user $pass";
15
16 plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
17 unless ($dsn && $user);
18
19 plan tests => 4;
20
21 { # Fake storage driver for mysql + no bind variables
22 package DBIx::Class::Storage::DBI::MySQLNoBindVars;
23 use Class::C3;
24 use base qw/
25 DBIx::Class::Storage::DBI::NoBindVars
26 DBIx::Class::Storage::DBI::mysql
27 /;
28 $INC{'DBIx/Class/Storage/DBI/MySQLNoBindVars.pm'} = 1;
29 }
30
31 # XXX Class::C3 doesn't like some of the Storage stuff happening late...
32 Class::C3::reinitialize();
33
34 my $schema = DBICTest::Schema->clone;
35 $schema->storage_type('::DBI::MySQLNoBindVars');
36 $schema->connection($dsn, $user, $pass);
37
38 my $dbh = $schema->storage->dbh;
39
40 $dbh->do("DROP TABLE IF EXISTS artist;");
41
42 $dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10));");
43
44 $schema->class('Artist')->load_components('PK::Auto');
45
46 # test primary key handling
47 my $new = $schema->resultset('Artist')->create({ name => 'foo' });
48 ok($new->artistid, "Auto-PK worked");
49
50 # test LIMIT support
51 for (1..6) {
52 $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
53 }
54 my $it = $schema->resultset('Artist')->search( {},
55 { rows => 3,
56 offset => 2,
57 order_by => 'artistid' }
58 );
59 is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 7 artists
60 is( $it->next->name, "Artist 2", "iterator->next ok" );
61 $it->next;
62 $it->next;
63 is( $it->next, undef, "next past end of resultset ok" );
64
65 # clean up our mess
66 END {
67 my $dbh = eval { $schema->storage->_dbh };
68 $dbh->do("DROP TABLE artist") if $dbh;
69 }
+62
-62
t/94pk_mutation.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 10;
10
11 my $old_artistid = 1;
12 my $new_artistid = $schema->resultset("Artist")->get_column('artistid')->max + 1;
13
14 # Update the PK
15 {
16 my $artist = $schema->resultset("Artist")->find($old_artistid);
17 ok(defined $artist, 'found an artist with the new PK');
18
19 $artist->update({ artistid => $new_artistid });
20 is($artist->artistid, $new_artistid, 'artist ID matches');
21 }
22
23 # Look for the old PK
24 {
25 my $artist = $schema->resultset("Artist")->find($old_artistid);
26 ok(!defined $artist, 'no artist found with the old PK');
27 }
28
29 # Look for the new PK
30 {
31 my $artist = $schema->resultset("Artist")->find($new_artistid);
32 ok(defined $artist, 'found an artist with the new PK');
33 is($artist->artistid, $new_artistid, 'artist ID matches');
34 }
35
36 # Do it all over again, using a different methodology:
37 $old_artistid = $new_artistid;
38 $new_artistid++;
39
40 # Update the PK
41 {
42 my $artist = $schema->resultset("Artist")->find($old_artistid);
43 ok(defined $artist, 'found an artist with the new PK');
44
45 $artist->artistid($new_artistid);
46 $artist->update;
47 is($artist->artistid, $new_artistid, 'artist ID matches');
48 }
49
50 # Look for the old PK
51 {
52 my $artist = $schema->resultset("Artist")->find($old_artistid);
53 ok(!defined $artist, 'no artist found with the old PK');
54 }
55
56 # Look for the new PK
57 {
58 my $artist = $schema->resultset("Artist")->find($new_artistid);
59 ok(defined $artist, 'found an artist with the new PK');
60 is($artist->artistid, $new_artistid, 'artist ID matches');
61 }
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 10;
10
11 my $old_artistid = 1;
12 my $new_artistid = $schema->resultset("Artist")->get_column('artistid')->max + 1;
13
14 # Update the PK
15 {
16 my $artist = $schema->resultset("Artist")->find($old_artistid);
17 ok(defined $artist, 'found an artist with the new PK');
18
19 $artist->update({ artistid => $new_artistid });
20 is($artist->artistid, $new_artistid, 'artist ID matches');
21 }
22
23 # Look for the old PK
24 {
25 my $artist = $schema->resultset("Artist")->find($old_artistid);
26 ok(!defined $artist, 'no artist found with the old PK');
27 }
28
29 # Look for the new PK
30 {
31 my $artist = $schema->resultset("Artist")->find($new_artistid);
32 ok(defined $artist, 'found an artist with the new PK');
33 is($artist->artistid, $new_artistid, 'artist ID matches');
34 }
35
36 # Do it all over again, using a different methodology:
37 $old_artistid = $new_artistid;
38 $new_artistid++;
39
40 # Update the PK
41 {
42 my $artist = $schema->resultset("Artist")->find($old_artistid);
43 ok(defined $artist, 'found an artist with the new PK');
44
45 $artist->artistid($new_artistid);
46 $artist->update;
47 is($artist->artistid, $new_artistid, 'artist ID matches');
48 }
49
50 # Look for the old PK
51 {
52 my $artist = $schema->resultset("Artist")->find($old_artistid);
53 ok(!defined $artist, 'no artist found with the old PK');
54 }
55
56 # Look for the new PK
57 {
58 my $artist = $schema->resultset("Artist")->find($new_artistid);
59 ok(defined $artist, 'found an artist with the new PK');
60 is($artist->artistid, $new_artistid, 'artist ID matches');
61 }
+31
-0
t/94versioning.t less more
164164 is($schema_v3->get_db_version(), '3.0', 'db version number upgraded');
165165 }
166166
167 # Now, try a v1 -> v3 upgrade with a file that has comments strategically placed in it.
168 # First put the v1 schema back again...
169 {
170 # drop all the tables...
171 eval { $schema_v1->storage->dbh->do('drop table ' . $version_table_name) };
172 eval { $schema_v1->storage->dbh->do('drop table ' . $old_table_name) };
173 eval { $schema_v1->storage->dbh->do('drop table TestVersion') };
174
175 {
176 local $DBICVersion::Schema::VERSION = '1.0';
177 $schema_v1->deploy;
178 }
179 is($schema_v1->get_db_version(), '1.0', 'get_db_version 1.0 ok');
180 }
181
182 # add a "harmless" comment before one of the statements.
183 system( qq($^X -pi -e "s/ALTER/-- this is a comment\nALTER/" $fn->{trans_v23};) );
184
185 # Then attempt v1 -> v3 upgrade
186 {
187 local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
188 $schema_v3->upgrade();
189 is($schema_v3->get_db_version(), '3.0', 'db version number upgraded to 3.0');
190
191 # make sure that the column added after the comment is actually added.
192 lives_ok ( sub {
193 $schema_v3->storage->dbh->do('select ExtraColumn from TestVersion');
194 }, 'new column created');
195 }
196
197
167198 # check behaviour of DBIC_NO_VERSION_CHECK env var and ignore_version connect attr
168199 {
169200 my $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
+67
-67
t/96_is_deteministic_value.t less more
0 use strict;
1 use warnings;
2
3 # 6 tests
4
5 use Test::More;
6 use lib qw(t/lib);
7 use DBICTest;
8 plan skip_all => "DateTime required" unless eval { require DateTime };
9 eval "use DateTime::Format::Strptime";
10 plan skip_all => 'DateTime::Format::Strptime required' if $@;
11 plan 'no_plan';
12 use Test::Exception;
13
14 my $schema = DBICTest->init_schema();
15 my $artist_rs = $schema->resultset('Artist');
16 my $cd_rs = $schema->resultset('CD');
17
18 {
19 my $cd;
20 lives_ok {
21 $cd = $cd_rs->search({ year => {'=' => 1999}})->create
22 ({
23 artist => {name => 'Guillermo1'},
24 title => 'Guillermo 1',
25 });
26 };
27 is($cd->year, 1999);
28 }
29
30 {
31 my $formatter = DateTime::Format::Strptime->new(pattern => '%Y');
32 my $dt = DateTime->new(year => 2006, month => 06, day => 06,
33 formatter => $formatter );
34 my $cd;
35 lives_ok {
36 $cd = $cd_rs->search({ year => $dt})->create
37 ({
38 artist => {name => 'Guillermo2'},
39 title => 'Guillermo 2',
40 });
41 };
42 is($cd->year, 2006);
43 }
44
45
46 {
47 my $artist;
48 lives_ok {
49 $artist = $artist_rs->search({ name => {'!=' => 'Killer'}})
50 ->create({artistid => undef});
51 };
52 is($artist->name, undef);
53 }
54
55
56 {
57 my $artist;
58 lives_ok {
59 $artist = $artist_rs->search({ name => [ q/ some stupid names here/]})
60 ->create({artistid => undef});
61 };
62 is($artist->name, undef);
63 }
64
65
66 1;
0 use strict;
1 use warnings;
2
3 # 6 tests
4
5 use Test::More;
6 use lib qw(t/lib);
7 use DBICTest;
8 plan skip_all => "DateTime required" unless eval { require DateTime };
9 eval "use DateTime::Format::Strptime";
10 plan skip_all => 'DateTime::Format::Strptime required' if $@;
11 plan 'no_plan';
12 use Test::Exception;
13
14 my $schema = DBICTest->init_schema();
15 my $artist_rs = $schema->resultset('Artist');
16 my $cd_rs = $schema->resultset('CD');
17
18 {
19 my $cd;
20 lives_ok {
21 $cd = $cd_rs->search({ year => {'=' => 1999}})->create
22 ({
23 artist => {name => 'Guillermo1'},
24 title => 'Guillermo 1',
25 });
26 };
27 is($cd->year, 1999);
28 }
29
30 {
31 my $formatter = DateTime::Format::Strptime->new(pattern => '%Y');
32 my $dt = DateTime->new(year => 2006, month => 06, day => 06,
33 formatter => $formatter );
34 my $cd;
35 lives_ok {
36 $cd = $cd_rs->search({ year => $dt})->create
37 ({
38 artist => {name => 'Guillermo2'},
39 title => 'Guillermo 2',
40 });
41 };
42 is($cd->year, 2006);
43 }
44
45
46 {
47 my $artist;
48 lives_ok {
49 $artist = $artist_rs->search({ name => {'!=' => 'Killer'}})
50 ->create({artistid => undef});
51 };
52 is($artist->name, undef);
53 }
54
55
56 {
57 my $artist;
58 lives_ok {
59 $artist = $artist_rs->search({ name => [ q/ some stupid names here/]})
60 ->create({artistid => undef});
61 };
62 is($artist->name, undef);
63 }
64
65
66 1;
+63
-63
t/97result_class.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 my $schema = DBICTest->init_schema();
9
10 plan tests => 12;
11
12 {
13 my $cd_rc = $schema->resultset("CD")->result_class;
14
15 throws_ok {
16 $schema->resultset("Artist")
17 ->search_rs({}, {result_class => "IWillExplode"})
18 } qr/Can't locate IWillExplode/, 'nonexistant result_class exception';
19
20 # to make ensure_class_loaded happy, dies on inflate
21 eval 'package IWillExplode; sub dummy {}';
22
23 my $artist_rs = $schema->resultset("Artist")
24 ->search_rs({}, {result_class => "IWillExplode"});
25 is($artist_rs->result_class, 'IWillExplode', 'Correct artist result_class');
26
27 throws_ok {
28 $artist_rs->result_class('mtfnpy')
29 } qr/Can't locate mtfnpy/,
30 'nonexistant result_access exception (from accessor)';
31
32 throws_ok {
33 $artist_rs->first
34 } qr/Can't locate object method "inflate_result" via package "IWillExplode"/,
35 'IWillExplode explodes on inflate';
36
37 my $cd_rs = $artist_rs->related_resultset('cds');
38 is($cd_rs->result_class, $cd_rc, 'Correct cd result_class');
39
40 my $cd_rs2 = $schema->resultset("Artist")->search_rs({})->related_resultset('cds');
41 is($cd_rs->result_class, $cd_rc, 'Correct cd2 result_class');
42
43 my $cd_rs3 = $schema->resultset("Artist")->search_rs({},{})->related_resultset('cds');
44 is($cd_rs->result_class, $cd_rc, 'Correct cd3 result_class');
45
46 isa_ok(eval{ $cd_rs->find(1) }, $cd_rc, 'Inflated into correct cd result_class');
47 }
48
49
50 {
51 my $cd_rc = $schema->resultset("CD")->result_class;
52
53 my $artist_rs = $schema->resultset("Artist")
54 ->search_rs({}, {result_class => "IWillExplode"})->search({artistid => 1});
55 is($artist_rs->result_class, 'IWillExplode', 'Correct artist result_class');
56
57 my $cd_rs = $artist_rs->related_resultset('cds');
58 is($cd_rs->result_class, $cd_rc, 'Correct cd result_class');
59
60 isa_ok(eval{ $cd_rs->find(1) }, $cd_rc, 'Inflated into correct cd result_class');
61 isa_ok(eval{ $cd_rs->search({ cdid => 1 })->first }, $cd_rc, 'Inflated into correct cd result_class');
62 }
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 my $schema = DBICTest->init_schema();
9
10 plan tests => 12;
11
12 {
13 my $cd_rc = $schema->resultset("CD")->result_class;
14
15 throws_ok {
16 $schema->resultset("Artist")
17 ->search_rs({}, {result_class => "IWillExplode"})
18 } qr/Can't locate IWillExplode/, 'nonexistant result_class exception';
19
20 # to make ensure_class_loaded happy, dies on inflate
21 eval 'package IWillExplode; sub dummy {}';
22
23 my $artist_rs = $schema->resultset("Artist")
24 ->search_rs({}, {result_class => "IWillExplode"});
25 is($artist_rs->result_class, 'IWillExplode', 'Correct artist result_class');
26
27 throws_ok {
28 $artist_rs->result_class('mtfnpy')
29 } qr/Can't locate mtfnpy/,
30 'nonexistant result_access exception (from accessor)';
31
32 throws_ok {
33 $artist_rs->first
34 } qr/Can't locate object method "inflate_result" via package "IWillExplode"/,
35 'IWillExplode explodes on inflate';
36
37 my $cd_rs = $artist_rs->related_resultset('cds');
38 is($cd_rs->result_class, $cd_rc, 'Correct cd result_class');
39
40 my $cd_rs2 = $schema->resultset("Artist")->search_rs({})->related_resultset('cds');
41 is($cd_rs->result_class, $cd_rc, 'Correct cd2 result_class');
42
43 my $cd_rs3 = $schema->resultset("Artist")->search_rs({},{})->related_resultset('cds');
44 is($cd_rs->result_class, $cd_rc, 'Correct cd3 result_class');
45
46 isa_ok(eval{ $cd_rs->find(1) }, $cd_rc, 'Inflated into correct cd result_class');
47 }
48
49
50 {
51 my $cd_rc = $schema->resultset("CD")->result_class;
52
53 my $artist_rs = $schema->resultset("Artist")
54 ->search_rs({}, {result_class => "IWillExplode"})->search({artistid => 1});
55 is($artist_rs->result_class, 'IWillExplode', 'Correct artist result_class');
56
57 my $cd_rs = $artist_rs->related_resultset('cds');
58 is($cd_rs->result_class, $cd_rc, 'Correct cd result_class');
59
60 isa_ok(eval{ $cd_rs->find(1) }, $cd_rc, 'Inflated into correct cd result_class');
61 isa_ok(eval{ $cd_rs->search({ cdid => 1 })->first }, $cd_rc, 'Inflated into correct cd result_class');
62 }
+2
-2
t/admin/03data.t less more
4747
4848 my $expected_data = [
4949 [$employee->result_source->columns() ],
50 [1,1,undef,undef,undef,'Trout'],
51 [2,2,undef,undef,undef,'Aran']
50 [1,1,undef,undef,undef,'Trout',undef],
51 [2,2,undef,undef,undef,'Aran',undef]
5252 ];
5353 my $data;
5454 lives_ok { $data = $admin->select('Employee')} 'can retrive data from database';
+25
-25
t/cdbi/08-inheritcols.t less more
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
6 : (tests=> 3);
7 }
8
9 package A;
10 @A::ISA = qw(DBIx::Class::CDBICompat);
11 __PACKAGE__->columns(Primary => 'id');
12
13 package A::B;
14 @A::B::ISA = 'A';
15 __PACKAGE__->columns(All => qw(id b1));
16
17 package A::C;
18 @A::C::ISA = 'A';
19 __PACKAGE__->columns(All => qw(id c1 c2 c3));
20
21 package main;
22 is join (' ', sort A->columns), 'id', "A columns";
23 is join (' ', sort A::B->columns), 'b1 id', "A::B columns";
24 is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns";
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
6 : (tests=> 3);
7 }
8
9 package A;
10 @A::ISA = qw(DBIx::Class::CDBICompat);
11 __PACKAGE__->columns(Primary => 'id');
12
13 package A::B;
14 @A::B::ISA = 'A';
15 __PACKAGE__->columns(All => qw(id b1));
16
17 package A::C;
18 @A::C::ISA = 'A';
19 __PACKAGE__->columns(All => qw(id c1 c2 c3));
20
21 package main;
22 is join (' ', sort A->columns), 'id', "A columns";
23 is join (' ', sort A::B->columns), 'b1 id', "A::B columns";
24 is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns";
+119
-119
t/cdbi/13-constraint.t less more
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 if ($@) {
6 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
7 next;
8 }
9 eval "use DBD::SQLite";
10 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 23);
11 }
12
13 use lib 't/cdbi/testlib';
14 use Film;
15
16 sub valid_rating {
17 my $value = shift;
18 my $ok = grep $value eq $_, qw/U Uc PG 12 15 18/;
19 return $ok;
20 }
21
22 Film->add_constraint('valid rating', Rating => \&valid_rating);
23
24 my %info = (
25 Title => 'La Double Vie De Veronique',
26 Director => 'Kryzstof Kieslowski',
27 Rating => '18',
28 );
29
30 {
31 local $info{Title} = "nonsense";
32 local $info{Rating} = 19;
33 eval { Film->create({%info}) };
34 ok $@, $@;
35 ok !Film->retrieve($info{Title}), "No film created";
36 is(Film->retrieve_all, 0, "So no films");
37 }
38
39 ok(my $ver = Film->create({%info}), "Can create with valid rating");
40 is $ver->Rating, 18, "Rating 18";
41
42 ok $ver->Rating(12), "Change to 12";
43 ok $ver->update, "And update";
44 is $ver->Rating, 12, "Rating now 12";
45
46 eval {
47 $ver->Rating(13);
48 $ver->update;
49 };
50 ok $@, $@;
51 is $ver->Rating, 12, "Rating still 12";
52 ok $ver->delete, "Delete";
53
54 # this threw an infinite loop in old versions
55 Film->add_constraint('valid director', Director => sub { 1 });
56 my $fred = Film->create({ Rating => '12' });
57
58 # this test is a bit problematical because we don't supply a primary key
59 # to the create() and the table doesn't use auto_increment or a sequence.
60 ok $fred, "Got fred";
61
62 {
63 ok +Film->constrain_column(rating => [qw/U PG 12 15 19/]),
64 "constraint_column";
65 my $narrower = eval { Film->create({ Rating => 'Uc' }) };
66 like $@, qr/fails.*constraint/, "Fails listref constraint";
67 my $ok = eval { Film->create({ Rating => 'U' }) };
68 is $@, '', "Can create with rating U";
69 SKIP: {
70 skip "No column objects", 2;
71 ok +Film->find_column('rating')->is_constrained, "Rating is constrained";
72 ok +Film->find_column('director')->is_constrained, "Director is not";
73 }
74 }
75
76 {
77 ok +Film->constrain_column(title => qr/The/), "constraint_column";
78 my $inferno = eval { Film->create({ Title => 'Towering Infero' }) };
79 like $@, qr/fails.*constraint/, "Can't create towering inferno";
80 my $the_inferno = eval { Film->create({ Title => 'The Towering Infero' }) };
81 is $@, '', "But can create THE towering inferno";
82 }
83
84 {
85
86 sub Film::_constrain_by_untaint {
87 my ($class, $col, $string, $type) = @_;
88 $class->add_constraint(
89 untaint => $col => sub {
90 my ($value, $self, $column_name, $changing) = @_;
91 $value eq "today" ? $changing->{$column_name} = "2001-03-03" : 0;
92 }
93 );
94 }
95 eval { Film->constrain_column(codirector => Untaint => 'date') };
96 is $@, '', 'Can constrain with untaint';
97
98 my $freeaa =
99 eval { Film->create({ title => "The Freaa", codirector => 'today' }) };
100 is $@, '', "Can create codirector";
101 is $freeaa && $freeaa->codirector, '2001-03-03', "Set the codirector";
102 }
103
104 __DATA__
105
106 use CGI::Untaint;
107
108 sub _constrain_by_untaint {
109 my ($class, $col, $string, $type) = @_;
110 $class->add_constraint(untaint => $col => sub {
111 my ($value, $self, $column_name, $changing) = @_;
112 my $h = CGI::Untaint->new({ %$changing });
113 return unless my $val = $h->extract("-as_$type" => $column_name);
114 $changing->{$column_name} = $val;
115 return 1;
116 });
117 }
118
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 if ($@) {
6 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
7 next;
8 }
9 eval "use DBD::SQLite";
10 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 23);
11 }
12
13 use lib 't/cdbi/testlib';
14 use Film;
15
16 sub valid_rating {
17 my $value = shift;
18 my $ok = grep $value eq $_, qw/U Uc PG 12 15 18/;
19 return $ok;
20 }
21
22 Film->add_constraint('valid rating', Rating => \&valid_rating);
23
24 my %info = (
25 Title => 'La Double Vie De Veronique',
26 Director => 'Kryzstof Kieslowski',
27 Rating => '18',
28 );
29
30 {
31 local $info{Title} = "nonsense";
32 local $info{Rating} = 19;
33 eval { Film->create({%info}) };
34 ok $@, $@;
35 ok !Film->retrieve($info{Title}), "No film created";
36 is(Film->retrieve_all, 0, "So no films");
37 }
38
39 ok(my $ver = Film->create({%info}), "Can create with valid rating");
40 is $ver->Rating, 18, "Rating 18";
41
42 ok $ver->Rating(12), "Change to 12";
43 ok $ver->update, "And update";
44 is $ver->Rating, 12, "Rating now 12";
45
46 eval {
47 $ver->Rating(13);
48 $ver->update;
49 };
50 ok $@, $@;
51 is $ver->Rating, 12, "Rating still 12";
52 ok $ver->delete, "Delete";
53
54 # this threw an infinite loop in old versions
55 Film->add_constraint('valid director', Director => sub { 1 });
56 my $fred = Film->create({ Rating => '12' });
57
58 # this test is a bit problematical because we don't supply a primary key
59 # to the create() and the table doesn't use auto_increment or a sequence.
60 ok $fred, "Got fred";
61
62 {
63 ok +Film->constrain_column(rating => [qw/U PG 12 15 19/]),
64 "constraint_column";
65 my $narrower = eval { Film->create({ Rating => 'Uc' }) };
66 like $@, qr/fails.*constraint/, "Fails listref constraint";
67 my $ok = eval { Film->create({ Rating => 'U' }) };
68 is $@, '', "Can create with rating U";
69 SKIP: {
70 skip "No column objects", 2;
71 ok +Film->find_column('rating')->is_constrained, "Rating is constrained";
72 ok +Film->find_column('director')->is_constrained, "Director is not";
73 }
74 }
75
76 {
77 ok +Film->constrain_column(title => qr/The/), "constraint_column";
78 my $inferno = eval { Film->create({ Title => 'Towering Infero' }) };
79 like $@, qr/fails.*constraint/, "Can't create towering inferno";
80 my $the_inferno = eval { Film->create({ Title => 'The Towering Infero' }) };
81 is $@, '', "But can create THE towering inferno";
82 }
83
84 {
85
86 sub Film::_constrain_by_untaint {
87 my ($class, $col, $string, $type) = @_;
88 $class->add_constraint(
89 untaint => $col => sub {
90 my ($value, $self, $column_name, $changing) = @_;
91 $value eq "today" ? $changing->{$column_name} = "2001-03-03" : 0;
92 }
93 );
94 }
95 eval { Film->constrain_column(codirector => Untaint => 'date') };
96 is $@, '', 'Can constrain with untaint';
97
98 my $freeaa =
99 eval { Film->create({ title => "The Freaa", codirector => 'today' }) };
100 is $@, '', "Can create codirector";
101 is $freeaa && $freeaa->codirector, '2001-03-03', "Set the codirector";
102 }
103
104 __DATA__
105
106 use CGI::Untaint;
107
108 sub _constrain_by_untaint {
109 my ($class, $col, $string, $type) = @_;
110 $class->add_constraint(untaint => $col => sub {
111 my ($value, $self, $column_name, $changing) = @_;
112 my $h = CGI::Untaint->new({ %$changing });
113 return unless my $val = $h->extract("-as_$type" => $column_name);
114 $changing->{$column_name} = $val;
115 return 1;
116 });
117 }
118
+36
-36
t/cdbi/16-reserved.t less more
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 if ($@) {
6 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
7 next;
8 }
9 eval "use DBD::SQLite";
10 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5);
11 }
12
13 use lib 't/cdbi/testlib';
14 require Film;
15 require Order;
16
17 Film->has_many(orders => 'Order');
18 Order->has_a(film => 'Film');
19
20 Film->create_test_film;
21
22 my $film = Film->retrieve('Bad Taste');
23 isa_ok $film => 'Film';
24
25 $film->add_to_orders({ orders => 10 });
26
27 my $bto = (Order->search(film => 'Bad Taste'))[0];
28 isa_ok $bto => 'Order';
29 is $bto->orders, 10, "Correct number of orders";
30
31
32 my $infilm = $bto->film;
33 isa_ok $infilm, "Film";
34
35 is $infilm->id, $film->id, "Orders hasa Film";
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 if ($@) {
6 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
7 next;
8 }
9 eval "use DBD::SQLite";
10 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5);
11 }
12
13 use lib 't/cdbi/testlib';
14 require Film;
15 require Order;
16
17 Film->has_many(orders => 'Order');
18 Order->has_a(film => 'Film');
19
20 Film->create_test_film;
21
22 my $film = Film->retrieve('Bad Taste');
23 isa_ok $film => 'Film';
24
25 $film->add_to_orders({ orders => 10 });
26
27 my $bto = (Order->search(film => 'Bad Taste'))[0];
28 isa_ok $bto => 'Order';
29 is $bto->orders, 10, "Correct number of orders";
30
31
32 my $infilm = $bto->film;
33 isa_ok $infilm, "Film";
34
35 is $infilm->id, $film->id, "Orders hasa Film";
+25
-25
t/cdbi/22-self_referential.t less more
0 use Test::More;
1
2 BEGIN {
3 eval "use DBIx::Class::CDBICompat;";
4 plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required') : (tests=> 2);
5 }
6
7 use strict;
8
9 use lib 't/cdbi/testlib';
10 use Actor;
11 use ActorAlias;
12 Actor->has_many( aliases => [ 'ActorAlias' => 'alias' ] );
13
14 my $first = Actor->create( { Name => 'First' } );
15 my $second = Actor->create( { Name => 'Second' } );
16
17 ActorAlias->create( { actor => $first, alias => $second } );
18
19 my @aliases = $first->aliases;
20
21 is( scalar @aliases, 1, 'proper number of aliases' );
22 is( $aliases[ 0 ]->name, 'Second', 'proper alias' );
23
24
0 use Test::More;
1
2 BEGIN {
3 eval "use DBIx::Class::CDBICompat;";
4 plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required') : (tests=> 2);
5 }
6
7 use strict;
8
9 use lib 't/cdbi/testlib';
10 use Actor;
11 use ActorAlias;
12 Actor->has_many( aliases => [ 'ActorAlias' => 'alias' ] );
13
14 my $first = Actor->create( { Name => 'First' } );
15 my $second = Actor->create( { Name => 'Second' } );
16
17 ActorAlias->create( { actor => $first, alias => $second } );
18
19 my @aliases = $first->aliases;
20
21 is( scalar @aliases, 1, 'proper number of aliases' );
22 is( $aliases[ 0 ]->name, 'Second', 'proper alias' );
23
24
+78
-78
t/cdbi/23-cascade.t less more
0 use strict;
1 use Test::More;
2 use Data::Dumper;
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 if ($@) {
7 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
8 next;
9 }
10 eval "use DBD::SQLite";
11 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 12);
12 }
13
14 INIT {
15 use lib 't/cdbi/testlib';
16 use Film;
17 use Director;
18 }
19
20 { # Cascade on delete
21 Director->has_many(nasties => 'Film');
22
23 my $dir = Director->insert({
24 name => "Lewis Teague",
25 });
26 my $kk = $dir->add_to_nasties({
27 Title => 'Alligator'
28 });
29 is $kk->director, $dir, "Director set OK";
30 is $dir->nasties, 1, "We have one nasty";
31
32 ok $dir->delete;
33 ok !Film->retrieve("Alligator"), "has_many cascade deletes by default";
34 }
35
36
37 # Two ways of saying not to cascade
38 for my $args ({ no_cascade_delete => 1 }, { cascade => "None" }) {
39 Director->has_many(nasties => 'Film', $args);
40
41 my $dir = Director->insert({
42 name => "Lewis Teague",
43 });
44 my $kk = $dir->add_to_nasties({
45 Title => 'Alligator'
46 });
47 is $kk->director, $dir, "Director set OK";
48 is $dir->nasties, 1, "We have one nasty";
49
50 ok $dir->delete;
51 local $Data::Dumper::Terse = 1;
52 ok +Film->retrieve("Alligator"), 'has_many with ' . Dumper ($args);;
53 $kk->delete;
54 }
55
56
57 #{ # Fail on cascade
58 # local $TODO = 'cascade => "Fail" unimplemented';
59 #
60 # Director->has_many(nasties => Film => { cascade => 'Fail' });
61 #
62 # my $dir = Director->insert({ name => "Nasty Noddy" });
63 # my $kk = $dir->add_to_nasties({ Title => 'Killer Killers' });
64 # is $kk->director, $dir, "Director set OK";
65 # is $dir->nasties, 1, "We have one nasty";
66 #
67 # ok !eval { $dir->delete };
68 # like $@, qr/1/, "Can't delete while films exist";
69 #
70 # my $rr = $dir->add_to_nasties({ Title => 'Revenge of the Revengers' });
71 # ok !eval { $dir->delete };
72 # like $@, qr/2/, "Still can't delete";
73 #
74 # $dir->nasties->delete_all;
75 # ok eval { $dir->delete };
76 # is $@, '', "Can delete once films are gone";
77 #}
0 use strict;
1 use Test::More;
2 use Data::Dumper;
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 if ($@) {
7 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
8 next;
9 }
10 eval "use DBD::SQLite";
11 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 12);
12 }
13
14 INIT {
15 use lib 't/cdbi/testlib';
16 use Film;
17 use Director;
18 }
19
20 { # Cascade on delete
21 Director->has_many(nasties => 'Film');
22
23 my $dir = Director->insert({
24 name => "Lewis Teague",
25 });
26 my $kk = $dir->add_to_nasties({
27 Title => 'Alligator'
28 });
29 is $kk->director, $dir, "Director set OK";
30 is $dir->nasties, 1, "We have one nasty";
31
32 ok $dir->delete;
33 ok !Film->retrieve("Alligator"), "has_many cascade deletes by default";
34 }
35
36
37 # Two ways of saying not to cascade
38 for my $args ({ no_cascade_delete => 1 }, { cascade => "None" }) {
39 Director->has_many(nasties => 'Film', $args);
40
41 my $dir = Director->insert({
42 name => "Lewis Teague",
43 });
44 my $kk = $dir->add_to_nasties({
45 Title => 'Alligator'
46 });
47 is $kk->director, $dir, "Director set OK";
48 is $dir->nasties, 1, "We have one nasty";
49
50 ok $dir->delete;
51 local $Data::Dumper::Terse = 1;
52 ok +Film->retrieve("Alligator"), 'has_many with ' . Dumper ($args);;
53 $kk->delete;
54 }
55
56
57 #{ # Fail on cascade
58 # local $TODO = 'cascade => "Fail" unimplemented';
59 #
60 # Director->has_many(nasties => Film => { cascade => 'Fail' });
61 #
62 # my $dir = Director->insert({ name => "Nasty Noddy" });
63 # my $kk = $dir->add_to_nasties({ Title => 'Killer Killers' });
64 # is $kk->director, $dir, "Director set OK";
65 # is $dir->nasties, 1, "We have one nasty";
66 #
67 # ok !eval { $dir->delete };
68 # like $@, qr/1/, "Can't delete while films exist";
69 #
70 # my $rr = $dir->add_to_nasties({ Title => 'Revenge of the Revengers' });
71 # ok !eval { $dir->delete };
72 # like $@, qr/2/, "Still can't delete";
73 #
74 # $dir->nasties->delete_all;
75 # ok eval { $dir->delete };
76 # is $@, '', "Can delete once films are gone";
77 #}
+78
-78
t/cdbi/24-meta_info.t less more
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
6 if $@;
7
8 plan skip_all => "Time::Piece required for this test"
9 unless eval { require Time::Piece };
10
11 plan tests => 12;
12 }
13
14 use Test::Warn;
15
16 package Temp::DBI;
17 use base qw(DBIx::Class::CDBICompat);
18 Temp::DBI->columns(All => qw(id date));
19
20 my $strptime_inflate = sub {
21 Time::Piece->strptime(shift, "%Y-%m-%d")
22 };
23 Temp::DBI->has_a(
24 date => 'Time::Piece',
25 inflate => $strptime_inflate
26 );
27
28
29 package Temp::Person;
30 use base 'Temp::DBI';
31 Temp::Person->table('people');
32 Temp::Person->columns(Info => qw(name pet));
33 Temp::Person->has_a( pet => 'Temp::Pet' );
34
35 package Temp::Pet;
36 use base 'Temp::DBI';
37 Temp::Pet->table('pets');
38 Temp::Pet->columns(Info => qw(name));
39 Temp::Pet->has_many(owners => 'Temp::Person');
40
41 package main;
42
43 {
44 my $pn_meta = Temp::Person->meta_info('has_a');
45 is_deeply [sort keys %$pn_meta], [qw/date pet/], "Person has Date and Pet";
46 }
47
48 {
49 my $pt_meta = Temp::Pet->meta_info;
50 is_deeply [keys %{$pt_meta->{has_a}}], [qw/date/], "Pet has Date";
51 is_deeply [keys %{$pt_meta->{has_many}}], [qw/owners/], "And owners";
52 }
53
54 {
55 my $pet = Temp::Person->meta_info( has_a => 'pet' );
56 is $pet->class, 'Temp::Person';
57 is $pet->foreign_class, 'Temp::Pet';
58 is $pet->accessor, 'pet';
59 is $pet->name, 'has_a';
60 }
61
62 {
63 my $owners = Temp::Pet->meta_info( has_many => 'owners' );
64
65 is_deeply $owners->args, {
66 foreign_key => 'pet',
67 mapping => [],
68 };
69 }
70
71 {
72 my $date = Temp::Pet->meta_info( has_a => 'date' );
73 is $date->class, 'Temp::DBI';
74 is $date->foreign_class, 'Time::Piece';
75 is $date->accessor, 'date';
76 is $date->args->{inflate}, $strptime_inflate;
77 }
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
6 if $@;
7
8 plan skip_all => "Time::Piece required for this test"
9 unless eval { require Time::Piece };
10
11 plan tests => 12;
12 }
13
14 use Test::Warn;
15
16 package Temp::DBI;
17 use base qw(DBIx::Class::CDBICompat);
18 Temp::DBI->columns(All => qw(id date));
19
20 my $strptime_inflate = sub {
21 Time::Piece->strptime(shift, "%Y-%m-%d")
22 };
23 Temp::DBI->has_a(
24 date => 'Time::Piece',
25 inflate => $strptime_inflate
26 );
27
28
29 package Temp::Person;
30 use base 'Temp::DBI';
31 Temp::Person->table('people');
32 Temp::Person->columns(Info => qw(name pet));
33 Temp::Person->has_a( pet => 'Temp::Pet' );
34
35 package Temp::Pet;
36 use base 'Temp::DBI';
37 Temp::Pet->table('pets');
38 Temp::Pet->columns(Info => qw(name));
39 Temp::Pet->has_many(owners => 'Temp::Person');
40
41 package main;
42
43 {
44 my $pn_meta = Temp::Person->meta_info('has_a');
45 is_deeply [sort keys %$pn_meta], [qw/date pet/], "Person has Date and Pet";
46 }
47
48 {
49 my $pt_meta = Temp::Pet->meta_info;
50 is_deeply [keys %{$pt_meta->{has_a}}], [qw/date/], "Pet has Date";
51 is_deeply [keys %{$pt_meta->{has_many}}], [qw/owners/], "And owners";
52 }
53
54 {
55 my $pet = Temp::Person->meta_info( has_a => 'pet' );
56 is $pet->class, 'Temp::Person';
57 is $pet->foreign_class, 'Temp::Pet';
58 is $pet->accessor, 'pet';
59 is $pet->name, 'has_a';
60 }
61
62 {
63 my $owners = Temp::Pet->meta_info( has_many => 'owners' );
64
65 is_deeply $owners->args, {
66 foreign_key => 'pet',
67 mapping => [],
68 };
69 }
70
71 {
72 my $date = Temp::Pet->meta_info( has_a => 'date' );
73 is $date->class, 'Temp::DBI';
74 is $date->foreign_class, 'Time::Piece';
75 is $date->accessor, 'date';
76 is $date->args->{inflate}, $strptime_inflate;
77 }
+67
-67
t/cdbi/68-inflate_has_a.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan skip_all => "Class::Trigger and DBIx::ContextualFetch required"
7 if $@;
8
9 eval { require DateTime };
10 plan skip_all => "Need DateTime for inflation tests" if $@;
11
12 eval { require Clone };
13 plan skip_all => "Need Clone for CDBICompat inflation tests" if $@;
14 }
15
16 plan tests => 6;
17
18 use lib qw(t/lib);
19 use DBICTest;
20
21 my $schema = DBICTest->init_schema();
22
23 DBICTest::Schema::CD->load_components(qw/CDBICompat::Relationships/);
24
25 DBICTest::Schema::CD->has_a( 'year', 'DateTime',
26 inflate => sub { DateTime->new( year => shift ) },
27 deflate => sub { shift->year }
28 );
29 Class::C3->reinitialize;
30
31 # inflation test
32 my $cd = $schema->resultset("CD")->find(3);
33
34 is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
35
36 is( $cd->year->month, 1, 'inflated month ok' );
37
38 # deflate test
39 my $now = DateTime->now;
40 $cd->year( $now );
41 $cd->update;
42
43 ($cd) = $schema->resultset("CD")->search( year => $now->year );
44 is( $cd->year->year, $now->year, 'deflate ok' );
45
46 # re-test using alternate deflate syntax
47 $schema->class("CD")->has_a( 'year', 'DateTime',
48 inflate => sub { DateTime->new( year => shift ) },
49 deflate => 'year'
50 );
51
52 # inflation test
53 $cd = $schema->resultset("CD")->find(3);
54
55 is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
56
57 is( $cd->year->month, 1, 'inflated month ok' );
58
59 # deflate test
60 $now = DateTime->now;
61 $cd->year( $now );
62 $cd->update;
63
64 ($cd) = $schema->resultset("CD")->search( year => $now->year );
65 is( $cd->year->year, $now->year, 'deflate ok' );
66
0 use strict;
1 use warnings;
2 use Test::More;
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan skip_all => "Class::Trigger and DBIx::ContextualFetch required"
7 if $@;
8
9 eval { require DateTime };
10 plan skip_all => "Need DateTime for inflation tests" if $@;
11
12 eval { require Clone };
13 plan skip_all => "Need Clone for CDBICompat inflation tests" if $@;
14 }
15
16 plan tests => 6;
17
18 use lib qw(t/lib);
19 use DBICTest;
20
21 my $schema = DBICTest->init_schema();
22
23 DBICTest::Schema::CD->load_components(qw/CDBICompat::Relationships/);
24
25 DBICTest::Schema::CD->has_a( 'year', 'DateTime',
26 inflate => sub { DateTime->new( year => shift ) },
27 deflate => sub { shift->year }
28 );
29 Class::C3->reinitialize;
30
31 # inflation test
32 my $cd = $schema->resultset("CD")->find(3);
33
34 is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
35
36 is( $cd->year->month, 1, 'inflated month ok' );
37
38 # deflate test
39 my $now = DateTime->now;
40 $cd->year( $now );
41 $cd->update;
42
43 ($cd) = $schema->resultset("CD")->search( year => $now->year );
44 is( $cd->year->year, $now->year, 'deflate ok' );
45
46 # re-test using alternate deflate syntax
47 $schema->class("CD")->has_a( 'year', 'DateTime',
48 inflate => sub { DateTime->new( year => shift ) },
49 deflate => 'year'
50 );
51
52 # inflation test
53 $cd = $schema->resultset("CD")->find(3);
54
55 is( ref($cd->year), 'DateTime', 'year is a DateTime, ok' );
56
57 is( $cd->year->month, 1, 'inflated month ok' );
58
59 # deflate test
60 $now = DateTime->now;
61 $cd->year( $now );
62 $cd->update;
63
64 ($cd) = $schema->resultset("CD")->search( year => $now->year );
65 is( $cd->year->year, $now->year, 'deflate ok' );
66
+301
-301
t/cdbi/DeepAbstractSearch/01_search.t less more
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 if ($@) {
6 plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
7 next;
8 }
9
10 plan skip_all => 'needs DBD::SQLite for testing'
11 unless eval { require DBD::SQLite };
12
13 plan skip_all => 'needs Class::DBI::Plugin::DeepAbstractSearch'
14 unless eval { require Class::DBI::Plugin::DeepAbstractSearch };
15
16 plan tests => 19;
17 }
18
19 my $DB = "t/var/cdbi_testdb";
20 unlink $DB if -e $DB;
21
22 my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 0 });
23
24 package Music::DBI;
25 use base qw(DBIx::Class::CDBICompat);
26 use Class::DBI::Plugin::DeepAbstractSearch;
27 __PACKAGE__->connection(@DSN);
28
29 my $sql = <<'SQL_END';
30
31 ---------------------------------------
32 -- Artists
33 ---------------------------------------
34 CREATE TABLE artists (
35 id INTEGER NOT NULL PRIMARY KEY,
36 name VARCHAR(32)
37 );
38
39 INSERT INTO artists VALUES (1, "Willie Nelson");
40 INSERT INTO artists VALUES (2, "Patsy Cline");
41
42 ---------------------------------------
43 -- Labels
44 ---------------------------------------
45 CREATE TABLE labels (
46 id INTEGER NOT NULL PRIMARY KEY,
47 name VARCHAR(32)
48 );
49
50 INSERT INTO labels VALUES (1, "Columbia");
51 INSERT INTO labels VALUES (2, "Sony");
52 INSERT INTO labels VALUES (3, "Supraphon");
53
54 ---------------------------------------
55 -- CDs
56 ---------------------------------------
57 CREATE TABLE cds (
58 id INTEGER NOT NULL PRIMARY KEY,
59 label INTEGER,
60 artist INTEGER,
61 title VARCHAR(32),
62 year INTEGER
63 );
64 INSERT INTO cds VALUES (1, 1, 1, "Songs", 2005);
65 INSERT INTO cds VALUES (2, 2, 1, "Read Headed Stanger", 2000);
66 INSERT INTO cds VALUES (3, 1, 1, "Wanted! The Outlaws", 2004);
67 INSERT INTO cds VALUES (4, 2, 1, "The Very Best of Willie Nelson", 1999);
68
69 INSERT INTO cds VALUES (5, 1, 2, "12 Greates Hits", 1999);
70 INSERT INTO cds VALUES (6, 2, 2, "Sweet Dreams", 1995);
71 INSERT INTO cds VALUES (7, 3, 2, "The Best of Patsy Cline", 1991);
72
73 ---------------------------------------
74 -- Tracks
75 ---------------------------------------
76 CREATE TABLE tracks (
77 id INTEGER NOT NULL PRIMARY KEY,
78 cd INTEGER,
79 position INTEGER,
80 title VARCHAR(32)
81 );
82 INSERT INTO tracks VALUES (1, 1, 1, "Songs: Track 1");
83 INSERT INTO tracks VALUES (2, 1, 2, "Songs: Track 2");
84 INSERT INTO tracks VALUES (3, 1, 3, "Songs: Track 3");
85 INSERT INTO tracks VALUES (4, 1, 4, "Songs: Track 4");
86
87 INSERT INTO tracks VALUES (5, 2, 1, "Read Headed Stanger: Track 1");
88 INSERT INTO tracks VALUES (6, 2, 2, "Read Headed Stanger: Track 2");
89 INSERT INTO tracks VALUES (7, 2, 3, "Read Headed Stanger: Track 3");
90 INSERT INTO tracks VALUES (8, 2, 4, "Read Headed Stanger: Track 4");
91
92 INSERT INTO tracks VALUES (9, 3, 1, "Wanted! The Outlaws: Track 1");
93 INSERT INTO tracks VALUES (10, 3, 2, "Wanted! The Outlaws: Track 2");
94
95 INSERT INTO tracks VALUES (11, 4, 1, "The Very Best of Willie Nelson: Track 1");
96 INSERT INTO tracks VALUES (12, 4, 2, "The Very Best of Willie Nelson: Track 2");
97 INSERT INTO tracks VALUES (13, 4, 3, "The Very Best of Willie Nelson: Track 3");
98 INSERT INTO tracks VALUES (14, 4, 4, "The Very Best of Willie Nelson: Track 4");
99 INSERT INTO tracks VALUES (15, 4, 5, "The Very Best of Willie Nelson: Track 5");
100 INSERT INTO tracks VALUES (16, 4, 6, "The Very Best of Willie Nelson: Track 6");
101
102 INSERT INTO tracks VALUES (17, 5, 1, "12 Greates Hits: Track 1");
103 INSERT INTO tracks VALUES (18, 5, 2, "12 Greates Hits: Track 2");
104 INSERT INTO tracks VALUES (19, 5, 3, "12 Greates Hits: Track 3");
105 INSERT INTO tracks VALUES (20, 5, 4, "12 Greates Hits: Track 4");
106
107 INSERT INTO tracks VALUES (21, 6, 1, "Sweet Dreams: Track 1");
108 INSERT INTO tracks VALUES (22, 6, 2, "Sweet Dreams: Track 2");
109 INSERT INTO tracks VALUES (23, 6, 3, "Sweet Dreams: Track 3");
110 INSERT INTO tracks VALUES (24, 6, 4, "Sweet Dreams: Track 4");
111
112 INSERT INTO tracks VALUES (25, 7, 1, "The Best of Patsy Cline: Track 1");
113 INSERT INTO tracks VALUES (26, 7, 2, "The Best of Patsy Cline: Track 2");
114
115 SQL_END
116
117 foreach my $statement (split /;/, $sql) {
118 $statement =~ s/^\s*//gs;
119 $statement =~ s/\s*$//gs;
120 next unless $statement;
121 Music::DBI->db_Main->do($statement) or die "$@ $!";
122 }
123
124 Music::DBI->dbi_commit;
125
126 package Music::Artist;
127 use base 'Music::DBI';
128 Music::Artist->table('artists');
129 Music::Artist->columns(All => qw/id name/);
130
131
132 package Music::Label;
133 use base 'Music::DBI';
134 Music::Label->table('labels');
135 Music::Label->columns(All => qw/id name/);
136
137 package Music::CD;
138 use base 'Music::DBI';
139 Music::CD->table('cds');
140 Music::CD->columns(All => qw/id label artist title year/);
141
142
143 package Music::Track;
144 use base 'Music::DBI';
145 Music::Track->table('tracks');
146 Music::Track->columns(All => qw/id cd position title/);
147
148 Music::Artist->has_many(cds => 'Music::CD');
149 Music::Label->has_many(cds => 'Music::CD');
150 Music::CD->has_many(tracks => 'Music::Track');
151 Music::CD->has_a(artist => 'Music::Artist');
152 Music::CD->has_a(label => 'Music::Label');
153 Music::Track->has_a(cd => 'Music::CD');
154
155 package main;
156
157 {
158 my $where = { };
159 my $attr;
160 my @artists = Music::Artist->deep_search_where($where, $attr);
161 is_deeply [ sort @artists ], [ 1, 2 ], "all without order";
162 }
163
164 {
165 my $where = { };
166 my $attr = { order_by => 'name' };
167 my @artists = Music::Artist->deep_search_where($where, $attr);
168 is_deeply \@artists, [ 2, 1 ], "all with ORDER BY name";
169 }
170
171 {
172 my $where = { };
173 my $attr = { order_by => 'name DESC' };
174 my @artists = Music::Artist->deep_search_where($where, $attr);
175 is_deeply \@artists, [ 1, 2 ], "all with ORDER BY name DESC";
176 }
177
178 {
179 my $where = { name => { -like => 'Patsy Cline' }, };
180 my $attr;
181 my @artists = Music::Artist->deep_search_where($where, $attr);
182 is_deeply \@artists, [ 2 ], "simple search";
183 }
184
185 {
186 my $where = { 'artist.name' => 'Patsy Cline' };
187 my $attr = { } ;
188 my @cds = Music::CD->deep_search_where($where, $attr);
189 is_deeply [ sort @cds ], [ 5, 6, 7 ], "Patsy's CDs";
190 }
191
192 {
193 my $where = { 'artist.name' => 'Patsy Cline' };
194 my $attr = { order_by => "title" } ;
195 my @cds = Music::CD->deep_search_where($where, $attr);
196 is_deeply [ @cds ], [ 5, 6, 7 ], "Patsy's CDs by title";
197
198 my $count = Music::CD->count_deep_search_where($where);
199 is_deeply $count, 3, "count Patsy's CDs by title";
200 }
201
202 {
203 my $where = { 'cd.title' => { -like => 'S%' }, };
204 my $attr = { order_by => "cd.title, title" } ;
205 my @cds = Music::Track->deep_search_where($where, $attr);
206 is_deeply [ @cds ], [1, 2, 3, 4, 21, 22, 23, 24 ], "Tracks from CDs whose name starts with 'S'";
207 }
208
209 {
210 my $where = {
211 'cd.artist.name' => { -like => 'W%' },
212 'cd.year' => { '>' => 2000 },
213 'position' => { '<' => 3 }
214 };
215 my $attr = { order_by => "cd.title DESC, title" } ;
216 my @cds = Music::Track->deep_search_where($where, $attr);
217 is_deeply [ @cds ], [ 9, 10, 1, 2 ], "First 2 tracks from W's albums after 2000 ";
218
219 my $count = Music::Track->count_deep_search_where($where);
220 is_deeply $count, 4, "Count First 2 tracks from W's albums after 2000";
221 }
222
223 {
224 my $where = {
225 'cd.artist.name' => { -like => 'W%' },
226 'cd.year' => { '>' => 2000 },
227 'position' => { '<' => 3 }
228 };
229 my $attr = { order_by => [ 'cd.title DESC' , 'title' ] } ;
230 my @cds = Music::Track->deep_search_where($where, $attr);
231 is_deeply [ @cds ], [ 9, 10, 1, 2 ], "First 2 tracks from W's albums after 2000, array ref order ";
232
233 my $count = Music::Track->count_deep_search_where($where);
234 is_deeply $count, 4, "Count First 2 tracks from W's albums after 2000, array ref order";
235 }
236
237 {
238 my $where = { 'cd.title' => [ -and => { -like => '%o%' }, { -like => '%W%' } ] };
239 my $attr = { order_by => [ 'cd.id' ] } ;
240
241 my @tracks = Music::Track->deep_search_where($where, $attr);
242 is_deeply [ @tracks ], [ 3, 3, 4, 4, 4, 4, 4, 4 ], "Tracks from CD titles containing 'o' AND 'W'";
243 }
244
245 {
246 my $where = { 'cd.year' => [ 1995, 1999 ] };
247 my $attr = { order_by => [ 'cd.id' ] } ;
248
249 my @tracks = Music::Track->deep_search_where($where, $attr);
250 is_deeply [ @tracks ], [ 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6 ],
251 "Tracks from CDs from 1995, 1999";
252 }
253
254 {
255 my $where = { 'cd.year' => { -in => [ 1995, 1999 ] } };
256 my $attr = { order_by => [ 'cd.id' ] } ;
257
258 my @tracks = Music::Track->deep_search_where($where, $attr);
259 is_deeply [ @tracks ], [ 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6 ],
260 "Tracks from CDs in 1995, 1999";
261 }
262
263 {
264 my $where = { -and => [ 'cd.year' => [ 1995, 1999 ], position => { '<=', 2 } ] };
265 my $attr = { order_by => [ 'cd.id' ] } ;
266
267 my @tracks = Music::Track->deep_search_where($where, $attr);
268 is_deeply [ @tracks ], [ 4, 4, 5, 5, 6, 6 ],
269 "First 2 tracks Tracks from CDs from 1995, 1999";
270 }
271
272 {
273 my $where = { -and => [ 'cd.year' => { -in => [ 1995, 1999 ] }, position => { '<=', 2 } ] };
274 my $attr = { order_by => [ 'cd.id' ] } ;
275
276 my @tracks = Music::Track->deep_search_where($where, $attr);
277 is_deeply [ @tracks ], [ 4, 4, 5, 5, 6, 6 ],
278 "First 2 tracks Tracks from CDs in 1995, 1999";
279 }
280
281 {
282 my $where = { 'label.name' => { -in => [ 'Sony', 'Supraphon', 'Bogus' ] } };
283 my $attr = { order_by => [ 'id' ] } ;
284
285 my @cds = Music::CD->deep_search_where($where, $attr);
286 is_deeply [ @cds ], [ 2, 4, 6, 7 ],
287 "CDs from Sony or Supraphon";
288 }
289
290 {
291 my $where = { 'label.name' => [ 'Sony', 'Supraphon', 'Bogus' ] };
292 my $attr = { order_by => [ 'id' ] } ;
293
294 my @cds = Music::CD->deep_search_where($where, $attr);
295 is_deeply [ @cds ], [ 2, 4, 6, 7 ],
296 "CDs from Sony or Supraphon";
297 }
298
299 END { unlink $DB if -e $DB }
300
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 if ($@) {
6 plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
7 next;
8 }
9
10 plan skip_all => 'needs DBD::SQLite for testing'
11 unless eval { require DBD::SQLite };
12
13 plan skip_all => 'needs Class::DBI::Plugin::DeepAbstractSearch'
14 unless eval { require Class::DBI::Plugin::DeepAbstractSearch };
15
16 plan tests => 19;
17 }
18
19 my $DB = "t/var/cdbi_testdb";
20 unlink $DB if -e $DB;
21
22 my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 0 });
23
24 package Music::DBI;
25 use base qw(DBIx::Class::CDBICompat);
26 use Class::DBI::Plugin::DeepAbstractSearch;
27 __PACKAGE__->connection(@DSN);
28
29 my $sql = <<'SQL_END';
30
31 ---------------------------------------
32 -- Artists
33 ---------------------------------------
34 CREATE TABLE artists (
35 id INTEGER NOT NULL PRIMARY KEY,
36 name VARCHAR(32)
37 );
38
39 INSERT INTO artists VALUES (1, "Willie Nelson");
40 INSERT INTO artists VALUES (2, "Patsy Cline");
41
42 ---------------------------------------
43 -- Labels
44 ---------------------------------------
45 CREATE TABLE labels (
46 id INTEGER NOT NULL PRIMARY KEY,
47 name VARCHAR(32)
48 );
49
50 INSERT INTO labels VALUES (1, "Columbia");
51 INSERT INTO labels VALUES (2, "Sony");
52 INSERT INTO labels VALUES (3, "Supraphon");
53
54 ---------------------------------------
55 -- CDs
56 ---------------------------------------
57 CREATE TABLE cds (
58 id INTEGER NOT NULL PRIMARY KEY,
59 label INTEGER,
60 artist INTEGER,
61 title VARCHAR(32),
62 year INTEGER
63 );
64 INSERT INTO cds VALUES (1, 1, 1, "Songs", 2005);
65 INSERT INTO cds VALUES (2, 2, 1, "Read Headed Stanger", 2000);
66 INSERT INTO cds VALUES (3, 1, 1, "Wanted! The Outlaws", 2004);
67 INSERT INTO cds VALUES (4, 2, 1, "The Very Best of Willie Nelson", 1999);
68
69 INSERT INTO cds VALUES (5, 1, 2, "12 Greates Hits", 1999);
70 INSERT INTO cds VALUES (6, 2, 2, "Sweet Dreams", 1995);
71 INSERT INTO cds VALUES (7, 3, 2, "The Best of Patsy Cline", 1991);
72
73 ---------------------------------------
74 -- Tracks
75 ---------------------------------------
76 CREATE TABLE tracks (
77 id INTEGER NOT NULL PRIMARY KEY,
78 cd INTEGER,
79 position INTEGER,
80 title VARCHAR(32)
81 );
82 INSERT INTO tracks VALUES (1, 1, 1, "Songs: Track 1");
83 INSERT INTO tracks VALUES (2, 1, 2, "Songs: Track 2");
84 INSERT INTO tracks VALUES (3, 1, 3, "Songs: Track 3");
85 INSERT INTO tracks VALUES (4, 1, 4, "Songs: Track 4");
86
87 INSERT INTO tracks VALUES (5, 2, 1, "Read Headed Stanger: Track 1");
88 INSERT INTO tracks VALUES (6, 2, 2, "Read Headed Stanger: Track 2");
89 INSERT INTO tracks VALUES (7, 2, 3, "Read Headed Stanger: Track 3");
90 INSERT INTO tracks VALUES (8, 2, 4, "Read Headed Stanger: Track 4");
91
92 INSERT INTO tracks VALUES (9, 3, 1, "Wanted! The Outlaws: Track 1");
93 INSERT INTO tracks VALUES (10, 3, 2, "Wanted! The Outlaws: Track 2");
94
95 INSERT INTO tracks VALUES (11, 4, 1, "The Very Best of Willie Nelson: Track 1");
96 INSERT INTO tracks VALUES (12, 4, 2, "The Very Best of Willie Nelson: Track 2");
97 INSERT INTO tracks VALUES (13, 4, 3, "The Very Best of Willie Nelson: Track 3");
98 INSERT INTO tracks VALUES (14, 4, 4, "The Very Best of Willie Nelson: Track 4");
99 INSERT INTO tracks VALUES (15, 4, 5, "The Very Best of Willie Nelson: Track 5");
100 INSERT INTO tracks VALUES (16, 4, 6, "The Very Best of Willie Nelson: Track 6");
101
102 INSERT INTO tracks VALUES (17, 5, 1, "12 Greates Hits: Track 1");
103 INSERT INTO tracks VALUES (18, 5, 2, "12 Greates Hits: Track 2");
104 INSERT INTO tracks VALUES (19, 5, 3, "12 Greates Hits: Track 3");
105 INSERT INTO tracks VALUES (20, 5, 4, "12 Greates Hits: Track 4");
106
107 INSERT INTO tracks VALUES (21, 6, 1, "Sweet Dreams: Track 1");
108 INSERT INTO tracks VALUES (22, 6, 2, "Sweet Dreams: Track 2");
109 INSERT INTO tracks VALUES (23, 6, 3, "Sweet Dreams: Track 3");
110 INSERT INTO tracks VALUES (24, 6, 4, "Sweet Dreams: Track 4");
111
112 INSERT INTO tracks VALUES (25, 7, 1, "The Best of Patsy Cline: Track 1");
113 INSERT INTO tracks VALUES (26, 7, 2, "The Best of Patsy Cline: Track 2");
114
115 SQL_END
116
117 foreach my $statement (split /;/, $sql) {
118 $statement =~ s/^\s*//gs;
119 $statement =~ s/\s*$//gs;
120 next unless $statement;
121 Music::DBI->db_Main->do($statement) or die "$@ $!";
122 }
123
124 Music::DBI->dbi_commit;
125
126 package Music::Artist;
127 use base 'Music::DBI';
128 Music::Artist->table('artists');
129 Music::Artist->columns(All => qw/id name/);
130
131
132 package Music::Label;
133 use base 'Music::DBI';
134 Music::Label->table('labels');
135 Music::Label->columns(All => qw/id name/);
136
137 package Music::CD;
138 use base 'Music::DBI';
139 Music::CD->table('cds');
140 Music::CD->columns(All => qw/id label artist title year/);
141
142
143 package Music::Track;
144 use base 'Music::DBI';
145 Music::Track->table('tracks');
146 Music::Track->columns(All => qw/id cd position title/);
147
148 Music::Artist->has_many(cds => 'Music::CD');
149 Music::Label->has_many(cds => 'Music::CD');
150 Music::CD->has_many(tracks => 'Music::Track');
151 Music::CD->has_a(artist => 'Music::Artist');
152 Music::CD->has_a(label => 'Music::Label');
153 Music::Track->has_a(cd => 'Music::CD');
154
155 package main;
156
157 {
158 my $where = { };
159 my $attr;
160 my @artists = Music::Artist->deep_search_where($where, $attr);
161 is_deeply [ sort @artists ], [ 1, 2 ], "all without order";
162 }
163
164 {
165 my $where = { };
166 my $attr = { order_by => 'name' };
167 my @artists = Music::Artist->deep_search_where($where, $attr);
168 is_deeply \@artists, [ 2, 1 ], "all with ORDER BY name";
169 }
170
171 {
172 my $where = { };
173 my $attr = { order_by => 'name DESC' };
174 my @artists = Music::Artist->deep_search_where($where, $attr);
175 is_deeply \@artists, [ 1, 2 ], "all with ORDER BY name DESC";
176 }
177
178 {
179 my $where = { name => { -like => 'Patsy Cline' }, };
180 my $attr;
181 my @artists = Music::Artist->deep_search_where($where, $attr);
182 is_deeply \@artists, [ 2 ], "simple search";
183 }
184
185 {
186 my $where = { 'artist.name' => 'Patsy Cline' };
187 my $attr = { } ;
188 my @cds = Music::CD->deep_search_where($where, $attr);
189 is_deeply [ sort @cds ], [ 5, 6, 7 ], "Patsy's CDs";
190 }
191
192 {
193 my $where = { 'artist.name' => 'Patsy Cline' };
194 my $attr = { order_by => "title" } ;
195 my @cds = Music::CD->deep_search_where($where, $attr);
196 is_deeply [ @cds ], [ 5, 6, 7 ], "Patsy's CDs by title";
197
198 my $count = Music::CD->count_deep_search_where($where);
199 is_deeply $count, 3, "count Patsy's CDs by title";
200 }
201
202 {
203 my $where = { 'cd.title' => { -like => 'S%' }, };
204 my $attr = { order_by => "cd.title, title" } ;
205 my @cds = Music::Track->deep_search_where($where, $attr);
206 is_deeply [ @cds ], [1, 2, 3, 4, 21, 22, 23, 24 ], "Tracks from CDs whose name starts with 'S'";
207 }
208
209 {
210 my $where = {
211 'cd.artist.name' => { -like => 'W%' },
212 'cd.year' => { '>' => 2000 },
213 'position' => { '<' => 3 }
214 };
215 my $attr = { order_by => "cd.title DESC, title" } ;
216 my @cds = Music::Track->deep_search_where($where, $attr);
217 is_deeply [ @cds ], [ 9, 10, 1, 2 ], "First 2 tracks from W's albums after 2000 ";
218
219 my $count = Music::Track->count_deep_search_where($where);
220 is_deeply $count, 4, "Count First 2 tracks from W's albums after 2000";
221 }
222
223 {
224 my $where = {
225 'cd.artist.name' => { -like => 'W%' },
226 'cd.year' => { '>' => 2000 },
227 'position' => { '<' => 3 }
228 };
229 my $attr = { order_by => [ 'cd.title DESC' , 'title' ] } ;
230 my @cds = Music::Track->deep_search_where($where, $attr);
231 is_deeply [ @cds ], [ 9, 10, 1, 2 ], "First 2 tracks from W's albums after 2000, array ref order ";
232
233 my $count = Music::Track->count_deep_search_where($where);
234 is_deeply $count, 4, "Count First 2 tracks from W's albums after 2000, array ref order";
235 }
236
237 {
238 my $where = { 'cd.title' => [ -and => { -like => '%o%' }, { -like => '%W%' } ] };
239 my $attr = { order_by => [ 'cd.id' ] } ;
240
241 my @tracks = Music::Track->deep_search_where($where, $attr);
242 is_deeply [ @tracks ], [ 3, 3, 4, 4, 4, 4, 4, 4 ], "Tracks from CD titles containing 'o' AND 'W'";
243 }
244
245 {
246 my $where = { 'cd.year' => [ 1995, 1999 ] };
247 my $attr = { order_by => [ 'cd.id' ] } ;
248
249 my @tracks = Music::Track->deep_search_where($where, $attr);
250 is_deeply [ @tracks ], [ 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6 ],
251 "Tracks from CDs from 1995, 1999";
252 }
253
254 {
255 my $where = { 'cd.year' => { -in => [ 1995, 1999 ] } };
256 my $attr = { order_by => [ 'cd.id' ] } ;
257
258 my @tracks = Music::Track->deep_search_where($where, $attr);
259 is_deeply [ @tracks ], [ 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 6, 6 ],
260 "Tracks from CDs in 1995, 1999";
261 }
262
263 {
264 my $where = { -and => [ 'cd.year' => [ 1995, 1999 ], position => { '<=', 2 } ] };
265 my $attr = { order_by => [ 'cd.id' ] } ;
266
267 my @tracks = Music::Track->deep_search_where($where, $attr);
268 is_deeply [ @tracks ], [ 4, 4, 5, 5, 6, 6 ],
269 "First 2 tracks Tracks from CDs from 1995, 1999";
270 }
271
272 {
273 my $where = { -and => [ 'cd.year' => { -in => [ 1995, 1999 ] }, position => { '<=', 2 } ] };
274 my $attr = { order_by => [ 'cd.id' ] } ;
275
276 my @tracks = Music::Track->deep_search_where($where, $attr);
277 is_deeply [ @tracks ], [ 4, 4, 5, 5, 6, 6 ],
278 "First 2 tracks Tracks from CDs in 1995, 1999";
279 }
280
281 {
282 my $where = { 'label.name' => { -in => [ 'Sony', 'Supraphon', 'Bogus' ] } };
283 my $attr = { order_by => [ 'id' ] } ;
284
285 my @cds = Music::CD->deep_search_where($where, $attr);
286 is_deeply [ @cds ], [ 2, 4, 6, 7 ],
287 "CDs from Sony or Supraphon";
288 }
289
290 {
291 my $where = { 'label.name' => [ 'Sony', 'Supraphon', 'Bogus' ] };
292 my $attr = { order_by => [ 'id' ] } ;
293
294 my @cds = Music::CD->deep_search_where($where, $attr);
295 is_deeply [ @cds ], [ 2, 4, 6, 7 ],
296 "CDs from Sony or Supraphon";
297 }
298
299 END { unlink $DB if -e $DB }
300
+103
-103
t/cdbi/columns_as_hashes.t less more
0 use strict;
1 use Test::More;
2 use Test::Warn;
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
7 : ('no_plan');
8 }
9
10 use lib 't/cdbi/testlib';
11 use Film;
12
13 my $waves = Film->insert({
14 Title => "Breaking the Waves",
15 Director => 'Lars von Trier',
16 Rating => 'R'
17 });
18
19 local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 0;
20
21 {
22 local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 1;
23
24 warnings_like {
25 my $rating = $waves->{rating};
26 $waves->Rating("PG");
27 is $rating, "R", 'evaluation of column value is not deferred';
28 } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at \Q$0};
29
30 warnings_like {
31 is $waves->{title}, $waves->Title, "columns can be accessed as hashes";
32 } qr{^Column 'title' of 'Film/$waves' was fetched as a hash at\b};
33
34 $waves->Rating("G");
35
36 warnings_like {
37 is $waves->{rating}, "G", "updating via the accessor updates the hash";
38 } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at\b};
39
40
41 warnings_like {
42 $waves->{rating} = "PG";
43 } qr{^Column 'rating' of 'Film/$waves' was stored as a hash at\b};
44
45 $waves->update;
46 my @films = Film->search( Rating => "PG", Title => "Breaking the Waves" );
47 is @films, 1, "column updated as hash was saved";
48 }
49
50 warning_is {
51 $waves->{rating}
52 } '', 'DBIC_CDBICOMPAT_HASH_WARN controls warnings';
53
54
55 {
56 $waves->rating("R");
57 $waves->update;
58
59 no warnings 'redefine';
60 local *Film::rating = sub {
61 return "wibble";
62 };
63
64 is $waves->{rating}, "R";
65 }
66
67
68 {
69 no warnings 'redefine';
70 no warnings 'once';
71 local *Actor::accessor_name_for = sub {
72 my($class, $col) = @_;
73 return "movie" if lc $col eq "film";
74 return $col;
75 };
76
77 require Actor;
78 Actor->has_a( film => "Film" );
79
80 my $actor = Actor->insert({
81 name => 'Emily Watson',
82 film => $waves,
83 });
84
85 ok !eval { $actor->film };
86 is $actor->{film}->id, $waves->id,
87 'hash access still works despite lack of accessor';
88 }
89
90
91 # Emulate that Class::DBI inflates immediately
92 SKIP: {
93 skip "Need MySQL to run this test", 3 unless eval { require MyFoo };
94
95 my $foo = MyFoo->insert({
96 name => 'Whatever',
97 tdate => '1949-02-01',
98 });
99 isa_ok $foo, 'MyFoo';
100
101 isa_ok $foo->{tdate}, 'Date::Simple';
102 is $foo->{tdate}->year, 1949;
0 use strict;
1 use Test::More;
2 use Test::Warn;
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
7 : ('no_plan');
8 }
9
10 use lib 't/cdbi/testlib';
11 use Film;
12
13 my $waves = Film->insert({
14 Title => "Breaking the Waves",
15 Director => 'Lars von Trier',
16 Rating => 'R'
17 });
18
19 local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 0;
20
21 {
22 local $ENV{DBIC_CDBICOMPAT_HASH_WARN} = 1;
23
24 warnings_like {
25 my $rating = $waves->{rating};
26 $waves->Rating("PG");
27 is $rating, "R", 'evaluation of column value is not deferred';
28 } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at \Q$0};
29
30 warnings_like {
31 is $waves->{title}, $waves->Title, "columns can be accessed as hashes";
32 } qr{^Column 'title' of 'Film/$waves' was fetched as a hash at\b};
33
34 $waves->Rating("G");
35
36 warnings_like {
37 is $waves->{rating}, "G", "updating via the accessor updates the hash";
38 } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at\b};
39
40
41 warnings_like {
42 $waves->{rating} = "PG";
43 } qr{^Column 'rating' of 'Film/$waves' was stored as a hash at\b};
44
45 $waves->update;
46 my @films = Film->search( Rating => "PG", Title => "Breaking the Waves" );
47 is @films, 1, "column updated as hash was saved";
48 }
49
50 warning_is {
51 $waves->{rating}
52 } '', 'DBIC_CDBICOMPAT_HASH_WARN controls warnings';
53
54
55 {
56 $waves->rating("R");
57 $waves->update;
58
59 no warnings 'redefine';
60 local *Film::rating = sub {
61 return "wibble";
62 };
63
64 is $waves->{rating}, "R";
65 }
66
67
68 {
69 no warnings 'redefine';
70 no warnings 'once';
71 local *Actor::accessor_name_for = sub {
72 my($class, $col) = @_;
73 return "movie" if lc $col eq "film";
74 return $col;
75 };
76
77 require Actor;
78 Actor->has_a( film => "Film" );
79
80 my $actor = Actor->insert({
81 name => 'Emily Watson',
82 film => $waves,
83 });
84
85 ok !eval { $actor->film };
86 is $actor->{film}->id, $waves->id,
87 'hash access still works despite lack of accessor';
88 }
89
90
91 # Emulate that Class::DBI inflates immediately
92 SKIP: {
93 skip "Need MySQL to run this test", 3 unless eval { require MyFoo };
94
95 my $foo = MyFoo->insert({
96 name => 'Whatever',
97 tdate => '1949-02-01',
98 });
99 isa_ok $foo, 'MyFoo';
100
101 isa_ok $foo->{tdate}, 'Date::Simple';
102 is $foo->{tdate}->year, 1949;
103103 }⏎
+33
-33
t/cdbi/columns_dont_override_custom_accessors.t less more
0 use strict;
1 use Test::More;
2 use lib 't/cdbi/testlib';
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
7 : (tests=> 5);
8 }
9
10 {
11 package Thing;
12
13 use base 'DBIC::Test::SQLite';
14
15 Thing->columns(TEMP => qw[foo bar]);
16 Thing->columns(All => qw[thing_id yarrow flower]);
17 sub foo { 42 }
18 sub yarrow { "hock" }
19 }
20
21 is_deeply( [sort Thing->columns("TEMP")],
22 [sort qw(foo bar)],
23 "TEMP columns set"
24 );
25 my $thing = Thing->construct(
26 { thing_id => 23, foo => "this", bar => "that" }
27 );
28
29 is( $thing->id, 23 );
30 is( $thing->yarrow, "hock", 'custom accessor not overwritten by column' );
31 is( $thing->foo, 42, 'custom routine not overwritten by temp column' );
32 is( $thing->bar, "that", 'temp column accessor generated' );
0 use strict;
1 use Test::More;
2 use lib 't/cdbi/testlib';
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
7 : (tests=> 5);
8 }
9
10 {
11 package Thing;
12
13 use base 'DBIC::Test::SQLite';
14
15 Thing->columns(TEMP => qw[foo bar]);
16 Thing->columns(All => qw[thing_id yarrow flower]);
17 sub foo { 42 }
18 sub yarrow { "hock" }
19 }
20
21 is_deeply( [sort Thing->columns("TEMP")],
22 [sort qw(foo bar)],
23 "TEMP columns set"
24 );
25 my $thing = Thing->construct(
26 { thing_id => 23, foo => "this", bar => "that" }
27 );
28
29 is( $thing->id, 23 );
30 is( $thing->yarrow, "hock", 'custom accessor not overwritten by column' );
31 is( $thing->foo, 42, 'custom routine not overwritten by temp column' );
32 is( $thing->bar, "that", 'temp column accessor generated' );
+43
-43
t/cdbi/construct.t less more
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
6 : (tests=> 5);
7 }
8
9 INIT {
10 use lib 't/cdbi/testlib';
11 use Film;
12 }
13
14 {
15 Film->insert({
16 Title => "Breaking the Waves",
17 Director => 'Lars von Trier',
18 Rating => 'R'
19 });
20
21 my $film = Film->construct({
22 Title => "Breaking the Waves",
23 Director => 'Lars von Trier',
24 });
25
26 isa_ok $film, "Film";
27 is $film->title, "Breaking the Waves";
28 is $film->director, "Lars von Trier";
29 is $film->rating, "R",
30 "constructed objects can get missing data from the db";
31 }
32
33 {
34 package Foo;
35 use base qw(Film);
36 Foo->columns( TEMP => qw(temp_thing) );
37 my $film = Foo->construct({
38 temp_thing => 23
39 });
40
41 ::is $film->temp_thing, 23, "construct sets temp columns";
42 }
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
6 : (tests=> 5);
7 }
8
9 INIT {
10 use lib 't/cdbi/testlib';
11 use Film;
12 }
13
14 {
15 Film->insert({
16 Title => "Breaking the Waves",
17 Director => 'Lars von Trier',
18 Rating => 'R'
19 });
20
21 my $film = Film->construct({
22 Title => "Breaking the Waves",
23 Director => 'Lars von Trier',
24 });
25
26 isa_ok $film, "Film";
27 is $film->title, "Breaking the Waves";
28 is $film->director, "Lars von Trier";
29 is $film->rating, "R",
30 "constructed objects can get missing data from the db";
31 }
32
33 {
34 package Foo;
35 use base qw(Film);
36 Foo->columns( TEMP => qw(temp_thing) );
37 my $film = Foo->construct({
38 temp_thing => 23
39 });
40
41 ::is $film->temp_thing, 23, "construct sets temp columns";
42 }
+41
-41
t/cdbi/copy.t less more
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
6 : (tests=> 4);
7 }
8
9 INIT {
10 use lib 't/cdbi/testlib';
11 }
12
13 {
14 package # hide from PAUSE
15 MyFilm;
16
17 use base 'DBIC::Test::SQLite';
18 use strict;
19
20 __PACKAGE__->set_table('Movies');
21 __PACKAGE__->columns(All => qw(id title));
22
23 sub create_sql {
24 return qq{
25 id INTEGER PRIMARY KEY AUTOINCREMENT,
26 title VARCHAR(255)
27 }
28 }
29 }
30
31 my $film = MyFilm->create({ title => "For Your Eyes Only" });
32 ok $film->id;
33
34 my $new_film = $film->copy;
35 ok $new_film->id;
36 isnt $new_film->id, $film->id, "copy() gets new primary key";
37
38 $new_film = $film->copy(42);
39 is $new_film->id, 42, "copy() with new id";
40
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
6 : (tests=> 4);
7 }
8
9 INIT {
10 use lib 't/cdbi/testlib';
11 }
12
13 {
14 package # hide from PAUSE
15 MyFilm;
16
17 use base 'DBIC::Test::SQLite';
18 use strict;
19
20 __PACKAGE__->set_table('Movies');
21 __PACKAGE__->columns(All => qw(id title));
22
23 sub create_sql {
24 return qq{
25 id INTEGER PRIMARY KEY AUTOINCREMENT,
26 title VARCHAR(255)
27 }
28 }
29 }
30
31 my $film = MyFilm->create({ title => "For Your Eyes Only" });
32 ok $film->id;
33
34 my $new_film = $film->copy;
35 ok $new_film->id;
36 isnt $new_film->id, $film->id, "copy() gets new primary key";
37
38 $new_film = $film->copy(42);
39 is $new_film->id, 42, "copy() with new id";
40
+28
-28
t/cdbi/early_column_heisenbug.t less more
0 use strict;
1
2 use Test::More;
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
7 : ('no_plan');
8 }
9
10
11 {
12 package Thing;
13 use base qw(DBIx::Class::CDBICompat);
14 }
15
16 {
17 package Stuff;
18 use base qw(DBIx::Class::CDBICompat);
19 }
20
21 # There was a bug where looking at a column group before any were
22 # set would cause them to be shared across classes.
23 is_deeply [Stuff->columns("Essential")], [];
24 Thing->columns(Essential => qw(foo bar baz));
25 is_deeply [Stuff->columns("Essential")], [];
26
27 1;
0 use strict;
1
2 use Test::More;
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
7 : ('no_plan');
8 }
9
10
11 {
12 package Thing;
13 use base qw(DBIx::Class::CDBICompat);
14 }
15
16 {
17 package Stuff;
18 use base qw(DBIx::Class::CDBICompat);
19 }
20
21 # There was a bug where looking at a column group before any were
22 # set would cause them to be shared across classes.
23 is_deeply [Stuff->columns("Essential")], [];
24 Thing->columns(Essential => qw(foo bar baz));
25 is_deeply [Stuff->columns("Essential")], [];
26
27 1;
+36
-36
t/cdbi/has_many_loads_foreign_class.t less more
0 use strict;
1 use Test::More;
2
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
7 eval "use DBD::SQLite";
8 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 3);
9 }
10
11
12 use lib 't/cdbi/testlib';
13 use Director;
14
15 # Test that has_many() will load the foreign class.
16 ok !Class::Inspector->loaded( 'Film' );
17 ok eval { Director->has_many( films => 'Film' ); 1; } || diag $@;
18
19 my $shan_hua = Director->create({
20 Name => "Shan Hua",
21 });
22
23 my $inframan = Film->create({
24 Title => "Inframan",
25 Director => "Shan Hua",
26 });
27 my $guillotine2 = Film->create({
28 Title => "Flying Guillotine 2",
29 Director => "Shan Hua",
30 });
31 my $guillotine = Film->create({
32 Title => "Master of the Flying Guillotine",
33 Director => "Yu Wang",
34 });
35
0 use strict;
1 use Test::More;
2
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
7 eval "use DBD::SQLite";
8 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 3);
9 }
10
11
12 use lib 't/cdbi/testlib';
13 use Director;
14
15 # Test that has_many() will load the foreign class.
16 ok !Class::Inspector->loaded( 'Film' );
17 ok eval { Director->has_many( films => 'Film' ); 1; } || diag $@;
18
19 my $shan_hua = Director->create({
20 Name => "Shan Hua",
21 });
22
23 my $inframan = Film->create({
24 Title => "Inframan",
25 Director => "Shan Hua",
26 });
27 my $guillotine2 = Film->create({
28 Title => "Flying Guillotine 2",
29 Director => "Shan Hua",
30 });
31 my $guillotine = Film->create({
32 Title => "Master of the Flying Guillotine",
33 Director => "Yu Wang",
34 });
35
3636 is_deeply [sort $shan_hua->films], [sort $inframan, $guillotine2];⏎
+21
-21
t/cdbi/hasa_without_loading.t less more
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
6 : (tests=> 2);
7 }
8
9 package Foo;
10
11 use base qw(DBIx::Class::CDBICompat);
12
13 eval {
14 Foo->table("foo");
15 Foo->columns(Essential => qw(foo bar));
16 #Foo->has_a( bar => "This::Does::Not::Exist::Yet" );
17 };
18 #::is $@, '';
19 ::is(Foo->table, "foo");
20 ::is_deeply [sort map lc, Foo->columns], [sort map lc, qw(foo bar)];
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
6 : (tests=> 2);
7 }
8
9 package Foo;
10
11 use base qw(DBIx::Class::CDBICompat);
12
13 eval {
14 Foo->table("foo");
15 Foo->columns(Essential => qw(foo bar));
16 #Foo->has_a( bar => "This::Does::Not::Exist::Yet" );
17 };
18 #::is $@, '';
19 ::is(Foo->table, "foo");
20 ::is_deeply [sort map lc, Foo->columns], [sort map lc, qw(foo bar)];
+32
-32
t/cdbi/max_min_value_of.t less more
0 use strict;
1 use Test::More;
2
3 #----------------------------------------------------------------------
4 # Test database failures
5 #----------------------------------------------------------------------
6
7 BEGIN {
8 eval "use DBIx::Class::CDBICompat;";
9 if ($@) {
10 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
11 next;
12 }
13 eval "use DBD::SQLite";
14 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 2);
15 }
16
17 use lib 't/cdbi/testlib';
18 use Film;
19
20 Film->create({
21 title => "Bad Taste",
22 numexplodingsheep => 10,
23 });
24
25 Film->create({
26 title => "Evil Alien Conquerers",
27 numexplodingsheep => 2,
28 });
29
30 is( Film->maximum_value_of("numexplodingsheep"), 10 );
31 is( Film->minimum_value_of("numexplodingsheep"), 2 );
0 use strict;
1 use Test::More;
2
3 #----------------------------------------------------------------------
4 # Test database failures
5 #----------------------------------------------------------------------
6
7 BEGIN {
8 eval "use DBIx::Class::CDBICompat;";
9 if ($@) {
10 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
11 next;
12 }
13 eval "use DBD::SQLite";
14 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 2);
15 }
16
17 use lib 't/cdbi/testlib';
18 use Film;
19
20 Film->create({
21 title => "Bad Taste",
22 numexplodingsheep => 10,
23 });
24
25 Film->create({
26 title => "Evil Alien Conquerers",
27 numexplodingsheep => 2,
28 });
29
30 is( Film->maximum_value_of("numexplodingsheep"), 10 );
31 is( Film->minimum_value_of("numexplodingsheep"), 2 );
+69
-69
t/cdbi/mk_group_accessors.t less more
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
6
7 eval "use DBD::SQLite";
8 plan skip_all => 'needs DBD::SQLite for testing' if $@;
9
10 plan 'no_plan';
11 }
12
13 INIT {
14 use lib 't/cdbi/testlib';
15 require Film;
16 }
17
18 sub Film::get_test {
19 my $self = shift;
20 my $key = shift;
21 $self->{get_test}++;
22 return $self->{$key};
23 }
24
25 sub Film::set_test {
26 my($self, $key, $val) = @_;
27 $self->{set_test}++;
28 return $self->{$key} = $val;
29 }
30
31
32 my $film = Film->create({ Title => "No Wolf McQuade" });
33
34 # Test mk_group_accessors() with a list of fields.
35 {
36 Film->mk_group_accessors(test => qw(foo bar));
37 $film->foo(42);
38 is $film->foo, 42;
39
40 $film->bar(23);
41 is $film->bar, 23;
42 }
43
44
45 # An explicit accessor passed to mk_group_accessors should
46 # ignore accessor/mutator_name_for.
47 sub Film::accessor_name_for {
48 my($class, $col) = @_;
49 return "hlaglagh" if $col eq "wibble";
50 return $col;
51 }
52
53 sub Film::mutator_name_for {
54 my($class, $col) = @_;
55 return "hlaglagh" if $col eq "wibble";
56 return $col;
57 }
58
59
60 # Test with a mix of fields and field specs
61 {
62 Film->mk_group_accessors(test => ("baz", [wibble_thing => "wibble"]));
63 $film->baz(42);
64 is $film->baz, 42;
65
66 $film->wibble_thing(23);
67 is $film->wibble_thing, 23;
68 }
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
6
7 eval "use DBD::SQLite";
8 plan skip_all => 'needs DBD::SQLite for testing' if $@;
9
10 plan 'no_plan';
11 }
12
13 INIT {
14 use lib 't/cdbi/testlib';
15 require Film;
16 }
17
18 sub Film::get_test {
19 my $self = shift;
20 my $key = shift;
21 $self->{get_test}++;
22 return $self->{$key};
23 }
24
25 sub Film::set_test {
26 my($self, $key, $val) = @_;
27 $self->{set_test}++;
28 return $self->{$key} = $val;
29 }
30
31
32 my $film = Film->create({ Title => "No Wolf McQuade" });
33
34 # Test mk_group_accessors() with a list of fields.
35 {
36 Film->mk_group_accessors(test => qw(foo bar));
37 $film->foo(42);
38 is $film->foo, 42;
39
40 $film->bar(23);
41 is $film->bar, 23;
42 }
43
44
45 # An explicit accessor passed to mk_group_accessors should
46 # ignore accessor/mutator_name_for.
47 sub Film::accessor_name_for {
48 my($class, $col) = @_;
49 return "hlaglagh" if $col eq "wibble";
50 return $col;
51 }
52
53 sub Film::mutator_name_for {
54 my($class, $col) = @_;
55 return "hlaglagh" if $col eq "wibble";
56 return $col;
57 }
58
59
60 # Test with a mix of fields and field specs
61 {
62 Film->mk_group_accessors(test => ("baz", [wibble_thing => "wibble"]));
63 $film->baz(42);
64 is $film->baz, 42;
65
66 $film->wibble_thing(23);
67 is $film->wibble_thing, 23;
68 }
+26
-26
t/cdbi/multi_column_set.t less more
0 use strict;
1 use Test::More;
2 use lib 't/cdbi/testlib';
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
7 : (tests=> 3);
8 }
9
10 {
11 package Thing;
12
13 use base 'DBIC::Test::SQLite';
14
15 Thing->columns(TEMP => qw[foo bar baz]);
16 Thing->columns(All => qw[some real stuff]);
17 }
18
19 my $thing = Thing->construct({ foo => 23, some => 42, baz => 99 });
20 $thing->set( foo => "wibble", some => "woosh" );
21 is $thing->foo, "wibble";
22 is $thing->some, "woosh";
23 is $thing->baz, 99;
24
25 $thing->discard_changes;
0 use strict;
1 use Test::More;
2 use lib 't/cdbi/testlib';
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
7 : (tests=> 3);
8 }
9
10 {
11 package Thing;
12
13 use base 'DBIC::Test::SQLite';
14
15 Thing->columns(TEMP => qw[foo bar baz]);
16 Thing->columns(All => qw[some real stuff]);
17 }
18
19 my $thing = Thing->construct({ foo => 23, some => 42, baz => 99 });
20 $thing->set( foo => "wibble", some => "woosh" );
21 is $thing->foo, "wibble";
22 is $thing->some, "woosh";
23 is $thing->baz, 99;
24
25 $thing->discard_changes;
+82
-82
t/cdbi/object_cache.t less more
0 use strict;
1 use Test::More;
2 $| = 1;
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 if ($@) {
7 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
8 }
9
10 eval "use DBD::SQLite";
11 plan skip_all => 'needs DBD::SQLite for testing' if $@;
12 }
13
14 INIT {
15 use lib 't/cdbi/testlib';
16 use Film;
17 }
18
19 plan skip_all => "Object cache is turned off"
20 if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
21
22 plan tests => 5;
23
24
25 ok +Film->create({
26 Title => 'This Is Spinal Tap',
27 Director => 'Rob Reiner',
28 Rating => 'R',
29 });
30
31 {
32 my $film1 = Film->retrieve( "This Is Spinal Tap" );
33 my $film2 = Film->retrieve( "This Is Spinal Tap" );
34
35 $film1->Director("Marty DiBergi");
36 is $film2->Director, "Marty DiBergi", 'retrieve returns the same object';
37
38 $film1->discard_changes;
39 }
40
41 {
42 Film->nocache(1);
43
44 my $film1 = Film->retrieve( "This Is Spinal Tap" );
45 my $film2 = Film->retrieve( "This Is Spinal Tap" );
46
47 $film1->Director("Marty DiBergi");
48 is $film2->Director, "Rob Reiner",
49 'caching turned off';
50
51 $film1->discard_changes;
52 }
53
54 {
55 Film->nocache(0);
56
57 my $film1 = Film->retrieve( "This Is Spinal Tap" );
58 my $film2 = Film->retrieve( "This Is Spinal Tap" );
59
60 $film1->Director("Marty DiBergi");
61 is $film2->Director, "Marty DiBergi",
62 'caching back on';
63
64 $film1->discard_changes;
65 }
66
67
68 {
69 Film->nocache(1);
70
71 local $Class::DBI::Weaken_Is_Available = 0;
72
73 my $film1 = Film->retrieve( "This Is Spinal Tap" );
74 my $film2 = Film->retrieve( "This Is Spinal Tap" );
75
76 $film1->Director("Marty DiBergi");
77 is $film2->Director, "Rob Reiner",
78 'CDBI::Weaken_Is_Available turns off all caching';
79
80 $film1->discard_changes;
81 }
0 use strict;
1 use Test::More;
2 $| = 1;
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 if ($@) {
7 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
8 }
9
10 eval "use DBD::SQLite";
11 plan skip_all => 'needs DBD::SQLite for testing' if $@;
12 }
13
14 INIT {
15 use lib 't/cdbi/testlib';
16 use Film;
17 }
18
19 plan skip_all => "Object cache is turned off"
20 if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex");
21
22 plan tests => 5;
23
24
25 ok +Film->create({
26 Title => 'This Is Spinal Tap',
27 Director => 'Rob Reiner',
28 Rating => 'R',
29 });
30
31 {
32 my $film1 = Film->retrieve( "This Is Spinal Tap" );
33 my $film2 = Film->retrieve( "This Is Spinal Tap" );
34
35 $film1->Director("Marty DiBergi");
36 is $film2->Director, "Marty DiBergi", 'retrieve returns the same object';
37
38 $film1->discard_changes;
39 }
40
41 {
42 Film->nocache(1);
43
44 my $film1 = Film->retrieve( "This Is Spinal Tap" );
45 my $film2 = Film->retrieve( "This Is Spinal Tap" );
46
47 $film1->Director("Marty DiBergi");
48 is $film2->Director, "Rob Reiner",
49 'caching turned off';
50
51 $film1->discard_changes;
52 }
53
54 {
55 Film->nocache(0);
56
57 my $film1 = Film->retrieve( "This Is Spinal Tap" );
58 my $film2 = Film->retrieve( "This Is Spinal Tap" );
59
60 $film1->Director("Marty DiBergi");
61 is $film2->Director, "Marty DiBergi",
62 'caching back on';
63
64 $film1->discard_changes;
65 }
66
67
68 {
69 Film->nocache(1);
70
71 local $Class::DBI::Weaken_Is_Available = 0;
72
73 my $film1 = Film->retrieve( "This Is Spinal Tap" );
74 my $film2 = Film->retrieve( "This Is Spinal Tap" );
75
76 $film1->Director("Marty DiBergi");
77 is $film2->Director, "Rob Reiner",
78 'CDBI::Weaken_Is_Available turns off all caching';
79
80 $film1->discard_changes;
81 }
+25
-25
t/cdbi/retrieve_from_sql_with_limit.t less more
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
6 : (tests=> 3);
7 }
8
9 INIT {
10 use lib 't/cdbi/testlib';
11 use Film;
12 }
13
14 for my $title ("Bad Taste", "Braindead", "Forgotten Silver") {
15 Film->insert({ Title => $title, Director => 'Peter Jackson' });
16 }
17
18 Film->insert({ Title => "Transformers", Director => "Michael Bay"});
19
20 {
21 my @films = Film->retrieve_from_sql(qq[director = "Peter Jackson" LIMIT 2]);
22 is @films, 2, "retrieve_from_sql with LIMIT";
23 is( $_->director, "Peter Jackson" ) for @films;
24 }
0 use strict;
1 use Test::More;
2
3 BEGIN {
4 eval "use DBIx::Class::CDBICompat;";
5 plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
6 : (tests=> 3);
7 }
8
9 INIT {
10 use lib 't/cdbi/testlib';
11 use Film;
12 }
13
14 for my $title ("Bad Taste", "Braindead", "Forgotten Silver") {
15 Film->insert({ Title => $title, Director => 'Peter Jackson' });
16 }
17
18 Film->insert({ Title => "Transformers", Director => "Michael Bay"});
19
20 {
21 my @films = Film->retrieve_from_sql(qq[director = "Peter Jackson" LIMIT 2]);
22 is @films, 2, "retrieve_from_sql with LIMIT";
23 is( $_->director, "Peter Jackson" ) for @films;
24 }
+33
-33
t/cdbi/set_to_undef.t less more
0 use strict;
1 use Test::More;
2 use lib 't/cdbi/testlib';
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
7 if $@;
8 plan skip_all => "DateTime required" unless eval { require DateTime };
9 plan tests => 2;
10 }
11
12
13 # Don't use Test::NoWarnings because of an unrelated DBD::SQLite warning.
14 my @warnings;
15 local $SIG{__WARN__} = sub {
16 push @warnings, @_;
17 };
18
19 {
20 package Thing;
21
22 use base 'DBIC::Test::SQLite';
23
24 Thing->columns(All => qw[thing_id this that date]);
25 }
26
27 my $thing = Thing->construct({ thing_id => 23, this => 42 });
28 $thing->set( this => undef );
29 is $thing->get( "this" ), undef, 'undef set';
30 $thing->discard_changes;
31
32 is @warnings, 0, 'no warnings';
0 use strict;
1 use Test::More;
2 use lib 't/cdbi/testlib';
3
4 BEGIN {
5 eval "use DBIx::Class::CDBICompat;";
6 plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
7 if $@;
8 plan skip_all => "DateTime required" unless eval { require DateTime };
9 plan tests => 2;
10 }
11
12
13 # Don't use Test::NoWarnings because of an unrelated DBD::SQLite warning.
14 my @warnings;
15 local $SIG{__WARN__} = sub {
16 push @warnings, @_;
17 };
18
19 {
20 package Thing;
21
22 use base 'DBIC::Test::SQLite';
23
24 Thing->columns(All => qw[thing_id this that date]);
25 }
26
27 my $thing = Thing->construct({ thing_id => 23, this => 42 });
28 $thing->set( this => undef );
29 is $thing->get( "this" ), undef, 'undef set';
30 $thing->discard_changes;
31
32 is @warnings, 0, 'no warnings';
+31
-31
t/cdbi/set_vs_DateTime.t less more
0 use strict;
1 use Test::More;
2 use Test::Exception;
3 use lib 't/cdbi/testlib';
4
5 BEGIN {
6 eval "use DBIx::Class::CDBICompat;";
7 plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
8 if $@;
9 plan skip_all => "DateTime required" unless eval { require DateTime };
10 plan tests => 1;
11 }
12
13 {
14 package Thing;
15
16 use base 'DBIC::Test::SQLite';
17
18 Thing->columns(All => qw[thing_id this that date]);
19 }
20
21 my $thing = Thing->construct({ thing_id => 23, date => "01-02-1994" });
22 my $date = DateTime->now;
23 lives_ok {
24 $thing->set( date => $date );
25 $thing->set( date => $date );
26 };
27
28
29
30 $thing->discard_changes;
0 use strict;
1 use Test::More;
2 use Test::Exception;
3 use lib 't/cdbi/testlib';
4
5 BEGIN {
6 eval "use DBIx::Class::CDBICompat;";
7 plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
8 if $@;
9 plan skip_all => "DateTime required" unless eval { require DateTime };
10 plan tests => 1;
11 }
12
13 {
14 package Thing;
15
16 use base 'DBIC::Test::SQLite';
17
18 Thing->columns(All => qw[thing_id this that date]);
19 }
20
21 my $thing = Thing->construct({ thing_id => 23, date => "01-02-1994" });
22 my $date = DateTime->now;
23 lives_ok {
24 $thing->set( date => $date );
25 $thing->set( date => $date );
26 };
27
28
29
30 $thing->discard_changes;
+73
-73
t/cdbi/sweet/08pager.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4
5 BEGIN {
6 eval "use DBIx::Class::CDBICompat;";
7 if ($@) {
8 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
9 next;
10 }
11 eval "use DBD::SQLite";
12 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 10);
13 }
14
15 use lib 't/lib';
16
17 use_ok('DBICTest');
18
19 DBICTest::Schema::CD->load_components(qw/CDBICompat CDBICompat::Pager/);
20
21 my $schema = DBICTest->init_schema(compose_connection => 1);
22
23 DBICTest::CD->result_source_instance->schema->storage($schema->storage);
24
25 my ( $pager, $it ) = DBICTest::CD->page(
26 {},
27 { order_by => 'title',
28 rows => 3,
29 page => 1 } );
30
31 cmp_ok( $pager->entries_on_this_page, '==', 3, "entries_on_this_page ok" );
32
33 cmp_ok( $pager->next_page, '==', 2, "next_page ok" );
34
35 is( $it->next->title, "Caterwaulin' Blues", "iterator->next ok" );
36
37 $it->next;
38 $it->next;
39
40 is( $it->next, undef, "next past end of page ok" );
41
42 ( $pager, $it ) = DBICTest::CD->page(
43 {},
44 { rows => 2,
45 page => 2,
46 disable_sql_paging => 1 } );
47
48 cmp_ok( $pager->total_entries, '==', 5, "disable_sql_paging total_entries ok" );
49
50 cmp_ok( $pager->previous_page, '==', 1, "disable_sql_paging previous_page ok" );
51
52 is( $it->next->title, "Caterwaulin' Blues", "disable_sql_paging iterator->next ok" );
53
54 $it->next;
55
56 is( $it->next, undef, "disable_sql_paging next past end of page ok" );
57
58 # based on a failing criteria submitted by waswas
59 ( $pager, $it ) = DBICTest::CD->page(
60 { title => [
61 -and =>
62 {
63 -like => '%bees'
64 },
65 {
66 -not_like => 'Forkful%'
67 }
68 ]
69 },
70 { rows => 5 }
71 );
72 is( $it->count, 1, "complex abstract count ok" );
0 use strict;
1 use warnings;
2
3 use Test::More;
4
5 BEGIN {
6 eval "use DBIx::Class::CDBICompat;";
7 if ($@) {
8 plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
9 next;
10 }
11 eval "use DBD::SQLite";
12 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 10);
13 }
14
15 use lib 't/lib';
16
17 use_ok('DBICTest');
18
19 DBICTest::Schema::CD->load_components(qw/CDBICompat CDBICompat::Pager/);
20
21 my $schema = DBICTest->init_schema(compose_connection => 1);
22
23 DBICTest::CD->result_source_instance->schema->storage($schema->storage);
24
25 my ( $pager, $it ) = DBICTest::CD->page(
26 {},
27 { order_by => 'title',
28 rows => 3,
29 page => 1 } );
30
31 cmp_ok( $pager->entries_on_this_page, '==', 3, "entries_on_this_page ok" );
32
33 cmp_ok( $pager->next_page, '==', 2, "next_page ok" );
34
35 is( $it->next->title, "Caterwaulin' Blues", "iterator->next ok" );
36
37 $it->next;
38 $it->next;
39
40 is( $it->next, undef, "next past end of page ok" );
41
42 ( $pager, $it ) = DBICTest::CD->page(
43 {},
44 { rows => 2,
45 page => 2,
46 disable_sql_paging => 1 } );
47
48 cmp_ok( $pager->total_entries, '==', 5, "disable_sql_paging total_entries ok" );
49
50 cmp_ok( $pager->previous_page, '==', 1, "disable_sql_paging previous_page ok" );
51
52 is( $it->next->title, "Caterwaulin' Blues", "disable_sql_paging iterator->next ok" );
53
54 $it->next;
55
56 is( $it->next, undef, "disable_sql_paging next past end of page ok" );
57
58 # based on a failing criteria submitted by waswas
59 ( $pager, $it ) = DBICTest::CD->page(
60 { title => [
61 -and =>
62 {
63 -like => '%bees'
64 },
65 {
66 -not_like => 'Forkful%'
67 }
68 ]
69 },
70 { rows => 5 }
71 );
72 is( $it->count, 1, "complex abstract count ok" );
+7
-7
t/cdbi/testlib/CDBase.pm less more
0 package # hide from PAUSE
1 CDBase;
2
3 use strict;
4 use base qw(DBIC::Test::SQLite);
5
6 1;
0 package # hide from PAUSE
1 CDBase;
2
3 use strict;
4 use base qw(DBIC::Test::SQLite);
5
6 1;
+11
-11
t/cdbi/testlib/OtherThing.pm less more
0 package OtherThing;
1 use base 'DBIC::Test::SQLite';
2
3 OtherThing->set_table("other_thing");
4 OtherThing->columns(All => qw(id));
5
6 sub create_sql {
7 return qq{
8 id INTEGER
9 };
10 }
0 package OtherThing;
1 use base 'DBIC::Test::SQLite';
2
3 OtherThing->set_table("other_thing");
4 OtherThing->columns(All => qw(id));
5
6 sub create_sql {
7 return qq{
8 id INTEGER
9 };
10 }
+14
-14
t/cdbi/testlib/Thing.pm less more
0 package Thing;
1 use base 'DBIC::Test::SQLite';
2
3 Thing->set_table("thing");
4 Thing->columns(All => qw(id that_thing));
5
6 sub create_sql {
7 return qq{
8 id INTEGER,
9 that_thing INTEGER
10 };
11 }
12
13 1;
0 package Thing;
1 use base 'DBIC::Test::SQLite';
2
3 Thing->set_table("thing");
4 Thing->columns(All => qw(id that_thing));
5
6 sub create_sql {
7 return qq{
8 id INTEGER,
9 that_thing INTEGER
10 };
11 }
12
13 1;
+42
-42
t/count/grouped_pager.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4
5 use lib qw(t/lib);
6
7 use DBICTest;
8
9 plan tests => 7;
10
11 my $schema = DBICTest->init_schema();
12
13 # add 2 extra artists
14 $schema->populate ('Artist', [
15 [qw/name/],
16 [qw/ar_1/],
17 [qw/ar_2/],
18 ]);
19
20 # add 3 extra cds to every artist
21 for my $ar ($schema->resultset ('Artist')->all) {
22 for my $cdnum (1 .. 3) {
23 $ar->create_related ('cds', {
24 title => "bogon $cdnum",
25 year => 2000 + $cdnum,
26 });
27 }
28 }
29
30 my $cds = $schema->resultset ('CD')->search ({}, { group_by => 'artist' } );
31 is ($cds->count, 5, 'Resultset collapses to 5 groups');
32
33 my ($pg1, $pg2, $pg3) = map { $cds->search_rs ({}, {rows => 2, page => $_}) } (1..3);
34
35 for ($pg1, $pg2, $pg3) {
36 is ($_->pager->total_entries, 5, 'Total count via pager correct');
37 }
38
39 is ($pg1->count, 2, 'First page has 2 groups');
40 is ($pg2->count, 2, 'Second page has 2 groups');
41 is ($pg3->count, 1, 'Third page has one group remaining');
0 use strict;
1 use warnings;
2
3 use Test::More;
4
5 use lib qw(t/lib);
6
7 use DBICTest;
8
9 plan tests => 7;
10
11 my $schema = DBICTest->init_schema();
12
13 # add 2 extra artists
14 $schema->populate ('Artist', [
15 [qw/name/],
16 [qw/ar_1/],
17 [qw/ar_2/],
18 ]);
19
20 # add 3 extra cds to every artist
21 for my $ar ($schema->resultset ('Artist')->all) {
22 for my $cdnum (1 .. 3) {
23 $ar->create_related ('cds', {
24 title => "bogon $cdnum",
25 year => 2000 + $cdnum,
26 });
27 }
28 }
29
30 my $cds = $schema->resultset ('CD')->search ({}, { group_by => 'artist' } );
31 is ($cds->count, 5, 'Resultset collapses to 5 groups');
32
33 my ($pg1, $pg2, $pg3) = map { $cds->search_rs ({}, {rows => 2, page => $_}) } (1..3);
34
35 for ($pg1, $pg2, $pg3) {
36 is ($_->pager->total_entries, 5, 'Total count via pager correct');
37 }
38
39 is ($pg1->count, 2, 'First page has 2 groups');
40 is ($pg2->count, 2, 'Second page has 2 groups');
41 is ($pg3->count, 1, 'Third page has one group remaining');
+24
-24
t/count/in_subquery.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4
5 use Test::More;
6
7 plan ( tests => 1 );
8
9 use lib qw(t/lib);
10 use DBICTest;
11 use DBIC::SqlMakerTest;
12
13 my $schema = DBICTest->init_schema();
14
15 {
16 my $rs = $schema->resultset("CD")->search(
17 { 'artist.name' => 'Caterwauler McCrae' },
18 { join => [qw/artist/]}
19 );
20 my $squery = $rs->get_column('cdid')->as_query;
21 my $subsel_rs = $schema->resultset("CD")->search( { cdid => { IN => $squery } } );
22 is($subsel_rs->count, $rs->count, 'Subselect on PK got the same row count');
23 }
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4
5 use Test::More;
6
7 plan ( tests => 1 );
8
9 use lib qw(t/lib);
10 use DBICTest;
11 use DBIC::SqlMakerTest;
12
13 my $schema = DBICTest->init_schema();
14
15 {
16 my $rs = $schema->resultset("CD")->search(
17 { 'artist.name' => 'Caterwauler McCrae' },
18 { join => [qw/artist/]}
19 );
20 my $squery = $rs->get_column('cdid')->as_query;
21 my $subsel_rs = $schema->resultset("CD")->search( { cdid => { IN => $squery } } );
22 is($subsel_rs->count, $rs->count, 'Subselect on PK got the same row count');
23 }
+37
-37
t/count/joined.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4
5 use lib qw(t/lib);
6
7 use DBICTest;
8
9 plan tests => 7;
10
11 my $schema = DBICTest->init_schema();
12
13 my $cds = $schema->resultset("CD")->search({ cdid => 1 }, { join => { cd_to_producer => 'producer' } });
14 cmp_ok($cds->count, '>', 1, "extra joins explode entity count");
15
16 is (
17 $cds->search({}, { prefetch => 'cd_to_producer' })->count,
18 1,
19 "Count correct with extra joins collapsed by prefetch"
20 );
21
22 is (
23 $cds->search({}, { distinct => 1 })->count,
24 1,
25 "Count correct with requested distinct collapse of main table"
26 );
27
28 # JOIN and LEFT JOIN issues mean that we've seen problems where counted rows and fetched rows are sometimes 1 higher than they should
29 # be in the related resultset.
30 my $artist=$schema->resultset('Artist')->create({name => 'xxx'});
31 is($artist->related_resultset('cds')->count(), 0, "No CDs found for a shiny new artist");
32 is(scalar($artist->related_resultset('cds')->all()), 0, "No CDs fetched for a shiny new artist");
33
34 my $artist_rs = $schema->resultset('Artist')->search({artistid => $artist->id});
35 is($artist_rs->related_resultset('cds')->count(), 0, "No CDs counted for a shiny new artist using a resultset search");
36 is(scalar($artist_rs->related_resultset('cds')->all), 0, "No CDs fetched for a shiny new artist using a resultset search");
0 use strict;
1 use warnings;
2
3 use Test::More;
4
5 use lib qw(t/lib);
6
7 use DBICTest;
8
9 plan tests => 7;
10
11 my $schema = DBICTest->init_schema();
12
13 my $cds = $schema->resultset("CD")->search({ cdid => 1 }, { join => { cd_to_producer => 'producer' } });
14 cmp_ok($cds->count, '>', 1, "extra joins explode entity count");
15
16 is (
17 $cds->search({}, { prefetch => 'cd_to_producer' })->count,
18 1,
19 "Count correct with extra joins collapsed by prefetch"
20 );
21
22 is (
23 $cds->search({}, { distinct => 1 })->count,
24 1,
25 "Count correct with requested distinct collapse of main table"
26 );
27
28 # JOIN and LEFT JOIN issues mean that we've seen problems where counted rows and fetched rows are sometimes 1 higher than they should
29 # be in the related resultset.
30 my $artist=$schema->resultset('Artist')->create({name => 'xxx'});
31 is($artist->related_resultset('cds')->count(), 0, "No CDs found for a shiny new artist");
32 is(scalar($artist->related_resultset('cds')->all()), 0, "No CDs fetched for a shiny new artist");
33
34 my $artist_rs = $schema->resultset('Artist')->search({artistid => $artist->id});
35 is($artist_rs->related_resultset('cds')->count(), 0, "No CDs counted for a shiny new artist using a resultset search");
36 is(scalar($artist_rs->related_resultset('cds')->all), 0, "No CDs fetched for a shiny new artist using a resultset search");
+22
-22
t/delete/m2m.t less more
0 #!/usr/bin/perl -w
1
2 use strict;
3 use warnings;
4
5 use Test::More;
6 use lib qw(t/lib);
7 use DBICTest;
8
9 my $schema = DBICTest->init_schema();
10
11 plan tests => 5;
12
13 my $cd = $schema->resultset("CD")->find(2);
14 ok $cd->liner_notes;
15 ok keys %{$cd->{_relationship_data}}, "_relationship_data populated";
16
17 $cd->discard_changes;
18 ok $cd->liner_notes, 'relationships still valid after discarding changes';
19
20 ok $cd->liner_notes->delete;
21 $cd->discard_changes;
0 #!/usr/bin/perl -w
1
2 use strict;
3 use warnings;
4
5 use Test::More;
6 use lib qw(t/lib);
7 use DBICTest;
8
9 my $schema = DBICTest->init_schema();
10
11 plan tests => 5;
12
13 my $cd = $schema->resultset("CD")->find(2);
14 ok $cd->liner_notes;
15 ok keys %{$cd->{_relationship_data}}, "_relationship_data populated";
16
17 $cd->discard_changes;
18 ok $cd->liner_notes, 'relationships still valid after discarding changes';
19
20 ok $cd->liner_notes->delete;
21 $cd->discard_changes;
2222 ok !$cd->liner_notes, 'discard_changes resets relationship';⏎
+61
-61
t/delete/related.t less more
0 use Test::More;
1 use strict;
2 use warnings;
3 use lib qw(t/lib);
4 use DBICTest;
5
6 plan tests => 4;
7
8 my $schema = DBICTest->init_schema();
9
10 my $ars = $schema->resultset('Artist');
11 my $cdrs = $schema->resultset('CD');
12 my $cd2pr_rs = $schema->resultset('CD_to_Producer');
13
14 # create some custom entries
15 $ars->populate ([
16 [qw/artistid name/],
17 [qw/71 a1/],
18 [qw/72 a2/],
19 [qw/73 a3/],
20 ]);
21
22 $cdrs->populate ([
23 [qw/cdid artist title year/],
24 [qw/70 71 delete0 2005/],
25 [qw/71 72 delete1 2005/],
26 [qw/72 72 delete2 2005/],
27 [qw/73 72 delete3 2006/],
28 [qw/74 72 delete4 2007/],
29 [qw/75 73 delete5 2008/],
30 ]);
31
32 my $prod = $schema->resultset('Producer')->create ({ name => 'deleter' });
33 my $prod_cd = $cdrs->find (70);
34 my $cd2pr = $cd2pr_rs->create ({
35 producer => $prod,
36 cd => $prod_cd,
37 });
38
39 my $total_cds = $cdrs->count;
40
41 # test that delete_related w/o conditions deletes all related records only
42 $ars->search ({name => 'a3' })->search_related ('cds')->delete;
43 is ($cdrs->count, $total_cds -= 1, 'related delete ok');
44
45 my $a2_cds = $ars->search ({ name => 'a2' })->search_related ('cds');
46
47 # test that related deletion w/conditions deletes just the matched related records only
48 $a2_cds->search ({ year => 2005 })->delete;
49 is ($cdrs->count, $total_cds -= 2, 'related + condition delete ok');
50
51 # test that related deletion with limit condition works
52 $a2_cds->search ({}, { rows => 1})->delete;
53 is ($cdrs->count, $total_cds -= 1, 'related + limit delete ok');
54
55 TODO: {
56 local $TODO = 'delete_related is based on search_related which is based on search which does not understand object arguments';
57 my $cd2pr_count = $cd2pr_rs->count;
58 $prod_cd->delete_related('cd_to_producer', { producer => $prod } );
59 is ($cd2pr_rs->count, $cd2pr_count -= 1, 'm2m link deleted succesfully');
60 }
0 use Test::More;
1 use strict;
2 use warnings;
3 use lib qw(t/lib);
4 use DBICTest;
5
6 plan tests => 4;
7
8 my $schema = DBICTest->init_schema();
9
10 my $ars = $schema->resultset('Artist');
11 my $cdrs = $schema->resultset('CD');
12 my $cd2pr_rs = $schema->resultset('CD_to_Producer');
13
14 # create some custom entries
15 $ars->populate ([
16 [qw/artistid name/],
17 [qw/71 a1/],
18 [qw/72 a2/],
19 [qw/73 a3/],
20 ]);
21
22 $cdrs->populate ([
23 [qw/cdid artist title year/],
24 [qw/70 71 delete0 2005/],
25 [qw/71 72 delete1 2005/],
26 [qw/72 72 delete2 2005/],
27 [qw/73 72 delete3 2006/],
28 [qw/74 72 delete4 2007/],
29 [qw/75 73 delete5 2008/],
30 ]);
31
32 my $prod = $schema->resultset('Producer')->create ({ name => 'deleter' });
33 my $prod_cd = $cdrs->find (70);
34 my $cd2pr = $cd2pr_rs->create ({
35 producer => $prod,
36 cd => $prod_cd,
37 });
38
39 my $total_cds = $cdrs->count;
40
41 # test that delete_related w/o conditions deletes all related records only
42 $ars->search ({name => 'a3' })->search_related ('cds')->delete;
43 is ($cdrs->count, $total_cds -= 1, 'related delete ok');
44
45 my $a2_cds = $ars->search ({ name => 'a2' })->search_related ('cds');
46
47 # test that related deletion w/conditions deletes just the matched related records only
48 $a2_cds->search ({ year => 2005 })->delete;
49 is ($cdrs->count, $total_cds -= 2, 'related + condition delete ok');
50
51 # test that related deletion with limit condition works
52 $a2_cds->search ({}, { rows => 1})->delete;
53 is ($cdrs->count, $total_cds -= 1, 'related + limit delete ok');
54
55 TODO: {
56 local $TODO = 'delete_related is based on search_related which is based on search which does not understand object arguments';
57 my $cd2pr_count = $cd2pr_rs->count;
58 $prod_cd->delete_related('cd_to_producer', { producer => $prod } );
59 is ($cd2pr_rs->count, $cd2pr_count -= 1, 'm2m link deleted succesfully');
60 }
+31
-31
t/discard_changes_in_DESTROY.t less more
0 #!/usr/bin/perl -w
1
2 use strict;
3 use warnings;
4
5 use Test::More;
6 use lib qw(t/lib);
7 use DBICTest;
8
9 my $schema = DBICTest->init_schema();
10
11 plan tests => 1;
12
13 {
14 my @warnings;
15 local $SIG{__WARN__} = sub { push @warnings, @_; };
16 {
17 # Test that this doesn't cause infinite recursion.
18 local *DBICTest::Artist::DESTROY;
19 local *DBICTest::Artist::DESTROY = sub { $_[0]->discard_changes };
20
21 my $artist = $schema->resultset("Artist")->create( {
22 artistid => 10,
23 name => "artist number 10",
24 });
25
26 $artist->name("Wibble");
27
28 print "# About to call DESTROY\n";
29 }
30 is_deeply \@warnings, [];
0 #!/usr/bin/perl -w
1
2 use strict;
3 use warnings;
4
5 use Test::More;
6 use lib qw(t/lib);
7 use DBICTest;
8
9 my $schema = DBICTest->init_schema();
10
11 plan tests => 1;
12
13 {
14 my @warnings;
15 local $SIG{__WARN__} = sub { push @warnings, @_; };
16 {
17 # Test that this doesn't cause infinite recursion.
18 local *DBICTest::Artist::DESTROY;
19 local *DBICTest::Artist::DESTROY = sub { $_[0]->discard_changes };
20
21 my $artist = $schema->resultset("Artist")->create( {
22 artistid => 10,
23 name => "artist number 10",
24 });
25
26 $artist->name("Wibble");
27
28 print "# About to call DESTROY\n";
29 }
30 is_deeply \@warnings, [];
3131 }⏎
+76
-76
t/inflate/datetime.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 eval { require DateTime::Format::SQLite };
10 plan $@
11 ? ( skip_all => "Need DateTime::Format::SQLite for DT inflation tests" )
12 : ( tests => 18 )
13 ;
14
15 # inflation test
16 my $event = $schema->resultset("Event")->find(1);
17
18 isa_ok($event->starts_at, 'DateTime', 'DateTime returned');
19
20 # klunky, but makes older Test::More installs happy
21 my $starts = $event->starts_at;
22 is("$starts", '2006-04-25T22:24:33', 'Correct date/time');
23
24 TODO: {
25 local $TODO = "We can't do this yet before 0.09" if DBIx::Class->VERSION < 0.09;
26
27 ok(my $row =
28 $schema->resultset('Event')->search({ starts_at => $starts })->single);
29 is(eval { $row->id }, 1, 'DT in search');
30
31 ok($row =
32 $schema->resultset('Event')->search({ starts_at => { '>=' => $starts } })->single);
33 is(eval { $row->id }, 1, 'DT in search with condition');
34 }
35
36 # create using DateTime
37 my $created = $schema->resultset('Event')->create({
38 starts_at => DateTime->new(year=>2006, month=>6, day=>18),
39 created_on => DateTime->new(year=>2006, month=>6, day=>23)
40 });
41 my $created_start = $created->starts_at;
42
43 isa_ok($created->starts_at, 'DateTime', 'DateTime returned');
44 is("$created_start", '2006-06-18T00:00:00', 'Correct date/time');
45
46 ## timestamp field
47 isa_ok($event->created_on, 'DateTime', 'DateTime returned');
48
49 ## varchar fields
50 isa_ok($event->varchar_date, 'DateTime', 'DateTime returned');
51 isa_ok($event->varchar_datetime, 'DateTime', 'DateTime returned');
52
53 ## skip inflation field
54 isnt(ref($event->skip_inflation), 'DateTime', 'No DateTime returned for skip inflation column');
55
56 # klunky, but makes older Test::More installs happy
57 my $createo = $event->created_on;
58 is("$createo", '2006-06-22T21:00:05', 'Correct date/time');
59
60 my $created_cron = $created->created_on;
61
62 isa_ok($created->created_on, 'DateTime', 'DateTime returned');
63 is("$created_cron", '2006-06-23T00:00:00', 'Correct date/time');
64
65 ## varchar field using inflate_date => 1
66 my $varchar_date = $event->varchar_date;
67 is("$varchar_date", '2006-07-23T00:00:00', 'Correct date/time');
68
69 ## varchar field using inflate_datetime => 1
70 my $varchar_datetime = $event->varchar_datetime;
71 is("$varchar_datetime", '2006-05-22T19:05:07', 'Correct date/time');
72
73 ## skip inflation field
74 my $skip_inflation = $event->skip_inflation;
75 is ("$skip_inflation", '2006-04-21 18:04:06', 'Correct date/time');
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 eval { require DateTime::Format::SQLite };
10 plan $@
11 ? ( skip_all => "Need DateTime::Format::SQLite for DT inflation tests" )
12 : ( tests => 18 )
13 ;
14
15 # inflation test
16 my $event = $schema->resultset("Event")->find(1);
17
18 isa_ok($event->starts_at, 'DateTime', 'DateTime returned');
19
20 # klunky, but makes older Test::More installs happy
21 my $starts = $event->starts_at;
22 is("$starts", '2006-04-25T22:24:33', 'Correct date/time');
23
24 TODO: {
25 local $TODO = "We can't do this yet before 0.09" if DBIx::Class->VERSION < 0.09;
26
27 ok(my $row =
28 $schema->resultset('Event')->search({ starts_at => $starts })->single);
29 is(eval { $row->id }, 1, 'DT in search');
30
31 ok($row =
32 $schema->resultset('Event')->search({ starts_at => { '>=' => $starts } })->single);
33 is(eval { $row->id }, 1, 'DT in search with condition');
34 }
35
36 # create using DateTime
37 my $created = $schema->resultset('Event')->create({
38 starts_at => DateTime->new(year=>2006, month=>6, day=>18),
39 created_on => DateTime->new(year=>2006, month=>6, day=>23)
40 });
41 my $created_start = $created->starts_at;
42
43 isa_ok($created->starts_at, 'DateTime', 'DateTime returned');
44 is("$created_start", '2006-06-18T00:00:00', 'Correct date/time');
45
46 ## timestamp field
47 isa_ok($event->created_on, 'DateTime', 'DateTime returned');
48
49 ## varchar fields
50 isa_ok($event->varchar_date, 'DateTime', 'DateTime returned');
51 isa_ok($event->varchar_datetime, 'DateTime', 'DateTime returned');
52
53 ## skip inflation field
54 isnt(ref($event->skip_inflation), 'DateTime', 'No DateTime returned for skip inflation column');
55
56 # klunky, but makes older Test::More installs happy
57 my $createo = $event->created_on;
58 is("$createo", '2006-06-22T21:00:05', 'Correct date/time');
59
60 my $created_cron = $created->created_on;
61
62 isa_ok($created->created_on, 'DateTime', 'DateTime returned');
63 is("$created_cron", '2006-06-23T00:00:00', 'Correct date/time');
64
65 ## varchar field using inflate_date => 1
66 my $varchar_date = $event->varchar_date;
67 is("$varchar_date", '2006-07-23T00:00:00', 'Correct date/time');
68
69 ## varchar field using inflate_datetime => 1
70 my $varchar_datetime = $event->varchar_datetime;
71 is("$varchar_datetime", '2006-05-22T19:05:07', 'Correct date/time');
72
73 ## skip inflation field
74 my $skip_inflation = $event->skip_inflation;
75 is ("$skip_inflation", '2006-04-21 18:04:06', 'Correct date/time');
+28
-28
t/inflate/datetime_determine_parser.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 eval { require DateTime::Format::SQLite };
8 plan $@ ? ( skip_all => 'Requires DateTime::Format::SQLite' )
9 : ( tests => 3 );
10
11 my $schema = DBICTest->init_schema(
12 no_deploy => 1, # Deploying would cause an early rebless
13 );
14
15 is(
16 ref $schema->storage, 'DBIx::Class::Storage::DBI',
17 'Starting with generic storage'
18 );
19
20 # Calling date_time_parser should cause the storage to be reblessed,
21 # so that we can pick up datetime_parser_type from subclasses
22
23 my $parser = $schema->storage->datetime_parser();
24
25 is($parser, 'DateTime::Format::SQLite', 'Got expected storage-set datetime_parser');
26 isa_ok($schema->storage, 'DBIx::Class::Storage::DBI::SQLite', 'storage');
27
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 eval { require DateTime::Format::SQLite };
8 plan $@ ? ( skip_all => 'Requires DateTime::Format::SQLite' )
9 : ( tests => 3 );
10
11 my $schema = DBICTest->init_schema(
12 no_deploy => 1, # Deploying would cause an early rebless
13 );
14
15 is(
16 ref $schema->storage, 'DBIx::Class::Storage::DBI',
17 'Starting with generic storage'
18 );
19
20 # Calling date_time_parser should cause the storage to be reblessed,
21 # so that we can pick up datetime_parser_type from subclasses
22
23 my $parser = $schema->storage->datetime_parser();
24
25 is($parser, 'DateTime::Format::SQLite', 'Got expected storage-set datetime_parser');
26 isa_ok($schema->storage, 'DBIx::Class::Storage::DBI::SQLite', 'storage');
27
+92
-0
t/inflate/datetime_firebird.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7 use Scope::Guard ();
8
9 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_FIREBIRD_${_}" } qw/DSN USER PASS/};
10 my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_FIREBIRD_ODBC_${_}" } qw/DSN USER PASS/};
11
12 if (not ($dsn || $dsn2)) {
13 plan skip_all => <<'EOF';
14 Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN}
15 _USER and _PASS to run this test'.
16 Warning: This test drops and creates a table called 'event'";
17 EOF
18 } else {
19 eval "use DateTime; use DateTime::Format::Strptime;";
20 if ($@) {
21 plan skip_all => 'needs DateTime and DateTime::Format::Strptime for testing';
22 }
23 }
24
25 my @info = (
26 [ $dsn, $user, $pass ],
27 [ $dsn2, $user2, $pass2 ],
28 );
29
30 my $schema;
31
32 foreach my $conn_idx (0..$#info) {
33 my ($dsn, $user, $pass) = @{ $info[$conn_idx] || [] };
34
35 next unless $dsn;
36
37 $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
38 quote_char => '"',
39 name_sep => '.',
40 on_connect_call => [ 'datetime_setup' ],
41 });
42
43 my $sg = Scope::Guard->new(\&cleanup);
44
45 eval { $schema->storage->dbh->do('DROP TABLE "event"') };
46 $schema->storage->dbh->do(<<'SQL');
47 CREATE TABLE "event" (
48 "id" INT PRIMARY KEY,
49 "starts_at" DATE,
50 "created_on" TIMESTAMP
51 )
52 SQL
53 my $rs = $schema->resultset('Event');
54
55 my $dt = DateTime->now;
56 $dt->set_nanosecond($dsn =~ /odbc/i ? 0 : 555600000);
57
58 my $date_only = DateTime->new(
59 year => $dt->year, month => $dt->month, day => $dt->day
60 );
61
62 my $row;
63 ok( $row = $rs->create({
64 id => 1,
65 starts_at => $date_only,
66 created_on => $dt,
67 }));
68 ok( $row = $rs->search({ id => 1 }, { select => [qw/starts_at created_on/] })
69 ->first
70 );
71 is $row->created_on, $dt, 'TIMESTAMP as DateTime roundtrip';
72
73 cmp_ok $row->created_on->nanosecond, '==', $dt->nanosecond,
74 'fractional part of a second survived' if 0+$dt->nanosecond;
75
76 is $row->starts_at, $date_only, 'DATE as DateTime roundtrip';
77 }
78
79 done_testing;
80
81 # clean up our mess
82 sub cleanup {
83 my $dbh;
84 eval {
85 $schema->storage->disconnect; # to avoid object FOO is in use errors
86 $dbh = $schema->storage->dbh;
87 };
88 return unless $dbh;
89
90 eval { $dbh->do(qq{DROP TABLE "$_"}) } for qw/event/;
91 }
+78
-0
t/inflate/datetime_informix.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7 use Scope::Guard ();
8
9 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/};
10
11 if (not $dsn) {
12 plan skip_all => <<'EOF';
13 Set $ENV{DBICTEST_INFORMIX_DSN} _USER and _PASS to run this test'.
14 Warning: This test drops and creates a table called 'event'";
15 EOF
16 } else {
17 eval "use DateTime; use DateTime::Format::Strptime;";
18 if ($@) {
19 plan skip_all => 'needs DateTime and DateTime::Format::Strptime for testing';
20 }
21 }
22
23 my $schema;
24
25 {
26 $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
27 on_connect_call => [ 'datetime_setup' ],
28 });
29
30 my $sg = Scope::Guard->new(\&cleanup);
31
32 eval { $schema->storage->dbh->do('DROP TABLE event') };
33 $schema->storage->dbh->do(<<'SQL');
34 CREATE TABLE event (
35 id INT PRIMARY KEY,
36 starts_at DATE,
37 created_on DATETIME YEAR TO FRACTION(5)
38 );
39 SQL
40 my $rs = $schema->resultset('Event');
41
42 my $dt = DateTime->now;
43 $dt->set_nanosecond(555640000);
44
45 my $date_only = DateTime->new(
46 year => $dt->year, month => $dt->month, day => $dt->day
47 );
48
49 my $row;
50 ok( $row = $rs->create({
51 id => 1,
52 starts_at => $date_only,
53 created_on => $dt,
54 }));
55 ok( $row = $rs->search({ id => 1 }, { select => [qw/starts_at created_on/] })
56 ->first
57 );
58 is $row->created_on, $dt, 'TIMESTAMP as DateTime roundtrip';
59
60 cmp_ok $row->created_on->nanosecond, '==', $dt->nanosecond,
61 'fractional part of a second survived';
62
63 is $row->starts_at, $date_only, 'DATE as DateTime roundtrip';
64 }
65
66 done_testing;
67
68 # clean up our mess
69 sub cleanup {
70 my $dbh;
71 eval {
72 $dbh = $schema->storage->dbh;
73 };
74 return unless $dbh;
75
76 eval { $dbh->do(qq{DROP TABLE $_}) } for qw/event/;
77 }
+97
-97
t/inflate/datetime_mysql.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7 use DBICTest::Schema;
8
9 {
10 local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /extra \=\> .+? has been deprecated/ };
11 DBICTest::Schema->load_classes('EventTZ');
12 DBICTest::Schema->load_classes('EventTZDeprecated');
13 }
14
15 eval { require DateTime::Format::MySQL };
16 plan $@
17 ? ( skip_all => "Need DateTime::Format::MySQL for inflation tests")
18 : ( tests => 33 )
19 ;
20
21 my $schema = DBICTest->init_schema();
22
23 # Test "timezone" parameter
24 foreach my $tbl (qw/EventTZ EventTZDeprecated/) {
25 my $event_tz = $schema->resultset($tbl)->create({
26 starts_at => DateTime->new(year=>2007, month=>12, day=>31, time_zone => "America/Chicago" ),
27 created_on => DateTime->new(year=>2006, month=>1, day=>31,
28 hour => 13, minute => 34, second => 56, time_zone => "America/New_York" ),
29 });
30
31 is ($event_tz->starts_at->day_name, "Montag", 'Locale de_DE loaded: day_name');
32 is ($event_tz->starts_at->month_name, "Dezember", 'Locale de_DE loaded: month_name');
33 is ($event_tz->created_on->day_name, "Tuesday", 'Default locale loaded: day_name');
34 is ($event_tz->created_on->month_name, "January", 'Default locale loaded: month_name');
35
36 my $starts_at = $event_tz->starts_at;
37 is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using timezone');
38
39 my $created_on = $event_tz->created_on;
40 is("$created_on", '2006-01-31T12:34:56', 'Correct timestamp using timezone');
41 is($event_tz->created_on->time_zone->name, "America/Chicago", "Correct timezone");
42
43 my $loaded_event = $schema->resultset($tbl)->find( $event_tz->id );
44
45 isa_ok($loaded_event->starts_at, 'DateTime', 'DateTime returned');
46 $starts_at = $loaded_event->starts_at;
47 is("$starts_at", '2007-12-31T00:00:00', 'Loaded correct date/time using timezone');
48 is($starts_at->time_zone->name, 'America/Chicago', 'Correct timezone');
49
50 isa_ok($loaded_event->created_on, 'DateTime', 'DateTime returned');
51 $created_on = $loaded_event->created_on;
52 is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using timezone');
53 is($created_on->time_zone->name, 'America/Chicago', 'Correct timezone');
54
55 # Test floating timezone warning
56 # We expect one warning
57 SKIP: {
58 skip "ENV{DBIC_FLOATING_TZ_OK} was set, skipping", 1 if $ENV{DBIC_FLOATING_TZ_OK};
59 local $SIG{__WARN__} = sub {
60 like(
61 shift,
62 qr/You're using a floating timezone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/,
63 'Floating timezone warning'
64 );
65 };
66 my $event_tz_floating = $schema->resultset($tbl)->create({
67 starts_at => DateTime->new(year=>2007, month=>12, day=>31, ),
68 created_on => DateTime->new(year=>2006, month=>1, day=>31,
69 hour => 13, minute => 34, second => 56, ),
70 });
71 delete $SIG{__WARN__};
72 };
73
74 # This should fail to set
75 my $prev_str = "$created_on";
76 $loaded_event->update({ created_on => '0000-00-00' });
77 is("$created_on", $prev_str, "Don't update invalid dates");
78 }
79
80 # Test invalid DT
81 my $invalid = $schema->resultset('EventTZ')->create({
82 starts_at => '0000-00-00',
83 created_on => DateTime->now,
84 });
85
86 is( $invalid->get_column('starts_at'), '0000-00-00', "Invalid date stored" );
87 is( $invalid->starts_at, undef, "Inflate to undef" );
88
89 $invalid->created_on('0000-00-00');
90 $invalid->update;
91
92 throws_ok (
93 sub { $invalid->created_on },
94 qr/invalid date format/i,
95 "Invalid date format exception"
96 );
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7 use DBICTest::Schema;
8
9 {
10 local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /extra \=\> .+? has been deprecated/ };
11 DBICTest::Schema->load_classes('EventTZ');
12 DBICTest::Schema->load_classes('EventTZDeprecated');
13 }
14
15 eval { require DateTime::Format::MySQL };
16 plan $@
17 ? ( skip_all => "Need DateTime::Format::MySQL for inflation tests")
18 : ( tests => 33 )
19 ;
20
21 my $schema = DBICTest->init_schema();
22
23 # Test "timezone" parameter
24 foreach my $tbl (qw/EventTZ EventTZDeprecated/) {
25 my $event_tz = $schema->resultset($tbl)->create({
26 starts_at => DateTime->new(year=>2007, month=>12, day=>31, time_zone => "America/Chicago" ),
27 created_on => DateTime->new(year=>2006, month=>1, day=>31,
28 hour => 13, minute => 34, second => 56, time_zone => "America/New_York" ),
29 });
30
31 is ($event_tz->starts_at->day_name, "Montag", 'Locale de_DE loaded: day_name');
32 is ($event_tz->starts_at->month_name, "Dezember", 'Locale de_DE loaded: month_name');
33 is ($event_tz->created_on->day_name, "Tuesday", 'Default locale loaded: day_name');
34 is ($event_tz->created_on->month_name, "January", 'Default locale loaded: month_name');
35
36 my $starts_at = $event_tz->starts_at;
37 is("$starts_at", '2007-12-31T00:00:00', 'Correct date/time using timezone');
38
39 my $created_on = $event_tz->created_on;
40 is("$created_on", '2006-01-31T12:34:56', 'Correct timestamp using timezone');
41 is($event_tz->created_on->time_zone->name, "America/Chicago", "Correct timezone");
42
43 my $loaded_event = $schema->resultset($tbl)->find( $event_tz->id );
44
45 isa_ok($loaded_event->starts_at, 'DateTime', 'DateTime returned');
46 $starts_at = $loaded_event->starts_at;
47 is("$starts_at", '2007-12-31T00:00:00', 'Loaded correct date/time using timezone');
48 is($starts_at->time_zone->name, 'America/Chicago', 'Correct timezone');
49
50 isa_ok($loaded_event->created_on, 'DateTime', 'DateTime returned');
51 $created_on = $loaded_event->created_on;
52 is("$created_on", '2006-01-31T12:34:56', 'Loaded correct timestamp using timezone');
53 is($created_on->time_zone->name, 'America/Chicago', 'Correct timezone');
54
55 # Test floating timezone warning
56 # We expect one warning
57 SKIP: {
58 skip "ENV{DBIC_FLOATING_TZ_OK} was set, skipping", 1 if $ENV{DBIC_FLOATING_TZ_OK};
59 local $SIG{__WARN__} = sub {
60 like(
61 shift,
62 qr/You're using a floating timezone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/,
63 'Floating timezone warning'
64 );
65 };
66 my $event_tz_floating = $schema->resultset($tbl)->create({
67 starts_at => DateTime->new(year=>2007, month=>12, day=>31, ),
68 created_on => DateTime->new(year=>2006, month=>1, day=>31,
69 hour => 13, minute => 34, second => 56, ),
70 });
71 delete $SIG{__WARN__};
72 };
73
74 # This should fail to set
75 my $prev_str = "$created_on";
76 $loaded_event->update({ created_on => '0000-00-00' });
77 is("$created_on", $prev_str, "Don't update invalid dates");
78 }
79
80 # Test invalid DT
81 my $invalid = $schema->resultset('EventTZ')->create({
82 starts_at => '0000-00-00',
83 created_on => DateTime->now,
84 });
85
86 is( $invalid->get_column('starts_at'), '0000-00-00', "Invalid date stored" );
87 is( $invalid->starts_at, undef, "Inflate to undef" );
88
89 $invalid->created_on('0000-00-00');
90 $invalid->update;
91
92 throws_ok (
93 sub { $invalid->created_on },
94 qr/invalid date format/i,
95 "Invalid date format exception"
96 );
+103
-103
t/inflate/datetime_oracle.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
8
9 if (not ($dsn && $user && $pass)) {
10 plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test. ' .
11 'Warning: This test drops and creates a table called \'track\'';
12 }
13 else {
14 eval "use DateTime; use DateTime::Format::Oracle;";
15 if ($@) {
16 plan skip_all => 'needs DateTime and DateTime::Format::Oracle for testing';
17 }
18 else {
19 plan tests => 10;
20 }
21 }
22
23 # DateTime::Format::Oracle needs this set
24 $ENV{NLS_DATE_FORMAT} = 'DD-MON-YY';
25 $ENV{NLS_TIMESTAMP_FORMAT} = 'YYYY-MM-DD HH24:MI:SSXFF';
26 $ENV{NLS_LANG} = 'AMERICAN_AMERICA.WE8ISO8859P1';
27
28 my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
29
30 # Need to redefine the last_updated_on column
31 my $col_metadata = $schema->class('Track')->column_info('last_updated_on');
32 $schema->class('Track')->add_column( 'last_updated_on' => {
33 data_type => 'date' });
34 $schema->class('Track')->add_column( 'last_updated_at' => {
35 data_type => 'timestamp' });
36
37 my $dbh = $schema->storage->dbh;
38
39 #$dbh->do("alter session set nls_timestamp_format = 'YYYY-MM-DD HH24:MI:SSXFF'");
40
41 eval {
42 $dbh->do("DROP TABLE track");
43 };
44 $dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at TIMESTAMP, small_dt DATE)");
45
46 # insert a row to play with
47 my $new = $schema->resultset('Track')->create({ trackid => 1, cd => 1, position => 1, title => 'Track1', last_updated_on => '06-MAY-07', last_updated_at => '2009-05-03 21:17:18.5' });
48 is($new->trackid, 1, "insert sucessful");
49
50 my $track = $schema->resultset('Track')->find( 1 );
51
52 is( ref($track->last_updated_on), 'DateTime', "last_updated_on inflated ok");
53
54 is( $track->last_updated_on->month, 5, "DateTime methods work on inflated column");
55
56 #note '$track->last_updated_at => ', $track->last_updated_at;
57 is( ref($track->last_updated_at), 'DateTime', "last_updated_at inflated ok");
58
59 is( $track->last_updated_at->nanosecond, 500_000_000, "DateTime methods work with nanosecond precision");
60
61 my $dt = DateTime->now();
62 $track->last_updated_on($dt);
63 $track->last_updated_at($dt);
64 $track->update;
65
66 is( $track->last_updated_on->month, $dt->month, "deflate ok");
67 is( int $track->last_updated_at->nanosecond, int $dt->nanosecond, "deflate ok with nanosecond precision");
68
69 # test datetime_setup
70
71 $schema->storage->disconnect;
72
73 delete $ENV{NLS_DATE_FORMAT};
74 delete $ENV{NLS_TIMESTAMP_FORMAT};
75
76 $schema->connection($dsn, $user, $pass, {
77 on_connect_call => 'datetime_setup'
78 });
79
80 $dt = DateTime->now();
81
82 my $timestamp = $dt->clone;
83 $timestamp->set_nanosecond( int 500_000_000 );
84
85 $track = $schema->resultset('Track')->find( 1 );
86 $track->update({ last_updated_on => $dt, last_updated_at => $timestamp });
87
88 $track = $schema->resultset('Track')->find(1);
89
90 is( $track->last_updated_on, $dt, 'DateTime round-trip as DATE' );
91 is( $track->last_updated_at, $timestamp, 'DateTime round-trip as TIMESTAMP' );
92
93 is( int $track->last_updated_at->nanosecond, int 500_000_000,
94 'TIMESTAMP nanoseconds survived' );
95
96 # clean up our mess
97 END {
98 if($schema && ($dbh = $schema->storage->dbh)) {
99 $dbh->do("DROP TABLE track");
100 }
101 }
102
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
8
9 if (not ($dsn && $user && $pass)) {
10 plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test. ' .
11 'Warning: This test drops and creates a table called \'track\'';
12 }
13 else {
14 eval "use DateTime; use DateTime::Format::Oracle;";
15 if ($@) {
16 plan skip_all => 'needs DateTime and DateTime::Format::Oracle for testing';
17 }
18 else {
19 plan tests => 10;
20 }
21 }
22
23 # DateTime::Format::Oracle needs this set
24 $ENV{NLS_DATE_FORMAT} = 'DD-MON-YY';
25 $ENV{NLS_TIMESTAMP_FORMAT} = 'YYYY-MM-DD HH24:MI:SSXFF';
26 $ENV{NLS_LANG} = 'AMERICAN_AMERICA.WE8ISO8859P1';
27
28 my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
29
30 # Need to redefine the last_updated_on column
31 my $col_metadata = $schema->class('Track')->column_info('last_updated_on');
32 $schema->class('Track')->add_column( 'last_updated_on' => {
33 data_type => 'date' });
34 $schema->class('Track')->add_column( 'last_updated_at' => {
35 data_type => 'timestamp' });
36
37 my $dbh = $schema->storage->dbh;
38
39 #$dbh->do("alter session set nls_timestamp_format = 'YYYY-MM-DD HH24:MI:SSXFF'");
40
41 eval {
42 $dbh->do("DROP TABLE track");
43 };
44 $dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at TIMESTAMP, small_dt DATE)");
45
46 # insert a row to play with
47 my $new = $schema->resultset('Track')->create({ trackid => 1, cd => 1, position => 1, title => 'Track1', last_updated_on => '06-MAY-07', last_updated_at => '2009-05-03 21:17:18.5' });
48 is($new->trackid, 1, "insert sucessful");
49
50 my $track = $schema->resultset('Track')->find( 1 );
51
52 is( ref($track->last_updated_on), 'DateTime', "last_updated_on inflated ok");
53
54 is( $track->last_updated_on->month, 5, "DateTime methods work on inflated column");
55
56 #note '$track->last_updated_at => ', $track->last_updated_at;
57 is( ref($track->last_updated_at), 'DateTime', "last_updated_at inflated ok");
58
59 is( $track->last_updated_at->nanosecond, 500_000_000, "DateTime methods work with nanosecond precision");
60
61 my $dt = DateTime->now();
62 $track->last_updated_on($dt);
63 $track->last_updated_at($dt);
64 $track->update;
65
66 is( $track->last_updated_on->month, $dt->month, "deflate ok");
67 is( int $track->last_updated_at->nanosecond, int $dt->nanosecond, "deflate ok with nanosecond precision");
68
69 # test datetime_setup
70
71 $schema->storage->disconnect;
72
73 delete $ENV{NLS_DATE_FORMAT};
74 delete $ENV{NLS_TIMESTAMP_FORMAT};
75
76 $schema->connection($dsn, $user, $pass, {
77 on_connect_call => 'datetime_setup'
78 });
79
80 $dt = DateTime->now();
81
82 my $timestamp = $dt->clone;
83 $timestamp->set_nanosecond( int 500_000_000 );
84
85 $track = $schema->resultset('Track')->find( 1 );
86 $track->update({ last_updated_on => $dt, last_updated_at => $timestamp });
87
88 $track = $schema->resultset('Track')->find(1);
89
90 is( $track->last_updated_on, $dt, 'DateTime round-trip as DATE' );
91 is( $track->last_updated_at, $timestamp, 'DateTime round-trip as TIMESTAMP' );
92
93 is( int $track->last_updated_at->nanosecond, int 500_000_000,
94 'TIMESTAMP nanoseconds survived' );
95
96 # clean up our mess
97 END {
98 if($schema && ($dbh = $schema->storage->dbh)) {
99 $dbh->do("DROP TABLE track");
100 }
101 }
102
+40
-40
t/inflate/datetime_pg.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 {
8 local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /extra \=\> .+? has been deprecated/ };
9 DBICTest::Schema->load_classes('EventTZPg');
10 }
11
12 eval { require DateTime::Format::Pg };
13 plan $@
14 ? ( skip_all => 'Need DateTime::Format::Pg for timestamp inflation tests')
15 : ( tests => 6 )
16 ;
17
18
19 my $schema = DBICTest->init_schema();
20
21 {
22 my $event = $schema->resultset("EventTZPg")->find(1);
23 $event->update({created_on => '2009-01-15 17:00:00+00'});
24 $event->discard_changes;
25 isa_ok($event->created_on, "DateTime") or diag $event->created_on;
26 is($event->created_on->time_zone->name, "America/Chicago", "Timezone changed");
27 # Time zone difference -> -6hours
28 is($event->created_on->iso8601, "2009-01-15T11:00:00", "Time with TZ correct");
29
30 # test 'timestamp without time zone'
31 my $dt = DateTime->from_epoch(epoch => time);
32 $dt->set_nanosecond(int 500_000_000);
33 $event->update({ts_without_tz => $dt});
34 $event->discard_changes;
35 isa_ok($event->ts_without_tz, "DateTime") or diag $event->created_on;
36 is($event->ts_without_tz, $dt, 'timestamp without time zone inflation');
37 is($event->ts_without_tz->microsecond, $dt->microsecond,
38 'timestamp without time zone microseconds survived');
39 }
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 {
8 local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /extra \=\> .+? has been deprecated/ };
9 DBICTest::Schema->load_classes('EventTZPg');
10 }
11
12 eval { require DateTime::Format::Pg };
13 plan $@
14 ? ( skip_all => 'Need DateTime::Format::Pg for timestamp inflation tests')
15 : ( tests => 6 )
16 ;
17
18
19 my $schema = DBICTest->init_schema();
20
21 {
22 my $event = $schema->resultset("EventTZPg")->find(1);
23 $event->update({created_on => '2009-01-15 17:00:00+00'});
24 $event->discard_changes;
25 isa_ok($event->created_on, "DateTime") or diag $event->created_on;
26 is($event->created_on->time_zone->name, "America/Chicago", "Timezone changed");
27 # Time zone difference -> -6hours
28 is($event->created_on->iso8601, "2009-01-15T11:00:00", "Time with TZ correct");
29
30 # test 'timestamp without time zone'
31 my $dt = DateTime->from_epoch(epoch => time);
32 $dt->set_nanosecond(int 500_000_000);
33 $event->update({ts_without_tz => $dt});
34 $event->discard_changes;
35 isa_ok($event->ts_without_tz, "DateTime") or diag $event->created_on;
36 is($event->ts_without_tz, $dt, 'timestamp without time zone inflation');
37 is($event->ts_without_tz->microsecond, $dt->microsecond,
38 'timestamp without time zone microseconds survived');
39 }
+11
-2
t/inflate/file_column.t less more
00 use strict;
1 use warnings;
1 use warnings;
22
33 use Test::More;
44 use lib qw(t/lib);
5
6 # inject IC::File into the result baseclass for testing
7 BEGIN {
8 $ENV{DBIC_IC_FILE_NOWARN} = 1;
9 require DBICTest::BaseResult;
10 DBICTest::BaseResult->load_components (qw/InflateColumn::File/);
11 }
12
13
514 use DBICTest;
615 use File::Compare;
716 use Path::Class qw/file/;
817
9 my $schema = DBICTest->init_schema();
18 my $schema = DBICTest->init_schema;
1019
1120 plan tests => 10;
1221
+112
-112
t/inflate/serialize.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 my @serializers = (
10 { module => 'YAML.pm',
11 inflater => sub { YAML::Load (shift) },
12 deflater => sub { die "Expecting a reference" unless (ref $_[0]); YAML::Dump (shift) },
13 },
14 { module => 'Storable.pm',
15 inflater => sub { Storable::thaw (shift) },
16 deflater => sub { die "Expecting a reference" unless (ref $_[0]); Storable::nfreeze (shift) },
17 },
18 );
19
20
21 my $selected;
22 foreach my $serializer (@serializers) {
23 eval { require $serializer->{module} };
24 unless ($@) {
25 $selected = $serializer;
26 last;
27 }
28 }
29
30 plan (skip_all => "No suitable serializer found") unless $selected;
31
32 DBICTest::Schema::Serialized->inflate_column( 'serialized',
33 { inflate => $selected->{inflater},
34 deflate => $selected->{deflater},
35 },
36 );
37 Class::C3->reinitialize;
38
39 my $struct_hash = {
40 a => 1,
41 b => [
42 { c => 2 },
43 ],
44 d => 3,
45 };
46
47 my $struct_array = [
48 'a',
49 {
50 b => 1,
51 c => 2,
52 },
53 'd',
54 ];
55
56 my $rs = $schema->resultset('Serialized');
57 my $inflated;
58
59 #======= testing hashref serialization
60
61 my $object = $rs->create( {
62 serialized => '',
63 } );
64 ok($object->update( { serialized => $struct_hash } ), 'hashref deflation');
65 ok($inflated = $object->serialized, 'hashref inflation');
66 is_deeply($inflated, $struct_hash, 'inflated hash matches original');
67
68 $object = $rs->create( {
69 serialized => '',
70 } );
71 $object->set_inflated_column('serialized', $struct_hash);
72 is_deeply($object->serialized, $struct_hash, 'inflated hash matches original');
73
74 $object = $rs->new({});
75 $object->serialized ($struct_hash);
76 $object->insert;
77 is_deeply (
78 $rs->find ({id => $object->id})->serialized,
79 $struct_hash,
80 'new/insert works',
81 );
82
83 #====== testing arrayref serialization
84
85 ok($object->update( { serialized => $struct_array } ), 'arrayref deflation');
86 ok($inflated = $object->serialized, 'arrayref inflation');
87 is_deeply($inflated, $struct_array, 'inflated array matches original');
88
89 $object = $rs->new({});
90 $object->serialized ($struct_array);
91 $object->insert;
92 is_deeply (
93 $rs->find ({id => $object->id})->serialized,
94 $struct_array,
95 'new/insert works',
96 );
97
98 #===== make sure make_column_dirty interacts reasonably with inflation
99 $object = $rs->first;
100 $object->update ({serialized => { x => 'y'}});
101
102 $object->serialized->{x} = 'z'; # change state without notifying $object
103 ok (!$object->get_dirty_columns, 'no dirty columns yet');
104 is_deeply ($object->serialized, { x => 'z' }, 'object data correct');
105
106 $object->make_column_dirty('serialized');
107 $object->update;
108
109 is_deeply ($rs->first->serialized, { x => 'z' }, 'changes made it to the db' );
110
111 done_testing;
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 my @serializers = (
10 { module => 'YAML.pm',
11 inflater => sub { YAML::Load (shift) },
12 deflater => sub { die "Expecting a reference" unless (ref $_[0]); YAML::Dump (shift) },
13 },
14 { module => 'Storable.pm',
15 inflater => sub { Storable::thaw (shift) },
16 deflater => sub { die "Expecting a reference" unless (ref $_[0]); Storable::nfreeze (shift) },
17 },
18 );
19
20
21 my $selected;
22 foreach my $serializer (@serializers) {
23 eval { require $serializer->{module} };
24 unless ($@) {
25 $selected = $serializer;
26 last;
27 }
28 }
29
30 plan (skip_all => "No suitable serializer found") unless $selected;
31
32 DBICTest::Schema::Serialized->inflate_column( 'serialized',
33 { inflate => $selected->{inflater},
34 deflate => $selected->{deflater},
35 },
36 );
37 Class::C3->reinitialize;
38
39 my $struct_hash = {
40 a => 1,
41 b => [
42 { c => 2 },
43 ],
44 d => 3,
45 };
46
47 my $struct_array = [
48 'a',
49 {
50 b => 1,
51 c => 2,
52 },
53 'd',
54 ];
55
56 my $rs = $schema->resultset('Serialized');
57 my $inflated;
58
59 #======= testing hashref serialization
60
61 my $object = $rs->create( {
62 serialized => '',
63 } );
64 ok($object->update( { serialized => $struct_hash } ), 'hashref deflation');
65 ok($inflated = $object->serialized, 'hashref inflation');
66 is_deeply($inflated, $struct_hash, 'inflated hash matches original');
67
68 $object = $rs->create( {
69 serialized => '',
70 } );
71 $object->set_inflated_column('serialized', $struct_hash);
72 is_deeply($object->serialized, $struct_hash, 'inflated hash matches original');
73
74 $object = $rs->new({});
75 $object->serialized ($struct_hash);
76 $object->insert;
77 is_deeply (
78 $rs->find ({id => $object->id})->serialized,
79 $struct_hash,
80 'new/insert works',
81 );
82
83 #====== testing arrayref serialization
84
85 ok($object->update( { serialized => $struct_array } ), 'arrayref deflation');
86 ok($inflated = $object->serialized, 'arrayref inflation');
87 is_deeply($inflated, $struct_array, 'inflated array matches original');
88
89 $object = $rs->new({});
90 $object->serialized ($struct_array);
91 $object->insert;
92 is_deeply (
93 $rs->find ({id => $object->id})->serialized,
94 $struct_array,
95 'new/insert works',
96 );
97
98 #===== make sure make_column_dirty interacts reasonably with inflation
99 $object = $rs->first;
100 $object->update ({serialized => { x => 'y'}});
101
102 $object->serialized->{x} = 'z'; # change state without notifying $object
103 ok (!$object->get_dirty_columns, 'no dirty columns yet');
104 is_deeply ($object->serialized, { x => 'z' }, 'object data correct');
105
106 $object->make_column_dirty('serialized');
107 $object->update;
108
109 is_deeply ($rs->first->serialized, { x => 'z' }, 'changes made it to the db' );
110
111 done_testing;
+50
-50
t/lib/DBIC/DebugObj.pm less more
0 package DBIC::DebugObj;
1
2 use strict;
3 use warnings;
4
5 use Class::C3;
6
7 use base qw/DBIx::Class::Storage::Statistics Exporter Class::Accessor::Fast/;
8
9 __PACKAGE__->mk_accessors( qw/dbictest_sql_ref dbictest_bind_ref/ );
10
11
12 =head2 new(PKG, SQL_REF, BIND_REF, ...)
13
14 Creates a new instance that on subsequent queries will store
15 the generated SQL to the scalar pointed to by SQL_REF and bind
16 values to the array pointed to by BIND_REF.
17
18 =cut
19
20 sub new {
21 my $pkg = shift;
22 my $sql_ref = shift;
23 my $bind_ref = shift;
24
25 my $self = $pkg->SUPER::new(@_);
26
27 $self->debugfh(undef);
28
29 $self->dbictest_sql_ref($sql_ref);
30 $self->dbictest_bind_ref($bind_ref || []);
31
32 return $self;
33 }
34
35 sub query_start {
36 my $self = shift;
37
38 (${$self->dbictest_sql_ref}, @{$self->dbictest_bind_ref}) = @_;
39 }
40
41 sub query_end { }
42
43 sub txn_start { }
44
45 sub txn_commit { }
46
47 sub txn_rollback { }
48
49 1;
0 package DBIC::DebugObj;
1
2 use strict;
3 use warnings;
4
5 use Class::C3;
6
7 use base qw/DBIx::Class::Storage::Statistics Exporter Class::Accessor::Fast/;
8
9 __PACKAGE__->mk_accessors( qw/dbictest_sql_ref dbictest_bind_ref/ );
10
11
12 =head2 new(PKG, SQL_REF, BIND_REF, ...)
13
14 Creates a new instance that on subsequent queries will store
15 the generated SQL to the scalar pointed to by SQL_REF and bind
16 values to the array pointed to by BIND_REF.
17
18 =cut
19
20 sub new {
21 my $pkg = shift;
22 my $sql_ref = shift;
23 my $bind_ref = shift;
24
25 my $self = $pkg->SUPER::new(@_);
26
27 $self->debugfh(undef);
28
29 $self->dbictest_sql_ref($sql_ref);
30 $self->dbictest_bind_ref($bind_ref || []);
31
32 return $self;
33 }
34
35 sub query_start {
36 my $self = shift;
37
38 (${$self->dbictest_sql_ref}, @{$self->dbictest_bind_ref}) = @_;
39 }
40
41 sub query_end { }
42
43 sub txn_start { }
44
45 sub txn_commit { }
46
47 sub txn_rollback { }
48
49 1;
+165
-165
t/lib/DBIC/SqlMakerTest.pm less more
0 package DBIC::SqlMakerTest;
1
2 use strict;
3 use warnings;
4
5 use base qw/Exporter/;
6
7 use Carp;
8 use SQL::Abstract::Test;
9
10 our @EXPORT = qw/
11 is_same_sql_bind
12 is_same_sql
13 is_same_bind
14 /;
15 our @EXPORT_OK = qw/
16 eq_sql
17 eq_bind
18 eq_sql_bind
19 /;
20
21 sub is_same_sql_bind {
22 # unroll possible as_query arrayrefrefs
23 my @args;
24
25 for (1,2) {
26 my $chunk = shift @_;
27
28 if ( ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY' ) {
29 my ($sql, @bind) = @$$chunk;
30 push @args, ($sql, \@bind);
31 }
32 else {
33 push @args, $chunk, shift @_;
34 }
35
36 }
37
38 push @args, shift @_;
39
40 croak "Unexpected argument(s) supplied to is_same_sql_bind: " . join ('; ', @_)
41 if @_;
42
43 @_ = @args;
44 goto &SQL::Abstract::Test::is_same_sql_bind;
45 }
46
47 *is_same_sql = \&SQL::Abstract::Test::is_same_sql;
48 *is_same_bind = \&SQL::Abstract::Test::is_same_bind;
49 *eq_sql = \&SQL::Abstract::Test::eq_sql;
50 *eq_bind = \&SQL::Abstract::Test::eq_bind;
51 *eq_sql_bind = \&SQL::Abstract::Test::eq_sql_bind;
52
53 1;
54
55 __END__
56
57
58 =head1 NAME
59
60 DBIC::SqlMakerTest - Helper package for testing sql_maker component of DBIC
61
62 =head1 SYNOPSIS
63
64 use Test::More;
65 use DBIC::SqlMakerTest;
66
67 my ($sql, @bind) = $schema->storage->sql_maker->select(%args);
68 is_same_sql_bind(
69 $sql, \@bind,
70 $expected_sql, \@expected_bind,
71 'foo bar works'
72 );
73
74 =head1 DESCRIPTION
75
76 Exports functions that can be used to compare generated SQL and bind values.
77
78 This is a thin wrapper around L<SQL::Abstract::Test>, which makes it easier
79 to compare as_query sql/bind arrayrefrefs directly.
80
81 =head1 FUNCTIONS
82
83 =head2 is_same_sql_bind
84
85 is_same_sql_bind(
86 $given_sql, \@given_bind,
87 $expected_sql, \@expected_bind,
88 $test_msg
89 );
90
91 is_same_sql_bind(
92 $rs->as_query
93 $expected_sql, \@expected_bind,
94 $test_msg
95 );
96
97 is_same_sql_bind(
98 \[$given_sql, @given_bind],
99 $expected_sql, \@expected_bind,
100 $test_msg
101 );
102
103 Compares given and expected pairs of C<($sql, \@bind)>, and calls
104 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
105
106 =head2 is_same_sql
107
108 is_same_sql(
109 $given_sql,
110 $expected_sql,
111 $test_msg
112 );
113
114 Compares given and expected SQL statement, and calls L<Test::Builder/ok> on the
115 result, with C<$test_msg> as message.
116
117 =head2 is_same_bind
118
119 is_same_bind(
120 \@given_bind,
121 \@expected_bind,
122 $test_msg
123 );
124
125 Compares given and expected bind value lists, and calls L<Test::Builder/ok> on
126 the result, with C<$test_msg> as message.
127
128 =head2 eq_sql
129
130 my $is_same = eq_sql($given_sql, $expected_sql);
131
132 Compares the two SQL statements. Returns true IFF they are equivalent.
133
134 =head2 eq_bind
135
136 my $is_same = eq_sql(\@given_bind, \@expected_bind);
137
138 Compares two lists of bind values. Returns true IFF their values are the same.
139
140 =head2 eq_sql_bind
141
142 my $is_same = eq_sql_bind(
143 $given_sql, \@given_bind,
144 $expected_sql, \@expected_bind
145 );
146
147 Compares the two SQL statements and the two lists of bind values. Returns true
148 IFF they are equivalent and the bind values are the same.
149
150
151 =head1 SEE ALSO
152
153 L<SQL::Abstract::Test>, L<Test::More>, L<Test::Builder>.
154
155 =head1 AUTHOR
156
157 Norbert Buchmuller, <norbi@nix.hu>
158
159 =head1 COPYRIGHT AND LICENSE
160
161 Copyright 2008 by Norbert Buchmuller.
162
163 This library is free software; you can redistribute it and/or modify
164 it under the same terms as Perl itself.
0 package DBIC::SqlMakerTest;
1
2 use strict;
3 use warnings;
4
5 use base qw/Exporter/;
6
7 use Carp;
8 use SQL::Abstract::Test;
9
10 our @EXPORT = qw/
11 is_same_sql_bind
12 is_same_sql
13 is_same_bind
14 /;
15 our @EXPORT_OK = qw/
16 eq_sql
17 eq_bind
18 eq_sql_bind
19 /;
20
21 sub is_same_sql_bind {
22 # unroll possible as_query arrayrefrefs
23 my @args;
24
25 for (1,2) {
26 my $chunk = shift @_;
27
28 if ( ref $chunk eq 'REF' and ref $$chunk eq 'ARRAY' ) {
29 my ($sql, @bind) = @$$chunk;
30 push @args, ($sql, \@bind);
31 }
32 else {
33 push @args, $chunk, shift @_;
34 }
35
36 }
37
38 push @args, shift @_;
39
40 croak "Unexpected argument(s) supplied to is_same_sql_bind: " . join ('; ', @_)
41 if @_;
42
43 @_ = @args;
44 goto &SQL::Abstract::Test::is_same_sql_bind;
45 }
46
47 *is_same_sql = \&SQL::Abstract::Test::is_same_sql;
48 *is_same_bind = \&SQL::Abstract::Test::is_same_bind;
49 *eq_sql = \&SQL::Abstract::Test::eq_sql;
50 *eq_bind = \&SQL::Abstract::Test::eq_bind;
51 *eq_sql_bind = \&SQL::Abstract::Test::eq_sql_bind;
52
53 1;
54
55 __END__
56
57
58 =head1 NAME
59
60 DBIC::SqlMakerTest - Helper package for testing sql_maker component of DBIC
61
62 =head1 SYNOPSIS
63
64 use Test::More;
65 use DBIC::SqlMakerTest;
66
67 my ($sql, @bind) = $schema->storage->sql_maker->select(%args);
68 is_same_sql_bind(
69 $sql, \@bind,
70 $expected_sql, \@expected_bind,
71 'foo bar works'
72 );
73
74 =head1 DESCRIPTION
75
76 Exports functions that can be used to compare generated SQL and bind values.
77
78 This is a thin wrapper around L<SQL::Abstract::Test>, which makes it easier
79 to compare as_query sql/bind arrayrefrefs directly.
80
81 =head1 FUNCTIONS
82
83 =head2 is_same_sql_bind
84
85 is_same_sql_bind(
86 $given_sql, \@given_bind,
87 $expected_sql, \@expected_bind,
88 $test_msg
89 );
90
91 is_same_sql_bind(
92 $rs->as_query
93 $expected_sql, \@expected_bind,
94 $test_msg
95 );
96
97 is_same_sql_bind(
98 \[$given_sql, @given_bind],
99 $expected_sql, \@expected_bind,
100 $test_msg
101 );
102
103 Compares given and expected pairs of C<($sql, \@bind)>, and calls
104 L<Test::Builder/ok> on the result, with C<$test_msg> as message.
105
106 =head2 is_same_sql
107
108 is_same_sql(
109 $given_sql,
110 $expected_sql,
111 $test_msg
112 );
113
114 Compares given and expected SQL statement, and calls L<Test::Builder/ok> on the
115 result, with C<$test_msg> as message.
116
117 =head2 is_same_bind
118
119 is_same_bind(
120 \@given_bind,
121 \@expected_bind,
122 $test_msg
123 );
124
125 Compares given and expected bind value lists, and calls L<Test::Builder/ok> on
126 the result, with C<$test_msg> as message.
127
128 =head2 eq_sql
129
130 my $is_same = eq_sql($given_sql, $expected_sql);
131
132 Compares the two SQL statements. Returns true IFF they are equivalent.
133
134 =head2 eq_bind
135
136 my $is_same = eq_sql(\@given_bind, \@expected_bind);
137
138 Compares two lists of bind values. Returns true IFF their values are the same.
139
140 =head2 eq_sql_bind
141
142 my $is_same = eq_sql_bind(
143 $given_sql, \@given_bind,
144 $expected_sql, \@expected_bind
145 );
146
147 Compares the two SQL statements and the two lists of bind values. Returns true
148 IFF they are equivalent and the bind values are the same.
149
150
151 =head1 SEE ALSO
152
153 L<SQL::Abstract::Test>, L<Test::More>, L<Test::Builder>.
154
155 =head1 AUTHOR
156
157 Norbert Buchmuller, <norbi@nix.hu>
158
159 =head1 COPYRIGHT AND LICENSE
160
161 Copyright 2008 by Norbert Buchmuller.
162
163 This library is free software; you can redistribute it and/or modify
164 it under the same terms as Perl itself.
+3
-3
t/lib/DBICNSTest/RSBase.pm less more
0 package DBICNSTest::RSBase;
1 use base qw/DBIx::Class::ResultSet/;
2 1;
0 package DBICNSTest::RSBase;
1 use base qw/DBIx::Class::ResultSet/;
2 1;
+3
-3
t/lib/DBICNSTest/RSet/A.pm less more
0 package DBICNSTest::RSet::A;
1 use base qw/DBIx::Class::ResultSet/;
2 1;
0 package DBICNSTest::RSet::A;
1 use base qw/DBIx::Class::ResultSet/;
2 1;
+3
-3
t/lib/DBICNSTest/RSet/C.pm less more
0 package DBICNSTest::RSet::C;
1 use base qw/DBIx::Class::ResultSet/;
2 1;
0 package DBICNSTest::RSet::C;
1 use base qw/DBIx::Class::ResultSet/;
2 1;
+3
-3
t/lib/DBICNSTest/ResultSet/A.pm less more
0 package DBICNSTest::ResultSet::A;
1 use base qw/DBIx::Class::ResultSet/;
2 1;
0 package DBICNSTest::ResultSet::A;
1 use base qw/DBIx::Class::ResultSet/;
2 1;
+3
-3
t/lib/DBICNSTest/ResultSet/C.pm less more
0 package DBICNSTest::ResultSet::C;
1 use base qw/DBIx::Class::ResultSet/;
2 1;
0 package DBICNSTest::ResultSet::C;
1 use base qw/DBIx::Class::ResultSet/;
2 1;
+8
-8
t/lib/DBICNSTest/RtBug41083/ResultSet/Foo.pm less more
0 package DBICNSTest::RtBug41083::ResultSet::Foo;
1 use strict;
2 use warnings;
3 use base 'DBICNSTest::RtBug41083::ResultSet';
4
5 sub fooBar { 1; }
6
7 1;
0 package DBICNSTest::RtBug41083::ResultSet::Foo;
1 use strict;
2 use warnings;
3 use base 'DBICNSTest::RtBug41083::ResultSet';
4
5 sub fooBar { 1; }
6
7 1;
+5
-5
t/lib/DBICNSTest/RtBug41083/ResultSet.pm less more
0 package DBICNSTest::RtBug41083::ResultSet;
1 use strict;
2 use warnings;
3 use base 'DBIx::Class::ResultSet';
4 1;
0 package DBICNSTest::RtBug41083::ResultSet;
1 use strict;
2 use warnings;
3 use base 'DBIx::Class::ResultSet';
4 1;
+7
-7
t/lib/DBICNSTest/RtBug41083/ResultSet_A/A.pm less more
0 package DBICNSTest::RtBug41083::ResultSet_A::A;
1 use strict;
2 use warnings;
3 use base 'DBICNSTest::RtBug41083::ResultSet';
4
5 sub fooBar { 1; }
6 1;
0 package DBICNSTest::RtBug41083::ResultSet_A::A;
1 use strict;
2 use warnings;
3 use base 'DBICNSTest::RtBug41083::ResultSet';
4
5 sub fooBar { 1; }
6 1;
+5
-5
t/lib/DBICNSTest/RtBug41083/Schema/Foo/Sub.pm less more
0 package DBICNSTest::RtBug41083::Schema::Foo::Sub;
1 use strict;
2 use warnings;
3 use base 'DBICNSTest::RtBug41083::Schema::Foo';
4 1;
0 package DBICNSTest::RtBug41083::Schema::Foo::Sub;
1 use strict;
2 use warnings;
3 use base 'DBICNSTest::RtBug41083::Schema::Foo';
4 1;
+5
-5
t/lib/DBICNSTest/RtBug41083/Schema_A/A/Sub.pm less more
0 package DBICNSTest::RtBug41083::Schema_A::A::Sub;
1 use strict;
2 use warnings;
3 use base 'DBICNSTest::RtBug41083::Schema_A::A';
4 1;
0 package DBICNSTest::RtBug41083::Schema_A::A::Sub;
1 use strict;
2 use warnings;
3 use base 'DBICNSTest::RtBug41083::Schema_A::A';
4 1;
+13
-13
t/lib/DBICTest/BaseResultSet.pm less more
0 package #hide from pause
1 DBICTest::BaseResultSet;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class::ResultSet/;
7
8 sub hri_dump {
9 return shift->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' });
10 }
11
12 1;
0 package #hide from pause
1 DBICTest::BaseResultSet;
2
3 use strict;
4 use warnings;
5
6 use base qw/DBIx::Class::ResultSet/;
7
8 sub hri_dump {
9 return shift->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' });
10 }
11
12 1;
+8
-8
t/lib/DBICTest/ErrorComponent.pm less more
0 # belongs to t/run/90ensure_class_loaded.tl
1 package # hide from PAUSE
2 DBICTest::ErrorComponent;
3 use warnings;
4 use strict;
5
6 # this is missing on purpose
7 # 1;
0 # belongs to t/run/90ensure_class_loaded.tl
1 package # hide from PAUSE
2 DBICTest::ErrorComponent;
3 use warnings;
4 use strict;
5
6 # this is missing on purpose
7 # 1;
+7
-7
t/lib/DBICTest/FakeComponent.pm less more
0 # belongs to t/run/90ensure_class_loaded.tl
1 package # hide from PAUSE
2 DBICTest::FakeComponent;
3 use warnings;
4 use strict;
5
6 1;
0 # belongs to t/run/90ensure_class_loaded.tl
1 package # hide from PAUSE
2 DBICTest::FakeComponent;
3 use warnings;
4 use strict;
5
6 1;
+9
-9
t/lib/DBICTest/ForeignComponent/TestComp.pm less more
0 # belongs to t/05components.t
1 package # hide from PAUSE
2 DBICTest::ForeignComponent::TestComp;
3 use warnings;
4 use strict;
5
6 sub foreign_test_method { 1 }
7
8 1;
0 # belongs to t/05components.t
1 package # hide from PAUSE
2 DBICTest::ForeignComponent::TestComp;
3 use warnings;
4 use strict;
5
6 sub foreign_test_method { 1 }
7
8 1;
+11
-11
t/lib/DBICTest/ForeignComponent.pm less more
0 # belongs to t/05components.t
1 package # hide from PAUSE
2 DBICTest::ForeignComponent;
3 use warnings;
4 use strict;
5
6 use base qw/ DBIx::Class /;
7
8 __PACKAGE__->load_components( qw/ +DBICTest::ForeignComponent::TestComp / );
9
10 1;
0 # belongs to t/05components.t
1 package # hide from PAUSE
2 DBICTest::ForeignComponent;
3 use warnings;
4 use strict;
5
6 use base qw/ DBIx::Class /;
7
8 __PACKAGE__->load_components( qw/ +DBICTest::ForeignComponent::TestComp / );
9
10 1;
+7
-7
t/lib/DBICTest/OptionalComponent.pm less more
0 # belongs to t/run/90ensure_class_loaded.tl
1 package # hide from PAUSE
2 DBICTest::OptionalComponent;
3 use warnings;
4 use strict;
5
6 1;
0 # belongs to t/run/90ensure_class_loaded.tl
1 package # hide from PAUSE
2 DBICTest::OptionalComponent;
3 use warnings;
4 use strict;
5
6 1;
+18
-18
t/lib/DBICTest/Plain/Test.pm less more
0 package # hide from PAUSE
1 DBICTest::Plain::Test;
2
3 use base 'DBIx::Class::Core';
4
5 __PACKAGE__->table('test');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1
10 },
11 'name' => {
12 data_type => 'varchar',
13 },
14 );
15 __PACKAGE__->set_primary_key('id');
16
17 1;
0 package # hide from PAUSE
1 DBICTest::Plain::Test;
2
3 use base 'DBIx::Class::Core';
4
5 __PACKAGE__->table('test');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1
10 },
11 'name' => {
12 data_type => 'varchar',
13 },
14 );
15 __PACKAGE__->set_primary_key('id');
16
17 1;
+40
-40
t/lib/DBICTest/Plain.pm less more
0 package # hide from PAUSE
1 DBICTest::Plain;
2
3 use strict;
4 use warnings;
5 use base qw/DBIx::Class::Schema/;
6 use DBI;
7
8 my $db_file = "t/var/Plain.db";
9
10 unlink($db_file) if -e $db_file;
11 unlink($db_file . "-journal") if -e $db_file . "-journal";
12 mkdir("t/var") unless -d "t/var";
13
14 my $dsn = "dbi:SQLite:${db_file}";
15
16 __PACKAGE__->load_classes("Test");
17 my $schema = __PACKAGE__->compose_connection(
18 __PACKAGE__,
19 $dsn,
20 undef,
21 undef,
22 { AutoCommit => 1 }
23 );
24
25 my $dbh = DBI->connect($dsn);
26
27 my $sql = <<EOSQL;
28 CREATE TABLE test (
29 id INTEGER NOT NULL,
30 name VARCHAR(32) NOT NULL
31 );
32
33 INSERT INTO test (id, name) VALUES (1, 'DBIC::Plain is broken!');
34
35 EOSQL
36
37 $dbh->do($_) for split(/\n\n/, $sql);
38
39 1;
0 package # hide from PAUSE
1 DBICTest::Plain;
2
3 use strict;
4 use warnings;
5 use base qw/DBIx::Class::Schema/;
6 use DBI;
7
8 my $db_file = "t/var/Plain.db";
9
10 unlink($db_file) if -e $db_file;
11 unlink($db_file . "-journal") if -e $db_file . "-journal";
12 mkdir("t/var") unless -d "t/var";
13
14 my $dsn = "dbi:SQLite:${db_file}";
15
16 __PACKAGE__->load_classes("Test");
17 my $schema = __PACKAGE__->compose_connection(
18 __PACKAGE__,
19 $dsn,
20 undef,
21 undef,
22 { AutoCommit => 1 }
23 );
24
25 my $dbh = DBI->connect($dsn);
26
27 my $sql = <<EOSQL;
28 CREATE TABLE test (
29 id INTEGER NOT NULL,
30 name VARCHAR(32) NOT NULL
31 );
32
33 INSERT INTO test (id, name) VALUES (1, 'DBIC::Plain is broken!');
34
35 EOSQL
36
37 $dbh->do($_) for split(/\n\n/, $sql);
38
39 1;
+7
-7
t/lib/DBICTest/ResultSetManager.pm less more
0 package # hide from PAUSE
1 DBICTest::ResultSetManager;
2 use base 'DBIx::Class::Schema';
3
4 __PACKAGE__->load_classes("Foo");
5
6 1;
0 package # hide from PAUSE
1 DBICTest::ResultSetManager;
2 use base 'DBIx::Class::Schema';
3
4 __PACKAGE__->load_classes("Foo");
5
6 1;
+8
-8
t/lib/DBICTest/Schema/ArtistSourceName.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::ArtistSourceName;
2
3 use base 'DBICTest::Schema::Artist';
4 __PACKAGE__->table(__PACKAGE__->table);
5 __PACKAGE__->source_name('SourceNameArtists');
6
7 1;
0 package # hide from PAUSE
1 DBICTest::Schema::ArtistSourceName;
2
3 use base 'DBICTest::Schema::Artist';
4 __PACKAGE__->table(__PACKAGE__->table);
5 __PACKAGE__->source_name('SourceNameArtists');
6
7 1;
+7
-7
t/lib/DBICTest/Schema/ArtistSubclass.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::ArtistSubclass;
2
3 use base 'DBICTest::Schema::Artist';
4
5 __PACKAGE__->table(__PACKAGE__->table);
6
0 package # hide from PAUSE
1 DBICTest::Schema::ArtistSubclass;
2
3 use base 'DBICTest::Schema::Artist';
4
5 __PACKAGE__->table(__PACKAGE__->table);
6
77 1;⏎
+20
-20
t/lib/DBICTest/Schema/ArtistUndirectedMap.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::ArtistUndirectedMap;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('artist_undirected_map');
6 __PACKAGE__->add_columns(
7 'id1' => { data_type => 'integer' },
8 'id2' => { data_type => 'integer' },
9 );
10 __PACKAGE__->set_primary_key(qw/id1 id2/);
11
12 __PACKAGE__->belongs_to( 'artist1', 'DBICTest::Schema::Artist', 'id1', { on_delete => 'RESTRICT', on_update => 'CASCADE'} );
13 __PACKAGE__->belongs_to( 'artist2', 'DBICTest::Schema::Artist', 'id2', { on_delete => undef, on_update => undef} );
14 __PACKAGE__->has_many(
15 'mapped_artists', 'DBICTest::Schema::Artist',
16 [ {'foreign.artistid' => 'self.id1'}, {'foreign.artistid' => 'self.id2'} ],
17 );
18
19 1;
0 package # hide from PAUSE
1 DBICTest::Schema::ArtistUndirectedMap;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('artist_undirected_map');
6 __PACKAGE__->add_columns(
7 'id1' => { data_type => 'integer' },
8 'id2' => { data_type => 'integer' },
9 );
10 __PACKAGE__->set_primary_key(qw/id1 id2/);
11
12 __PACKAGE__->belongs_to( 'artist1', 'DBICTest::Schema::Artist', 'id1', { on_delete => 'RESTRICT', on_update => 'CASCADE'} );
13 __PACKAGE__->belongs_to( 'artist2', 'DBICTest::Schema::Artist', 'id2', { on_delete => undef, on_update => undef} );
14 __PACKAGE__->has_many(
15 'mapped_artists', 'DBICTest::Schema::Artist',
16 [ {'foreign.artistid' => 'self.id1'}, {'foreign.artistid' => 'self.id2'} ],
17 );
18
19 1;
+20
-20
t/lib/DBICTest/Schema/Artwork.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Artwork;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('cd_artwork');
6 __PACKAGE__->add_columns(
7 'cd_id' => {
8 data_type => 'integer',
9 is_nullable => 0,
10 },
11 );
12 __PACKAGE__->set_primary_key('cd_id');
13 __PACKAGE__->belongs_to('cd', 'DBICTest::Schema::CD', 'cd_id');
14 __PACKAGE__->has_many('images', 'DBICTest::Schema::Image', 'artwork_id');
15
16 __PACKAGE__->has_many('artwork_to_artist', 'DBICTest::Schema::Artwork_to_Artist', 'artwork_cd_id');
17 __PACKAGE__->many_to_many('artists', 'artwork_to_artist', 'artist');
18
19 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Artwork;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('cd_artwork');
6 __PACKAGE__->add_columns(
7 'cd_id' => {
8 data_type => 'integer',
9 is_nullable => 0,
10 },
11 );
12 __PACKAGE__->set_primary_key('cd_id');
13 __PACKAGE__->belongs_to('cd', 'DBICTest::Schema::CD', 'cd_id');
14 __PACKAGE__->has_many('images', 'DBICTest::Schema::Image', 'artwork_id');
15
16 __PACKAGE__->has_many('artwork_to_artist', 'DBICTest::Schema::Artwork_to_Artist', 'artwork_cd_id');
17 __PACKAGE__->many_to_many('artists', 'artwork_to_artist', 'artist');
18
19 1;
+21
-21
t/lib/DBICTest/Schema/Artwork_to_Artist.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Artwork_to_Artist;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('artwork_to_artist');
6 __PACKAGE__->add_columns(
7 'artwork_cd_id' => {
8 data_type => 'integer',
9 is_foreign_key => 1,
10 },
11 'artist_id' => {
12 data_type => 'integer',
13 is_foreign_key => 1,
14 },
15 );
16 __PACKAGE__->set_primary_key(qw/artwork_cd_id artist_id/);
17 __PACKAGE__->belongs_to('artwork', 'DBICTest::Schema::Artwork', 'artwork_cd_id');
18 __PACKAGE__->belongs_to('artist', 'DBICTest::Schema::Artist', 'artist_id');
19
20 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Artwork_to_Artist;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('artwork_to_artist');
6 __PACKAGE__->add_columns(
7 'artwork_cd_id' => {
8 data_type => 'integer',
9 is_foreign_key => 1,
10 },
11 'artist_id' => {
12 data_type => 'integer',
13 is_foreign_key => 1,
14 },
15 );
16 __PACKAGE__->set_primary_key(qw/artwork_cd_id artist_id/);
17 __PACKAGE__->belongs_to('artwork', 'DBICTest::Schema::Artwork', 'artwork_cd_id');
18 __PACKAGE__->belongs_to('artist', 'DBICTest::Schema::Artist', 'artist_id');
19
20 1;
+29
-29
t/lib/DBICTest/Schema/BindType.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::BindType;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('bindtype_test');
6
7 __PACKAGE__->add_columns(
8 'id' => {
9 data_type => 'integer',
10 is_auto_increment => 1,
11 },
12 'bytea' => {
13 data_type => 'bytea',
14 is_nullable => 1,
15 },
16 'blob' => {
17 data_type => 'blob',
18 is_nullable => 1,
19 },
20 'clob' => {
21 data_type => 'clob',
22 is_nullable => 1,
23 },
24 );
25
26 __PACKAGE__->set_primary_key('id');
27
28 1;
0 package # hide from PAUSE
1 DBICTest::Schema::BindType;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('bindtype_test');
6
7 __PACKAGE__->add_columns(
8 'id' => {
9 data_type => 'integer',
10 is_auto_increment => 1,
11 },
12 'bytea' => {
13 data_type => 'bytea',
14 is_nullable => 1,
15 },
16 'blob' => {
17 data_type => 'blob',
18 is_nullable => 1,
19 },
20 'clob' => {
21 data_type => 'clob',
22 is_nullable => 1,
23 },
24 );
25
26 __PACKAGE__->set_primary_key('id');
27
28 1;
+25
-25
t/lib/DBICTest/Schema/Bookmark.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Bookmark;
2
3 use base qw/DBICTest::BaseResult/;
4
5
6 use strict;
7 use warnings;
8
9 __PACKAGE__->table('bookmark');
10 __PACKAGE__->add_columns(
11 'id' => {
12 data_type => 'integer',
13 is_auto_increment => 1
14 },
15 'link' => {
16 data_type => 'integer',
17 is_nullable => 1,
18 },
19 );
20
21 __PACKAGE__->set_primary_key('id');
22 __PACKAGE__->belongs_to(link => 'DBICTest::Schema::Link', 'link', { on_delete => 'SET NULL' } );
23
24 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Bookmark;
2
3 use base qw/DBICTest::BaseResult/;
4
5
6 use strict;
7 use warnings;
8
9 __PACKAGE__->table('bookmark');
10 __PACKAGE__->add_columns(
11 'id' => {
12 data_type => 'integer',
13 is_auto_increment => 1
14 },
15 'link' => {
16 data_type => 'integer',
17 is_nullable => 1,
18 },
19 );
20
21 __PACKAGE__->set_primary_key('id');
22 __PACKAGE__->belongs_to(link => 'DBICTest::Schema::Link', 'link', { on_delete => 'SET NULL' } );
23
24 1;
+34
-34
t/lib/DBICTest/Schema/BooksInLibrary.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::BooksInLibrary;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('books');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'source' => {
12 data_type => 'varchar',
13 size => '100',
14 },
15 'owner' => {
16 data_type => 'integer',
17 },
18 'title' => {
19 data_type => 'varchar',
20 size => '100',
21 },
22 'price' => {
23 data_type => 'integer',
24 is_nullable => 1,
25 },
26 );
27 __PACKAGE__->set_primary_key('id');
28
29 __PACKAGE__->resultset_attributes({where => { source => "Library" } });
30
31 __PACKAGE__->belongs_to ( owner => 'DBICTest::Schema::Owners', 'owner' );
32
33 1;
0 package # hide from PAUSE
1 DBICTest::Schema::BooksInLibrary;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('books');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'source' => {
12 data_type => 'varchar',
13 size => '100',
14 },
15 'owner' => {
16 data_type => 'integer',
17 },
18 'title' => {
19 data_type => 'varchar',
20 size => '100',
21 },
22 'price' => {
23 data_type => 'integer',
24 is_nullable => 1,
25 },
26 );
27 __PACKAGE__->set_primary_key('id');
28
29 __PACKAGE__->resultset_attributes({where => { source => "Library" } });
30
31 __PACKAGE__->belongs_to ( owner => 'DBICTest::Schema::Owners', 'owner' );
32
33 1;
+25
-25
t/lib/DBICTest/Schema/CD_to_Producer.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::CD_to_Producer;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('cd_to_producer');
6 __PACKAGE__->add_columns(
7 cd => { data_type => 'integer' },
8 producer => { data_type => 'integer' },
9 attribute => { data_type => 'integer', is_nullable => 1 },
10 );
11 __PACKAGE__->set_primary_key(qw/cd producer/);
12
13 __PACKAGE__->belongs_to(
14 'cd', 'DBICTest::Schema::CD',
15 { 'foreign.cdid' => 'self.cd' }
16 );
17
18 __PACKAGE__->belongs_to(
19 'producer', 'DBICTest::Schema::Producer',
20 { 'foreign.producerid' => 'self.producer' },
21 { on_delete => undef, on_update => undef },
22 );
23
24 1;
0 package # hide from PAUSE
1 DBICTest::Schema::CD_to_Producer;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('cd_to_producer');
6 __PACKAGE__->add_columns(
7 cd => { data_type => 'integer' },
8 producer => { data_type => 'integer' },
9 attribute => { data_type => 'integer', is_nullable => 1 },
10 );
11 __PACKAGE__->set_primary_key(qw/cd producer/);
12
13 __PACKAGE__->belongs_to(
14 'cd', 'DBICTest::Schema::CD',
15 { 'foreign.cdid' => 'self.cd' }
16 );
17
18 __PACKAGE__->belongs_to(
19 'producer', 'DBICTest::Schema::Producer',
20 { 'foreign.producerid' => 'self.producer' },
21 { on_delete => undef, on_update => undef },
22 );
23
24 1;
+30
-30
t/lib/DBICTest/Schema/Collection.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Collection;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('collection');
6 __PACKAGE__->add_columns(
7 'collectionid' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'name' => {
12 data_type => 'varchar',
13 size => 100,
14 },
15 );
16 __PACKAGE__->set_primary_key('collectionid');
17
18 __PACKAGE__->has_many( collection_object => "DBICTest::Schema::CollectionObject",
19 { "foreign.collection" => "self.collectionid" }
20 );
21 __PACKAGE__->many_to_many( objects => collection_object => "object" );
22 __PACKAGE__->many_to_many( pointy_objects => collection_object => "object",
23 { where => { "object.type" => "pointy" } }
24 );
25 __PACKAGE__->many_to_many( round_objects => collection_object => "object",
26 { where => { "object.type" => "round" } }
27 );
28
29 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Collection;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('collection');
6 __PACKAGE__->add_columns(
7 'collectionid' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'name' => {
12 data_type => 'varchar',
13 size => 100,
14 },
15 );
16 __PACKAGE__->set_primary_key('collectionid');
17
18 __PACKAGE__->has_many( collection_object => "DBICTest::Schema::CollectionObject",
19 { "foreign.collection" => "self.collectionid" }
20 );
21 __PACKAGE__->many_to_many( objects => collection_object => "object" );
22 __PACKAGE__->many_to_many( pointy_objects => collection_object => "object",
23 { where => { "object.type" => "pointy" } }
24 );
25 __PACKAGE__->many_to_many( round_objects => collection_object => "object",
26 { where => { "object.type" => "round" } }
27 );
28
29 1;
+24
-24
t/lib/DBICTest/Schema/CollectionObject.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::CollectionObject;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('collection_object');
6 __PACKAGE__->add_columns(
7 'collection' => {
8 data_type => 'integer',
9 },
10 'object' => {
11 data_type => 'integer',
12 },
13 );
14 __PACKAGE__->set_primary_key(qw/collection object/);
15
16 __PACKAGE__->belongs_to( collection => "DBICTest::Schema::Collection",
17 { "foreign.collectionid" => "self.collection" }
18 );
19 __PACKAGE__->belongs_to( object => "DBICTest::Schema::TypedObject",
20 { "foreign.objectid" => "self.object" }
21 );
22
23 1;
0 package # hide from PAUSE
1 DBICTest::Schema::CollectionObject;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('collection_object');
6 __PACKAGE__->add_columns(
7 'collection' => {
8 data_type => 'integer',
9 },
10 'object' => {
11 data_type => 'integer',
12 },
13 );
14 __PACKAGE__->set_primary_key(qw/collection object/);
15
16 __PACKAGE__->belongs_to( collection => "DBICTest::Schema::Collection",
17 { "foreign.collectionid" => "self.collection" }
18 );
19 __PACKAGE__->belongs_to( object => "DBICTest::Schema::TypedObject",
20 { "foreign.objectid" => "self.object" }
21 );
22
23 1;
+17
-17
t/lib/DBICTest/Schema/CustomSql.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::CustomSql;
2
3 use base qw/DBICTest::Schema::Artist/;
4
5 __PACKAGE__->table('dummy');
6
7 __PACKAGE__->result_source_instance->name(\<<SQL);
8 ( SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year
9 FROM artist a
10 JOIN cd ON cd.artist = a.artistid
11 WHERE cd.year = ?)
12 SQL
13
14 sub sqlt_deploy_hook { $_[1]->schema->drop_table($_[1]) }
15
16 1;
0 package # hide from PAUSE
1 DBICTest::Schema::CustomSql;
2
3 use base qw/DBICTest::Schema::Artist/;
4
5 __PACKAGE__->table('dummy');
6
7 __PACKAGE__->result_source_instance->name(\<<SQL);
8 ( SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year
9 FROM artist a
10 JOIN cd ON cd.artist = a.artistid
11 WHERE cd.year = ?)
12 SQL
13
14 sub sqlt_deploy_hook { $_[1]->schema->drop_table($_[1]) }
15
16 1;
+23
-23
t/lib/DBICTest/Schema/Dummy.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Dummy;
2
3 use base qw/DBICTest::BaseResult/;
4
5 use strict;
6 use warnings;
7
8 __PACKAGE__->table('dummy');
9 __PACKAGE__->add_columns(
10 'id' => {
11 data_type => 'integer',
12 is_auto_increment => 1
13 },
14 'gittery' => {
15 data_type => 'varchar',
16 size => 100,
17 is_nullable => 1,
18 },
19 );
20 __PACKAGE__->set_primary_key('id');
21
22 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Dummy;
2
3 use base qw/DBICTest::BaseResult/;
4
5 use strict;
6 use warnings;
7
8 __PACKAGE__->table('dummy');
9 __PACKAGE__->add_columns(
10 'id' => {
11 data_type => 'integer',
12 is_auto_increment => 1
13 },
14 'gittery' => {
15 data_type => 'varchar',
16 size => 100,
17 is_nullable => 1,
18 },
19 );
20 __PACKAGE__->set_primary_key('id');
21
22 1;
+8
-6
t/lib/DBICTest/Schema/Employee.pm less more
3131 size => 100,
3232 is_nullable => 1,
3333 },
34 encoded => {
35 data_type => 'integer',
36 is_nullable => 1,
37 },
3438 );
3539
3640 __PACKAGE__->set_primary_key('employee_id');
3741 __PACKAGE__->position_column('position');
3842
39 #__PACKAGE__->add_unique_constraint(position_group => [ qw/position group_id/ ]);
43 # Do not add unique constraints here - different groups are used throughout
44 # the ordered tests
4045
41 __PACKAGE__->mk_classdata('field_name_for', {
42 employee_id => 'primary key',
43 position => 'list position',
44 group_id => 'collection column',
45 name => 'employee name',
46 __PACKAGE__->belongs_to (secretkey => 'DBICTest::Schema::Encoded', 'encoded', {
47 join_type => 'left'
4648 });
4749
4850 1;
+2
-0
t/lib/DBICTest/Schema/Encoded.pm less more
2020
2121 __PACKAGE__->set_primary_key('id');
2222
23 __PACKAGE__->has_many (keyholders => 'DBICTest::Schema::Employee', 'encoded');
24
2325 sub set_column {
2426 my ($self, $col, $value) = @_;
2527 if( $col eq 'encoded' ){
+16
-3
t/lib/DBICTest/Schema/Event.pm less more
99
1010 __PACKAGE__->add_columns(
1111 id => { data_type => 'integer', is_auto_increment => 1 },
12 starts_at => { data_type => 'datetime' },
12
13 # this MUST be 'date' for the Firebird tests
14 starts_at => { data_type => 'date' },
15
1316 created_on => { data_type => 'timestamp' },
14 varchar_date => { data_type => 'varchar', inflate_date => 1, size => 20, is_nullable => 1 },
15 varchar_datetime => { data_type => 'varchar', inflate_datetime => 1, size => 20, is_nullable => 1 },
17 varchar_date => { data_type => 'varchar', size => 20, is_nullable => 1 },
18 varchar_datetime => { data_type => 'varchar', size => 20, is_nullable => 1 },
1619 skip_inflation => { data_type => 'datetime', inflate_datetime => 0, is_nullable => 1 },
1720 ts_without_tz => { data_type => 'datetime', is_nullable => 1 }, # used in EventTZPg
1821 );
1922
2023 __PACKAGE__->set_primary_key('id');
2124
25 # Test add_columns '+colname' to augment a column definition.
26 __PACKAGE__->add_columns(
27 '+varchar_date' => {
28 inflate_date => 1,
29 },
30 '+varchar_datetime' => {
31 inflate_datetime => 1,
32 },
33 );
34
2235 1;
+24
-24
t/lib/DBICTest/Schema/EventTZ.pm less more
0 package DBICTest::Schema::EventTZ;
1
2 use strict;
3 use warnings;
4 use base qw/DBICTest::BaseResult/;
5
6 __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
7
8 __PACKAGE__->table('event');
9
10 __PACKAGE__->add_columns(
11 id => { data_type => 'integer', is_auto_increment => 1 },
12 starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE', datetime_undef_if_invalid => 1 },
13 created_on => { data_type => 'timestamp', timezone => "America/Chicago", floating_tz_ok => 1 },
14 );
15
16 __PACKAGE__->set_primary_key('id');
17
18 sub _datetime_parser {
19 require DateTime::Format::MySQL;
20 DateTime::Format::MySQL->new();
21 }
22
23 1;
0 package DBICTest::Schema::EventTZ;
1
2 use strict;
3 use warnings;
4 use base qw/DBICTest::BaseResult/;
5
6 __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
7
8 __PACKAGE__->table('event');
9
10 __PACKAGE__->add_columns(
11 id => { data_type => 'integer', is_auto_increment => 1 },
12 starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE', datetime_undef_if_invalid => 1 },
13 created_on => { data_type => 'timestamp', timezone => "America/Chicago", floating_tz_ok => 1 },
14 );
15
16 __PACKAGE__->set_primary_key('id');
17
18 sub _datetime_parser {
19 require DateTime::Format::MySQL;
20 DateTime::Format::MySQL->new();
21 }
22
23 1;
+25
-25
t/lib/DBICTest/Schema/EventTZDeprecated.pm less more
0 package DBICTest::Schema::EventTZDeprecated;
1
2 use strict;
3 use warnings;
4 use base qw/DBICTest::BaseResult/;
5
6 __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
7
8 __PACKAGE__->table('event');
9
10 __PACKAGE__->add_columns(
11 id => { data_type => 'integer', is_auto_increment => 1 },
12 starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => 'de_DE' } },
13 created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } },
14 );
15
16 __PACKAGE__->set_primary_key('id');
17
18 sub _datetime_parser {
19 require DateTime::Format::MySQL;
20 DateTime::Format::MySQL->new();
21 }
22
23
24 1;
0 package DBICTest::Schema::EventTZDeprecated;
1
2 use strict;
3 use warnings;
4 use base qw/DBICTest::BaseResult/;
5
6 __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
7
8 __PACKAGE__->table('event');
9
10 __PACKAGE__->add_columns(
11 id => { data_type => 'integer', is_auto_increment => 1 },
12 starts_at => { data_type => 'datetime', extra => { timezone => "America/Chicago", locale => 'de_DE' } },
13 created_on => { data_type => 'timestamp', extra => { timezone => "America/Chicago", floating_tz_ok => 1 } },
14 );
15
16 __PACKAGE__->set_primary_key('id');
17
18 sub _datetime_parser {
19 require DateTime::Format::MySQL;
20 DateTime::Format::MySQL->new();
21 }
22
23
24 1;
+25
-25
t/lib/DBICTest/Schema/EventTZPg.pm less more
0 package DBICTest::Schema::EventTZPg;
1
2 use strict;
3 use warnings;
4 use base qw/DBICTest::BaseResult/;
5
6 __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
7
8 __PACKAGE__->table('event');
9
10 __PACKAGE__->add_columns(
11 id => { data_type => 'integer', is_auto_increment => 1 },
12 starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE' },
13 created_on => { data_type => 'timestamp with time zone', timezone => "America/Chicago" },
14 ts_without_tz => { data_type => 'timestamp without time zone' },
15 );
16
17 __PACKAGE__->set_primary_key('id');
18
19 sub _datetime_parser {
20 require DateTime::Format::Pg;
21 DateTime::Format::Pg->new();
22 }
23
24 1;
0 package DBICTest::Schema::EventTZPg;
1
2 use strict;
3 use warnings;
4 use base qw/DBICTest::BaseResult/;
5
6 __PACKAGE__->load_components(qw/InflateColumn::DateTime/);
7
8 __PACKAGE__->table('event');
9
10 __PACKAGE__->add_columns(
11 id => { data_type => 'integer', is_auto_increment => 1 },
12 starts_at => { data_type => 'datetime', timezone => "America/Chicago", locale => 'de_DE' },
13 created_on => { data_type => 'timestamp with time zone', timezone => "America/Chicago" },
14 ts_without_tz => { data_type => 'timestamp without time zone' },
15 );
16
17 __PACKAGE__->set_primary_key('id');
18
19 sub _datetime_parser {
20 require DateTime::Format::Pg;
21 DateTime::Format::Pg->new();
22 }
23
24 1;
+0
-2
t/lib/DBICTest/Schema/FileColumn.pm less more
44 use warnings;
55 use base qw/DBICTest::BaseResult/;
66 use File::Temp qw/tempdir/;
7
8 __PACKAGE__->load_components(qw/InflateColumn::File/);
97
108 __PACKAGE__->table('file_columns');
119
+29
-29
t/lib/DBICTest/Schema/FourKeys.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::FourKeys;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('fourkeys');
6 __PACKAGE__->add_columns(
7 'foo' => { data_type => 'integer' },
8 'bar' => { data_type => 'integer' },
9 'hello' => { data_type => 'integer' },
10 'goodbye' => { data_type => 'integer' },
11 'sensors' => { data_type => 'character', size => 10 },
12 'read_count' => { data_type => 'integer', is_nullable => 1 },
13 );
14 __PACKAGE__->set_primary_key(qw/foo bar hello goodbye/);
15
16 __PACKAGE__->has_many(
17 'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', {
18 'foreign.f_foo' => 'self.foo',
19 'foreign.f_bar' => 'self.bar',
20 'foreign.f_hello' => 'self.hello',
21 'foreign.f_goodbye' => 'self.goodbye',
22 });
23
24 __PACKAGE__->many_to_many(
25 'twokeys', 'fourkeys_to_twokeys', 'twokeys',
26 );
27
28 1;
0 package # hide from PAUSE
1 DBICTest::Schema::FourKeys;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('fourkeys');
6 __PACKAGE__->add_columns(
7 'foo' => { data_type => 'integer' },
8 'bar' => { data_type => 'integer' },
9 'hello' => { data_type => 'integer' },
10 'goodbye' => { data_type => 'integer' },
11 'sensors' => { data_type => 'character', size => 10 },
12 'read_count' => { data_type => 'integer', is_nullable => 1 },
13 );
14 __PACKAGE__->set_primary_key(qw/foo bar hello goodbye/);
15
16 __PACKAGE__->has_many(
17 'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', {
18 'foreign.f_foo' => 'self.foo',
19 'foreign.f_bar' => 'self.bar',
20 'foreign.f_hello' => 'self.hello',
21 'foreign.f_goodbye' => 'self.goodbye',
22 });
23
24 __PACKAGE__->many_to_many(
25 'twokeys', 'fourkeys_to_twokeys', 'twokeys',
26 );
27
28 1;
+33
-33
t/lib/DBICTest/Schema/FourKeys_to_TwoKeys.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::FourKeys_to_TwoKeys;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('fourkeys_to_twokeys');
6 __PACKAGE__->add_columns(
7 'f_foo' => { data_type => 'integer' },
8 'f_bar' => { data_type => 'integer' },
9 'f_hello' => { data_type => 'integer' },
10 'f_goodbye' => { data_type => 'integer' },
11 't_artist' => { data_type => 'integer' },
12 't_cd' => { data_type => 'integer' },
13 'autopilot' => { data_type => 'character' },
14 'pilot_sequence' => { data_type => 'integer', is_nullable => 1 },
15 );
16 __PACKAGE__->set_primary_key(
17 qw/f_foo f_bar f_hello f_goodbye t_artist t_cd/
18 );
19
20 __PACKAGE__->belongs_to('fourkeys', 'DBICTest::Schema::FourKeys', {
21 'foreign.foo' => 'self.f_foo',
22 'foreign.bar' => 'self.f_bar',
23 'foreign.hello' => 'self.f_hello',
24 'foreign.goodbye' => 'self.f_goodbye',
25 });
26
27 __PACKAGE__->belongs_to('twokeys', 'DBICTest::Schema::TwoKeys', {
28 'foreign.artist' => 'self.t_artist',
29 'foreign.cd' => 'self.t_cd',
30 });
31
32 1;
0 package # hide from PAUSE
1 DBICTest::Schema::FourKeys_to_TwoKeys;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('fourkeys_to_twokeys');
6 __PACKAGE__->add_columns(
7 'f_foo' => { data_type => 'integer' },
8 'f_bar' => { data_type => 'integer' },
9 'f_hello' => { data_type => 'integer' },
10 'f_goodbye' => { data_type => 'integer' },
11 't_artist' => { data_type => 'integer' },
12 't_cd' => { data_type => 'integer' },
13 'autopilot' => { data_type => 'character' },
14 'pilot_sequence' => { data_type => 'integer', is_nullable => 1 },
15 );
16 __PACKAGE__->set_primary_key(
17 qw/f_foo f_bar f_hello f_goodbye t_artist t_cd/
18 );
19
20 __PACKAGE__->belongs_to('fourkeys', 'DBICTest::Schema::FourKeys', {
21 'foreign.foo' => 'self.f_foo',
22 'foreign.bar' => 'self.f_bar',
23 'foreign.hello' => 'self.f_hello',
24 'foreign.goodbye' => 'self.f_goodbye',
25 });
26
27 __PACKAGE__->belongs_to('twokeys', 'DBICTest::Schema::TwoKeys', {
28 'foreign.artist' => 'self.t_artist',
29 'foreign.cd' => 'self.t_cd',
30 });
31
32 1;
+25
-25
t/lib/DBICTest/Schema/Genre.pm less more
0 package DBICTest::Schema::Genre;
1
2 use strict;
3
4 use base qw/DBICTest::BaseResult/;
5
6 __PACKAGE__->table('genre');
7 __PACKAGE__->add_columns(
8 genreid => {
9 data_type => 'integer',
10 is_auto_increment => 1,
11 },
12 name => {
13 data_type => 'varchar',
14 size => 100,
15 },
16 );
17 __PACKAGE__->set_primary_key('genreid');
18 __PACKAGE__->add_unique_constraint ( genre_name => [qw/name/] );
19
20 __PACKAGE__->has_many (cds => 'DBICTest::Schema::CD', 'genreid');
21
22 __PACKAGE__->has_one (model_cd => 'DBICTest::Schema::CD', 'genreid');
23
24 1;
0 package DBICTest::Schema::Genre;
1
2 use strict;
3
4 use base qw/DBICTest::BaseResult/;
5
6 __PACKAGE__->table('genre');
7 __PACKAGE__->add_columns(
8 genreid => {
9 data_type => 'integer',
10 is_auto_increment => 1,
11 },
12 name => {
13 data_type => 'varchar',
14 size => 100,
15 },
16 );
17 __PACKAGE__->set_primary_key('genreid');
18 __PACKAGE__->add_unique_constraint ( genre_name => [qw/name/] );
19
20 __PACKAGE__->has_many (cds => 'DBICTest::Schema::CD', 'genreid');
21
22 __PACKAGE__->has_one (model_cd => 'DBICTest::Schema::CD', 'genreid');
23
24 1;
+28
-28
t/lib/DBICTest/Schema/Image.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Image;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('images');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'artwork_id' => {
12 data_type => 'integer',
13 is_foreign_key => 1,
14 },
15 'name' => {
16 data_type => 'varchar',
17 size => 100,
18 },
19 'data' => {
20 data_type => 'blob',
21 is_nullable => 1,
22 },
23 );
24 __PACKAGE__->set_primary_key('id');
25 __PACKAGE__->belongs_to('artwork', 'DBICTest::Schema::Artwork', 'artwork_id');
26
27 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Image;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('images');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'artwork_id' => {
12 data_type => 'integer',
13 is_foreign_key => 1,
14 },
15 'name' => {
16 data_type => 'varchar',
17 size => 100,
18 },
19 'data' => {
20 data_type => 'blob',
21 is_nullable => 1,
22 },
23 );
24 __PACKAGE__->set_primary_key('id');
25 __PACKAGE__->belongs_to('artwork', 'DBICTest::Schema::Artwork', 'artwork_id');
26
27 1;
+21
-21
t/lib/DBICTest/Schema/LinerNotes.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::LinerNotes;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('liner_notes');
6 __PACKAGE__->add_columns(
7 'liner_id' => {
8 data_type => 'integer',
9 },
10 'notes' => {
11 data_type => 'varchar',
12 size => 100,
13 },
14 );
15 __PACKAGE__->set_primary_key('liner_id');
16 __PACKAGE__->belongs_to(
17 'cd', 'DBICTest::Schema::CD', 'liner_id'
18 );
19
20 1;
0 package # hide from PAUSE
1 DBICTest::Schema::LinerNotes;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('liner_notes');
6 __PACKAGE__->add_columns(
7 'liner_id' => {
8 data_type => 'integer',
9 },
10 'notes' => {
11 data_type => 'varchar',
12 size => 100,
13 },
14 );
15 __PACKAGE__->set_primary_key('liner_id');
16 __PACKAGE__->belongs_to(
17 'cd', 'DBICTest::Schema::CD', 'liner_id'
18 );
19
20 1;
+32
-32
t/lib/DBICTest/Schema/Link.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Link;
2
3 use base qw/DBICTest::BaseResult/;
4
5 use strict;
6 use warnings;
7
8 __PACKAGE__->table('link');
9 __PACKAGE__->add_columns(
10 'id' => {
11 data_type => 'integer',
12 is_auto_increment => 1
13 },
14 'url' => {
15 data_type => 'varchar',
16 size => 100,
17 is_nullable => 1,
18 },
19 'title' => {
20 data_type => 'varchar',
21 size => 100,
22 is_nullable => 1,
23 },
24 );
25 __PACKAGE__->set_primary_key('id');
26
27 __PACKAGE__->has_many ( bookmarks => 'DBICTest::Schema::Bookmark', 'link', { cascade_delete => 0 } );
28
29 use overload '""' => sub { shift->url }, fallback=> 1;
30
31 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Link;
2
3 use base qw/DBICTest::BaseResult/;
4
5 use strict;
6 use warnings;
7
8 __PACKAGE__->table('link');
9 __PACKAGE__->add_columns(
10 'id' => {
11 data_type => 'integer',
12 is_auto_increment => 1
13 },
14 'url' => {
15 data_type => 'varchar',
16 size => 100,
17 is_nullable => 1,
18 },
19 'title' => {
20 data_type => 'varchar',
21 size => 100,
22 is_nullable => 1,
23 },
24 );
25 __PACKAGE__->set_primary_key('id');
26
27 __PACKAGE__->has_many ( bookmarks => 'DBICTest::Schema::Bookmark', 'link', { cascade_delete => 0 } );
28
29 use overload '""' => sub { shift->url }, fallback=> 1;
30
31 1;
+24
-24
t/lib/DBICTest/Schema/LyricVersion.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::LyricVersion;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('lyric_versions');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'lyric_id' => {
12 data_type => 'integer',
13 is_foreign_key => 1,
14 },
15 'text' => {
16 data_type => 'varchar',
17 size => 100,
18 },
19 );
20 __PACKAGE__->set_primary_key('id');
21 __PACKAGE__->belongs_to('lyric', 'DBICTest::Schema::Lyrics', 'lyric_id');
22
23 1;
0 package # hide from PAUSE
1 DBICTest::Schema::LyricVersion;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('lyric_versions');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'lyric_id' => {
12 data_type => 'integer',
13 is_foreign_key => 1,
14 },
15 'text' => {
16 data_type => 'varchar',
17 size => 100,
18 },
19 );
20 __PACKAGE__->set_primary_key('id');
21 __PACKAGE__->belongs_to('lyric', 'DBICTest::Schema::Lyrics', 'lyric_id');
22
23 1;
+21
-21
t/lib/DBICTest/Schema/Lyrics.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Lyrics;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('lyrics');
6 __PACKAGE__->add_columns(
7 'lyric_id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'track_id' => {
12 data_type => 'integer',
13 is_foreign_key => 1,
14 },
15 );
16 __PACKAGE__->set_primary_key('lyric_id');
17 __PACKAGE__->belongs_to('track', 'DBICTest::Schema::Track', 'track_id');
18 __PACKAGE__->has_many('lyric_versions', 'DBICTest::Schema::LyricVersion', 'lyric_id');
19
20 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Lyrics;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('lyrics');
6 __PACKAGE__->add_columns(
7 'lyric_id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'track_id' => {
12 data_type => 'integer',
13 is_foreign_key => 1,
14 },
15 );
16 __PACKAGE__->set_primary_key('lyric_id');
17 __PACKAGE__->belongs_to('track', 'DBICTest::Schema::Track', 'track_id');
18 __PACKAGE__->has_many('lyric_versions', 'DBICTest::Schema::LyricVersion', 'lyric_id');
19
20 1;
+15
-15
t/lib/DBICTest/Schema/NoPrimaryKey.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::NoPrimaryKey;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('noprimarykey');
6 __PACKAGE__->add_columns(
7 'foo' => { data_type => 'integer' },
8 'bar' => { data_type => 'integer' },
9 'baz' => { data_type => 'integer' },
10 );
11
12 __PACKAGE__->add_unique_constraint(foo_bar => [ qw/foo bar/ ]);
13
14 1;
0 package # hide from PAUSE
1 DBICTest::Schema::NoPrimaryKey;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('noprimarykey');
6 __PACKAGE__->add_columns(
7 'foo' => { data_type => 'integer' },
8 'bar' => { data_type => 'integer' },
9 'baz' => { data_type => 'integer' },
10 );
11
12 __PACKAGE__->add_unique_constraint(foo_bar => [ qw/foo bar/ ]);
13
14 1;
+6
-6
t/lib/DBICTest/Schema/NoSuchClass.pm less more
0 package DBICTest::Schema::NoSuchClass;
1
2 ## This is purposefully not a real DBIC class
3 ## Used in t/102load_classes.t
4
5 1;
0 package DBICTest::Schema::NoSuchClass;
1
2 ## This is purposefully not a real DBIC class
3 ## Used in t/102load_classes.t
4
5 1;
+22
-22
t/lib/DBICTest/Schema/OneKey.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::OneKey;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('onekey');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'artist' => {
12 data_type => 'integer',
13 },
14 'cd' => {
15 data_type => 'integer',
16 },
17 );
18 __PACKAGE__->set_primary_key('id');
19
20
21 1;
0 package # hide from PAUSE
1 DBICTest::Schema::OneKey;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('onekey');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'artist' => {
12 data_type => 'integer',
13 },
14 'cd' => {
15 data_type => 'integer',
16 },
17 );
18 __PACKAGE__->set_primary_key('id');
19
20
21 1;
+21
-21
t/lib/DBICTest/Schema/Owners.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Owners;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('owners');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'name' => {
12 data_type => 'varchar',
13 size => '100',
14 },
15 );
16 __PACKAGE__->set_primary_key('id');
17
18 __PACKAGE__->has_many(books => "DBICTest::Schema::BooksInLibrary", "owner");
19
20 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Owners;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('owners');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'name' => {
12 data_type => 'varchar',
13 size => '100',
14 },
15 );
16 __PACKAGE__->set_primary_key('id');
17
18 __PACKAGE__->has_many(books => "DBICTest::Schema::BooksInLibrary", "owner");
19
20 1;
+24
-24
t/lib/DBICTest/Schema/Producer.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Producer;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('producer');
6 __PACKAGE__->add_columns(
7 'producerid' => {
8 data_type => 'integer',
9 is_auto_increment => 1
10 },
11 'name' => {
12 data_type => 'varchar',
13 size => 100,
14 },
15 );
16 __PACKAGE__->set_primary_key('producerid');
17 __PACKAGE__->add_unique_constraint(prod_name => [ qw/name/ ]);
18
19 __PACKAGE__->has_many(
20 producer_to_cd => 'DBICTest::Schema::CD_to_Producer' => 'producer'
21 );
22 __PACKAGE__->many_to_many('cds', 'producer_to_cd', 'cd');
23 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Producer;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('producer');
6 __PACKAGE__->add_columns(
7 'producerid' => {
8 data_type => 'integer',
9 is_auto_increment => 1
10 },
11 'name' => {
12 data_type => 'varchar',
13 size => 100,
14 },
15 );
16 __PACKAGE__->set_primary_key('producerid');
17 __PACKAGE__->add_unique_constraint(prod_name => [ qw/name/ ]);
18
19 __PACKAGE__->has_many(
20 producer_to_cd => 'DBICTest::Schema::CD_to_Producer' => 'producer'
21 );
22 __PACKAGE__->many_to_many('cds', 'producer_to_cd', 'cd');
23 1;
+21
-21
t/lib/DBICTest/Schema/SelfRef.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::SelfRef;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('self_ref');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'name' => {
12 data_type => 'varchar',
13 size => 100,
14 },
15 );
16 __PACKAGE__->set_primary_key('id');
17
18 __PACKAGE__->has_many( aliases => 'DBICTest::Schema::SelfRefAlias' => 'self_ref' );
19
20 1;
0 package # hide from PAUSE
1 DBICTest::Schema::SelfRef;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('self_ref');
6 __PACKAGE__->add_columns(
7 'id' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'name' => {
12 data_type => 'varchar',
13 size => 100,
14 },
15 );
16 __PACKAGE__->set_primary_key('id');
17
18 __PACKAGE__->has_many( aliases => 'DBICTest::Schema::SelfRefAlias' => 'self_ref' );
19
20 1;
+20
-20
t/lib/DBICTest/Schema/SelfRefAlias.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::SelfRefAlias;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('self_ref_alias');
6 __PACKAGE__->add_columns(
7 'self_ref' => {
8 data_type => 'integer',
9 },
10 'alias' => {
11 data_type => 'integer',
12 },
13 );
14 __PACKAGE__->set_primary_key(qw/self_ref alias/);
15
16 __PACKAGE__->belongs_to( self_ref => 'DBICTest::Schema::SelfRef' );
17 __PACKAGE__->belongs_to( alias => 'DBICTest::Schema::SelfRef' );
18
19 1;
0 package # hide from PAUSE
1 DBICTest::Schema::SelfRefAlias;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('self_ref_alias');
6 __PACKAGE__->add_columns(
7 'self_ref' => {
8 data_type => 'integer',
9 },
10 'alias' => {
11 data_type => 'integer',
12 },
13 );
14 __PACKAGE__->set_primary_key(qw/self_ref alias/);
15
16 __PACKAGE__->belongs_to( self_ref => 'DBICTest::Schema::SelfRef' );
17 __PACKAGE__->belongs_to( alias => 'DBICTest::Schema::SelfRef' );
18
19 1;
+37
-37
t/lib/DBICTest/Schema/SequenceTest.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::SequenceTest;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('sequence_test');
6 __PACKAGE__->source_info({
7 "source_info_key_A" => "source_info_value_A",
8 "source_info_key_B" => "source_info_value_B",
9 "source_info_key_C" => "source_info_value_C",
10 "source_info_key_D" => "source_info_value_D",
11 });
12 __PACKAGE__->add_columns(
13 'pkid1' => {
14 data_type => 'integer',
15 auto_nextval => 1,
16 sequence => 'pkid1_seq',
17 },
18 'pkid2' => {
19 data_type => 'integer',
20 auto_nextval => 1,
21 sequence => 'pkid2_seq',
22 },
23 'nonpkid' => {
24 data_type => 'integer',
25 auto_nextval => 1,
26 sequence => 'nonpkid_seq',
27 },
28 'name' => {
29 data_type => 'varchar',
30 size => 100,
31 is_nullable => 1,
32 },
33 );
34 __PACKAGE__->set_primary_key('pkid1', 'pkid2');
35
36 1;
0 package # hide from PAUSE
1 DBICTest::Schema::SequenceTest;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('sequence_test');
6 __PACKAGE__->source_info({
7 "source_info_key_A" => "source_info_value_A",
8 "source_info_key_B" => "source_info_value_B",
9 "source_info_key_C" => "source_info_value_C",
10 "source_info_key_D" => "source_info_value_D",
11 });
12 __PACKAGE__->add_columns(
13 'pkid1' => {
14 data_type => 'integer',
15 auto_nextval => 1,
16 sequence => 'pkid1_seq',
17 },
18 'pkid2' => {
19 data_type => 'integer',
20 auto_nextval => 1,
21 sequence => 'pkid2_seq',
22 },
23 'nonpkid' => {
24 data_type => 'integer',
25 auto_nextval => 1,
26 sequence => 'nonpkid_seq',
27 },
28 'name' => {
29 data_type => 'varchar',
30 size => 100,
31 is_nullable => 1,
32 },
33 );
34 __PACKAGE__->set_primary_key('pkid1', 'pkid2');
35
36 1;
+13
-13
t/lib/DBICTest/Schema/Serialized.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Serialized;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('serialized');
6 __PACKAGE__->add_columns(
7 'id' => { data_type => 'integer', is_auto_increment => 1 },
8 'serialized' => { data_type => 'text' },
9 );
10 __PACKAGE__->set_primary_key('id');
11
12 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Serialized;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('serialized');
6 __PACKAGE__->add_columns(
7 'id' => { data_type => 'integer', is_auto_increment => 1 },
8 'serialized' => { data_type => 'text' },
9 );
10 __PACKAGE__->set_primary_key('id');
11
12 1;
+24
-24
t/lib/DBICTest/Schema/Tag.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::Tag;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('tags');
6 __PACKAGE__->add_columns(
7 'tagid' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'cd' => {
12 data_type => 'integer',
13 },
14 'tag' => {
15 data_type => 'varchar',
16 size => 100,
17 },
18 );
19 __PACKAGE__->set_primary_key('tagid');
20
21 __PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD' );
22
23 1;
0 package # hide from PAUSE
1 DBICTest::Schema::Tag;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('tags');
6 __PACKAGE__->add_columns(
7 'tagid' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'cd' => {
12 data_type => 'integer',
13 },
14 'tag' => {
15 data_type => 'varchar',
16 size => 100,
17 },
18 );
19 __PACKAGE__->set_primary_key('tagid');
20
21 __PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD' );
22
23 1;
+17
-0
t/lib/DBICTest/Schema/TimestampPrimaryKey.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::TimestampPrimaryKey;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('timestamp_primary_key_test');
6
7 __PACKAGE__->add_columns(
8 'id' => {
9 data_type => 'timestamp',
10 default_value => \'current_timestamp',
11 },
12 );
13
14 __PACKAGE__->set_primary_key('id');
15
16 1;
+28
-28
t/lib/DBICTest/Schema/TreeLike.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::TreeLike;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('treelike');
6 __PACKAGE__->add_columns(
7 'id' => { data_type => 'integer', is_auto_increment => 1 },
8 'parent' => { data_type => 'integer' , is_nullable=>1},
9 'name' => { data_type => 'varchar',
10 size => 100,
11 },
12 );
13 __PACKAGE__->set_primary_key(qw/id/);
14 __PACKAGE__->belongs_to('parent', 'TreeLike',
15 { 'foreign.id' => 'self.parent' });
16 __PACKAGE__->has_many('children', 'TreeLike', { 'foreign.parent' => 'self.id' });
17
18 ## since this is a self referential table we need to do a post deploy hook and get
19 ## some data in while constraints are off
20
21 sub sqlt_deploy_hook {
22 my ($self, $sqlt_table) = @_;
23
24 ## We don't seem to need this anymore, but keeping it for the moment
25 ## $sqlt_table->add_index(name => 'idx_name', fields => ['name']);
26 }
27 1;
0 package # hide from PAUSE
1 DBICTest::Schema::TreeLike;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('treelike');
6 __PACKAGE__->add_columns(
7 'id' => { data_type => 'integer', is_auto_increment => 1 },
8 'parent' => { data_type => 'integer' , is_nullable=>1},
9 'name' => { data_type => 'varchar',
10 size => 100,
11 },
12 );
13 __PACKAGE__->set_primary_key(qw/id/);
14 __PACKAGE__->belongs_to('parent', 'TreeLike',
15 { 'foreign.id' => 'self.parent' });
16 __PACKAGE__->has_many('children', 'TreeLike', { 'foreign.parent' => 'self.id' });
17
18 ## since this is a self referential table we need to do a post deploy hook and get
19 ## some data in while constraints are off
20
21 sub sqlt_deploy_hook {
22 my ($self, $sqlt_table) = @_;
23
24 ## We don't seem to need this anymore, but keeping it for the moment
25 ## $sqlt_table->add_index(name => 'idx_name', fields => ['name']);
26 }
27 1;
+21
-21
t/lib/DBICTest/Schema/TwoKeyTreeLike.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::TwoKeyTreeLike;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('twokeytreelike');
6 __PACKAGE__->add_columns(
7 'id1' => { data_type => 'integer' },
8 'id2' => { data_type => 'integer' },
9 'parent1' => { data_type => 'integer' },
10 'parent2' => { data_type => 'integer' },
11 'name' => { data_type => 'varchar',
12 size => 100,
13 },
14 );
15 __PACKAGE__->set_primary_key(qw/id1 id2/);
16 __PACKAGE__->add_unique_constraint('tktlnameunique' => ['name']);
17 __PACKAGE__->belongs_to('parent', 'DBICTest::Schema::TwoKeyTreeLike',
18 { 'foreign.id1' => 'self.parent1', 'foreign.id2' => 'self.parent2'});
19
20 1;
0 package # hide from PAUSE
1 DBICTest::Schema::TwoKeyTreeLike;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('twokeytreelike');
6 __PACKAGE__->add_columns(
7 'id1' => { data_type => 'integer' },
8 'id2' => { data_type => 'integer' },
9 'parent1' => { data_type => 'integer' },
10 'parent2' => { data_type => 'integer' },
11 'name' => { data_type => 'varchar',
12 size => 100,
13 },
14 );
15 __PACKAGE__->set_primary_key(qw/id1 id2/);
16 __PACKAGE__->add_unique_constraint('tktlnameunique' => ['name']);
17 __PACKAGE__->belongs_to('parent', 'DBICTest::Schema::TwoKeyTreeLike',
18 { 'foreign.id1' => 'self.parent1', 'foreign.id2' => 'self.parent2'});
19
20 1;
+30
-30
t/lib/DBICTest/Schema/TwoKeys.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::TwoKeys;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('twokeys');
6 __PACKAGE__->add_columns(
7 'artist' => { data_type => 'integer' },
8 'cd' => { data_type => 'integer' },
9 );
10 __PACKAGE__->set_primary_key(qw/artist cd/);
11
12 __PACKAGE__->belongs_to(
13 artist => 'DBICTest::Schema::Artist',
14 {'foreign.artistid'=>'self.artist'},
15 );
16
17 __PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, { is_deferrable => 0, add_fk_index => 0 } );
18
19 __PACKAGE__->has_many(
20 'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', {
21 'foreign.t_artist' => 'self.artist',
22 'foreign.t_cd' => 'self.cd',
23 });
24
25 __PACKAGE__->many_to_many(
26 'fourkeys', 'fourkeys_to_twokeys', 'fourkeys',
27 );
28
29 1;
0 package # hide from PAUSE
1 DBICTest::Schema::TwoKeys;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('twokeys');
6 __PACKAGE__->add_columns(
7 'artist' => { data_type => 'integer' },
8 'cd' => { data_type => 'integer' },
9 );
10 __PACKAGE__->set_primary_key(qw/artist cd/);
11
12 __PACKAGE__->belongs_to(
13 artist => 'DBICTest::Schema::Artist',
14 {'foreign.artistid'=>'self.artist'},
15 );
16
17 __PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, { is_deferrable => 0, add_fk_index => 0 } );
18
19 __PACKAGE__->has_many(
20 'fourkeys_to_twokeys', 'DBICTest::Schema::FourKeys_to_TwoKeys', {
21 'foreign.t_artist' => 'self.artist',
22 'foreign.t_cd' => 'self.cd',
23 });
24
25 __PACKAGE__->many_to_many(
26 'fourkeys', 'fourkeys_to_twokeys', 'fourkeys',
27 );
28
29 1;
+28
-28
t/lib/DBICTest/Schema/TypedObject.pm less more
0 package # hide from PAUSE
1 DBICTest::Schema::TypedObject;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('typed_object');
6 __PACKAGE__->add_columns(
7 'objectid' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'type' => {
12 data_type => 'varchar',
13 size => '100',
14 },
15 'value' => {
16 data_type => 'varchar',
17 size => 100,
18 },
19 );
20 __PACKAGE__->set_primary_key('objectid');
21
22 __PACKAGE__->has_many( collection_object => "DBICTest::Schema::CollectionObject",
23 { "foreign.object" => "self.objectid" }
24 );
25 __PACKAGE__->many_to_many( collections => collection_object => "collection" );
26
27 1;
0 package # hide from PAUSE
1 DBICTest::Schema::TypedObject;
2
3 use base qw/DBICTest::BaseResult/;
4
5 __PACKAGE__->table('typed_object');
6 __PACKAGE__->add_columns(
7 'objectid' => {
8 data_type => 'integer',
9 is_auto_increment => 1,
10 },
11 'type' => {
12 data_type => 'varchar',
13 size => '100',
14 },
15 'value' => {
16 data_type => 'varchar',
17 size => 100,
18 },
19 );
20 __PACKAGE__->set_primary_key('objectid');
21
22 __PACKAGE__->has_many( collection_object => "DBICTest::Schema::CollectionObject",
23 { "foreign.object" => "self.objectid" }
24 );
25 __PACKAGE__->many_to_many( collections => collection_object => "collection" );
26
27 1;
+1
-0
t/lib/DBICTest/Schema.pm less more
2121 Year1999CDs
2222 CustomSql
2323 Money
24 TimestampPrimaryKey
2425 /,
2526 { 'DBICTest::Schema' => [qw/
2627 LinerNotes
+63
-63
t/lib/DBICTest/Stats.pm less more
0 package DBICTest::Stats;
1 use strict;
2 use warnings;
3
4 use base qw/DBIx::Class::Storage::Statistics/;
5
6 sub txn_begin {
7 my $self = shift;
8
9 $self->{'TXN_BEGIN'}++;
10 return $self->{'TXN_BEGIN'};
11 }
12
13 sub txn_rollback {
14 my $self = shift;
15
16 $self->{'TXN_ROLLBACK'}++;
17 return $self->{'TXN_ROLLBACK'};
18 }
19
20 sub txn_commit {
21 my $self = shift;
22
23 $self->{'TXN_COMMIT'}++;
24 return $self->{'TXN_COMMIT'};
25 }
26
27 sub svp_begin {
28 my ($self, $name) = @_;
29
30 $self->{'SVP_BEGIN'}++;
31 return $self->{'SVP_BEGIN'};
32 }
33
34 sub svp_release {
35 my ($self, $name) = @_;
36
37 $self->{'SVP_RELEASE'}++;
38 return $self->{'SVP_RELEASE'};
39 }
40
41 sub svp_rollback {
42 my ($self, $name) = @_;
43
44 $self->{'SVP_ROLLBACK'}++;
45 return $self->{'SVP_ROLLBACK'};
46 }
47
48 sub query_start {
49 my ($self, $string, @bind) = @_;
50
51 $self->{'QUERY_START'}++;
52 return $self->{'QUERY_START'};
53 }
54
55 sub query_end {
56 my ($self, $string) = @_;
57
58 $self->{'QUERY_END'}++;
59 return $self->{'QUERY_START'};
60 }
61
62 1;
0 package DBICTest::Stats;
1 use strict;
2 use warnings;
3
4 use base qw/DBIx::Class::Storage::Statistics/;
5
6 sub txn_begin {
7 my $self = shift;
8
9 $self->{'TXN_BEGIN'}++;
10 return $self->{'TXN_BEGIN'};
11 }
12
13 sub txn_rollback {
14 my $self = shift;
15
16 $self->{'TXN_ROLLBACK'}++;
17 return $self->{'TXN_ROLLBACK'};
18 }
19
20 sub txn_commit {
21 my $self = shift;
22
23 $self->{'TXN_COMMIT'}++;
24 return $self->{'TXN_COMMIT'};
25 }
26
27 sub svp_begin {
28 my ($self, $name) = @_;
29
30 $self->{'SVP_BEGIN'}++;
31 return $self->{'SVP_BEGIN'};
32 }
33
34 sub svp_release {
35 my ($self, $name) = @_;
36
37 $self->{'SVP_RELEASE'}++;
38 return $self->{'SVP_RELEASE'};
39 }
40
41 sub svp_rollback {
42 my ($self, $name) = @_;
43
44 $self->{'SVP_ROLLBACK'}++;
45 return $self->{'SVP_ROLLBACK'};
46 }
47
48 sub query_start {
49 my ($self, $string, @bind) = @_;
50
51 $self->{'QUERY_START'}++;
52 return $self->{'QUERY_START'};
53 }
54
55 sub query_end {
56 my ($self, $string) = @_;
57
58 $self->{'QUERY_END'}++;
59 return $self->{'QUERY_START'};
60 }
61
62 1;
+9
-9
t/lib/DBICTest/SyntaxErrorComponent1.pm less more
0 # belongs to t/run/90ensure_class_loaded.tl
1 package # hide from PAUSE
2 DBICTest::SyntaxErrorComponent1;
3 use warnings;
4 use strict;
5
6 my $str ''; # syntax error
7
8 1;
0 # belongs to t/run/90ensure_class_loaded.tl
1 package # hide from PAUSE
2 DBICTest::SyntaxErrorComponent1;
3 use warnings;
4 use strict;
5
6 my $str ''; # syntax error
7
8 1;
+9
-9
t/lib/DBICTest/SyntaxErrorComponent2.pm less more
0 # belongs to t/run/90ensure_class_loaded.tl
1 package # hide from PAUSE
2 DBICTest::SyntaxErrorComponent2;
3 use warnings;
4 use strict;
5
6 my $str ''; # syntax error
7
8 1;
0 # belongs to t/run/90ensure_class_loaded.tl
1 package # hide from PAUSE
2 DBICTest::SyntaxErrorComponent2;
3 use warnings;
4 use strict;
5
6 my $str ''; # syntax error
7
8 1;
+5
-5
t/lib/DBICTest/SyntaxErrorComponent3.pm less more
0 package DBICErrorTest::SyntaxError;
1
2 use strict;
3
4 I'm a syntax error!
0 package DBICErrorTest::SyntaxError;
1
2 use strict;
3
4 I'm a syntax error!
+7
-7
t/lib/DBICTest/Taint/Classes/Auto.pm less more
0 package # hide from PAUSE
1 DBICTest::Taint::Classes::Auto;
2
3 use base 'DBIx::Class::Core';
4 __PACKAGE__->table('test');
5
6 1;
0 package # hide from PAUSE
1 DBICTest::Taint::Classes::Auto;
2
3 use base 'DBIx::Class::Core';
4 __PACKAGE__->table('test');
5
6 1;
+7
-7
t/lib/DBICTest/Taint/Classes/Manual.pm less more
0 package # hide from PAUSE
1 DBICTest::Taint::Classes::Manual;
2
3 use base 'DBIx::Class::Core';
4 __PACKAGE__->table('test');
5
6 1;
0 package # hide from PAUSE
1 DBICTest::Taint::Classes::Manual;
2
3 use base 'DBIx::Class::Core';
4 __PACKAGE__->table('test');
5
6 1;
+7
-7
t/lib/DBICTest/Taint/Namespaces/Result/Test.pm less more
0 package # hide from PAUSE
1 DBICTest::Taint::Namespaces::Result::Test;
2
3 use base 'DBIx::Class::Core';
4 __PACKAGE__->table('test');
5
6 1;
0 package # hide from PAUSE
1 DBICTest::Taint::Namespaces::Result::Test;
2
3 use base 'DBIx::Class::Core';
4 __PACKAGE__->table('test');
5
6 1;
+25
-14
t/lib/sqlite.sql less more
00 --
11 -- Created by SQL::Translator::Producer::SQLite
2 -- Created on Sat Jan 30 19:18:55 2010
2 -- Created on Mon Mar 22 11:08:33 2010
33 --
44 ;
55
3434 );
3535
3636 --
37 -- Table: employee
38 --
39 CREATE TABLE employee (
40 employee_id INTEGER PRIMARY KEY NOT NULL,
41 position integer NOT NULL,
42 group_id integer,
43 group_id_2 integer,
44 group_id_3 integer,
45 name varchar(100)
46 );
47
48 --
4937 -- Table: encoded
5038 --
5139 CREATE TABLE encoded (
5846 --
5947 CREATE TABLE event (
6048 id INTEGER PRIMARY KEY NOT NULL,
61 starts_at datetime NOT NULL,
49 starts_at date NOT NULL,
6250 created_on timestamp NOT NULL,
6351 varchar_date varchar(20),
6452 varchar_datetime varchar(20),
180168 );
181169
182170 --
171 -- Table: timestamp_primary_key_test
172 --
173 CREATE TABLE timestamp_primary_key_test (
174 id timestamp NOT NULL DEFAULT current_timestamp,
175 PRIMARY KEY (id)
176 );
177
178 --
183179 -- Table: treelike
184180 --
185181 CREATE TABLE treelike (
250246 );
251247
252248 CREATE INDEX books_idx_owner ON books (owner);
249
250 --
251 -- Table: employee
252 --
253 CREATE TABLE employee (
254 employee_id INTEGER PRIMARY KEY NOT NULL,
255 position integer NOT NULL,
256 group_id integer,
257 group_id_2 integer,
258 group_id_3 integer,
259 name varchar(100),
260 encoded integer
261 );
262
263 CREATE INDEX employee_idx_encoded ON employee (encoded);
253264
254265 --
255266 -- Table: forceforeign
+34
-34
t/multi_create/cd_single.t less more
0 use strict;
1 use warnings;
2
3 use Test::More qw(no_plan);
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 my $schema = DBICTest->init_schema();
9
10 eval {
11 my $cd = $schema->resultset('CD')->first;
12 my $track = $schema->resultset('Track')->new_result({
13 cd => $cd,
14 title => 'Multicreate rocks',
15 cd_single => {
16 artist => $cd->artist,
17 year => 2008,
18 title => 'Disemboweling MultiCreate',
19 },
20 });
21
22 isa_ok ($track, 'DBICTest::Track', 'Main Track object created');
23
24 $track->insert;
25
26 ok(1, 'created track');
27
28 is($track->title, 'Multicreate rocks', 'Correct Track title');
29
30 my $single = $track->cd_single;
31
32 ok($single->cdid, 'Got cdid');
33 };
0 use strict;
1 use warnings;
2
3 use Test::More qw(no_plan);
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 my $schema = DBICTest->init_schema();
9
10 eval {
11 my $cd = $schema->resultset('CD')->first;
12 my $track = $schema->resultset('Track')->new_result({
13 cd => $cd,
14 title => 'Multicreate rocks',
15 cd_single => {
16 artist => $cd->artist,
17 year => 2008,
18 title => 'Disemboweling MultiCreate',
19 },
20 });
21
22 isa_ok ($track, 'DBICTest::Track', 'Main Track object created');
23
24 $track->insert;
25
26 ok(1, 'created track');
27
28 is($track->title, 'Multicreate rocks', 'Correct Track title');
29
30 my $single = $track->cd_single;
31
32 ok($single->cdid, 'Got cdid');
33 };
+52
-52
t/multi_create/diamond.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} };
9
10 my $schema = DBICTest->init_schema();
11
12 mc_diag (<<'DG');
13 * Try a diamond multicreate
14
15 Artist -> has_many -> Artwork_to_Artist -> belongs_to
16 /
17 belongs_to <- CD <- belongs_to <- Artwork <-/
18 \
19 \-> Artist2
20
21 DG
22
23 lives_ok (sub {
24 $schema->resultset ('Artist')->create ({
25 name => 'The wooled wolf',
26 artwork_to_artist => [{
27 artwork => {
28 cd => {
29 title => 'Wool explosive',
30 year => 1999,
31 artist => { name => 'The black exploding sheep' },
32 }
33 }
34 }],
35 });
36
37 my $art2 = $schema->resultset ('Artist')->find ({ name => 'The black exploding sheep' });
38 ok ($art2, 'Second artist exists');
39
40 my $cd = $art2->cds->single;
41 is ($cd->title, 'Wool explosive', 'correctly created CD');
42
43 is_deeply (
44 [ $cd->artwork->artists->get_column ('name')->all ],
45 [ 'The wooled wolf' ],
46 'Artist correctly attached to artwork',
47 );
48
49 }, 'Diamond chain creation ok');
50
51 done_testing;
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} };
9
10 my $schema = DBICTest->init_schema();
11
12 mc_diag (<<'DG');
13 * Try a diamond multicreate
14
15 Artist -> has_many -> Artwork_to_Artist -> belongs_to
16 /
17 belongs_to <- CD <- belongs_to <- Artwork <-/
18 \
19 \-> Artist2
20
21 DG
22
23 lives_ok (sub {
24 $schema->resultset ('Artist')->create ({
25 name => 'The wooled wolf',
26 artwork_to_artist => [{
27 artwork => {
28 cd => {
29 title => 'Wool explosive',
30 year => 1999,
31 artist => { name => 'The black exploding sheep' },
32 }
33 }
34 }],
35 });
36
37 my $art2 = $schema->resultset ('Artist')->find ({ name => 'The black exploding sheep' });
38 ok ($art2, 'Second artist exists');
39
40 my $cd = $art2->cds->single;
41 is ($cd->title, 'Wool explosive', 'correctly created CD');
42
43 is_deeply (
44 [ $cd->artwork->artists->get_column ('name')->all ],
45 [ 'The wooled wolf' ],
46 'Artist correctly attached to artwork',
47 );
48
49 }, 'Diamond chain creation ok');
50
51 done_testing;
+88
-6
t/multi_create/in_memory.t less more
44 use Test::Exception;
55 use lib qw(t/lib);
66 use DBICTest;
7
8 plan tests => 12;
97
108 my $schema = DBICTest->init_schema();
119
4543 }
4644
4745 {
48 my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode 2: Insertion Boogaloo' });
49 my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave Loudly While Singing Off Key', 'year' => 1982});
46 my $new_cd = $schema->resultset('CD')->new ({ 'title' => 'Leave Loudly While Singing Off Key', 'year' => 1982});
47 my $new_artist = $schema->resultset("Artist")->new ({ 'name' => 'Depeche Mode 2: Insertion Boogaloo' });
48 $new_cd->artist ($new_artist);
49
5050 eval {
51 $new_related_cd->insert;
51 $new_cd->insert;
5252 };
5353 is ($@, '', 'CD insertion survives by inserting artist');
54 ok($new_cd->in_storage, 'new_related_cd inserted');
5455 ok($new_artist->in_storage, 'artist inserted');
55 ok($new_related_cd->in_storage, 'new_related_cd inserted');
56
57 my $retrieved_cd = $schema->resultset('CD')->find ({ 'title' => 'Leave Loudly While Singing Off Key'});
58 ok ($retrieved_cd, 'CD found in db');
59 is ($retrieved_cd->artist->name, 'Depeche Mode 2: Insertion Boogaloo', 'Correct artist attached to cd');
60 }
61
62 # test both sides of a 1:(1|0)
63 {
64 for my $reldir ('might_have', 'belongs_to') {
65 my $artist = $schema->resultset('Artist')->next;
66
67 my $new_track = $schema->resultset('Track')->new ({
68 title => "$reldir: First track of latest cd",
69 cd => {
70 title => "$reldir: Latest cd",
71 year => 2666,
72 artist => $artist,
73 },
74 });
75
76 my $new_single = $schema->resultset('CD')->new ({
77 artist => $artist,
78 title => "$reldir: Awesome first single",
79 year => 2666,
80 });
81
82 if ($reldir eq 'might_have') {
83 $new_track->cd_single ($new_single);
84 $new_track->insert;
85 }
86 else {
87 $new_single->single_track ($new_track);
88 $new_single->insert;
89 }
90
91 ok ($new_single->in_storage, "$reldir single inserted");
92 ok ($new_track->in_storage, "$reldir track inserted");
93
94 my $new_cds = $artist->search_related ('cds',
95 { year => '2666' },
96 { prefetch => 'tracks', order_by => 'cdid' }
97 );
98
99 is_deeply (
100 [$new_cds->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator'})->all ],
101 [
102 {
103 artist => 1,
104 cdid => 9,
105 genreid => undef,
106 single_track => undef,
107 title => "$reldir: Latest cd",
108 tracks => [
109 {
110 cd => 9,
111 last_updated_at => undef,
112 last_updated_on => undef,
113 position => 1,
114 small_dt => undef,
115 title => "$reldir: First track of latest cd",
116 trackid => 19
117 }
118 ],
119 year => 2666
120 },
121 {
122 artist => 1,
123 cdid => 10,
124 genreid => undef,
125 single_track => 19,
126 title => "$reldir: Awesome first single",
127 tracks => [],
128 year => 2666
129 },
130 ],
131 'Expected rows created in database',
132 );
133
134 $new_cds->delete_all;
135 }
56136 }
57137
58138 {
71151 ok($new_related_artist->in_storage, 'related artist inserted');
72152 ok($new_cd->in_storage, 'cd inserted');
73153 }
154
155 done_testing;
+103
-103
t/multi_create/multilev_single_PKeqFK.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} };
9
10 my $schema = DBICTest->init_schema();
11
12 mc_diag (<<'DG');
13 * Test a multilevel might-have/has_one with a PK == FK in the mid-table
14
15 CD -> might have -> Artwork
16 \- has_one -/ \
17 \
18 \-> has_many \
19 --> Artwork_to_Artist
20 /-> has_many /
21 /
22 Artist
23 DG
24
25 my $rels = {
26 has_one => 'mandatory_artwork',
27 might_have => 'artwork',
28 };
29
30 for my $type (qw/has_one might_have/) {
31
32 lives_ok (sub {
33
34 my $rel = $rels->{$type};
35 my $cd_title = "Simple test $type cd";
36
37 my $cd = $schema->resultset('CD')->create ({
38 artist => 1,
39 title => $cd_title,
40 year => 2008,
41 $rel => {},
42 });
43
44 isa_ok ($cd, 'DBICTest::CD', 'Main CD object created');
45 is ($cd->title, $cd_title, 'Correct CD title');
46
47 isa_ok ($cd->$rel, 'DBICTest::Artwork', 'Related artwork present');
48 ok ($cd->$rel->in_storage, 'And in storage');
49
50 }, "Simple $type creation");
51 }
52
53 my $artist_rs = $schema->resultset('Artist');
54 for my $type (qw/has_one might_have/) {
55
56 my $rel = $rels->{$type};
57
58 my $cd_title = "Test $type cd";
59 my $artist_names = [ map { "Artist via $type $_" } (1, 2) ];
60
61 my $someartist = $artist_rs->next;
62
63 lives_ok (sub {
64 my $cd = $schema->resultset('CD')->create ({
65 artist => $someartist,
66 title => $cd_title,
67 year => 2008,
68 $rel => {
69 artwork_to_artist => [ map {
70 { artist => { name => $_ } }
71 } (@$artist_names)
72 ]
73 },
74 });
75
76
77 isa_ok ($cd, 'DBICTest::CD', 'Main CD object created');
78 is ($cd->title, $cd_title, 'Correct CD title');
79
80 my $art_obj = $cd->$rel;
81 ok ($art_obj->has_column_loaded ('cd_id'), 'PK/FK present on artwork object');
82 is ($art_obj->artists->count, 2, 'Correct artwork creator count via the new object');
83 is_deeply (
84 [ sort $art_obj->artists->get_column ('name')->all ],
85 $artist_names,
86 'Artists named correctly when queried via object',
87 );
88
89 my $artwork = $schema->resultset('Artwork')->search (
90 { 'cd.title' => $cd_title },
91 { join => 'cd' },
92 )->single;
93 is ($artwork->artists->count, 2, 'Correct artwork creator count via a new search');
94 is_deeply (
95 [ sort $artwork->artists->get_column ('name')->all ],
96 $artist_names,
97 'Artists named correctly queried via a new search',
98 );
99 }, "multilevel $type with a PK == FK in the $type/has_many table ok");
100 }
101
102 done_testing;
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 sub mc_diag { diag (@_) if $ENV{DBIC_MULTICREATE_DEBUG} };
9
10 my $schema = DBICTest->init_schema();
11
12 mc_diag (<<'DG');
13 * Test a multilevel might-have/has_one with a PK == FK in the mid-table
14
15 CD -> might have -> Artwork
16 \- has_one -/ \
17 \
18 \-> has_many \
19 --> Artwork_to_Artist
20 /-> has_many /
21 /
22 Artist
23 DG
24
25 my $rels = {
26 has_one => 'mandatory_artwork',
27 might_have => 'artwork',
28 };
29
30 for my $type (qw/has_one might_have/) {
31
32 lives_ok (sub {
33
34 my $rel = $rels->{$type};
35 my $cd_title = "Simple test $type cd";
36
37 my $cd = $schema->resultset('CD')->create ({
38 artist => 1,
39 title => $cd_title,
40 year => 2008,
41 $rel => {},
42 });
43
44 isa_ok ($cd, 'DBICTest::CD', 'Main CD object created');
45 is ($cd->title, $cd_title, 'Correct CD title');
46
47 isa_ok ($cd->$rel, 'DBICTest::Artwork', 'Related artwork present');
48 ok ($cd->$rel->in_storage, 'And in storage');
49
50 }, "Simple $type creation");
51 }
52
53 my $artist_rs = $schema->resultset('Artist');
54 for my $type (qw/has_one might_have/) {
55
56 my $rel = $rels->{$type};
57
58 my $cd_title = "Test $type cd";
59 my $artist_names = [ map { "Artist via $type $_" } (1, 2) ];
60
61 my $someartist = $artist_rs->next;
62
63 lives_ok (sub {
64 my $cd = $schema->resultset('CD')->create ({
65 artist => $someartist,
66 title => $cd_title,
67 year => 2008,
68 $rel => {
69 artwork_to_artist => [ map {
70 { artist => { name => $_ } }
71 } (@$artist_names)
72 ]
73 },
74 });
75
76
77 isa_ok ($cd, 'DBICTest::CD', 'Main CD object created');
78 is ($cd->title, $cd_title, 'Correct CD title');
79
80 my $art_obj = $cd->$rel;
81 ok ($art_obj->has_column_loaded ('cd_id'), 'PK/FK present on artwork object');
82 is ($art_obj->artists->count, 2, 'Correct artwork creator count via the new object');
83 is_deeply (
84 [ sort $art_obj->artists->get_column ('name')->all ],
85 $artist_names,
86 'Artists named correctly when queried via object',
87 );
88
89 my $artwork = $schema->resultset('Artwork')->search (
90 { 'cd.title' => $cd_title },
91 { join => 'cd' },
92 )->single;
93 is ($artwork->artists->count, 2, 'Correct artwork creator count via a new search');
94 is_deeply (
95 [ sort $artwork->artists->get_column ('name')->all ],
96 $artist_names,
97 'Artists named correctly queried via a new search',
98 );
99 }, "multilevel $type with a PK == FK in the $type/has_many table ok");
100 }
101
102 done_testing;
+228
-228
t/multi_create/torture.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 plan tests => 23;
9
10 # an insane multicreate
11 # (should work, despite the fact that no one will probably use it this way)
12
13 my $schema = DBICTest->init_schema();
14
15 # first count how many rows do we initially have
16 my $counts;
17 $counts->{$_} = $schema->resultset($_)->count for qw/Artist CD Genre Producer Tag/;
18
19 # do the crazy create
20 eval {
21 $schema->resultset('CD')->create ({
22 artist => {
23 name => 'james',
24 },
25 title => 'Greatest hits 1',
26 year => '2012',
27 genre => {
28 name => '"Greatest" collections',
29 },
30 tags => [
31 { tag => 'A' },
32 { tag => 'B' },
33 ],
34 cd_to_producer => [
35 {
36 producer => {
37 name => 'bob',
38 producer_to_cd => [
39 {
40 cd => {
41 artist => {
42 name => 'lars',
43 cds => [
44 {
45 title => 'Greatest hits 2',
46 year => 2012,
47 genre => {
48 name => '"Greatest" collections',
49 },
50 tags => [
51 { tag => 'A' },
52 { tag => 'B' },
53 ],
54 # This cd is created via artist so it doesn't know about producers
55 cd_to_producer => [
56 { producer => { name => 'bob' } },
57 { producer => { name => 'paul' } },
58 { producer => {
59 name => 'flemming',
60 producer_to_cd => [
61 { cd => {
62 artist => {
63 name => 'kirk',
64 cds => [
65 {
66 title => 'Greatest hits 3',
67 year => 2012,
68 genre => {
69 name => '"Greatest" collections',
70 },
71 tags => [
72 { tag => 'A' },
73 { tag => 'B' },
74 ],
75 },
76 {
77 title => 'Greatest hits 4',
78 year => 2012,
79 genre => {
80 name => '"Greatest" collections2',
81 },
82 tags => [
83 { tag => 'A' },
84 { tag => 'B' },
85 ],
86 },
87 ],
88 },
89 title => 'Greatest hits 5',
90 year => 2013,
91 genre => {
92 name => '"Greatest" collections2',
93 },
94 }},
95 ],
96 }},
97 ],
98 },
99 ],
100 },
101 title => 'Greatest hits 6',
102 year => 2012,
103 genre => {
104 name => '"Greatest" collections',
105 },
106 tags => [
107 { tag => 'A' },
108 { tag => 'B' },
109 ],
110 },
111 },
112 {
113 cd => {
114 artist => {
115 name => 'lars', # should already exist
116 # even though the artist 'name' is not uniquely constrained
117 # find_or_create will arguably DWIM
118 },
119 title => 'Greatest hits 7',
120 year => 2013,
121 },
122 },
123 ],
124 },
125 },
126 ],
127 });
128
129 is ($schema->resultset ('Artist')->count, $counts->{Artist} + 3, '3 new artists created');
130 is ($schema->resultset ('Genre')->count, $counts->{Genre} + 2, '2 additional genres created');
131 is ($schema->resultset ('Producer')->count, $counts->{Producer} + 3, '3 new producer');
132 is ($schema->resultset ('CD')->count, $counts->{CD} + 7, '7 new CDs');
133 is ($schema->resultset ('Tag')->count, $counts->{Tag} + 10, '10 new Tags');
134
135 my $cd_rs = $schema->resultset ('CD')
136 ->search ({ title => { -like => 'Greatest hits %' }}, { order_by => 'title'} );
137 is ($cd_rs->count, 7, '7 greatest hits created');
138
139 my $cds_2012 = $cd_rs->search ({ year => 2012});
140 is ($cds_2012->count, 5, '5 CDs created in 2012');
141
142 is (
143 $cds_2012->search(
144 { 'tags.tag' => { -in => [qw/A B/] } },
145 {
146 join => 'tags',
147 group_by => 'me.cdid',
148 having => 'count(me.cdid) = 2',
149 }
150 ),
151 5,
152 'All 10 tags were pairwise distributed between 5 year-2012 CDs'
153 );
154
155 my $paul_prod = $cd_rs->search (
156 { 'producer.name' => 'paul'},
157 { join => { cd_to_producer => 'producer' } }
158 );
159 is ($paul_prod->count, 1, 'Paul had 1 production');
160 my $pauls_cd = $paul_prod->single;
161 is ($pauls_cd->cd_to_producer->count, 3, 'Paul had two co-producers');
162 is (
163 $pauls_cd->search_related ('cd_to_producer',
164 { 'producer.name' => 'flemming'},
165 { join => 'producer' }
166 )->count,
167 1,
168 'The second producer is flemming',
169 );
170
171 my $kirk_cds = $cd_rs->search ({ 'artist.name' => 'kirk' }, { join => 'artist' });
172 is ($kirk_cds, 3, 'Kirk had 3 CDs');
173 is (
174 $kirk_cds->search (
175 { 'cd_to_producer.cd' => { '!=', undef } },
176 { join => 'cd_to_producer' },
177 ),
178 1,
179 'Kirk had a producer only on one cd',
180 );
181
182 my $lars_cds = $cd_rs->search ({ 'artist.name' => 'lars' }, { join => 'artist' });
183 is ($lars_cds->count, 3, 'Lars had 3 CDs');
184 is (
185 $lars_cds->search (
186 { 'cd_to_producer.cd' => undef },
187 { join => 'cd_to_producer' },
188 ),
189 0,
190 'Lars always had a producer',
191 );
192 is (
193 $lars_cds->search_related ('cd_to_producer',
194 { 'producer.name' => 'flemming'},
195 { join => 'producer' }
196 )->count,
197 1,
198 'Lars produced 1 CD with flemming',
199 );
200 is (
201 $lars_cds->search_related ('cd_to_producer',
202 { 'producer.name' => 'bob'},
203 { join => 'producer' }
204 )->count,
205 3,
206 'Lars produced 3 CDs with bob',
207 );
208
209 my $bob_prod = $cd_rs->search (
210 { 'producer.name' => 'bob'},
211 { join => { cd_to_producer => 'producer' } }
212 );
213 is ($bob_prod->count, 4, 'Bob produced a total of 4 CDs');
214 ok ($bob_prod->find ({ title => 'Greatest hits 1'}), '1st Bob production name correct');
215 ok ($bob_prod->find ({ title => 'Greatest hits 6'}), '2nd Bob production name correct');
216 ok ($bob_prod->find ({ title => 'Greatest hits 2'}), '3rd Bob production name correct');
217 ok ($bob_prod->find ({ title => 'Greatest hits 7'}), '4th Bob production name correct');
218
219 is (
220 $bob_prod->search ({ 'artist.name' => 'james' }, { join => 'artist' })->count,
221 1,
222 "Bob produced james' only CD",
223 );
224 };
225 diag $@ if $@;
226
227 1;
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 plan tests => 23;
9
10 # an insane multicreate
11 # (should work, despite the fact that no one will probably use it this way)
12
13 my $schema = DBICTest->init_schema();
14
15 # first count how many rows do we initially have
16 my $counts;
17 $counts->{$_} = $schema->resultset($_)->count for qw/Artist CD Genre Producer Tag/;
18
19 # do the crazy create
20 eval {
21 $schema->resultset('CD')->create ({
22 artist => {
23 name => 'james',
24 },
25 title => 'Greatest hits 1',
26 year => '2012',
27 genre => {
28 name => '"Greatest" collections',
29 },
30 tags => [
31 { tag => 'A' },
32 { tag => 'B' },
33 ],
34 cd_to_producer => [
35 {
36 producer => {
37 name => 'bob',
38 producer_to_cd => [
39 {
40 cd => {
41 artist => {
42 name => 'lars',
43 cds => [
44 {
45 title => 'Greatest hits 2',
46 year => 2012,
47 genre => {
48 name => '"Greatest" collections',
49 },
50 tags => [
51 { tag => 'A' },
52 { tag => 'B' },
53 ],
54 # This cd is created via artist so it doesn't know about producers
55 cd_to_producer => [
56 { producer => { name => 'bob' } },
57 { producer => { name => 'paul' } },
58 { producer => {
59 name => 'flemming',
60 producer_to_cd => [
61 { cd => {
62 artist => {
63 name => 'kirk',
64 cds => [
65 {
66 title => 'Greatest hits 3',
67 year => 2012,
68 genre => {
69 name => '"Greatest" collections',
70 },
71 tags => [
72 { tag => 'A' },
73 { tag => 'B' },
74 ],
75 },
76 {
77 title => 'Greatest hits 4',
78 year => 2012,
79 genre => {
80 name => '"Greatest" collections2',
81 },
82 tags => [
83 { tag => 'A' },
84 { tag => 'B' },
85 ],
86 },
87 ],
88 },
89 title => 'Greatest hits 5',
90 year => 2013,
91 genre => {
92 name => '"Greatest" collections2',
93 },
94 }},
95 ],
96 }},
97 ],
98 },
99 ],
100 },
101 title => 'Greatest hits 6',
102 year => 2012,
103 genre => {
104 name => '"Greatest" collections',
105 },
106 tags => [
107 { tag => 'A' },
108 { tag => 'B' },
109 ],
110 },
111 },
112 {
113 cd => {
114 artist => {
115 name => 'lars', # should already exist
116 # even though the artist 'name' is not uniquely constrained
117 # find_or_create will arguably DWIM
118 },
119 title => 'Greatest hits 7',
120 year => 2013,
121 },
122 },
123 ],
124 },
125 },
126 ],
127 });
128
129 is ($schema->resultset ('Artist')->count, $counts->{Artist} + 3, '3 new artists created');
130 is ($schema->resultset ('Genre')->count, $counts->{Genre} + 2, '2 additional genres created');
131 is ($schema->resultset ('Producer')->count, $counts->{Producer} + 3, '3 new producer');
132 is ($schema->resultset ('CD')->count, $counts->{CD} + 7, '7 new CDs');
133 is ($schema->resultset ('Tag')->count, $counts->{Tag} + 10, '10 new Tags');
134
135 my $cd_rs = $schema->resultset ('CD')
136 ->search ({ title => { -like => 'Greatest hits %' }}, { order_by => 'title'} );
137 is ($cd_rs->count, 7, '7 greatest hits created');
138
139 my $cds_2012 = $cd_rs->search ({ year => 2012});
140 is ($cds_2012->count, 5, '5 CDs created in 2012');
141
142 is (
143 $cds_2012->search(
144 { 'tags.tag' => { -in => [qw/A B/] } },
145 {
146 join => 'tags',
147 group_by => 'me.cdid',
148 having => 'count(me.cdid) = 2',
149 }
150 ),
151 5,
152 'All 10 tags were pairwise distributed between 5 year-2012 CDs'
153 );
154
155 my $paul_prod = $cd_rs->search (
156 { 'producer.name' => 'paul'},
157 { join => { cd_to_producer => 'producer' } }
158 );
159 is ($paul_prod->count, 1, 'Paul had 1 production');
160 my $pauls_cd = $paul_prod->single;
161 is ($pauls_cd->cd_to_producer->count, 3, 'Paul had two co-producers');
162 is (
163 $pauls_cd->search_related ('cd_to_producer',
164 { 'producer.name' => 'flemming'},
165 { join => 'producer' }
166 )->count,
167 1,
168 'The second producer is flemming',
169 );
170
171 my $kirk_cds = $cd_rs->search ({ 'artist.name' => 'kirk' }, { join => 'artist' });
172 is ($kirk_cds, 3, 'Kirk had 3 CDs');
173 is (
174 $kirk_cds->search (
175 { 'cd_to_producer.cd' => { '!=', undef } },
176 { join => 'cd_to_producer' },
177 ),
178 1,
179 'Kirk had a producer only on one cd',
180 );
181
182 my $lars_cds = $cd_rs->search ({ 'artist.name' => 'lars' }, { join => 'artist' });
183 is ($lars_cds->count, 3, 'Lars had 3 CDs');
184 is (
185 $lars_cds->search (
186 { 'cd_to_producer.cd' => undef },
187 { join => 'cd_to_producer' },
188 ),
189 0,
190 'Lars always had a producer',
191 );
192 is (
193 $lars_cds->search_related ('cd_to_producer',
194 { 'producer.name' => 'flemming'},
195 { join => 'producer' }
196 )->count,
197 1,
198 'Lars produced 1 CD with flemming',
199 );
200 is (
201 $lars_cds->search_related ('cd_to_producer',
202 { 'producer.name' => 'bob'},
203 { join => 'producer' }
204 )->count,
205 3,
206 'Lars produced 3 CDs with bob',
207 );
208
209 my $bob_prod = $cd_rs->search (
210 { 'producer.name' => 'bob'},
211 { join => { cd_to_producer => 'producer' } }
212 );
213 is ($bob_prod->count, 4, 'Bob produced a total of 4 CDs');
214 ok ($bob_prod->find ({ title => 'Greatest hits 1'}), '1st Bob production name correct');
215 ok ($bob_prod->find ({ title => 'Greatest hits 6'}), '2nd Bob production name correct');
216 ok ($bob_prod->find ({ title => 'Greatest hits 2'}), '3rd Bob production name correct');
217 ok ($bob_prod->find ({ title => 'Greatest hits 7'}), '4th Bob production name correct');
218
219 is (
220 $bob_prod->search ({ 'artist.name' => 'james' }, { join => 'artist' })->count,
221 1,
222 "Bob produced james' only CD",
223 );
224 };
225 diag $@ if $@;
226
227 1;
+31
-31
t/ordered/cascade_delete.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 use POSIX qw(ceil);
9
10 my $schema = DBICTest->init_schema();
11
12 plan tests => 1;
13
14 {
15 my $artist = $schema->resultset ('Artist')->search ({}, { rows => 1})->single; # braindead sqlite
16 my $cd = $schema->resultset ('CD')->create ({
17 artist => $artist,
18 title => 'Get in order',
19 year => 2009,
20 tracks => [
21 { title => 'T1' },
22 { title => 'T2' },
23 { title => 'T3' },
24 ],
25 });
26
27 lives_ok (sub { $cd->delete}, "Cascade delete on ordered has_many doesn't bomb");
28 }
29
30 1;
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 use POSIX qw(ceil);
9
10 my $schema = DBICTest->init_schema();
11
12 plan tests => 1;
13
14 {
15 my $artist = $schema->resultset ('Artist')->search ({}, { rows => 1})->single; # braindead sqlite
16 my $cd = $schema->resultset ('CD')->create ({
17 artist => $artist,
18 title => 'Get in order',
19 year => 2009,
20 tracks => [
21 { title => 'T1' },
22 { title => 'T2' },
23 { title => 'T3' },
24 ],
25 });
26
27 lives_ok (sub { $cd->delete}, "Cascade delete on ordered has_many doesn't bomb");
28 }
29
30 1;
+27
-27
t/prefetch/attrs_untouched.t less more
0 use warnings;
1
2 use Test::More;
3 use Test::Exception;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 use Data::Dumper;
8 $Data::Dumper::Sortkeys = 1;
9
10 my $schema = DBICTest->init_schema();
11
12 plan tests => 3;
13
14 # bug in 0.07000 caused attr (join/prefetch) to be modifed by search
15 # so we check the search & attr arrays are not modified
16 my $search = { 'artist.name' => 'Caterwauler McCrae' };
17 my $attr = { prefetch => [ qw/artist liner_notes/ ],
18 order_by => 'me.cdid' };
19 my $search_str = Dumper($search);
20 my $attr_str = Dumper($attr);
21
22 my $rs = $schema->resultset("CD")->search($search, $attr);
23
24 is(Dumper($search), $search_str, 'Search hash untouched after search()');
25 is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()');
26 cmp_ok($rs + 0, '==', 3, 'Correct number of records returned');
0 use warnings;
1
2 use Test::More;
3 use Test::Exception;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 use Data::Dumper;
8 $Data::Dumper::Sortkeys = 1;
9
10 my $schema = DBICTest->init_schema();
11
12 plan tests => 3;
13
14 # bug in 0.07000 caused attr (join/prefetch) to be modifed by search
15 # so we check the search & attr arrays are not modified
16 my $search = { 'artist.name' => 'Caterwauler McCrae' };
17 my $attr = { prefetch => [ qw/artist liner_notes/ ],
18 order_by => 'me.cdid' };
19 my $search_str = Dumper($search);
20 my $attr_str = Dumper($attr);
21
22 my $rs = $schema->resultset("CD")->search($search, $attr);
23
24 is(Dumper($search), $search_str, 'Search hash untouched after search()');
25 is(Dumper($attr), $attr_str, 'Attribute hash untouched after search()');
26 cmp_ok($rs + 0, '==', 3, 'Correct number of records returned');
+0
-3
t/prefetch/via_search_related.t less more
3636
3737 }, 'search_related prefetch with order_by works');
3838
39 TODO: { local $TODO = 'Unqualified columns in where clauses can not be fixed without an SQLA rewrite' if SQL::Abstract->VERSION < 2;
4039 lives_ok ( sub {
4140 my $no_prefetch = $schema->resultset('Track')->search_related(cd =>
4241 {
6463 is($use_prefetch->count, $no_prefetch->count, 'counts with and without prefetch match');
6564
6665 }, 'search_related prefetch with condition referencing unqualified column of a joined table works');
67 }
68
6966
7067 lives_ok (sub {
7168 my $rs = $schema->resultset("Artwork")->search(undef, {distinct => 1})
+28
-28
t/relationship/after_update.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 2;
10
11 my $bookmark = $schema->resultset("Bookmark")->find(1);
12 my $link = $bookmark->link;
13 my $link_id = $link->id;
14
15 my $new_link = $schema->resultset("Link")->new({
16 id => 42,
17 url => "http://monstersarereal.com",
18 title => "monstersarereal.com"
19 });
20
21 # Changing a relationship by id rather than by object would cause
22 # old related_resultsets to be used.
23 $bookmark->link($new_link->id);
24 is $bookmark->link->id, $new_link->id;
25
26 $bookmark->update;
27 is $bookmark->link->id, $new_link->id;
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 2;
10
11 my $bookmark = $schema->resultset("Bookmark")->find(1);
12 my $link = $bookmark->link;
13 my $link_id = $link->id;
14
15 my $new_link = $schema->resultset("Link")->new({
16 id => 42,
17 url => "http://monstersarereal.com",
18 title => "monstersarereal.com"
19 });
20
21 # Changing a relationship by id rather than by object would cause
22 # old related_resultsets to be used.
23 $bookmark->link($new_link->id);
24 is $bookmark->link->id, $new_link->id;
25
26 $bookmark->update;
27 is $bookmark->link->id, $new_link->id;
+4
-0
t/relationship/core.t less more
7777 title => 'Hidden Track'
7878 } );
7979 $track->set_from_related( cd => $cd );
80
81 # has_relationship
82 ok(! $track->has_relationship( 'foo' ), 'Track has no relationship "foo"');
83 ok($track->has_relationship( 'disc' ), 'Track has relationship "disk"' );
8084
8185 is($track->disc->cdid, 4, 'set_from_related ok, including alternative accessor' );
8286
+28
-28
t/relationship/doesnt_exist.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 3;
10
11 my $bookmark = $schema->resultset("Bookmark")->find(1);
12 my $link = $bookmark->link;
13 my $link_id = $link->id;
14 ok $link->id;
15
16 $link->delete;
17 is $schema->resultset("Link")->search(id => $link_id)->count, 0,
18 "link $link_id was deleted";
19
20 # Get a fresh object with nothing cached
21 $bookmark = $schema->resultset("Bookmark")->find($bookmark->id);
22
23 # This would create a new link row if none existed
24 $bookmark->link;
25
26 is $schema->resultset("Link")->search(id => $link_id)->count, 0,
27 'accessor did not create a link object where there was none';
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 3;
10
11 my $bookmark = $schema->resultset("Bookmark")->find(1);
12 my $link = $bookmark->link;
13 my $link_id = $link->id;
14 ok $link->id;
15
16 $link->delete;
17 is $schema->resultset("Link")->search(id => $link_id)->count, 0,
18 "link $link_id was deleted";
19
20 # Get a fresh object with nothing cached
21 $bookmark = $schema->resultset("Bookmark")->find($bookmark->id);
22
23 # This would create a new link row if none existed
24 $bookmark->link;
25
26 is $schema->resultset("Link")->search(id => $link_id)->count, 0,
27 'accessor did not create a link object where there was none';
+21
-0
t/relationship/unresolvable.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5
6 use lib qw(t/lib);
7 use DBICTest;
8
9 my $schema = DBICTest->init_schema();
10
11 my $cd = $schema->resultset('CD')->search ({}, { columns => ['year'], rows => 1 })->single;
12
13
14 throws_ok (
15 sub { $cd->tracks },
16 qr/Unable to resolve relationship .+ column .+ not loaded from storage/,
17 'Correct exception on nonresolvable object-based condition'
18 );
19
20 done_testing;
+22
-22
t/resultset_class.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5 use Class::Inspector ();
6
7 unshift(@INC, './t/lib');
8 use lib 't/lib';
9 plan tests => 5;
10
11 use DBICTest;
12
13 is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICTest::BaseResultSet', 'default resultset class');
14 ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded');
15 DBICTest::Schema->source('Artist')->resultset_class('DBICNSTest::ResultSet::A');
16 ok(Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded automatically');
17 is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICNSTest::ResultSet::A', 'custom resultset class set');
18
19 my $schema = DBICTest->init_schema;
20 my $resultset = $schema->resultset('Artist')->search;
21 isa_ok($resultset, 'DBICNSTest::ResultSet::A', 'resultset is custom class');
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5 use Class::Inspector ();
6
7 unshift(@INC, './t/lib');
8 use lib 't/lib';
9 plan tests => 5;
10
11 use DBICTest;
12
13 is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICTest::BaseResultSet', 'default resultset class');
14 ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded');
15 DBICTest::Schema->source('Artist')->resultset_class('DBICNSTest::ResultSet::A');
16 ok(Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded automatically');
17 is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICNSTest::ResultSet::A', 'custom resultset class set');
18
19 my $schema = DBICTest->init_schema;
20 my $resultset = $schema->resultset('Artist')->search;
21 isa_ok($resultset, 'DBICNSTest::ResultSet::A', 'resultset is custom class');
+25
-25
t/resultset_overload.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 6;
10
11 {
12 my $rs = $schema->resultset("CD")->search({});
13
14 ok $rs->count;
15 is $rs, $rs->count, "resultset as number with results";
16 ok $rs, "resultset as boolean always true";
17 }
18
19 {
20 my $rs = $schema->resultset("CD")->search({ title => "Does not exist" });
21
22 ok !$rs->count;
23 is $rs, $rs->count, "resultset as number without results";
24 ok $rs, "resultset as boolean always true";
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 my $schema = DBICTest->init_schema();
8
9 plan tests => 6;
10
11 {
12 my $rs = $schema->resultset("CD")->search({});
13
14 ok $rs->count;
15 is $rs, $rs->count, "resultset as number with results";
16 ok $rs, "resultset as boolean always true";
17 }
18
19 {
20 my $rs = $schema->resultset("CD")->search({ title => "Does not exist" });
21
22 ok !$rs->count;
23 is $rs, $rs->count, "resultset as number without results";
24 ok $rs, "resultset as boolean always true";
2525 }⏎
+111
-0
t/row/inflate_result.t less more
0 package My::Schema::Result::User;
1
2 use strict;
3 use warnings;
4 use base qw/DBIx::Class::Core/;
5
6 ### Define what our admin class is, for ensure_class_loaded()
7 my $admin_class = __PACKAGE__ . '::Admin';
8
9 __PACKAGE__->table('users');
10
11 __PACKAGE__->add_columns(
12 qw/user_id email password
13 firstname lastname active
14 admin/
15 );
16
17 __PACKAGE__->set_primary_key('user_id');
18
19 sub inflate_result {
20 my $self = shift;
21 my $ret = $self->next::method(@_);
22 if ( $ret->admin ) { ### If this is an admin, rebless for extra functions
23 $self->ensure_class_loaded($admin_class);
24 bless $ret, $admin_class;
25 }
26 return $ret;
27 }
28
29 sub hello {
30 return "I am a regular user.";
31 }
32
33 package My::Schema::Result::User::Admin;
34
35 use strict;
36 use warnings;
37 use base qw/My::Schema::Result::User/;
38
39 # This line is important
40 __PACKAGE__->table('users');
41
42 sub hello {
43 return "I am an admin.";
44 }
45
46 sub do_admin_stuff {
47 return "I am doing admin stuff";
48 }
49
50 package My::Schema;
51
52 use base qw/DBIx::Class::Schema/;
53
54 My::Schema->register_class( Admin => 'My::Schema::Result::User::Admin' );
55 My::Schema->register_class( User => 'My::Schema::Result::User' );
56
57 1;
58
59 package main;
60
61 use lib qw(t/lib);
62 use DBICTest;
63
64 use Test::More;
65
66 my $user_data = {
67 email => 'someguy@place.com',
68 password => 'pass1',
69 admin => 0
70 };
71
72 my $admin_data = {
73 email => 'someadmin@adminplace.com',
74 password => 'pass2',
75 admin => 1
76 };
77
78 ok( my $schema = My::Schema->connection('dbi:SQLite:dbname=:memory:') );
79
80 ok(
81 $schema->storage->dbh->do(
82 "create table users (user_id, email, password, firstname, lastname, active, admin)"
83 )
84 );
85
86 TODO: {
87 local $TODO = 'New objects should also be inflated';
88 my $user = $schema->resultset('User')->create($user_data);
89 my $admin = $schema->resultset('User')->create($admin_data);
90
91 is( ref $user, 'My::Schema::Result::User' );
92 is( ref $admin, 'My::Schema::Result::User::Admin' );
93
94 }
95
96 my $user = $schema->resultset('User')->single($user_data);
97 my $admin = $schema->resultset('User')->single($admin_data);
98
99 is( ref $user, 'My::Schema::Result::User' );
100 is( ref $admin, 'My::Schema::Result::User::Admin' );
101
102 is( $user->password, 'pass1' );
103 is( $admin->password, 'pass2' );
104 is( $user->hello, 'I am a regular user.' );
105 is( $admin->hello, 'I am an admin.' );
106
107 ok( !$user->can('do_admin_stuff') );
108 ok( $admin->can('do_admin_stuff') );
109
110 done_testing;
+32
-0
t/row/pkless.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Exception;
5
6 use lib qw(t/lib);
7 use DBICTest;
8
9 my $schema = DBICTest->init_schema();
10
11 my $rs = $schema->resultset('NoPrimaryKey');
12
13 my $row = $rs->create ({ foo => 1, bar => 1, baz => 1 });
14
15 lives_ok (sub {
16 $row->foo (2);
17 }, 'Set on pkless object works');
18
19 is ($row->foo, 2, 'Column updated in-object');
20
21 dies_ok (sub {
22 $row->update ({baz => 3});
23 }, 'update() fails on pk-less object');
24
25 is ($row->foo, 2, 'Column not updated by failed update()');
26
27 dies_ok (sub {
28 $row->delete;
29 }, 'delete() fails on pk-less object');
30
31 done_testing;
+16
-0
t/sqlahacks/sqlite.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6 use DBIC::SqlMakerTest;
7
8 my $schema = DBICTest->init_schema;
9
10 is_same_sql_bind(
11 $schema->resultset('Artist')->search ({}, {for => 'update'})->as_query,
12 '(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me)', [],
13 );
14
15 done_testing;
+189
-189
t/storage/base.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Warn;
5 use lib qw(t/lib);
6 use DBICTest;
7 use Data::Dumper;
8
9 {
10 package DBICTest::ExplodingStorage::Sth;
11 use strict;
12 use warnings;
13
14 sub execute { die "Kablammo!" }
15
16 sub bind_param {}
17
18 package DBICTest::ExplodingStorage;
19 use strict;
20 use warnings;
21 use base 'DBIx::Class::Storage::DBI::SQLite';
22
23 my $count = 0;
24 sub sth {
25 my ($self, $sql) = @_;
26 return bless {}, "DBICTest::ExplodingStorage::Sth" unless $count++;
27 return $self->next::method($sql);
28 }
29
30 sub connected {
31 return 0 if $count == 1;
32 return shift->next::method(@_);
33 }
34 }
35
36 my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
37
38 is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite',
39 'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' );
40
41 my $storage = $schema->storage;
42 $storage->ensure_connected;
43
44 eval {
45 $schema->storage->throw_exception('test_exception_42');
46 };
47 like($@, qr/\btest_exception_42\b/, 'basic exception');
48
49 eval {
50 $schema->resultset('CD')->search_literal('broken +%$#$1')->all;
51 };
52 like($@, qr/prepare_cached failed/, 'exception via DBI->HandleError, etc');
53
54 bless $storage, "DBICTest::ExplodingStorage";
55 $schema->storage($storage);
56
57 eval {
58 $schema->resultset('Artist')->create({ name => "Exploding Sheep" });
59 };
60
61 is($@, "", "Exploding \$sth->execute was caught");
62
63 is(1, $schema->resultset('Artist')->search({name => "Exploding Sheep" })->count,
64 "And the STH was retired");
65
66
67 # testing various invocations of connect_info ([ ... ])
68
69 my $coderef = sub { 42 };
70 my $invocations = {
71 'connect_info ([ $d, $u, $p, \%attr, \%extra_attr])' => {
72 args => [
73 'foo',
74 'bar',
75 undef,
76 {
77 on_connect_do => [qw/a b c/],
78 PrintError => 0,
79 },
80 {
81 AutoCommit => 1,
82 on_disconnect_do => [qw/d e f/],
83 },
84 {
85 unsafe => 1,
86 auto_savepoint => 1,
87 },
88 ],
89 dbi_connect_info => [
90 'foo',
91 'bar',
92 undef,
93 {
94 %{$storage->_default_dbi_connect_attributes || {} },
95 PrintError => 0,
96 AutoCommit => 1,
97 },
98 ],
99 },
100
101 'connect_info ([ \%code, \%extra_attr ])' => {
102 args => [
103 $coderef,
104 {
105 on_connect_do => [qw/a b c/],
106 PrintError => 0,
107 AutoCommit => 1,
108 on_disconnect_do => [qw/d e f/],
109 },
110 {
111 unsafe => 1,
112 auto_savepoint => 1,
113 },
114 ],
115 dbi_connect_info => [
116 $coderef,
117 ],
118 },
119
120 'connect_info ([ \%attr ])' => {
121 args => [
122 {
123 on_connect_do => [qw/a b c/],
124 PrintError => 1,
125 AutoCommit => 0,
126 on_disconnect_do => [qw/d e f/],
127 user => 'bar',
128 dsn => 'foo',
129 },
130 {
131 unsafe => 1,
132 auto_savepoint => 1,
133 },
134 ],
135 dbi_connect_info => [
136 'foo',
137 'bar',
138 undef,
139 {
140 %{$storage->_default_dbi_connect_attributes || {} },
141 PrintError => 1,
142 AutoCommit => 0,
143 },
144 ],
145 },
146 'connect_info ([ \%attr_with_coderef ])' => {
147 args => [ {
148 dbh_maker => $coderef,
149 dsn => 'blah',
150 user => 'bleh',
151 on_connect_do => [qw/a b c/],
152 on_disconnect_do => [qw/d e f/],
153 } ],
154 dbi_connect_info => [
155 $coderef
156 ],
157 warn => qr/Attribute\(s\) 'dsn', 'user' in connect_info were ignored/,
158 },
159 };
160
161 for my $type (keys %$invocations) {
162
163 # we can not use a cloner portably because of the coderef
164 # so compare dumps instead
165 local $Data::Dumper::Sortkeys = 1;
166 my $arg_dump = Dumper ($invocations->{$type}{args});
167
168 warnings_exist (
169 sub { $storage->connect_info ($invocations->{$type}{args}) },
170 $invocations->{$type}{warn} || (),
171 'Warned about ignored attributes',
172 );
173
174 is ($arg_dump, Dumper ($invocations->{$type}{args}), "$type didn't modify passed arguments");
175
176 is_deeply ($storage->_dbi_connect_info, $invocations->{$type}{dbi_connect_info}, "$type produced correct _dbi_connect_info");
177 ok ( (not $storage->auto_savepoint and not $storage->unsafe), "$type correctly ignored extra hashref");
178
179 is_deeply (
180 [$storage->on_connect_do, $storage->on_disconnect_do ],
181 [ [qw/a b c/], [qw/d e f/] ],
182 "$type correctly parsed DBIC specific on_[dis]connect_do",
183 );
184 }
185
186 done_testing;
187
188 1;
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use Test::Warn;
5 use lib qw(t/lib);
6 use DBICTest;
7 use Data::Dumper;
8
9 {
10 package DBICTest::ExplodingStorage::Sth;
11 use strict;
12 use warnings;
13
14 sub execute { die "Kablammo!" }
15
16 sub bind_param {}
17
18 package DBICTest::ExplodingStorage;
19 use strict;
20 use warnings;
21 use base 'DBIx::Class::Storage::DBI::SQLite';
22
23 my $count = 0;
24 sub sth {
25 my ($self, $sql) = @_;
26 return bless {}, "DBICTest::ExplodingStorage::Sth" unless $count++;
27 return $self->next::method($sql);
28 }
29
30 sub connected {
31 return 0 if $count == 1;
32 return shift->next::method(@_);
33 }
34 }
35
36 my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
37
38 is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite',
39 'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' );
40
41 my $storage = $schema->storage;
42 $storage->ensure_connected;
43
44 eval {
45 $schema->storage->throw_exception('test_exception_42');
46 };
47 like($@, qr/\btest_exception_42\b/, 'basic exception');
48
49 eval {
50 $schema->resultset('CD')->search_literal('broken +%$#$1')->all;
51 };
52 like($@, qr/prepare_cached failed/, 'exception via DBI->HandleError, etc');
53
54 bless $storage, "DBICTest::ExplodingStorage";
55 $schema->storage($storage);
56
57 eval {
58 $schema->resultset('Artist')->create({ name => "Exploding Sheep" });
59 };
60
61 is($@, "", "Exploding \$sth->execute was caught");
62
63 is(1, $schema->resultset('Artist')->search({name => "Exploding Sheep" })->count,
64 "And the STH was retired");
65
66
67 # testing various invocations of connect_info ([ ... ])
68
69 my $coderef = sub { 42 };
70 my $invocations = {
71 'connect_info ([ $d, $u, $p, \%attr, \%extra_attr])' => {
72 args => [
73 'foo',
74 'bar',
75 undef,
76 {
77 on_connect_do => [qw/a b c/],
78 PrintError => 0,
79 },
80 {
81 AutoCommit => 1,
82 on_disconnect_do => [qw/d e f/],
83 },
84 {
85 unsafe => 1,
86 auto_savepoint => 1,
87 },
88 ],
89 dbi_connect_info => [
90 'foo',
91 'bar',
92 undef,
93 {
94 %{$storage->_default_dbi_connect_attributes || {} },
95 PrintError => 0,
96 AutoCommit => 1,
97 },
98 ],
99 },
100
101 'connect_info ([ \%code, \%extra_attr ])' => {
102 args => [
103 $coderef,
104 {
105 on_connect_do => [qw/a b c/],
106 PrintError => 0,
107 AutoCommit => 1,
108 on_disconnect_do => [qw/d e f/],
109 },
110 {
111 unsafe => 1,
112 auto_savepoint => 1,
113 },
114 ],
115 dbi_connect_info => [
116 $coderef,
117 ],
118 },
119
120 'connect_info ([ \%attr ])' => {
121 args => [
122 {
123 on_connect_do => [qw/a b c/],
124 PrintError => 1,
125 AutoCommit => 0,
126 on_disconnect_do => [qw/d e f/],
127 user => 'bar',
128 dsn => 'foo',
129 },
130 {
131 unsafe => 1,
132 auto_savepoint => 1,
133 },
134 ],
135 dbi_connect_info => [
136 'foo',
137 'bar',
138 undef,
139 {
140 %{$storage->_default_dbi_connect_attributes || {} },
141 PrintError => 1,
142 AutoCommit => 0,
143 },
144 ],
145 },
146 'connect_info ([ \%attr_with_coderef ])' => {
147 args => [ {
148 dbh_maker => $coderef,
149 dsn => 'blah',
150 user => 'bleh',
151 on_connect_do => [qw/a b c/],
152 on_disconnect_do => [qw/d e f/],
153 } ],
154 dbi_connect_info => [
155 $coderef
156 ],
157 warn => qr/Attribute\(s\) 'dsn', 'user' in connect_info were ignored/,
158 },
159 };
160
161 for my $type (keys %$invocations) {
162
163 # we can not use a cloner portably because of the coderef
164 # so compare dumps instead
165 local $Data::Dumper::Sortkeys = 1;
166 my $arg_dump = Dumper ($invocations->{$type}{args});
167
168 warnings_exist (
169 sub { $storage->connect_info ($invocations->{$type}{args}) },
170 $invocations->{$type}{warn} || (),
171 'Warned about ignored attributes',
172 );
173
174 is ($arg_dump, Dumper ($invocations->{$type}{args}), "$type didn't modify passed arguments");
175
176 is_deeply ($storage->_dbi_connect_info, $invocations->{$type}{dbi_connect_info}, "$type produced correct _dbi_connect_info");
177 ok ( (not $storage->auto_savepoint and not $storage->unsafe), "$type correctly ignored extra hashref");
178
179 is_deeply (
180 [$storage->on_connect_do, $storage->on_disconnect_do ],
181 [ [qw/a b c/], [qw/d e f/] ],
182 "$type correctly parsed DBIC specific on_[dis]connect_do",
183 );
184 }
185
186 done_testing;
187
188 1;
+32
-32
t/storage/dbh_do.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4
5 use Test::More tests => 8;
6 use lib qw(t/lib);
7 use DBICTest;
8
9
10 my $schema = DBICTest->init_schema();
11 my $storage = $schema->storage;
12
13 my $test_func = sub {
14 is $_[0], $storage;
15 is $_[1], $storage->dbh;
16 is $_[2], "foo";
17 is $_[3], "bar";
18 };
19
20 $storage->dbh_do(
21 $test_func,
22 "foo", "bar"
23 );
24
25 my $storage_class = ref $storage;
26 {
27 no strict 'refs';
28 *{$storage_class .'::__test_method'} = $test_func;
29 }
30 $storage->dbh_do("__test_method", "foo", "bar");
31
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4
5 use Test::More tests => 8;
6 use lib qw(t/lib);
7 use DBICTest;
8
9
10 my $schema = DBICTest->init_schema();
11 my $storage = $schema->storage;
12
13 my $test_func = sub {
14 is $_[0], $storage;
15 is $_[1], $storage->dbh;
16 is $_[2], "foo";
17 is $_[3], "bar";
18 };
19
20 $storage->dbh_do(
21 $test_func,
22 "foo", "bar"
23 );
24
25 my $storage_class = ref $storage;
26 {
27 no strict 'refs';
28 *{$storage_class .'::__test_method'} = $test_func;
29 }
30 $storage->dbh_do("__test_method", "foo", "bar");
31
3232 ⏎
+24
-24
t/storage/dbi_coderef.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 plan tests => 1;
8
9 # Set up the "usual" sqlite for DBICTest
10 my $normal_schema = DBICTest->init_schema( sqlite_use_file => 1 );
11
12 # Steal the dsn, which should be like 'dbi:SQLite:t/var/DBIxClass.db'
13 my $normal_dsn = $normal_schema->storage->_dbi_connect_info->[0];
14
15 # Make sure we have no active connection
16 $normal_schema->storage->disconnect;
17
18 # Make a new clone with a new connection, using a code reference
19 my $code_ref_schema = $normal_schema->connect(sub { DBI->connect($normal_dsn); });
20
21 # Stolen from 60core.t - this just verifies things seem to work at all
22 my @art = $code_ref_schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
23 cmp_ok(@art, '==', 3, "Three artists returned");
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 plan tests => 1;
8
9 # Set up the "usual" sqlite for DBICTest
10 my $normal_schema = DBICTest->init_schema( sqlite_use_file => 1 );
11
12 # Steal the dsn, which should be like 'dbi:SQLite:t/var/DBIxClass.db'
13 my $normal_dsn = $normal_schema->storage->_dbi_connect_info->[0];
14
15 # Make sure we have no active connection
16 $normal_schema->storage->disconnect;
17
18 # Make a new clone with a new connection, using a code reference
19 my $code_ref_schema = $normal_schema->connect(sub { DBI->connect($normal_dsn); });
20
21 # Stolen from 60core.t - this just verifies things seem to work at all
22 my @art = $code_ref_schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
23 cmp_ok(@art, '==', 3, "Three artists returned");
+19
-19
t/storage/disable_sth_caching.t less more
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 plan tests => 2;
8
9 # Set up the "usual" sqlite for DBICTest
10 my $schema = DBICTest->init_schema;
11
12 my $sth_one = $schema->storage->sth('SELECT 42');
13 my $sth_two = $schema->storage->sth('SELECT 42');
14 $schema->storage->disable_sth_caching(1);
15 my $sth_three = $schema->storage->sth('SELECT 42');
16
17 ok($sth_one == $sth_two, "statement caching works");
18 ok($sth_two != $sth_three, "disabling statement caching works");
0 use strict;
1 use warnings;
2
3 use Test::More;
4 use lib qw(t/lib);
5 use DBICTest;
6
7 plan tests => 2;
8
9 # Set up the "usual" sqlite for DBICTest
10 my $schema = DBICTest->init_schema;
11
12 my $sth_one = $schema->storage->sth('SELECT 42');
13 my $sth_two = $schema->storage->sth('SELECT 42');
14 $schema->storage->disable_sth_caching(1);
15 my $sth_three = $schema->storage->sth('SELECT 42');
16
17 ok($sth_one == $sth_two, "statement caching works");
18 ok($sth_two != $sth_three, "disabling statement caching works");
+89
-89
t/storage/on_connect_do.t less more
0 use strict;
1 use warnings;
2
3 use Test::More tests => 12;
4
5 use lib qw(t/lib);
6 use base 'DBICTest';
7 require DBI;
8
9
10 my $schema = DBICTest->init_schema(
11 no_connect => 1,
12 no_deploy => 1,
13 );
14
15 ok $schema->connection(
16 DBICTest->_database,
17 {
18 on_connect_do => 'CREATE TABLE TEST_empty (id INTEGER)',
19 },
20 ), 'connection()';
21
22 is_deeply (
23 $schema->storage->dbh->selectall_arrayref('SELECT * FROM TEST_empty'),
24 [],
25 'string version on_connect_do() worked'
26 );
27
28 $schema->storage->disconnect;
29
30 ok $schema->connection(
31 sub { DBI->connect(DBICTest->_database) },
32 {
33 on_connect_do => [
34 'CREATE TABLE TEST_empty (id INTEGER)',
35 [ 'INSERT INTO TEST_empty VALUES (?)', {}, 2 ],
36 \&insert_from_subref,
37 ],
38 on_disconnect_do =>
39 [\&check_exists, 'DROP TABLE TEST_empty', \&check_dropped],
40 },
41 ), 'connection()';
42
43 is_deeply (
44 $schema->storage->dbh->selectall_arrayref('SELECT * FROM TEST_empty'),
45 [ [ 2 ], [ 3 ], [ 7 ] ],
46 'on_connect_do() worked'
47 );
48 eval { $schema->storage->dbh->do('SELECT 1 FROM TEST_nonexistent'); };
49 ok $@, 'Searching for nonexistent table dies';
50
51 $schema->storage->disconnect();
52
53 my($connected, $disconnected, @cb_args);
54 ok $schema->connection(
55 DBICTest->_database,
56 {
57 on_connect_do => sub { $connected = 1; @cb_args = @_; },
58 on_disconnect_do => sub { $disconnected = 1 },
59 },
60 ), 'second connection()';
61 $schema->storage->dbh->do('SELECT 1');
62 ok $connected, 'on_connect_do() called after connect()';
63 ok ! $disconnected, 'on_disconnect_do() not called after connect()';
64 $schema->storage->disconnect();
65 ok $disconnected, 'on_disconnect_do() called after disconnect()';
66
67 isa_ok($cb_args[0], 'DBIx::Class::Storage', 'first arg to on_connect_do hook');
68
69 sub check_exists {
70 my $storage = shift;
71 ok $storage->dbh->do('SELECT 1 FROM TEST_empty'), 'Table still exists';
72 return;
73 }
74
75 sub check_dropped {
76 my $storage = shift;
77 eval { $storage->dbh->do('SELECT 1 FROM TEST_empty'); };
78 ok $@, 'Reading from dropped table fails';
79 return;
80 }
81
82 sub insert_from_subref {
83 my $storage = shift;
84 return [
85 [ 'INSERT INTO TEST_empty VALUES (?)', {}, 3 ],
86 'INSERT INTO TEST_empty VALUES (7)',
87 ];
88 }
0 use strict;
1 use warnings;
2
3 use Test::More tests => 12;
4
5 use lib qw(t/lib);
6 use base 'DBICTest';
7 require DBI;
8
9
10 my $schema = DBICTest->init_schema(
11 no_connect => 1,
12 no_deploy => 1,
13 );
14
15 ok $schema->connection(
16 DBICTest->_database,
17 {
18 on_connect_do => 'CREATE TABLE TEST_empty (id INTEGER)',
19 },
20 ), 'connection()';
21
22 is_deeply (
23 $schema->storage->dbh->selectall_arrayref('SELECT * FROM TEST_empty'),
24 [],
25 'string version on_connect_do() worked'
26 );
27
28 $schema->storage->disconnect;
29
30 ok $schema->connection(
31 sub { DBI->connect(DBICTest->_database) },
32 {
33 on_connect_do => [
34 'CREATE TABLE TEST_empty (id INTEGER)',
35 [ 'INSERT INTO TEST_empty VALUES (?)', {}, 2 ],
36 \&insert_from_subref,
37 ],
38 on_disconnect_do =>
39 [\&check_exists, 'DROP TABLE TEST_empty', \&check_dropped],
40 },
41 ), 'connection()';
42
43 is_deeply (
44 $schema->storage->dbh->selectall_arrayref('SELECT * FROM TEST_empty'),
45 [ [ 2 ], [ 3 ], [ 7 ] ],
46 'on_connect_do() worked'
47 );
48 eval { $schema->storage->dbh->do('SELECT 1 FROM TEST_nonexistent'); };
49 ok $@, 'Searching for nonexistent table dies';
50
51 $schema->storage->disconnect();
52
53 my($connected, $disconnected, @cb_args);
54 ok $schema->connection(
55 DBICTest->_database,
56 {
57 on_connect_do => sub { $connected = 1; @cb_args = @_; },
58 on_disconnect_do => sub { $disconnected = 1 },
59 },
60 ), 'second connection()';
61 $schema->storage->dbh->do('SELECT 1');
62 ok $connected, 'on_connect_do() called after connect()';
63 ok ! $disconnected, 'on_disconnect_do() not called after connect()';
64 $schema->storage->disconnect();
65 ok $disconnected, 'on_disconnect_do() called after disconnect()';
66
67 isa_ok($cb_args[0], 'DBIx::Class::Storage', 'first arg to on_connect_do hook');
68
69 sub check_exists {
70 my $storage = shift;
71 ok $storage->dbh->do('SELECT 1 FROM TEST_empty'), 'Table still exists';
72 return;
73 }
74
75 sub check_dropped {
76 my $storage = shift;
77 eval { $storage->dbh->do('SELECT 1 FROM TEST_empty'); };
78 ok $@, 'Reading from dropped table fails';
79 return;
80 }
81
82 sub insert_from_subref {
83 my $storage = shift;
84 return [
85 [ 'INSERT INTO TEST_empty VALUES (?)', {}, 3 ],
86 'INSERT INTO TEST_empty VALUES (7)',
87 ];
88 }
+73
-73
t/storage/reconnect.t less more
0 use strict;
1 use warnings;
2
3 use FindBin;
4 use File::Copy;
5 use Test::More;
6 use lib qw(t/lib);
7 use DBICTest;
8
9 plan tests => 6;
10
11 my $db_orig = "$FindBin::Bin/../var/DBIxClass.db";
12 my $db_tmp = "$db_orig.tmp";
13
14 # Set up the "usual" sqlite for DBICTest
15 my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
16
17 # Make sure we're connected by doing something
18 my @art = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
19 cmp_ok(@art, '==', 3, "Three artists returned");
20
21 # Disconnect the dbh, and be sneaky about it
22 # Also test if DBD::SQLite finaly knows how to ->disconnect properly
23 {
24 my $w;
25 local $SIG{__WARN__} = sub { $w = shift };
26 $schema->storage->_dbh->disconnect;
27 ok ($w !~ /active statement handles/, 'SQLite can disconnect properly');
28 }
29
30 # Try the operation again - What should happen here is:
31 # 1. S::DBI blindly attempts the SELECT, which throws an exception
32 # 2. It catches the exception, checks ->{Active}/->ping, sees the disconnected state...
33 # 3. Reconnects, and retries the operation
34 # 4. Success!
35 my @art_two = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
36 cmp_ok(@art_two, '==', 3, "Three artists returned");
37
38 ### Now, disconnect the dbh, and move the db file;
39 # create a new one and chmod 000 to prevent SQLite from connecting.
40 $schema->storage->_dbh->disconnect;
41 move( $db_orig, $db_tmp );
42 open DBFILE, '>', $db_orig;
43 print DBFILE 'THIS IS NOT A REAL DATABASE';
44 close DBFILE;
45 chmod 0000, $db_orig;
46
47 ### Try the operation again... it should fail, since there's no db
48 {
49 # Catch the DBI connection error
50 local $SIG{__WARN__} = sub {};
51 eval {
52 my @art_three = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
53 };
54 ok( $@, 'The operation failed' );
55 }
56
57 ### Now, move the db file back to the correct name
58 unlink($db_orig);
59 move( $db_tmp, $db_orig );
60
61 SKIP: {
62 skip "Cannot reconnect if original connection didn't fail", 2
63 if ( $@ =~ /encrypted or is not a database/ );
64
65 ### Try the operation again... this time, it should succeed
66 my @art_four;
67 eval {
68 @art_four = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
69 };
70 ok( !$@, 'The operation succeeded' );
71 cmp_ok( @art_four, '==', 3, "Three artists returned" );
72 }
0 use strict;
1 use warnings;
2
3 use FindBin;
4 use File::Copy;
5 use Test::More;
6 use lib qw(t/lib);
7 use DBICTest;
8
9 plan tests => 6;
10
11 my $db_orig = "$FindBin::Bin/../var/DBIxClass.db";
12 my $db_tmp = "$db_orig.tmp";
13
14 # Set up the "usual" sqlite for DBICTest
15 my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
16
17 # Make sure we're connected by doing something
18 my @art = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
19 cmp_ok(@art, '==', 3, "Three artists returned");
20
21 # Disconnect the dbh, and be sneaky about it
22 # Also test if DBD::SQLite finaly knows how to ->disconnect properly
23 {
24 my $w;
25 local $SIG{__WARN__} = sub { $w = shift };
26 $schema->storage->_dbh->disconnect;
27 ok ($w !~ /active statement handles/, 'SQLite can disconnect properly');
28 }
29
30 # Try the operation again - What should happen here is:
31 # 1. S::DBI blindly attempts the SELECT, which throws an exception
32 # 2. It catches the exception, checks ->{Active}/->ping, sees the disconnected state...
33 # 3. Reconnects, and retries the operation
34 # 4. Success!
35 my @art_two = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
36 cmp_ok(@art_two, '==', 3, "Three artists returned");
37
38 ### Now, disconnect the dbh, and move the db file;
39 # create a new one and chmod 000 to prevent SQLite from connecting.
40 $schema->storage->_dbh->disconnect;
41 move( $db_orig, $db_tmp );
42 open DBFILE, '>', $db_orig;
43 print DBFILE 'THIS IS NOT A REAL DATABASE';
44 close DBFILE;
45 chmod 0000, $db_orig;
46
47 ### Try the operation again... it should fail, since there's no db
48 {
49 # Catch the DBI connection error
50 local $SIG{__WARN__} = sub {};
51 eval {
52 my @art_three = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
53 };
54 ok( $@, 'The operation failed' );
55 }
56
57 ### Now, move the db file back to the correct name
58 unlink($db_orig);
59 move( $db_tmp, $db_orig );
60
61 SKIP: {
62 skip "Cannot reconnect if original connection didn't fail", 2
63 if ( $@ =~ /encrypted or is not a database/ );
64
65 ### Try the operation again... this time, it should succeed
66 my @art_four;
67 eval {
68 @art_four = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
69 };
70 ok( !$@, 'The operation succeeded' );
71 cmp_ok( @art_four, '==', 3, "Three artists returned" );
72 }
+104
-104
t/storage/stats.t less more
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 plan tests => 12;
7
8 use lib qw(t/lib);
9
10 use_ok('DBICTest');
11 my $schema = DBICTest->init_schema();
12
13 my $cbworks = 0;
14
15 $schema->storage->debugcb(sub { $cbworks = 1; });
16 $schema->storage->debug(0);
17 my $rs = $schema->resultset('CD')->search({});
18 $rs->count();
19 ok(!$cbworks, 'Callback not called with debug disabled');
20
21 $schema->storage->debug(1);
22
23 $rs->count();
24 ok($cbworks, 'Debug callback worked.');
25
26 my $prof = new DBIx::Test::Profiler();
27 $schema->storage->debugobj($prof);
28
29 # Test non-transaction calls.
30 $rs->count();
31 ok($prof->{'query_start'}, 'query_start called');
32 ok($prof->{'query_end'}, 'query_end called');
33 ok(!$prof->{'txn_begin'}, 'txn_begin not called');
34 ok(!$prof->{'txn_commit'}, 'txn_commit not called');
35
36 $prof->reset();
37
38 # Test transaction calls
39 $schema->txn_begin();
40 ok($prof->{'txn_begin'}, 'txn_begin called');
41
42 $rs = $schema->resultset('CD')->search({});
43 $rs->count();
44 ok($prof->{'query_start'}, 'query_start called');
45 ok($prof->{'query_end'}, 'query_end called');
46
47 $schema->txn_commit();
48 ok($prof->{'txn_commit'}, 'txn_commit called');
49
50 $prof->reset();
51
52 # Test a rollback
53 $schema->txn_begin();
54 $rs = $schema->resultset('CD')->search({});
55 $rs->count();
56 $schema->txn_rollback();
57 ok($prof->{'txn_rollback'}, 'txn_rollback called');
58
59 $schema->storage->debug(0);
60
61 package DBIx::Test::Profiler;
62 use strict;
63
64 sub new {
65 my $self = bless({});
66 }
67
68 sub query_start {
69 my $self = shift();
70 $self->{'query_start'} = 1;
71 }
72
73 sub query_end {
74 my $self = shift();
75 $self->{'query_end'} = 1;
76 }
77
78 sub txn_begin {
79 my $self = shift();
80 $self->{'txn_begin'} = 1;
81 }
82
83 sub txn_rollback {
84 my $self = shift();
85 $self->{'txn_rollback'} = 1;
86 }
87
88 sub txn_commit {
89 my $self = shift();
90 $self->{'txn_commit'} = 1;
91 }
92
93 sub reset {
94 my $self = shift();
95
96 $self->{'query_start'} = 0;
97 $self->{'query_end'} = 0;
98 $self->{'txn_begin'} = 0;
99 $self->{'txn_rollback'} = 0;
100 $self->{'txn_end'} = 0;
101 }
102
103 1;
0 #!/usr/bin/perl
1
2 use strict;
3 use warnings;
4 use Test::More;
5
6 plan tests => 12;
7
8 use lib qw(t/lib);
9
10 use_ok('DBICTest');
11 my $schema = DBICTest->init_schema();
12
13 my $cbworks = 0;
14
15 $schema->storage->debugcb(sub { $cbworks = 1; });
16 $schema->storage->debug(0);
17 my $rs = $schema->resultset('CD')->search({});
18 $rs->count();
19 ok(!$cbworks, 'Callback not called with debug disabled');
20
21 $schema->storage->debug(1);
22
23 $rs->count();
24 ok($cbworks, 'Debug callback worked.');
25
26 my $prof = new DBIx::Test::Profiler();
27 $schema->storage->debugobj($prof);
28
29 # Test non-transaction calls.
30 $rs->count();
31 ok($prof->{'query_start'}, 'query_start called');
32 ok($prof->{'query_end'}, 'query_end called');
33 ok(!$prof->{'txn_begin'}, 'txn_begin not called');
34 ok(!$prof->{'txn_commit'}, 'txn_commit not called');
35
36 $prof->reset();
37
38 # Test transaction calls
39 $schema->txn_begin();
40 ok($prof->{'txn_begin'}, 'txn_begin called');
41
42 $rs = $schema->resultset('CD')->search({});
43 $rs->count();
44 ok($prof->{'query_start'}, 'query_start called');
45 ok($prof->{'query_end'}, 'query_end called');
46
47 $schema->txn_commit();
48 ok($prof->{'txn_commit'}, 'txn_commit called');
49
50 $prof->reset();
51
52 # Test a rollback
53 $schema->txn_begin();
54 $rs = $schema->resultset('CD')->search({});
55 $rs->count();
56 $schema->txn_rollback();
57 ok($prof->{'txn_rollback'}, 'txn_rollback called');
58
59 $schema->storage->debug(0);
60
61 package DBIx::Test::Profiler;
62 use strict;
63
64 sub new {
65 my $self = bless({});
66 }
67
68 sub query_start {
69 my $self = shift();
70 $self->{'query_start'} = 1;
71 }
72
73 sub query_end {
74 my $self = shift();
75 $self->{'query_end'} = 1;
76 }
77
78 sub txn_begin {
79 my $self = shift();
80 $self->{'txn_begin'} = 1;
81 }
82
83 sub txn_rollback {
84 my $self = shift();
85 $self->{'txn_rollback'} = 1;
86 }
87
88 sub txn_commit {
89 my $self = shift();
90 $self->{'txn_commit'} = 1;
91 }
92
93 sub reset {
94 my $self = shift();
95
96 $self->{'query_start'} = 0;
97 $self->{'query_end'} = 0;
98 $self->{'txn_begin'} = 0;
99 $self->{'txn_rollback'} = 0;
100 $self->{'txn_end'} = 0;
101 }
102
103 1;
+119
-119
t/zzzzzzz_perl_perf_bug.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3 use Benchmark;
4 use lib qw(t/lib);
5 use DBICTest; # do not remove even though it is not used
6
7 # This is a rather unusual test.
8 # It does not test any aspect of DBIx::Class, but instead tests the
9 # perl installation this is being run under to see if it is:-
10 # 1. Potentially affected by a RH perl build bug
11 # 2. If so we do a performance test for the effect of
12 # that bug.
13 #
14 # You can skip these tests by setting the DBIC_NO_WARN_BAD_PERL env
15 # variable
16 #
17 # If these tests fail then please read the section titled
18 # Perl Performance Issues on Red Hat Systems in
19 # L<DBIx::Class::Manual::Troubleshooting>
20
21 plan skip_all =>
22 'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set'
23 if ( $ENV{DBIC_NO_WARN_BAD_PERL} );
24
25 plan skip_all => 'Skipping as AUTOMATED_TESTING is set'
26 if ( $ENV{AUTOMATED_TESTING} );
27
28 plan tests => 3;
29
30 ok( 1, 'Dummy - prevents next test timing out' );
31
32 # we do a benchmark test filling an array with blessed/overloaded references,
33 # against an array filled with array refs.
34 # On a sane system the ratio between these operation sets is 1 - 1.5,
35 # whereas a bugged system gives a ratio of around 8
36 # we therefore consider there to be a problem if the ratio is >= 2
37
38 my $results = timethese(
39 -1, # run for 1 CPU second each
40 {
41 no_bless => sub {
42 my %h;
43 for ( my $i = 0 ; $i < 10000 ; $i++ ) {
44 $h{$i} = [];
45 }
46 },
47 bless_overload => sub {
48 use overload q(<) => sub { };
49 my %h;
50 for ( my $i = 0 ; $i < 10000 ; $i++ ) {
51 $h{$i} = bless [] => 'main';
52 }
53 },
54 },
55 );
56
57 my $ratio = $results->{no_bless}->iters / $results->{bless_overload}->iters;
58
59 ok( ( $ratio < 2 ), 'Overload/bless performance acceptable' )
60 || diag(
61 "\n",
62 "This perl has a substantial slow down when handling large numbers\n",
63 "of blessed/overloaded objects. This can severely adversely affect\n",
64 "the performance of DBIx::Class programs. Please read the section\n",
65 "in the Troubleshooting POD documentation entitled\n",
66 "'Perl Performance Issues on Red Hat Systems'\n",
67 "As this is an extremely serious condition, the only way to skip\n",
68 "over this test is to --force the installation, or to look in the test\n",
69 "file " . __FILE__ . "\n",
70 );
71
72 # We will only check for the difference in bless handling (whether the
73 # bless applies to the reference or the referent) if we have seen a
74 # performance issue...
75
76 SKIP: {
77 skip "Not checking for bless handling as performance is OK", 1
78 if ( $ratio < 2 );
79
80 {
81 package # don't want this in PAUSE
82 TestRHBug;
83 use overload bool => sub { 0 }
84 }
85
86 sub _has_bug_34925 {
87 my %thing;
88 my $r1 = \%thing;
89 my $r2 = \%thing;
90 bless $r1 => 'TestRHBug';
91 return !!$r2;
92 }
93
94 sub _possibly_has_bad_overload_performance {
95 return $] < 5.008009 && !_has_bug_34925();
96 }
97
98 # If this next one fails then you almost certainly have a RH derived
99 # perl with the performance bug
100 # if this test fails, look at the section titled
101 # "Perl Performance Issues on Red Hat Systems" in
102 # L<DBIx::Class::Manual::Troubleshooting>
103 # Basically you may suffer severe performance issues when running
104 # DBIx::Class (and many other) modules. Look at getting a fixed
105 # version of the perl interpreter for your system.
106 #
107 ok( !_possibly_has_bad_overload_performance(),
108 'Checking whether bless applies to reference not object' )
109 || diag(
110 "\n",
111 "This perl is probably derived from a buggy Red Hat perl build\n",
112 "Please read the section in the Troubleshooting POD documentation\n",
113 "entitled 'Perl Performance Issues on Red Hat Systems'\n",
114 "As this is an extremely serious condition, the only way to skip\n",
115 "over this test is to --force the installation, or to look in the test\n",
116 "file " . __FILE__ . "\n",
117 );
118 }
0 use strict;
1 use warnings;
2 use Test::More;
3 use Benchmark;
4 use lib qw(t/lib);
5 use DBICTest; # do not remove even though it is not used
6
7 # This is a rather unusual test.
8 # It does not test any aspect of DBIx::Class, but instead tests the
9 # perl installation this is being run under to see if it is:-
10 # 1. Potentially affected by a RH perl build bug
11 # 2. If so we do a performance test for the effect of
12 # that bug.
13 #
14 # You can skip these tests by setting the DBIC_NO_WARN_BAD_PERL env
15 # variable
16 #
17 # If these tests fail then please read the section titled
18 # Perl Performance Issues on Red Hat Systems in
19 # L<DBIx::Class::Manual::Troubleshooting>
20
21 plan skip_all =>
22 'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set'
23 if ( $ENV{DBIC_NO_WARN_BAD_PERL} );
24
25 plan skip_all => 'Skipping as AUTOMATED_TESTING is set'
26 if ( $ENV{AUTOMATED_TESTING} );
27
28 plan tests => 3;
29
30 ok( 1, 'Dummy - prevents next test timing out' );
31
32 # we do a benchmark test filling an array with blessed/overloaded references,
33 # against an array filled with array refs.
34 # On a sane system the ratio between these operation sets is 1 - 1.5,
35 # whereas a bugged system gives a ratio of around 8
36 # we therefore consider there to be a problem if the ratio is >= 2
37
38 my $results = timethese(
39 -1, # run for 1 CPU second each
40 {
41 no_bless => sub {
42 my %h;
43 for ( my $i = 0 ; $i < 10000 ; $i++ ) {
44 $h{$i} = [];
45 }
46 },
47 bless_overload => sub {
48 use overload q(<) => sub { };
49 my %h;
50 for ( my $i = 0 ; $i < 10000 ; $i++ ) {
51 $h{$i} = bless [] => 'main';
52 }
53 },
54 },
55 );
56
57 my $ratio = $results->{no_bless}->iters / $results->{bless_overload}->iters;
58
59 ok( ( $ratio < 2 ), 'Overload/bless performance acceptable' )
60 || diag(
61 "\n",
62 "This perl has a substantial slow down when handling large numbers\n",
63 "of blessed/overloaded objects. This can severely adversely affect\n",
64 "the performance of DBIx::Class programs. Please read the section\n",
65 "in the Troubleshooting POD documentation entitled\n",
66 "'Perl Performance Issues on Red Hat Systems'\n",
67 "As this is an extremely serious condition, the only way to skip\n",
68 "over this test is to --force the installation, or to look in the test\n",
69 "file " . __FILE__ . "\n",
70 );
71
72 # We will only check for the difference in bless handling (whether the
73 # bless applies to the reference or the referent) if we have seen a
74 # performance issue...
75
76 SKIP: {
77 skip "Not checking for bless handling as performance is OK", 1
78 if ( $ratio < 2 );
79
80 {
81 package # don't want this in PAUSE
82 TestRHBug;
83 use overload bool => sub { 0 }
84 }
85
86 sub _has_bug_34925 {
87 my %thing;
88 my $r1 = \%thing;
89 my $r2 = \%thing;
90 bless $r1 => 'TestRHBug';
91 return !!$r2;
92 }
93
94 sub _possibly_has_bad_overload_performance {
95 return $] < 5.008009 && !_has_bug_34925();
96 }
97
98 # If this next one fails then you almost certainly have a RH derived
99 # perl with the performance bug
100 # if this test fails, look at the section titled
101 # "Perl Performance Issues on Red Hat Systems" in
102 # L<DBIx::Class::Manual::Troubleshooting>
103 # Basically you may suffer severe performance issues when running
104 # DBIx::Class (and many other) modules. Look at getting a fixed
105 # version of the perl interpreter for your system.
106 #
107 ok( !_possibly_has_bad_overload_performance(),
108 'Checking whether bless applies to reference not object' )
109 || diag(
110 "\n",
111 "This perl is probably derived from a buggy Red Hat perl build\n",
112 "Please read the section in the Troubleshooting POD documentation\n",
113 "entitled 'Perl Performance Issues on Red Hat Systems'\n",
114 "As this is an extremely serious condition, the only way to skip\n",
115 "over this test is to --force the installation, or to look in the test\n",
116 "file " . __FILE__ . "\n",
117 );
118 }