File Coverage

blib/lib/Net/Syndic8/Base.pm
Criterion Covered Total %
statement 6 87 6.9
branch 0 24 0.0
condition n/a
subroutine 2 17 11.7
pod 0 11 0.0
total 8 139 5.7


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;