File Coverage

lib/Net/ISC/DHCPd/Config/Role.pm
Criterion Covered Total %
statement 176 198 88.8
branch 65 86 75.5
condition 7 9 77.7
subroutine 342 344 99.4
pod 8 8 100.0
total 598 645 92.7


line stmt bran cond sub pod time code
1             package Net::ISC::DHCPd::Config::Role;
2              
3             =head1 NAME
4              
5             Net::ISC::DHCPd::Config::Role - Role with generic config methods and attributes
6              
7             =head1 DESCRIPTION
8              
9             This role contains common methods and attributes for each of the config
10             classes in the L<Net::ISC::DHCPd::Config> namespace.
11              
12             =head1 WARNINGS
13              
14             This module will warn when a line in the input config could not be parsed.
15             This can be turned off by adding the line below before calling L</parse>.
16              
17             no warnings 'net_isc_dhcpd_config_parse';
18              
19             =cut
20              
21 24     24   20749 use Class::Load;
  24         53  
  24         1377  
22 24     24   153 use Moose::Role;
  24         53  
  24         223  
23              
24             requires 'generate';
25              
26             my $COMMENT_RE = qr{^\s*\#\s*};
27              
28             =head1 ATTRIBUTES
29              
30             =head2 parent
31              
32             The parent node in the config tree. This must be an object which does
33             this role.
34              
35             =cut
36              
37             has parent => (
38             is => 'rw',
39             does => 'Net::ISC::DHCPd::Config::Role',
40             weak_ref => 1,
41             );
42              
43             =head2 root
44              
45             The root node in the config tree.
46              
47             =cut
48              
49             has root => (
50             is => 'ro',
51             isa => 'Object',
52             lazy => 1,
53             weak_ref => 1,
54             builder => '_build_root',
55             );
56              
57             sub _build_root {
58 75     75   142 my $obj = shift;
59              
60 75         2670 while(my $tmp = $obj->parent) {
61 108 100       1716 blessed($obj = $tmp) eq 'Net::ISC::DHCPd::Config' and last;
62             }
63              
64 75         2506 return $obj;
65             }
66              
67             =head2 depth
68              
69             Integer value that counts how far this node is from the root node.
70              
71             =cut
72              
73             has depth => (
74             is => 'ro',
75             isa => 'Int',
76             lazy => 1,
77             builder => '_build_depth',
78             );
79              
80             sub _build_depth {
81 0     0   0 my $self = shift;
82 0         0 my $obj = $self;
83 0         0 my $i = 0;
84              
85 0         0 while($obj = $obj->parent) {
86 0         0 $i++;
87 0 0       0 last if($obj == $self->root);
88             }
89              
90 0         0 return $i;
91             }
92              
93             =head2 children
94              
95             Holds a list of possible child objects as objects. This list is used
96             when L</parse> or L</generate_config_from_children> is called.
97             The child list has a default value set from L</create_children> in each
98             of the config modules. This is a static list, which reflects the actual
99             documentation from C<dhcpd.conf(5)>. Example:
100              
101             package Net::ISC::DHCPd::Config::Foo;
102             __PACKAGE__->create_children("Net::ISC::DHCPd::Config::Host");
103              
104             package main;
105             $config = Net::ISC::DHCPd::Config::Foo->new;
106             $config->add_host({ ... });
107             @host_objects = $config->find_hosts({ ... });
108             $config->remove_host({ ... });
109             @host_objects = $config->hosts;
110              
111             The L</create_children> method will autogenerate three methods and an
112             attribute. The name of the attribute and methods will be the last part
113             of the config class, with "s" at the end in some cases.
114              
115             =over 4
116              
117             =item foos
118              
119             C<foos> is the name the attribute as well as the accessor. The accessor
120             will auto-deref the array-ref to a list if called in list context. (yes:
121             be aware of this!).
122              
123             =item add_foo
124              
125             Instead of pushing values directly to the C<foos> list, an C<add_foo>
126             method is available. It can take either a hash, hash-ref or an object
127             to add/construct a new child.
128              
129             =item find_foos
130              
131             This method will return zero or more objects as a list. It takes
132             a hash-ref which will be matched against the object attributes of
133             the children.
134              
135             =item remove_foo
136              
137             This method will remove zero or more children from the C<foos> attribute.
138             The method takes a hash-ref which will be used to match against the
139             child list. It returns the number of child nodes actually matched and
140             removed.
141              
142             =back
143              
144             =cut
145              
146             # should be overridden by anything that has children
147 169     169 1 507 sub children { }
148              
149             # actual children
150             has _children => (
151             is => 'ro',
152             isa => 'ArrayRef',
153             default => sub { [] },
154             );
155              
156             =head2 comments
157              
158             @str = $self->comments;
159              
160             Will return all the comments before this element appeared in the config file.
161             The comments will not contain leading hash symbol spaces, nor trailing newline.
162              
163             =cut
164              
165             has _comments => (
166             is => 'ro',
167             traits => ['Array'],
168             init_arg => 'comments',
169             default => sub { [] },
170             handles => {
171             comments => 'elements',
172             },
173             );
174              
175             =head2 regex
176              
177             Regex used to scan a line of config text, which then spawns an
178             a new node to the config tree. This is used inside l</parse>.
179              
180             THIS IS A STATIC METHOD. SELF is not used.
181              
182             =cut
183              
184             =head2 endpoint
185              
186             Regex to search for before ending the current node block.
187             Will not be used if the node does not have any possible L</children>.
188              
189             =cut
190              
191             has endpoint => (
192             is => 'ro',
193             isa => 'Maybe[RegexpRef]',
194             builder => '_build_endpoint',
195             );
196              
197 302     302   30796 sub _build_endpoint { qr" ^ \s* } \s* $ "x }
198              
199             has _filehandle => (
200             is => 'ro',
201             lazy_build => 1,
202             );
203              
204             sub _build__filehandle {
205 107     107   207 my $self = shift;
206 107         131 my $file;
207              
208             # get filehandle from parent to prevent seeking file from beginning
209 107 100       3849 if(my $parent = $self->parent) {
210 89         3287 return $parent->_filehandle;
211             }
212              
213 18 100       809 if ($self->fh) {
214 16         639 return $self->fh;
215             }
216              
217 2         60 $file = $self->file;
218              
219 2 50 33     28 if($file->is_relative and !-e $file) {
220 0         0 $file = Path::Class::File->new($self->root->file->dir, $file);
221             }
222              
223 2         290 return $file->openr;
224             }
225              
226             =head2 filename_callback
227              
228             Callback for changing file paths when include files are on different relative paths.
229              
230             # here is an example:
231             my $cb = sub {
232             my $file = shift;
233             print "We're in callback and file is $file\n";
234             if ($file =~ /catphotos/) {
235             return "/dog.conf";
236             }
237             };
238              
239             =cut
240              
241             has filename_callback => (
242             is => 'rw',
243             isa => 'CodeRef',
244             );
245              
246              
247             =head1 METHODS
248              
249             =head2 BUILD
250              
251             Used to convert input arguments to child nodes.
252              
253             =cut
254              
255             sub BUILD {
256 295     295 1 35520 my($self, $args) = @_;
257 295         1454 my $meta = $self->meta;
258              
259 295         7042 for my $key (sort keys %$args) {
260 1108         19799 my $list = $args->{$key};
261 1108         1557 my $method = "add_$key";
262 1108         1906 $method =~ s/s$//;
263 1108 100 100     14057 if(ref $list eq 'ARRAY' and $meta->has_method($method)) {
264 6         193 for my $element (@$list) {
265 6         26 $self->$method($element);
266             }
267             }
268             }
269             }
270              
271             =head2 parse
272              
273             Will read a line of the time from the current config
274             L<file|Net::ISC::DHCPd::Config::Root/file>. For each line, this method
275             will loop though each object in L</children> and try to match the line
276             against a given child and create a new node in the object graph if it
277             match the L</regex>. This method is called recursively for each child
278             when possible.
279              
280             =cut
281              
282             sub parse {
283 113     113 1 2695 my $self = shift;
284 113         172 my $linebuf = $_[1];
285 113         4283 my $fh = $self->_filehandle;
286 113         4188 my $endpoint = $self->endpoint;
287 113         191 my($n, $pos, @comments);
288 113         170 my $lines = '';
289 113         177 my $line_from_array=0;
290              
291             LINE:
292 113         146 while(1) {
293 552         613 my $line;
294 552 50       2864 $pos = $fh->getpos or die $!;
295 552 100       1273 if (defined($linebuf->[0])) {
296 52         46 $line = pop(@{$linebuf});
  52         81  
297 52         71 $line_from_array=1;
298             } else {
299 500 100       73202 defined($line = readline $fh) or last LINE;
300 476         549 $n++;
301 476         692 chomp $line;
302 476         554 $line_from_array=0;
303             # From here we need to preprocess the line to see if it can be broken
304             # into multiple lines. Something like group { option test; }
305             # lines with comments can't be handled by this so we do them first
306 476 100       2778 if($line =~ s/$COMMENT_RE//) {
307 27         56 push @comments, $line;
308 27         57 next LINE;
309             }
310              
311 449         898 $line =~ s/ ([;\{\}]) # after semicolon or braces
312             ([^;\n\r]) # if there isn't a semicolon or return
313             /$1\n$2/gx; # insert a newline
314              
315 449 100       1349 if ($line =~ /\n/) {
316 14         14 push(@{$linebuf}, reverse split(/\n/, $line));
  14         69  
317 14         33 next LINE;
318             }
319             }
320              
321              
322 487 100       4280 if($self->can('slurp')) {
    100          
    100          
    100          
323 63         169 my $action = $self->slurp($line); # next or last
324 63 100       160 if($action eq 'next') {
    50          
    0          
325 49         86 next LINE;
326             }
327             elsif($action eq 'last') {
328 14         30 last LINE;
329             }
330             elsif($action eq 'backtrack') {
331 0 0       0 if ($line_from_array) {
332 0         0 push(@{$linebuf}, $line);
  0         0  
333             } else {
334 0         0 $fh->setpos($pos);
335 0         0 $n--;
336             }
337 0         0 last LINE;
338             }
339             }
340             elsif($line =~ /^\s*$/o) {
341 55         112 next LINE;
342             }
343             elsif($line =~ $endpoint) {
344 75         267 $self->captured_endpoint($1, $2, $3, $4); # urk...
345 75 50       2942 next LINE if($self->root == $self);
346 75         160 last LINE;
347             }
348             elsif ($line =~ /^\s*{\s*$/) {
349 9         22 next LINE;
350             }
351              
352             # this is how we handle incomplete lines
353             # we need a space for lines like 'option\ndomain-name-servers'
354 285 100       575 if ($lines =~ /\S$/) {
355 21         62 $lines .= ' '.$line;
356             } else {
357 264         454 $lines = $line;
358             }
359              
360             CHILD:
361 285         1009 for my $child ($self->children) {
362 1953         12690 my $regex = $child->can('regex');
363 1953 100       5912 my @c = $lines =~ $regex->() or next CHILD;
364 264         1997 my $add = 'add_' .lc +($child =~ /::(\w+)$/)[0];
365 264         1527 my $method = $child->can('captured_to_args');
366 264         946 my $args = $method->(@c);
367 264         6145 my $obj;
368              
369 264         1093 $args->{'comments'} = [@comments];
370 264         409 @comments = ();
371 264         350 $lines = '';
372 264         1068 $obj = $self->$add($args);
373              
374             # the recursive statement is used for Include.pm
375 264 100       859 $n += $obj->parse('recursive', $linebuf) if(@_ = $obj->children);
376              
377 264         1344 next LINE;
378             }
379              
380             # if we get here that means our parse failed. If the incoming line
381             # doesn't have a semicolon then we can guess it's a partial line and
382             # append the next line to it.
383             # we could do this with Slurp but then everything would need to
384             # support slurp and odd semicolon handling. If we figure out a way to
385             # merge the lines then the normal parser should be able to cover it.
386 21 50       83 if ($lines !~ /;/) {
387 21         34 next LINE;
388             }
389              
390              
391 0 0       0 if(warnings::enabled('net_isc_dhcpd_config_parse')) {
392 0         0 warn sprintf qq[Could not parse "%s" at %s line %s\n],
393             $lines,
394             $self->root->file,
395             $fh->input_line_number
396             ;
397             }
398             }
399              
400 113 100       616 return $n ? $n : '0e0';
401             }
402              
403             =head2 captured_to_args
404              
405             $hash_ref = $self->captured_to_args(@list);
406              
407             Called when a L</regex> matches, with a list of captured strings.
408             This method then returns a hash-ref passed on to the constructor when
409             a new node in the object graph is constructed.
410              
411             THIS IS A STATIC METHOD. SELF is not used.
412              
413             =cut
414              
415             sub captured_to_args {
416 12     12 1 26 return {};
417             }
418              
419             =head2 captured_endpoint
420              
421             $self->captured_endpoint(@list)
422              
423             Called when a L</endpoint> matches, with a list of captured strings.
424              
425             =cut
426              
427             sub captured_endpoint {
428 75     75 1 116 return;
429             }
430              
431             =head2 create_children
432              
433             This method takes a list of classes, and creates builder method for
434             the L</children> attribute, an attribute and helper methods. See
435             L</children> for more details.
436              
437             =cut
438              
439             sub create_children {
440 240     240 1 995 my $self = shift;
441 240         1645 my $meta = $self->meta;
442 240         6060 my @children = @_;
443              
444 240         685 for my $class (@children) {
445 1944         92777 my $name = lc (($class =~ /::(\w+)$/)[0]);
446 1944         4538 my $attr = $name .'s';
447              
448             # hack so the child method for class is classes instead of classs
449 1944 100       6620 $attr = $name . 'es' if ($name =~ /s$/);
450              
451              
452 1944         6914 Class::Load::load_class($class);
453              
454 1944 50       75810 unless($meta->find_method_by_name($attr)) {
455 1944     278   254352 $meta->add_method("add_${name}" => sub { shift->_add_child($class, @_) });
  278     278   2009  
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
        278      
456 1944     6   102889 $meta->add_method("find_${attr}" => sub { shift->_find_children($class, @_) });
  6     6   30  
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
        6      
457 1944     11   91165 $meta->add_method("remove_${attr}" => sub { shift->_remove_children($class, @_) });
  11     11   47  
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
        11      
458             $meta->add_method($attr => sub {
459 174     174   3076 my $self = shift;
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
        174      
460 174 50       490 return $self->_set_children($class, @_) if(@_);
461 174         624 return $self->_get_children_by_class($class);
462 1944         89593 });
463             }
464             }
465              
466 240         10615 return \@children;
467             }
468              
469             sub _set_children {
470 0     0   0 my($self, $attr, $class, $children) = @_;
471              
472 0         0 for my $child (@$children) {
473 0 0       0 $child = $class->new(parent => $self, %$child) if(ref $child eq 'HASH');
474             }
475              
476 0         0 @{ $self->_children } = @$children;
  0         0  
477             }
478              
479             sub _get_children_by_class {
480 174     174   284 my($self, $class) = @_;
481 174         226 my @children = grep { $class eq blessed $_ } @{ $self->_children };
  1075         3375  
  174         6707  
482              
483 174 100       3962 return wantarray ? @children : \@children;
484             }
485              
486             sub _add_child {
487 278     278   365 my $self = shift;
488 278         354 my $class = shift;
489 278 100       691 my $child = @_ == 1 ? $_[0] : {@_};
490 278         9682 my $children = $self->_children;
491              
492 278 50       860 if(ref $child eq 'HASH') {
493 278         10174 $child = $class->new(parent => $self, %$child);
494             }
495              
496 278         783 push @$children, $child;
497 278         695 return $child;
498             }
499              
500             sub _find_children {
501 6     6   13 my($self, $class, $query) = @_;
502 6         9 my @children;
503              
504 6 50       21 if(ref $query ne 'HASH') {
505 0         0 return;
506             }
507              
508             CHILD:
509 6         10 for my $child (@{ $self->_children }) {
  6         198  
510 76 100       559 if($class ne blessed $child) {
511 72         112 next CHILD;
512             }
513 4         13 for my $key (keys %$query) {
514 4 100       132 next CHILD unless($child->$key eq $query->{$key});
515             }
516 2         283 push @children, $child;
517             }
518              
519 6         34 return @children;
520             }
521              
522             sub _remove_children {
523 11     11   16 my $self = shift;
524 11         18 my $class = shift;
525 11 50       29 my $query = shift or return;
526 11         314 my $children = $self->_children;
527 11         19 my $i = 0;
528 11         15 my @removed;
529              
530             CHILD:
531 11         32 while($i < @$children) {
532 85 100       248 if($class ne blessed $children->[$i]) {
533 69         72 next CHILD;
534             }
535 16         51 for my $key (keys %$query) {
536 14 100       389 next CHILD unless($children->[$i]->$key eq $query->{$key});
537             }
538 12         1007 push @removed, splice @$children, $i, 1;
539 12         18 $i--;
540             } continue {
541 85         185 $i++;
542             }
543              
544 11         248 return @removed;
545             }
546              
547              
548             =head2 find_all_children
549              
550             Loops through all child nodes with recursion looking for nodes of "class"
551             type. Returns an array of those nodes. You can use the full classname or
552             just the end part. For subclasses like Host::FixedAddress you would need to
553             use the whole name.
554              
555             my @subnet = $config->find_all_children('subnet');
556              
557             =cut
558              
559             sub find_all_children {
560 7     7 1 10 my $self = shift;
561 7         13 my $class = shift;
562 7         9 my @children;
563              
564 7 100       18 if ($class !~ /::/) {
565             # strip plural if they put it.
566 1         5 $class =~ s/s\z//;
567 1         3 $class =~ s/(class|address)e/$1/;
568 1         6 $class = 'Net::ISC::DHCPd::Config::' . ucfirst(lc($class));
569             }
570              
571 7         10 for my $child (@{ $self->_children }) {
  7         309  
572 6 100       18 if (ref($child) eq $class) {
573 3         6 push(@children, $child);
574             }
575              
576 6 50       276 if ($child->_children) {
577 6         22 push(@children, $child->find_all_children($class));
578             }
579             }
580 7         25 return @children;
581             }
582              
583             =head2 generate_config_from_children
584              
585             Loops all child nodes in reverse order and calls L</generate> on each
586             of them. Each L</generate> method must return a list of strings which
587             will be indented correctly and concatenated with newline inside this
588             method, before returned as one string.
589              
590             =cut
591              
592             sub generate_config_from_children {
593 26     26 1 113 return join "\n", shift->_generate_config_from_children;
594             }
595              
596             sub _generate_config_from_children {
597 46     46   6055 my $self = shift;
598 46         78 my $indent = '';
599 46         239 my @text;
600              
601 46 100 100     2500 if($self->parent and !$self->can('generate_with_include')) {
602 27         50 $indent = ' ' x 4;
603             }
604              
605 46         269 for my $child (@{ $self->_children }) {
  46         2506  
606 109         5873 push @text, map { "$indent# $_" } $child->comments;
  17         58  
607 109         418 push @text, map { "$indent$_" } $child->generate;
  229         1477  
608             }
609              
610 46         505 return @text;
611             }
612              
613             =head2 generate
614              
615             A C<generate()> must be defined in the consuming class. This method
616             must return a list of lines (zero or more), which will be indented
617             and concatenated inside L</generate_config_from_children>.
618              
619             =head1 COPYRIGHT & LICENSE
620              
621             =head1 AUTHOR
622              
623             See L<Net::ISC::DHCPd>.
624              
625             =cut
626              
627             package # hack to register a new warnings category
628             net_isc_dhcpd_config_parse;
629 24     24   200488 use warnings::register;
  24         65  
  24         4239  
630              
631             1;