Profile: /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm

File	/wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm
Statements Executed	166927
Total Time	0.494640999999403 seconds

Subroutines — ordered by exclusive time
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
55549	3	2	0.47251	1.77419	DBIx::Class::Schema::	source
1	1	1	0.04208	0.05289	DBIx::Class::Schema::	connection
10	2	1	0.00057	0.00253	DBIx::Class::Schema::	register_source
1	1	1	0.00045	0.00221	DBIx::Class::Schema::	clone
1	1	1	0.00027	0.07372	DBIx::Class::Schema::	load_classes
5	1	1	5.4e-5	0.00145	DBIx::Class::Schema::	register_class
3	3	2	4.6e-5	0.00171	DBIx::Class::Schema::	resultset
9	1	1	4.6e-5	4.6e-5	DBIx::Class::Schema::	__ANON__[:288]
1	1	1	2.0e-5	0.05512	DBIx::Class::Schema::	connect
1	1	1	1.2e-5	4.9e-5	DBIx::Class::Schema::	sources
0	0	0	0	0	DBIx::Class::Schema::	BEGIN
0	0	0	0	0	DBIx::Class::Schema::	__ANON__[:437]
0	0	0	0	0	DBIx::Class::Schema::	__ANON__[:538]
0	0	0	0	0	DBIx::Class::Schema::	__ANON__[:592]
0	0	0	0	0	DBIx::Class::Schema::	__ANON__[:610]
0	0	0	0	0	DBIx::Class::Schema::	_expand_relative_name
0	0	0	0	0	DBIx::Class::Schema::	_map_namespaces
0	0	0	0	0	DBIx::Class::Schema::	_unregister_source
0	0	0	0	0	DBIx::Class::Schema::	class
0	0	0	0	0	DBIx::Class::Schema::	compose_connection
0	0	0	0	0	DBIx::Class::Schema::	compose_namespace
0	0	0	0	0	DBIx::Class::Schema::	create_ddl_dir
0	0	0	0	0	DBIx::Class::Schema::	dclone
0	0	0	0	0	DBIx::Class::Schema::	ddl_filename
0	0	0	0	0	DBIx::Class::Schema::	deploy
0	0	0	0	0	DBIx::Class::Schema::	freeze
0	0	0	0	0	DBIx::Class::Schema::	load_namespaces
0	0	0	0	0	DBIx::Class::Schema::	populate
0	0	0	0	0	DBIx::Class::Schema::	setup_connection_class
0	0	0	0	0	DBIx::Class::Schema::	thaw
0	0	0	0	0	DBIx::Class::Schema::	throw_exception
0	0	0	0	0	DBIx::Class::Schema::	txn_begin
0	0	0	0	0	DBIx::Class::Schema::	txn_commit
0	0	0	0	0	DBIx::Class::Schema::	txn_do
0	0	0	0	0	DBIx::Class::Schema::	txn_rollback

Line	Stmts.	Exclusive Time	Avg.	Code
1				package DBIx::Class::Schema;
2
3	3	3.2e-5	1.1e-5	use strict; # spent 9µs making 1 call to strict::import
4	3	4.2e-5	1.4e-5	use warnings; # spent 26µs making 1 call to warnings::import
5
6	3	0.00067	0.00022	use DBIx::Class::Exception; # spent 8µs making 1 call to import
7	3	3.3e-5	1.1e-5	use Carp::Clan qw/^DBIx::Class/; # spent 85µs making 1 call to Carp::Clan::import
8	3	2.8e-5	9.3e-6	use Scalar::Util qw/weaken/; # spent 37µs making 1 call to Exporter::import
9	3	3.9e-5	1.3e-5	use File::Spec; # spent 3µs making 1 call to import
10	1	0.00112	0.00112	require Module::Find;
11
12	3	0.00075	0.00025	use base qw/DBIx::Class/; # spent 19.7ms making 1 call to base::import, max recursion depth 1
13
14	1	1.4e-5	1.4e-5	__PACKAGE__->mk_classdata('class_mappings' => {}); # spent 282µs making 1 call to DBIx::Class::mk_classdata
15	1	8.0e-6	8.0e-6	__PACKAGE__->mk_classdata('source_registrations' => {}); # spent 154µs making 1 call to DBIx::Class::mk_classdata
16	1	7.0e-6	7.0e-6	__PACKAGE__->mk_classdata('storage_type' => '::DBI'); # spent 152µs making 1 call to DBIx::Class::mk_classdata
17	1	8.0e-6	8.0e-6	__PACKAGE__->mk_classdata('storage'); # spent 140µs making 1 call to DBIx::Class::mk_classdata
18	1	6.0e-6	6.0e-6	__PACKAGE__->mk_classdata('exception_action'); # spent 130µs making 1 call to DBIx::Class::mk_classdata
19	1	1.6e-5	1.6e-5	__PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} \|\| 0); # spent 151µs making 1 call to DBIx::Class::mk_classdata
20	1	7.0e-6	7.0e-6	__PACKAGE__->mk_classdata('default_resultset_attributes' => {}); # spent 156µs making 1 call to DBIx::Class::mk_classdata
21
22				=head1 NAME
23
24				DBIx::Class::Schema - composable schemas
25
26				=head1 SYNOPSIS
27
28				package Library::Schema;
29				use base qw/DBIx::Class::Schema/;
30
31				# load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
32				__PACKAGE__->load_classes(qw/CD Book DVD/);
33
34				package Library::Schema::CD;
35				use base qw/DBIx::Class/;
36				__PACKAGE__->load_components(qw/PK::Auto Core/); # for example
37				__PACKAGE__->table('cd');
38
39				# Elsewhere in your code:
40				my $schema1 = Library::Schema->connect(
41				$dsn,
42				$user,
43				$password,
44				{ AutoCommit => 0 },
45				);
46
47				my $schema2 = Library::Schema->connect($coderef_returning_dbh);
48
49				# fetch objects using Library::Schema::DVD
50				my $resultset = $schema1->resultset('DVD')->search( ... );
51				my @dvd_objects = $schema2->resultset('DVD')->search( ... );
52
53				=head1 DESCRIPTION
54
55				Creates database classes based on a schema. This is the recommended way to
56				use L<DBIx::Class> and allows you to use more than one concurrent connection
57				with your classes.
58
59				NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
60				carefully, as DBIx::Class does things a little differently. Note in
61				particular which module inherits off which.
62
63				=head1 METHODS
64
65				=head2 register_class
66
67				=over 4
68
69				=item Arguments: $moniker, $component_class
70
71				=back
72
73				Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
74				calling:
75
76				$schema->register_source($moniker, $component_class->result_source_instance);
77
78				=cut
79
80				# spent 1.45ms (54µs+1.39) within DBIx::Class::Schema::register_class which was called 5 times, avg 289µs/call: # 5 times (54µs+1.39ms) by DBIx::Class::Schema::load_classes at line 310, avg 289µs/call sub register_class {
81	10	7.7e-5	7.7e-6	my ($self, $moniker, $to_register) = @_;
82				$self->register_source($moniker => $to_register->result_source_instance); # spent 1.28ms making 5 calls to DBIx::Class::Schema::register_source, avg 256µs/call # spent 110µs making 5 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 22µs/call
83				}
84
85				=head2 register_source
86
87				=over 4
88
89				=item Arguments: $moniker, $result_source
90
91				=back
92
93				Registers the L<DBIx::Class::ResultSource> in the schema with the given
94				moniker.
95
96				=cut
97
98				# spent 2.53ms (569µs+1.96) within DBIx::Class::Schema::register_source which was called 10 times, avg 253µs/call: # 5 times (281µs+1.00ms) by DBIx::Class::Schema::register_class at line 82, avg 256µs/call # 5 times (288µs+958µs) by DBIx::Class::Schema::clone at line 809, avg 249µs/call sub register_source {
99	80	0.00062	7.8e-6	my ($self, $moniker, $source) = @_;
100
101				%$source = %{ $source->new( { %$source, source_name => $moniker }) }; # spent 356µs making 10 calls to DBIx::Class::ResultSource::new, avg 36µs/call
102
103				my %reg = %{$self->source_registrations}; # spent 284µs making 10 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 28µs/call
104				$reg{$moniker} = $source;
105				$self->source_registrations(\%reg); # spent 189µs making 10 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 19µs/call
106
107				$source->schema($self); # spent 120µs making 10 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 12µs/call
108
109				weaken($source->{schema}) if ref($self); # spent 21µs making 5 calls to Scalar::Util::weaken, avg 4µs/call
110	30	0.00022	7.2e-6	if ($source->result_class) { # spent 295µs making 10 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 29µs/call
111				my %map = %{$self->class_mappings}; # spent 253µs making 10 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 25µs/call
112				$map{$source->result_class} = $moniker; # spent 258µs making 10 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 26µs/call
113				$self->class_mappings(\%map); # spent 183µs making 10 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 18µs/call
114				}
115				}
116
117				sub _unregister_source {
118				my ($self, $moniker) = @_;
119				my %reg = %{$self->source_registrations};
120
121				my $source = delete $reg{$moniker};
122				$self->source_registrations(\%reg);
123				if ($source->result_class) {
124				my %map = %{$self->class_mappings};
125				delete $map{$source->result_class};
126				$self->class_mappings(\%map);
127				}
128				}
129
130				=head2 class
131
132				=over 4
133
134				=item Arguments: $moniker
135
136				=item Return Value: $classname
137
138				=back
139
140				Retrieves the result class name for the given moniker. For example:
141
142				my $class = $schema->class('CD');
143
144				=cut
145
146				sub class {
147				my ($self, $moniker) = @_;
148				return $self->source($moniker)->result_class;
149				}
150
151				=head2 source
152
153				=over 4
154
155				=item Arguments: $moniker
156
157				=item Return Value: $result_source
158
159				=back
160
161				my $source = $schema->source('Book');
162
163				Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
164
165				=cut
166
167				# spent 1.77s (473ms+1.30) within DBIx::Class::Schema::source which was called 55549 times, avg 32µs/call: # 55541 times (472ms+1.30s) by DBIx::Class::ResultSourceHandle::resolve at line 67 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceHandle.pm, avg 32µs/call # 5 times (46µs+93µs) by DBIx::Class::Schema::clone at line 807, avg 28µs/call # 3 times (28µs+98µs) by DBIx::Class::Schema::resultset at line 220, avg 42µs/call sub source {
168	166647	0.48587	2.9e-6	my ($self, $moniker) = @_;
169				my $sreg = $self->source_registrations; # spent 1.30s making 55549 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 23µs/call
170				return $sreg->{$moniker} if exists $sreg->{$moniker};
171
172				# if we got here, they probably passed a full class name
173				my $mapped = $self->class_mappings->{$moniker};
174				$self->throw_exception("Can't find source for ${moniker}")
175				unless $mapped && exists $sreg->{$mapped};
176				return $sreg->{$mapped};
177				}
178
179				=head2 sources
180
181				=over 4
182
183				=item Return Value: @source_monikers
184
185				=back
186
187				Returns the source monikers of all source registrations on this schema.
188				For example:
189
190				my @source_monikers = $schema->sources;
191
192				=cut
193
194	1	1.4e-5	1.4e-5	# spent 49µs (12+37) within DBIx::Class::Schema::sources which was called # once (12µs+37µs) by DBIx::Class::Schema::clone at line 806 sub sources { return keys %{shift->source_registrations}; } # spent 37µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
195
196				=head2 storage
197
198				my $storage = $schema->storage;
199
200				Returns the L<DBIx::Class::Storage> object for this Schema.
201
202				=head2 resultset
203
204				=over 4
205
206				=item Arguments: $moniker
207
208				=item Return Value: $result_set
209
210				=back
211
212				my $rs = $schema->resultset('DVD');
213
214				Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
215
216				=cut
217
218				# spent 1.71ms (46µs+1.66) within DBIx::Class::Schema::resultset which was called 3 times, avg 569µs/call: # once (20µs+934µs) at line 522 of /wise/base/deliv/dev/bin/getfix # once (17µs+433µs) by WISE::DB::FrameIndex::search at line 488 of /wise/base/deliv/dev/lib/perl/WISE/DB/FrameIndex.pm # once (9µs+294µs) by WISE::DB::FrameIndex::_neighbor_hp at line 502 of /wise/base/deliv/dev/lib/perl/WISE/DB/FrameIndex.pm sub resultset {
219	6	5.1e-5	8.5e-6	my ($self, $moniker) = @_;
220				return $self->source($moniker)->resultset; # spent 1.54ms making 3 calls to DBIx::Class::ResultSource::resultset, avg 512µs/call # spent 126µs making 3 calls to DBIx::Class::Schema::source, avg 42µs/call
221				}
222
223				=head2 load_classes
224
225				=over 4
226
227				=item Arguments: @classes?, { $namespace => [ @classes ] }+
228
229				=back
230
231				With no arguments, this method uses L<Module::Find> to find all classes under
232				the schema's namespace. Otherwise, this method loads the classes you specify
233				(using L<use>), and registers them (using L</"register_class">).
234
235				It is possible to comment out classes with a leading C<#>, but note that perl
236				will think it's a mistake (trying to use a comment in a qw list), so you'll
237				need to add C<no warnings 'qw';> before your load_classes call.
238
239				Example:
240
241				My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
242				# etc. (anything under the My::Schema namespace)
243
244				# loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
245				# not Other::Namespace::LinerNotes nor My::Schema::Track
246				My::Schema->load_classes(qw/ CD Artist #Track /, {
247				Other::Namespace => [qw/ Producer #LinerNotes /],
248				});
249
250				=cut
251
252				# spent 73.7ms (275µs+73.5) within DBIx::Class::Schema::load_classes which was called # once (275µs+73.5ms) at line 36 of /wise/base/deliv/dev/lib/perl/WISE/DB/FrameIndex.pm sub load_classes {
253	7	2.5e-5	3.6e-6	my ($class, @params) = @_;
254
255				my %comps_for;
256
257	1	3.0e-6	3.0e-6	if (@params) {
258				foreach my $param (@params) {
259	2	8.0e-6	4.0e-6	if (ref $param eq 'ARRAY') {
260				# filter out commented entries
261				my @modules = grep { $_ !~ /^#/ } @$param;
262
263				push (@{$comps_for{$class}}, @modules);
264				}
265				elsif (ref $param eq 'HASH') {
266				# more than one namespace possible
267				for my $comp ( keys %$param ) {
268				# filter out commented entries
269	7	1.8e-5	2.6e-6	my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
270
271				push (@{$comps_for{$comp}}, @modules);
272				}
273				}
274				else {
275				# filter out commented entries
276				push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
277				}
278				}
279				} else {
280				my @comp = map { substr $_, length "${class}::" }
281				Module::Find::findallmod($class);
282				$comps_for{$class} = \@comp;
283				}
284
285				my @to_register;
286				{
287	3	8.3e-5	2.8e-5	no warnings qw/redefine/; # spent 21µs making 1 call to warnings::unimport
288	11	2.1e-5	1.9e-6	# spent 46µs within DBIx::Class::Schema::__ANON__[/wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm:288] which was called 9 times, avg 5µs/call: # 9 times (46µs+0) by Class::C3::Componentised::_load_components at line 84 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/C3/Componentised.pm, avg 5µs/call local *Class::C3::reinitialize = sub { };
289				foreach my $prefix (keys %comps_for) {
290	1	4.0e-6	4.0e-6	foreach my $comp (@{$comps_for{$prefix}\|\|[]}) {
291	25	0.00021	8.3e-6	my $comp_class = "${prefix}::${comp}";
292				{ # try to untaint module name. mods where this fails
293				# are left alone so we don't have to change the old behavior
294	3	0.00073	0.00024	no locale; # localized \w doesn't untaint expression # spent 8µs making 1 call to locale::unimport
295	5	3.4e-5	6.8e-6	if ( $comp_class =~ m/^( (?:\w+::)* \w+ )$/x ) {
296				$comp_class = $1;
297				}
298				}
299				$class->ensure_class_loaded($comp_class); # spent 71.5ms making 5 calls to Class::C3::Componentised::ensure_class_loaded, avg 14.3ms/call
300
301				$comp = $comp_class->source_name \|\| $comp; # spent 508µs making 5 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 102µs/call
302				# $DB::single = 1;
303				push(@to_register, [ $comp, $comp_class ]);
304				}
305				}
306				}
307				Class::C3->reinitialize; # spent 9µs making 1 call to MRO::Compat::__ANON__[/wise/base/static/lib/perl5/site_perl/5.10.0/MRO/Compat.pm:41]
308
309				foreach my $to (@to_register) {
310	5	3.8e-5	7.6e-6	$class->register_class(@$to); # spent 1.45ms making 5 calls to DBIx::Class::Schema::register_class, avg 289µs/call
311				# if $class->can('result_source_instance');
312				}
313				}
314
315				=head2 load_namespaces
316
317				=over 4
318
319				=item Arguments: %options?
320
321				=back
322
323				This is an alternative to L</load_classes> above which assumes an alternative
324				layout for automatic class loading. It assumes that all result
325				classes are underneath a sub-namespace of the schema called C<Result>, any
326				corresponding ResultSet classes are underneath a sub-namespace of the schema
327				called C<ResultSet>.
328
329				Both of the sub-namespaces are configurable if you don't like the defaults,
330				via the options C<result_namespace> and C<resultset_namespace>.
331
332				If (and only if) you specify the option C<default_resultset_class>, any found
333				Result classes for which we do not find a corresponding
334				ResultSet class will have their C<resultset_class> set to
335				C<default_resultset_class>.
336
337				C<load_namespaces> takes care of calling C<resultset_class> for you where
338				neccessary if you didn't do it for yourself.
339
340				All of the namespace and classname options to this method are relative to
341				the schema classname by default. To specify a fully-qualified name, prefix
342				it with a literal C<+>.
343
344				Examples:
345
346				# load My::Schema::Result::CD, My::Schema::Result::Artist,
347				# My::Schema::ResultSet::CD, etc...
348				My::Schema->load_namespaces;
349
350				# Override everything to use ugly names.
351				# In this example, if there is a My::Schema::Res::Foo, but no matching
352				# My::Schema::RSets::Foo, then Foo will have its
353				# resultset_class set to My::Schema::RSetBase
354				My::Schema->load_namespaces(
355				result_namespace => 'Res',
356				resultset_namespace => 'RSets',
357				default_resultset_class => 'RSetBase',
358				);
359
360				# Put things in other namespaces
361				My::Schema->load_namespaces(
362				result_namespace => '+Some::Place::Results',
363				resultset_namespace => '+Another::Place::RSets',
364				);
365
366				If you'd like to use multiple namespaces of each type, simply use an arrayref
367				of namespaces for that option. In the case that the same result
368				(or resultset) class exists in multiple namespaces, the latter entries in
369				your list of namespaces will override earlier ones.
370
371				My::Schema->load_namespaces(
372				# My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
373				result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
374				resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
375				);
376
377				=cut
378
379				# Pre-pends our classname to the given relative classname or
380				# class namespace, unless there is a '+' prefix, which will
381				# be stripped.
382				sub _expand_relative_name {
383				my ($class, $name) = @_;
384				return if !$name;
385				$name = $class . '::' . $name if ! ($name =~ s/^\+//);
386				return $name;
387				}
388
389				# returns a hash of $shortname => $fullname for every package
390				# found in the given namespaces ($shortname is with the $fullname's
391				# namespace stripped off)
392				sub _map_namespaces {
393				my ($class, @namespaces) = @_;
394
395				my @results_hash;
396				foreach my $namespace (@namespaces) {
397				push(
398				@results_hash,
399				map { (substr($_, length "${namespace}::"), $_) }
400				Module::Find::findallmod($namespace)
401				);
402				}
403
404				@results_hash;
405				}
406
407				sub load_namespaces {
408				my ($class, %args) = @_;
409
410				my $result_namespace = delete $args{result_namespace} \|\| 'Result';
411				my $resultset_namespace = delete $args{resultset_namespace} \|\| 'ResultSet';
412				my $default_resultset_class = delete $args{default_resultset_class};
413
414				$class->throw_exception('load_namespaces: unknown option(s): '
415				. join(q{,}, map { qq{'$_'} } keys %args))
416				if scalar keys %args;
417
418				$default_resultset_class
419				= $class->_expand_relative_name($default_resultset_class);
420
421				for my $arg ($result_namespace, $resultset_namespace) {
422				$arg = [ $arg ] if !ref($arg) && $arg;
423
424				$class->throw_exception('load_namespaces: namespace arguments must be '
425				. 'a simple string or an arrayref')
426				if ref($arg) ne 'ARRAY';
427
428				$_ = $class->_expand_relative_name($_) for (@$arg);
429				}
430
431				my %results = $class->_map_namespaces(@$result_namespace);
432				my %resultsets = $class->_map_namespaces(@$resultset_namespace);
433
434				my @to_register;
435				{
436	3	7.3e-5	2.4e-5	no warnings 'redefine'; # spent 20µs making 1 call to warnings::unimport
437				local *Class::C3::reinitialize = sub { };
438	3	0.00037	0.00012	use warnings 'redefine'; # spent 19µs making 1 call to warnings::import
439
440				foreach my $result (keys %results) {
441				my $result_class = $results{$result};
442				$class->ensure_class_loaded($result_class);
443				$result_class->source_name($result) unless $result_class->source_name;
444
445				my $rs_class = delete $resultsets{$result};
446				my $rs_set = $result_class->resultset_class;
447				if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
448				if($rs_class && $rs_class ne $rs_set) {
449				warn "We found ResultSet class '$rs_class' for '$result', but it seems "
450				. "that you had already set '$result' to use '$rs_set' instead";
451				}
452				}
453				elsif($rs_class \|\|= $default_resultset_class) {
454				$class->ensure_class_loaded($rs_class);
455				$result_class->resultset_class($rs_class);
456				}
457
458				push(@to_register, [ $result_class->source_name, $result_class ]);
459				}
460				}
461
462				foreach (sort keys %resultsets) {
463				warn "load_namespaces found ResultSet class $_ with no "
464				. 'corresponding Result class';
465				}
466
467				Class::C3->reinitialize;
468				$class->register_class(@$_) for (@to_register);
469
470				return;
471				}
472
473				=head2 compose_connection (DEPRECATED)
474
475				=over 4
476
477				=item Arguments: $target_namespace, @db_info
478
479				=item Return Value: $new_schema
480
481				=back
482
483				DEPRECATED. You probably wanted compose_namespace.
484
485				Actually, you probably just wanted to call connect.
486
487				=begin hidden
488
489				(hidden due to deprecation)
490
491				Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
492				calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
493				then injects the L<DBix::Class::ResultSetProxy> component and a
494				resultset_instance classdata entry on all the new classes, in order to support
495				$target_namespaces::$class->search(...) method calls.
496
497				This is primarily useful when you have a specific need for class method access
498				to a connection. In normal usage it is preferred to call
499				L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
500				on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
501				more information.
502
503				=end hidden
504
505				=cut
506
507				{
508	2	2.0e-6	1.0e-6	my $warn;
509
510				sub compose_connection {
511				my ($self, $target, @info) = @_;
512
513				warn "compose_connection deprecated as of 0.08000"
514				unless ($INC{"DBIx/Class/CDBICompat.pm"} \|\| $warn++);
515
516				my $base = 'DBIx::Class::ResultSetProxy';
517				eval "require ${base};";
518				$self->throw_exception
519				("No arguments to load_classes and couldn't load ${base} ($@)")
520				if $@;
521
522				if ($self eq $target) {
523				# Pathological case, largely caused by the docs on early C::M::DBIC::Plain
524				foreach my $moniker ($self->sources) {
525				my $source = $self->source($moniker);
526				my $class = $source->result_class;
527				$self->inject_base($class, $base);
528				$class->mk_classdata(resultset_instance => $source->resultset);
529				$class->mk_classdata(class_resolver => $self);
530				}
531				$self->connection(@info);
532				return $self;
533				}
534
535				my $schema = $self->compose_namespace($target, $base);
536				{
537	3	0.00018	5.9e-5	no strict 'refs'; # spent 20µs making 1 call to strict::unimport
538				*{"${target}::schema"} = sub { $schema };
539				}
540
541				$schema->connection(@info);
542				foreach my $moniker ($schema->sources) {
543				my $source = $schema->source($moniker);
544				my $class = $source->result_class;
545				#warn "$moniker $class $source ".$source->storage;
546				$class->mk_classdata(result_source_instance => $source);
547				$class->mk_classdata(resultset_instance => $source->resultset);
548				$class->mk_classdata(class_resolver => $schema);
549				}
550				return $schema;
551				}
552				}
553
554				=head2 compose_namespace
555
556				=over 4
557
558				=item Arguments: $target_namespace, $additional_base_class?
559
560				=item Return Value: $new_schema
561
562				=back
563
564				For each L<DBIx::Class::ResultSource> in the schema, this method creates a
565				class in the target namespace (e.g. $target_namespace::CD,
566				$target_namespace::Artist) that inherits from the corresponding classes
567				attached to the current schema.
568
569				It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
570				new $schema object. If C<$additional_base_class> is given, the new composed
571				classes will inherit from first the corresponding classe from the current
572				schema then the base class.
573
574				For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
575
576				$schema->compose_namespace('My::DB', 'Base::Class');
577				print join (', ', @My::DB::CD::ISA) . "\n";
578				print join (', ', @My::DB::Artist::ISA) ."\n";
579
580				will produce the output
581
582				My::Schema::CD, Base::Class
583				My::Schema::Artist, Base::Class
584
585				=cut
586
587				sub compose_namespace {
588				my ($self, $target, $base) = @_;
589				my $schema = $self->clone;
590				{
591	3	0.00014	4.6e-5	no warnings qw/redefine/; # spent 19µs making 1 call to warnings::unimport
592				local *Class::C3::reinitialize = sub { };
593				foreach my $moniker ($schema->sources) {
594				my $source = $schema->source($moniker);
595				my $target_class = "${target}::${moniker}";
596				$self->inject_base(
597				$target_class => $source->result_class, ($base ? $base : ())
598				);
599				$source->result_class($target_class);
600				$target_class->result_source_instance($source)
601				if $target_class->can('result_source_instance');
602				}
603				}
604				Class::C3->reinitialize();
605				{
606	3	2.8e-5	9.3e-6	no strict 'refs'; # spent 21µs making 1 call to strict::unimport
607	3	0.00115	0.00038	no warnings 'redefine'; # spent 19µs making 1 call to warnings::unimport
608				foreach my $meth (qw/class source resultset/) {
609				*{"${target}::${meth}"} =
610				sub { shift->schema->$meth(@_) };
611				}
612				}
613				return $schema;
614				}
615
616				=head2 setup_connection_class
617
618				=over 4
619
620				=item Arguments: $target, @info
621
622				=back
623
624				Sets up a database connection class to inject between the schema and the
625				subclasses that the schema creates.
626
627				=cut
628
629				sub setup_connection_class {
630				my ($class, $target, @info) = @_;
631				$class->inject_base($target => 'DBIx::Class::DB');
632				#$target->load_components('DB');
633				$target->connection(@info);
634				}
635
636				=head2 storage_type
637
638				=over 4
639
640				=item Arguments: $storage_type
641
642				=item Return Value: $storage_type
643
644				=back
645
646				Set the storage class that will be instantiated when L</connect> is called.
647				If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
648				assumed by L</connect>. Defaults to C<::DBI>,
649				which is L<DBIx::Class::Storage::DBI>.
650
651				You want to use this to hardcoded subclasses of L<DBIx::Class::Storage::DBI>
652				in cases where the appropriate subclass is not autodetected, such as when
653				dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
654				C<::DBI::Sybase::MSSQL>.
655
656				=head2 connection
657
658				=over 4
659
660				=item Arguments: @args
661
662				=item Return Value: $new_schema
663
664				=back
665
666				Instantiates a new Storage object of type
667				L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
668				$storage->connect_info. Sets the connection in-place on the schema.
669
670				See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
671				or L<DBIx::Class::Storage> in general.
672
673				=cut
674
675				# spent 52.9ms (42.1+10.8) within DBIx::Class::Schema::connection which was called # once (42.1ms+10.8ms) by DBIx::Class::Schema::connect at line 707 sub connection {
676	10	0.00012	1.2e-5	my ($self, @info) = @_;
677				return $self if !@info && $self->storage;
678				my $storage_class = $self->storage_type; # spent 66µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
679				$storage_class = 'DBIx::Class::Storage'.$storage_class
680				if $storage_class =~ m/^::/;
681	1	0.00123	0.00123	eval "require ${storage_class};";
682				$self->throw_exception(
683				"No arguments to load_classes and couldn't load ${storage_class} ($@)"
684				) if $@;
685				my $storage = $storage_class->new($self); # spent 288µs making 1 call to DBIx::Class::Storage::DBI::new
686				$storage->connect_info(\@info); # spent 114µs making 1 call to DBIx::Class::Storage::DBI::connect_info
687				$self->storage($storage); # spent 27µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
688				return $self;
689				}
690
691				=head2 connect
692
693				=over 4
694
695				=item Arguments: @info
696
697				=item Return Value: $new_schema
698
699				=back
700
701				This is a convenience method. It is equivalent to calling
702				$schema->clone->connection(@info). See L</connection> and L</clone> for more
703				information.
704
705				=cut
706
707	1	2.4e-5	2.4e-5	# spent 55.1ms (20µs+55.1) within DBIx::Class::Schema::connect which was called # once (20µs+55.1ms) at line 518 of /wise/base/deliv/dev/bin/getfix sub connect { shift->clone->connection(@_) } # spent 52.9ms making 1 call to DBIx::Class::Schema::connection # spent 2.21ms making 1 call to DBIx::Class::Schema::clone
708
709				=head2 txn_do
710
711				=over 4
712
713				=item Arguments: C<$coderef>, @coderef_args?
714
715				=item Return Value: The return value of $coderef
716
717				=back
718
719				Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
720				returning its result (if any). Equivalent to calling $schema->storage->txn_do.
721				See L<DBIx::Class::Storage/"txn_do"> for more information.
722
723				This interface is preferred over using the individual methods L</txn_begin>,
724				L</txn_commit>, and L</txn_rollback> below.
725
726				=cut
727
728				sub txn_do {
729				my $self = shift;
730
731				$self->storage or $self->throw_exception
732				('txn_do called on $schema without storage');
733
734				$self->storage->txn_do(@_);
735				}
736
737				=head2 txn_begin
738
739				Begins a transaction (does nothing if AutoCommit is off). Equivalent to
740				calling $schema->storage->txn_begin. See
741				L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
742
743				=cut
744
745				sub txn_begin {
746				my $self = shift;
747
748				$self->storage or $self->throw_exception
749				('txn_begin called on $schema without storage');
750
751				$self->storage->txn_begin;
752				}
753
754				=head2 txn_commit
755
756				Commits the current transaction. Equivalent to calling
757				$schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
758				for more information.
759
760				=cut
761
762				sub txn_commit {
763				my $self = shift;
764
765				$self->storage or $self->throw_exception
766				('txn_commit called on $schema without storage');
767
768				$self->storage->txn_commit;
769				}
770
771				=head2 txn_rollback
772
773				Rolls back the current transaction. Equivalent to calling
774				$schema->storage->txn_rollback. See
775				L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
776
777				=cut
778
779				sub txn_rollback {
780				my $self = shift;
781
782				$self->storage or $self->throw_exception
783				('txn_rollback called on $schema without storage');
784
785				$self->storage->txn_rollback;
786				}
787
788				=head2 clone
789
790				=over 4
791
792				=item Return Value: $new_schema
793
794				=back
795
796				Clones the schema and its associated result_source objects and returns the
797				copy.
798
799				=cut
800
801				# spent 2.21ms (451µs+1.76) within DBIx::Class::Schema::clone which was called # once (451µs+1.76ms) by DBIx::Class::Schema::connect at line 707 sub clone {
802	6	0.00040	6.7e-5	my ($self) = @_;
803				my $clone = { (ref $self ? %$self : ()) };
804				bless $clone, (ref $self \|\| $self);
805
806				foreach my $moniker ($self->sources) { # spent 49µs making 1 call to DBIx::Class::Schema::sources
807	15	0.00010	6.7e-6	my $source = $self->source($moniker); # spent 139µs making 5 calls to DBIx::Class::Schema::source, avg 28µs/call
808				my $new = $source->new($source); # spent 270µs making 5 calls to DBIx::Class::ResultSource::new, avg 54µs/call
809				$clone->register_source($moniker => $new); # spent 1.25ms making 5 calls to DBIx::Class::Schema::register_source, avg 249µs/call
810				}
811				$clone->storage->set_schema($clone) if $clone->storage; # spent 55µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
812				return $clone;
813				}
814
815				=head2 populate
816
817				=over 4
818
819				=item Arguments: $source_name, \@data;
820
821				=back
822
823				Pass this method a resultsource name, and an arrayref of
824				arrayrefs. The arrayrefs should contain a list of column names,
825				followed by one or many sets of matching data for the given columns.
826
827				In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
828				to insert the data, as this is a fast method. However, insert_bulk currently
829				assumes that your datasets all contain the same type of values, using scalar
830				references in a column in one row, and not in another will probably not work.
831
832				Otherwise, each set of data is inserted into the database using
833				L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
834				objects is returned.
835
836				i.e.,
837
838				$schema->populate('Artist', [
839				[ qw/artistid name/ ],
840				[ 1, 'Popular Band' ],
841				[ 2, 'Indie Band' ],
842				...
843				]);
844
845				Since wantarray context is basically the same as looping over $rs->create(...)
846				you won't see any performance benefits and in this case the method is more for
847				convenience. Void context sends the column information directly to storage
848				using <DBI>s bulk insert method. So the performance will be much better for
849				storages that support this method.
850
851				Because of this difference in the way void context inserts rows into your
852				database you need to note how this will effect any loaded components that
853				override or augment insert. For example if you are using a component such
854				as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
855				wantarray context if you want the PKs automatically created.
856
857				=cut
858
859				sub populate {
860				my ($self, $name, $data) = @_;
861				my $rs = $self->resultset($name);
862				my @names = @{shift(@$data)};
863				if(defined wantarray) {
864				my @created;
865				foreach my $item (@$data) {
866				my %create;
867				@create{@names} = @$item;
868				push(@created, $rs->create(\%create));
869				}
870				return @created;
871				}
872				my @results_to_create;
873				foreach my $datum (@$data) {
874				my %result_to_create;
875				foreach my $index (0..$#names) {
876				$result_to_create{$names[$index]} = $$datum[$index];
877				}
878				push @results_to_create, \%result_to_create;
879				}
880				$rs->populate(\@results_to_create);
881				}
882
883				=head2 exception_action
884
885				=over 4
886
887				=item Arguments: $code_reference
888
889				=back
890
891				If C<exception_action> is set for this class/object, L</throw_exception>
892				will prefer to call this code reference with the exception as an argument,
893				rather than its normal C<croak> or C<confess> action.
894
895				Your subroutine should probably just wrap the error in the exception
896				object/class of your choosing and rethrow. If, against all sage advice,
897				you'd like your C<exception_action> to suppress a particular exception
898				completely, simply have it return true.
899
900				Example:
901
902				package My::Schema;
903				use base qw/DBIx::Class::Schema/;
904				use My::ExceptionClass;
905				__PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
906				__PACKAGE__->load_classes;
907
908				# or:
909				my $schema_obj = My::Schema->connect( .... );
910				$schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
911
912				# suppress all exceptions, like a moron:
913				$schema_obj->exception_action(sub { 1 });
914
915				=head2 stacktrace
916
917				=over 4
918
919				=item Arguments: boolean
920
921				=back
922
923				Whether L</throw_exception> should include stack trace information.
924				Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
925				is true.
926
927				=head2 throw_exception
928
929				=over 4
930
931				=item Arguments: $message
932
933				=back
934
935				Throws an exception. Defaults to using L<Carp::Clan> to report errors from
936				user's perspective. See L</exception_action> for details on overriding
937				this method's behavior. If L</stacktrace> is turned on, C<throw_exception>'s
938				default behavior will provide a detailed stack trace.
939
940				=cut
941
942				sub throw_exception {
943				my $self = shift;
944
945				DBIx::Class::Exception->throw($_[0], $self->stacktrace)
946				if !$self->exception_action \|\| !$self->exception_action->(@_);
947				}
948
949				=head2 deploy
950
951				=over 4
952
953				=item Arguments: $sqlt_args, $dir
954
955				=back
956
957				Attempts to deploy the schema to the current storage using L<SQL::Translator>.
958
959				See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
960				common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
961				produced include a DROP TABLE statement for each table created.
962
963				Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
964				ref or an array ref, containing a list of source to deploy. If present, then
965				only the sources listed will get deployed.
966
967				=cut
968
969				sub deploy {
970				my ($self, $sqltargs, $dir) = @_;
971				$self->throw_exception("Can't deploy without storage") unless $self->storage;
972				$self->storage->deploy($self, undef, $sqltargs, $dir);
973				}
974
975				=head2 create_ddl_dir (EXPERIMENTAL)
976
977				=over 4
978
979				=item Arguments: \@databases, $version, $directory, $preversion, $sqlt_args
980
981				=back
982
983				Creates an SQL file based on the Schema, for each of the specified
984				database types, in the given directory. Given a previous version number,
985				this will also create a file containing the ALTER TABLE statements to
986				transform the previous schema into the current one. Note that these
987				statements may contain DROP TABLE or DROP COLUMN statements that can
988				potentially destroy data.
989
990				The file names are created using the C<ddl_filename> method below, please
991				override this method in your schema if you would like a different file
992				name format. For the ALTER file, the same format is used, replacing
993				$version in the name with "$preversion-$version".
994
995				If no arguments are passed, then the following default values are used:
996
997				=over 4
998
999				=item databases - ['MySQL', 'SQLite', 'PostgreSQL']
1000
1001				=item version - $schema->VERSION
1002
1003				=item directory - './'
1004
1005				=item preversion - <none>
1006
1007				=back
1008
1009				Note that this feature is currently EXPERIMENTAL and may not work correctly
1010				across all databases, or fully handle complex relationships.
1011
1012				WARNING: Please check all SQL files created, before applying them.
1013
1014				=cut
1015
1016				sub create_ddl_dir {
1017				my $self = shift;
1018
1019				$self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
1020				$self->storage->create_ddl_dir($self, @_);
1021				}
1022
1023				=head2 ddl_filename (EXPERIMENTAL)
1024
1025				=over 4
1026
1027				=item Arguments: $directory, $database-type, $version, $preversion
1028
1029				=back
1030
1031				my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
1032
1033				This method is called by C<create_ddl_dir> to compose a file name out of
1034				the supplied directory, database type and version number. The default file
1035				name format is: C<$dir$schema-$version-$type.sql>.
1036
1037				You may override this method in your schema if you wish to use a different
1038				format.
1039
1040				=cut
1041
1042				sub ddl_filename {
1043				my ($self, $type, $dir, $version, $pversion) = @_;
1044
1045				my $filename = ref($self);
1046				$filename =~ s/::/-/g;
1047				$filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
1048				$filename =~ s/$version/$pversion-$version/ if($pversion);
1049
1050				return $filename;
1051				}
1052
1053				=head2 sqlt_deploy_hook($sqlt_schema)
1054
1055				An optional sub which you can declare in your own Schema class that will get
1056				passed the L<SQL::Translator::Schema> object when you deploy the schema via
1057				L</create_ddl_dir> or L</deploy>.
1058
1059				For an example of what you can do with this, see
1060				L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1061
1062				=head2 thaw
1063
1064				Provided as the recommened way of thawing schema objects. You can call
1065				C<Storable::thaw> directly if you wish, but the thawed objects will not have a
1066				reference to any schema, so are rather useless
1067
1068				=cut
1069
1070				sub thaw {
1071				my ($self, $obj) = @_;
1072				local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1073				return Storable::thaw($obj);
1074				}
1075
1076				=head2 freeze
1077
1078				This doesn't actualy do anything more than call L<Storable/freeze>, it is just
1079				provided here for symetry.
1080
1081				=cut
1082
1083				sub freeze {
1084				return Storable::freeze($_[1]);
1085				}
1086
1087				=head2 dclone
1088
1089				Recommeneded way of dcloning objects. This is needed to properly maintain
1090				references to the schema object (which itself is B<not> cloned.)
1091
1092				=cut
1093
1094				sub dclone {
1095				my ($self, $obj) = @_;
1096				local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1097				return Storable::dclone($obj);
1098				}
1099
1100	1	1.2e-5	1.2e-5	1;
1101
1102				=head1 AUTHORS
1103
1104				Matt S. Trout <mst@shadowcatsystems.co.uk>
1105
1106				=head1 LICENSE
1107
1108				You may distribute this code under the same terms as Perl itself.
1109
1110				=cut