Acme-Tools
view release on metacpan or search on metacpan
$digits||=9e9;
no warnings;
croak if $num<$start;
$num-=$start;
for(1..$digits){
$key=substr($validchars,$num%$l,1).$key;
$num=int($num/$l);
last if $digits==9e9 and !$num;
}
croak if $num>0;
return $key;
}
sub code2num {
my($code,$validchars,$start)=@_; $start=0 if!defined$start;
my $l=length($validchars);
my $num=0;
$num=$num*$l+index($validchars,$_) for split//,$code;
return $num+$start;
}
=head2 base
Numbers in any number system of base between 2 and 36. Using capital letters A-Z for base higher than 10.
base(2,15) # 1111 2 --> binary
base(8,4096) # 10000 8 --> octal
base(10,4096) # 4096 of course
base(16,254) # FE 16 --> hex
base(16,254.3) # FE 16 --> hex, can not handle decimal numbers (yet...todo)
base(36,123456) # FE 16 --> hex, can not handle decimal numbers (yet...todo)
base(36,1234567891011) # FR5HUHC3 base36 using all 0-9 and A-Z as digits, 10+26=36
base(37,1) # die with message 'base not 2-36'
base($x,0) # 0
base(16, 14,15,16,17) # list of four elements: E F 10 11
=head2 dec2bin dec2hex dec2oct bin2dec bin2hex bin2oct hex2dec hex2bin hex2oct oct2dec oct2bin oct2hex
print dec2bin(101); # 1100101
print dec2hex(101); # 65
print dec2oct(101); # 145
print bin2dec(1010011110); # 670
print bin2hex(1010011110); # 29e
print bin2oct(1010011110); # 1236
print hex2dec(101); # 257
print hex2bin(101); # 100000001
print hex2oct(101); # 401
print oct2dec(101); # 65
print oct2bin(101); # 1000001
print oct2hex(101); # 41
=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) }
sub hex2dec { hex(shift) }
sub hex2bin { sprintf"%b",hex(shift) }
sub hex2oct { sprintf"%o",hex(shift) }
sub oct2dec { oct(shift) }
sub oct2bin { sprintf"%b",oct(shift) }
sub oct2hex { sprintf"%x",oct(shift) }
=head2 gcd
I< C<">The Euclidean algorithm (also called Euclid's algorithm) is an
algorithm to determine the greatest common divisor (gcd) of two
integers. It is one of the oldest algorithms known, since it appeared
in the classic Euclid's Elements around 300 BC. The algorithm does not
require factoring.C<"> >
B<Input:> two or more positive numbers (integers, without decimals that is)
B<Output:> an integer
B<Example:>
print gcd(12, 8); # prints 4
Because the (prime number) factors of 12 is 2 * 2 * 3 and the factors of 8 is 2 * 2 * 2
and the common ('overlapping') factors for both 12 and 8 is then 2 * 2 and the result becomes 4.
B<Example two>:
print gcd(90, 135, 315); # prints 45
print gcd(2*3*3*5, 3*3*3*5, 3*3*5*7); # prints 45 ( = 3*3*5 which is common to all three args)
Implementation:
sub gcd { my($a,$b,@r)=@_; @r ? gcd($a,gcd($b,@r)) : $b==0 ? $a : gcd($b, $a % $b) }
One way of putting it: Keep replacing the larger of the two numbers with the difference between them until you got two equal numbers. Then thats the answer.
L<http://en.wikipedia.org/wiki/Greatest_common_divisor>
L<http://en.wikipedia.org/wiki/Euclidean_algorithm>
=cut
sub gcd { my($a,$b,@r)=@_; @r ? gcd($a,gcd($b,@r)) : $b==0 ? $a : gcd($b, $a % $b) }
#hm sub gcd { my($a,$b)=@_; ($a,$b)=($b,$a%$b) while $b; $a }
=head2 lcm
C<lcm()> finds the Least Common Multiple of two or more numbers (integers).
B<Input:> two or more positive numbers (integers)
B<Output:> an integer number
Example: C< 2/21 + 1/6 = 4/42 + 7/42 = 11/42>
Where 42 = lcm(21,6).
B<Example:>
print lcm(45,120,75); # prints 1800
Because the factors are:
45 = 2^0 * 3^2 * 5^1
120 = 2^3 * 3^1 * 5^1
75 = 2^0 * 3^1 * 5^2
Take the bigest power of each primary number (2, 3 and 5 here).
Which is 2^3, 3^2 and 5^2. Multiplied this is 8 * 9 * 25 = 1800.
sub lcm { my($a,$b,@r)=@_; @r ? lcm($a,lcm($b,@r)) : $a*$b/gcd($a,$b) }
Seems to works with L<Math::BigInt> as well: (C<lcm> of all integers from 1 to 200)
perl -MAcme::Tools -MMath::BigInt -le'print lcm(map Math::BigInt->new($_),1..200)'
337293588832926264639465766794841407432394382785157234228847021917234018060677390066992000
=cut
sub lcm { my($a,$b,@r)=@_; @r ? lcm($a,lcm($b,@r)) : $a*$b/gcd($a,$b) }
=head2 resolve
Resolves an equation by Newtons method.
B<Input:> 1-6 arguments. At least one argument.
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.
B<Example:>
The equation C<< x^2 - 4x - 21 = 0 >> has two solutions: -3 and 7.
The result of C<resolve> will depend on the start position:
print resolve(sub{ $_**2 - 4*$_ - 21 }); # -3 with $_ as your x
print resolve(sub{ my $x=shift; $x**2 - 4*$x - 21 }); # -3 more elaborate call
print resolve(sub{ my $x=shift; $x**2 - 4*$x - 21 },0,3); # 7 with start position 3
print "Iterations: $Acme::Tools::Resolve_iterations\n"; # 3 or larger, about 10-15 is normal
The variable C< $Acme::Tools::Resolve_iterations > (which is exported) will be set
to the last number of iterations C<resolve> used. Also if C<resolve> dies (carps).
The variable C< $Acme::Tools::Resolve_last_estimate > (which is exported) will be
set to the last estimate. This number will often be close to the solution and can
be used even if C<resolve> dies (carps).
B<BigFloat-example:>
If either second, third or fourth argument is an instance of L<Math::BigFloat>, so will the result be:
use Acme::Tools;
my $equation = sub{ $_ - 1 - 1/$_ };
my $gr1 = resolve( $equation, 0, 1 ); #
my $gr2 = resolve( $equation, 0, bigf(1) ); # 1/2 + sqrt(5)/2
bigscale(50);
my $gr3 = resolve( $equation, 0, bigf(1) ); # 1/2 + sqrt(5)/2
print 1/2 + sqrt(5)/2, "\n";
print "Golden ratio 1: $gr1\n";
print "Golden ratio 2: $gr2\n";
print "Golden ratio 3: $gr3\n";
Output:
1.61803398874989
Golden ratio 1: 1.61803398874989
Golden ratio 2: 1.61803398874989484820458683436563811772029300310882395927211731893236137472439025
Golden ratio 3: 1.6180339887498948482045868343656381177203091798057610016490334024184302360920167724737807104860909804
See:
L<http://en.wikipedia.org/wiki/Newtons_method>
L<Math::BigFloat>
L<http://en.wikipedia.org/wiki/Golden_ratio>
=cut
our $Resolve_iterations;
our $Resolve_last_estimate;
our $Resolve_time;
#sub resolve(\[&$]@) {
#sub resolve(&@) { <=0.17
#todo: perl -MAcme::Tools -le'print resolve(sub{$_[0]**2-9431**2});print$Acme::Tools::Resolve_iterations'
#todo: perl -MAcme::Tools -le'sub d{5.3*1.0094**$_[0]-10.2*1.0072**$_[0]} print resolve(\&d)' #err, pop norway vs sweden
#todo: perl -MAcme::Tools -le' print resolve(sub{5.3*1.0094**$_[0]-10.2*1.0072**$_[0]})' #err, pop norway vs sweden
# =>Div by zero: df(x) = 0 at n'th iteration, n=0, delta=0.0001, fx=CODE(0xc81d470) at -e line 1
#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($_);
}
$fx
};
#warn "delta=$delta\n";
my $n=0;
while($n<=$iters-1){
my $fd= &$fx($x[$n]+$delta*0.5) - &$fx($x[$n]-$delta*0.5);
$fd = &$fx($x[$n]+$delta*0.7) - &$fx($x[$n]-$delta*0.3) if $fd==0;# and warn"wigle 1\n";
$fd = &$fx($x[$n]+$delta*0.2) - &$fx($x[$n]-$delta*0.8) if $fd==0;# and warn"wigle 2\n";
croak "Div by zero: df(x) = $x[$n] at n'th iteration, n=$n, delta=$delta, fx=$fx" if $fd==0;
$x[$n+1]=$x[$n]-(&$fx($x[$n])-$goal)/($fd/$delta);
$Resolve_last_estimate=$x[$n+1];
#warn "n=$n fd=$fd x=$x[$n+1]\n";
$Resolve_iterations=$n;
last if $n>3 and $x[$n+1]==$x[$n] and $x[$n]==$x[$n-1];
last if $n>4 and $x[$n]!=0 and abs(1-$x[$n+1]/$x[$n])<1e-13; #sub{3*$_+$_**4-12}
last if $n>3 and ref($x[$n+1]) eq 'Math::BigFloat' and substr($x[$n+1],0,$ds) eq substr($x[$n],0,$ds); #hm
croak "Could not resolve, perhaps too little time given ($sec), iteratons=$n"
if $sec>0 and ($Resolve_time=time_fp()-$time_start)>$sec;
#warn "$n: ".$x[$n+1]."\n";
$n++;
}
croak "Could not resolve, perhaps too few iterations ($iters)" if @x>=$iters;
return $x[-1];
}
=head2 resolve_equation
This prints 2:
print resolve_equation "x + 13*(3-x) = 17 - x"
A string containing at least one x is converted into a perl function.
Then x is found by using L<resolve>. The string conversion is done by
replacing every x with $_ and if a C< = > char is present it converts
C< leftside = rightside > into C< (leftside) - (rightside) = 0 > which
is the default behaviour of L<resolve>.
=cut
sub resolve_equation { my $e=shift;resolve(sub{$e},@_)}
=head2 conv
Converts between:
=over 4
=item * units of measurement
:$fr eq 'small_gross' ? $n*12*10
:$fr eq 'skokk' ? $n*60 #norwegian unit
:$fr eq 'roman' ? roman2int($n)
:$fr eq 'des' ? $n
:croak "Conv from $fr not supported yet";
my $ret=$to eq 'dec' ? $dec
:$to eq 'hex' ? sprintf("%x",$dec)
:$to eq 'oct' ? sprintf("%o",$dec)
:$to eq 'bin' ? sprintf("%b",$dec)
:$to =~ /^(dusin|dozen|doz|dz)$/ ? $dec/12
:$to =~ /^(gross|gr|gro)$/ ? $dec/144
:$to eq 'great_gross' ? $dec/(12*144)
:$to eq 'small_gross' ? $dec/(12*10)
:$to eq 'skokk' ? $dec/60
:$to eq 'roman' ? int2roman($dec)
:$to eq 'des' ? $dec
:croak "Conv to $to not suppoerted yet";
$ret;
}
#http://en.wikipedia.org/wiki/Norwegian_units_of_measurement
=head2 bytes_readable
Converts a number of bytes to something human readable.
Input 1: a number
Input 2: optionally the number of decimals if >1000 B. Default is 2.
Output: a string containing:
the number with a B behind if the number is less than 1000
the number divided by 1024 with two decimals and "kB" behind if the number is less than 1024*1000
the number divided by 1048576 with two decimals and "MB" behind if the number is less than 1024*1024*1000
the number divided by 1073741824 with two decimals and "GB" behind if the number is less than 1024*1024*1024*1000
the number divided by 1099511627776 with two decimals and "TB" behind otherwise
Examples:
print bytes_readable(999); # 999 B
print bytes_readable(1000); # 1000 B
print bytes_readable(1001); # 0.98 kB
print bytes_readable(1024); # 1.00 kB
print bytes_readable(1153433.6); # 1.10 MB
print bytes_readable(1181116006.4); # 1.10 GB
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
Time written as C< 14h 37m > is often more humanly comprehensible than C< 52620 seconds >.
print sec_readable( 0 ); # 0s
print sec_readable( 0.0123 ); # 0.0123s
print sec_readable(-0.0123 ); # -0.0123s
print sec_readable( 1.23 ); # 1.23s
print sec_readable( 1 ); # 1s
print sec_readable( 9.87 ); # 9.87s
print sec_readable( 10 ); # 10s
print sec_readable( 10.1 ); # 10.1s
print sec_readable( 59 ); # 59s
print sec_readable( 59.123 ); # 59.1s
print sec_readable( 60 ); # 1m 0s
print sec_readable( 60.1 ); # 1m 0s
print sec_readable( 121 ); # 2m 1s
print sec_readable( 131 ); # 2m 11s
print sec_readable( 1331 ); # 22m 11s
print sec_readable(-1331 ); # -22m 11s
print sec_readable( 13331 ); # 3h 42m
print sec_readable( 133331 ); # 1d 13h
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 int2roman
Converts integers to roman numbers.
B<Examples:>
print int2roman(1234); # prints MCCXXXIV
print int2roman(1971); # prints MCMLXXI
(Adapted subroutine from Peter J. Acklam, jacklam(&)math.uio.no)
I = 1
V = 5
X = 10
L = 50
C = 100 (centum)
D = 500
M = 1000 (mille)
See also L<Roman>.
See L<http://en.wikipedia.org/wiki/Roman_numbers> for more.
=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
# =~s,VV,X,gr
# =~s,VIV,IX,gr
# =~s,XXXXX,L,gr
# =~s,XXXX,XL,gr
# =~s,LL,C,gr
# =~s,LXL,XC,gr
# =~s,CCCCC,D,gr
# =~s,CCCC,CD,gr
# =~s,DD,M,gr
# =~s,DCD,CM,gr
: do {
$n="I" x $n;
$n=~s,I{1000},M,g; #unnecessary, but speedup for n>1000
$n=~s,I{100},C,g; #unnecessary, but speedup for n>100
$n=~s,I{10},X,g; #unnecessary, but speedup for n>10
$n=~s,IIIII,V,g;
$n=~s,IIII,IV,g;
$n=~s,VV,X,g;
$n=~s,VIV,IX,g;
$n=~s,XXXXX,L,g;
$n=~s,XXXX,XL,g;
$n=~s,LL,C,g;
$n=~s,LXL,XC,g;
$n=~s,CCCCC,D,g;
$n=~s,CCCC,CD,g;
$n=~s,DD,M,g;
$n=~s,DCD,CM,g;
$n
}
}
sub int2roman_golfed{my$r='I'x pop;for(qw(IVX XLC CDM)){my($I,$V,$X)=split//;$r=~s,$I$I$I$I($I?),$1?$V:"$I$V",ge;$r=~s,$V($I?)$V,$1$X,g}$r}
sub roman2int {
my($r,$n,%c)=(shift,0,'',0,qw/I 1 V 5 X 10 L 50 C 100 D 500 M 1000/);
$r=~s/^-//?-roman2int($r):
$r=~s/(C?)([DM])|(X?)([LCDM])|(I?)([VXLCDM])|(I)|(.)/
croak "roman2int: Invalid number $r" if $8;
$n += $c{$2||$4||$6||$7} - $c{$1||$3||$5||''}; ''/eg && $n
}
#sub roman2int_slow {
# my $r=shift;
# $r=~s,^\-,, ? 0-roman2int($r)
# : $r=~s,^M,,i ? 1000+roman2int($r)
# : $r=~s,^CM,,i ? 900+roman2int($r)
# : $r=~s,^D,,i ? 500+roman2int($r)
# : $r=~s,^CD,,i ? 400+roman2int($r)
# : $r=~s,^C,,i ? 100+roman2int($r)
# : $r=~s,^XC,,i ? 90+roman2int($r)
# : $r=~s,^L,,i ? 50+roman2int($r)
print "l=$l max=$max\n";
$ne="9" x $l;
print log($n),"\n";
my $st=sub{print "status: ".($te/$ne)." n=$n ".($n/$te*$ne)."\n"};
while($n/$te*$ne<0.99){ &$st(); $ne*=10 }
while($te/$n/$ne<0.99){ &$st(); $te*=10 }
&$st();
while(1){
my $d=gcd($te,$ne); print "gcd=$d\n";
last if $d==1;
$te/=$d; $ne/=$d;
}
&$st();
wantarray ? ($te,$ne) : "$te/$ne"; #gcd()
}
=head2 isnum
B<Input:> String to be tested on this regexp:
C<< /^ \s* [\-\+]? (?: \d*\.\d+ | \d+ ) (?:[eE][\-\+]?\d+)?\s*$/x >>
If no argument is given isnum checks C<< $_ >>.
B<Output:> True or false (1 or 0)
use Acme::Tools;
my @e=(' +32.12354E-21 ', 2.2, '9' x 99999, ' -123.12', '29,323.31', '29 323.31');
print isnum() ? 'num' : 'str' for @e; #prints num for every element except the last two
print $_=~$Re_isnum ? 'num' : 'str' for @e; #same but slighhly faster
=cut
our $Re_isnum =qr/^ \s* [\-\+]? (?: \d*\.\d+ | \d+ ) (?:[eE][\-\+]?\d+)?\s*$/x;
our $Re_isnum_wolz=qr/^ \s* [\-\+]? (?: ([1-9]\d*|0)?\.\d+ | [1-9]\d* | 0 ) (?:[eE][\-\+]?\d+)?\s*$/x; #without leading zero
sub isnum {(@_?$_[0]:$_)=~$Re_isnum}
=head2 between
Input: Three arguments.
Returns: Something I<true> if the first argument is numerically between the two next. Uses Perls C<< < >>, C<< >= >> and C<< <= >> operators.
=head2 btw
Like L<between> but instead of assuming numbers it checks all three input args
and does alphanumerical comparisons (with Perl operators C<lt>, C<ge> and C<le>) if any of the
three input args don't look like a number or look like a number but with
one or more leading zeros.
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;
}
sub btw {
my($test,$fom,$tom)=@_;
return if !defined$test or !defined$fom or !defined$tom;
$fom =~ $Re_isnum_wolz &&
$tom =~ $Re_isnum_wolz &&
$test=~ $Re_isnum_wolz
? $fom < $tom ? $test >= $fom && $test <= $tom : $test >= $tom && $test <= $fom
: $fom lt $tom ? $test ge $fom && $test le $tom : $test ge $tom && $test le $fom
}
=head2 curb
B<Input:> Three arguments: value, minumum, maximum.
B<Output:> Returns the value if its between the given minumum and maximum.
Returns minimum if the value is less or maximum if the value is more.
Changes the variable if 1st arg is a scalarref.
my $enthusiasm = 11;
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
=head2 log2
=head2 logn
print log10(1000); # prints 3
print log10(10000*sqtr(10)); # prints 4.5
print log2(16); # prints 4
print logn(4096, 8); # prints 4 (12/3=4)
print logn($PI, 2.71828182845905); # same as print log($PI) using perls builtin log()
=cut
sub log10 { log($_[0]) / log(10) }
sub log2 { log($_[0]) / log(2) }
sub logn { log($_[0]) / log($_[1]) }
=head1 STRINGS
=head2 upper
=head2 lower
Returns input string as uppercase or lowercase.
Can be used if Perls build in C<uc()> and C<lc()> for some reason does not convert æøå or other latin1 letters outsize a-z.
Converts C<< æøåäëïöüÿâêîôûãõà èìòùáéÃóúýñð >> to and from C<< ÆØÅÄËÃÖÜ?ÂÊÎÔÛÃÕÀÈÌÒÙÃÉÃÓÚÃÑà >>
See also C<< perldoc -f uc >> and C<< perldoc -f lc >>
=head2 trim
Removes space from the beginning and end of a string. Whitespace (C<< \s >>) that is.
And removes any whitespace inside the string of more than one char, leaving the first whitespace char. Thus:
trim(" asdf \t\n 123 ") eq "asdf 123"
trim(" asdf\t\n 123\n") eq "asdf\t123"
Works on C<< $_ >> if no argument i given:
print join",", map trim, " please ", " remove ", " my ", " spaces "; # please,remove,my,spaces
print join",", trim(" please ", " remove ", " my ", " spaces "); # works on arrays as well
my $s=' please '; trim(\$s); # now $s eq 'please'
trim(\@untrimmedstrings); # trims array strings inplace
@untrimmedstrings = map trim, @untrimmedstrings; # same, works on $_
trim(\$_) for @untrimmedstrings; # same, works on \$_
=head2 lpad
=head2 rpad
If the first argument is a reference to a scalar variable, that variable is changed "in place".
Example:
my $str="test";
replace(\$str,'e','ee','s','S');
print $str; # prints teeSt
=cut
sub replace { repl(@_) }
sub repl {
my $str=shift;
return $$str=replace($$str,@_) if ref($str) eq 'SCALAR';
#return ? if ref($str) eq 'ARRAY';
#return ? if ref($str) eq 'HASH';
while(@_){
my($fra,$til)=(shift,shift);
defined $til ? $str=~s/$fra/$til/g : $str=~s/$fra//g;
}
return $str;
}
=head1 ARRAYS
=head2 subarr
The equivalent of C<substr> on arrays or C<splice> without changing the array.
Input: 1) array or arrayref, 2) offset and optionally 3) length. Without a
third argument, subarr returns the rest of the array.
@top10 = subarr( @array, 0, 10); # first 10
@last_two = subarr( @array, -2, 2); # last 2
@last_two = subarr( $array_ref, -2); # also last 2
@last_six = subarr $array_ref, -6; # parens are optional
The same can be obtained from C<< @array[$from..$to] >> but that dont work the
same way with negative offsets and boundary control of length.
=cut
#Todo: sjekk paastand over
#sub subarr(+$;$) { #perl>=5.14 # t/35_subarr.t
sub subarr { #perl<5.14
my($a,$o,$l)=@_;
$o=@$a+$o if $o<0;
$o=0 if $o<0;
$o=@$a-1 if $o>@$a-1;
$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
=head2 maxs
Just as L</mix>, except for strings.
print max(2,7,10); # 10
print maxs("2","7","10"); # 7
print maxs(2,7,10); # 7
=cut
sub min {my $min;for(@_){ $min=$_ if defined($_) and !defined($min) || $_ < $min } $min }
sub mins {my $min;for(@_){ $min=$_ if defined($_) and !defined($min) || $_ lt $min} $min }
sub max {my $max;for(@_){ $max=$_ if defined($_) and !defined($max) || $_ > $max } $max }
sub maxs {my $max;for(@_){ $max=$_ if defined($_) and !defined($max) || $_ gt $max} $max }
=head2 zip
B<Input:> Two or more arrayrefs. A number of equal sized arrays
containing numbers, strings or anything really.
B<Output:> An array of those input arrays zipped (interlocked, merged) into each other.
print join " ", zip( [1,3,5], [2,4,6] ); # 1 2 3 4 5 6
print join " ", zip( [1,4,7], [2,5,8], [3,6,9] ); # 1 2 3 4 5 6 7 8 9
Example:
zip() creates a hash where the keys are found in the first array and values in the secord in the correct order:
my @media = qw/CD DVD VHS LP Blueray/;
my @count = qw/20 12 2 4 3/;
my %count = zip(\@media,\@count); # or zip( [@media], [@count] )
print "I got $count{DVD} DVDs\n"; # I got 12 DVDs
Dies (croaks) if the two lists are of different sizes
...or any input argument is not an array ref.
=cut
sub zip {
my @t=@_;
ref($_) ne 'ARRAY' and croak "ERROR: zip should have arrayrefs as arguments" for @t;
@{$t[$_]} != @{$t[0]} and croak "ERROR: zip should have equal sized arrays" for 1..$#t;
my @res;
for my $i (0..@{$t[0]}-1){
push @res, $$_[$i] for @t;
}
return @res;
}
=head2 sim
B<Input:> Two or more strings
B<Output:> A number 0 - 1 indicating the similarity between two strings.
Requires L<String::Similarity> where the real magic happens.
sim("Donald Duck", "Donald E. Knuth"); # returns 0.615
sim("Kalle Anka", "Kalle And")' # returns 0.842
sim("Kalle Anka", "Kalle Anka"); # returns 1
sim("Kalle Anka", "kalle anka"); # returns 0.8
sim(map lc, "Kalle Anka", "kalle anka"); # returns 1
Todo: more doc
=cut
#Todo:
#peat -le'print join", ",sim("GskOk",[zip([qw(Gsk_ok Vgdoknr Personnavn Adferdkode Ordenkode G_kok)],[0..5])],0.7,0.127)'
#Use of uninitialized value in subroutine entry at /usr/local/share/perl/5.22.1/Acme/Tools.pm line 2365.
#Use of uninitialized value $simlikest in numeric ge (>=) at /usr/local/share/perl/5.22.1/Acme/Tools.pm line 2366.
#Use of uninitialized value in subroutine entry at /usr/local/share/perl/5.22.1/Acme/Tools.pm line 2365.
#Use of uninitialized value $simnestlikest in numeric ge (>=) at /usr/local/share/perl/5.22.1/Acme/Tools.pm line 2372.
sub sim {
require String::Similarity;
my($str,@r)=@_;
return String::Similarity::similarity(@_) if @r==1; #to param
my($min,$mindiff);
if(ref($r[0]) eq 'ARRAY'){
($min,$mindiff)=@r[1,2];
@r=@{$r[0]};
}
$min=0 if!defined$min;
my($simlikest,$simnestlikest,$likest,$idlikest)=(-1,-1);
for(@r){
my($s,$id)=ref($_) eq 'ARRAY' ? @$_ : ($_);
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.
Requires L<String::Similarity> where the real magic happens.
While sim() is case sensitive, sim_perm() is not.
Name1 Name2 sim() sim_perm()
---------------------------------- ------------------------------------- ----- ----------
Humphrey DeForest Bogart Bogart Humphrey DeForest 0.71 1.00
Humphrey Bogart Humphrey Gump Bogart 0.86 1.00
Humphrey deforest Bogart Bogart DeForest 0.41 1.00
Humfrey DeForest Boghart BOGART HUMPHREY 0.05 0.87
Humphrey Bogart Humphrey 0.70 1.00
Humfrey Deforest Boghart BOGART D. HUMFREY 0.15 0.78 *)
Presley, Elvis Aaron Elvis Presley 0.424242 1.00
sim_perm() was written to identify double-profiles in databases: two people with
either the same (or similar) email or phone number or zip code and similar enough
names are going on the list of probable doubles.
*) Todo: deal with initials better, should be higher than 0.78
=cut
sub sim_perm {
require String::Similarity;
my($s1,$s2)=map {s/^\s*(.+?)\s*$/$1/;$_} map upper($_), @_; #/r v5.14
croak if !length($s1) or !length($s2);
my $max;
for(cart([permutations(split(/[\s,]+/,$s1))],
[permutations(split(/[\s,]+/,$s2))])) {
my($n1,$n2)=@$_;
if(@$n1>@$n2){ pop@$n1 while @$n1>@$n2 }
else { pop@$n2 while @$n1<@$n2 }
my($str1,$str2)=map join(" ",@$_),($n1,$n2);
if(defined $max){
my $sim=String::Similarity::similarity($str1,$str2,$max);
$max=$sim if $sim>$max;
}
else {
$max=String::Similarity::similarity($str1,$str2);
}
last if $max==1;
}
return $max;
}
=head2 pushsort
Adds one or more element to a numerically sorted array and keeps it sorted.
pushsort @a, 13; # this...
push @a, 13; @a = sort {$a<=>$b} @a; # is the same as this, but the former is faster if @a is large
=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 (@_){
#not needed but often faster
if(!defined $Pushsort_cmpsub){ #faster rank() in most cases
push @$ar, $v and next if $v>=$$ar[-1];
unshift @$ar, $v and next if $v< $$ar[0];
}
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:
=over 4
=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
my ($x,$v)=@_;
my ($klo,$khi)=(0,$#{$x});
my $k;
while (($khi-$klo)>1) {
$k=int(($khi+$klo)/2);
if ($$x[$k]>$v) { $khi=$k; } else { $klo=$k; }
}
return $klo;
}
sub binsearchstr {binsearch(@_[0..2],sub{$_[0]cmp$_[1]})}
=head2 rank
B<Input:> Two or three arguments. N and an arrayref for the list to look at.
In scalar context: Returns the nth smallest number in an array. The array doesn't have to be sorted.
In array context: Returns the n smallest numbers in an array.
To return the n(th) largest number(s) instead of smallest, just negate n.
An optional third argument can be a sub that is used to compare the elements of the input array.
Examples:
my $second_smallest = rank(2, [11,12,13,14]); # 12
my @top10 = rank(-10, [1..100]); # 100, 99, 98, 97, 96, 95, 94, 93, 92, 91
my $max = rank(-1, [101,102,103,102,101]); #103
my @contest = ({name=>"Alice",score=>14},{name=>"Bob",score=>13},{name=>"Eve",score=>12});
my $second = rank(2, \@contest, sub{$_[1]{score}<=>$_[0]{score}})->{name}; #Bob
=head2 rankstr
Just as C<rank> but sorts alphanumerically (strings, cmp) instead of numerically.
=cut
sub rank {
my($rank,$aref,$cmpsub)=@_;
if($rank<0){
$cmpsub||=sub{$_[0]<=>$_[1]};
return rank(-$rank,$aref,sub{0-&$cmpsub});
}
my @sort;
local $Pushsort_cmpsub=$cmpsub;
for(@$aref){
pushsort @sort, $_;
pop @sort if @sort>$rank;
}
return wantarray ? @sort : $sort[$rank-1];
}
sub rankstr {wantarray?(rank(@_,sub{$_[0]cmp$_[1]})):rank(@_,sub{$_[0]cmp$_[1]})}
=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
my @a=2..44;
egrep { $prev =~/4$/ or $next =~/2$/ } @a; # 5, 11, 15, 21, 25, 31, 35, 41
egrep { $prevr=~/4$/ or $nextr=~/2$/ } @a; # 2, 5, 11, 15, 21, 25, 31, 35, 41, 44
egrep { $i%7==0 } @a; # 2, 9, 16, 23, 30, 37, 44
egrep { $n%7==0 } @a; # 8, 15, 22, 29, 36, 43
=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;
}
=head2 sorted
Return true if the input array is numerically sorted.
@a=(1..10); print "array is sorted" if sorted @a; #true
Optionally the last argument can be a comparison sub:
@person=({Rank=>1,Name=>'Amy'}, {Rank=>2,Name=>'Paula'}, {Rank=>3,Name=>'Ruth'});
print "Persons are sorted" if sorted @person, sub{$_[0]{Rank}<=>$_[1]{Rank}};
=head2 sortedstr
Return true if the input array is I<alpha>numerically sorted.
@a=(1..10); print "array is sorted" if sortedstr @a; #false
@a=("01".."10"); print "array is sorted" if sortedstr @a; #true
=cut
sub sorted (\@@) {
my($a,$cmpsub)=@_;
if($cmpsub){ &$cmpsub($$a[$_],$$a[$_+1])>0 and return 0 for 0..$#$a-1 }
else { $$a[$_] > $$a[$_+1] and return 0 for 0..$#$a-1 }
return 1;
}
#sub sortedstr { sorted(@_,sub{$_[0]cmp$_[1]}) }
sub sortedstr { $_[$_] gt $_[$_+1] and return 0 for 0..$#$_-1; return 1 }
sub sortby {
my($arr,@by)=@_;
die if grep/^-/,@by; #hm 4now todo! - dash meaning descending order
my $pattern=join(" ",map"%-40s",@by);#hm 4now bad, cant handle numeric sort
map$$_[0],
sort{$$a[1]cmp$$b[1]}
map[$_,sprintf($pattern,@$_{@by})],
@$arr;
}
=head2 subarrays
Returns all 2^n-1 combinatory subarrays of an array where each element
of input array participates or not. Note: The empty array is not among
the returned arrayrefs unless an empty input is given.
my @a = subarrays( 'a', 'b', 'c' ); # same as:
my @a = ( ['a' ],
[ 'b'],
['a','b'],
[ 'c'],
['a', 'c'],
[ 'b','c'],
['a','b','c'] );
sub subarrays { map { my $n = 2*$_; [ grep {($n/=2)%2} @_ ] } 1 .. 2**@_-1 } #implemented as
=cut
sub subarrays { map { my $n = 2*$_; [ grep {($n/=2)%2} @_ ] } 1 .. 2**@_-1 }
=head2 part
B<Input:> A code-ref and a list
B<Output:> Two array-refs
Like C<grep> but returns the false list as well. Partitions a list
into two lists where each element goes into the first or second list
whether the predicate (a code-ref) is true or false for that element.
my( $odd, $even ) = part {$_%2} (1..8);
print for @$odd; #prints 1 3 5 7
print for @$even; #prints 2 4 6 8
(Works like C< partition() > in the Scala programming language)
=head2 parth
Like C<part> but returns any number of lists. Not just two. Sort of like I<group by> in SQL.
B<Input:> A code-ref and a list
B<Output:> A hash where the returned values from the code-ref are keys and the values are arrayrefs to the list elements which gave those keys.
my %hash = parth { uc(substr($_,0,1)) } ('These','are','the','words','of','this','array');
print serialize(\%hash);
Result:
%hash = ( T=>['These','the','this'],
A=>['are','array'],
O=>['of'],
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
=head2 refh
=head2 refs
=head2 refaa
=head2 refah
=head2 refha
=head2 refhh
Returns true or false (1 or 0) if the argument is an arrayref, hashref, scalarref, ref to an array of arrays, ref to an array of hashes
Examples:
my $ref_to_array = [1,2,3];
my $ref_to_hash = {1,100,2,200,3,300};
my $ref_to_scalar = \"String";
print "arrayref" if ref($ref_to_array) eq 'ARRAY'; #true
print "hashref" if ref($ref_to_hash) eq 'HASH'; #true
print "scalarref" if ref($ref_to_scalar) eq 'SCALAR'; #true
print "arrayref" if refa($ref_to_array); #also true, without: eq 'ARRAY'
print "hashref" if refh($ref_to_hash); #also true, without: eq 'HASH'
print "scalarref" if refs($ref_to_scalar); #also true, without: eq 'SCALAR'
my $ref_to_array_of_arrays = [ [1,2,3], [2,4,8], [10,100,1000] ];
my $ref_to_array_of_hashes = [ {1=>10, 2=>100}, {first=>1, second=>2} ];
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
=head2 splicer
=head2 keysr
=head2 valuesr
=head2 eachr
=head2 joinr
In Perl versions 5.12 - 5.22 push, pop, shift, unshift, splice, keys, values and each
handled references to arrays and references to hashes just as if they where arrays and hashes. Examples:
my $person={name=>'Gaga', array=>[1,2,3]};
push $person{array} , 4; #works in perl 5.12-5.22 but not before and after
push @{ $person{array} }, 4; #works in all perl5 versions
pushr $person{array} , 4; #use Acme::Tools and this should work in perl >= 5.8
popr $person{array}; #returns 4
=cut
sub pushr { push @{shift()}, @_ } # ? ($@)
sub popr { pop @{shift()} }
sub shiftr { shift @{shift()} }
sub unshiftr { unshift @{shift()}, @_ }
sub splicer { @_==1 ? splice( @{shift()} )
:@_==2 ? splice( @{shift()}, shift() )
:@_==3 ? splice( @{shift()}, shift(), shift() )
:@_>=4 ? splice( @{shift()}, shift(), shift(), @_ ) : croak }
sub keysr { ref($_[0]) eq 'HASH' ? keys(%{shift()}) : keysr({@{shift()}}) } #hm sort(keys%{shift()}) ?
sub valuesr { values( %{shift()} ) }
sub eachr { ref($_[0]) eq 'HASH' ? each(%{shift()})
#:ref($_[0]) eq 'ARRAY' ? each(@{shift()}) # perl 5.8.8 cannot compile each on array! eval?
: croak("eachr needs hashref or arrayref got '".ref($_[0])."'") }
sub joinr {join(shift(),@{shift()})}
#sub mapr # som scala: hvis map faar subref se kalles den sub paa hvert elem og resultatet returneres
#sub eachr { each(%{shift()}) }
=head2 pile
B<Input:> a pile size s and a list
B<Output:> A list of lists of length s or the length of the remainer in
the last list. Piles together the input list in lists of the given size.
my @list=(1,2,3,4,5,6,7,8,9,10);
my @piles = pile(3, @list ); # ([1,2,3], [4,5,6], [7,8,9], [10])
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
#create=>1, #default, use 0 to dont include create table
#drop=>0, #default 0: dont include drop table x; 1: drop table x; 2: drop table if exists x;
#end=>"commit;\n",
#begin=>"begin;\n",
#fix_colnames=>0,
});
Returns:
begin;
drop table if exists country;
create table country (
Area numeric(9,1),
Capital varchar(16),
Code varchar(2) not null,
Name varchar(36) not null,
Population numeric(9)
);
insert into country values (null,'Pago Pago','AS','American Samoa',54343);
insert into country values (7686850,'Canberra','AU','Australia',22751014);
insert into country values (null,'West Island','CC','Cocos (Keeling) Islands',596);
insert into country values (240,'Avarua','CK','Cook Islands',9838);
insert into country values (null,'Flying Fish Cove','CX','Christmas Island',1530);
insert into country values (18270,'Suva','FJ','Fiji',909389);
insert into country values (702,'Palikir','FM','Micronesia, Federated States of',105216);
insert into country values (549,'Hagatna (Agana)','GU','Guam',161785);
insert into country values (811,'Tarawa','KI','Kiribati',105711);
insert into country values (181.3,'Majuro','MH','Marshall Islands',72191);
insert into country values (19060,'Noumea','NC','New Caledonia',271615);
insert into country values (null,'Kingston','NF','Norfolk Island',2210);
insert into country values (21,'Yaren District','NR','Nauru',9540);
insert into country values (260,'Alofi','NU','Niue',1190);
insert into country values (268680,'Wellington','NZ','New Zealand',4438393);
insert into country values (null,'Papeete','PF','French Polynesia',282703);
insert into country values (462840,'Port Moresby','PG','Papua New Guinea',6672429);
insert into country values (null,'Adamstown','PN','Pitcairn',48);
insert into country values (458,'Melekeok','PW','Palau',21265);
insert into country values (28450,'Honiara','SB','Solomon Islands',622469);
insert into country values (null,null,'TK','Tokelau',1337);
insert into country values (26,'Funafuti','TV','Tuvalu',10869);
insert into country values (12200,'Port-Vila','VU','Vanuatu',272264);
insert into country values (null,'Mata-Utu','WF','Wallis and Futuna',15500);
insert into country values (2944,'Apia','WS','Samoa (Western)',197773);
commit;
=cut
for my $c (@col){
my($l,$s,$p,$nn,%ant,$t)=(0,0,0,0);
for my $r (@$aoh){
my $v=$$r{$c};
next if !defined$v or $v!~/\S/;
$nn++;
$l=length($v) if length($v)>$l;
no warnings 'uninitialized';
if($v=~/^(18|19|20)\d\d(0[1-9]|1[0-2])(0[1-9]|1\d|2\d|3[01])-?\d\d:?\d\d:?\d\d$/ and $conf{date}){
$ant{date}++;
next;
}
elsif($v=~/^\s*[-+]?(\d*)(\.\d+)?([Ee]\-?\d+)?\s*$/ and length("$1$2") and $conf{number}){
$ant{number}++;
$s=length("$1.$2") if length("$1.$2")>$s;#hm
$p=length($2)-1 if $2 and length($2)-1>$p;
next;
}
else {
$ant{varchar}++;
}
}
$t||='varchar' if $ant{varchar} or $ant{number} and $ant{date};
$t||='number' if $ant{number};
$t||='date' if $ant{date};
$t||='varchar'; #hm
$l=$conf{varchar_maxlen} if $conf{varchar_maxlen} and $l>$conf{varchar_maxlen};
$l||=1;
my $tdb;
$tdb="$conf{$t}($l)" if $t eq 'varchar';
$tdb="$conf{$t}($s)" if $t eq 'number' and $p==0;
$tdb="$conf{$t}($s,$p)" if $t eq 'number' and $p>0 and ++$s;
$tdb.=" not null" if $nn == 0+@$aoh;
$t{$c}=$t;
$tdb{$c}=$tdb;
}
my $sql;
$sql="create table $conf{name} (".
join(",",map sprintf("\n %-30s %s",do{s/\W+//g;$_},$tdb{$_}), @col). "\n);\n\n" if $conf{create};
my $val=sub{my($v,$t)=@_;defined$v or $v="";!length($v)?'null':$t eq 'number' ? $v : "'".repl($v,"\'","''")."'"};
for my $r (@$aoh){
my $v=join",",map &$val($$r{$_},$t{$_}), @col;
$sql.="insert into $conf{name} values ($v);\n";
}
$sql="drop table $conf{name};\n\n$sql" if $conf{drop}==1;
$sql="drop table if exists $conf{name};\n\n$sql" if $conf{drop}>=2;
$sql="$conf{begin}\n$sql" if $conf{begin};
$sql.=$conf{end};
$sql;
}
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
print avg( [2, 4, 9] ); # 5 pass by reference, same result but faster for large arrays
Also known as I<arithmetic mean>.
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
print exp(avg(map log($_),10,100,1000,10000,100000)); # 1000 same thing, this is how geomavg() works internally
=cut
sub geomavg { exp(avg(map log($_), @_)) }
=head2 harmonicavg
Returns the I<harmonic average> (a.k.a I<geometric mean>) of a list of numbers. L<http://en.wikipedia.org/wiki/Harmonic_mean>
print harmonicavg(10,11,12); # 3 / ( 1/10 + 1/11 + 1/12) = 10.939226519337
=cut
sub harmonicavg { my $s; $s+=1/$_ for @_; @_/$s }
=head2 variance
C<< variance = ( sum (x[i]-Average)**2)/(n-1) >>
=cut
sub variance {
my $sumx2; $sumx2+=$_*$_ for @_;
my $sumx; $sumx+=$_ for @_;
(@_*$sumx2-$sumx*$sumx)/(@_*(@_-1));
}
=head2 stddev
C<< Standard_Deviation = sqrt(variance) >>
Standard deviation (stddev) is a measurement of the width of a normal
distribution where one stddev on each side of the mean covers 68% and
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
=cut
sub rstddev { stddev(@_) / avg(@_) }
=head2 median
Returns the median value of a list of numbers. The list do not have to
be sorted.
Example 1, list having an odd number of numbers:
print median(1, 100, 101); # 100
100 is the middlemost number after sorting.
Example 2, an even number of numbers:
print median(1005, 100, 101, 99); # 100.5
100.5 is the average of the two middlemost numbers.
=cut
sub median {
no warnings;
my @list = sort {$a<=>$b} @_;
my $n=@list;
$n%2 ? $list[($n-1)/2]
: ($list[$n/2-1] + $list[$n/2])/2;
}
=head2 percentile
Returns one or more percentiles of a list of numbers.
Percentile 50 is the same as the I<median>, percentile 25 is the first
quartile, 75 is the third quartile.
B<Input:>
First argument is your wanted percentile, or a refrence to a list of percentiles you want from the dataset.
If the first argument to percentile() is a scalar, this percentile is returned.
If the first argument is a reference to an array, then all those percentiles are returned as an array.
Second, third, fourth and so on argument are the numbers from which you want to find the percentile(s).
B<Examples:>
B<Input:>
=over 4
=item 1.
Either a reference to an array as the only input. This array will then be mixed I<in-place>. The array will be changed:
This: C<< @a=mix(@a) >> is the same as: C<< mix(\@a) >>.
=item 2.
Or an array of zero, one or more elements.
=back
Note that an input-array which COINCIDENTLY SOME TIMES has one element
(but more other times), and that element is an array-ref, you will
probably not get the expected result.
To check distribution:
perl -MAcme::Tools -le 'print mix("a".."z") for 1..26000'|cut -c1|sort|uniq -c|sort -n
The letters a-z should occur around 1000 times each.
Shuffles a deck of cards: (s=spaces, h=hearts, c=clubs, d=diamonds)
perl -MAcme::Tools -le '@cards=map join("",@$_),cart([qw/s h c d/],[2..10,qw/J Q K A/]); print join " ",mix(@cards)'
(Uses L</cart>, which is not a typo, see further down here)
Note: C<List::Util::shuffle()> is approximately four times faster. Both respects the Perl built-in C<srand()>.
=cut
sub mix {
if(@_==1 and ref($_[0]) eq 'ARRAY'){ #just one arg, and its ref array
my $r=$_[0];
push@$r,splice(@$r,rand(@$r-$_),1) for 0..(@$r-1);
return $r;
}
else{
my@e=@_;
push@e,splice(@e,rand(@e-$_),1) for 0..$#e;
return @e;
}
}
=head2 pwgen
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)
my $pw=pwgen(12); # a random 12 chars password A-Z a-z 0-9 ,-./&%!_
my @pw=pwgen(0,10); # 10 random 8 chars passwords, containing the same possible chars
my @pw=pwgen(0,1000,'A-Z'); # 1000 random 8 chars passwords containing just uppercase letters from A to Z
pwgen(3); # dies, defaults require chars in each of 4 group (see above)
pwgen(5,1,'A-C0-9', qr/^\D{3}\d{2}$/); # a 5 char string starting with three A, B or Cs and endring with two digits
pwgen(5,1,'ABC0-9',sub{/^\D{3}\d{2}$/}); # same as above
Examples of adding additional requirements to the default ones:
my @pwreq = ( qr/^[A-C]/ );
pwgen(8,1,'','',@pwreq); # use defaults for allowed chars and the standard requirements
# but also demand that the password must start with A, B or C
push @pwreq, sub{ not /[a-z]{3}/i };
pwgen(8,1,'','',@pwreq); # as above and in addition the password should not contain three
# or more consecutive letters (to avoid "offensive" words perhaps)
=cut
our $Pwgen_max_sec=0.01; #max seconds/password before croak (for hard to find requirements)
our $Pwgen_max_trials=10000; #max trials/password before croak (for hard to find requirements)
our $Pwgen_sec=0; #seconds used in last call to pwgen()
our $Pwgen_trials=0; #trials in last call to pwgen()
sub pwgendefreq{/^[a-z].*[a-z\d]$/i and /[a-z]/ and /[A-Z]/ and /\d/ and /[,-.\/&%_!]/}
sub pwgen {
my($len,$num,$chars,@req)=@_;
$len||=8;
$num||=1;
$chars||='A-Za-z0-9,-./&%_!';
$req[0]||=\&pwgendefreq if !$_[2];
$chars=~s/([$_])-([$_])/join("","$1".."$2")/eg for ('a-z','A-Z','0-9');
my($c,$t,@pw,$d)=(length($chars),time_fp());
($Pwgen_trials,$Pwgen_sec)=(0,0);
TRIAL:
while(@pw<$num){
croak "pwgen timeout after $Pwgen_trials trials"
if ++$Pwgen_trials >= $Pwgen_max_trials
or ($d=time_fp()-$t) > $Pwgen_max_sec*$num
and $d!~/^\d+$/; #jic int from time_fp
my $pw=join"",map substr($chars,rand($c),1),1..$len;
for my $r (@req){
if (ref($r) eq 'CODE' ){ local$_=$pw; &$r() or next TRIAL }
elsif(ref($r) eq 'Regexp'){ no warnings; $pw=~$r or next TRIAL }
else { croak "pwgen: invalid req type $r ".ref($r) }
}
push@pw,$pw;
}
$Pwgen_sec=time_fp()-$t;
return $pw[0] if $num==1;
Note: The values are NOT deep copied when they are references. (Use C<< Storable::dclone() >> to do that).
Note2: For perl versions >= 5.20 subhashes (hash slices returning keys as well as values) is built in like this:
%scandinavia = %population{'Norway','Sweden','Denmark'};
=cut
sub subhash {
my $hr=shift;
my @r;
for(@_){ push@r,($_=>$$hr{$_}) }
return @r;
}
=head2 hashtrans
B<Input:> a reference to a hash of hashes
B<Output:> a hash like the input-hash, but matrix transposed (kind of). Think of it as if X and Y has swapped places.
%h = ( 1 => {a=>33,b=>55},
2 => {a=>11,b=>22},
3 => {a=>88,b=>99} );
print serialize({hashtrans(\%h)},'v');
Gives:
%v=( 'a'=>{'1'=>'33','2'=>'11','3'=>'88'},
'b'=>{'1'=>'55','2'=>'22','3'=>'99'} );
=cut
#Hashtrans brukes automatisk når første argument er -1 i sub hashtabell()
sub hashtrans {
my $h=shift;
my %new;
for my $k (keys%$h){
my $r=$$h{$k};
for(keys%$r){
$new{$_}{$k}=$$r{$_};
}
}
return %new;
}
=head2 a2h
B<Input:> array of arrays
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>
=cut
sub a2h {
my @col=@{shift@_};
map { my%h;@h{@col}=@$_;\%h} @_;
}
sub h2a {
my %c;
map $c{$_}++, keys%$_ for @_;
my @c=sort{$c{$a}<=>$c{$b} or $a cmp $b}keys%c;
(\@c,map[@$_{@c}],@_);
}
=head1 COMPRESSION
L</zipb64>, L</unzipb64>, L</zipbin>, L</unzipbin>, L</gzip>, and L</gunzip>
compresses and uncompresses strings to save space in disk, memory,
database or network transfer. Trades time for space. (Beware of wormholes)
=head2 zipb64
Compresses the input (text or binary) and returns a base64-encoded string of the compressed binary data.
No known limit on input length, several MB has been tested, as long as you've got the RAM...
B<Input:> One or two strings.
First argument: The string to be compressed.
Second argument is optional: A I<dictionary> string.
B<Output:> a base64-kodet string of the compressed input.
The use of an optional I<dictionary> string will result in an even
further compressed output in the dictionary string is somewhat similar
to the string that is compressed (the data in the first argument).
If x relatively similar string are to be compressed, i.e. x number
automatic of email responses to some action by a user, it will pay of
to choose one of those x as a dictionary string and store it as
such. (You will also use the same dictionary string when decompressing
using L</unzipb64>.
The returned string is base64 encoded. That is, the output is 33%
larger than it has to be. The advantage is that this string more
easily can be stored in a database (without the hassles of CLOB/BLOB)
or perhaps easier transfer in http POST requests (it still needs some
url-encoding, normally). See L</zipbin> and L</unzipbin> for the
same without base 64 encoding.
Compared to gzip/gunzip, bzip2 compression is much slower, bunzip2 decompression not so much.
See also L<Compress::Bzip2>, C<man Compress::Bzip2>, C<man bzip2>, C<man bunzip2>.
writefile( "file.bz2", bzip2("some string") );
print bunzip2( bzip2("some string") ); #some string
=head2 bunzip2
Decompressed something compressed by bzip2() or data from a C<.bz2> file. See L</bzip2>.
=cut
sub gzip { my $s=shift; eval"require Compress::Zlib" if !$INC{'Compress/Zlib.pm'}; croak "Compress::Zlib not found" if $@; Compress::Zlib::memGzip( ref($s)?$s:\$s ) }
sub gunzip { my $s=shift; eval"require Compress::Zlib" if !$INC{'Compress/Zlib.pm'}; croak "Compress::Zlib not found" if $@; Compress::Zlib::memGunzip( ref($s)?$s:\$s ) }
sub bzip2 { my $s=shift; eval"require Compress::Bzip2" if !$INC{'Compress/Bzip2.pm'}; croak "Compress::Bzip2 not found" if $@; Compress::Bzip2::memBzip( ref($s)?$s:\$s ) }
sub bunzip2 { my $s=shift; eval"require Compress::Bzip2" if !$INC{'Compress/Bzip2.pm'}; croak "Compress::Bzip2 not found" if $@; Compress::Bzip2::memBunzip( ref($s)?$s:\$s ) }
=head1 NET, WEB, CGI-STUFF
=head2 ipaddr
B<Input:> an IP-number
B<Output:> either an IP-address I<machine.sld.tld> or an empty string
if the DNS lookup didn't find anything.
Example:
perl -MAcme::Tools -le 'print ipaddr("129.240.8.200")' # prints www.uio.no
Uses perls C<gethostbyaddr> internally.
C<ipaddr()> memoizes the results internally (using the
C<%Acme::Tools::IPADDR_memo> hash) so only the first loopup on a
particular IP number might take some time.
Some few DNS loopups can take several seconds.
Most is done in a fraction of a second. Due to this slowness, medium to high traffic web servers should
probably turn off hostname lookups in their logs and just log IP numbers by using
C<HostnameLookups Off> in Apache C<httpd.conf> and then use I<ipaddr> afterwards if necessary.
=cut
our %IPADDR_memo;
sub ipaddr {
my $ipnr=shift;
#hm, NOTE: The 2 parameter on the next code line is not 2 for all OSes,
#but seems to work in Linux and HPUX. Den correct way is to use the
#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",
$m, $x>>24, ($x>>16)&255, ($x>>8)&255, $x&255, 32-$m);
$Iprange_start=$r;
return 1;
}
sub in_iprange {
my($ipnum,$iprange)=@_;
croak $Ipnum_errmsg if !ipnum_ok($ipnum);
croak $Iprange_errmsg if !iprange_ok($iprange=~m|/\d+$| ? $iprange : "$iprange/32");
"$iprange/32"=~m|/(\d+)| or die;
$Ipnum>=$Iprange_start &&
$Ipnum<=$Iprange_start + 2**(32-$1)-1;
}
=head2 webparams
B<Input:> (optional)
Zero or one input argument: A string of the same type often found behind the first question mark (C<< ? >>) in URLs.
This string can have one or more parts separated by C<&> chars.
Each part consists of C<key=value> pairs (with the first C<=> char being the separation char).
Both C<key> and C<value> can be url-encoded.
If there is no input argument, C<webparams> uses C<< $ENV{QUERY_STRING} >> instead.
If also C<< $ENV{QUERY_STRING} >> is lacking, C<webparams()> checks if C<< $ENV{REQUEST_METHOD} eq 'POST' >>.
In that case C<< $ENV{CONTENT_LENGTH} >> is taken as the number of bytes to be read from C<STDIN>
and those bytes are used as the missing input argument.
The environment variables QUERY_STRING, REQUEST_METHOD and CONTENT_LENGTH is
typically set by a web server following the CGI standard (which Apache and
most of them can do I guess) or in mod_perl by Apache. Although you are
probably better off using L<CGI>. Or C<< $R->args() >> or C<< $R->content() >> in mod_perl.
B<Output:>
C<webparams()> returns a hash of the key/value pairs in the input argument. Url-decoded.
If an input string has more than one occurrence of the same key, that keys value in the returned hash will become concatenated each value separated by a C<,> char. (A comma char)
Examples:
use Acme::Tools;
my %R=webparams();
print "Content-Type: text/plain\n\n"; # or rather \cM\cJ\cM\cJ instead of \n\n to be http-compliant
print "My name is $R{name}";
Storing those four lines in a file in the directory designated for CGI-scripts
sub writefile {
my($filename,$text)=@_;
if(ref($filename) eq 'ARRAY'){
writefile(@$_) for @$filename;
return;
}
open(WRITEFILE,openstr(">$filename")) and binmode(WRITEFILE) or croak($!);
if(!defined $text or !ref($text)){
print WRITEFILE $text;
}
elsif(ref($text) eq 'SCALAR'){
print WRITEFILE $$text;
}
elsif(ref($text) eq 'ARRAY'){
print WRITEFILE "$_\n" for @$text;
}
else {
croak;
}
close(WRITEFILE);
return;
}
=head2 readfile
Just as with L</writefile> you can read in a whole file in one operation with C<readfile()>. Instead of:
open my $FILE,'<', $filename or die $!;
my $data = join"",<$FILE>;
close($FILE);
This is simpler:
my $data = readfile($filename);
B<More examples:>
Reading the content of the file to a scalar variable: (Any content in C<$data> will be overwritten)
my $data;
readfile('filename.txt',\$data);
Reading the lines of a file into an array:
my @lines;
readfile('filnavn.txt',\@lines);
for(@lines){
...
}
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
#todo: readfile with grep-filter code ref in a third arg (avoid reading all into mem)
sub readfile {
my($filename,$ref)=@_;
if(@_==1){
if(wantarray){ my @data; readfile($filename,\@data); return @data }
else { my $data; readfile($filename,\$data); return $data }
}
else {
open my $fh,openstr($filename) or croak("ERROR: readfile $! $?");
if ( ref($ref) eq 'SCALAR') { $$ref=join"",<$fh> }
elsif( ref($ref) eq 'ARRAY' ) { while(my $l=<$fh>){ chomp($l); push @$ref, $l } }
else { croak "ERROR: Second arg to readfile should be a ref to a scalar og array" }
close($fh);
return;#?
}
}
=head2 readdirectory
B<Input:>
Name of a directory.
B<Output:>
A list of all files in it, except of C<.> and C<..> (on linux/unix systems, all directories have a C<.> and C<..> directory).
The names of all types of files are returned: normal files, directories, symbolic links,
pipes, semaphores. That is every thing shown by C<ls -la> except C<.> and C<..>
C<readdirectory> do not recurce down into subdirectories (but see example below).
B<Example:>
my @files = readdirectory("/tmp");
B<Why readdirectory?>
Sometimes calling the built ins C<opendir>, C<readdir> and C<closedir> seems a tad tedious, since this:
my $dir="/usr/bin";
opendir(D,$dir);
my @files=map "$dir/$_", grep {!/^\.\.?$/} readdir(D);
closedir(D);
Is the same as this:
my @files=readdirectory("/usr/bin");
my @files=("/tmp");
map {-d $_ and unshift @files,$_ or push @files,$_} readdirectory(shift(@files)) while -d $files[0];
...or to avoid symlinks and only get real files:
map {-d and !-l and unshift @files,$_ or -f and !-l and push @files,$_} readdirectory(shift(@files)) while -d $files[0];
=cut
sub readdirectory {
my $dir=shift;
opendir(my $D,$dir);
my @filer=map "$dir/$_", grep {!/^\.\.?$/} readdir($D);
closedir($D);
return @filer;
}
=head2 basename
The basename and dirname functions behaves like the *nix shell commands with the same names.
B<Input:> One or two arguments: Filename and an optional suffix
B<Output:> Returns the filename with any directory and (if given) the suffix removed.
basename('/usr/bin/perl') # returns 'perl'
basename('/usr/local/bin/report.pl','.pl') # returns 'report' since .pl at the end is removed
basename('report2.pl','.pl') # returns 'report2'
basename('report2.pl','.\w+') # returns 'report2.pl', probably not what you meant
basename('report2.pl',qr/.\w+/) # returns 'report2', use qr for regex
=head2 dirname
B<Input:> A filename including path
B<Output:> Removes the filename path and returns just the directory path up until but not including
the last /. Return just a one char C<< . >> (period string) if there is no directory in the input.
dirname('/usr/bin/perl') # returns '/usr/bin'
dirname('perl') # returns '.'
=head2 username
Returns the current linux/unix username, for example the string root
print username(); #just (getpwuid($<))[0] but more readable perhaps
=cut
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)=@_;
$times||=3;
croak "ERROR: File $file nonexisting\n" if not -f $file or not -e $file;
my $size=-s$file;
open my $WIFH, '+<', $file or croak "ERROR: Unable to open $file: $!\n";
binmode($WIFH);
for(1..$times){
my $block=chr(int(rand(256))) x 1024;#hm
for(0..($size/1024)){
seek($WIFH,$_*1024,0);
print $WIFH $block;
}
}
close($WIFH);
$keep || unlink($file);
}
=head2 chall
Does chmod + utime + chown on one or more files.
Returns the number of files of which those operations was successful.
Mode, uid, gid, atime and mtime are set from the array ref in the first argument.
The first argument references an array which is exactly like an array returned from perls internal C<stat($filename)> -function.
Example:
my @stat=stat($filenameA);
chall( \@stat, $filenameB, $filenameC, ... ); # by stat-array
chall( $filenameA, $filenameB, $filenameC, ... ); # by file name
Copies the chmod, owner, group, access time and modify time from file A to file B and C.
See C<perldoc -f stat>, C<perldoc -f chmod>, C<perldoc -f chown>, C<perldoc -f utime>
=cut
sub chall {
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks )
= ref($_[0]) ? @{shift()} : stat(shift());
my $successful=0;
for(@_){ chmod($mode,$_) && utime($atime,$mtime,$_) && chown($uid,$gid,$_) && $successful++ }
return $successful;
}
=head2 makedir
Input: One or two arguments.
my($dd,$mm,$yyyy,$str) = s2t("18/february/2019:13:53","DD","MM","YYYY","YYYYMMDD-HH24:MI:SS")
print "dd: $dd mm: $mm yyyy: $yyyy str: $str\n"; # dd: 18 mm: 02 yyyy: 2019 str: 20190218-13:53:00
=cut
sub s2t {
require Date::Parse;
my $s=shift;
if($s=~/\b(?:mai|okt|des|juni|juli|februar)/i){ #fix norwegian/danish (for now)
$s=~s/\bMai\b/May/i; $s=~s/\bmai\b/may/i; $s=~s/\bMAI\b/MAY/i;
$s=~s/\bOkt\b/Oct/i; $s=~s/\bokt\b/oct/i; $s=~s/\bOKT\b/OCT/i;
$s=~s/\bDes/Dec/; $s=~s/\bdes/dec/; $s=~s/\bDES/DEC/;
$s=~s/\bFebruar\b/February/; $s=~s/\bfebruar\b/february/; $s=~s/\bFEBRUAR\b/FEBRUARY/;
$s=~s/\bjuli\b/July/i;
$s=~s/\bjuni\b/June/i;
}
elsif($s =~ /^[19]\d{9}$/){ $s=localtime($s) } #hm, make faster
elsif($s =~ /^[19]\d{12}$/
and int($s/1000) =~ /^[19]\d{9}$/){ $s=localtime($s/1000) } #hm
elsif($s=~/^((?:17|18|19|20|21)\d\d)(0[1-9]|1[012])(0[1-9]|[12]\d|3[01])$/){#hm
$s="$1-$2-$3T00:00:00";
}
return Date::Parse::str2time($s) if !@_;
return tms(Date::Parse::str2time($s),shift(@_)) if 0+@_ == 1;
return map tms(Date::Parse::str2time($s),$_), @_;
}
sub date_ok {
my($y,$m,$d)=@_;
return date_ok($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/;
return 0 if $y!~/^\d\d\d\d$/;
return 0 if $m<1||$m>12||$d<1||$d>(31,$y%4||$y%100==0&&$y%400?28:29,31,30,31,30,31,31,30,31,30,31)[$m-1];
return 1;
}
sub weeknum {
return weeknum(tms('YYYYMMDD')) if @_<1;
return weeknum($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/;
my($year,$month,$day)= @_;
eval{
if(@_<2){
if($year=~/^\d{8}$/) { ($year,$month,$day)=unpack("A4A2A2",$year) }
elsif($year>99999999){ ($year,$month,$day)=(localtime($year))[5,4,3]; $year+=1900; $month++ }
else {die}
}
elsif(@_!=3){croak}
croak if !date_ok(sprintf("%04d%02d%02d",$year,$month,$day));
};
croak "ERROR: Wrong args Acme::Tools::weeknum(".join(",",@_).")" if $@;
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);
#todo? $is_date=0 if $time=~s/^\@(\-?\d)/$1/; #@n where n is sec since epoch makes it clear that its not a formatted, as in `date`
#todo? date --date='TZ="America/Los_Angeles" 09:00 next Fri' #`info date`
# Fri Nov 13 18:00:00 CET 2015
#date --date="next Friday" #--date or -d
#date --date="last friday"
#date --date="2 days ago"
#date --date="yesterday" #or tomorrow
#date --date="-1 day" #date --date='10 week'
if( $is_date ){
my $yy2c=sub{10+$_[0]>$lt[5]%100?"20":"19"}; #hm 10+
$time=totime(&$yy2c($1)."$1$2$3")."000000" if $time=~/^(\d\d)(\d\d)(\d\d)$/;
$time=totime("$1$2${3}000000") if $time=~/^((?:18|19|20)\d\d)(\d\d)(\d\d)$/; #hm 18-20?
}
else {
$time = yyyymmddhh24miss_time("$1$2$3$4$5$6") #yyyymmddhh24miss_time ???
if $time=~/^((?:19|20|18)\d\d) #yyyy
(0[1-9]|1[012]) #mm
(0[1-9]|[12]\d|3[01]) \-? #dd
([01]\d|2[0-3]) \:? #hh24
([0-5]\d) \:? #mi
([0-5]\d) $/x; #ss
}
tms_init() if !$_tms_inited;
return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]) if !$format;
my %p=('%'=>'%',
a=>'Dy',
A=>'Day',
b=>'Mon',
b=>'Month',
c=>'Dy Mon D HH:MI:SS YYYY',
C=>'CC',
d=>'DD',
D=>'MM/DD/YY',
e=>'D',
F=>'YYYY-MM-DD',
#G=>'',
h=>'Month', H=>'HH24', I=>'HH12',
j=>'DoY', #day of year
k=>'H24', _H=>'H24',
l=>'H12', _I=>'H12',
m=>'MM', M=>'MI',
n=>"\n",
#N=>'NS', #sprintf%09d,1e9*(time_fp()-time()) #000000000..999999999
p=>'AM', #AM|PM upper (yes, opposite: date +%H%M%S%P%p)
P=>'am', #am|pm lower
S=>'SS',
t=>"\t",
T=>'HH24:MI:SS',
u=>'DoW', #day of week 1..7, 1=mon 7=sun
sleep_fp() work as the built in C<< sleep() >> but also accepts fractional seconds:
sleep_fp(0.020); # sleeps for 20 milliseconds
Sub sleep_fp do a C<require Time::HiRes>, thus it might take some
extra time the first call. To avoid that, add C<< use Time::HiRes >>
to your code. Sleep_fp should not be trusted for accuracy to more than
a tenth of a second. Virtual machines tend to be less accurate (sleep
longer) than physical ones. This was tested on VMware and RHEL
(Linux). See also L<Time::HiRes>.
=head2 sleeps
=head2 sleepms
=head2 sleepus
=head2 sleepns
sleep_fp(0.020); #sleeps for 20 milliseconds
sleeps(0.020); #sleeps for 20 milliseconds, sleeps() is a synonym to sleep_fp()
sleepms(20); #sleeps for 20 milliseconds
sleepus(20000); #sleeps for 20000 microseconds = 20 milliseconds
sleepns(20000000); #sleeps for 20 million nanoseconds = 20 milliseconds
=cut
sub sleep_fp { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) }
sub sleeps { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) }
sub sleepms { eval{require Time::HiRes} or (sleep(shift()/1e3),return);Time::HiRes::sleep(shift()/1e3) }
sub sleepus { eval{require Time::HiRes} or (sleep(shift()/1e6),return);Time::HiRes::sleep(shift()/1e6) }
sub sleepns { eval{require Time::HiRes} or (sleep(shift()/1e9),return);Time::HiRes::sleep(shift()/1e9) }
=head2 eta
Estimated time of arrival (ETA).
for(@files){
...do work on file...
my $eta = eta( ++$i, 0+@files ); # file now, number of files
print "" . localtime($eta);
}
TODO: eta is borken and out of wack, good idea?: http://en.wikipedia.org/wiki/Kalman_filter
=head2 etahhmm
...NOT YET
=cut
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;
}
my $avg=$sum/$sumw;
return $avg;
# return avg(@eta);
#return $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-2][1])/($$a[-1][0]-$$a[-2][0]);
1;
}
=head2 sleep_until
sleep_until(0.5) sleeps until half a second has passed since the last
call to sleep_until. This example starts the next job excactly ten
seconds after the last job started even if the last job lasted for a
while (but not more than ten seconds):
for(@jobs){
sleep_until(10);
print localtime()."\n";
...heavy job....
}
Might print:
Thu Jan 12 16:00:00 2012
Thu Jan 12 16:00:10 2012
Thu Jan 12 16:00:20 2012
...and so on even if the C<< ...heavy job... >>-part takes more than a
second to complete. Whereas if sleep(10) was used, each job would
spend more than ten seconds in average since the work time would be
added to sleep(10).
Note: sleep_until() will remember the time of ANY last call of this sub,
not just the one on the same line in the source code (this might change
in the future). The first call to sleep_until() will be the same as
sleep_fp() or Perl's own sleep() if the argument is an integer.
=cut
our $Time_last_sleep_until;
sub sleep_until {
my $s=@_==1?shift():0;
my $time=time_fp();
my $sleep=$s-($time-nvl($Time_last_sleep_until,0));
$Time_last_sleep_until=time;
sleep_fp($sleep) if $sleep>0;
}
my %thr;
sub throttle {
my($times,$mintime,$what)=@_;
$what||=join(":",@{[caller(1)]}[3,2]);
$thr{$what}||=[];
my $thr=$thr{$what};
push @$thr,time_fp();
return if @$thr<$times;
my $since=$$thr[-1]-shift(@$thr);
my $sleep=$since<$mintime?$mintime-$since:0;
sleep_fp($sleep);
return $sleep;
}
=head2 leapyear
B<Input:> A year. A four digit number.
B<Output:> True (1) or false (0) of whether the year is a leap year or
not. (Uses current calendar even for periods before leapyears was used).
print join(", ",grep leapyear($_), 1900..2014)."\n";
1904, 1908, 1912, 1916, 1920, 1924, 1928, 1932, 1936, 1940, 1944, 1948, 1952, 1956,
1960, 1964, 1968, 1972, 1976, 1980, 1984, 1988, 1992, 1996, 2000, 2004, 2008, 2012
Note: 1900 is not a leap year, but 2000 is. Years divided by 100 is a leap year only
if it can be divided by 400.
=cut
sub leapyear{$_[0]%400?$_[0]%100?$_[0]%4?0:1:0:1} #bool
#http://rosettacode.org/wiki/Levenshtein_distance#Perl
our %ldist_cache;
sub ldist {
my($s,$t,$l) = @_;
return length($t) if !$s;
return length($s) if !$t;
%ldist_cache=() if !$l and 1000<0+%ldist_cache;
$ldist_cache{$s,$t} ||=
do {
my($s1,$t1) = ( substr($s,1), substr($t,1) );
substr($s,0,1) eq substr($t,0,1)
? ldist($s1,$t1)
: 1 + min( ldist($s1,$t1,1+$l), ldist($s,$t1,1+$l), ldist($s1,$t,1+$l) );
};
}
=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()>.
C<decode()> and C<decode_num()> accordingly uses perl operators C<eq> and C<==> for comparison.
Examples:
my $a=123;
print decode($a, 123,3, 214,4, $a); # prints 3
print decode($a, 123=>3, 214=>4, $a); # prints 3, same thing since => is synonymous to comma in Perl
The first argument is tested against the second, fourth, sixth and so on,
and then the third, fifth, seventh and so on is
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:
{123=>3, 214=>7}->{$a} || $a # (beware of 0)
=cut
sub decode {
croak "Must have a mimimum of two arguments" if @_<2;
my $uttrykk=shift;
if(defined$uttrykk){ shift eq $uttrykk and return shift or shift for 1..@_/2 }
else { !defined shift and return shift or shift for 1..@_/2 }
return shift;
}
sub decode_num {
croak "Must have a mimimum of two arguments" if @_<2;
my $uttrykk=shift;
if(defined$uttrykk){ shift == $uttrykk and return shift or shift for 1..@_/2 }
else { !defined shift and return shift or shift for 1..@_/2 }
return shift;
}
=head2 qrlist
Input: An array of values to be used to test againts for existence.
Output: A reference to a regular expression. That is a C<qr//>
The regex sets $1 if it match.
Example:
my @list=qw/ABc XY DEF DEFG XYZ/;
my $filter=qrlist("ABC","DEF","XY."); # makes a regex of it qr/^(\QABC\E|\QDEF\E|\QXY.\E)$/
my @filtered= grep { $_ =~ $filter } @list; # returns DEF and XYZ, but not XYZ because the . char is taken literally
Note: Filtering with hash lookups are WAY faster.
Source:
sub qrlist (@) { my $str=join"|",map quotemeta, @_; qr/^($str)$/ }
=cut
sub qrlist (@) {
my $str=join"|",map quotemeta,@_;
return qr/^($str)$/;
}
=head2 ansicolor
Perhaps easier to use than L<Term::ANSIColor> ?
B<Input:> One argument. A string where the char C<¤> have special
meaning and is replaced by color codings depending on the letter
following the C<¤>.
B<Output:> The same string, but with C<¤letter> replaced by ANSI color
codes respected by many types terminal windows. (xterm, telnet, ssh,
telnet, rlog, vt100, cygwin, rxvt and such...).
B<Codes for ansicolor():>
¤r red
¤g green
¤b blue
¤y yellow
¤m magenta
¤B bold
¤u underline
¤c clear
¤¤ reset, quits and returns to default text color.
B<Example:>
print ansicolor("This is maybe ¤ggreen¤¤?");
Prints I<This is maybe green?> where the word I<green> is shown in green.
If L<Term::ANSIColor> is not installed or not found, returns the input
string with every C<¤> including the following code letters
removed. (That is: ansicolor is safe to use even if Term::ANSIColor is
not installed, you just don't get the colors).
See also L<Term::ANSIColor>.
=cut
sub ansicolor {
my $txt=shift;
eval{require Term::ANSIColor} or return replace($txt,qr/¤./);
my %h=qw/r red g green b blue y yellow m magenta B bold u underline c clear ¤ reset/;
my $re=join"|",keys%h;
$txt=~s/¤($re)/Term::ANSIColor::color($h{$1})/ge;
return $txt;
}
=head2 ccn_ok
Checks if a Credit Card number (CCN) has correct control digits according to the LUHN-algorithm from 1960.
This method of control digits is used by MasterCard, Visa, American Express,
Discover, Diners Club / Carte Blanche, JCB and others.
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
'Visa' 4 13 eller 16
'American Express' 34 eller 37 15
'Discover' 6011 16
'Diners Club / Carte Blanche' 300-305, 36 eller 38 14
'JCB' 3 16
'JCB' 2131 eller 1800 15
And should perhaps have had:
'enRoute' 2014 eller 2149 15
...but that card uses either another control algorithm or no control
digits at all. So C<enRoute> is never returned here.
If the control digits is valid, but the input does not match anything in the column C<starts on>, 1 is returned.
(This is also the same control digit mechanism used in Norwegian KID numbers on payment bills)
The first digit in a credit card number is supposed to tell what "industry" the card is meant for:
MII Digit Value Issuer Category
--------------------------- ----------------------------------------------------
0 ISO/TC 68 and other industry assignments
1 Airlines
2 Airlines and other industry assignments
3 Travel and entertainment
4 Banking and financial
5 Banking and financial
6 Merchandizing and banking
7 Petroleum
8 Telecommunications and other industry assignments
9 National assignment
...although this has no meaning to C<Acme::Tools::ccn_ok()>.
The first six digits is I<Issuer Identifier>, that is the bank
(probably). The rest in the "account number", except the last digits,
which is the control digit. Max length on credit card numbers are 19
digits.
=cut
sub ccn_ok {
my $ccn=shift(); #credit card number
$ccn=~s/\D+//g;
if(KID_ok($ccn)){
return "MasterCard" if $ccn=~/^5[1-5]\d{14}$/;
return "Visa" if $ccn=~/^4\d{12}(?:\d{3})?$/;
return "American Express" if $ccn=~/^3[47]\d{13}$/;
return "Discover" if $ccn=~/^6011\d{12}$/;
return "Diners Club / Carte Blanche" if $ccn=~/^3(?:0[0-5]\d{11}|[68]\d{12})$/;
return "JCB" if $ccn=~/^(?:3\d{15}|(?:2131|1800)\d{11})$/;
return 1;
}
#return "enRoute" if $ccn=~/^(?:2014|2149)\d{11}$/; #ikke LUHN-krav?
return 0;
}
=head2 KID_ok
Checks if a norwegian KID number has an ok control digit.
To check if a customer has typed the number correctly.
This uses the LUHN algorithm (also known as mod-10) from 1960 which is also used
internationally in control digits for credit card numbers, and Canadian social security ID numbers as well.
The algorithm, as described in Phrack (47-8) (a long time hacker online publication):
"For a card with an even number of digits, double every odd numbered
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:>
One or more numeric arguments:
First: x (first returned element)
Second: y (up to y but not including y)
Third: step, default 1. The step between each returned element
If a fourth, fifth and so on arguments are given, they change the step for each returned element. As first derivative, second derivative.
B<Output:>
If one argument: returns the array C<(0 .. x-1)>
If two arguments: returns the array C<(x .. y-1)>
If three arguments: The default step is 1. Use a third argument to use a different step.
B<Examples:>
print join ",", range(11); # prints 0,1,2,3,4,5,6,7,8,9,10 (but not 11)
print join ",", range(2,11); # 2,3,4,5,6,7,8,9,10 (but not 11)
print join ",", range(11,2,-1); # 11,10,9,8,7,6,5,4,3
print join ",", range(2,11,3); # 2,5,8
print join ",", range(11,2,-3); # 11,8,5
print join ",", range(11,2,+3); # prints nothing
print join ", ",range(2,11,1,0.1); # 2, 3, 4.1, 5.3, 6.6, 8, 9.5 adds 0.1 to step each time
print join ", ",range(2,11,1,0.1,-0.01); # 2, 3, 4.1, 5.29, 6.56, 7.9, 9.3, 10.75
Note: In the Python language and others, C<range> is a build in iterator (a
generator), not an array. This saves memory for large sets and sometimes time.
Use C<range> in L<List::Gen> to get a similar lazy generator in Perl.
=cut
sub range {
return _range_accellerated(@_) if @_>3; #see below
my($x,$y,$jump)=@_;
return ( 0 .. $x-1 ) if @_==1;
return ( $x .. $y-1 ) if @_==2;
croak "Wrong number of arguments or jump==0" if @_!=3 or $jump==0;
my @r;
if($jump>0){ while($x<$y){ push @r, $x; $x+=$jump } }
else { while($x>$y){ push @r, $x; $x+=$jump } }
return @r;
}
#jumps derivative, double der., trippled der usw
sub _range_accellerated {
n, this many time took that many seconds:
n times seconds
-- ------- ---------
2 100000 0.32
3 10000 0.09
4 10000 0.33
5 1000 0.18
6 100 0.27
7 10 0.21
8 1 0.17
9 1 1.63
10 1 17.00
If the first argument is a coderef, that sub will be called for each permutation and the return from those calls with be the real return from C<permutations()>. For example this:
print for permutations(sub{join"",@_},1..3);
...will print the same as:
print for map join("",@$_), permutations(1..3);
...but the first of those two uses less RAM if 3 has been say 9.
Changing 3 with 10, and many computers hasn't enough memory
for the latter.
The examples prints:
123
132
213
231
312
321
If you just want to say calculate something on each permutation,
but is not interested in the list of them, you just don't
take the return. That is:
my $ant;
permutations(sub{$ant++ if $_[-1]>=$_[0]*2},1..9);
...is the same as:
$$_[-1]>=$$_[0]*2 and $ant++ for permutations(1..9);
...but the first uses next to nothing of memory compared to the latter. They have about the same speed.
(The examples just counts the permutations where the last number is at least twice as large as the first)
C<permutations()> was created to find all combinations of a persons
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]],
[@_[0,3,1,2]],[@_[0,3,2,1]],[@_[1,0,2,3]],[@_[1,0,3,2]],
[@_[1,2,0,3]],[@_[1,2,3,0]],[@_[1,3,0,2]],[@_[1,3,2,0]],
[@_[2,0,1,3]],[@_[2,0,3,1]],[@_[2,1,0,3]],[@_[2,1,3,0]],
[@_[2,3,0,1]],[@_[2,3,1,0]],[@_[3,0,1,2]],[@_[3,0,2,1]],
[@_[3,1,0,2]],[@_[3,1,2,0]],[@_[3,2,0,1]],[@_[3,2,1,0]]) if @_==4;
return ([@_[0,1,2,3,4]],[@_[0,1,2,4,3]],[@_[0,1,3,2,4]],[@_[0,1,3,4,2]],[@_[0,1,4,2,3]],
[@_[0,1,4,3,2]],[@_[0,2,1,3,4]],[@_[0,2,1,4,3]],[@_[0,2,3,1,4]],[@_[0,2,3,4,1]],
[@_[0,2,4,1,3]],[@_[0,2,4,3,1]],[@_[0,3,1,2,4]],[@_[0,3,1,4,2]],[@_[0,3,2,1,4]],
[@_[0,3,2,4,1]],[@_[0,3,4,1,2]],[@_[0,3,4,2,1]],[@_[0,4,1,2,3]],[@_[0,4,1,3,2]],
[@_[0,4,2,1,3]],[@_[0,4,2,3,1]],[@_[0,4,3,1,2]],[@_[0,4,3,2,1]],[@_[1,0,2,3,4]],
[@_[1,0,2,4,3]],[@_[1,0,3,2,4]],[@_[1,0,3,4,2]],[@_[1,0,4,2,3]],[@_[1,0,4,3,2]],
[@_[1,2,0,3,4]],[@_[1,2,0,4,3]],[@_[1,2,3,0,4]],[@_[1,2,3,4,0]],[@_[1,2,4,0,3]],
[@_[1,2,4,3,0]],[@_[1,3,0,2,4]],[@_[1,3,0,4,2]],[@_[1,3,2,0,4]],[@_[1,3,2,4,0]],
[@_[1,3,4,0,2]],[@_[1,3,4,2,0]],[@_[1,4,0,2,3]],[@_[1,4,0,3,2]],[@_[1,4,2,0,3]],
[@_[1,4,2,3,0]],[@_[1,4,3,0,2]],[@_[1,4,3,2,0]],[@_[2,0,1,3,4]],[@_[2,0,1,4,3]],
[@_[2,0,3,1,4]],[@_[2,0,3,4,1]],[@_[2,0,4,1,3]],[@_[2,0,4,3,1]],[@_[2,1,0,3,4]],
[@_[2,1,0,4,3]],[@_[2,1,3,0,4]],[@_[2,1,3,4,0]],[@_[2,1,4,0,3]],[@_[2,1,4,3,0]],
[@_[2,3,0,1,4]],[@_[2,3,0,4,1]],[@_[2,3,1,0,4]],[@_[2,3,1,4,0]],[@_[2,3,4,0,1]],
[@_[2,3,4,1,0]],[@_[2,4,0,1,3]],[@_[2,4,0,3,1]],[@_[2,4,1,0,3]],[@_[2,4,1,3,0]],
[@_[2,4,3,0,1]],[@_[2,4,3,1,0]],[@_[3,0,1,2,4]],[@_[3,0,1,4,2]],[@_[3,0,2,1,4]],
[@_[3,0,2,4,1]],[@_[3,0,4,1,2]],[@_[3,0,4,2,1]],[@_[3,1,0,2,4]],[@_[3,1,0,4,2]],
[@_[3,1,2,0,4]],[@_[3,1,2,4,0]],[@_[3,1,4,0,2]],[@_[3,1,4,2,0]],[@_[3,2,0,1,4]],
[@_[3,2,0,4,1]],[@_[3,2,1,0,4]],[@_[3,2,1,4,0]],[@_[3,2,4,0,1]],[@_[3,2,4,1,0]],
[@_[3,4,0,1,2]],[@_[3,4,0,2,1]],[@_[3,4,1,0,2]],[@_[3,4,1,2,0]],[@_[3,4,2,0,1]],
[@_[3,4,2,1,0]],[@_[4,0,1,2,3]],[@_[4,0,1,3,2]],[@_[4,0,2,1,3]],[@_[4,0,2,3,1]],
[@_[4,0,3,1,2]],[@_[4,0,3,2,1]],[@_[4,1,0,2,3]],[@_[4,1,0,3,2]],[@_[4,1,2,0,3]],
[@_[4,1,2,3,0]],[@_[4,1,3,0,2]],[@_[4,1,3,2,0]],[@_[4,2,0,1,3]],[@_[4,2,0,3,1]],
[@_[4,2,1,0,3]],[@_[4,2,1,3,0]],[@_[4,2,3,0,1]],[@_[4,2,3,1,0]],[@_[4,3,0,1,2]],
[@_[4,3,0,2,1]],[@_[4,3,1,0,2]],[@_[4,3,1,2,0]],[@_[4,3,2,0,1]],[@_[4,3,2,1,0]]) if @_==5;
my(@r,@p,@c,@i,@n); @i=(0,@_); @p=@c=1..@_; @n=1..@_-1;
PERM:
while(1){
if($code){if(defined wantarray){push(@r,&$code(@i[@p]))}else{&$code(@i[@p])}}else{push@r,[@i[@p]]}
for my$i(@n){splice@p,$i,0,shift@p;next PERM if --$c[$i];$c[$i]=$i+1}
return@r
}
}
=head2 perm
print @$_,"\n" for perm("a".."c"); # prints six lines: abc acb bac bca cab cba
=head2 permute
my $c = permute { print @_,"\n" } "a".."c"; # prints six lines: abc acb bac bca cab cba
print "count: $c\n"; # prints 6 = 3*2*1 = 3!
The permute BLOCK needs to return true (which print does) for permute to continue:
Report B
Year Season Height Height Height Weight Weight Weight Weight
Gerd Hilde Per Gerd Hilde Per Tone
---- ------ ------ ------ ----- ----- ------ ------ ------
1997 Summer 170 168 182 66 62 75 70
1997 Winter 158 164 180 64 61 73 69
1998 Summer 171 168 182 64 62 76 70
1998 Winter 171 168 183 64 62 74 71
.
my @reportC=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name","Attributt");
print "\n\nReport C\n\n".tablestring(\@reportC);
Will print:
Report C
Name Attributt 1997 1997 1998 1998
Summer Winter Summer Winter
----- --------- ------ ------ ------ ------
Gerd Height 170 158 171 171
Gerd Weight 66 64 64 64
Hilde Height 168 164 168 168
Hilde Weight 62 61 62 62
Per Height 182 180 182 183
Per Weight 75 73 76 74
Tone Weight 70 69 70 71
.
my @reportD=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name");
print "\n\nReport D\n\n".tablestring(\@reportD);
Will print:
Report D
Name Height Height Height Height Weight Weight Weight Weight
1997 1997 1998 1998 1997 1997 1998 1998
Summer Winter Summer Winter Summer Winter Summer Winter
----- ------ ------ ------ ------ ------ ------ ------ ------
Gerd 170 158 171 171 66 64 64 64
Hilde 168 164 168 168 62 61 62 62
Per 182 180 182 183 75 73 76 74
Tone 70 69 70 71
Options:
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){
my $rad=join($;,@$_[0..($antned-1)]);
my $felt=join($;,@$_[$antned..($bakerst-1)]);
my $verdi=$$_[$bakerst];
length($rad) or $rad=' ';
length($felt) or $felt=' ';
$h{$rad}{$felt}=$verdi;
$h{$rad}{"%$felt"}=$verdi;
if($opt_sum or defined $opt_pro){
$h{$rad}{Sum}+=$verdi;
$sum{$felt}+=$verdi;
$sum{Sum}+=$verdi;
}
$feltfinnes{$felt}++;
$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{
$verdi!=0?"div0":$verdi;
}
}
else{
$h{$rad}{$_};
}
}
@feltfinnes);
push(@t,[@rad]);
}
push(@t,"-",["Sum",(map{""}(2..$antned)),map{print "<$_>\n";$sum{$_}}@feltfinnes]) if $opt_sum;
return @t;
}
# default sortsub for pivot()
sub _sortsub {
no warnings;
#my $c=($a<=>$b)||($a cmp $b);
#return $c if $c;
#printf "%-30s %-30s ",replace($a,$;,','),replace($b,$;,',');
my @a=split $;,$a;
my @b=split $;,$b;
for(0..$#a){
my $c=$a[$_]<=>$b[$_];
return $c if $c and "$a[$_]$b[$_]"!~/[iI][nN][fF]|þ|∞/i; # hm inf(inity)
$c=$a[$_]cmp$b[$_];
return $c if $c;
}
return 0;
}
=head2 tablestring
B<Input:> a reference to an array of arrayrefs -- a two dimensional table of strings and numbers
B<Output:> a string containing the textual table -- a string of two or more lines
The first arrayref in the list refers to a list of either column headings (scalar)
or ... (...more later...)
In this output table:
- the columns will not be wider than necessary by its widest value (any <html>-tags are removed in every internal width-calculation)
- multi-lined cell values are handled also
- and so are html-tags, if the output is to be used inside <pre>-tags on a web page.
- columns with just numeric values are right justified (header row excepted)
my $line=$row_start_line+$_;
my $txt=shift(@cell);
$txt='' if !defined$txt;
$txt=sprintf("%*s",$width[$y]-1,$txt) if length($txt)>0 && !$left[$y] && ($x>0 || $no_header_line);
$tabout[$line].=$txt;
if($y==$j){
$tabout[$line]=~s/\s+$//;
}
else{
my $wider;
$wider = $txt=~/<input.+type=text.+size=(\d+)/i?1+$1:0;
$txt=~s/<[^>]+>//g;
$txt=~s/>/>/g;
$txt=~s/</</g;
$tabout[$line].= ' ' x ($width[$y]-length($txt)-$wider);
}
}
}
}
$row_start_line+=$height[$x];
#--lage streker?
if(not $no_header_line){
if($x==0){
for my $y (0..$j){
next if $remove_empty && !$not_empty[$y];
$tabout[$row_start_line].=('-' x ($width[$y]-1))." ";
}
$row_start_line++;
@header=("",@tabout);
}
elsif(
$x%$pagesize==0 || $nodup>0&&!$nodup[$x+1][$nodup-1]
and $x+1<@$tab
and !$no_header_line
)
{
push(@tabout,@header);
$row_start_line+=@header;
$header_last=1;
}
else{
$header_last=0;
}
}
}#for x
return join("\n",@tabout)."\n";
}
=head2 serialize
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:
- Code refs are not handled (just returns C<sub{die()}>)
- Regex, class refs and circular recursive structures are also not handled.
B<Examples:>
$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',
'3'=>\'5',
'4'=>'7',
'5'=>'11',
'6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}],
'7'=>'x');
Areas of use:
- Debugging (first and foremost)
- Storing arrays and hashes and data structures of those on file, database or sending them over the net
- eval earlier stored string to get back the data structure
Be aware of the security implications of C<eval>ing a perl code string
stored somewhere that unauthorized users can change them! You are
probably better of using L<YAML::Syck> or L<Storable> without
enabling the CODE-options if you have such security issues.
More on decompiling Perl-code: L<Storable> or L<B::Deparse>.
=head2 dserialize
Debug-serialize, dumping data structures for you to look at.
Same as C<serialize()> but the output is given a newline every 80th character.
(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).",";
$ret.="\n" if $level>=0;
}
$ret=~s/,$//;
$ret.=")";
$ret.=";\n" if $name;
return $ret;
}
elsif(ref($r) eq 'HASH'){
return "\%$name=".serialize($r,@r).";\n" if $name;
my $ret="(";
for(sort keys %$r){
$ret.=serialize(\$_,@r)."=>".serialize(\$$r{$_},@r).",";
$ret.="\n" if $level>=0;
}
$ret=~s/,$//;
$ret.=")";
$ret.=";\n" if $name;
return $ret;
}
elsif(ref($$r) eq 'ARRAY'){
return "\@$name=".serialize($r,@r).";\n" if $name;
my $ret="[";
for(@$$r){
$ret.=serialize(\$_,@r).",";
$ret.="\n" if !defined $level or $level>=0;
}
$ret=~s/,$//;
$ret.="]";
$ret.=";\n" if $name;
return $ret;
}
elsif(ref($$r) eq 'HASH'){
return "\%$name=".serialize($r,@r).";\n" if $name;
my $ret="{";
for(sort keys %$$r){
$ret.=serialize(\$_,@r)."=>".serialize(\$$$r{$_},@r).",";
$ret.="\n" if $level>=0;
}
$ret=~s/,$//;
$ret.="}";
$ret.=";\n" if $name;
return $ret;
}
elsif(ref($$r) eq 'SCALAR'){
return "\\".serialize($$r,@r);
}
elsif(ref($r) eq 'LVALUE'){
my $s="$$r";
return serialize(\$s,@r);
}
$r;
}
=head2 sys
Call instead of C<system> if you want C<die> (Carp::croak) when something fails.
sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" }
=cut
sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" }
=head2 recursed
Returns true or false (actually 1 or 0) depending on whether the
current sub has been called by itself or not.
sub xyz
{
xyz() if not recursed;
}
=cut
sub recursed {(caller(1))[3] eq (caller(2))[3]?1:0}
=head2 ed
String editor commands
literals: a-z 0-9 space
move cursor: FBAEPN MF MB ME
delete: D Md
up/low/camelcase word U L C
backspace: -
search: S
return/enter: R
meta/esc/alt: M
shift: T
cut to eol: K
caps lock: C
yank: Y
start and end: < >
macro start/end/play: { } !
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) }
elsif($c eq 'D') { substr($s,$p,1)='' }
elsif($c eq 'MD'){ substr($s,$p)=~s/^(\W*\w+)// and $buf=$1 }
elsif($c eq 'MF'){ substr($s,$p)=~/(\W*\w+)/ and $p+=length($1) }
elsif($c eq 'MB'){ substr($s,0,$p)=~/(\w+\W*)$/ and $p-=length($1) }
elsif($c eq '-') { substr($s,--$p,1)='' if $p }
elsif($c eq 'M-'){ substr($s,0,$p)=~s/(\w+\W*)$// and $p-=length($buf=$1)}
elsif($c eq 'K') { substr($s,$p)=~s/(\S.+|\s*?\n)// and $buf=$1 }
elsif($c eq 'Y') { &$add($buf) }
elsif($c eq 'U') { substr($s,$p)=~s/(\W*)(\w+)/$1\U$2\E/; $p+=length($1.$2) }
elsif($c eq 'L') { substr($s,$p)=~s/(\W*)(\w+)/$1\L$2\E/; $p+=length($1.$2) }
elsif($c eq 'C') { substr($s,$p)=~s/(\W*)(\w+)/$1\u\L$2\E/; $p+=length($1.$2) }
elsif($c eq '<') { $p=0 }
elsif($c eq '>') { $p=length($s) }
elsif($c eq 'T') { $sh=1 }
elsif($c eq 'C') { $cl^=1 }
elsif($c eq '{') { $m=1; @m=() }
elsif($c eq '}') { $m=0 }
elsif($c eq '!') { $m||!@m and die"ed: no macro"; $cs=join("",@m).$cs }
elsif($c eq '""'){ &$add('"') }
else { croak "ed: Unknown cmd '$c'\n" }
push @m, $c if $m and $c ne '{';
#warn serialize([$c,$m,$cs],'d');
}
$Edcursor=$p;
$s;
}
=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);
=head1 JUST FOR FUN
=head2 brainfu
B<Input:> one or two arguments
First argument: a string, source code of the brainfu
language. String containing the eight charachters + - < > [ ] . ,
Every other char is ignored silently.
Second argument: if the source code contains commas (,) the second
argument is the input characters in a string.
B<Output:> The resulting output from the program.
Example:
print brainfu(<<""); #prints "Hallo Verden!\n"
++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>---.+++++++++++..+++.>++.<<++++++++++++++
.>----------.+++++++++++++.--------------.+.+++++++++.>+.>.
See L<http://en.wikipedia.org/wiki/Brainfuck>
=head2 brainfu2perl
Just as L</brainfu> but instead it return the perl code to which the
brainfu code is translated. Just C<< eval() >> this perl code to run.
Example:
print brainfu2perl('>++++++++[<++++++++>-]<++++++++.>++++++[<++++++>-]<---.');
Prints this string:
my($c,$o,@b)=(0); sub out{$o.=chr($b[$c]) for 1..$_[0]||1}
++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
++$b[$c];++$c;--$b[$c];}--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
++$b[$c];++$b[$c];out;++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$c;--$b[$c];}
--$c;--$b[$c];--$b[$c];--$b[$c];out;$o;
=head2 brainfu2perl_optimized
Just as L</brainfu2perl> but optimizes the perl code. The same
example as above with brainfu2perl_optimized returns this equivalent
but shorter perl code:
$b[++$c]+=8;while($b[$c]){$b[--$c]+=8;--$b[++$c]}$b[--$c]+=8;out;$b[++$c]+=6;
:@_==2 ? (@_,1,100,1)
: croak "Wrong number of arguments (".@_."), should be 2";
croak "p ($p) should be > 0 and < 1" if not ( 0<$p && $p<1 );
$m=-1*$_*$n/log(1-$p**(1/$_)) and (!defined $flen or $m<$flen) and ($flen,$k)=($m,$_) for $mink..$maxk;
$flen = int(1+$flen);
return ($flen,$k);
}
sub bfdimensions {
my($n,$p,$mink,$maxk)=
@_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'})
:@_==2 ? (@_,1,100)
: croak "Wrong number of arguments (".@_."), should be 2";
my $k=log(1/$p)/log(2); # k hash funcs
my $m=-$n*log($p)/log(2)**2; # m bits in filter
return ($m+0.5,min($maxk,max($mink,int($k+0.5))));
}
#crontab -e
#01 4,10,16,22 * * * /usr/bin/perl -MAcme::Tools -e'Acme::Tools::_update_currency_file("/var/www/html/currency-rates")' > /dev/null 2>&1
sub _update_currency_file { #call from cron
my $fn=shift()||'/var/www/html/currency-rates';
my %exe=map+($_=>"/usr/bin/$_"),qw/curl ci/;-x$_ or croak for values %exe;
open my $F, '>', $fn or die"ERROR: Could not write file $fn ($!)\n";
print $F "#-- Currency rates ".localtime()." (".time().")\n";
print $F "# File generated by Acme::Tools version $VERSION\n";
print $F "# Updated every 6th hour on http://calthis.com/currency-rates\n";
print $F "NOK 1.000000000\n";
my $amount=1000;
my $data=qx($exe{curl} -s "https://www.x-rates.com/table/?from=NOK&amount=$amount");
$data=~s,to=([A-Z]{3})(.)>,$2>$1</td><td>,g;
my @data=ht2t($data,"Alphabetical order"); shift @data;
@data=map "$$_[1] ".($$_[4]>1e-2?$$_[4]:$$_[2]?sprintf("%.8f",$amount/$$_[2]):0)."\n",@data;
my %data=map split,@data;
my $json=qx( $exe{curl} -s https://api.coinmarketcap.com/v1/ticker/ );
eval "require JSON;"; croak if $@;
my $arr=JSON::decode_json($json);
for my $c (qw(BTC LTC XBT ETH XRP BCH ETC)) {
my @a=grep$$_{symbol} eq $c,@$arr;
next if @a != 1 or !$a[0]{price_usd};
push @data, "$c ".($a[0]{price_usd}*$data{USD})."\n";
}
#die srlz(\@data,'data');
print $F sort(@data);
close($F);
qx($exe{ci} -l -m. -d $fn) if -w"$fn,v";
}
sub ftype {
my $f=shift;
-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 ($;$) { #
if ($] >= 5.006) {
require bytes;
croak "base64 failed: only defined for bytes"
if bytes::length($_[0]) > length($_[0])
or $] >= 5.008 && $_[0] =~ /[^\0-\xFF]/
}
my $eol=defined$_[1]?$_[1]:"\n";
my $res=pack("u",$_[0]);
$res=~s/^.//mg;
$res=~s/\n//g;
$res=~tr|` -_|AA-Za-z0-9+/|;
my $pad=(3-length($_[0])%3)%3;
$res=~s/.{$pad}$/'=' x $pad/e if $pad;
$res=~s/(.{1,76})/$1$eol/g if length($eol); #todo !=76
$res;
}
our $Fix_unbase64=0;
sub unbase64 ($) {
my $s=shift;
$s=~tr,0-9a-zA-Z+=/,,cd;
if($Fix_unbase64){ $s.='=' while length($s)%4 }
croak "unbase64 failed: length ".length($s)." not multiple of 4" if length($s)%4;
$s=~s/=+$//;
$s=~tr|A-Za-z0-9+/| -_|;
length($s) ? unpack("u",join'',map(chr(32+length($_)*3/4).$_,$s=~/(.{1,60})/gs)) : "";
}
=head1 COMMANDS
=head2 install_acme_command_tools
sudo perl -MAcme::Tools -e install_acme_command_tools
Wrote executable /usr/local/bin/conv
Wrote executable /usr/local/bin/due
Wrote executable /usr/local/bin/xcat
Wrote executable /usr/local/bin/freq
Wrote executable /usr/local/bin/deldup
Wrote executable /usr/local/bin/ccmd
Wrote executable /usr/local/bin/z2z
Wrote executable /usr/local/bin/2gz
Wrote executable /usr/local/bin/2gzip
Wrote executable /usr/local/bin/2bz2
Wrote executable /usr/local/bin/2bzip2
Wrote executable /usr/local/bin/2xz
Wrote executable /usr/local/bin/resubst
Examples of commands then made available:
( run in 1.942 second using v1.01-cache-2.11-cpan-d80b1682f3f )