File Coverage

blib/lib/Net/IMP.pm
Criterion Covered Total %
statement 127 134 94.7
branch 8 16 50.0
condition 2 6 33.3
subroutine 35 37 94.5
pod 0 2 0.0
total 172 195 88.2


line stmt bran cond sub pod time code
1 8     8   92003 use strict;
  8         45  
  8         237  
2 8     8   39 use warnings;
  8         17  
  8         408  
3              
4             package Net::IMP;
5             our $VERSION = '0.635';
6              
7 8     8   45 use Carp 'croak';
  8         24  
  8         645  
8 8     8   47 use Scalar::Util 'dualvar';
  8         14  
  8         875  
9              
10             # map set_debug into local namespace for convinience, so that one
11             # can call Net::IMP->set_debug instead of Net::IMP::Debug->set_debug
12 8     8   3479 use Net::IMP::Debug 'set_debug';
  8         20  
  8         29  
13              
14 8     8   55 use Exporter 'import';
  8         18  
  8         991  
15             our @EXPORT = qw(
16             IMP_PASS
17             IMP_PASS_PATTERN
18             IMP_PREPASS
19             IMP_DENY
20             IMP_DROP
21             IMP_TOSENDER
22             IMP_REPLACE
23             IMP_REPLACE_LATER
24             IMP_PAUSE
25             IMP_CONTINUE
26             IMP_LOG
27             IMP_PORT_OPEN
28             IMP_PORT_CLOSE
29             IMP_ACCTFIELD
30             IMP_FATAL
31             IMP_MAXOFFSET
32             IMP_DATA_STREAM
33             IMP_DATA_PACKET
34             );
35              
36             my @log_levels = qw(
37             IMP_LOG_DEBUG
38             IMP_LOG_INFO
39             IMP_LOG_NOTICE
40             IMP_LOG_WARNING
41             IMP_LOG_ERR
42             IMP_LOG_CRIT
43             IMP_LOG_ALERT
44             IMP_LOG_EMERG
45             );
46             our @EXPORT_OK = (@log_levels, 'IMP_DATA','IMP_DATA_TYPES', 'IMP_PASS_IF_BUSY');
47             our %EXPORT_TAGS = ( log => \@log_levels );
48              
49             # data types/protocols
50             # These two are the basic types, more application specific types might
51             # be defined somewhere else and be mapped to a number within supported_dtypes.
52             # The only important thing is, that streaming data should be <0, while
53             # packetized data (like HTTP header or UDP datagrams) should be > 0
54             # If no explicit type is given in sub data, it will assume IMP_DATA_STREAM.
55 8     8   53 use constant IMP_DATA_STREAM => dualvar(-1,'imp.data.stream');
  8         16  
  8         1003  
56 8     8   67 use constant IMP_DATA_PACKET => dualvar(+1,'imp.data.packet');
  8         12  
  8         558  
57              
58              
59             # the numerical order of the constants describes priority when
60             # cascading modules, e.g. replacement has a higher value then
61             # pass and gets thus forwarded as the cause for the data
62              
63             ### information only
64 8     8   53 use constant IMP_LOG => dualvar(0x0001,"log");
  8         12  
  8         487  
65 8     8   48 use constant IMP_PORT_OPEN => dualvar(0x0002,"port_open");
  8         71  
  8         491  
66 8     8   48 use constant IMP_PORT_CLOSE => dualvar(0x0003,"port_close");
  8         25  
  8         507  
67 8     8   59 use constant IMP_ACCTFIELD => dualvar(0x0004,"acctfield");
  8         30  
  8         481  
68             ### flow control
69 8     8   46 use constant IMP_PAUSE => dualvar(0x0010,"pause");
  8         16  
  8         474  
70 8     8   57 use constant IMP_CONTINUE => dualvar(0x0011,"continue");
  8         12  
  8         502  
71 8     8   50 use constant IMP_REPLACE_LATER => dualvar(0x0012,"replace_later");
  8         15  
  8         486  
72             ### keep data
73 8     8   50 use constant IMP_PASS => dualvar(0x1001,"pass");
  8         21  
  8         580  
74 8     8   59 use constant IMP_PASS_PATTERN => dualvar(0x1002,"pass_pattern");
  8         13  
  8         512  
75 8     8   47 use constant IMP_PREPASS => dualvar(0x1003,"prepass");
  8         12  
  8         491  
76             ### change data
77 8     8   51 use constant IMP_TOSENDER => dualvar(0x1010,"tosender");
  8         14  
  8         476  
78 8     8   48 use constant IMP_REPLACE => dualvar(0x1011,"replace");
  8         12  
  8         443  
79             ### affect whole connection
80 8     8   53 use constant IMP_DENY => dualvar(0x1100,"deny");
  8         21  
  8         499  
81 8     8   60 use constant IMP_DROP => dualvar(0x1101,"drop");
  8         16  
  8         495  
82 8     8   53 use constant IMP_FATAL => dualvar(0x1102,"fatal");
  8         14  
  8         684  
83              
84             # these return values still get sent if the data provider is busy
85             # the most important are on top
86 8         501 use constant IMP_PASS_IF_BUSY => [
87             IMP_FATAL,
88             IMP_DENY,
89             IMP_DROP,
90             IMP_PAUSE,
91             IMP_CONTINUE,
92             IMP_ACCTFIELD
93 8     8   56 ];
  8         12  
94              
95              
96             # marker for (pre)pass to Infinite for IMP_PASS, IMP_PREPASS
97 8     8   49 use constant IMP_MAXOFFSET => -1;
  8         13  
  8         518  
98              
99             # log levels for IMP_LOG
100             # these are modeled analog to syslog levels
101 8     8   53 use constant IMP_LOG_DEBUG => dualvar(1,'debug');
  8         15  
  8         512  
102 8     8   49 use constant IMP_LOG_INFO => dualvar(2,'info');
  8         13  
  8         483  
103 8     8   48 use constant IMP_LOG_NOTICE => dualvar(3,'notice');
  8         90  
  8         583  
104 8     8   62 use constant IMP_LOG_WARNING => dualvar(4,'warning');
  8         15  
  8         443  
105 8     8   51 use constant IMP_LOG_ERR => dualvar(5,'error');
  8         85  
  8         536  
106 8     8   51 use constant IMP_LOG_CRIT => dualvar(6,'critical');
  8         15  
  8         502  
107 8     8   48 use constant IMP_LOG_ALERT => dualvar(7,'alert');
  8         14  
  8         506  
108 8     8   51 use constant IMP_LOG_EMERG => dualvar(8,'emergency');
  8         13  
  8         3929  
109              
110              
111             # helper function to define new IMP_DATA_* types for protocols
112             {
113             my @dualvars = ( IMP_DATA_STREAM, IMP_DATA_PACKET );
114 0     0 0 0 sub IMP_DATA_TYPES { return @dualvars }
115              
116             my %atoi = map {( "$_" => $_+0 )} @dualvars;
117             my %itoa = map {( $_+0 => "$_" )} @dualvars;
118              
119             # $basename - name which gets used in constant name, e.g. 'http' makes
120             # IMP_DATA_HTTP_..... Best would be name of IP service.
121             # - if name[number] will use number as base type number
122             # - if name[other_name+number] will base types on already defined
123             # types with number added as offset
124             # - if no number given it will use port name from getservbyname,
125             # multiplied with 0x10000 and die if no such service is defined
126             # @def: list of defname => [+-]offset which will result in a definition
127             # of IMP_DATA_BASENAME_DEFNAME => [+-](base+offset), e.g. '+' for packet
128             # types and '-' for stream types
129             sub IMP_DATA {
130 1     1 0 999 my ($basename,@def) = @_;
131 1         3 my $basenum;
132 1 50       7 if ( $basename =~s{\[(?:(\w+)\+)?(\d+)\]$}{} ) {
133 0         0 (my $base,$basenum) = ($1,$2);
134 0 0       0 if ( $base ) {
135 0 0       0 my $offset = $atoi{$base}
136             or croak("cannot find base type $base");
137 0         0 $basenum += $offset;
138             }
139             } else {
140 1 50 33     692 $basenum = getservbyname($basename,'tcp' )
141             || getservbyname($basename,'udp' )
142             or croak("cannot determine id for $basename");
143 1         7 $basenum = $basenum << 16;
144             }
145              
146 1         3 my @const;
147              
148 1         4 my $pkg = caller;
149 1         5 unshift(@def,'',0);
150 1         4 while (@def) {
151 6         13 my $name = shift(@def);
152 6         8 my $diff = shift(@def);
153 6 100       20 my $lname = $name ne '' ? "$basename.$name" : $basename;
154 6 50       17 croak("$lname already defined") if exists $atoi{$lname};
155 6 100       13 my $lnum = $diff>=0 ? $basenum + $diff : -$basenum+$diff;
156 6 50 33     32 if ( my $s = $itoa{$lnum} || $itoa{-$lnum} ) {
157 0         0 croak("id $lnum alreday used for $s");
158             }
159 6         13 $atoi{$lname} = $lnum;
160 6         12 $itoa{$lnum} = $lname;
161              
162 6         13 my $string = "imp.data.$lname";
163 6         26 ( my $const = uc($string) )=~s{\.}{_}g;
164 6         13 push @const,$const;
165              
166 8     8   66 no strict 'refs';
  8         15  
  8         1365  
167 6         18 my $var = dualvar($lnum,$string);
168 6     0   52 *{ "${pkg}::$const" } = sub () { $var };
  6         37  
  0         0  
169 6         29 push @dualvars, $var;
170             }
171              
172 1         10 return @const;
173             }
174              
175             }
176              
177              
178             1;
179              
180             __END__