File Coverage

blib/lib/Metabrik/Lookup/Protocol.pm
Criterion Covered Total %
statement 9 64 14.0
branch 0 30 0.0
condition 0 12 0.0
subroutine 3 9 33.3
pod 1 6 16.6
total 13 121 10.7


line stmt bran cond sub pod time code
1             #
2             # $Id$
3             #
4             # lookup::protocol Brik
5             #
6             package Metabrik::Lookup::Protocol;
7 1     1   801 use strict;
  1         2  
  1         31  
8 1     1   5 use warnings;
  1         2  
  1         41  
9              
10 1     1   6 use base qw(Metabrik::File::Csv);
  1         2  
  1         850  
11              
12             sub brik_properties {
13             return {
14 0     0 1   revision => '$Revision$',
15             tags => [ qw(unstable iana) ],
16             author => 'GomoR ',
17             license => 'http://opensource.org/licenses/BSD-3-Clause',
18             attributes => {
19             datadir => [ qw(datadir) ],
20             input => [ qw(input) ],
21             _load => [ qw(INTERNAL) ],
22             },
23             attributes_default => {
24             separator => ',',
25             input => 'protocol-numbers-1.csv',
26             },
27             commands => {
28             update => [ qw(output|OPTIONAL) ],
29             load => [ qw(input|OPTIONAL) ],
30             from_dec => [ qw(dec_number) ],
31             from_hex => [ qw(hex_number) ],
32             from_string => [ qw(protocol_string) ],
33             },
34             require_modules => {
35             'Metabrik::Client::Www' => [ ],
36             'Metabrik::File::Text' => [ ],
37             },
38             };
39             }
40              
41             sub update {
42 0     0 0   my $self = shift;
43 0           my ($output) = @_;
44              
45 0           my $url = 'http://www.iana.org/assignments/protocol-numbers/protocol-numbers-1.csv';
46 0           my ($file) = $self->input;
47              
48 0           my $datadir = $self->datadir;
49 0   0       $output ||= $datadir.'/'.$file;
50              
51 0 0         my $cw = Metabrik::Client::Www->new_from_brik_init($self) or return;
52 0 0         my $files = $cw->mirror($url, $file, $datadir) or return;
53 0 0         if (@$files == 0) { # Nothing new
54 0           return $output;
55             }
56              
57             # We have to rewrite the CSV file, cause some entries are multiline.
58 0 0         my $ft = Metabrik::File::Text->new_from_brik_init($self) or return;
59 0           $ft->overwrite(1);
60 0           $ft->append(0);
61 0 0         my $text = $ft->read($output)
62             or return $self->log->error("update: read failed");
63              
64             # Some lines are split on multi-lines, we put into a single line
65             # for each record.
66 0           my @new = split(/\r\n/, $text);
67 0           for (@new) {
68 0           s/\n/ /g;
69             }
70              
71 0           $ft->write(\@new, $output);
72              
73 0           return $output;
74             }
75              
76             sub load {
77 0     0 0   my $self = shift;
78 0           my ($input) = @_;
79              
80 0   0       $input ||= $self->datadir.'/'.$self->input;
81 0 0         $self->brik_help_run_file_not_found('load', $input) or return;
82              
83 0 0         my $data = $self->read($input) or return;
84              
85 0           return $self->_load($data);
86             }
87              
88             sub from_dec {
89 0     0 0   my $self = shift;
90 0           my ($dec) = @_;
91              
92 0 0         $self->brik_help_run_undef_arg('from_dec', $dec) or return;
93              
94 0   0       my $data = $self->_load || $self->load;
95 0 0         if (! defined($data)) {
96 0           return $self->log->error("from_dec: load failed");
97             }
98              
99 0           for my $this (@$data) {
100 0 0         if ($this->{Decimal} == $dec) {
101 0           return $this->{Keyword};
102             }
103             }
104              
105             # No match
106 0           return 'undef';
107             }
108              
109             sub from_hex {
110 0     0 0   my $self = shift;
111 0           my ($hex) = @_;
112              
113 0 0         $self->brik_help_run_undef_arg('from_hex', $hex) or return;
114              
115 0           my $dec = hex($hex);
116              
117 0           return $self->from_dec($dec);
118             }
119              
120             sub from_string {
121 0     0 0   my $self = shift;
122 0           my ($string) = @_;
123              
124 0 0         $self->brik_help_run_undef_arg('from_string', $string) or return;
125              
126 0   0       my $data = $self->_load || $self->load;
127 0 0         if (! defined($data)) {
128 0           return $self->log->error("from_string: load failed");
129             }
130              
131 0           my @match = ();
132 0           for my $this (@$data) {
133 0 0         if ($this->{Keyword} =~ /$string/i) {
    0          
134 0           $self->log->verbose("from_string: match with [".$this->{Keyword}."]");
135 0           push @match, $this->{Decimal};
136             }
137             elsif ($this->{Protocol} =~ /$string/i) {
138 0           $self->log->verbose("from_string: match with [".$this->{Protocol}."]");
139 0           push @match, $this->{Decimal};
140             }
141             }
142              
143 0           return \@match;
144             }
145              
146             1;
147              
148             __END__