File Coverage

blib/lib/Device/Network/ConfigParser/CheckPoint/Gaia.pm
Criterion Covered Total %
statement 44 81 54.3
branch 1 10 10.0
condition n/a
subroutine 11 16 68.7
pod 5 5 100.0
total 61 112 54.4


line stmt bran cond sub pod time code
1             package Device::Network::ConfigParser::CheckPoint::Gaia;
2             # ABSTRACT: Parse CheckPoint Configuration
3             our $VERSION = '0.005'; # VERSION
4              
5 1     1   1612 use 5.006;
  1         5  
6 1     1   8 use strict;
  1         3  
  1         25  
7 1     1   8 use warnings;
  1         3  
  1         39  
8 1     1   333 use Modern::Perl;
  1         8065  
  1         10  
9 1     1   1196 use Parse::RecDescent;
  1         32484  
  1         9  
10 1     1   524 use Data::Dumper;
  1         6167  
  1         91  
11 1     1   595 use JSON;
  1         7137  
  1         7  
12              
13 1     1   207 use Exporter qw{import};
  1         2  
  1         900  
14              
15             our @EXPORT_OK = qw{get_parser get_output_drivers parse_config post_process};
16              
17             =head1 NAME
18              
19             Device::Network::ConfigParser::CheckPoint::Gaia - parse CheckPoint Gaia configuration.
20              
21             =head1 VERSION
22              
23             version 0.005
24              
25             =head1 SYNOPSIS
26              
27             This module is intended to be used in conjunction with L, however there's nothing stopping it being used on its own.
28              
29             The module provides subroutines to parse & post-process CheckPoint Gaia configuration, and output the structured data in a number of formats.
30              
31             =head1 SUBROUTINES
32              
33             =head2 get_parser
34              
35             For more information on the subroutine, see L.
36              
37             This module currently parses the following sections of Gaia config:
38              
39             =over 4
40              
41             =item * Static routes
42              
43             =item * Interface configuration
44              
45             =back
46              
47             Any other lines within the file are classified as 'unrecognised'.
48              
49             =cut
50              
51             sub get_parser {
52 1     1 1 635 return new Parse::RecDescent(q{
53            
54             startrule: config_line(s) { $item[1] }
55             config_line:
56             interface { $item[1] } |
57             static_route { $item[1] } |
58             unrecognised { $item[1] }
59              
60             static_route: 'set static-route' destination (nexthop | comment) { { type => $item[0], config => { @{ $item[2] }, @{ $item[3]->[1] } } } }
61             destination: m{((\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\/\d{2})|default)} { [$item[0], $item[1]] }
62             nexthop: 'nexthop' (nexthop_blackhole | nexthop_reject | nexthop_address | nexthop_interface) { [@{$item[2]->[1]}] }
63             nexthop_blackhole: 'blackhole' { ['nexthop_type', $item[1]] }
64             nexthop_reject: 'reject' { ['nexthop_type', $item[1]] }
65             nexthop_address: 'gateway address' ipv4 m{on|off} { [nexthop_type => 'address', nexthop => $item[2]->[1], status => $item[3]] }
66             nexthop_interface: 'gateway logical' interface_name m{on|off} { [nexthop_type => 'interface', nexthop => $item[2]->[1], status => $item[3]] }
67             comment: 'comment' m{"[\w\s]+"} { [$item[0], $item[2]] }
68              
69             interface:
70             'set interface' interface_name (ipv4_address_mask | vlan | state | comment | mtu | auto_negotiation | link_speed)
71             { { type => $item[0], config => { name => $item[2]->[1], %{ $item[3]->[1] } } } }
72              
73             ipv4_address_mask: ipv4_address ipv4_mask { $return = { @{$item[1]}, @{$item[2]}} }
74             ipv4_address: 'ipv4-address' ipv4 { [$item[0], $item[2]->[1]] }
75             ipv4_mask: 'mask-length' m{\d+} { [$item[0], $item[2]] }
76              
77             vlan: 'vlan' m{\d+} { $return = { $item[0], $item[2] } }
78             state: 'state' m{\S+} { $return = { $item[0], $item[2] } }
79             comment: 'comments' m{"[\w\s]+"} { $return = { $item[0], $item[2] } }
80             mtu: 'mtu' m{\d+} { $return = { $item[0], $item[2] } }
81             auto_negotiation: 'auto-negotiation' m{\S+} { $return = { $item[0], $item[2] } }
82             link_speed: 'link-speed' m{\S+} { $return = { $item[0], $item[2] } }
83              
84             # Utility definitions
85             ipv4: m{\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}}
86             interface_name: m{\S+}
87              
88             unrecognised: m{\N+}
89             { { type => $item[0], config => $item[1] } }
90             });
91             }
92              
93              
94             =head2 parse_config
95              
96             For more information on the subroutine, see L.
97              
98             =cut
99              
100             sub parse_config {
101 13     13 1 133803 my ($parser, $config_contents) = @_;
102              
103 13         143 my $parse_tree = $parser->startrule($config_contents);
104              
105 13         79086 return $parse_tree;
106             }
107              
108              
109              
110             =head2 post_process
111              
112             For more information on the subroutine, see L.
113              
114             The C subroutine consolidates configuration spread out over multiple lines.
115              
116             =cut
117              
118             sub post_process {
119 13     13 1 86 my ($parsed_config) = @_;
120 13         36 my %aggregation = ();
121 13         28 my %post_processed_config;
122              
123             # For each 'type' of config, (e.g. interface config), the aggregator key we're using to aggregate the separate
124             # config lines together into a single hash.
125 13         61 my $aggregator_keys_for = {
126             interface => q{$config_entry->{config}->{name}},
127             static_route => q{$config_entry->{config}->{destination}},
128             };
129              
130             # Go through each config entry (which was originally each line of config. If there's an aggregate key defined,
131             # aggregate on the 'type' and then this 'key'.
132             #
133             # If not, then just push it to the post processed hash.
134 13         34 for my $config_entry (@{ $parsed_config }) {
  13         38  
135 18 50       93 if (exists $aggregator_keys_for->{ $config_entry->{type} }) {
136 18         1740 my $aggregate_key = eval $aggregator_keys_for->{ $config_entry->{type} };
137 18         114 @{ $aggregation{ $config_entry->{type} }{ $aggregate_key } }{ keys %{ $config_entry->{config} } } = values %{ $config_entry->{config} };
  18         144  
  18         61  
  18         81  
138             } else {
139 0         0 push @{ $post_processed_config{ $config_entry->{type} } }, $config_entry->{config};
  0         0  
140             }
141             }
142              
143             # It's of the form $aggregation{type}{key} = { #interface into }; but the key is implicitly part of the hash it points to.
144             # Turn the hash of hash of hashes into a hash of array of hashes ( $aggregation{type} = [ { #interface info } ];
145 13         45 for my $config_type (keys %aggregation) {
146 13         30 $aggregation{ $config_type } = [ values %{ $aggregation{ $config_type } } ];
  13         70  
147             }
148              
149 13         54 @post_processed_config{ keys %aggregation } = values %aggregation;
150              
151 13         67 return \%post_processed_config;
152             }
153              
154             =head2 get_output_drivers
155              
156             For more information on the subroutine, see L.
157              
158             Currently supported output drivers are:
159              
160             =over 4
161              
162             =item * csv - writes the parsed configuration out in CSV format.
163              
164             =item * json - writes the parsed configuration out as JSON.
165              
166             =back
167              
168             sub get_output_drivers {
169             return {
170             csv => \&csv_output_driver,
171             json => \&json_output_driver,
172             };
173             }
174              
175             =head2 csv_output_driver
176              
177             =cut
178              
179             sub csv_output_driver {
180 0     0 1   my ($fh, $filename, $parsed_config) = @_;
181 0           my $csv_type_driver = {
182             interface => \&_csv_interface_driver,
183             static_route => \&_csv_static_route_driver,
184             not_config => \&_csv_not_config_driver,
185             };
186              
187 0           say "=" x 16 . "BEGIN FILE $filename" . "=" x 16;
188              
189             TYPE:
190 0           for my $type (keys %{ $parsed_config }) {
  0            
191 0           say "-" x 8 . "BEGIN TYPE $type" . "-" x 8;
192              
193             defined $csv_type_driver->{$type} ?
194 0 0         $csv_type_driver->{$type}->($fh, $parsed_config->{$type}) :
    0          
195             warn "No CSV output driver for $type\n" and next TYPE;
196              
197 0           say "-" x 8 . "END TYPE $type" . "-" x 8;
198             }
199              
200 0           say "-" x 8 . "END FILE $filename" . "-" x 8;
201             }
202              
203             sub _csv_interface_driver {
204 0     0     my ($fh, $interfaces_ref) = @_;
205              
206             # Print the CSV schema line
207 0           my @interface_properties = qw{name state vlan ipv4_address ipv4_mask auto_negotiation link_speed mtu comment};
208 0           say $fh join(',', @interface_properties);
209              
210             # Interface through the interfaces, extract and print their properties
211 0           for my $interface (@{ $interfaces_ref }) {
  0            
212 0           my @properties = @{ $interface }{ @interface_properties };
  0            
213              
214             # Replace any undef with an empty string
215 0 0         @properties = map { defined $_ ? $_ : '' } @properties;
  0            
216 0           say $fh join(',', @properties);
217             }
218             }
219              
220              
221             sub _csv_static_route_driver {
222 0     0     my ($fh, $static_routes_ref) = @_;
223              
224 0           my @static_route_properties = qw{destination nexthop nexthop_type status};
225 0           say $fh join(',', @static_route_properties);
226              
227 0           for my $route (@{ $static_routes_ref }) {
  0            
228 0           my @properties = @{ $route }{ @static_route_properties };
  0            
229              
230             # Replace any undef with an empty string
231 0 0         @properties = map { defined $_ ? $_ : '' } @properties;
  0            
232 0           say $fh join(',', @properties);
233             }
234             }
235              
236              
237             sub _csv_not_config_driver {
238 0     0     my ($fh, $not_config) = @_;
239              
240 0           for my $config_line (@{ $not_config }) {
  0            
241 0           print $fh "$config_line\n";
242             }
243             }
244              
245              
246              
247              
248              
249             =head2 json_output_driver
250              
251             =cut
252              
253             sub json_output_driver {
254 0     0 1   my ($fh, $filename, $parsed_config) = @_;
255              
256 0           print encode_json($parsed_config);
257             }
258              
259             =head1 AUTHOR
260              
261             Greg Foletta, C<< >>
262              
263             =head1 BUGS
264              
265             Please report any bugs or feature requests to C, or through
266             the web interface at L. I will be notified, and then you'll
267             automatically be notified of progress on your bug as I make changes.
268              
269              
270              
271              
272             =head1 SUPPORT
273              
274             You can find documentation for this module with the perldoc command.
275              
276             perldoc Device::CheckPoint::ConfigParse
277              
278              
279             You can also look for information at:
280              
281             =over 4
282              
283             =item * RT: CPAN's request tracker (report bugs here)
284              
285             L
286              
287             =item * AnnoCPAN: Annotated CPAN documentation
288              
289             L
290              
291             =item * CPAN Ratings
292              
293             L
294              
295             =item * Search CPAN
296              
297             L
298              
299             =back
300              
301              
302             =head1 ACKNOWLEDGEMENTS
303              
304              
305             =head1 LICENSE AND COPYRIGHT
306              
307             Copyright 2017 Greg Foletta.
308              
309             This program is free software; you can redistribute it and/or modify it
310             under the terms of the the Artistic License (2.0). You may obtain a
311             copy of the full license at:
312              
313             L
314              
315             Any use, modification, and distribution of the Standard or Modified
316             Versions is governed by this Artistic License. By using, modifying or
317             distributing the Package, you accept this license. Do not use, modify,
318             or distribute the Package, if you do not accept this license.
319              
320             If your Modified Version has been derived from a Modified Version made
321             by someone other than you, you are nevertheless required to ensure that
322             your Modified Version complies with the requirements of this license.
323              
324             This license does not grant you the right to use any trademark, service
325             mark, tradename, or logo of the Copyright Holder.
326              
327             This license includes the non-exclusive, worldwide, free-of-charge
328             patent license to make, have made, use, offer to sell, sell, import and
329             otherwise transfer the Package with respect to any patent claims
330             licensable by the Copyright Holder that are necessarily infringed by the
331             Package. If you institute patent litigation (including a cross-claim or
332             counterclaim) against any party alleging that the Package constitutes
333             direct or contributory patent infringement, then this Artistic License
334             to you shall terminate on the date that such litigation is filed.
335              
336             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
337             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
338             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
339             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
340             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
341             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
342             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
343             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
344              
345              
346             =cut
347              
348             1; # End of Device::CheckPoint::ConfigParse