File Coverage

blib/lib/Config/Model/Backend/OpenSsh/Role/MatchBlock.pm
Criterion Covered Total %
statement 64 65 98.4
branch 5 6 83.3
condition 4 6 66.6
subroutine 13 13 100.0
pod 0 4 0.0
total 86 94 91.4


line stmt bran cond sub pod time code
1             #
2             # This file is part of Config-Model-OpenSsh
3             #
4             # This software is Copyright (c) 2008-2022 by Dominique Dumont.
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU Lesser General Public License, Version 2.1, February 1999
9             #
10 4     4   1973 use strict;
  4         8  
  4         113  
11 4     4   18 use warnings;
  4         9  
  4         177  
12              
13             $Config::Model::Backend::OpenSsh::Role::MatchBlock::VERSION = '2.9.0.2';
14             use Mouse::Role ;
15 4     4   21  
  4         8  
  4         25  
16             requires qw(current_node write_node_content write_line);
17              
18             use Carp ;
19 4     4   1161 use IO::File ;
  4         8  
  4         242  
20 4     4   24 use Log::Log4perl;
  4         9  
  4         575  
21 4     4   24 use File::Copy ;
  4         8  
  4         27  
22 4     4   188 use File::Path ;
  4         14  
  4         180  
23 4     4   21  
  4         17  
  4         1885  
24             my $logger = Log::Log4perl::get_logger("Backend::OpenSsh");
25              
26             my ($self, $root, $key, $pairs, $comment, $check) = @_ ;
27             $logger->debug("match: @$pairs # $comment");
28 8     8 0 28 my $list_obj = $root->fetch_element('Match');
29 8         48  
30 8         68 # create new match block
31             my $nb_of_elt = $list_obj->fetch_size;
32             my $block_obj = $list_obj->fetch_with_id($nb_of_elt) ;
33 8         30397 $block_obj->annotation($comment) ;
34 8         63  
35 8         7844 while (@$pairs) {
36             my $criteria = shift @$pairs;
37 8         237 my $pattern = shift @$pairs;
38 15         12747 $block_obj->load(
39 15         29 steps => qq!Condition $criteria="$pattern"!,
40 15         76 check => $check,
41             );
42             }
43              
44             $self->current_node( $block_obj->fetch_element('Settings') );
45             }
46 8         19331  
47              
48             my $self = shift ;
49             my $match_elt = shift ;
50             my $mode = shift || '';
51 12     12 0 29  
52 12         30 my $result = '';
53 12   100     59 foreach my $elt ($match_elt->fetch_all($mode) ) {
54             $result .= $self->write_match_block($elt,$mode) ;
55 12         27 }
56 12         78  
57 4         317 return $result ;
58             }
59              
60 12         571 my $self = shift ;
61             my $match_elt = shift ;
62             my $mode = shift || '';
63              
64 4     4 0 12 my $match_line ;
65 4         7 my $match_body ;
66 4   50     20  
67             foreach my $name ($match_elt->get_element_name() ) {
68 4         9 my $elt = $match_elt->fetch_element($name) ;
69              
70             if ($name eq 'Settings') {
71 4         58 $match_body .= $self->write_node_content($elt,$mode)."\n" ;
72 8         724 }
73             elsif ($name eq 'Condition') {
74 8 100       497 $match_line = $self->write_line(
    50          
75 4         19 Match => $self->write_match_condition($elt,$mode) ,
76             $match_elt -> annotation
77             ) ;
78 4         15 }
79             else {
80             die "write_match_block: unexpected element: $name";
81             }
82             }
83              
84 0         0 return $match_line.$match_body ;
85             }
86              
87             my $self = shift ;
88 4         21 my $cond_elt = shift ;
89             my $mode = shift || '';
90              
91             my $result = '' ;
92 4     4 0 7  
93 4         8 foreach my $name ($cond_elt->get_element_name() ) {
94 4   50     19 my $elt = $cond_elt->fetch_element($name) ;
95             my $v = $elt->fetch($mode) ;
96 4         7 $result .= " $name $v" if defined $v;
97             }
98 4         11  
99 16         388 return $result ;
100 16         959 }
101 16 100       2973  
102             no Mouse;
103              
104 4         25 1;
105              
106             # ABSTRACT: Backend role for Ssh Match blocks
107 4     4   27  
  4         8  
  4         24  
108              
109             =pod
110              
111             =encoding UTF-8
112              
113             =head1 NAME
114              
115             Config::Model::Backend::OpenSsh::Role::MatchBlock - Backend role for Ssh Match blocks
116              
117             =head1 VERSION
118              
119             version 2.9.0.2
120              
121             =head1 SYNOPSIS
122              
123             None
124              
125             =head1 DESCRIPTION
126              
127             This class provides a backend role to read and write C<Match> blocks
128             in OpenSsh configuration files.
129              
130             =head1 SEE ALSO
131              
132             L<Config::Model::Backend::OpenSsh>,
133              
134             =head1 AUTHOR
135              
136             Dominique Dumont
137              
138             =head1 COPYRIGHT AND LICENSE
139              
140             This software is Copyright (c) 2008-2022 by Dominique Dumont.
141              
142             This is free software, licensed under:
143              
144             The GNU Lesser General Public License, Version 2.1, February 1999
145              
146             =cut