view release on metacpan or  search on metacpan

t/02_general.t  view on Meta::CPAN

ok( join( " ", not_intersect( ["five", 1, 2, 3.0, 4], [4, 2+1, "five"] )) eq '1 2' );

#--subhash
my %pop = ( Norway=>4800000, Sweeden=>8900000, Finland=>5000000,
            Denmark=>5100000, Iceland=>260000, India => 1e9 );
ok_ref({subhash(\%pop,qw/Norway Sweeden Denmark/)},
       {Denmark=>5100000,Norway=>4800000,Sweeden=>8900000}, 'subhash');

#--hashtrans
my%h = ( 1 => {a=>33,b=>55},
         2 => {a=>11,b=>22},
         3 => {a=>88,b=>99} );
ok_ref( {hashtrans(\%h)},
        {a=>{1=>33,2=>11,3=>88},
         b=>{1=>55,2=>22,3=>99}}, 'hashtrans' );

#--ipaddr, ipnum
my $ipnum=ipnum('www.vg.no'); # !defined implies no network
my $ipaddr=defined$ipnum?ipaddr($ipnum):undef;
if( defined $ipaddr ){
  ok( $ipnum=~/^(\d+\.\d+\.\d+\.\d+)$/, 'ipnum'); #hm ip6
  is( ipaddr($ipnum), 'www.vg.no' );
  is( $Acme::Tools::IPADDR_memo{$ipnum}, 'www.vg.no' );
  is( $Acme::Tools::IPNUM_memo{'www.vg.no'}, $ipnum );
}
else{
  ok( 1, 'skip: no network') for 1..4
}

#--in_iprange

eval{in_iprange('x','255.255.255.255')};                  ok( $@=~/malformed ipnum x/,            'in_iprange, malformed ipnum' );
eval{in_iprange('255.255.255.255','x')};                  ok( $@=~/malformed iprange x/,          'in_iprange, malformed iprange' );
eval{in_iprange('0.0.0.0','255.255.255.256')};            ok( $@=~/iprange part should be 0-255/, 'in_iprange, iprange part should be 0-255' );
eval{in_iprange('255.255.256.255','255.255.255.255')};    ok( $@=~/invalid ipnum/,                'in_iprange, invalid ipnum' );
eval{in_iprange('255.255.255.255','255.255.255.255/33')}; ok( $@=~/iprange mask should be 0-32/,  'in_iprange, invalid iprange' );
eval{in_iprange('100.255.255.255','100.255.255.0/22')};   ok( $@=~m|need zero in last 10 bits, should be 100.255.252.0/22|, 'in_iprange, need zero in last 10...' );
ok( in_iprange('255.255.255.255','255.255.255.0/24'), 'in_iprange' );
ok( in_iprange('255.255.255.254','255.255.254.0/23'), 'in_iprange' );
ok( in_iprange('100.255.255.255','100.255.254.0/23'), 'in_iprange, yes' );
ok( in_iprange('100.255.254.0','100.255.254.0/23'),   'in_iprange, y' );
ok( in_iprange('100.255.255.0','100.255.254.0/23'),   'in_iprange, y' );
ok(!in_iprange('100.255.0.1','100.254.254.0/23'),     'in_iprange, n' );
ok( in_iprange('100.255.0.1','100.255.0.1'),          'in_iprange, same' );
ok( in_iprange('100.255.0.1','100.255.0.1/32'),       'in_iprange, same/32' );
ok( in_iprange('0.0.0.1','0.0.0.0/1'),                'in_iprange, /1' );
ok( in_iprange(join('.',map int(rand(256)),1..4),'0.0.0.0/0'), 'in_iprange, /0' );

#--webparams, urlenc, urldec
my $s=join"",map random([qw/hip hop and you dont stop/]), 1..1000;
my %in=("\n&pi=3.14+0\n\n"=>gz($s x 5),123=>123321);
my %out=webparams(join("&",map{urlenc($_)."=".urlenc($in{$_})}sort keys%in));
ok_ref( \%in, \%out, 'webparams 1' );
ok_ref( $a={webparams("b=123&a=1&b=122&a=3&a=2%20")},{a=>'1,3,2 ',b=>'123,122'}, 'webparams 2' );undef$a;

#--chall
my $tmp=tmp();
if($^O eq 'linux' and -w$tmp){
  my $f1="$tmp/tmpf1";
  my $f2="$tmp/tmpf2";
  chmod(0777,$f1,$f2) and unlink($f1, $f2);
  open my $fh1,">",$f1 or die$!;
  open my $fh2,">",$f2 or die$!;
  close($fh1);close($fh2); #sleep_fp(0.5);
  chmod(0457,$f1);#chmod(02457,$f1);
  my $chown=chown(666,777,$f1);# or warn " -- Not checking chown, ok if not root\n";
  utime(1e9,1.1e9,$f1);
  my @stat=stat($f1);
  my $chall_ant=chall(\@stat,$f2);
  ok(!$chown || $chall_ant==1, "chall returned $chall_ant");
  for(($f1,$f2)){
    print "$_\n";
    my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks ) = stat($_);
    ok($mode%010000 == 0457, sprintf("mode=%05o",$mode));
    ok(!$chown || $uid == 666,    "uid=$uid");
    ok(!$chown || $gid == 777,    "gid=$gid");
    ok($atime==1e9,    "atime=$atime");
    ok($mtime==1.1e9,  "mtime=$mtime");
  }
  chmod(0777,$f1,$f2) and unlink($f1, $f2);
}
else {ok(1) for 1..11}   # not linux

#--writefile, readfile
if($^O eq 'linux' and -w$tmp){
  my $fn="$tmp/tmptestfile$$";
  unlink($fn);
  my $data="xxx\nyyy\nzzzz" x 10001;
  writefile($fn,$data);
  if(open my $file, "<", $fn){ ok(join("",<$file>) eq $data, 'writefile') }
  else                       { ok(0,"open $fn") }
  ok("".readfile($fn) eq $data, 'readfile');
  ok(join(",",readfile($fn)) eq replace($data,"\n",","), 'readfile lines');
  my $sz=-s$fn;
  unlink($fn);
  writefile("$fn.gz",$data);
  my $szgz=-s"$fn.gz";
  ok($szgz/$sz < 0.1,             'writefile gz');
  deb "gz ".($szgz/$sz);
  ok(readfile("$fn.gz") eq $data, 'readfile gz');
  unlink("$fn.gz");
}
else{ok(1) for 1..5}     # not linux

#--permutations, perm, permutate
ok(join("-", map join("",@$_), permutations('a','b'))  eq 'ab-ba',                  'permutations 1');
ok(join("-", map join("",@$_), permutations('a'..'c')) eq 'abc-acb-bac-bca-cab-cba','permutations 2');
ok(join("-", map join("",@$_), perm(        'a'..'c')) eq 'abc-acb-bac-bca-cab-cba','perm');

my @p=('a'..'e');
my $permute=printed { print permute{print @_,"\n"}@p };
is($permute, join('',map join('',@$_)."\n", perm(@p)).120,'permute');

my $permute2=printed { print permute{print @_,"\n"}\@p,['b','a','c'] };
my @perm=perm('a'..'c'); splice@perm,0,2;
is($permute2, join('',map join('',@$_)."\n", @perm).4,'permute start at');


#--trigram
ok( join(", ",trigram("Kjetil Skotheim"))   eq 'Kje, jet, eti, til, il , l S,  Sk, Sko, kot, oth, the, hei, eim',        'trigram');
ok( join(", ",trigram("Kjetil Skotheim", 4)) eq 'Kjet, jeti, etil, til , il S, l Sk,  Sko, Skot, koth, othe, thei, heim','trigram');

#--sliding
ok_ref([sliding(["Reven","rasker","over","isen"],2)],
       [['Reven','rasker'],['rasker','over'],['over','isen']], 'sliding' );

#--chunks
ok_ref( [chunks("Reven rasker over isen",7)],['Reven r','asker o','ver ise','n'] ,            'chunks string' );
ok_ref( [chunks([qw/Og gubben satt i kveldinga og koste seg med skillinga/], 3)],
           [['Og','gubben','satt'],['i','kveldinga','og'],['koste','seg','med'],['skillinga']] , 'chunks array' );

#--cart
my @a1 = (1,2);
my @a2 = (10,20,30);
my @a3 = (100,200,300,400);
my $ss = join"", map "*".join(",",@$_), cart(\@a1,\@a2,\@a3);
ok( $ss eq "*1,10,100*1,10,200*1,10,300*1,10,400*1,20,100*1,20,200"
          ."*1,20,300*1,20,400*1,30,100*1,30,200*1,30,300*1,30,400"
          ."*2,10,100*2,10,200*2,10,300*2,10,400*2,20,100*2,20,200"
          ."*2,20,300*2,20,400*2,30,100*2,30,200*2,30,300*2,30,400");