File Coverage

blib/lib/Test/Collectd/Config.pm
Criterion Covered Total %
statement 40 46 86.9
branch 7 10 70.0
condition 2 5 40.0
subroutine 11 13 84.6
pod 1 1 100.0
total 61 75 81.3


line stmt bran cond sub pod time code
1             package Test::Collectd::Config;
2              
3 6     6   7194 use Test::Collectd::Config::Parse;
  6         18  
  6         200  
4 6     6   13789 use Parse::Lex;
  6         209691  
  6         206  
5 6     6   7556 use IO::File;
  6         42554  
  6         1128  
6 6     6   52 use strict;
  6         12  
  6         271  
7 6     6   34 use warnings;
  6         22  
  6         401  
8              
9             =head1 NAME
10              
11             Test::Collectd::Config - Reimplementation of L in perl.
12              
13             =head1 VERSION
14              
15             Version 0.1001
16              
17             =head1 SYNOPSOS
18              
19             use Test::Collectd::Config;
20              
21             my $config = parse ( "/etc/collectd.conf" );
22              
23             This module reimplements the config parser of collectd in perl. It's being used by L. The only exported function is L.
24              
25             =cut
26              
27             require Exporter;
28 6     6   37 use vars qw($VERSION @ISA @EXPORT_OK @EXPORT $BFALSE $IGNORE_mlWHITE_SPACE $CLOSEBRAC $IGNORE_COL $NUMBER $EOL $IGNORE_CONT_QUOTED_STRING $SLASH $ERROR $IGNORE_WHITE_SPACE $OPENBRAC $BTRUE $IGNORE_COMMENT $IGNORE_START_QUOTED_STRING $QUOTED_STRING $DUPE_0_QUOTED_STRING $DUPE_0_UNQUOTED_STRING $UNQUOTED_STRING);
  6         13  
  6         9697  
29             push @ISA, qw(Exporter);
30             @EXPORT_OK = qw(
31             parse
32             );
33             @EXPORT = qw(
34             parse
35             );
36              
37             $VERSION = "0.1001";
38              
39             my $EOL = '\r?\n';
40             my $IP_BYTE = '(2(5[0-5]|[0-4][0-9])|1[0-9][0-9]|[1-9]?[0-9])';
41             my $PORT = '(6(5(5(3[0-5]|[0-2][0-9])|[0-4][0-9][0-9])|[0-4][0-9][0-9][0-9])|[1-5][0-9][0-9][0-9][0-9]|[1-9][0-9]?[0-9]?[0-9]?)';
42             my $IPV4_ADDR = "$IP_BYTE\\.$IP_BYTE\\.$IP_BYTE\\.$IP_BYTE(:$PORT)?";
43             my $HEX_NUMBER = '0[xX][0-9a-fA-F]+';
44             my $OCT_NUMBER = '0[0-7]+';
45             my $DEC_NUMBER = '[\+\-]?[0-9]+';
46             my $FLOAT_NUMBER = '[\+\-]?[0-9]*\.[0-9]+([eE][\+\-][0-9]+)?';
47             my $NUMBER = "($FLOAT_NUMBER|$HEX_NUMBER|$OCT_NUMBER|$DEC_NUMBER)";
48             my $QUOTED_STRING = '([^\\"]+|\\.)*';
49             #$QUOTED_STRING = '((?
50             my $UNQUOTED_STRING = '[0-9A-Za-z_]+';
51             my $WHITE_SPACE = '[\ \t\b]';
52             my $NON_WHITE_SPACE = '[^\ \t\b]';
53              
54             my $ml_buffer;
55              
56             my @lex = (
57             qw(IGNORE_WHITE_SPACE), $WHITE_SPACE,
58             qw(IGNORE_COMMENT), '#.*',
59             qw(IGNORE_COL), "\\$EOL",
60             qw(EOL), $EOL,
61             qw(SLASH /),
62             qw(OPENBRAC <),
63             qw(CLOSEBRAC >),
64             qw(BTRUE), '(true|yes|on)$', sub { 1 },
65             qw(BFALSE), '(false|no|off)$', sub { 0 },
66             qw(UNQUOTED_STRING), ${IPV4_ADDR},
67             qw(NUMBER), $NUMBER,
68             qw(QUOTED_STRING), "\"$QUOTED_STRING\"",
69             qw(DUPE_0_UNQUOTED_STRING), ${UNQUOTED_STRING},
70             qw(IGNORE_START_QUOTED_STRING), "\"$QUOTED_STRING\\$EOL", \&_start_string,
71             qw(ML:IGNORE_mlWHITE_SPACE), "^${WHITE_SPACE}+",
72             qw(ML:IGNORE_CONT_QUOTED_STRING), "${NON_WHITE_SPACE}${QUOTED_STRING}\\${EOL}", \&_cont_string,
73             qw(ML:DUPE_0_QUOTED_STRING), "${NON_WHITE_SPACE}${QUOTED_STRING}\"", \&_end_string,
74             qw(ERROR .*), \&_error,
75             );
76              
77             sub _error {
78 0     0   0 die qq!can\'t analyze: "$_[1]"!;
79             }
80             sub _start_string {
81 1     1   120 $ml_buffer = "";
82 1         6 ($ml_buffer.= $_[1]) =~ s/\\\r?\n$//;
83 1         7 $_[0] -> lexer -> start ("ML");
84             }
85             sub _cont_string {
86 1     1   3 ($ml_buffer.= $_[1]) =~ s/\\$//;
87 1         3 return @_;
88             }
89             sub _end_string {
90 1     1   98 _cont_string (@_);
91 1         4 $_[0] -> lexer -> start ("INITIAL");
92 1         48 return $ml_buffer;
93             }
94              
95             Parse::Lex->exclusive('ML');
96             my $lexer = Parse::Lex->new(@lex);
97             #$lexer -> trace;
98             $lexer -> skip('');
99              
100             sub _lex {
101 201     201   525 while (my $token = $lexer -> next) {
102 472 100       40780 return ('', undef) if $lexer->eoi;
103 468 100       2796 next if $token -> name =~ /^IGNORE_/;
104 197         986 (my $name = $token->name) =~ s/^DUPE_[^_]+_//;
105 197         1000 return ($name, $token->text);
106             }
107             }
108              
109 0     0   0 sub _parse_error {die "parser failed ", join ", ", map { "$_: ".${$_[0] -> {$_}}} qw(TOKEN VALUE)}
  0         0  
  0         0  
110              
111             =head2 parse ( $config_in )
112              
113             Parses $config_in and returns the compiled configuration in the form of a nested structure identical to the one returned to the plugin's config callback. The
114              
115             =cut
116              
117             sub parse {
118 4   50 4 1 5173 my $in = shift || die "usage: __PACKAGE__->parse(\$config_in)";
119 4         8 my $config;
120 4 50 33     35 if (ref $in && $in->isa("GLOB")) {
    50          
121 0         0 $config = $in;
122             } elsif (!ref $in) {
123 4 50       43 my $fh = IO::File -> new ( $in, 'r' ) or die $!;
124 4         600 local $/;
125 4         14 $config = $fh;
126             } else {
127 0         0 die 'parse($config_in) must be either a string (filename) or a GLOB (handle).';
128             }
129 4         113 $lexer->from($config);
130 4         39452 my $parser = Test::Collectd::Config::Parse -> new;
131 4         39 my $value = $parser -> YYParse(yylex => \&_lex, yyerror => \&_parse_error, yydebug => 0x00);
132             }
133              
134             1;
135