Acme-Tools
view release on metacpan or search on metacpan
=cut
sub _base{my($b,$n)=@_;$n?_base($b,int$n/$b).chr(48+$n%$b+7*($n%$b>9)):''} #codegolf
sub base {
my($b,$n)=@_;
@_>2 ? (map base($b,$_),@_[1..$#_])
:$b<2||$b>36 ? croak"base not 2-36"
:$n>0 ? _base($b,$n)
:$n<0 ? "-"._base($b,-$n)
:!defined $n ? undef
:$n==0 ? 0
: croak
}
sub dec2bin { sprintf"%b",shift }
sub dec2hex { sprintf"%x",shift }
sub dec2oct { sprintf"%o",shift }
sub bin2dec { oct("0b".shift) }
sub bin2hex { sprintf"%x",oct("0b".shift) }
sub bin2oct { sprintf"%o",oct("0b".shift) }
First argument: must be a coderef to a subroutine (a function)
Second argument: if present, the target, f(x)=target. Default 0.
Third argument: a start position for x. Default 0.
Fourth argument: a small delta value. Default 1e-4 (0.0001).
Fifth argument: a maximum number of iterations before resolve gives up
and carps. Default 100 (if fifth argument is not given or is
undef). The number 0 means infinite here. If the derivative of the
start position is zero or close to zero more iterations are typically
needed.
Sixth argument: A number of seconds to run before giving up. If both
fifth and sixth argument is given and > 0, C<resolve> stops at
whichever comes first.
B<Output:> returns the number C<x> for C<f(x)> = 0
...or equal to the second input argument if present.
#todo: ren solve?
sub resolve {
my($f,$goal,$start,$delta,$iters,$sec)=@_;
$goal=0 if!defined$goal;
$start=0 if!defined$start;
$delta=1e-4 if!defined$delta;
$iters=100 if!defined$iters;
$sec=0 if!defined$sec;
$iters=13e13 if $iters==0;
croak "Iterations ($iters) or seconds ($sec) can not be a negative number" if $iters<0 or $sec<0;
$Resolve_iterations=undef;
$Resolve_last_estimate=undef;
croak "Should have at least 1 argument, a coderef" if !@_;
croak "First argument should be a coderef" if ref($f) ne 'CODE';
my @x=($start);
my $time_start=$sec>0?time_fp():undef;
my $ds=ref($start) eq 'Math::BigFloat' ? Math::BigFloat->div_scale() : undef;
my $fx=sub{
local$_=$_[0];
my $fx=&$f($_);
if($fx=~/x/ and $fx=~/^[ \(\)\.\d\+\-\*\/x\=\^]+$/){
$fx=~s/(\d)x/$1*x/g;
$fx=~s/\^/**/g;
$fx=~s/^(.*)=(.*)$/($1)-($2)/;
$fx=~s,x,\$_,g;
$f=eval"sub{$fx}";
$fx=&$f($_);
print bytes_readable(1209462790553.6); # 1.10 TB
print bytes_readable(1088516511498.24*1000); # 990.00 TB
print bytes_readable(1088516511498.24*1000, 3); # 990.000 TB
print bytes_readable(1088516511498.24*1000, 1); # 990.0 TB
=cut
sub bytes_readable {
my $bytes=shift();
my $d=shift()||2; #decimals
return undef if !defined $bytes;
return "$bytes B" if abs($bytes) <= 2** 0*1000; #bytes
return sprintf("%.*f kB",$d,$bytes/2**10) if abs($bytes) < 2**10*1000; #kilobyte
return sprintf("%.*f MB",$d,$bytes/2**20) if abs($bytes) < 2**20*1000; #megabyte
return sprintf("%.*f GB",$d,$bytes/2**30) if abs($bytes) < 2**30*1000; #gigabyte
return sprintf("%.*f TB",$d,$bytes/2**40) if abs($bytes) < 2**40*1000; #terrabyte
return sprintf("%.*f PB",$d,$bytes/2**50); #petabyte, exabyte, zettabyte, yottabyte
}
=head2 sec_readable
print sec_readable( 1333331 ); # 15d 10h
print sec_readable( 13333331 ); # 154d 7h
print sec_readable( 133333331 ); # 4yr 82d
print sec_readable( 1333333331 ); # 42yr 91d
=cut
sub sec_readable {
my $s=shift();
my($h,$d,$y)=(3600,24*3600,365.25*24*3600);
!defined$s ? undef
:!length($s) ? ''
:$s<0 ? '-'.sec_readable(-$s)
:$s<60 && int($s)==$s
? $s."s"
:$s<60 ? sprintf("%.*fs",int(3+-log($s)/log(10)),$s)
:$s<3600 ? int($s/60)."m " .($s%60) ."s"
:$s<24*3600 ? int($s/$h)."h " .int(($s%$h)/60)."m"
:$s<366*24*3600 ? int($s/$d)."d " .int(($s%$d)/$h)."h"
: int($s/$y)."yr ".int(($s%$y)/$d)."d";
}
=head2 roman2int
roman2int("MCMLXXI") == 1971
=cut
#alternative algorithm: http://www.rapidtables.com/convert/number/how-number-to-roman-numerals.htm
#see also t/17_roman.t sub int2roman_old
sub int2roman {
my $n=shift;
!defined$n ? undef
: !length($n) ? ""
: $n<0 ? "-".int2roman(-$n)
: int($n)!=$n ? croak"int2roman: $n is not an integer"
# : $] >= 5.014 ? #s///r modifier introduced in perl v5.14
# ("I" x $n)
# =~s,I{1000},M,gr #unnecessary, but speedup for n>1000
# =~s,I{100},C,gr #unnecessary, but speedup for n>100
# =~s,I{10},X,gr #unnecessary, but speedup for n>10
# =~s,IIIII,V,gr
# =~s,IIII,IV,gr
btw(1,1,10) #true numeric order since all three looks like number according to =~$Re_isnum
btw(1,'02',13) #true leading zero in '02' leads to alphabetical order
btw(10, 012,10) #true leading zero here means oct number, 012 = 10 (8*1+2), so 10 is btw 10 and 10
btw('003', '02', '09') #false because '003' lt '02'
btw('a', 'b', 'c') #false because 'a' lt 'b'
btw('a', 'B', 'c') #true because upper case letters comes before lower case ones in the "ascii alphabet"
btw('a', 'c', 'B') #true, btw() and between switches from and to if the first is > the second
btw( -1, -2, 1) #true
btw( -1, -2, 0) #true
Both between and btw returns C<undef> if any of the three input args are C<undef> (not defined).
If you're doing only numerical comparisons, using C<between> is faster than C<btw>.
=cut
sub between {
my($test ,$fom, $tom)=@_;
return if !defined$test or !defined$fom or !defined$tom;
$fom < $tom ? $test >= $fom && $test <= $tom : $test >= $tom && $test <= $fom;
}
print curb( $enthusiasm, 1, 20 ); # prints 11, within bounds
print curb( $enthusiasm, 1, 10 ); # prints 10
print curb( $enthusiasm, 20, 100 ); # prints 20
print curb(\$enthusiasm, 1, 10 ); # prints 10 and sets $enthusiasm = 10
print $enthusiasm; # prints 10
=cut
sub curb {
my($val,$min,$max)=@_;
# todo: undef min|max => dont curb min|max
croak "curb: wrong args" if @_!=3 or !defined$min or !defined$max or !defined$val or $min>$max;
return $$val=curb($$val,$min,$max) if ref($val) eq 'SCALAR';
$val < $min ? $min :
$val > $max ? $max :
$val;
}
sub bound { curb(@_) }
=head2 log10
$l=@$a-$o if @_<3;
croak if $l<0;
$l=@$a-$o if $l>@$a-$o;
@$a[$o..$o+$l-1];
}
=head2 min
Returns the smallest number in a list. Undef is ignored.
@lengths=(2,3,5,2,10,undef,5,4);
$shortest = min(@lengths); # returns 2
Note: The comparison operator is perls C<< < >>> which means empty strings is treated as C<0>, the number zero. The same goes for C<max()>, except of course C<< > >> is used instead.
min(3,4,5) # 3
min(3,4,5,undef) # 3
min(3,4,5,'') # returns the empty string
=head2 max
Returns the largest number in a list. Undef is ignored.
@heights=(123,90,134,undef,132);
$highest = max(@heights); # 134
=head2 mins
Just as L</min>, except for strings.
print min(2,7,10); # 2
print mins("2","7","10"); # 10
print mins(2,7,10); # 10
my $sim=String::Similarity::similarity($str,$s,$simnestlikest//0);
if($sim>=$simlikest){
($simnestlikest,$likest,$simlikest)=($simlikest,$s,$sim);
$idlikest=$id if defined$id;
}
elsif($sim>=$simnestlikest){
$simnestlikest=$sim;
}
}
my@ret=($simlikest,$likest);
@ret=(undef,undef) if $simnestlikest>0 and $simlikest-$simnestlikest<$mindiff;
@ret=(undef,undef) if $simlikest<$min;
@ret=(@ret,$simnestlikest,$simlikest,$likest);
push(@ret, $ret[0] ? $idlikest : undef) if defined $idlikest;
return wantarray?@ret:$ret[0];
}
=head2 sim_perm
B<Input:> Two strings
B<Output:> A number 0 - 1 indicating the maximum similarity between two strings tested
against all permutations of both strings split on C<< [\s,]+ >> and where the string
with most words (i.e. names) are cut to as many words as the one with least words.
=head2 pushsortstr
Same as pushsort except that the array is kept sorted alphanumerically (cmp) instead of numerically (<=>). See L</pushsort>.
pushsort @a, "abc"; # this...
push @a, "abc"; @a = sort @a; # is the same as this, but the former is faster if @a is large
=cut
#todo: use List::BinarySearch::XS 'binsearch_pos';
our $Pushsort_cmpsub=undef;
sub pushsort (\@@) {
my $ar=shift;
#not needed but often faster
if(!defined $Pushsort_cmpsub and @$ar+@_<100){ #hm speedup?
@$ar=(sort {$a<=>$b} (@$ar,@_));
return 0+@$ar;
}
for my $v (@_){
}
splice @$ar, binsearch($v,$ar,1,$Pushsort_cmpsub)+1, 0, $v;
}
0+@$ar
}
sub pushsortstr(\@@){ local $Pushsort_cmpsub=sub{$_[0]cmp$_[1]}; pushsort(@_) } #speedup: copy sub pushsort
=head2 binsearch
Returns the position of an element in a numerically sorted array. Returns undef if the element is not found.
B<Input:> Two, three or four arguments
B<First argument:> the element to find. Usually a number.
B<Second argument:> a reference to the array to search in. The array
should be sorted in ascending numerical order (se exceptions below).
B<Third argument:> Optional. Default false.
If true, whether result I<not found> should return undef or a fractional position.
If the third argument is false binsearch returns undef if the element is not found.
If the third argument is true binsearch returns 0.5 plus closest position below the searched value.
Returns C< last position + 0.5 > if the searched element is greater than all elements in the sorted array.
Returns C< -0.5 > if the searched element is less than all elements in the sorted array.
Fourth argument: Optional. Default C<< sub { $_[0] <=> $_[1] } >>.
If present, the fourth argument is either:
=item * a code-ref that alters the way binsearch compares two elements, default is C<< sub{$_[0]<=>$_[1]} >>
=item * a string that works as a hash key (column name), see example below
=back
B<Examples:>
binsearch(10,[5,10,15,20]); # 1
binsearch(10,[20,15,10,5],undef,sub{$_[1]<=>$_[0]}); # 2 search arrays sorted numerically in opposite order
binsearch("c",["a","b","c","d"],undef,sub{$_[0]cmp$_[1]}); # 2 search arrays sorted alphanumerically
binsearchstr("b",["a","b","c","d"]); # 1 search arrays sorted alphanumerically
my @data=( map { {num=>$_, sqrt=>sqrt($_), square=>$_**2} }
grep !$_%7, 1..1000000 );
my $i = binsearch( {num=>913374}, \@data, undef, sub {$_[0]{num} <=> $_[1]{num}} );
my $i = binsearch( {num=>913374}, \@data, undef, 'num' ); #same as previous line
my $found_hashref = defined $i ? $data[$i] : undef;
=head2 binsearchstr
Same as binsearch except that the arrays is sorted alphanumerically
(cmp) instead of numerically (<=>) and the searched element is a
string, not a number. See L</binsearch>.
=cut
our $Binsearch_steps;
our $Binsearch_maxsteps=100;
sub binsearch {
my($search,$aref,$insertpos,$cmpsub)=@_; #search pos of search in array
croak "binsearch did not get arrayref as second arg" if ref($aref) ne 'ARRAY';
croak "binsearch got fourth arg which is not a code-ref" if defined $cmpsub and ref($cmpsub) and ref($cmpsub) ne 'CODE';
if(defined $cmpsub and !ref($cmpsub)){
my $key=$cmpsub;
$cmpsub = sub{ $_[0]{$key} <=> $_[1]{$key} };
}
return $insertpos ? -0.5 : undef if !@$aref;
my($min,$max)=(0,$#$aref);
$Binsearch_steps=0;
while (++$Binsearch_steps <= $Binsearch_maxsteps) {
my $middle=int(($min+$max+0.5)/2);
my $middle_value=$$aref[$middle];
#croak "binsearch got non-sorted array" if !$cmpsub and $$aref[$min]>$$aref[$min]
# or $cmpsub and &$cmpsub($$aref[$min],$$aref[$min])>0;
if( !$cmpsub and $search < $middle_value
or $cmpsub and &$cmpsub($search,$middle_value) < 0 ) { #print "<\n";
$max=$min, next if $middle == $max and $min != $max;
return $insertpos ? $middle-0.5 : undef if $middle == $max;
$max=$middle;
}
elsif( !$cmpsub and $search > $middle_value
or $cmpsub and &$cmpsub($search,$middle_value) > 0 ) { #print ">\n";
$min=$max, next if $middle == $min and $max != $min;
return $insertpos ? $middle+0.5 : undef if $middle == $min;
$min=$middle;
}
else { #print "=\n";
return $middle;
}
}
croak "binsearch exceded $Binsearch_maxsteps steps";
}
sub binsearchfast { # binary search routine finds index just below value
=head2 egrep
Extended grep.
Works like L<grep> but with more insight: local vars $i, $n, $prev, $next, $prevr and $nextr are available:
$i is the current index, starts with 0, ends with the length of the input array minus one
$n is the current element number, starts with 1, $n = $i + 1
$prev is the previous value (undef if current is first)
$next is the next value (undef if current is last)
$prevr is the previous value, rotated so that the previous of the first element is the last element
$nextr is the next value, rotated so that the next of the last element is the first element
$_ is the current value, just as with Perls built-in grep
my @a = (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20); # 1..20
my @r = egrep { $_ % 3 == 0 } @a; # @r is 3, 6, 9, 12, 15, 18. Plain grep could have been used here
my @r = egrep { $i==1 or $next==12 or $prev==14 } @a; # @r is now 2, 11, 15
=cut
sub egrep (&@) {
my($code,$i,$package)=(shift,-1,(caller)[0]);
my %h=map{($_=>"${package}::$_")}qw(i n prev next prevr nextr);
no strict 'refs';
grep {
#no strict 'refs'; #not here! "no" not allowed in expression in perl5.16
local ${$h{i}} = ++$i;
local ${$h{n}} = $i+1;
local ${$h{prev}} = $i>0?$_[$i-1]:undef;
local ${$h{next}} = $i<$#_?$_[$i+1]:undef;
local ${$h{prevr}} = $_[$i>0?$i-1:$#_];
local ${$h{nextr}} = $_[$i<$#_?$i+1:0];
&$code;
}
@_;
}
=head2 eqarr
B<Input:> Two or more references to arrays.
B<Output:> True (1) or false (0) for whether or not the arrays are numerically I<and> alphanumerically equal.
Comparing each element in each array with both C< == > and C< eq >.
Examples:
eqarr([1,2,3],[1,2,3],[1,2,3]); # 1 (true)
eqarr([1,2,3],[1,2,3],[1,2,4]); # 0 (false)
eqarr([1,2,3],[1,2,3,4]); # undef (different size, false)
eqarr([1,2,3]); # croak (should be two or more arrays)
eqarr([1,2,3],1,2,3); # croak (not arraysrefs)
=cut
sub eqarr {
my @arefs=@_;
croak if @arefs<2;
ref($_) ne 'ARRAY' and croak for @arefs;
@{$arefs[0]} != @{$arefs[$_]} and return undef for 1..$#arefs;
my $ant;
for my $ar (@arefs[1..$#arefs]){
for(0..@$ar-1){
++$ant and $ant>100 and croak ">100"; #TODO: feiler ved sammenligning av to tabeller > 10000(?) tall
return 0 if $arefs[0][$_] ne $$ar[$_]
or $arefs[0][$_] != $$ar[$_];
}
}
return 1;
W=>['words'] )
=head2 parta
Like L<parth> but returns an array of lists where the predicate returns an index number.
my @a = parta { length } qw/These are the words of this array/;
Result:
@a = ( undef, undef, ['of'], ['are','the'], ['this'], ['These','words','array'] )
Two undefs at first (index positions 0 and 1) since there are no words of length 0 or 1 in the input array.
=cut
sub part (&@) { my($c,@r)=(shift,[],[]); push @{ $r[ &$c?0:1 ] }, $_ for @_; @r }
sub parth (&@) { my($c,%r)=(shift); push @{ $r{ &$c } }, $_ for @_; %r }
sub parta (&@) { my($c,@r)=(shift); push @{ $r[ &$c ] }, $_ for @_; @r }
#sub mapn (&$@) { ... } like map but @_ contains n elems at a time, n=1 is map
=head2 refa
my $ref_to_hash_of_arrays = { alice=>[1,2,3], bob=>[2,4,8], eve=>[10,100,1000] };
my $ref_to_hash_of_hashes = { alice=>{a=>22,b=>11}, bob=>{a=>33,b=>66} };
print "aa" if refaa($ref_to_array_of_arrays); #true
print "ah" if refah($ref_to_array_of_hashes); #true
print "ha" if refha($ref_to_hash_of_arrays); #true
print "hh" if refhh($ref_to_hash_of_hashes); #true
=cut
sub refa { ref($_[0]) eq 'ARRAY' ? 1 : ref($_[0]) ? 0 : undef }
sub refh { ref($_[0]) eq 'HASH' ? 1 : ref($_[0]) ? 0 : undef }
sub refs { ref($_[0]) eq 'SCALAR' ? 1 : ref($_[0]) ? 0 : undef }
sub refaa { ref($_[0]) eq 'ARRAY' ? refa($_[0][0]) : ref($_[0]) ? 0 : undef }
sub refah { ref($_[0]) eq 'ARRAY' ? refh($_[0][0]) : ref($_[0]) ? 0 : undef }
sub refha { ref($_[0]) eq 'HASH' ? refa((values%{$_[0]})[0]) : ref($_[0]) ? 0 : undef }
sub refhh { ref($_[0]) eq 'HASH' ? refh((values%{$_[0]})[0]) : ref($_[0]) ? 0 : undef }
=head2 pushr
=head2 popr
=head2 shiftr
=head2 unshiftr
my $i=0;
my @piles = parta {$i++/3} @list; # same as above pile(3, @list)
=cut
sub pile { my $size=shift; my @r; for (@_){ push@r,[] if !@r or 0+@{$r[-1]}>=$size; push @{$r[-1]}, $_ } @r }
=head2 aoh2sql
my @oceania=(
{Area=>undef, Capital=>'Pago Pago', Code=>'AS', Name=>'American Samoa', Population=>54343},
{Area=>7686850, Capital=>'Canberra', Code=>'AU', Name=>'Australia', Population=>22751014},
{Area=>undef, Capital=>'West Island', Code=>'CC', Name=>'Cocos (Keeling) Islands', Population=>596},
{Area=>240, Capital=>'Avarua', Code=>'CK', Name=>'Cook Islands', Population=>9838},
{Area=>undef, Capital=>'Flying Fish Cove', Code=>'CX', Name=>'Christmas Island', Population=>1530},
{Area=>18270, Capital=>'Suva', Code=>'FJ', Name=>'Fiji', Population=>909389},
{Area=>702, Capital=>'Palikir', Code=>'FM', Name=>'Micronesia, Federated States of', Population=>105216},
{Area=>549, Capital=>'Hagatna (Agana)', Code=>'GU', Name=>'Guam', Population=>161785},
{Area=>811, Capital=>'Tarawa', Code=>'KI', Name=>'Kiribati', Population=>105711},
{Area=>181.3, Capital=>'Majuro', Code=>'MH', Name=>'Marshall Islands', Population=>72191},
{Area=>19060, Capital=>'Noumea', Code=>'NC', Name=>'New Caledonia', Population=>271615},
{Area=>undef, Capital=>'Kingston', Code=>'NF', Name=>'Norfolk Island', Population=>2210},
{Area=>21, Capital=>'Yaren District', Code=>'NR', Name=>'Nauru', Population=>9540},
{Area=>260, Capital=>'Alofi', Code=>'NU', Name=>'Niue', Population=>1190},
{Area=>268680, Capital=>'Wellington', Code=>'NZ', Name=>'New Zealand', Population=>4438393},
{Area=>undef, Capital=>'Papeete', Code=>'PF', Name=>'French Polynesia', Population=>282703},
{Area=>462840, Capital=>'Port Moresby', Code=>'PG', Name=>'Papua New Guinea', Population=>6672429},
{Area=>undef, Capital=>'Adamstown', Code=>'PN', Name=>'Pitcairn', Population=>48},
{Area=>458, Capital=>'Melekeok', Code=>'PW', Name=>'Palau', Population=>21265},
{Area=>28450, Capital=>'Honiara', Code=>'SB', Name=>'Solomon Islands', Population=>622469},
{Area=>undef, Capital=>undef, Code=>'TK', Name=>'Tokelau', Population=>1337},
{Area=>26, Capital=>'Funafuti', Code=>'TV', Name=>'Tuvalu', Population=>10869},
{Area=>12200, Capital=>'Port-Vila', Code=>'VU', Name=>'Vanuatu', Population=>272264},
{Area=>undef, Capital=>'Mata-Utu', Code=>'WF', Name=>'Wallis and Futuna', Population=>15500},
{Area=>2944, Capital=>'Apia', Code=>'WS', Name=>'Samoa (Western)', Population=>197773}
);
print aoh2sql(\@oceania,{
name=>'country',
drop=>2,
#number=>'numeric', #default
#varchar=>'varchar', #default, change to varchar2 if Oracle
#date=>'date', #default, perhaps change to 'timestamp with time zone' if postgres
#varchar_maxlen=>4000, #default, 4000 (used to be?) is max in Oracle
sub aoh2xls { croak "Not implemented yet: aoh2xls" }
=head1 STATISTICS
=head2 sum
Returns the sum of a list of numbers. Undef is ignored.
print sum(1,3,undef,8); # 12
print sum(1..1000); # 500500
print sum(undef); # undef
=cut
sub sum { my $sum; no warnings; defined($_) and $sum+=$_ for @_; $sum }
=head2 avg
Returns the I<average> number of a list of numbers. That is C<sum / count>
print avg( 2, 4, 9); # 5 (2+4+9) / 3 = 5
Pass by reference: If one argument is given and it is a reference to an array,
this array is taken as the list of numbers. This mode is about twice as fast
for 10000 numbers or more. It most likely also saves memory.
=cut
sub avg {
my($sum,$n,@a)=(0,0);
no warnings;
if( @_==0 ) { return undef }
if( @_==1 and ref($_[0]) eq 'ARRAY' ){ @a=grep defined,@{$_[0]} }
else { @a=grep defined,@_ }
if( @a==0 ) { return undef }
$sum+=$_ for @a;
return $sum/@a
}
=head2 geomavg
Returns the I<geometric average> (a.k.a I<geometric mean>) of a list of numbers.
print geomavg(10,100,1000,10000,100000); # 1000
print 0+ (10*100*1000*10000*100000) ** (1/5); # 1000 same thing
two stddevs 95%. Normal distributions are sometimes called Gauss curves
or Bell shapes. L<https://en.wikipedia.org/wiki/Standard_deviation>
stddev(4,5,6,5,6,4,3,5,5,6,7,6,5,7,5,6,4) # = 1.0914103126635
avg(@testscores) + stddev(@testscores) # = the score for one stddev above avg, 115
avg(@testscores) - stddev(@testscores) # = the score for one stddev below avg, 85
=cut
sub stddev {
return undef if @_==0;
return stddev(\@_) if @_>0 and !ref($_[0]);
my $ar=shift;
return undef if @$ar==0;
return 0 if @$ar==1;
my $sumx2; $sumx2 += $_*$_ for @$ar;
my $sumx; $sumx += $_ for @$ar;
sqrt( (@$ar*$sumx2-$sumx*$sumx)/(@$ar*(@$ar-1)) );
}
=head2 rstddev
Relative stddev = stddev / avg
Generates random passwords.
B<Input:> 0-n args
* First arg: length of password(s), default 8
* Second arg: number of passwords, default 1
* Third arg: string containing legal chars in password, default A-Za-z0-9,-./&%_!
* Fourth to n'th arg: list of requirements for passwords, default if the third arg is false/undef (so default third arg is used) is:
sub{/^[a-zA-Z0-9].*[a-zA-Z0-9]$/ and /[a-z]/ and /[A-Z]/ and /\d/ and /[,-.\/&%_!]/}
...meaning the password should:
* start and end with: a letter a-z (lower- or uppercase) or a digit 0-9
* should contain at least one char from each of the groups lower, upper, digit and special char
To keep the default requirement-sub but add additional ones just set the fourth arg to false/undef
and add your own requirements in the fifth arg and forward (examples below). Sub pwgen uses perls
own C<rand()> internally.
C<< $Acme::Tools::Pwgen_max_sec >> and C<< $Acme::Tools::Pwgen_max_trials >> can be set to adjust for how long
pwgen tries to find a password. Defaults for those are 0.01 and 10000.
Whenever one of the two limits is reached, a first generates a croak.
Examples:
my $pw=pwgen(); # a random 8 chars password A-Z a-z 0-9 ,-./&%!_ (8 is default length)
B<Output:> array of hashes
Transforms an array of arrays (arrayrefs) to an array of hashes (hashrefs).
Example:
my @h = a2h( ['Name', 'Age', 'Gender'], #1st row become keys
['Alice', 20, 'F'],
['Bob', 30, 'M'],
['Eve', undef, 'F'] );
Result array @h:
(
{Name=>'Alice', Age=>20, Gender=>'F'},
{Name=>'Bob', Age=>30, Gender=>'M'},
{Name=>'Eve', Age=>undef, Gender=>'F'},
);
=head2 h2a
B<Input:> array of hashes
B<Output:> array of arrays
Opposite of L</a2h>
#AF_INET constant in the Socket or the IO::Socket package.
return $IPADDR_memo{$ipnr} ||= gethostbyaddr(pack("C4",split("\\.",$ipnr)),2);
}
=head2 ipnum
C<ipnum()> does the opposite of C<ipaddr()>
Does an attempt of converting an IP address (hostname) to an IP number.
Uses DNS name servers via perls internal C<gethostbyname()>.
Return empty string (undef) if unsuccessful.
print ipnum("www.uio.no"); # prints 129.240.13.152
Does internal memoization via the hash C<%Acme::Tools::IPNUM_memo>.
=cut
our %IPNUM_memo;
sub ipnum {
my $ipaddr=shift;
#croak "No $ipaddr" if !length($ipaddr);
return $IPNUM_memo{$ipaddr} if exists $IPNUM_memo{$ipaddr};
my $h=gethostbyname($ipaddr);
#croak "No ipnum for $ipaddr" if !$h;
return if !defined $h;
my $ipnum = join(".",unpack("C4",$h));
$IPNUM_memo{$ipaddr} = $ipnum=~/^(\d+\.){3}\d+$/ ? $ipnum : undef;
return $IPNUM_memo{$ipaddr};
}
our $Ipnum_errmsg;
our $Ipnum;
sub ipnum_ok {
my $ipnum=shift;
$Ipnum=undef;
eval{
die "malformed ipnum $ipnum\n" if not $ipnum=~/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
die "invalid ipnum $ipnum\n" if grep$_>255,$1,$2,$3,$4;
$Ipnum=$1*256**3 + $2*256**2 + $3*256 + $4;
};
my$r=($Ipnum_errmsg=$@) ? 0 : 1;
$r
}
our $Iprange_errmsg;
our $Iprange_start;
sub iprange_ok {
my $iprange=shift;
$Iprange_start=undef;
my($r,$m);
eval{
die "malformed iprange $iprange\n" if not $iprange=~m|^(\d+)\.(\d+)\.(\d+)\.(\d+)(?:/(\d+))$|;
die "iprange part should be 0-255\n" if grep$_<0||$_>255,$1,$2,$3,$4;
die "iprange mask should be 0-32\n" if defined$5 and $5>32;
($r,$m)=($1*256**3+$2*256**2+$3*256+$4,32-$5);
};
return if $Iprange_errmsg=$@;
my $x=$r>>$m<<$m;
return if $r!=$x and $Iprange_errmsg=sprintf("need zero in last %d bits, should be %d.%d.%d.%d/%d",
Note: Chomp is done on each line. That is, any newlines (C<< \n >>) will be removed.
If C<@lines> is non-empty, this will be lost.
Sub readfile is context aware. If an array is expected it returns an array of the lines without a trailing C<< \n >>.
The last example can be rewritten:
for(readfile('filnavn.txt')){
...
}
With two input arguments, nothing (undef) is returned from C<readfile()>.
Automatic decompression:
my $txt = readfile('file.txt.gz'); #uses /bin/gunzip to decompress content
Extentions C<.gz>, C<.bz2> and C<.xz> are recognized for decompression. See also C<writefile()> and C<openstr()>.
=cut
#http://blogs.perl.org/users/leon_timmermans/2013/05/why-you-dont-need-fileslurp.html
sub basename { my($f,$s)=(@_,'');$s=quotemeta($s)if!ref($s);$f=~m,^(.*/)?([^/]*?)($s)?$,;$2 }
sub dirname { $_[0]=~m,^(.*)/,;defined($1) && length($1) ? $1 : '.' }
sub username { (getpwuid($<))[0] }
=head2 wipe
Deletes a file by "wiping" it on the disk. Overwrites the file before deleting. (May not work properly on SSDs)
B<Input:>
* Arg 1: A filename
* Optional arg 2: number of times to overwrite file. Default is 3 if omitted, 0 or undef
* Optional arg 3: keep (true/false), wipe() but no delete of file
B<Output:> Same as the C<unlink()> (remove file): 1 for success, 0 or false for failure.
See also: L<https://www.google.com/search?q=wipe+file>, L<http://www.dban.org/>
=cut
sub wipe {
my($file,$times,$keep)=@_;
use integer;#heltallsdivisjon
my $y=$year+4800-(14-$month)/12;
my $j=$day+(153*($month+(14-$month)/12*12-3)+2)/5+365*$y+$y/4-$y/100+$y/400-32045;
my $d=($j+31741-$j%7)%146097%36524%1461;
return (($d-$d/1460)%365+$d/1460)/7+1;
}
#perl -MAcme::Tools -le 'print "$_ ".tms($_."0501","day",1) for 2015..2026'
sub tms {
return undef if @_>1 and not defined $_[1]; #time=undef => undef
if(@_==1){
my @lt=localtime();
$_[0] eq 'YYYY' and return 1900+$lt[5];
$_[0] eq 'YYYYMMDD' and return sprintf("%04d%02d%02d",1900+$lt[5],1+$lt[4],$lt[3]);
$_[0] =~ $Re_isnum and @lt=localtime($_[0]) and return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]);
}
my($format,$time,$is_date)=@_;
$time=time_fp() if !defined$time;
($time,$format)=($format,$time) if @_>=2 and $format=~/^[\d+\:\-\.]+$/; #swap /hm/
my @lt=localtime($time);
our %Eta;
our $Eta_forgetfulness=2;
sub eta {
my($id,$pos,$end,$time_fp)=( @_==2 ? (join(";",caller()),@_) : @_ );
$time_fp||=time_fp();
my $a=$Eta{$id}||=[];
push @$a, [$pos,$time_fp];
@$a=@$a[map$_*2,0..@$a/2] if @$a>40; #hm 40
splice(@$a,-2,1) if @$a>1 and $$a[-2][0]==$$a[-1][0]; #same pos as last
return undef if @$a<2;
my @eta;
for(2..@$a){
push @eta, $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-$_][1])/($$a[-1][0]-$$a[-$_][0]);
}
my($sum,$sumw,$w)=(0,0,1);
for(@eta){
$sum+=$w*$_;
$sumw+=$w;
$w/=$Eta_forgetfulness;
}
=head1 OTHER
=head2 nvl
The I<no value> function (or I<null value> function)
C<nvl()> takes two or more arguments. (Oracles nvl-function take just two)
Returns the value of the first input argument with length() > 0.
Return I<undef> if there is no such input argument.
In perl 5.10 and perl 6 this will most often be easier with the C< //
> operator, although C<nvl()> and C<< // >> treats empty strings C<"">
differently. Sub nvl here considers empty strings and undef the same.
=cut
sub nvl {
return $_[0] if defined $_[0] and length($_[0]) or @_==1;
return $_[1] if @_==2;
return nvl(@_[1..$#_]) if @_>2;
return undef;
}
=head2 decode_num
See L</decode>.
=head2 decode
C<decode()> and C<decode_num()> works just as Oracles C<decode()>.
returned if decode() finds an equal string or number.
In the above example: 123 maps to 3, 124 maps to 4 and the last argument $a is returned elsewise.
More examples:
my $a=123;
print decode($a, 123=>3, 214=>7, $a); # also 3, note that => is synonym for , (comma) in perl
print decode($a, 122=>3, 214=>7, $a); # prints 123
print decode($a, 123.0 =>3, 214=>7); # prints 3
print decode($a, '123.0'=>3, 214=>7); # prints nothing (undef), no last argument default value here
print decode_num($a, 121=>3, 221=>7, '123.0','b'); # prints b
Sort of:
decode($string, %conversion, $default);
The last argument is returned as a default if none of the keys in the keys/value-pairs matched.
A more perl-ish and often faster way of doing the same:
B<Input:>
A credit card number. Can contain non-digits, but they are removed internally before checking.
B<Output:>
Something true or false.
Or more accurately:
Returns C<undef> (false) if the input argument is missing digits.
Returns 0 (zero, which is false) is the digits is not correct according to the LUHN algorithm.
Returns 1 or the name of a credit card company (true either way) if the last digit is an ok control digit for this ccn.
The name of the credit card company is returned like this (without the C<'> character)
Returns (wo '') Starts on Number of digits
------------------------------ ------------------------ ----------------
'MasterCard' 51-55 16
digit and subtract 9 if the product is greater than 9. Add up all the
even digits as well as the doubled-odd digits, and the result must be
a multiple of 10 or it's not a valid card. If the card has an odd
number of digits, perform the same addition doubling the even numbered
digits instead."
B<Input:> A KID-nummer. Must consist of digits 0-9 only, otherwise a die (croak) happens.
B<Output:>
- Returns undef if the input argument is missing.
- Returns 0 if the control digit (the last digit) does not satify the LUHN/mod-10 algorithm.
- Returns 1 if ok
B<See also:> L</ccn_ok>
=cut
sub KID_ok {
croak "Non-numeric argument" if $_[0]=~/\D/;
my @k=split//,shift or return undef;
my $s;$s+=pop(@k)+[qw/0 2 4 6 8 1 3 5 7 9/]->[pop@k] while @k;
$s%10==0?1:0;
}
=head2 range
B<Input:>
name. This is useful in "fuzzy" name searches with
L<String::Similarity> if you can not be certain what is first, middle
and last names. In foreign or unfamiliar names it can be difficult to
know that.
=cut
#TODO: see t/test_perm.pl and t/test_perm2.pl
sub permutations {
my $code=ref($_[0]) eq 'CODE' ? shift() : undef;
$code and @_<6 and return map &$code(@$_),permutations(@_);
return [@_] if @_<2;
return ([@_[0,1]],[@_[1,0]]) if @_==2;
return ([@_[0,1,2]],[@_[0,2,1]],[@_[1,0,2]],
[@_[1,2,0]],[@_[2,0,1]],[@_[2,1,0]]) if @_==3;
return ([@_[0,1,2,3]],[@_[0,1,3,2]],[@_[0,2,1,3]],[@_[0,2,3,1]],
Options to sort differently and show sums and percents are available. (...MORE DOC ON THAT LATER...)
See also L<Data::Pivot>
=cut
sub pivot {
my($tabref,@vertikalefelt)=@_;
my %opt=ref($vertikalefelt[-1]) eq 'HASH' ? %{pop(@vertikalefelt)} : ();
my $opt_sum=1 if $opt{sum};
my $opt_pro=exists $opt{prosent}?$opt{prosent}||0:undef;
my $sortsub = $opt{'sortsub'} || \&_sortsub;
my $sortsub_bortover = $opt{'sortsub_bortover'} || $sortsub;
my $sortsub_nedover = $opt{'sortsub_nedover'} || $sortsub;
#print serialize(\%opt,'opt');
#print serialize(\$opt_pro,'opt_pro');
my $antned=0+@vertikalefelt;
my $bakerst=-1+@{$$tabref[0]};
my(%h,%feltfinnes,%sum);
#print "Bakerst<$bakerst>\n";
for(@$tabref){
$feltfinnes{"%$felt"}++ if $opt_pro;
}
my @feltfinnes = sort $sortsub_bortover keys%feltfinnes;
push @feltfinnes, "Sum" if $opt_sum;
my @t=([@vertikalefelt,map{replace($_,$;,"\n")}@feltfinnes]);
#print serialize(\@feltfinnes,'feltfinnes');
#print serialize(\%h,'h');
#print "H = ".join(", ",sort _sortsub keys%h)."\n";
for my $rad (sort $sortsub_nedover keys(%h)){
my @rad=(split($;,$rad),
map { defined($_)?$_:exists$opt{undefined}?$opt{undefined}:undef }
map {
if(/^\%/ and defined $opt_pro){
my $sum=$h{$rad}{Sum};
my $verdi=$h{$rad}{$_};
if($sum!=0){
defined $verdi
?sprintf("%*.*f",3+1+$opt_pro,$opt_pro,100*$verdi/$sum)
:$verdi;
}
else{
Returns a data structure as a string. See also C<Data::Dumper>
(serialize was created long time ago before Data::Dumper appeared on
CPAN, before CPAN even...)
B<Input:> One to four arguments.
First argument: A reference to the structure you want.
Second argument: (optional) The name the structure will get in the output string.
If second argument is missing or is undef or '', it will get no name in the output.
Third argument: (optional) The string that is returned is also put
into a created file with the name given in this argument. Putting a
C<< > >> char in from of the filename will append that file
instead. Use C<''> or C<undef> to not write to a file if you want to
use a fourth argument.
Fourth argument: (optional) A number signalling the depth on which newlines is used in the output.
The default is infinite (some big number) so no extra newlines are output.
B<Output:> A string containing the perl-code definition that makes that data structure.
The input reference (first input argument) can be to an array, hash or a string.
Those can contain other refs and strings in a deep data structure.
Limitations:
$a = 'test';
@b = (1,2,3);
%c = (1=>2, 2=>3, 3=>5, 4=>7, 5=>11);
%d = (1=>2, 2=>3, 3=>\5, 4=>7, 5=>11, 6=>[13,17,19,{1,2,3,'asdf\'\\\''}],7=>'x');
print serialize(\$a,'a');
print serialize(\@b,'tab');
print serialize(\%c,'c');
print serialize(\%d,'d');
print serialize(\("test'n roll",'brb "brb"'));
print serialize(\%d,'d',undef,1);
Prints accordingly:
$a='test';
@tab=('1','2','3');
%c=('1','2','2','3','3','5','4','7','5','11');
%d=('1'=>'2','2'=>'3','3'=>\'5','4'=>'7','5'=>'11','6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}]);
('test\'n roll','brb "brb"');
%d=('1'=>'2',
'2'=>'3',
(Every 80th or whatever C<$Acme::Tools::Dserialize_width> contains)
=cut
our $Dserialize_width=80;
sub _kallstack { my $tilbake=shift||0; my @c; my $ret; $ret.=serialize(\@c,"caller$tilbake") while @c=caller(++$tilbake); $ret }
sub dserialize{join "\n",serialize(@_)=~/(.{1,$Dserialize_width})/gs}
sub serialize {
no warnings;
my($r,$name,$filename,$level)=@_;
my @r=(undef,undef,($level||0)-1);
if($filename){
open my $fh, '>', $filename or croak("FEIL: could not open file $filename\n" . _kallstack());
my $ret=serialize($r,$name,undef,$level);
print $fh "$ret\n1;\n";
close($fh);
return $ret;
}
if(ref($r) eq 'SCALAR'){
return "\$$name=".serialize($r,@r).";\n" if $name;
return "undef" unless defined $$r;
my $ret=$$r;
$ret=~s/\\/\\\\/g;
$ret=~s/\'/\\'/g;
return "'$ret'";
}
elsif(ref($r) eq 'ARRAY'){
return "\@$name=".serialize($r,@r).";\n" if $name;
my $ret="(";
for(@$r){
$ret.=serialize(\$_,@r).",";
times for next cmd: M<number> (i.e. M24a inserts 24 a's)
(TODO: alfa...and more docs needed)
=cut
our $Edcursor;
sub ed {
my($s,$cs,$p,$buf)=@_; #string, commands, point (or cursor)
return $$s=ed($$s,$cs,$p,$buf) if ref($s);
my($sh,$cl,$m,$t,@m)=(0,0,0,undef);
while(length($cs)){
my $n = 0;
my $c = $cs=~s,^(M\d+|M.|""|".+?"|S.+?R|\\.|.),,s ? $1 : die;
$p = curb($p||0,0,length($s));
if(defined$t){$cs="".($c x $t).$cs;$t=undef;next}
my $add=sub{substr($s,$p,0)=$_[0];$p+=length($_[0])};
if ($c =~ /^([a-z0-9 ])/){ &$add($sh^$cl?uc($1):$1); $sh=0 }
elsif($c =~ /^"(.+)"$/) { &$add($1) }
elsif($c =~ /^\\(.)/) { &$add($1) }
elsif($c =~ /^S(.+)R/) { my $i=index($s,$1,$p);$p=$i+length($1) if $i>=0 }
elsif($c =~ /^M(\d+)/) { $t=$1; next }
elsif($c eq 'F') { $p++ }
elsif($c eq 'B') { $p-- }
elsif($c eq 'A') { $p-- while $p>0 and substr($s,$p-1,2)!~/^\n/ }
elsif($c eq 'E') { substr($s,$p)=~/(.*)/ and $p+=length($1) }
}
=head2 changed
while(<>){
my $line=$_;
print "\n" if changed(/^\d\d\d\d-\d\d-(\d\d)/);
print "\n" if changed(substr($_,8,2));
}
Returns undef, 0 or 1. Undef if its the first time C<changed> is
called on that perl line. 0 if not the first time and the parameters
differ from the last call on that line. 1 if not the first time and
the parameters is the exact same as they where on the previous call on
that line of perl source code.
=cut
our %Changed_lastval;
sub changed {
my $now=join($;,@_);
my $key=join($;,caller());
my $e=exists $Changed_lastval{$key};
if($e){
my $last=$Changed_lastval{$key};
return 0 if defined $last and defined $now and $last eq $now
or !defined $last and !defined $now;
}
$Changed_lastval{$key}=$now;
return $e?1:undef;
}
#todo: sub unbless eller sub damn
#todo: ..se også: use Data::Structure::Util qw/unbless/;
#todo: ...og: Acme::Damn sin damn()
#todo? sub swap($$) http://www.idg.no/computerworld/article242008.ece
#todo? catal
#todo?
#void quicksort(int t, int u) int i, m; if (t >= u) return; swap(t, randint(t, u)); m = t; for (i = t + 1; i <= u; i++) if (x[i] < x[t]) swap(++m, i); swap(t, m) quicksort(t, m-1); quicksort(m+1, u);
-e $f and
-f$f ? 'file' # -f File is a plain file.
:-d$f ? 'dir' # -d File is a directory.
:-l$f ? 'symlink' # -l File is a symbolic link.
:-p$f ? 'pipe' # -p File is a named pipe (FIFO), or Filehandle is a pipe.
:-S$f ? 'socket' # -S File is a socket.
:-b$f ? 'blockfile' # -b File is a block special file.
:-c$f ? 'charfile' # -c File is a character special file.
:-t$f ? 'ttyfile' # -t Filehandle is opened to a tty.
: ''
or undef;
}
sub ext2mime {
my $ext=shift(); #or filename
#http://www.sitepoint.com/web-foundations/mime-types-complete-list/
croak "todo: ext2mime not yet implemented";
#return "application/json";#feks
}
sub base64 ($;$) { #
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' );
t/02_general.t view on Meta::CPAN
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');
t/02_general.t view on Meta::CPAN
#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' );
t/02_general.t view on Meta::CPAN
#--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
}
t/02_general.t view on Meta::CPAN
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);
t/04_resolve.t view on Meta::CPAN
ok(resolve($f,0,2) == 7 ,'second solution, start 2');
ok(resolve($f,0,2) == 7 ,'second solution, start 2');
ok($Resolve_iterations > 1 ,"iterations=$Resolve_iterations");
ok($Resolve_last_estimate == 7 ,"last_estimate=$Resolve_last_estimate (should be 7)");
eval{ resolve(sub{1}) }; # 1=0
ok($@=~/Div by zero/);
ok(!defined $Resolve_iterations);
ok(!defined $Resolve_last_estimate);
my $c;
eval{$e=resolve(sub{$c++; sleep_fp(0.02); $_**2 - 4*$_ -21},0,.02,undef,undef,0.05)};
deb "x=$e, est=$Resolve_last_estimate, iters=$Resolve_iterations, time=$Resolve_time, c=$c -- $@\n";
ok($@=~/Could not resolve, perhaps too little time given/,'ok $@');
my$no=0;sub isr{is( ($e=$_[0]), $_[1], "r".(++$no).": e=$e, iters=$Resolve_iterations")}
isr( sprintf("%.12f",resolve(sub{3*$_ + $_**4 - 12})), '1.632498783713' ); #*)
isr( log(resolve(sub{ $_**log($_)-$_},0,2)), 1);
isr( resolve(sub{$_**2+7*$_-60},0,1), 5);
isr( resolve_equation("x^2+7x-60"), 5);
#*) http://www.quickmath.com/webMathematica3/quickmath/equations/solve/basic.jsp#c=solve_stepssolveequation&v1=3x%2Bx%5E4-12%3D0&v2=x
t/09_rank_pushsort_binsearch.t view on Meta::CPAN
my $cmpsub=sub{$_[0] <=> $_[1]};
ok( binsearch(1,[1,2,5],0,$cmpsub)==0 );
ok( binsearch(2,[1,2,5],0,$cmpsub)==1 );
ok( binsearch(5,[1,2,5],0,$cmpsub)==2 );
ok( ($bs=binsearch(6,[1,2,5],1,$cmpsub))==2.5, "after $bs");
ok( ($bs=binsearch(3,[1,2,5],1,$cmpsub))==1.5, $bs);
ok( ($bs=binsearch(1.4,[1,2,5],1,$cmpsub))==0.5, $bs);
ok( ($bs=binsearch(0,[1,2,5],1,$cmpsub))==-0.5,"before $bs");
ok( binsearch(10,[20,15,10,5],undef,sub{$_[1]<=>$_[0]}) == 2); # 2 search arrays sorted numerically in opposite order
ok( binsearch("c",["a","b","c","d"],undef,sub{$_[0]cmp$_[1]}) == 2); # 2 search arrays sorted alphanumerically
ok( binsearchstr("b",["a","b","c","d"]) == 1); # 1 search arrays sorted alphanumerically
my @data=( map { {num=>$_,sqrt=>sqrt($_), square=>$_**2} } grep !($_%7), 1..10000 );
my($i1,$i2) = ( binsearch( {num=>8883}, \@data, undef, sub {$_[0]{num} <=> $_[1]{num}} ),
binsearch( {num=>8883}, \@data, undef, 'num' ) );
ok( $i1==1268, 'binsearch i1');
ok( $i2==1268, 'binsearch i2' );
#ok( $data[$i1]{square}==78907689 );
ok( $Acme::Tools::Binsearch_steps == 10, 'binsearch 10 steps' );
#print "i=$i ".srlz(\$found,'f')."Binsearch_steps = $Acme::Tools::Binsearch_steps\n";
deb "--------------------------------------------------------------------------------eqarr\n";
ok( eqarr([1,2,3],[1,2,3],[1,2,3]) == 1 ,'eqarr 1');
ok( eqarr([1,2,3],[1,2,3],[1,2,4]) == 0 ,'eqarr 0');
ok( !defined(eqarr([1,2,3],[1,2,3,4])) ,'eqarr undef' );
ok( do{eval{eqarr([1,2,3])};$@} ,'eqarr croak 1');
ok( do{eval{eqarr([1,2,3],1,2,3)};$@} ,'eqarr croak 2');
deb "--------------------------------------------------------------------------------rank\n";
ok( rank(1,[20,30,10,15,40])==10 ,'rank 1');
ok( rank(2,[20,30,10,15,40])==15 ,'rank 2');
ok( rank(3,[20,30,10,15,40])==20 ,'rank 3');
ok( rank(4,[20,30,10,15,40])==30 ,'rank 4.1');
ok( rank(4,[20,30,10,15,40,10])==20 ,'rank 4.2');
t/11_part.t view on Meta::CPAN
my %h=parth { uc(substr($_,0,1)) } @words;
#warn serialize(\%h);
ok_ref( \%h,
{ T=>[qw/These the this/],
A=>[qw/are array/],
W=>[qw/words/],
O=>[qw/of/] }, 'parth');
my @a=parta { length } @words;
#warn serialize(\@a);
ok_ref( \@a, [undef,undef,['of'],['are','the'],['this'],['These','words','array']], 'parta' );
ok_ref( [pile(2, 1..9)], [[1,2],[3,4],[5,6],[7,8],[9]], 'pile 2' );
ok_ref( [pile(4, 1..9)], [[1,2,3,4],[5,6,7,8],[9]], 'pile 4' );
ok_ref( [pile(2)], [], 'pile empty' );
ok_ref( [pile2(4, 1..9)], [[1,2,3,4],[5,6,7,8],[9]], 'pile parta' );
sub pile2 {
my $size=shift;
my $i=0;
t/17_roman.t view on Meta::CPAN
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 31;
use Carp;
my %rom=(MCCXXXIV=>1234,MCMLXXI=>1971,IV=>4,VI=>6,I=>1,V=>5,X=>10,L=>50,C=>100,D=>500,M=>1000,CDXCVII=>497);
my$rom;ok( ($rom=int2roman($rom{$_})) eq $_, sprintf"int2roman %8d => %-10s %-10s",$rom{$_},$_,"($rom)") for sort keys%rom;
my$int;ok( ($int=roman2int($_)) eq $rom{$_}, sprintf"roman2int %-8s => %10d %10d",$_,$rom{$_},$int) for sort keys%rom;
ok( do{eval{roman2int("a")};$@=~/invalid/i}, "croaks ok" );
ok( roman2int("-MCCXXXIV")==-1234, 'negative ok');
ok( int2roman(0) eq '', 'zero');
ok( !defined(int2roman(undef)), 'undef');
ok( defined(int2roman("")) && !length(int2roman("")), 'empty');
my @n=(-100..4999);
my @err=grep roman2int(int2roman($_))!=$_, grep $_>100?$_%7==0:1, @n;
ok( @err==0, "all, not ok: ".(join(", ",@err)||'none') );
my @t=([time_fp(),join(" ",map int2roman($_) ,@n),time_fp()],
[time_fp(),join(" ",map int2roman_old($_),@n),time_fp()]);
ok( $t[0][1] eq $t[1][1] );
if($ENV{ATDEBUG}){
printf "Acme::Tools::int2roman - %.6fs\n",$t[0][2]-$t[0][0];
printf "17_roman.t/int2roman_old - %.6fs\n",$t[1][2]-$t[1][0];
}
sub int2roman_old {
my($n,@p)=(shift,[],[1],[1,1],[1,1,1],[1,2],[2],[2,1],[2,1,1],[2,1,1,1],[1,3],[3]);
!defined($n)? undef
: !length($n) ? ""
: int($n)!=$n ? croak"int2roman: $n is not an integer"
: $n==0 ? ""
: $n<0 ? "-".int2roman(-$n)
: $n>3999 ? "M".int2roman($n-1000)
: join'',@{[qw/I V X L C D M/]}[map{my$i=$_;map($_+5-$i*2,@{$p[$n/10**(3-$i)%10]})}(0..3)];
}
# make test
# perl Makefile.PL; make; perl -Iblib/lib t/18_pad.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 20;
for(
['rpad','gomle',9,undef,'gomle '],
['lpad','gomle',9,undef,' gomle'],
['rpad','gomle',9,'-','gomle----'],
['lpad','gomle',9,'+','++++gomle'],
['rpad','gomle',4,undef,'goml'],
['lpad','gomle',4,undef,'goml'],
['rpad','gomle',7,'xyz','gomlexy'],
['lpad','gomle',10,'xyz','xyzxygomle'],
['lpad','gomle',24,'-xyz','-xyz-xyz-xyz-xyz-xygomle' ],
['cpad','mat',5,undef,' mat '],
['cpad','mat',4,undef,'mat '],
['cpad','mat',6,undef,' mat '],
['cpad','mat',9,undef,' mat '],
['cpad','mat',5,'+','+mat+'],
['cpad','mat',4,'xyz','matx'],
['cpad','mat',5,'xyz','xmatx'],
['cpad','mat',6,'xyz','xmatxy'],
['cpad','mat',12,'xyz','xyzxmatxyzxy'],
['cpad','MMM',20,'xyz','xyzxyzxyMMMxyzxyzxyz'],
['cpad','MMMM',20,'xyzXYZ','xyzXYZxyMMMMxyzXYZxy'],
){
my($f,$s,$l,$p,$c,$r)=@$_;
my @a=defined$p?($s,$l,$p):($s,$l);
t/28_wipe.t view on Meta::CPAN
# make test
# perl Makefile.PL; make; perl -Iblib/lib t/28_wipe.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 3;
if($^O eq 'linux'){
my $f=tmp().'/acme-tools.wipe.tmp';
writefile($f,join(" ",map rand(),1..1000)); #system("ls -l $f");
my $ntrp=sub{length(gz(readfile($f).""))};
my $n=&$ntrp;
wipe($f,undef,1);
my $ratio=$n/&$ntrp;
ok($ratio>50 || !$INC{'Compress/Zlib.pm'}, "ratio $ratio > 50");
ok(-s$f>5e3);
wipe($f,1);
ok(!-e$f);
}
else{ ok(1) for 1..3 }
t/32_a2h_h2a.t view on Meta::CPAN
[qw( Make Model Sales Used )], #alphabetical colnames for tests below
[qw( Nissan Qashqai 17 47.22% )],
[qw( Nissan Leaf 19 52.78% )],
[qw( Tesla ModelS 8 100.00% )],
[qw( Toyota Avensis 7 12.50% )],
[qw( Toyota RAV 12 21.43% )],
[qw( Toyota Auris 18 32.14% )],
[qw( Toyota Prius 19 33.93% )],
[qw( Volvo XC90 4 22.22% )],
[qw( Volvo V40 14 77.78% )],
[qw( Hyundai Ionic 22 ), undef ],
);
# deb srlz(\@a,'a','',1);
my @h = a2h(@a); # deb srlz(\@h,'h','',1);
my @a2 = h2a(@h); # deb srlz(\@a2,'a2','',1);
ok_ref( \@h, [
{Make=>'Nissan', Model=>'Qashqai',Sales=>17,Used=>'47.22%'},
{Make=>'Nissan', Model=>'Leaf', Sales=>19,Used=>'52.78%'},
{Make=>'Tesla', Model=>'ModelS', Sales=>8, Used=>'100.00%'},
{Make=>'Toyota', Model=>'Avensis',Sales=>7, Used=>'12.50%'},
{Make=>'Toyota', Model=>'RAV', Sales=>12,Used=>'21.43%'},
{Make=>'Toyota', Model=>'Auris', Sales=>18,Used=>'32.14%'},
{Make=>'Toyota', Model=>'Prius', Sales=>19,Used=>'33.93%'},
{Make=>'Volvo', Model=>'XC90', Sales=>4, Used=>'22.22%'},
{Make=>'Volvo', Model=>'V40', Sales=>14,Used=>'77.78%'},
{Make=>'Hyundai',Model=>'Ionic', Sales=>22,Used=>undef} ]);
ok_ref( \@a, \@a2 );
t/40_aoh2.t view on Meta::CPAN
# make;perl -Iblib/lib t/40_aoh2.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 3;
my @oceania=a2h(
[qw(Area Population Capital Code Name)],
[ undef, 54343, 'Pago Pago', 'AS', 'American Samoa'],
[ 7686850, 22751014, 'Canberra', 'AU', 'Australia'],
[ undef, 596, 'West Island', 'CC', 'Cocos (Keeling) Islands'],
[ 240, 9838, 'Avarua', 'CK', 'Cook Islands'],
[ undef, 1530, 'Flying Fish Cove', 'CX', 'Christmas Island'],
[ 18270, 909389, 'Suva', 'FJ', 'Fiji'],
[ 702, 105216, 'Palikir', 'FM', 'Micronesia, Federated States of'],
[ 549, 161785, 'Hagatna (Agana)', 'GU', 'Guam'],
[ undef, 0, undef, 'HM', 'Heard Island and McDonald Islands'],
[ 811, 105711, 'Tarawa', 'KI', 'Kiribati'],
[ 181.3, 72191, 'Majuro', 'MH', 'Marshall Islands'],
[ 19060, 271615, 'Noumea', 'NC', 'New Caledonia'],
[ undef, 2210, 'Kingston', 'NF', 'Norfolk Island'],
[ 21, 9540, 'Yaren District', 'NR', 'Nauru'],
[ 260, 1190, 'Alofi', 'NU', 'Niue'],
[ 268680, 4438393, 'Wellington', 'NZ', 'New Zealand'],
[ undef, 282703, 'Papeete', 'PF', 'French Polynesia'],
[ 462840, 6672429, 'Port Moresby', 'PG', 'Papua New Guinea'],
[ undef, 48, 'Adamstown', 'PN', 'Pitcairn'],
[ 458, 21265, 'Melekeok', 'PW', 'Palau'],
[ 28450, 622469, 'Honiara', 'SB', 'Solomon Islands'],
[ undef, 1337, undef, 'TK', 'Tokelau'],
[ 26, 10869, 'Funafuti', 'TV', 'Tuvalu'],
[ undef, undef, undef, 'UM', 'United States Minor Outlying Islands'],
[ 12200, 272264, 'Port-Vila', 'VU', 'Vanuatu'],
[ undef, 15500, 'Mata-Utu', 'WF', 'Wallis and Futuna'],
[ 2944, 197773, 'Apia', 'WS', 'Samoa (Western)']
);
my $sql1=aoh2sql(\@oceania,{name=>'country',drop=>2});
my $sql2=<<'.';
begin;
drop table if exists country;
create table country (
Area numeric(9,1),
t/41_changed.t view on Meta::CPAN
use Test::More tests => 4;
my @lst;
@lst=map { changed(int($_/6)) ? ($_,'-') : ($_) } 1..20; testen();
@lst=map { changed(int($_/6)) ? ($_,'-') : ($_) } 1..20; testen();
sub testen{is( join("",@lst), '123456-789101112-131415161718-1920', 'ok list' )};
is(keys(%Acme::Tools::Changed_lastval), 2, 'count 2');
#print srlz(\%Acme::Tools::Changed_lastval,'l','',1);
@lst=map changed(int($_/6)),1..20;
is( srlz(\@lst,'lst'), qq(\@lst=(undef,'0','0','0','0','1','0','0','0','0','0','1','0','0','0','0','0','1','0','0');\n), '1st undef');
t/45_opts.t view on Meta::CPAN
if($die){
ok( ref($die) eq 'Regexp' ? ($@=~/$die/) : $@, $@=~s, at /.*,,rs );
} else {
is_deeply(\@a,$ar_exp,srlz(\@a,'a')=~s,\n,,r);
is_deeply(\%o,$hr_exp,srlz(\%o,'o')=~s,\n,,r);
}
}
check_opts('ks:',[qw(-k -s str 1 2 3 4)],[1..4],{k=>1,s=>'str'});
check_opts('ks:',[qw(-k -- -s str 1 2 3 4)],['-s','str',1..4],{k=>1});
check_opts('ks:j',[qw(-k -s str -j 1 2 3 4)],[1..4],{k=>1,j=>1,s=>'str'});
check_opts('ks:x',[qw(-k -s str -j 1 2 3 4)],undef,undef,qr/unknown opt -j/);
check_opts('ks:j',[qw(-k -s str -j 1 -s str2 2 3 4)],[1..4],{k=>1,j=>1,s=>'str,str2'});
check_opts('ks:j',[qw(-k -sstr -j 1 -s str2 2 3 4)],[1..4],{k=>1,j=>1,s=>'str,str2'});
check_opts('ks:j',[qw(-k -sstr -j1 -s str2 2 3 4)],undef,undef,qr/has no arg/);
check_opts('ks:j',[qw(-kj -sstr 1 -s str2 2 3 4)],[1..4],{k=>1,j=>1,s=>'str,str2'});
check_opts('ks:je',[qw(-kje -sstr 1 -s str2 2 3 4)],[1..4],{e=>1,k=>1,j=>1,s=>'str,str2'});
check_opts('ks:jet:',[qw(-kjetil -sstr 1 -s str2 2 3 4)],[1..4],{e=>1,k=>1,j=>1,s=>'str,str2',t=>'il'});
t/test_binsearch_bench.pl view on Meta::CPAN
print srlz(\$h,"h");
my($i,$h1,$h2,$h3);
my $cnt=3000;
my @find1=map random(1e5,2e5), 1..$cnt;
my @find2=@find1;
my @find3=@find1;
timethese($cnt, { #for some mystical reason Acme::Tools seems 11x faster(?)
'Name1' => sub { my$r=pop@find1;($h1)=(List::MoreUtils::bsearch {$$_[0] <=> $r} @a) },
# 'Name2' => sub { $i=Acme::Tools::binsearch(pop(@find2),\@a); $h2=$a[$i] },
'Name3' => sub { $i=Acme::Tools::binsearch([pop@find3],\@a,undef,sub{$_[0][0]<=>$_[1][0]}); $h3=$a[$i] },
});
print srlz(\$h1,'h1');
print srlz(\$h3,'h3');
#print "i=$i h=".srlz(\$h)."\n";
my @data=( map { {num=>$_,sqrt=>sqrt($_), square=>$_**2} }
grep !($_%7), 1..1000000 );
my $i = binsearch( {num=>913374}, \@data, undef, sub {$_[0]{num} <=> $_[1]{num}} );
my $found = defined $i ? $data[$i] : undef;
print "i=$i\n";
print srlz(\$found,'f');
print "Binsearch_steps = $Acme::Tools::Binsearch_steps\n";
( run in 3.444 seconds using v1.01-cache-2.11-cpan-d80b1682f3f )