line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Dancer::Object; |
2
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:SUKRIA'; |
3
|
|
|
|
|
|
|
#ABSTRACT: Objects base class for Dancer |
4
|
|
|
|
|
|
|
$Dancer::Object::VERSION = '1.3521'; |
5
|
|
|
|
|
|
|
# This class is a root class for each object in Dancer. |
6
|
|
|
|
|
|
|
# It provides basic OO tools for Perl5 without being... Moose ;-) |
7
|
|
|
|
|
|
|
|
8
|
203
|
|
|
203
|
|
67421
|
use strict; |
|
203
|
|
|
|
|
437
|
|
|
203
|
|
|
|
|
5643
|
|
9
|
203
|
|
|
203
|
|
1066
|
use warnings; |
|
203
|
|
|
|
|
434
|
|
|
203
|
|
|
|
|
4471
|
|
10
|
203
|
|
|
203
|
|
960
|
use Carp; |
|
203
|
|
|
|
|
498
|
|
|
203
|
|
|
|
|
10944
|
|
11
|
203
|
|
|
203
|
|
90603
|
use Dancer::Exception qw(:all); |
|
203
|
|
|
|
|
657
|
|
|
203
|
|
|
|
|
64362
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# constructor |
14
|
|
|
|
|
|
|
sub new { |
15
|
4785
|
|
|
4785
|
1
|
68201
|
my ($class, %args) = @_; |
16
|
4785
|
|
|
|
|
8916
|
my $self = \%args; |
17
|
4785
|
|
|
|
|
8757
|
bless $self, $class; |
18
|
4785
|
|
|
|
|
21953
|
$self->init(%args); |
19
|
4782
|
|
|
|
|
88951
|
return $self; |
20
|
|
|
|
|
|
|
} |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub clone { |
23
|
1
|
|
|
1
|
1
|
3
|
my ($self) = @_; |
24
|
1
|
50
|
|
|
|
8
|
raise core => "The 'Clone' module is needed" |
25
|
|
|
|
|
|
|
unless Dancer::ModuleLoader->load('Clone'); |
26
|
1
|
|
|
|
|
31
|
return Clone::clone($self); |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# initializer |
30
|
139
|
|
|
139
|
1
|
1352
|
sub init {1} |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# meta information about classes |
33
|
|
|
|
|
|
|
my $_attrs_per_class = {}; |
34
|
|
|
|
|
|
|
sub get_attributes { |
35
|
349
|
|
|
349
|
1
|
1324
|
my ($class, $visited_parents) = @_; |
36
|
|
|
|
|
|
|
# $visited_parents keeps track of parent classes we already handled, to |
37
|
|
|
|
|
|
|
# avoid infinite recursion (in case of dependencies loop). It's not stored as class singleton, otherwise |
38
|
|
|
|
|
|
|
# get_attributes wouldn't be re-entrant. |
39
|
349
|
|
100
|
|
|
2745
|
$visited_parents ||= {}; |
40
|
349
|
100
|
|
|
|
713
|
my @attributes = @{$_attrs_per_class->{$class} || [] }; |
|
349
|
|
|
|
|
2815
|
|
41
|
349
|
|
|
|
|
951
|
my @parents; |
42
|
203
|
|
|
203
|
|
1658
|
{ no strict 'refs'; |
|
203
|
|
|
|
|
464
|
|
|
203
|
|
|
|
|
67062
|
|
|
349
|
|
|
|
|
686
|
|
43
|
349
|
|
|
|
|
686
|
@parents = @{"$class\::ISA"}; } |
|
349
|
|
|
|
|
2408
|
|
44
|
349
|
|
|
|
|
1274
|
foreach my $parent (@parents) { |
45
|
|
|
|
|
|
|
# cleanup $parent |
46
|
176
|
|
|
|
|
868
|
$parent =~ s/'/::/g; |
47
|
176
|
50
|
|
|
|
922
|
$parent =~ /^::/ |
48
|
|
|
|
|
|
|
and $parent = 'main' . $parent; |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
# check we didn't visited it already |
51
|
176
|
50
|
|
|
|
1082
|
$visited_parents->{$parent}++ |
52
|
|
|
|
|
|
|
and next; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# check it's a Dancer::Object |
55
|
176
|
50
|
|
|
|
2211
|
$parent->isa(__PACKAGE__) |
56
|
|
|
|
|
|
|
or next; |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
# merge parents attributes |
59
|
176
|
|
|
|
|
604
|
push @attributes, @{$parent->get_attributes($visited_parents)}; |
|
176
|
|
|
|
|
2369
|
|
60
|
|
|
|
|
|
|
} |
61
|
349
|
|
|
|
|
1831
|
return \@attributes; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
# accessor code for normal objects |
65
|
|
|
|
|
|
|
# (overloaded in D::O::Singleton for instance) |
66
|
|
|
|
|
|
|
sub _setter_code { |
67
|
10960
|
|
|
10960
|
|
19505
|
my ($class, $attr) = @_; |
68
|
|
|
|
|
|
|
sub { |
69
|
68340
|
|
|
68340
|
|
131209
|
my ($self, $value) = @_; |
70
|
68340
|
100
|
|
|
|
107294
|
if (@_ == 1) { |
71
|
61005
|
|
|
|
|
202429
|
return $self->{$attr}; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
else { |
74
|
7335
|
|
|
|
|
18464
|
return $self->{$attr} = $value; |
75
|
|
|
|
|
|
|
} |
76
|
10960
|
|
|
|
|
41635
|
}; |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# accessors builder |
80
|
|
|
|
|
|
|
sub attributes { |
81
|
2730
|
|
|
2730
|
1
|
15226
|
my ($class, @attributes) = @_; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# save meta information |
84
|
2730
|
|
|
|
|
9014
|
$_attrs_per_class->{$class} = \@attributes; |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
# define setters and getters for each attribute |
87
|
2730
|
|
|
|
|
7405
|
foreach my $attr (@attributes) { |
88
|
11727
|
|
|
|
|
30184
|
my $code = $class->_setter_code($attr); |
89
|
11727
|
|
|
|
|
25987
|
my $method = "${class}::${attr}"; |
90
|
203
|
|
|
203
|
|
1686
|
{ no strict 'refs'; *$method = $code; } |
|
203
|
|
|
|
|
459
|
|
|
203
|
|
|
|
|
28582
|
|
|
11727
|
|
|
|
|
14924
|
|
|
11727
|
|
|
|
|
47390
|
|
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub attributes_defaults { |
95
|
1086
|
|
|
1086
|
1
|
4784
|
my ($self, %defaults) = @_; |
96
|
1086
|
|
|
|
|
3960
|
while (my ($k, $v) = each %defaults) { |
97
|
6296
|
100
|
|
|
|
21346
|
exists $self->{$k} or $self->{$k} = $v; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
1; |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
__END__ |