← 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:35 2010

File/wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Row.pm
Statements Executed2455124
Total Time4.66488599998018 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
62410318184.257075.81070DBIx::Class::Row::get_column
55476111.149033.91867DBIx::Class::Row::inflate_result
73110.000650.01003DBIx::Class::Row::register_column
00000DBIx::Class::Row::BEGIN
00000DBIx::Class::Row::__ANON__[:166]
00000DBIx::Class::Row::copy
00000DBIx::Class::Row::delete
00000DBIx::Class::Row::get_columns
00000DBIx::Class::Row::get_dirty_columns
00000DBIx::Class::Row::get_inflated_columns
00000DBIx::Class::Row::has_column_loaded
00000DBIx::Class::Row::in_storage
00000DBIx::Class::Row::insert
00000DBIx::Class::Row::is_changed
00000DBIx::Class::Row::is_column_changed
00000DBIx::Class::Row::new
00000DBIx::Class::Row::result_source
00000DBIx::Class::Row::set_column
00000DBIx::Class::Row::set_columns
00000DBIx::Class::Row::set_inflated_columns
00000DBIx::Class::Row::store_column
00000DBIx::Class::Row::throw_exception
00000DBIx::Class::Row::update
00000DBIx::Class::Row::update_or_insert

LineStmts.Exclusive
Time		Avg.Code
1package DBIx::Class::Row;
2
333.3e-51.1e-5use strict;
# spent 14µs making 1 call to strict::import
433.1e-51.0e-5use warnings;
# spent 50µs making 1 call to warnings::import
5
633.5e-51.2e-5use base qw/DBIx::Class/;
# spent 77µs making 1 call to base::import, max recursion depth 1
732.9e-59.7e-6use Carp::Clan qw/^DBIx::Class/;
# spent 119µs making 1 call to Carp::Clan::import
831.8e-56.0e-6use Scalar::Util ();
930.004510.00150use Scope::Guard;
# spent 4µs making 1 call to import
10
1111.5e-51.5e-5__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
# spent 157µs making 1 call to Class::Accessor::Grouped::mk_group_accessors
12
13=head1 NAME
14
15DBIx::Class::Row - Basic row methods
16
17=head1 SYNOPSIS
18
19=head1 DESCRIPTION
20
21This class is responsible for defining and doing basic operations on rows
22derived from L<DBIx::Class::ResultSource> objects.
23
24=head1 METHODS
25
26=head2 new
27
28 my $obj = My::Class->new($attrs);
29
30Creates a new row object from column => value mappings passed as a hash ref
31
32Passing an object, or an arrayref of objects as a value will call
33L<DBIx::Class::Relationship::Base/set_from_related> for you. When
34passed a hashref or an arrayref of hashrefs as the value, these will
35be turned into objects via new_related, and treated as if you had
36passed objects.
37
38For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
39
40=cut
41
42## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new().
43## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
44## When doing the later insert, we need to make sure the PKs are set.
45## using _relationship_data in new and funky ways..
46## check Relationship::CascadeActions and Relationship::Accessor for compat
47## tests!
48
49sub new {
50 my ($class, $attrs) = @_;
51 $class = ref $class if ref $class;
52
53 my $new = { _column_data => {} };
54 bless $new, $class;
55
56 if (my $handle = delete $attrs->{-source_handle}) {
57 $new->_source_handle($handle);
58 }
59 if (my $source = delete $attrs->{-result_source}) {
60 $new->result_source($source);
61 }
62
63 if ($attrs) {
64 $new->throw_exception("attrs must be a hashref")
65 unless ref($attrs) eq 'HASH';
66
67 my ($related,$inflated);
68 ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
69 $new->{_rel_in_storage} = 1;
70
71 foreach my $key (keys %$attrs) {
72 if (ref $attrs->{$key}) {
73 ## Can we extract this lot to use with update(_or .. ) ?
74 my $info = $class->relationship_info($key);
75 if ($info && $info->{attrs}{accessor}
76 && $info->{attrs}{accessor} eq 'single')
77 {
78 my $rel_obj = delete $attrs->{$key};
79 if(!Scalar::Util::blessed($rel_obj)) {
80 $rel_obj = $new->find_or_new_related($key, $rel_obj);
81 }
82
83 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
84
85 $new->set_from_related($key, $rel_obj);
86 $related->{$key} = $rel_obj;
87 next;
88 } elsif ($info && $info->{attrs}{accessor}
89 && $info->{attrs}{accessor} eq 'multi'
90 && ref $attrs->{$key} eq 'ARRAY') {
91 my $others = delete $attrs->{$key};
92 foreach my $rel_obj (@$others) {
93 if(!Scalar::Util::blessed($rel_obj)) {
94 $rel_obj = $new->new_related($key, $rel_obj);
95 $new->{_rel_in_storage} = 0;
96 }
97
98 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
99 }
100 $related->{$key} = $others;
101 next;
102 } elsif ($info && $info->{attrs}{accessor}
103 && $info->{attrs}{accessor} eq 'filter')
104 {
105 ## 'filter' should disappear and get merged in with 'single' above!
106 my $rel_obj = delete $attrs->{$key};
107 if(!Scalar::Util::blessed($rel_obj)) {
108 $rel_obj = $new->find_or_new_related($key, $rel_obj);
109 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
110 }
111 $inflated->{$key} = $rel_obj;
112 next;
113 } elsif ($class->has_column($key)
114 && $class->column_info($key)->{_inflate_info}) {
115 $inflated->{$key} = $attrs->{$key};
116 next;
117 }
118 }
119 $new->throw_exception("No such column $key on $class")
120 unless $class->has_column($key);
121 $new->store_column($key => $attrs->{$key});
122 }
123
124 $new->{_relationship_data} = $related if $related;
125 $new->{_inflated_column} = $inflated if $inflated;
126 }
127
128 return $new;
129}
130
131=head2 insert
132
133 $obj->insert;
134
135Inserts an object into the database if it isn't already in
136there. Returns the object itself. Requires the object's result source to
137be set, or the class to have a result_source_instance method. To insert
138an entirely new object into the database, use C<create> (see
139L<DBIx::Class::ResultSet/create>).
140
141This will also insert any uninserted, related objects held inside this
142one, see L<DBIx::Class::ResultSet/create> for more details.
143
144=cut
145
146sub insert {
147 my ($self) = @_;
148 return $self if $self->in_storage;
149 my $source = $self->result_source;
150 $source ||= $self->result_source($self->result_source_instance)
151 if $self->can('result_source_instance');
152 $self->throw_exception("No result_source set on this object; can't insert")
153 unless $source;
154
155 my $rollback_guard;
156
157 # Check if we stored uninserted relobjs here in new()
158 my %related_stuff = (%{$self->{_relationship_data} || {}},
159 %{$self->{_inflated_column} || {}});
160
161 if(!$self->{_rel_in_storage}) {
162 $source->storage->txn_begin;
163
164 # The guard will save us if we blow out of this scope via die
165
166 $rollback_guard = Scope::Guard->new(sub { $source->storage->txn_rollback });
167
168 ## Should all be in relationship_data, but we need to get rid of the
169 ## 'filter' reltype..
170 ## These are the FK rels, need their IDs for the insert.
171
172 my @pri = $self->primary_columns;
173
174 REL: foreach my $relname (keys %related_stuff) {
175
176 my $rel_obj = $related_stuff{$relname};
177
178 next REL unless (Scalar::Util::blessed($rel_obj)
179 && $rel_obj->isa('DBIx::Class::Row'));
180
181 my $cond = $source->relationship_info($relname)->{cond};
182
183 next REL unless ref($cond) eq 'HASH';
184
185 # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
186
187 my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
188
189 # assume anything that references our PK probably is dependent on us
190 # rather than vice versa, unless the far side is (a) defined or (b)
191 # auto-increment
192
193 foreach my $p (@pri) {
194 if (exists $keyhash->{$p}) {
195 unless (defined($rel_obj->get_column($keyhash->{$p}))
196 || $rel_obj->column_info($keyhash->{$p})
197 ->{is_auto_increment}) {
198 next REL;
199 }
200 }
201 }
202
203 $rel_obj->insert();
204 $self->set_from_related($relname, $rel_obj);
205 delete $related_stuff{$relname};
206 }
207 }
208
209 $source->storage->insert($source, { $self->get_columns });
210
211 ## PK::Auto
212 my @auto_pri = grep {
213 !defined $self->get_column($_) ||
214 ref($self->get_column($_)) eq 'SCALAR'
215 } $self->primary_columns;
216
217 if (@auto_pri) {
218 #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
219 # if defined $too_many;
220
221 my $storage = $self->result_source->storage;
222 $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
223 unless $storage->can('last_insert_id');
224 my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
225 $self->throw_exception( "Can't get last insert id" )
226 unless (@ids == @auto_pri);
227 $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
228 }
229
230 if(!$self->{_rel_in_storage}) {
231 ## Now do the has_many rels, that need $selfs ID.
232 foreach my $relname (keys %related_stuff) {
233 my $rel_obj = $related_stuff{$relname};
234 my @cands;
235 if (Scalar::Util::blessed($rel_obj)
236 && $rel_obj->isa('DBIx::Class::Row')) {
237 @cands = ($rel_obj);
238 } elsif (ref $rel_obj eq 'ARRAY') {
239 @cands = @$rel_obj;
240 }
241 if (@cands) {
242 my $reverse = $source->reverse_relationship_info($relname);
243 foreach my $obj (@cands) {
244 $obj->set_from_related($_, $self) for keys %$reverse;
245 $obj->insert() unless ($obj->in_storage || $obj->result_source->resultset->search({$obj->get_columns})->count);
246 }
247 }
248 }
249 $source->storage->txn_commit;
250 $rollback_guard->dismiss;
251 }
252
253 $self->in_storage(1);
254 $self->{_dirty_columns} = {};
255 $self->{related_resultsets} = {};
256 undef $self->{_orig_ident};
257 return $self;
258}
259
260=head2 in_storage
261
262 $obj->in_storage; # Get value
263 $obj->in_storage(1); # Set value
264
265Indicates whether the object exists as a row in the database or not
266
267=cut
268
269sub in_storage {
270 my ($self, $val) = @_;
271 $self->{_in_storage} = $val if @_ > 1;
272 return $self->{_in_storage};
273}
274
275=head2 update
276
277 $obj->update \%columns?;
278
279Must be run on an object that is already in the database; issues an SQL
280UPDATE query to commit any changes to the object to the database if
281required.
282
283Also takes an options hashref of C<< column_name => value> pairs >> to update
284first. But be awawre that the hashref will be passed to
285C<set_inflated_columns>, which might edit it in place, so dont rely on it being
286the same after a call to C<update>. If you need to preserve the hashref, it is
287sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
288
289=cut
290
291sub update {
292 my ($self, $upd) = @_;
293 $self->throw_exception( "Not in database" ) unless $self->in_storage;
294 my $ident_cond = $self->ident_condition;
295 $self->throw_exception("Cannot safely update a row in a PK-less table")
296 if ! keys %$ident_cond;
297
298 $self->set_inflated_columns($upd) if $upd;
299 my %to_update = $self->get_dirty_columns;
300 return $self unless keys %to_update;
301 my $rows = $self->result_source->storage->update(
302 $self->result_source, \%to_update,
303 $self->{_orig_ident} || $ident_cond
304 );
305 if ($rows == 0) {
306 $self->throw_exception( "Can't update ${self}: row not found" );
307 } elsif ($rows > 1) {
308 $self->throw_exception("Can't update ${self}: updated more than one row");
309 }
310 $self->{_dirty_columns} = {};
311 $self->{related_resultsets} = {};
312 undef $self->{_orig_ident};
313 return $self;
314}
315
316=head2 delete
317
318 $obj->delete
319
320Deletes the object from the database. The object is still perfectly
321usable, but C<< ->in_storage() >> will now return 0 and the object must
322reinserted using C<< ->insert() >> before C<< ->update() >> can be used
323on it. If you delete an object in a class with a C<has_many>
324relationship, all the related objects will be deleted as well. To turn
325this behavior off, pass C<< cascade_delete => 0 >> in the C<$attr>
326hashref. Any database-level cascade or restrict will take precedence
327over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
328
329=cut
330
331sub delete {
332 my $self = shift;
333 if (ref $self) {
334 $self->throw_exception( "Not in database" ) unless $self->in_storage;
335 my $ident_cond = $self->ident_condition;
336 $self->throw_exception("Cannot safely delete a row in a PK-less table")
337 if ! keys %$ident_cond;
338 foreach my $column (keys %$ident_cond) {
339 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
340 unless exists $self->{_column_data}{$column};
341 }
342 $self->result_source->storage->delete(
343 $self->result_source, $ident_cond);
344 $self->in_storage(undef);
345 } else {
346 $self->throw_exception("Can't do class delete without a ResultSource instance")
347 unless $self->can('result_source_instance');
348 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
349 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
350 $self->result_source_instance->resultset->search(@_)->delete;
351 }
352 return $self;
353}
354
355=head2 get_column
356
357 my $val = $obj->get_column($col);
358
359Gets a column value from a row object. Does not do any queries; the column
360must have already been fetched from the database and stored in the object. If
361there is an inflated value stored that has not yet been deflated, it is deflated
362when the method is invoked.
363
364=cut
365
366
# spent 5.81s (4.26+1.55) within DBIx::Class::Row::get_column which was called 624103 times, avg 9µs/call: # 69344 times (492ms+0) at line 6 of (eval 133)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 69344 times (458ms+0) at line 6 of (eval 134)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 69344 times (447ms+0) at line 6 of (eval 135)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 6µs/call # 41607 times (296ms+0) at line 6 of (eval 168)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 41607 times (282ms+0) at line 6 of (eval 154)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 41607 times (276ms+0) at line 6 of (eval 163)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 41607 times (274ms+0) at line 6 of (eval 149)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 41607 times (268ms+0) at line 6 of (eval 155)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 6µs/call # 41607 times (263ms+0) at line 6 of (eval 156)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 6µs/call # 27738 times (275ms+1.55s) at line 6 of (eval 174)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 66µs/call # 27738 times (191ms+0) at line 6 of (eval 166)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 27738 times (185ms+0) at line 6 of (eval 165)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 27738 times (183ms+0) at line 6 of (eval 164)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 13869 times (93.1ms+0) at line 6 of (eval 151)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 13869 times (92.9ms+0) at line 6 of (eval 167)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 13869 times (90.7ms+0) at line 6 of (eval 150)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 7µs/call # 13869 times (89.5ms+0) at line 6 of (eval 152)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm, avg 6µs/call # once (13µs+0) at line 6 of (eval 196)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156] at line 156 of /wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm
sub get_column {
36719555233.088711.6e-6 my ($self, $column) = @_;
368 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
369 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
370 if (exists $self->{_inflated_column}{$column}) {
371 return $self->store_column($column,
372 $self->_deflated_column($column, $self->{_inflated_column}{$column}));
373 }
374 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
# spent 1.55s making 27738 calls to DBIx::Class::ResultSourceProxy::has_column, avg 56µs/call
375 return undef;
376}
377
378=head2 has_column_loaded
379
380 if ( $obj->has_column_loaded($col) ) {
381 print "$col has been loaded from db";
382 }
383
384Returns a true value if the column value has been loaded from the
385database (or set locally).
386
387=cut
388
389sub has_column_loaded {
390 my ($self, $column) = @_;
391 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
392 return 1 if exists $self->{_inflated_column}{$column};
393 return exists $self->{_column_data}{$column};
394}
395
396=head2 get_columns
397
398 my %data = $obj->get_columns;
399
400Does C<get_column>, for all column values at once.
401
402=cut
403
404sub get_columns {
405 my $self = shift;
406 if (exists $self->{_inflated_column}) {
407 foreach my $col (keys %{$self->{_inflated_column}}) {
408 $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
409 unless exists $self->{_column_data}{$col};
410 }
411 }
412 return %{$self->{_column_data}};
413}
414
415=head2 get_dirty_columns
416
417 my %data = $obj->get_dirty_columns;
418
419Identical to get_columns but only returns those that have been changed.
420
421=cut
422
423sub get_dirty_columns {
424 my $self = shift;
425 return map { $_ => $self->{_column_data}{$_} }
426 keys %{$self->{_dirty_columns}};
427}
428
429=head2 get_inflated_columns
430
431 my $inflated_data = $obj->get_inflated_columns;
432
433Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
434
435=cut
436
437sub get_inflated_columns {
438 my $self = shift;
439 return map {
440 my $accessor = $self->column_info($_)->{'accessor'} || $_;
441 ($_ => $self->$accessor);
442 } $self->columns;
443}
444
445=head2 set_column
446
447 $obj->set_column($col => $val);
448
449Sets a column value. If the new value is different from the old one,
450the column is marked as dirty for when you next call $obj->update.
451
452=cut
453
454sub set_column {
455 my $self = shift;
456 my ($column) = @_;
457 $self->{_orig_ident} ||= $self->ident_condition;
458 my $old = $self->get_column($column);
459 my $ret = $self->store_column(@_);
460 $self->{_dirty_columns}{$column} = 1
461 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
462 return $ret;
463}
464
465=head2 set_columns
466
467 my $copy = $orig->set_columns({ $col => $val, ... });
468
469Sets more than one column value at once.
470
471=cut
472
473sub set_columns {
474 my ($self,$data) = @_;
475 foreach my $col (keys %$data) {
476 $self->set_column($col,$data->{$col});
477 }
478 return $self;
479}
480
481=head2 set_inflated_columns
482
483 my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
484
485Sets more than one column value at once, taking care to respect inflations and
486relationships if relevant. Be aware that this hashref might be edited in place,
487so dont rely on it being the same after a call to C<set_inflated_columns>. If
488you need to preserve the hashref, it is sufficient to pass a shallow copy to
489C<set_inflated_columns>, e.g. ( { %{ $href } } )
490
491=cut
492
493sub set_inflated_columns {
494 my ( $self, $upd ) = @_;
495 foreach my $key (keys %$upd) {
496 if (ref $upd->{$key}) {
497 my $info = $self->relationship_info($key);
498 if ($info && $info->{attrs}{accessor}
499 && $info->{attrs}{accessor} eq 'single')
500 {
501 my $rel = delete $upd->{$key};
502 $self->set_from_related($key => $rel);
503 $self->{_relationship_data}{$key} = $rel;
504 } elsif ($info && $info->{attrs}{accessor}
505 && $info->{attrs}{accessor} eq 'multi'
506 && ref $upd->{$key} eq 'ARRAY') {
507 my $others = delete $upd->{$key};
508 foreach my $rel_obj (@$others) {
509 if(!Scalar::Util::blessed($rel_obj)) {
510 $rel_obj = $self->create_related($key, $rel_obj);
511 }
512 }
513 $self->{_relationship_data}{$key} = $others;
514# $related->{$key} = $others;
515 next;
516 }
517 elsif ($self->has_column($key)
518 && exists $self->column_info($key)->{_inflate_info})
519 {
520 $self->set_inflated_column($key, delete $upd->{$key});
521 }
522 }
523 }
524 $self->set_columns($upd);
525}
526
527=head2 copy
528
529 my $copy = $orig->copy({ change => $to, ... });
530
531Inserts a new row with the specified changes.
532
533=cut
534
535sub copy {
536 my ($self, $changes) = @_;
537 $changes ||= {};
538 my $col_data = { %{$self->{_column_data}} };
539 foreach my $col (keys %$col_data) {
540 delete $col_data->{$col}
541 if $self->result_source->column_info($col)->{is_auto_increment};
542 }
543
544 my $new = { _column_data => $col_data };
545 bless $new, ref $self;
546
547 $new->result_source($self->result_source);
548 $new->set_inflated_columns($changes);
549 $new->insert;
550
551 # Its possible we'll have 2 relations to the same Source. We need to make
552 # sure we don't try to insert the same row twice esle we'll violate unique
553 # constraints
554 my $rels_copied = {};
555
556 foreach my $rel ($self->result_source->relationships) {
557 my $rel_info = $self->result_source->relationship_info($rel);
558
559 next unless $rel_info->{attrs}{cascade_copy};
560
561 my $resolved = $self->result_source->resolve_condition(
562 $rel_info->{cond}, $rel, $new
563 );
564
565 my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
566 foreach my $related ($self->search_related($rel)) {
567 my $id_str = join("\0", $related->id);
568 next if $copied->{$id_str};
569 $copied->{$id_str} = 1;
570 my $rel_copy = $related->copy($resolved);
571 }
572
573 }
574 return $new;
575}
576
577=head2 store_column
578
579 $obj->store_column($col => $val);
580
581Sets a column value without marking it as dirty.
582
583=cut
584
585sub store_column {
586 my ($self, $column, $value) = @_;
587 $self->throw_exception( "No such column '${column}'" )
588 unless exists $self->{_column_data}{$column} || $self->has_column($column);
589 $self->throw_exception( "set_column called for ${column} without value" )
590 if @_ < 3;
591 return $self->{_column_data}{$column} = $value;
592}
593
594=head2 inflate_result
595
596 Class->inflate_result($result_source, \%me, \%prefetch?)
597
598Called by ResultSet to inflate a result from storage
599
600=cut
601
602
# spent 3.92s (1.15+2.77) within DBIx::Class::Row::inflate_result which was called 55476 times, avg 71µs/call: # 55476 times (1.15s+2.77s) by DBIx::Class::ResultSet::_construct_object at line 770 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSet.pm, avg 71µs/call
sub inflate_result {
6034438081.327253.0e-6 my ($class, $source, $me, $prefetch) = @_;
604
605 my ($source_handle) = $source;
606
607554760.243614.4e-6 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
# spent 459ms making 55476 calls to UNIVERSAL::isa, avg 8µs/call
608 $source = $source_handle->resolve
609 } else {
610 $source_handle = $source->handle
# spent 2.31s making 55476 calls to DBIx::Class::ResultSource::handle, avg 42µs/call
611 }
612
613 my $new = {
614 _source_handle => $source_handle,
615 _column_data => $me,
616 _in_storage => 1
617 };
618 bless $new, (ref $class || $class);
619
620 my $schema;
621 foreach my $pre (keys %{$prefetch||{}}) {
622 my $pre_val = $prefetch->{$pre};
623 my $pre_source = $source->related_source($pre);
624 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
625 unless $pre_source;
626 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
627 my @pre_objects;
628 foreach my $pre_rec (@$pre_val) {
629 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
630 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
631 next;
632 }
633 push(@pre_objects, $pre_source->result_class->inflate_result(
634 $pre_source, @{$pre_rec}));
635 }
636 $new->related_resultset($pre)->set_cache(\@pre_objects);
637 } elsif (defined $pre_val->[0]) {
638 my $fetched;
639 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
640 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
641 {
642 $fetched = $pre_source->result_class->inflate_result(
643 $pre_source, @{$pre_val});
644 }
645 $new->related_resultset($pre)->set_cache([ $fetched ]);
646 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
647 $class->throw_exception("No accessor for prefetched $pre")
648 unless defined $accessor;
649 if ($accessor eq 'single') {
650 $new->{_relationship_data}{$pre} = $fetched;
651 } elsif ($accessor eq 'filter') {
652 $new->{_inflated_column}{$pre} = $fetched;
653 } else {
654 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
655 }
656 }
657 }
658 return $new;
659}
660
661=head2 update_or_insert
662
663 $obj->update_or_insert
664
665Updates the object if it's already in the db, else inserts it.
666
667=head2 insert_or_update
668
669 $obj->insert_or_update
670
671Alias for L</update_or_insert>
672
673=cut
674
67511.0e-61.0e-6*insert_or_update = \&update_or_insert;
676sub update_or_insert {
677 my $self = shift;
678 return ($self->in_storage ? $self->update : $self->insert);
679}
680
681=head2 is_changed
682
683 my @changed_col_names = $obj->is_changed();
684 if ($obj->is_changed()) { ... }
685
686In array context returns a list of columns with uncommited changes, or
687in scalar context returns a true value if there are uncommitted
688changes.
689
690=cut
691
692sub is_changed {
693 return keys %{shift->{_dirty_columns} || {}};
694}
695
696=head2 is_column_changed
697
698 if ($obj->is_column_changed('col')) { ... }
699
700Returns a true value if the column has uncommitted changes.
701
702=cut
703
704sub is_column_changed {
705 my( $self, $col ) = @_;
706 return exists $self->{_dirty_columns}->{$col};
707}
708
709=head2 result_source
710
711 my $resultsource = $object->result_source;
712
713Accessor to the ResultSource this object was created from
714
715=cut
716
717sub result_source {
718 my $self = shift;
719
720 if (@_) {
721 $self->_source_handle($_[0]->handle);
722 } else {
723 $self->_source_handle->resolve;
724 }
725}
726
727=head2 register_column
728
729 $column_info = { .... };
730 $class->register_column($column_name, $column_info);
731
732Registers a column on the class. If the column_info has an 'accessor'
733key, creates an accessor named after the value if defined; if there is
734no such key, creates an accessor with the same name as the column
735
736The column_info attributes are described in
737L<DBIx::Class::ResultSource/add_columns>
738
739=cut
740
741
# spent 10.0ms (653µs+9.37) within DBIx::Class::Row::register_column which was called 73 times, avg 137µs/call: # 73 times (653µs+9.37ms) by DBIx::Class::ResultSourceProxy::add_columns at line 40 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm, avg 137µs/call
sub register_column {
7422920.000632.2e-6 my ($class, $col, $info) = @_;
743 my $acc = $col;
74446.0e-61.5e-6 if (exists $info->{accessor}) {
745 return unless defined $info->{accessor};
746 $acc = [ $info->{accessor}, $col ];
747 }
748 $class->mk_group_accessors('column' => $acc);
# spent 9.38ms making 73 calls to Class::Accessor::Grouped::mk_group_accessors, avg 128µs/call
749}
750
751
752=head2 throw_exception
753
754See Schema's throw_exception.
755
756=cut
757
758sub throw_exception {
759 my $self=shift;
760 if (ref $self && ref $self->result_source && $self->result_source->schema) {
761 $self->result_source->schema->throw_exception(@_);
762 } else {
763 croak(@_);
764 }
765}
766
767=head2 id
768
769Returns the primary key(s) for a row. Can't be called as a class method.
770Actually implemented in L<DBIx::Class::Pk>
771
772=head2 discard_changes
773
774Re-selects the row from the database, losing any changes that had
775been made.
776
777This method can also be used to refresh from storage, retrieving any
778changes made since the row was last read from storage. Actually
779implemented in L<DBIx::Class::Pk>
780
781=cut
782
78315.0e-65.0e-61;
784
785=head1 AUTHORS
786
787Matt S. Trout <mst@shadowcatsystems.co.uk>
788
789=head1 LICENSE
790
791You may distribute this code under the same terms as Perl itself.
792
793=cut

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