view release on metacpan or  search on metacpan

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

#--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");
$ss=join"",map "*".join(",",@$_), cart(\@a1,\@a2,\@a3,sub{sum(@$_)%3==0});
ok( $ss eq "*1,10,100*1,10,400*1,20,300*1,30,200*2,10,300*2,20,200*2,30,100*2,30,400", 'cart - array mode');

my @ch=                                         cart(a=>[1..3],b=>[1..2],c=>[1..4]);
my @ca=map{my($a,$b,$c)=@$_;{a=>$a,b=>$b,c=>$c}}cart(   [1..3],   [1..2],   [1..4]);
ok_ref(\@ch,\@ca, 'cart - hash mode');

#--num2code, code2num

ok( num2code(255,2,"0123456789ABCDEF") eq 'FF' );
ok( num2code(14,2,"0123456789ABCDEF")  eq '0E' );
ok( num2code(1234,16,"01") eq '0000010011010010' );
ok( code2num("0000010011010010","01") eq '1234' );
my $chars='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-_';
my $code=num2code("241274432",5,$chars);
ok( $code eq 'EOOv0' );

#--gcd
ok( gcd(12, 8) == 4 );
ok( gcd(90, 135, 315) == 45 );
ok( gcd(2*3*3*5, 3*3*3*5, 3*3*5*7) == 45 );

#--lcm
ok( lcm(45,120,75) == 1800 );
#--pivot
 my @table=(
               [1997,"Gina", "Weight", "Summer",66],
               [1997,"Gina", "Height", "Summer",170],
               [1997,"Per",  "Weight", "Summer",75],
               [1997,"Per",  "Height", "Summer",182],
               [1997,"Hilde","Weight", "Summer",62],
               [1997,"Hilde","Height", "Summer",168],
               [1997,"Tone", "Weight", "Summer",70],
 
               [1997,"Gina", "Weight", "Winter",64],
               [1997,"Gina", "Height", "Winter",158],