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

File /project/perl/lib/Class/DBI/Relationship/MightHave.pm
Statements Executed 10
Statement Execution Time 1.22ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sClass::DBI::Relationship::MightHave::::BEGINClass::DBI::Relationship::MightHave::BEGIN
0000s0sClass::DBI::Relationship::MightHave::::__ANON__[:22]Class::DBI::Relationship::MightHave::__ANON__[:22]
0000s0sClass::DBI::Relationship::MightHave::::__ANON__[:26]Class::DBI::Relationship::MightHave::__ANON__[:26]
0000s0sClass::DBI::Relationship::MightHave::::__ANON__[:52]Class::DBI::Relationship::MightHave::__ANON__[:52]
0000s0sClass::DBI::Relationship::MightHave::::__ANON__[:71]Class::DBI::Relationship::MightHave::__ANON__[:71]
0000s0sClass::DBI::Relationship::MightHave::::_imported_accessorClass::DBI::Relationship::MightHave::_imported_accessor
0000s0sClass::DBI::Relationship::MightHave::::_object_accessorClass::DBI::Relationship::MightHave::_object_accessor
0000s0sClass::DBI::Relationship::MightHave::::methodsClass::DBI::Relationship::MightHave::methods
0000s0sClass::DBI::Relationship::MightHave::::remap_argumentsClass::DBI::Relationship::MightHave::remap_arguments
0000s0sClass::DBI::Relationship::MightHave::::triggersClass::DBI::Relationship::MightHave::triggers
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::MightHave;
2
3388µs125µsuse strict;
# spent 25µs making 1 call to strict::import
4383µs1114µsuse warnings;
# spent 114µs making 1 call to warnings::import
5
631.04ms10suse base 'Class::DBI::Relationship';
# spent 3.56ms making 1 call to base::import, recursion: max depth 3, time 3.56ms
7
8sub remap_arguments {
9 my ($proto, $class, $method, $f_class, @methods) = @_;
10 $class->_require_class($f_class);
11 return ($class, $method, $f_class, { import => \@methods });
12}
13
14sub triggers {
15 my $self = shift;
16
17 my $method = $self->accessor;
18
19 return (
20 before_update => sub {
21 if (my $for_obj = shift->$method()) { $for_obj->update }
22 },
23
24 before_delete => sub {
25 if (my $for_obj = shift->$method()) { $for_obj->delete }
26 },
27 );
28}
29
30sub methods {
31 my $self = shift;
32 my ($class, $method) = ($self->class, $self->accessor);
33 return (
34 $method => $self->_object_accessor,
35 map { $_ => $self->_imported_accessor($_) } @{ $self->args->{import} }
36 );
37}
38
39sub _object_accessor {
40 my $rel = shift;
41 my ($class, $method) = ($rel->class, $rel->accessor);
42 return sub {
43 my $self = shift;
44 my $meta = $class->meta_info($rel->name => $method);
45 my ($f_class, @extra) =
46 ($meta->foreign_class, @{ $meta->args->{import} });
47 return
48 if defined($self->{"_${method}_object"})
49 && $self->{"_${method}_object"}
50 ->isa('Class::DBI::Object::Has::Been::Deleted');
51 $self->{"_${method}_object"} ||= $f_class->retrieve($self->id);
52 };
53}
54
55sub _imported_accessor {
56 my ($rel, $name) = @_;
57 my ($class, $method) = ($rel->class, $rel->accessor);
58 return sub {
59 my $self = shift;
60 my $meta = $class->meta_info($rel->name => $method);
61 my ($f_class, @extra) =
62 ($meta->foreign_class, @{ $meta->args->{import} });
63 my $for_obj = $self->$method() || do {
64 return unless @_; # just fetching
65 my $val = shift;
66 $f_class->insert(
67 { $f_class->primary_column => $self->id, $name => $val });
68 $self->$method();
69 };
70 $for_obj->$name(@_);
71 };
72}
73
74114µs1;