Profile of /project/perl/lib/Class/DBI/Relationship/MightHave.pm

File	/project/perl/lib/Class/DBI/Relationship/MightHave.pm
Statements Executed	10
Statement Execution Time	1.22ms

Subroutines — ordered by exclusive time
Exclusive Time	Inclusive Time	Subroutine
0s	0s	Class::DBI::Relationship::MightHave::BEGIN
0s	0s	Class::DBI::Relationship::MightHave::__ANON__[:22]
0s	0s	Class::DBI::Relationship::MightHave::__ANON__[:26]
0s	0s	Class::DBI::Relationship::MightHave::__ANON__[:52]
0s	0s	Class::DBI::Relationship::MightHave::__ANON__[:71]
0s	0s	Class::DBI::Relationship::MightHave::_imported_accessor
0s	0s	Class::DBI::Relationship::MightHave::_object_accessor
0s	0s	Class::DBI::Relationship::MightHave::methods
0s	0s	Class::DBI::Relationship::MightHave::remap_arguments
0s	0s	Class::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
1					package Class::DBI::Relationship::MightHave;
2
3	3	88µs	1	25µs	use strict; # spent 25µs making 1 call to strict::import
4	3	83µs	1	114µs	use warnings; # spent 114µs making 1 call to warnings::import
5
6	3	1.04ms	1	0s	use base 'Class::DBI::Relationship'; # spent 3.56ms making 1 call to base::import, recursion: max depth 3, time 3.56ms
7
8					sub 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
14					sub 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
30					sub 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
39					sub _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
55					sub _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
74	1	14µs			1;