File Coverage

lib/Net/ISC/DHCPd/OMAPI/Actions.pm
Criterion Covered Total %
statement 3 121 2.4
branch 0 58 0.0
condition 0 6 0.0
subroutine 1 9 11.1
pod 4 4 100.0
total 8 198 4.0


line stmt bran cond sub pod time code
1             package Net::ISC::DHCPd::OMAPI::Actions;
2              
3             =head1 NAME
4              
5             Net::ISC::DHCPd::OMAPI::Actions - Common actions on OMAPI objects
6              
7             =head1 DESCRIPTION
8              
9             This module contains methods which can be called on each of the
10             L<Net::ISC::DHCPd::OMAPI> subclasses.
11              
12             Changing object attributes will not alter the attributes on server. To do
13             so use L</write> to update the server.
14              
15             =cut
16              
17 1     1   409 use Moose::Role;
  1         2  
  1         6  
18              
19             my $ATTR_ROLE = "Net::ISC::DHCPd::OMAPI::Meta::Attribute";
20              
21             =head1 ATTRIBUTES
22              
23             =head2 parent
24              
25             $omapi_obj = $self->parent;
26              
27             Returns the parent L<Net::ISC::DHCPd::OMAPI> object.
28              
29             =cut
30              
31             has parent => (
32             is => 'ro',
33             isa => 'Net::ISC::DHCPd::OMAPI',
34             required => 1,
35             );
36              
37             =head2 errstr
38              
39             $str = $self->errstr;
40              
41             Holds the latest error. Check this if a method returns empty list.
42              
43             =cut
44              
45             has errstr => (
46             is => 'rw',
47             isa => 'Str',
48             default => '',
49             );
50              
51             =head2 extra_attributes
52              
53             $hash_ref = $self->extra_attributes;
54              
55             Contains all attributes, which is not predefined by the OMAPI object.
56              
57             Note: If you ever need to use this - send me a bug report, since it
58             means something is missing.
59              
60             =cut
61              
62             has extra_attributes => (
63             is => 'ro',
64             isa => 'HashRef',
65             default => sub { {} },
66             );
67              
68             =head1 METHODS
69              
70             =head2 read
71              
72             $int = $self->read;
73              
74             Open an object. Returns the number of attributes read. 0 = not in server.
75              
76             It looks up an object on server, by all the attributes that has action
77             C<lookup>. Will update all attributes in the local object, and setting
78             all unknown objects in L</extra_attributes>.
79              
80              
81             This is subject for change, but:
82              
83             C<read()> will also do a post check which checks if the retrieved values
84             actually match the one used to lookup. If they do not match all retrieved
85             data will be stored in L</extra_attributes> and this method will return
86             zero (0).
87              
88             =cut
89              
90             sub read {
91 0     0 1   my $self = shift;
92 0           my $post_check_failed = 0;
93 0           my $n = 0;
94 0           my(@out, %out);
95              
96 0           @out = $self->_open;
97              
98 0           %{ $self->extra_attributes } = (); # clear all extra attributes
  0            
99              
100 0           while($out[-1] =~ /(\S+)\s=\s(\S+)/g) {
101 0           my($name, $value) = ($1, $2);
102 0           $name =~ s/-/_/g;
103 0           $value =~ s/^"(.*)"$/$1/;
104 0           $n++;
105              
106 0 0         if(my $attr = $self->meta->get_attribute($name)) {
107              
108 0 0 0       if( #_ugly___________________________
      0        
109 0           $attr->does($ATTR_ROLE)
110             and $self->${ \"has_$name" }
111             and $attr->has_action('lookup')
112             ) { #--------------------------------
113              
114 0 0         if($attr->should_coerce) {
115 0           $value = $attr->type_constraint->coerce($value);
116             }
117              
118 0 0         if($self->$name ne $value) {
119 0           $post_check_failed = 1;
120             }
121             }
122              
123 0           $out{$name} = $value;
124             }
125             else {
126 0           $self->extra_attributes->{$name} = $value;
127             }
128             }
129              
130 0           for my $name (keys %out) {
131 0 0         if($post_check_failed) {
132 0           $self->extra_attributes->{$name} = $out{$name};
133             }
134             else {
135 0           $self->$name($out{$name});
136             }
137             }
138              
139 0 0         return $post_check_failed ? 0 : $n;
140             }
141              
142             around read => \&_around;
143              
144             =head2 write
145              
146             $bool = $self->write;
147             $bool = $self->write(@attributes);
148              
149             Will set attributes on server object.
150              
151             C<@attributes> is by default every attribute on create, or every
152             attribute with action "modify" on update.
153              
154             =cut
155              
156             sub write {
157 0     0 1   my $self = shift;
158 0           my @attr = @_;
159 0           my $new = 0;
160 0           my(@cmd, @out);
161              
162             # check for existence
163 0           @out = $self->_open;
164              
165 0 0         if(grep { /not found/i } @out) {
  0            
166 0           $new = 1;
167             }
168              
169 0 0         if(@attr == 0) {
170 0           for my $attr ($self->meta->get_all_attributes) {
171 0           my $name = $attr->name;
172              
173 0 0         next if(!$attr->does($ATTR_ROLE));
174 0 0         next if(!$self->${ \"has_$name" });
  0            
175 0 0         next if(!$attr->has_action('modify'));
176              
177 0           push @attr, $attr;
178             }
179             }
180              
181 0 0         @cmd = map { $self->_set_cmd($_) } @attr or return;
  0            
182              
183             # set attributes
184 0           @out = $self->_cmd(@cmd);
185              
186             # update or create
187 0 0         @out = $self->_cmd( $new ? "create" : "update" ) or return;
    0          
188              
189 0 0         if(grep { /not found/ } @out) {
  0            
190 0           $self->errstr("not found");
191 0           return;
192             }
193              
194 0 0         return $new ? +1 : -1;
195             }
196              
197             around write => \&_around;
198              
199             =head2 unset
200              
201             $bool = $self->unset(@attributes);
202              
203             Will unset values for an object in DHCP server.
204              
205             =cut
206              
207             sub unset {
208 0     0 1   my $self = shift;
209 0           my @attr = @_;
210 0           my(@out, $success);
211            
212 0           @out = $self->_cmd(map { local $_ = $_; s/_/-/g; "unset $_" } @attr);
  0            
  0            
  0            
213              
214             # read @out:
215             # ip-address = <null>
216             # key = value
217             # ...
218              
219 0 0         if($success) {
220 0           $self->${ \"clear_$_" } for(@attr);
  0            
221             }
222              
223 0           return 1;
224             }
225              
226             around unset => \&_around;
227              
228             =head2 remove
229              
230             $bool = $self->remove;
231              
232             This method will remove the object from the server.
233              
234             =cut
235              
236             sub remove {
237 0     0 1   my $self = shift;
238 0           my @out;
239              
240 0           @out = $self->_open;
241 0           @out = $self->_cmd('remove');
242              
243 0 0         if(grep { /not implemented/i } @out) {
  0            
244 0           $self->errstr('not implemented');
245 0           return;
246             }
247 0 0         if(grep { /not found/i } @out) {
  0            
248 0           $self->errstr('not found');
249 0           return;
250             }
251              
252 0           for my $attr ($self->meta->get_all_attributes) {
253 0 0         next unless($attr->does($ATTR_ROLE));
254 0           my $clearer = 'clear_' .$attr->name;
255 0           $self->$clearer;
256             }
257              
258 0           return 1;
259             }
260              
261             around remove => \&_around;
262              
263             # @out = $self->_open;
264             sub _open {
265 0     0     my $self = shift;
266 0           my @cmd;
267              
268 0           for my $name ($self->meta->get_attribute_list) {
269 0           my $attr = $self->meta->get_attribute($name);
270              
271 0 0         next unless($attr->does("Net::ISC::DHCPd::OMAPI::Meta::Attribute"));
272 0 0         next unless($attr->has_action("lookup"));
273 0 0         next unless($self->${ \"has_$name" });
  0            
274              
275 0           push @cmd, $self->_set_cmd($attr);
276             }
277              
278 0           return $self->_cmd(@cmd, "open");
279             }
280              
281             sub _set_cmd {
282 0     0     my $self = shift;
283 0           my $attr = shift;
284 0           my $name = $attr->name;
285 0           my $key = $name;
286 0           my $format;
287              
288 0           $key =~ s/_/-/g;
289 0 0         $format = $attr->type_constraint->equals('Str') ? 'set %s = "%s"'
290             : 'set %s = %s';
291              
292 0           return sprintf $format, $key, $self->${ \"raw_$name" };
  0            
293             }
294              
295             sub _around {
296 0     0     my $next = shift;
297 0           my $self = shift;
298 0           my $type = lc +(ref($self) =~ /::(\w+)$/)[0];
299 0           my(@out, @ret);
300              
301 0           $self->errstr("");
302              
303 0 0         @out = $self->_cmd("new $type") or return 0;
304 0           @ret = $self->$next(@_);
305 0 0         @out = $self->_cmd('close') or return 0;
306              
307 0 0         return @ret == 1 ? $ret[0] : @ret;
308             };
309              
310             # @buffer = $self->_cmd(@cmd)
311             # @buffer contains one-to-one output data from @cmd
312             # $self->errstr is reset each time empty errstr == success
313             sub _cmd {
314 0     0     my $self = shift;
315 0           my @cmd = @_;
316 0           my(@buffer, $head);
317              
318 0           for my $cmd (@cmd) {
319 0           my $tmp = $self->parent->_cmd($cmd);
320 0 0         last unless(defined $tmp);
321 0           push @buffer, $tmp;
322             }
323              
324 0 0         if($self->parent->errstr) {
325 0           $self->errstr($self->parent->errstr);
326 0           return;
327             }
328              
329 0           return @buffer;
330             }
331              
332             =head1 COPYRIGHT & LICENSE
333              
334             =head1 AUTHOR
335              
336             See L<Net::ISC::DHCPd>.
337              
338             =cut
339              
340             1;