← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:44 2010

File/wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm
Statements Executed166926
Total Time0.494641000000224 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
55549320.472511.77419DBIx::Class::Schema::source
1110.042080.05289DBIx::Class::Schema::connection
10210.000570.00253DBIx::Class::Schema::register_source
1110.000450.00221DBIx::Class::Schema::clone
1110.000270.07372DBIx::Class::Schema::load_classes
5115.4e-50.00145DBIx::Class::Schema::register_class
3324.6e-50.00171DBIx::Class::Schema::resultset
9114.6e-54.6e-5DBIx::Class::Schema::__ANON__[:288]
1112.0e-50.05512DBIx::Class::Schema::connect
1111.2e-54.9e-5DBIx::Class::Schema::sources
00000DBIx::Class::Schema::BEGIN
00000DBIx::Class::Schema::__ANON__[:437]
00000DBIx::Class::Schema::__ANON__[:538]
00000DBIx::Class::Schema::__ANON__[:592]
00000DBIx::Class::Schema::__ANON__[:610]
00000DBIx::Class::Schema::_expand_relative_name
00000DBIx::Class::Schema::_map_namespaces
00000DBIx::Class::Schema::_unregister_source
00000DBIx::Class::Schema::class
00000DBIx::Class::Schema::compose_connection
00000DBIx::Class::Schema::compose_namespace
00000DBIx::Class::Schema::create_ddl_dir
00000DBIx::Class::Schema::dclone
00000DBIx::Class::Schema::ddl_filename
00000DBIx::Class::Schema::deploy
00000DBIx::Class::Schema::freeze
00000DBIx::Class::Schema::load_namespaces
00000DBIx::Class::Schema::populate
00000DBIx::Class::Schema::setup_connection_class
00000DBIx::Class::Schema::thaw
00000DBIx::Class::Schema::throw_exception
00000DBIx::Class::Schema::txn_begin
00000DBIx::Class::Schema::txn_commit
00000DBIx::Class::Schema::txn_do
00000DBIx::Class::Schema::txn_rollback

LineStmts.Exclusive
Time		Avg.Code
1package DBIx::Class::Schema;
2
333.2e-51.1e-5use strict;
# spent 9µs making 1 call to strict::import
434.2e-51.4e-5use warnings;
# spent 26µs making 1 call to warnings::import
5
630.000670.00022use DBIx::Class::Exception;
# spent 8µs making 1 call to import
733.3e-51.1e-5use Carp::Clan qw/^DBIx::Class/;
# spent 85µs making 1 call to Carp::Clan::import
832.8e-59.3e-6use Scalar::Util qw/weaken/;
# spent 37µs making 1 call to Exporter::import
933.9e-51.3e-5use File::Spec;
# spent 3µs making 1 call to import
1010.001120.00112require Module::Find;
11
1230.000750.00025use base qw/DBIx::Class/;
# spent 19.7ms making 1 call to base::import, max recursion depth 1
13
1411.4e-51.4e-5__PACKAGE__->mk_classdata('class_mappings' => {});
# spent 282µs making 1 call to DBIx::Class::mk_classdata
1518.0e-68.0e-6__PACKAGE__->mk_classdata('source_registrations' => {});
# spent 154µs making 1 call to DBIx::Class::mk_classdata
1617.0e-67.0e-6__PACKAGE__->mk_classdata('storage_type' => '::DBI');
# spent 152µs making 1 call to DBIx::Class::mk_classdata
1718.0e-68.0e-6__PACKAGE__->mk_classdata('storage');
# spent 140µs making 1 call to DBIx::Class::mk_classdata
1816.0e-66.0e-6__PACKAGE__->mk_classdata('exception_action');
# spent 130µs making 1 call to DBIx::Class::mk_classdata
1911.6e-51.6e-5__PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0);
# spent 151µs making 1 call to DBIx::Class::mk_classdata
2017.0e-67.0e-6__PACKAGE__->mk_classdata('default_resultset_attributes' => {});
# spent 156µs making 1 call to DBIx::Class::mk_classdata
21
22=head1 NAME
23
24DBIx::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
55Creates database classes based on a schema. This is the recommended way to
56use L<DBIx::Class> and allows you to use more than one concurrent connection
57with your classes.
58
59NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
60carefully, as DBIx::Class does things a little differently. Note in
61particular 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
73Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
74calling:
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 {
8151.2e-52.4e-6 my ($self, $moniker, $to_register) = @_;
8256.5e-51.3e-5 $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
93Registers the L<DBIx::Class::ResultSource> in the schema with the given
94moniker.
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 {
99102.0e-52.0e-6 my ($self, $moniker, $source) = @_;
100
101100.000252.5e-5 %$source = %{ $source->new( { %$source, source_name => $moniker }) };
# spent 356µs making 10 calls to DBIx::Class::ResultSource::new, avg 36µs/call
102
103100.000101.0e-5 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
104101.2e-51.2e-6 $reg{$moniker} = $source;
105105.9e-55.9e-6 $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
107106.3e-56.3e-6 $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
109103.3e-53.3e-6 weaken($source->{schema}) if ref($self);
# spent 21µs making 5 calls to Scalar::Util::weaken, avg 4µs/call
110108.0e-58.0e-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
111100.000101.0e-5 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
112105.8e-55.8e-6 $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
113105.6e-55.6e-6 $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
117sub _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
140Retrieves the result class name for the given moniker. For example:
141
142 my $class = $schema->class('CD');
143
144=cut
145
146sub 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
163Returns 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 {
168555490.088261.6e-6 my ($self, $moniker) = @_;
169555490.274364.9e-6 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
170555490.123252.2e-6 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
187Returns the source monikers of all source registrations on this schema.
188For example:
189
190 my @source_monikers = $schema->sources;
191
192=cut
193
19411.4e-51.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
200Returns 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
214Returns 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 {
21937.0e-62.3e-6 my ($self, $moniker) = @_;
22034.4e-51.5e-5 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
231With no arguments, this method uses L<Module::Find> to find all classes under
232the schema's namespace. Otherwise, this method loads the classes you specify
233(using L<use>), and registers them (using L</"register_class">).
234
235It is possible to comment out classes with a leading C<#>, but note that perl
236will think it's a mistake (trying to use a comment in a qw list), so you'll
237need to add C<no warnings 'qw';> before your load_classes call.
238
239Example:
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 {
25313.0e-63.0e-6 my ($class, @params) = @_;
254
25511.0e-61.0e-6 my %comps_for;
256
25711.0e-61.0e-6 if (@params) {
25813.0e-63.0e-6 foreach my $param (@params) {
25914.0e-64.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
26714.0e-64.0e-6 for my $comp ( keys %$param ) {
268 # filter out commented entries
26961.4e-52.3e-6 my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
270
27114.0e-64.0e-6 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
28511.0e-61.0e-6 my @to_register;
286 {
28748.5e-52.1e-5 no warnings qw/redefine/;
# spent 21µs making 1 call to warnings::unimport
288101.7e-51.7e-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 { };
28914.0e-64.0e-6 foreach my $prefix (keys %comps_for) {
29014.0e-64.0e-6 foreach my $comp (@{$comps_for{$prefix}||[]}) {
29159.0e-61.8e-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
29480.000739.2e-5 no locale; # localized \w doesn't untaint expression
# spent 8µs making 1 call to locale::unimport
29553.4e-56.8e-6 if ( $comp_class =~ m/^( (?:\w+::)* \w+ )$/x ) {
296 $comp_class = $1;
297 }
298 }
29956.0e-51.2e-5 $class->ensure_class_loaded($comp_class);
# spent 71.5ms making 5 calls to Class::C3::Componentised::ensure_class_loaded, avg 14.3ms/call
300
30150.000122.4e-5 $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;
30351.3e-52.6e-6 push(@to_register, [ $comp, $comp_class ]);
304 }
305 }
306 }
30719.0e-69.0e-6 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
30918.0e-68.0e-6 foreach my $to (@to_register) {
31053.8e-57.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
323This is an alternative to L</load_classes> above which assumes an alternative
324layout for automatic class loading. It assumes that all result
325classes are underneath a sub-namespace of the schema called C<Result>, any
326corresponding ResultSet classes are underneath a sub-namespace of the schema
327called C<ResultSet>.
328
329Both of the sub-namespaces are configurable if you don't like the defaults,
330via the options C<result_namespace> and C<resultset_namespace>.
331
332If (and only if) you specify the option C<default_resultset_class>, any found
333Result classes for which we do not find a corresponding
334ResultSet class will have their C<resultset_class> set to
335C<default_resultset_class>.
336
337C<load_namespaces> takes care of calling C<resultset_class> for you where
338neccessary if you didn't do it for yourself.
339
340All of the namespace and classname options to this method are relative to
341the schema classname by default. To specify a fully-qualified name, prefix
342it with a literal C<+>.
343
344Examples:
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
366If you'd like to use multiple namespaces of each type, simply use an arrayref
367of namespaces for that option. In the case that the same result
368(or resultset) class exists in multiple namespaces, the latter entries in
369your 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.
382sub _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)
392sub _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
407sub 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 {
43637.3e-52.4e-5 no warnings 'redefine';
# spent 20µs making 1 call to warnings::unimport
437 local *Class::C3::reinitialize = sub { };
43830.000370.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
483DEPRECATED. You probably wanted compose_namespace.
484
485Actually, you probably just wanted to call connect.
486
487=begin hidden
488
489(hidden due to deprecation)
490
491Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
492calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
493then injects the L<DBix::Class::ResultSetProxy> component and a
494resultset_instance classdata entry on all the new classes, in order to support
495$target_namespaces::$class->search(...) method calls.
496
497This is primarily useful when you have a specific need for class method access
498to a connection. In normal usage it is preferred to call
499L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
500on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
501more information.
502
503=end hidden
504
505=cut
506
507{
50822.0e-61.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 {
53730.000185.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
564For each L<DBIx::Class::ResultSource> in the schema, this method creates a
565class in the target namespace (e.g. $target_namespace::CD,
566$target_namespace::Artist) that inherits from the corresponding classes
567attached to the current schema.
568
569It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
570new $schema object. If C<$additional_base_class> is given, the new composed
571classes will inherit from first the corresponding classe from the current
572schema then the base class.
573
574For 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
580will produce the output
581
582 My::Schema::CD, Base::Class
583 My::Schema::Artist, Base::Class
584
585=cut
586
587sub compose_namespace {
588 my ($self, $target, $base) = @_;
589 my $schema = $self->clone;
590 {
59130.000144.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 {
60632.8e-59.3e-6 no strict 'refs';
# spent 21µs making 1 call to strict::unimport
60730.001150.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
624Sets up a database connection class to inject between the schema and the
625subclasses that the schema creates.
626
627=cut
628
629sub 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
646Set the storage class that will be instantiated when L</connect> is called.
647If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
648assumed by L</connect>. Defaults to C<::DBI>,
649which is L<DBIx::Class::Storage::DBI>.
650
651You want to use this to hardcoded subclasses of L<DBIx::Class::Storage::DBI>
652in cases where the appropriate subclass is not autodetected, such as when
653dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
654C<::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
666Instantiates a new Storage object of type
667L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
668$storage->connect_info. Sets the connection in-place on the schema.
669
670See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
671or 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 {
67613.0e-63.0e-6 my ($self, @info) = @_;
67711.0e-61.0e-6 return $self if !@info && $self->storage;
67812.2e-52.2e-5 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]
67917.0e-67.0e-6 $storage_class = 'DBIx::Class::Storage'.$storage_class
680 if $storage_class =~ m/^::/;
68110.001280.00128 eval "require ${storage_class};";
682100 $self->throw_exception(
683 "No arguments to load_classes and couldn't load ${storage_class} ($@)"
684 ) if $@;
68511.9e-51.9e-5 my $storage = $storage_class->new($self);
# spent 288µs making 1 call to DBIx::Class::Storage::DBI::new
68617.0e-67.0e-6 $storage->connect_info(\@info);
# spent 114µs making 1 call to DBIx::Class::Storage::DBI::connect_info
68718.0e-68.0e-6 $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]
68811.2e-51.2e-5 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
701This is a convenience method. It is equivalent to calling
702$schema->clone->connection(@info). See L</connection> and L</clone> for more
703information.
704
705=cut
706
70712.4e-52.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
719Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
720returning its result (if any). Equivalent to calling $schema->storage->txn_do.
721See L<DBIx::Class::Storage/"txn_do"> for more information.
722
723This interface is preferred over using the individual methods L</txn_begin>,
724L</txn_commit>, and L</txn_rollback> below.
725
726=cut
727
728sub 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
739Begins a transaction (does nothing if AutoCommit is off). Equivalent to
740calling $schema->storage->txn_begin. See
741L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
742
743=cut
744
745sub 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
756Commits the current transaction. Equivalent to calling
757$schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
758for more information.
759
760=cut
761
762sub 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
773Rolls back the current transaction. Equivalent to calling
774$schema->storage->txn_rollback. See
775L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
776
777=cut
778
779sub 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
796Clones the schema and its associated result_source objects and returns the
797copy.
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 {
80213.0e-63.0e-6 my ($self) = @_;
80311.0e-61.0e-6 my $clone = { (ref $self ? %$self : ()) };
80410.000360.00036 bless $clone, (ref $self || $self);
805
80611.2e-51.2e-5 foreach my $moniker ($self->sources) {
# spent 49µs making 1 call to DBIx::Class::Schema::sources
80753.0e-56.0e-6 my $source = $self->source($moniker);
# spent 139µs making 5 calls to DBIx::Class::Schema::source, avg 28µs/call
80852.6e-55.2e-6 my $new = $source->new($source);
# spent 270µs making 5 calls to DBIx::Class::ResultSource::new, avg 54µs/call
80954.5e-59.0e-6 $clone->register_source($moniker => $new);
# spent 1.25ms making 5 calls to DBIx::Class::Schema::register_source, avg 249µs/call
810 }
81112.2e-52.2e-5 $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]
81212.0e-62.0e-6 return $clone;
813}
814
815=head2 populate
816
817=over 4
818
819=item Arguments: $source_name, \@data;
820
821=back
822
823Pass this method a resultsource name, and an arrayref of
824arrayrefs. The arrayrefs should contain a list of column names,
825followed by one or many sets of matching data for the given columns.
826
827In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
828to insert the data, as this is a fast method. However, insert_bulk currently
829assumes that your datasets all contain the same type of values, using scalar
830references in a column in one row, and not in another will probably not work.
831
832Otherwise, each set of data is inserted into the database using
833L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
834objects is returned.
835
836i.e.,
837
838 $schema->populate('Artist', [
839 [ qw/artistid name/ ],
840 [ 1, 'Popular Band' ],
841 [ 2, 'Indie Band' ],
842 ...
843 ]);
844
845Since wantarray context is basically the same as looping over $rs->create(...)
846you won't see any performance benefits and in this case the method is more for
847convenience. Void context sends the column information directly to storage
848using <DBI>s bulk insert method. So the performance will be much better for
849storages that support this method.
850
851Because of this difference in the way void context inserts rows into your
852database you need to note how this will effect any loaded components that
853override or augment insert. For example if you are using a component such
854as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
855wantarray context if you want the PKs automatically created.
856
857=cut
858
859sub 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
891If C<exception_action> is set for this class/object, L</throw_exception>
892will prefer to call this code reference with the exception as an argument,
893rather than its normal C<croak> or C<confess> action.
894
895Your subroutine should probably just wrap the error in the exception
896object/class of your choosing and rethrow. If, against all sage advice,
897you'd like your C<exception_action> to suppress a particular exception
898completely, simply have it return true.
899
900Example:
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
923Whether L</throw_exception> should include stack trace information.
924Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
925is true.
926
927=head2 throw_exception
928
929=over 4
930
931=item Arguments: $message
932
933=back
934
935Throws an exception. Defaults to using L<Carp::Clan> to report errors from
936user's perspective. See L</exception_action> for details on overriding
937this method's behavior. If L</stacktrace> is turned on, C<throw_exception>'s
938default behavior will provide a detailed stack trace.
939
940=cut
941
942sub 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
957Attempts to deploy the schema to the current storage using L<SQL::Translator>.
958
959See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
960common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
961produced include a DROP TABLE statement for each table created.
962
963Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
964ref or an array ref, containing a list of source to deploy. If present, then
965only the sources listed will get deployed.
966
967=cut
968
969sub 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
983Creates an SQL file based on the Schema, for each of the specified
984database types, in the given directory. Given a previous version number,
985this will also create a file containing the ALTER TABLE statements to
986transform the previous schema into the current one. Note that these
987statements may contain DROP TABLE or DROP COLUMN statements that can
988potentially destroy data.
989
990The file names are created using the C<ddl_filename> method below, please
991override this method in your schema if you would like a different file
992name format. For the ALTER file, the same format is used, replacing
993$version in the name with "$preversion-$version".
994
995If 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
1009Note that this feature is currently EXPERIMENTAL and may not work correctly
1010across all databases, or fully handle complex relationships.
1011
1012WARNING: Please check all SQL files created, before applying them.
1013
1014=cut
1015
1016sub 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
1033This method is called by C<create_ddl_dir> to compose a file name out of
1034the supplied directory, database type and version number. The default file
1035name format is: C<$dir$schema-$version-$type.sql>.
1036
1037You may override this method in your schema if you wish to use a different
1038format.
1039
1040=cut
1041
1042sub 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
1055An optional sub which you can declare in your own Schema class that will get
1056passed the L<SQL::Translator::Schema> object when you deploy the schema via
1057L</create_ddl_dir> or L</deploy>.
1058
1059For an example of what you can do with this, see
1060L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1061
1062=head2 thaw
1063
1064Provided as the recommened way of thawing schema objects. You can call
1065C<Storable::thaw> directly if you wish, but the thawed objects will not have a
1066reference to any schema, so are rather useless
1067
1068=cut
1069
1070sub thaw {
1071 my ($self, $obj) = @_;
1072 local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1073 return Storable::thaw($obj);
1074}
1075
1076=head2 freeze
1077
1078This doesn't actualy do anything more than call L<Storable/freeze>, it is just
1079provided here for symetry.
1080
1081=cut
1082
1083sub freeze {
1084 return Storable::freeze($_[1]);
1085}
1086
1087=head2 dclone
1088
1089Recommeneded way of dcloning objects. This is needed to properly maintain
1090references to the schema object (which itself is B<not> cloned.)
1091
1092=cut
1093
1094sub dclone {
1095 my ($self, $obj) = @_;
1096 local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1097 return Storable::dclone($obj);
1098}
1099
110011.2e-51.2e-51;
1101
1102=head1 AUTHORS
1103
1104Matt S. Trout <mst@shadowcatsystems.co.uk>
1105
1106=head1 LICENSE
1107
1108You may distribute this code under the same terms as Perl itself.
1109
1110=cut

Report produced by the NYTProf 2.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.