← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:56:57 2010

File /project/perl/lib/Class/DBI/Relationship/HasMany.pm
Statements Executed 93
Statement Execution Time 3.94ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
211401µs7.93msClass::DBI::Relationship::HasMany::::triggersClass::DBI::Relationship::HasMany::triggers
211291µs1.84msClass::DBI::Relationship::HasMany::::_set_up_class_dataClass::DBI::Relationship::HasMany::_set_up_class_data
211290µs37.9msClass::DBI::Relationship::HasMany::::remap_argumentsClass::DBI::Relationship::HasMany::remap_arguments
211163µs669µsClass::DBI::Relationship::HasMany::::methodsClass::DBI::Relationship::HasMany::methods
211132µs180µsClass::DBI::Relationship::HasMany::::_hm_run_searchClass::DBI::Relationship::HasMany::_hm_run_search
211127µs151µsClass::DBI::Relationship::HasMany::::_method_add_toClass::DBI::Relationship::HasMany::_method_add_to
211120µs326µsClass::DBI::Relationship::HasMany::::_has_many_methodClass::DBI::Relationship::HasMany::_has_many_method
21216µs16µsClass::DBI::Relationship::HasMany::::CORE:matchClass::DBI::Relationship::HasMany::CORE:match (opcode)
0000s0sClass::DBI::Relationship::HasMany::::BEGINClass::DBI::Relationship::HasMany::BEGIN
0000s0sClass::DBI::Relationship::HasMany::::__ANON__[:113]Class::DBI::Relationship::HasMany::__ANON__[:113]
0000s0sClass::DBI::Relationship::HasMany::::__ANON__[:126]Class::DBI::Relationship::HasMany::__ANON__[:126]
0000s0sClass::DBI::Relationship::HasMany::::__ANON__[:159]Class::DBI::Relationship::HasMany::__ANON__[:159]
0000s0sClass::DBI::Relationship::HasMany::::__ANON__[:75]Class::DBI::Relationship::HasMany::__ANON__[:75]
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Class::DBI::Relationship::HasMany;
2
33114µs150µsuse strict;
# spent 50µs making 1 call to strict::import
4390µs1117µsuse warnings;
# spent 117µs making 1 call to warnings::import
5
63203µs10suse base 'Class::DBI::Relationship';
# spent 261µs making 1 call to base::import, recursion: max depth 3, time 261µs
7
8
# spent 37.9ms (290µs+37.6) within Class::DBI::Relationship::HasMany::remap_arguments which was called 2 times, avg 19.0ms/call: # 2 times (290µs+37.6ms) by Class::DBI::Relationship::_init at line 22 of Class/DBI/Relationship.pm, avg 19.0ms/call
sub remap_arguments {
932268µs my ($proto, $class, $accessor, $f_class, $f_key, $args) = @_;
10
11 return $class->_croak($class->name . " needs an accessor name")
12 unless $accessor;
13 return $class->_croak($class->name . " needs a foreign class")
14 unless $f_class;
15
16 {
1732.08ms195µs no strict 'refs';
# spent 95µs making 1 call to strict::unimport
18222µs defined &{"$class\::$accessor"}
19 and return $class->_carp("$accessor method already exists in $class\n");
20 }
21
22 my @f_method = ();
23 if (ref $f_class eq "ARRAY") {
24 ($f_class, @f_method) = @$f_class;
25 }
26 $class->_require_class($f_class);
# spent 37.6ms making 2 calls to Class::DBI::_require_class, avg 18.8ms/call
27
28 if (ref $f_key eq "HASH") { # didn't supply f_key, this is really $args
29 $args = $f_key;
30 $f_key = "";
31 }
32
33 $f_key ||= do {
34 my $meta = $f_class->meta_info('has_a');
35 my ($col) = grep $meta->{$_}->foreign_class eq $class, keys %$meta;
36 $col || $class->table_alias;
37 };
38
39 if (ref $f_key eq "ARRAY") {
40 return $class->_croak("Multi-column foreign keys not supported")
41 if @$f_key > 1;
42 $f_key = $f_key->[0];
43 }
44
45 $args ||= {};
46 $args->{mapping} = \@f_method;
47 $args->{foreign_key} = $f_key;
48 $args->{order_by} ||= $args->{sort}; # deprecated 0.96
49 warn "sort argument to has_many deprecated in favour of order_by"
50 if $args->{sort}; # deprecated 0.96
51
52 return ($class, $accessor, $f_class, $args);
53}
54
55
# spent 1.84ms (291µs+1.55) within Class::DBI::Relationship::HasMany::_set_up_class_data which was called 2 times, avg 922µs/call: # 2 times (291µs+1.55ms) by Class::DBI::Relationship::set_up at line 13 of Class/DBI/Relationship.pm, avg 922µs/call
sub _set_up_class_data {
566255µs my $self = shift;
57 $self->class->_extend_class_data(
# spent 377µs making 2 calls to Class::DBI::_extend_class_data, avg 189µs/call # spent 89µs making 6 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 15µs/call
58 __hasa_list => $self->foreign_class => $self->args->{foreign_key});
59 $self->SUPER::_set_up_class_data;
# spent 1.09ms making 2 calls to Class::DBI::Relationship::_set_up_class_data, avg 544µs/call
60}
61
62
# spent 7.93ms (401µs+7.53) within Class::DBI::Relationship::HasMany::triggers which was called 2 times, avg 3.97ms/call: # 2 times (401µs+7.53ms) by Class::DBI::Relationship::_add_triggers at line 51 of Class/DBI/Relationship.pm, avg 3.97ms/call
sub triggers {
6316399µs my $self = shift;
64 if ($self->args->{no_cascade_delete}) { # old undocumented way
# spent 26µs making 2 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 13µs/call
65 warn "no_cascade_delete deprecated in favour of cascade => None";
66 return;
67 }
68 my $strategy = $self->args->{cascade} || "Delete";
# spent 24µs making 2 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 12µs/call
69 $strategy = "Class::DBI::Cascade::$strategy" unless $strategy =~ /::/;
# spent 16µs making 2 calls to Class::DBI::Relationship::HasMany::CORE:match, avg 8µs/call
70
71 $self->foreign_class->_require_class($strategy);
# spent 7.32ms making 2 calls to Class::DBI::_require_class, avg 3.66ms/call # spent 27µs making 2 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 14µs/call
72 $strategy->can('cascade')
# spent 20µs making 2 calls to UNIVERSAL::can, avg 10µs/call
73 or return $self->_croak("$strategy is not a valid Cascade Strategy");
74 my $strat_obj = $strategy->new($self);
# spent 99µs making 2 calls to Class::DBI::Cascade::None::new, avg 50µs/call
75 return (before_delete => sub { $strat_obj->cascade(@_) });
76}
77
78
# spent 669µs (163+506) within Class::DBI::Relationship::HasMany::methods which was called 2 times, avg 334µs/call: # 2 times (163µs+506µs) by Class::DBI::Relationship::_add_methods at line 61 of Class/DBI/Relationship.pm, avg 334µs/call
sub methods {
796136µs my $self = shift;
80 my $accessor = $self->accessor;
# spent 29µs making 2 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 14µs/call
81 return (
82 $accessor => $self->_has_many_method,
# spent 326µs making 2 calls to Class::DBI::Relationship::HasMany::_has_many_method, avg 163µs/call # spent 151µs making 2 calls to Class::DBI::Relationship::HasMany::_method_add_to, avg 75µs/call
83 "add_to_$accessor" => $self->_method_add_to,
84 );
85}
86
87
# spent 151µs (127+24) within Class::DBI::Relationship::HasMany::_method_add_to which was called 2 times, avg 75µs/call: # 2 times (127µs+24µs) by Class::DBI::Relationship::HasMany::methods at line 82, avg 75µs/call
sub _method_add_to {
886127µs my $rel = shift;
89 my $accessor = $rel->accessor;
# spent 24µs making 2 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 12µs/call
90 return sub {
91 my ($self, $data) = @_;
92 my $class = ref $self
93 or return $self->_croak("add_to_$accessor called as class method");
94 return $self->_croak("add_to_$accessor needs data")
95 unless ref $data eq "HASH";
96
97 my $meta = $class->meta_info($rel->name => $accessor);
98 my ($f_class, $f_key, $args) =
99 ($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
100 $data->{$f_key} = $self->id;
101
102 # See if has_many constraints were defined and auto fill them
103 if (defined $args->{constraint} && ref $args->{constraint} eq 'HASH') {
104 while (my ($k, $v) = each %{ $args->{constraint} }) {
105 $self->_croak(
106 "Can't add_to_$accessor with $k = $data->{$k} (must be $v)")
107 if defined($data->{$k}) && $data->{$k} ne $v;
108 $data->{$k} = $v;
109 }
110 }
111
112 $f_class->insert($data);
113 };
114}
115
116
# spent 326µs (120+206) within Class::DBI::Relationship::HasMany::_has_many_method which was called 2 times, avg 163µs/call: # 2 times (120µs+206µs) by Class::DBI::Relationship::HasMany::methods at line 82, avg 163µs/call
sub _has_many_method {
1176108µs my $self = shift;
118 my $run_search = $self->_hm_run_search;
# spent 180µs making 2 calls to Class::DBI::Relationship::HasMany::_hm_run_search, avg 90µs/call
119 my @mapping = @{ $self->args->{mapping} } or return $run_search;
# spent 26µs making 2 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 13µs/call
120 return sub {
121 return $run_search->(@_)->set_mapping_method(@mapping)
122 unless wantarray;
123 my @ret = $run_search->(@_);
124 foreach my $meth (@mapping) { @ret = map $_->$meth(), @ret }
125 return @ret;
126 }
127}
128
129
# spent 180µs (132+48) within Class::DBI::Relationship::HasMany::_hm_run_search which was called 2 times, avg 90µs/call: # 2 times (132µs+48µs) by Class::DBI::Relationship::HasMany::_has_many_method at line 118, avg 90µs/call
sub _hm_run_search {
1306126µs my $rel = shift;
131 my ($class, $accessor) = ($rel->class, $rel->accessor);
# spent 48µs making 4 calls to Class::Accessor::Fast::__ANON__[Class/Accessor/Fast.pm:41], avg 12µs/call
132 return sub {
133 my ($self, @search_args) = @_;
134 @search_args = %{ $search_args[0] } if ref $search_args[0] eq "HASH";
135 my $meta = $class->meta_info($rel->name => $accessor);
136 my ($f_class, $f_key, $args) =
137 ($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
138 if (ref $self) { # For $artist->cds
139 unshift @search_args, %{ $args->{constraint} }
140 if defined($args->{constraint}) && ref $args->{constraint} eq 'HASH';
141 unshift @search_args, ($f_key => $self->id);
142 push @search_args, { order_by => $args->{order_by} }
143 if defined $args->{order_by};
144 return $f_class->search(@search_args);
145 } else { # For Artist->cds
146 # Cross-table join as class method
147 # This stuff is highly experimental and will probably change beyond
148 # recognition. Use at your own risk...
149 my %kv = @search_args;
150 my $query = Class::DBI::Query->new({ owner => $f_class });
151 $query->kings($class, $f_class);
152 $query->add_restriction(sprintf "%s.%s = %s.%s",
153 $f_class->table_alias, $f_key, $class->table_alias,
154 $class->primary_column);
155 $query->add_restriction("$_ = ?") for keys %kv;
156 my $sth = $query->run(values %kv);
157 return $f_class->sth_to_objects($sth);
158 }
159 };
160}
161
162112µs1;
# spent 16µs within Class::DBI::Relationship::HasMany::CORE:match which was called 2 times, avg 8µs/call: # 2 times (16µs+0s) by Class::DBI::Relationship::HasMany::triggers at line 69 of Class/DBI/Relationship/HasMany.pm, avg 8µs/call
sub Class::DBI::Relationship::HasMany::CORE:match; # xsub
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.