File Coverage

blib/lib/App/DubiousHTTP/Tests/Common.pm
Criterion Covered Total %
statement 56 214 26.1
branch 2 80 2.5
condition 0 16 0.0
subroutine 9 37 24.3
pod 0 12 0.0
total 67 359 18.6


line stmt bran cond sub pod time code
1 1     1   3 use strict;
  1         1  
  1         19  
2 1     1   2 use warnings;
  1         1  
  1         22  
3             package App::DubiousHTTP::Tests::Common;
4 1     1   502 use Compress::Raw::Zlib;
  1         3605  
  1         166  
5 1     1   377 use MIME::Base64 'decode_base64';
  1         417  
  1         65  
6 1     1   4 use Exporter 'import';
  1         1  
  1         43  
7             our @EXPORT = qw(
8             MUSTBE_VALID SHOULDBE_VALID VALID INVALID UNCOMMON_VALID UNCOMMON_INVALID COMMON_INVALID
9             SETUP content html_escape url_encode garble_url ungarble_url bro_compress zlib_compress
10             $NOGARBLE $CLIENTIP $TRACKHDR $FAST_FEEDBACK
11             );
12 1     1   3 use Scalar::Util 'blessed';
  1         1  
  1         100  
13              
14             our $CLIENTIP = undef;
15             our $NOGARBLE = 0;
16             our $FAST_FEEDBACK = 0;
17             use constant {
18 1         912 SHOULDBE_VALID => 3, # simple chunked, gzip.. - note if blocked
19             MUSTBE_VALID => 2, # no browser should fail on this
20             VALID => 1,
21             INVALID => 0,
22             UNCOMMON_VALID => -1,
23             UNCOMMON_INVALID => -2,
24             COMMON_INVALID => -3,
25 1     1   3 };
  1         1  
26              
27             my $basedir = 'static/';
28 0     0 0 0 sub basedir { $basedir = pop }
29              
30             {
31             my %bro = (
32             "Don't be afraid to look at this message. It is completely harmless. Really!"
33             => decode_base64('G0oAAIyUq+1oRZSkJ0v1kiZ2hk1hs4NDDti/XVogkErgISv5M41kDrdKRMH7fRK8YAmyXwFNYppR3EBMbVhyBA=='),
34             'X5O!P%@AP[4\PZX54(P^)7CC)7}$EICAR-STANDARD-ANTIVIRUS-TEST-FILE!$H+H*'
35             => decode_base64('G0MAABQhyezgvJQnNVXciUrtsAEHrvlk0bTzGSRPqOdwPRhITMNtn+G6LB8+EYrC/LjqijSZFRhTlo5XllmqeTHxsABuVSsB'),
36             );
37 0     0 0 0 sub bro_compress { return $bro{shift()} }
38             }
39              
40             my %builtin = (
41             'novirus.txt' => [
42             "Content-type: application/octet-stream\r\n".
43             "Content-disposition: attachment; filename=\"download.txt\"\r\n",
44             "Don't be afraid to look at this message. It is completely harmless. Really!",
45             ],
46             'eicar.txt' => [
47             "Content-type: application/octet-stream\r\n".
48             "Content-disposition: attachment; filename=\"download.txt\"\r\n",
49             'X5O!P%@AP[4\PZX54(P^)7CC)7}$EICAR-STANDARD-ANTIVIRUS-TEST-FILE!$H+H*',
50             'EICAR test virus',
51             ],
52             # EICAR test virus with junk behind (proper antivirus should not match
53             'eicar-junk.txt' => [
54             "Content-type: application/octet-stream\r\n".
55             "Content-disposition: attachment; filename=\"download.txt\"\r\n",
56             'X5O!P%@AP[4\PZX54(P^)7CC)7}$EICAR-STANDARD-ANTIVIRUS-TEST-FILE!$H+H*WHATEVER',
57             ],
58             # EICAR test virus prefixed with junk (proper antivirus should not match)
59             'junk-eicar.txt' => [
60             "Content-type: application/octet-stream\r\n".
61             "Content-disposition: attachment; filename=\"download.txt\"\r\n",
62             'WHATEVERX5O!P%@AP[4\PZX54(P^)7CC)7}$EICAR-STANDARD-ANTIVIRUS-TEST-FILE!$H+H*',
63             ],
64             # zipped novirus
65             'novirus.zip' => [
66             "Content-type: application/octet-stream\r\n".
67             "Content-disposition: attachment; filename=\"download.zip\"\r\n",
68             decode_base64('UEsDBBQAAAAIAE1900g2ai/1SAAAAEwAAAAJABwAZWljYXIuY29tVVQJAANCoWZXQqFmV3V4CwABBOkDAAAE6QMAAA3JsRGAMAgF0N4pvpVdprCxzQaoaHKCeIEm25vy3VvtXQI7g65G9UQYxOwBBaJUh7I73ZywBQYP0084WDoKNZWxCZlJpM/TD1BLAQIeAxQAAAAIAE1900g2ai/1SAAAAEwAAAAJABgAAAAAAAEAAAC0gQAAAABlaWNhci5jb21VVAUAA0KhZld1eAsAAQTpAwAABOkDAABQSwUGAAAAAAEAAQBPAAAAiwAAAAAA'),
69             ],
70             # zipped eicar.com
71             'eicar.zip' => [
72             "Content-type: application/octet-stream\r\n".
73             "Content-disposition: attachment; filename=\"download.zip\"\r\n",
74             decode_base64('UEsDBAoAAAAAADJHi0c8z1FoRAAAAEQAAAAJABwAZWljYXIuY29tVVQJAAPvgWpWjqBmV3V4CwABBOkDAAAE6QMAAFg1TyFQJUBBUFs0XFBaWDU0KFBeKTdDQyk3fSRFSUNBUi1TVEFOREFSRC1BTlRJVklSVVMtVEVTVC1GSUxFISRIK0gqUEsBAh4DCgAAAAAAMkeLRzzPUWhEAAAARAAAAAkAGAAAAAAAAQAAAKCBAAAAAGVpY2FyLmNvbVVUBQAD74FqVnV4CwABBOkDAAAE6QMAAFBLBQYAAAAAAQABAE8AAACHAAAAAAA='),
75             'EICAR test virus in zip file',
76             ],
77             'warn.png' => [ "Content-type: image/png\r\n", decode_base64( <<'IMAGE' ) ],
78             iVBORw0KGgoAAAANSUhEUgAAABkAAAAZCAIAAABLixI0AAAAI0lEQVQ4y2N8fkObgUqAiYF6YNSs
79             UbNGzRo1a9SsUbOGi1kA82oCHFP7+koAAAAASUVORK5CYII=
80             IMAGE
81             'ok.png' => [ "Content-type: image/png\r\n", decode_base64( <<'IMAGE' ) ],
82             iVBORw0KGgoAAAANSUhEUgAAABkAAAAZCAIAAABLixI0AAAAIklEQVQ4y2Nk+MZALcDEwDBq1qhZ
83             o2aNmjVq1qhZo2ahAQDhPQEogMYUlwAAAABJRU5ErkJggg==
84             IMAGE
85             'bad.png' => [ "Content-type: image/png\r\n", decode_base64( <<'IMAGE' ) ],
86             iVBORw0KGgoAAAANSUhEUgAAABkAAAAZCAIAAABLixI0AAAAI0lEQVQ4y2N8zKfDQCXAxEA9MGrW
87             qFmjZo2aNWrWqFnDxSwAAzgBT9lsF30AAAAASUVORK5CYII=
88             IMAGE
89             'chunked.gif' => [ "Content-type: image/gif\r\n", decode_base64( <<'IMAGE' ) ],
90             R0lGODlhFAAUAKUrAAAAAAQEBAUFBQsLCxMTExYWFhcXFxwcHB0dHSAgICEhISwsLDExMTMzMzY2
91             Njo6OkFBQUJCQkZGRkhISGhoaGlpaZiYmJmZmZqamp6enqCgoKKiosfHx9bW1tfX19/f3+Dg4OTk
92             5Obm5ujo6Onp6erq6vX19fb29vn5+fr6+vv7+///////////////////////////////////////
93             /////////////////////////////////////////////yH5BAEKAD8ALAAAAAAUABQAAAZgwJVw
94             SCwaj8ikcslEqjQTg2CwoHCUIgdgy90mUw3AwfJJmTqYRxIDSJCawwhgAx8SAKO6MABQ6Vd3eXoQ
95             c38XAAoleigMAAgXICknHmlKIWFdXEspGRIFAVQVV3+kpUpBADs=
96             IMAGE
97             'clen.gif' => [ "Content-type: image/gif\r\n", decode_base64( <<'IMAGE' ) ],
98             R0lGODlhFAAUAKEBAAAAAP///////////yH5BAEKAAIALAAAAAAUABQAAAIhjI+py+0PFwAxzYou
99             Nnp3/FVhNELlczppM7Wt6b7bTGMFADs=
100             IMAGE
101             'ok.html' => sub {
102             my $spec = shift;
103             return [ "Content-type: text/html\r\n",
104             "
HTML
" ]
105             },
106             'bad.html' => sub {
107             my $spec = shift;
108             return [ "Content-type: text/html\r\n",
109             "
HTML
" ]
110             },
111             'warn.html' => sub {
112             my $spec = shift;
113             return [ "Content-type: text/html\r\n",
114             "
HTML
" ]
115             },
116              
117             # we hide javascript behind GIF87a to work around content filters :)
118             'ok.js' => sub {
119             my $spec = shift;
120             return [ "Content-type: application/javascript\n",
121             "GIF87a=1;try { document.getElementById('$spec').style.backgroundColor = '#00e800'; } catch(e) {} ping_back('/ping?OK:$spec');" ]
122             },
123             'bad.js' => sub {
124             my $spec = shift;
125             return [ "Content-type: application/javascript\r\n",
126             "GIF87a=1;try { document.getElementById('$spec').style.backgroundColor = '#e30e2c'; } catch(e) {} ping_back('/ping?BAD:$spec');" ]
127             },
128             'warn.js' => sub {
129             my $spec = shift;
130             return [ "Content-type: application/javascript\r\n",
131             "GIF87a=1;try { document.getElementById('$spec').style.backgroundColor = '#e7d82b'; } catch(e) {} ping_back('/ping?WARN:$spec');" ]
132             },
133             'ping' => [ "Content-type: text/plain\r\n", "pong" ],
134             'ping.js' => [
135             "Content-type: application/javascript\r\n".
136             "Expires: Tue, 30 Jul 2033 20:04:02 GMT\r\n",
137             <<'PING_JS' ],
138             GIF87a=1;
139             function ping_back(url) {
140             var xmlHttp = null;
141             try { xmlHttp = new XMLHttpRequest(); }
142             catch(e) {
143             try { xmlHttp = new ActiveXObject("Microsoft.XMLHTTP"); }
144             catch(e) {
145             try { xmlHttp = new ActiveXObject("Msxml2.XMLHTTP"); }
146             catch(e) { xmlHttp = null; }
147             }
148             }
149             if (xmlHttp) {
150             xmlHttp.open('GET', url, true);
151             xmlHttp.send(null);
152             }
153             }
154             PING_JS
155             'set_success.js' => sub {
156             my $spec = shift;
157             return [ "Content-type: application/javascript\n", "set_success('$spec','js');" ]
158             },
159             'parent_set_success.html' => sub {
160             my $spec = shift;
161             return [ "Content-type: text/html\n", "" ]
162             },
163             'stylesheet.css' => [
164             "Content-type: text/css\r\n".
165             "Expires: Tue, 30 Jul 2033 20:04:02 GMT\r\n",
166             <<'STYLESHEET' ],
167             body { max-width: 55em; line-height: 140%; margin-left: 2em; }
168             ul { list-style-type: square; padding-left: 2em; }
169             h1 { font-variant: small-caps; font-size: x-large; }
170             h2,h3 { font-size: large; }
171             .runtest { text-align: right; margin-right: 5em; margin-top: 2em; }
172             .runtest a {
173             text-decoration: none;
174             background-color: #bfbfbf;
175             color: #333333;
176             padding: 4px 6px;
177             white-space: nowrap;
178             }
179             #test_novirus a { background-color: #70e270; padding: 8px 10px; }
180             #test_virus a { background-color: #ff4d4d; padding: 8px 10px; }
181              
182             h1,h2,h3 { border: 1px; border-style: solid; padding: 5px 10px 5px 10px; }
183             h1 { color: #000; background: #eee; padding-top: 10px; padding-bottom: 10px; }
184             h2 { color: #444; background: #eee; }
185             h3 { color: #444; background: #fff; }
186             h2,h3 { margin-top: 2em; }
187              
188             * { font-size: medium; font-family: Verdana,sans-serif; }
189              
190             pre { font-family: Monospace,monospace; }
191              
192             .button {
193             text-decoration: none;
194             background-color: #EEEEEE;
195             color: #333333;
196             padding: 2px 6px 2px 6px;
197             border-top: 1px solid #CCCCCC;
198             border-right: 1px solid #333333;
199             border-bottom: 1px solid #333333;
200             border-left: 1px solid #CCCCCC;
201             white-space: nowrap;
202             }
203             STYLESHEET
204              
205             # give the bots something to play with
206             'robots.txt' => [
207             "Content-type: text/plain\r\n",
208             "User-Agent: *\nDisallow: /have-fun-looking-for-goodies/\n"
209             ],
210             # and a nice favicon
211             'favicon.ico' => [ "Content-type: image/vnd.microsoft.icon\r\n", decode_base64(<<'FAVICON') ],
212             AAABAAEAEBAQAAEABAAoAQAAFgAAACgAAAAQAAAAIAAAAAEABAAAAAAAgAAAAAAAAAAAAAAAEAAA
213             AAAAAAAAAAAASB3MAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
214             AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAERAAAAAAAAAREAAAAAAAABAQAAAAAAARER
215             EQAAAAARAAABEAAAAAAAAAAAAAAAAAERAAAAAAAAABAAAAAAAAAAAAAAAAAAAQAAAQAAAAAREAAR
216             EAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAD//wAA//8AAP4/AAD+PwAA/r8AAPgPAADz5wAA//8A
217             AP4/AAD/fwAA//8AAPvvAADxxwAA//8AAP//AAD//wAA
218             FAVICON
219             );
220              
221              
222             sub content {
223 0     0 0 0 my ($page,$spec) = @_;
224 0         0 $page =~s{^/+}{};
225 0         0 my ($hdr,$data);
226 0 0       0 if ( my $builtin = $builtin{$page} ) {
227 0 0       0 $builtin = $builtin->($spec,"/$page") if ref($builtin) eq 'CODE';
228 0         0 return @$builtin;
229             }
230 0 0 0     0 if ( $basedir && open( my $fh,'<',"$basedir/$page" )) {
231 0 0       0 $hdr =
    0          
    0          
    0          
232             $page =~m{\.js$} ? "Content-type: application/javascript\r\n" :
233             $page =~m{\.css$} ? "Content-type: text/css\r\n" :
234             $page =~m{\.html?$} ? "Content-type: text/html\r\n" :
235             $page =~m{\.(gif|png|jpeg)$} ? "Content-type: image/$1\r\n" :
236             "";
237 0         0 $data = do { local $/; <$fh> };
  0         0  
  0         0  
238 0         0 return ($hdr,$data);
239             }
240 0         0 return;
241             }
242              
243             sub html_escape {
244 0     0 0 0 local $_ = shift;
245 0         0 s{\&}{&}g;
246 0         0 s{<}{<}g;
247 0         0 s{>}{>}g;
248 0         0 return $_
249             }
250              
251             sub url_encode {
252 0     0 0 0 local $_ = shift;
253 0         0 s{([^\w\-&/?=!$~.,;])}{ sprintf("%%%02X",ord($1)) }esg;
  0         0  
254 0         0 return $_;
255             }
256              
257             sub SETUP {
258 1     1 0 10 my ($id,$desc,$ldesc,@tests) = @_;
259 1         2 my $pkg = caller();
260 1         2 my @tests_only;
261 1         1 for my $t (@tests) {
262             # title | valid,spec,desc
263 173 100       204 if (@$t>1) {
264 161         96 $t = bless [ @{$t}[1,2,0] ], $pkg.'::Test';
  161         231  
265 161         132 push @tests_only, $t;
266             }
267             }
268              
269 1     1   4 no strict 'refs';
  1         1  
  1         1443  
270 1     0   6 *{$pkg.'::ID'} = sub { $id };
  1         5  
  0         0  
271 1     0   3 *{$pkg.'::SHORT_DESC'} = sub { $desc };
  1         4  
  0         0  
272 1     0   6 *{$pkg.'::LONG_DESC_HTML'} = sub { $ldesc };
  1         3  
  0         0  
273 1     0   2 *{$pkg.'::TESTS'} = sub { @tests_only };
  1         14  
  0         0  
274 1         2 *{$pkg.'::make_index_page'} = sub {
275 0     0   0 my ($self,$page,$spec,$rqhdr) = @_;
276 0 0       0 return make_index_page($pkg,@tests) if ! $spec;
277 0 0       0 return make_index_page($pkg,undef,grep { $_->[0] && $_->[0] eq $spec } @tests);
  0         0  
278 1         3 };
279              
280 1     0   2 *{$pkg.'::Test::ID'} = sub { shift->[0] };
  1         3  
  0         0  
281 1     0   5 *{$pkg.'::Test::LONG_ID'} = sub { "$id-" . shift->[0] };
  1         3  
  0         0  
282 1     0   2 *{$pkg.'::Test::NUM_ID'} = sub { _path2num("$id/".shift->[0]) };
  1         3  
  0         0  
283 1     0   1 *{$pkg.'::Test::DESCRIPTION'} = sub { shift->[1] };
  1         3  
  0         0  
284 1     0   2 *{$pkg.'::Test::VALID'} = sub { shift->[2] };
  1         3  
  0         0  
285 1         3 *{$pkg.'::Test::url'} = sub {
286 0     0   0 my ($self,$page) = @_;
287 0         0 return garble_url("/$id/$page/$self->[0]");
288 1         3 };
289 1         5 *{$pkg.'::Test::make_response'} = sub {
290 0     0     my ($self,$page,$spec,$rqhdr) = @_;
291 0           return $pkg->make_response($page,$self->[0],$rqhdr);
292 1         2 };
293             }
294              
295             sub make_index_page {
296 0     0 0   my ($class,@tests) = @_;
297 0           my $body = <<'BODY';
298            
299            
300            
301             BODY
302 0 0         if ($tests[0]) {
303 0           $body .= "

".$class->SHORT_DESC."

";
304 0           $body .= $class->LONG_DESC_HTML()."
";
305             } else {
306             # skip header
307             shift @tests
308 0           }
309 0           $body .= ''; "; "; "; "; "; "; "; "; "; ";
310 0           for my $test (@tests) {
311 0 0         if (!blessed($test)) {
312 0           $body .= "

$test->[0]

313 0           next;
314             }
315 0           my $valid = $test->VALID;
316 0 0         my $base = $valid>0 ? 'ok' : $valid<0 ? 'warn' : 'bad';
    0          
317 0 0         my $bg = $valid>0 ? '#e30e2c' : $valid<0 ? '#d0cfd1' : '#00e800';
    0          
318 0           $body .= "
319 0           $body .= "". html_escape($test->DESCRIPTION) ."
320 0           $body .= "
IMAGE
321 0           $body .= "
SCRIPT
322 0           $body .= "
323 0           $body .= " load EICAR 
324 0           $body .= " load eicar.zip 
325 0           $body .= "
326 0           $body .= "";
327 0           $body .= "
328             }
329 0           $body .= "
";
330 0           $body .= "";
331 0           return "HTTP/1.0 200 Ok\r\n".
332             "Content-type: text/html\r\n".
333             "Content-length: ".length($body)."\r\n\r\n".
334             $body;
335             }
336              
337             sub garble_url {
338 0     0 0   my $url = shift;
339 0 0         return $url if $NOGARBLE;
340 0 0         my ($keep,$garble) = $url =~m{^((?:https?://[^/]+)?/)(.+)}
341             or return $url;
342 0 0         my $xor = $CLIENTIP ? _ip2bin($CLIENTIP): pack('L',rand(2**32));
343 0 0         my $g = ($CLIENTIP ? pack('C',length($xor)):'') . $xor . _xorall($garble,$xor);
344             # url safe base64
345 0           my $pad = ( 3 - length($g) % 3 ) % 3;
346 0           $g = pack('u',$g);
347 0           $g =~s{(^.|\n)}{}mg;
348 0           $g =~tr{` -_}{AA-Za-z0-9\-_};
349 0 0         substr($g,-$pad) = '=' x $pad if $pad;
350 0 0         return $keep . ($CLIENTIP?'-':'=') . $g;
351             }
352              
353             sub ungarble_url {
354 0     0 0   my $url = shift;
355 0 0         my ($keep,$type,$u,$rest) = $url =~m{^(.*/)([=-])([0-9A-Za-z_\-]+={0,2})([/? ].*)?$}
356             or return $url;
357             # url safe base64 -d
358 0           $u =~s{=+$}{};
359 0           $u =~tr{A-Za-z0-9\-_}{`!-_};
360 0           $u =~s{(.{1,60})}{ chr(32 + length($1)*3/4) . $1 . "\n" }eg;
  0            
361 0           $u = unpack("u",$u);
362 0 0         my $size = ($type eq '=') ? 4: unpack('C',substr($u,0,1,''));
363 0           my $xor = substr($u,0,$size,'');
364 0 0 0       ${$_[0]} = _bin2ip($xor) if $type ne '=' && @_;
  0            
365 0           $u = _xorall($u,$xor);
366             # make sure we only have valid stuff here
367 0 0         $u = 'some-binary-junk' if $u =~m{[\x00-\x1f\x7f-\xff]};
368 0   0       return $keep . $u . ($rest || '');
369             }
370              
371              
372             sub zlib_compress {
373 0     0 0   my ($data,$w) = @_;
374 0 0         my $zlib = Compress::Raw::Zlib::Deflate->new(
    0          
375             -WindowBits => $w eq 'gzip' ? WANT_GZIP : $w eq 'zlib' ? +MAX_WBITS() : -MAX_WBITS(),
376             -AppendOutput => 1,
377             );
378 0           my $newdata = '';
379 0           $zlib->deflate( $data, $newdata);
380 0           $zlib->flush($newdata,Z_FINISH);
381 0           return $newdata;
382             }
383              
384             {
385             my ($path2num,$num2path);
386             sub load_nummap {
387 0 0   0 0   my $maxold = @_>1 ? pop(@_) : 9999;
388 0   0       $num2path = eval(
389             "require App::DubiousHTTP::Tests::TestID;".
390             "App::DubiousHTTP::Tests::TestID->num2path"
391             ) || {};
392 0           $path2num = { reverse %$num2path };
393 0           my @new;
394 0           for my $mod ( App::DubiousHTTP::Tests->categories ) {
395 0           my $catid = $mod->ID;
396 0           for ($mod->TESTS) {
397 0           my $path = "$catid/".$_->ID;
398 0 0         if (my $n = $path2num->{$path}) {
399 0 0 0       $maxold = $n if !defined $maxold || $maxold<$n;
400             } else {
401 0           push @new,$path;
402             }
403             }
404             }
405 0           for(@new) {
406 0           $maxold++;
407 0           $num2path->{$maxold} = $_;
408 0           $path2num->{$_} = $maxold;
409             }
410 0           return $num2path;
411             }
412             sub _path2num {
413 0     0     my $path = shift;
414 0 0         $path2num || load_nummap;
415 0           return $path2num->{$path};
416             }
417 0     0 0   sub num2path { _num2path($_[1]) }
418             sub _num2path {
419 0     0     my $num = shift;
420 0 0         $num2path || load_nummap;
421 0           return $num2path->{$num};
422             }
423             }
424              
425             sub _xorall {
426 0     0     my ($data,$xor) = @_;
427 0           my @x = unpack('a' x length($xor),$xor);
428 0           my @c = split('',$data);
429 0           $data = '';
430 0           while (@c) {
431 0           $data .= shift(@c) ^ $x[0];
432 0           push @x, shift(@x);
433             }
434 0           return $data;
435             }
436              
437             sub _ip2bin {
438 0     0     my $ip = shift;
439              
440             # inet_ntop(AF_INET,...)
441 0 0         return pack("CCCC",split(m{\.},$1))
442             if $ip =~m{^(?:::ffff:)?(\d+\.\d+\.\d+\.\d+)$};
443              
444             # inet_ntop(AF_INET6,...)
445 0           my @p = split(m{:},$ip);
446 0           $ip = '';
447 0           for(my $i=0;$i<@p;$i++) {
448 0 0         if ($p[$i] eq '') {
449 0           $p[$i] = '0';
450 0           splice(@p,$i,0,'0') while @p<8;
451             }
452 0           $ip .= pack("n",hex($p[$i]));
453             }
454 0           return $ip;
455             }
456              
457             sub _bin2ip {
458 0     0     my $ip = shift;
459 0 0         return join('.',unpack('CCCC',$ip)) if length($ip) == 4;
460 0           my @part = unpack("n8",$ip);
461 0           my (@null,$null,$maxnull);
462 0           for( my $i=0;$i<@part;$i++) {
463 0 0         if (!$part[$i]) {
464 0           $part[$i] = '0';
465 0 0         if ($null) {
466 0           $$null++;
467 0 0 0       $maxnull = $#null if !$maxnull || $$null>$maxnull;
468             } else {
469 0           push @null,[$i,1];
470 0           $null = \$null[-1][1];
471             }
472             } else {
473 0           $part[$i] = sprintf("%x",$part[$i]);
474 0           $null = undef;
475             }
476             }
477 0 0         return join(':',@part) if !defined $maxnull;
478 0           my $begin = $null[$maxnull][0];
479 0           my $end = $begin + $null[$maxnull][1]-1;
480 0           return join(':', @part[0 .. $begin-1]). '::'. join(':',@part[$end+1 .. $#part]);
481             }
482              
483             1;