File Coverage

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


line stmt bran cond sub pod time code
1             package Device::Network::ConfigParser::CheckPoint::Gaia;
2             # ABSTRACT: Parse CheckPoint Configuration
3             our $VERSION = '0.006'; # VERSION
4              
5 1     1   1278 use 5.006;
  1         4  
6 1     1   5 use strict;
  1         1  
  1         19  
7 1     1   4 use warnings;
  1         2  
  1         23  
8 1     1   234 use Modern::Perl;
  1         6320  
  1         6  
9 1     1   963 use Parse::RecDescent;
  1         24600  
  1         8  
10 1     1   544 use Data::Dumper;
  1         4997  
  1         75  
11 1     1   372 use JSON;
  1         5626  
  1         6  
12              
13 1     1   149 use Exporter qw{import};
  1         2  
  1         801  
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.006
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 512 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 102868 my ($parser, $config_contents) = @_;
102              
103 13         99 my $parse_tree = $parser->startrule($config_contents);
104              
105 13         46937 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 64 my ($parsed_config) = @_;
120 13         28 my %aggregation = ();
121 13         21 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         43 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         20 for my $config_entry (@{ $parsed_config }) {
  13         30  
135 18 50       62 if (exists $aggregator_keys_for->{ $config_entry->{type} }) {
136 18         1344 my $aggregate_key = eval $aggregator_keys_for->{ $config_entry->{type} };
137 18         76 @{ $aggregation{ $config_entry->{type} }{ $aggregate_key } }{ keys %{ $config_entry->{config} } } = values %{ $config_entry->{config} };
  18         90  
  18         36  
  18         56  
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         33 for my $config_type (keys %aggregation) {
146 13         23 $aggregation{ $config_type } = [ values %{ $aggregation{ $config_type } } ];
  13         48  
147             }
148              
149 13         41 @post_processed_config{ keys %aggregation } = values %aggregation;
150              
151 13         46 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             =back
165              
166             =cut
167              
168              
169             sub get_output_drivers {
170             return {
171 0     0 1   csv => \&csv_output_driver,
172             };
173             }
174              
175             =head2 csv_output_driver
176              
177             This function outputs certain configuration elements as CSV. It currently supports C and C configuration.
178              
179             =cut
180              
181             sub csv_output_driver {
182 0     0 1   my ($fh, $filename, $parsed_config) = @_;
183 0           my $csv_type_driver = {
184             interface => \&_csv_interface_driver,
185             static_route => \&_csv_static_route_driver,
186             not_config => \&_csv_not_config_driver,
187             };
188              
189 0           say "=" x 16 . "BEGIN FILE $filename" . "=" x 16;
190              
191             TYPE:
192 0           for my $type (keys %{ $parsed_config }) {
  0            
193 0           say "-" x 8 . "BEGIN TYPE $type" . "-" x 8;
194              
195             defined $csv_type_driver->{$type} ?
196 0 0         $csv_type_driver->{$type}->($fh, $parsed_config->{$type}) :
    0          
197             warn "No CSV output driver for $type\n" and next TYPE;
198              
199 0           say "-" x 8 . "END TYPE $type" . "-" x 8;
200             }
201              
202 0           say "-" x 8 . "END FILE $filename" . "-" x 8;
203             }
204              
205             sub _csv_interface_driver {
206 0     0     my ($fh, $interfaces_ref) = @_;
207              
208             # Print the CSV schema line
209 0           my @interface_properties = qw{name state vlan ipv4_address ipv4_mask auto_negotiation link_speed mtu comment};
210 0           say $fh join(',', @interface_properties);
211              
212             # Interface through the interfaces, extract and print their properties
213 0           for my $interface (@{ $interfaces_ref }) {
  0            
214 0           my @properties = @{ $interface }{ @interface_properties };
  0            
215              
216             # Replace any undef with an empty string
217 0 0         @properties = map { defined $_ ? $_ : '' } @properties;
  0            
218 0           say $fh join(',', @properties);
219             }
220             }
221              
222              
223             sub _csv_static_route_driver {
224 0     0     my ($fh, $static_routes_ref) = @_;
225              
226 0           my @static_route_properties = qw{destination nexthop nexthop_type status};
227 0           say $fh join(',', @static_route_properties);
228              
229 0           for my $route (@{ $static_routes_ref }) {
  0            
230 0           my @properties = @{ $route }{ @static_route_properties };
  0            
231              
232             # Replace any undef with an empty string
233 0 0         @properties = map { defined $_ ? $_ : '' } @properties;
  0            
234 0           say $fh join(',', @properties);
235             }
236             }
237              
238              
239             sub _csv_not_config_driver {
240 0     0     my ($fh, $not_config) = @_;
241              
242 0           for my $config_line (@{ $not_config }) {
  0            
243 0           print $fh "$config_line\n";
244             }
245             }
246              
247              
248             =head1 AUTHOR
249              
250             Greg Foletta, C<< >>
251              
252             =head1 BUGS
253              
254             Please report any bugs or feature requests to C, or through
255             the web interface at L. I will be notified, and then you'll
256             automatically be notified of progress on your bug as I make changes.
257              
258              
259              
260              
261             =head1 SUPPORT
262              
263             You can find documentation for this module with the perldoc command.
264              
265             perldoc Device::CheckPoint::ConfigParse
266              
267              
268             You can also look for information at:
269              
270             =over 4
271              
272             =item * RT: CPAN's request tracker (report bugs here)
273              
274             L
275              
276             =item * AnnoCPAN: Annotated CPAN documentation
277              
278             L
279              
280             =item * CPAN Ratings
281              
282             L
283              
284             =item * Search CPAN
285              
286             L
287              
288             =back
289              
290              
291             =head1 ACKNOWLEDGEMENTS
292              
293              
294             =head1 LICENSE AND COPYRIGHT
295              
296             Copyright 2017 Greg Foletta.
297              
298             This program is free software; you can redistribute it and/or modify it
299             under the terms of the the Artistic License (2.0). You may obtain a
300             copy of the full license at:
301              
302             L
303              
304             Any use, modification, and distribution of the Standard or Modified
305             Versions is governed by this Artistic License. By using, modifying or
306             distributing the Package, you accept this license. Do not use, modify,
307             or distribute the Package, if you do not accept this license.
308              
309             If your Modified Version has been derived from a Modified Version made
310             by someone other than you, you are nevertheless required to ensure that
311             your Modified Version complies with the requirements of this license.
312              
313             This license does not grant you the right to use any trademark, service
314             mark, tradename, or logo of the Copyright Holder.
315              
316             This license includes the non-exclusive, worldwide, free-of-charge
317             patent license to make, have made, use, offer to sell, sell, import and
318             otherwise transfer the Package with respect to any patent claims
319             licensable by the Copyright Holder that are necessarily infringed by the
320             Package. If you institute patent litigation (including a cross-claim or
321             counterclaim) against any party alleging that the Package constitutes
322             direct or contributory patent infringement, then this Artistic License
323             to you shall terminate on the date that such litigation is filed.
324              
325             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
326             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
327             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
328             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
329             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
330             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
331             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
332             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
333              
334              
335             =cut
336              
337             1; # End of Device::CheckPoint::ConfigParse