line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#$Id: Base.pm,v 1.3 2004/03/09 20:34:26 zagap Exp $ |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package Net::Syndic8::Base; |
4
|
|
|
|
|
|
|
#require Exporter; |
5
|
|
|
|
|
|
|
# Import freeze() and thaw() for methods ref2str & str2ref |
6
|
1
|
|
|
1
|
|
1072
|
use FreezeThaw qw(freeze thaw); |
|
1
|
|
|
|
|
5899
|
|
|
1
|
|
|
|
|
94
|
|
7
|
1
|
|
|
1
|
|
9
|
use Carp; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1504
|
|
8
|
|
|
|
|
|
|
@Net::Syndic8::Base::ISA = qw(Exporter); |
9
|
|
|
|
|
|
|
@Net::Syndic8::Base::EXPORT = qw(attributes rtl_attributes); |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
$DEBUG = 0; # assign 1 to it to see code generated on the fly |
12
|
|
|
|
|
|
|
sub attributes { |
13
|
0
|
|
|
0
|
0
|
|
my ($pkg) = caller; |
14
|
0
|
|
|
|
|
|
croak "Error: attributes() invoked multiple times" |
15
|
0
|
0
|
|
|
|
|
if scalar @{"${pkg}::_ATTRIBUTES_"}; |
16
|
|
|
|
|
|
|
|
17
|
0
|
|
|
|
|
|
@{"${pkg}::_ATTRIBUTES_"} = @_; |
|
0
|
|
|
|
|
|
|
18
|
0
|
|
|
|
|
|
my $code = ""; |
19
|
0
|
0
|
|
|
|
|
print STDERR "Creating methods for $pkg\n" if $DEBUG; |
20
|
0
|
|
|
|
|
|
foreach my $attr (@_) { |
21
|
0
|
0
|
|
|
|
|
print STDERR " defining method $attr\n" if $DEBUG; |
22
|
|
|
|
|
|
|
# If the accessor is already present, give a warning |
23
|
0
|
0
|
|
|
|
|
if (UNIVERSAL::can($pkg,"$attr")) { |
24
|
0
|
|
|
|
|
|
carp "$pkg already has method: $attr"; |
25
|
0
|
|
|
|
|
|
next; |
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
# $code .= (UNIVERSAL::can($pkg,"__define_accessor")) ? __define_accessor ($pkg, $attr):_define_accessor ($pkg, $attr); |
28
|
0
|
|
|
|
|
|
$code .= _define_accessor ($pkg, $attr); |
29
|
|
|
|
|
|
|
} |
30
|
|
|
|
|
|
|
# $code .= _define_constructor($pkg); |
31
|
0
|
|
|
|
|
|
eval $code; |
32
|
0
|
0
|
|
|
|
|
if ($@) { |
33
|
0
|
|
|
|
|
|
die "ERROR defining and attributes for '$pkg':" |
34
|
|
|
|
|
|
|
. "\n\t$@\n" |
35
|
|
|
|
|
|
|
. "-----------------------------------------------------" |
36
|
|
|
|
|
|
|
. $code; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
|
sub rtl_attributes { |
40
|
0
|
|
|
0
|
0
|
|
my ($pkg) = caller; |
41
|
0
|
|
|
|
|
|
my $code = ""; |
42
|
0
|
|
|
|
|
|
foreach my $attr (@_) { |
43
|
0
|
0
|
|
|
|
|
print STDERR " defining method $attr\n" if $DEBUG; |
44
|
|
|
|
|
|
|
# If the accessor is already present, give a warning |
45
|
0
|
0
|
|
|
|
|
if (UNIVERSAL::can($pkg,"$attr")) { |
46
|
0
|
|
|
|
|
|
carp "$pkg already has rtl method: $attr"; |
47
|
0
|
|
|
|
|
|
next; |
48
|
|
|
|
|
|
|
} |
49
|
0
|
|
|
|
|
|
$code .= _define_rtl_accessor ($pkg, $attr); |
50
|
|
|
|
|
|
|
} |
51
|
0
|
|
|
|
|
|
eval $code; |
52
|
0
|
0
|
|
|
|
|
if ($@) { |
53
|
0
|
|
|
|
|
|
die "ERROR defining rtl_attributes for '$pkg':" |
54
|
|
|
|
|
|
|
. "\n\t$@\n" |
55
|
|
|
|
|
|
|
. "-----------------------------------------------------" |
56
|
|
|
|
|
|
|
. $code; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
sub _define_accessor { |
62
|
0
|
|
|
0
|
|
|
my ($pkg, $attr) = @_; |
63
|
|
|
|
|
|
|
# qq makes this block behave like a double-quoted string |
64
|
0
|
|
|
|
|
|
my $code = qq{ |
65
|
|
|
|
|
|
|
package $pkg; |
66
|
|
|
|
|
|
|
sub $attr { # Accessor ... |
67
|
|
|
|
|
|
|
my \$self=shift; |
68
|
|
|
|
|
|
|
\@_ ? \$self->set_attribute($attr,shift):\$self->get_attribute($attr); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
}; |
71
|
0
|
|
|
|
|
|
$code; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
sub _define_rtl_accessor { |
75
|
0
|
|
|
0
|
|
|
my ($pkg, $attr) = @_; |
76
|
|
|
|
|
|
|
# qq makes this block behave like a double-quoted string |
77
|
0
|
|
|
|
|
|
my $code = qq{ |
78
|
|
|
|
|
|
|
package $pkg; |
79
|
|
|
|
|
|
|
sub $attr { # Accessor ... |
80
|
|
|
|
|
|
|
my \$self=shift; |
81
|
|
|
|
|
|
|
\@_ ? \$self->set_attribute($attr,shift):\$self->get_attribute($attr); |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
}; |
84
|
0
|
|
|
|
|
|
$code; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
sub _define_constructor { |
87
|
0
|
|
|
0
|
|
|
my $pkg = shift; |
88
|
0
|
|
|
|
|
|
my $code = qq { |
89
|
|
|
|
|
|
|
package $pkg; |
90
|
|
|
|
|
|
|
sub new { |
91
|
|
|
|
|
|
|
my \$class =shift; |
92
|
|
|
|
|
|
|
my \$self={}; |
93
|
|
|
|
|
|
|
my \$stat; |
94
|
|
|
|
|
|
|
bless (\$self,\$class); |
95
|
|
|
|
|
|
|
return (\$stat=\$self->_init(\@_)) ? \$self: \$stat; |
96
|
|
|
|
|
|
|
# return \$self if (\$self->_init(\@_)); |
97
|
|
|
|
|
|
|
# return (\$stat=\$self->Error) ? \$stat : "Error initialize"; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
}; |
100
|
0
|
|
|
|
|
|
$code; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
sub get_attribute_names { |
103
|
0
|
|
|
0
|
0
|
|
my $pkg = shift; |
104
|
0
|
0
|
|
|
|
|
$pkg = ref($pkg) if ref($pkg); |
105
|
0
|
|
|
|
|
|
my @result = @{"${pkg}::_ATTRIBUTES_"}; |
|
0
|
|
|
|
|
|
|
106
|
0
|
0
|
|
|
|
|
if (defined (@{"${pkg}::ISA"})) { |
|
0
|
|
|
|
|
|
|
107
|
0
|
|
|
|
|
|
foreach my $base_pkg (@{"${pkg}::ISA"}) { |
|
0
|
|
|
|
|
|
|
108
|
0
|
|
|
|
|
|
push (@result, get_attribute_names($base_pkg)); |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
} |
111
|
0
|
|
|
|
|
|
@result; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub set_attribute { |
116
|
0
|
|
|
0
|
0
|
|
my ($obj, $attr_name, $attr_value) = @_; |
117
|
0
|
|
|
|
|
|
$obj->{"Var"}->{$attr_name}=$attr_value; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
# |
120
|
|
|
|
|
|
|
sub get_attribute { |
121
|
0
|
|
|
0
|
0
|
|
my ($self, $attr_name) = @_; |
122
|
0
|
|
|
|
|
|
return $self->{"Var"}->{$attr_name}; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# $obj->set_attributes (name => 'John', age => 23); |
126
|
|
|
|
|
|
|
# Or, $obj->set_attributes (['name', 'age'], ['John', 23]); |
127
|
|
|
|
|
|
|
sub set_attributes { |
128
|
0
|
|
|
0
|
0
|
|
my $obj = shift; |
129
|
0
|
|
|
|
|
|
my $attr_name; |
130
|
0
|
0
|
|
|
|
|
if (ref($_[0])) { |
131
|
0
|
|
|
|
|
|
my ($attr_name_list, $attr_value_list) = @_; |
132
|
0
|
|
|
|
|
|
my $i = 0; |
133
|
0
|
|
|
|
|
|
foreach $attr_name (@$attr_name_list) { |
134
|
0
|
|
|
|
|
|
$obj->$attr_name($attr_value_list->[$i++]); |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
} else { |
137
|
0
|
|
|
|
|
|
my ($attr_name, $attr_value); |
138
|
0
|
|
|
|
|
|
while (@_) { |
139
|
0
|
|
|
|
|
|
$attr_name = shift; |
140
|
0
|
|
|
|
|
|
$attr_value = shift; |
141
|
0
|
|
|
|
|
|
$obj->$attr_name($attr_value); |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
# @attrs = $obj->get_attributes (qw(name age)); |
147
|
|
|
|
|
|
|
sub get_attributes { |
148
|
0
|
|
|
0
|
0
|
|
my $obj = shift; |
149
|
0
|
|
|
|
|
|
my (@retval); |
150
|
0
|
|
|
|
|
|
map {$obj->$_()} @_; |
|
0
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
sub new { |
153
|
0
|
|
|
0
|
0
|
|
my $class =shift; |
154
|
0
|
|
|
|
|
|
my $self={}; |
155
|
0
|
|
|
|
|
|
my $stat; |
156
|
0
|
|
|
|
|
|
bless ($self,$class); |
157
|
0
|
0
|
|
|
|
|
return ($stat=$self->_init(@_)) ? $self: $stat; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
sub _init{ |
160
|
0
|
|
|
0
|
|
|
my $self=shift; |
161
|
0
|
|
|
|
|
|
return 1; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
#-------- this methods use for |
164
|
|
|
|
|
|
|
#encodes complex data structures into printable ASCII strings |
165
|
|
|
|
|
|
|
#used module FreezeThaw, written by Ilya Zakharevich |
166
|
|
|
|
|
|
|
sub ref2str{ |
167
|
0
|
|
|
0
|
0
|
|
my ($self,$ref)=@_; |
168
|
0
|
|
|
|
|
|
return freeze($ref); |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
sub str2ref{ |
171
|
0
|
|
|
0
|
0
|
|
my ($self,$str)=@_; |
172
|
0
|
|
|
|
|
|
return (thaw($str))[0]; |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
#put message into syslog |
175
|
|
|
|
|
|
|
sub logmsgs { |
176
|
0
|
|
|
0
|
0
|
|
my $self=shift; |
177
|
0
|
|
|
|
|
|
open FH, ">>system.log"; |
178
|
0
|
|
|
|
|
|
print FH ref($self)." @_\n"; |
179
|
0
|
|
|
|
|
|
close FH; |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
1; |