Acme-Tools
view release on metacpan or search on metacpan
t/02_general.t view on Meta::CPAN
# make test
# perl Makefile.PL && make && perl -Iblib/lib t/02_general.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 204;
use Digest::MD5 qw(md5_hex);
my @empty;
#-- min, max
ok(min(1,2,3,undef,4)==1, 'min');
ok(max(undef,1,4,3,4)==4, 'max');
ok(not defined min());
ok(not defined max());
ok(not defined min(@empty));
ok(not defined max(@empty));
#-- mins, maxs
ok(mins('2','4','10') eq '10', 'mins');
ok(maxs(2,4,10) == 4, 'maxs');
#--sum
ok(sum(2)==2);
ok(sum(2,2)==4);
ok(sum(2,-2)==0);
ok(sum(1..1000)==500500);
ok(!defined sum(), 'def sum');
ok(!defined sum(@empty), 'def sum');
ok(!defined(sum(undef,undef)), 'def sum');
ok(sum(undef,2)==2, 'def sum');
ok(sum(3,undef)==3, 'def sum');
#--avg, geomavg
ok(avg(2,4,9)==5, 'avg 2 4 9 is 5');
ok(avg([2,4,9])==5, 'avg 2 4 9 is 5');
ok(avg(2,4,9,undef)==5, 'avg ignore undef');
ok(0==0+grep{abs(geomavg($_,$_)-$_)>1e-8}range(3,10000,13));
ok(abs(geomavg(2,3,4,5)-3.30975091964687)<1e-11);
ok(abs(geomavg(10,100,1000,10000,100000)-1000)<1e-8);
ok(!defined(avg(undef)));
#--stddev
ok(stddev(12,13,14)>0);
ok(between(stddev(map { avg(map rand(),1..100) } 1..100), 0.02, 0.04));
ok(!defined(stddev()));
for((1,10,100)){ my @a=map rand(),1..$_; ok(stddev(@a) == stddev(\@a),'stddev: not ref vs ref') }
#print map"$_\n", sort {$a<=>$b} map stddev(map { avg(map rand(),1..100) } 1..100), 1..1000;
#--median
ok(median(2,3,4,5,6)==4);
ok(median(2,3,4,5)==3.5);
ok(median(2)==2);
ok(median(reverse(1..10000))==5000.5);
ok(median( 1, 4, 6, 7, 8, 9, 22, 24, 39, 49, 555, 992 ) == 15.5 );
ok(not defined median(undef));
#--percentile
ok(percentile(25, 1, 4, 6, 7, 8, 9, 22, 24, 39, 49, 555, 992 ) == 6.25);
ok(percentile(75, 1, 4, 6, 7, 8, 9, 22, 24, 39, 49, 555, 992 ) == 46.5);
ok(join(", ",percentile([0,1,25,50,75,99,100], 1,4,6,7,8,9,22,24,39,49,555,992))
eq '-2, -1.61, 6.25, 15.5, 46.5, 1372.19, 1429');
#--nvl
ok(not defined nvl());
ok(not defined nvl(undef));
ok(not defined nvl(undef,undef));
ok(not defined nvl(undef,undef,undef,undef));
ok(nvl(2.0)==2);
ok(nvl("3e0")==3);
ok(nvl(undef,4)==4);
ok(nvl(undef,undef,5)==5);
ok(nvl(undef,undef,undef,6)==6);
ok(nvl(undef,undef,undef,undef,7)==7);
#--replace
ok( replace("water","ater","ine") eq 'wine' );
ok( replace("water","ater") eq 'w');
ok( replace("water","at","eath") eq 'weather');
ok( replace("water","wa","ju",
"te","ic",
"x","y",
'r$',"e") eq 'juice' );
ok( replace('JACK and JUE','J','BL') eq 'BLACK and BLUE' );
ok( replace('JACK and JUE','J') eq 'ACK and UE' );
ok( replace('a2b3c4',qr/\d/) eq 'abc');
ok( replace('a2b3c4','\d') eq 'abc');
ok( replace('a2b3c4',qr{[^a-z]},'.') eq 'a.b.c.');
ok( replace('a2b3c4','[^a-z]','.') eq 'a.b.c.');
my $str="test";
replace(\$str,'e','ee','s','S');
ok( $str eq 'teeSt' );
ok( replace("abc","a","b","b","c") eq "ccc" ); #not bcc
#--decode, decode_num
my $test=123;
ok( decode($test, 123,3, 214,4, $test) == 3 ,'decode easy');
ok( decode($test, 122=>3, 214=>7, $test) == 123 ,'decode else');
ok( !defined decode($test, '123.0'=>3, 214=>7) ,'decode !def'); # prints nothing (undef)
ok( decode($test, 123.0=>3, 214=>7) == 3 ,'decode float');
ok( decode_num($test, 121=>3, 221=>7, '123.0','b') eq 'b' ,'decode_num');
#--between
ok( between(7, 1,10) ,'between a');
ok( between(undef, 1,10) eq '' ,'between b');
ok( between(7, 10,1) ,'between c');
ok( between(5,5,5) ,'between d');
#--btw, a better(?) between
ok( btw(7, 1,10) ,'btw a');
ok( btw(undef, 1,10) eq '' ,'btw b');
ok( btw(7, 10,1) ,'btw c');
ok( btw(5,5,5) ,'btw d');
ok( btw(1,1,10) ,'btw e'); # numeric order since all three looks like number according to =~$Re_isnum
ok( btw(1,'02',13) ,'btw f'); # leading zero in '02' leads to alphabetical order
ok( btw(10, 012,10) ,'btw h'); # leading zero here means oct number, 012 = 10 (8*1+2), so 10 is btw 10 and 10
ok(!btw('003', '02', '09') ,'btw i'); #
ok(!btw('a', 'b', 'c') ,'btw j'); #
ok( btw('a', 'B', 'c') ,'btw k'); #
ok( btw('a', 'c', 'B') ,'btw l'); #
ok( btw( -1, -2, 1) ,'btw m');
ok( btw( -1, -2, 0) ,'btw n');
ok( btw( -1, -2, '0e0') ,'btw o');
#my($btw,$btw2)=(0,0);
#my @errs=grep{my@a=map rand(),1..3;$btw++ if btw(@a);$btw2++ if btw2(@a);btw(@a)!=btw2(@a)}1..1000;
#ok( !@errs, "btw2==btw, btw=$btw btw2=$btw2" );
#use Benchmark qw(:all) ;
#cmpthese(1e5, { btw => sub { btw(rand(),rand(),rand()) },
# btw2=> sub { btw2(rand(),rand(),rand()) } }); exit;
#--curb
my $vb = 234;
ok( curb( $vb, 200, 250 ) == 234, 'curb 1');
ok( curb( $vb, 150, 200 ) == 200, 'curb 2');
ok( curb( $vb, 250, 300 ) == 250 && $vb==234, 'curb 3');
ok( curb(\$vb, 250, 300 ) == 250 && $vb==250, 'curb 4');
ok( do{eval{curb()}; $@=~/^curb/}, 'curb 5'); eval{1};
ok( do{eval{curb(1,2,undef)}; $@=~/^curb/}, 'curb 6'); eval{1};
ok( do{eval{curb(1,2,3,4)}; $@=~/^curb/}, 'curb 7'); eval{1};
#--distinct
ok( join(", ", distinct(4,9,30,4,"abc",30,"abc")) eq '30, 4, 9, abc' );
#--in, in_num
ok( in( 5, 1,2,3,4,6) == 0 );
ok( in( 4, 1,2,3,4,6) == 1 );
ok( in( 'a', 'A','B','C','aa') == 0 );
ok( in( 'a', 'A','B','C','a') == 1 );
ok( in( undef,'A','B','C','a') == 0 );
ok( in( undef,'A','B','C',undef) == 1 ); # undef eq undef
ok( in(5000, '5e3') == 0 );
ok( in_num(5000, 1..4999,'5e3') == 1 );
#--uniq
my @t=(7,2,3,3,4,2,1,4,5,3,"x","xx","x",02,"07");
ok( join( " ", uniq @t ) eq '7 2 3 4 1 5 x xx 07' );
#--union
ok( join( ",", union([1,2,3],[2,3,3,4,4]) ) eq '1,2,3,4' );
#--minus
ok( join( " ", minus( ["five", "FIVE", 1, 2, 3.0, 4], [4, 3, "FIVE"] ) ) eq 'five 1 2' );
#--intersect
ok( join(" ", intersect( ["five", 1, 2, 3.0, 4], [4, 2+1, "five"] )) eq '4 3 five' );
#--not_intersect
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'] };
( run in 0.754 second using v1.01-cache-2.11-cpan-d80b1682f3f )