Acme-Tools
view release on metacpan or search on metacpan
=head1 INSTALLATION
sudo cpan Acme::Tools
sudo cpanm Acme::Tools # after: sudo apt-get install cpanminus make # for Ubuntu 12.04
Or to get the very newest:
git clone https://github.com/kjetillll/Acme-Tools.git
cd Acme-Tools
perl Makefile.PL
make test
sudo make install
=head1 EXPORT
Almost every sub, about 90 of them.
Beware of namespace pollution. But what did you expect from an Acme module?
=head1 NUMBERS
=head2 num2code
See L</code2num>
=head2 code2num
C<num2code()> convert numbers (integers) from the normal decimal system to some arbitrary other number system.
That can be binary (2), oct (8), hex (16) or others.
Example:
print num2code(255,2,"0123456789ABCDEF"); # prints FF
print num2code( 14,2,"0123456789ABCDEF"); # prints 0E
...because 255 are converted to hex FF (base C<< length("0123456789ABCDEF") >> ) which is 2 digits of 0-9 or A-F.
...and 14 are converted to 0E, with leading 0 because of the second argument 2.
Example:
print num2code(1234,16,"01")
Prints the 16 binary digits 0000010011010010 which is 1234 converted to binary zeros and ones.
To convert back:
print code2num("0000010011010010","01"); #prints 1234
C<num2code()> can be used to compress numeric IDs to something shorter:
$chars="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-_";
print num2code("241274432",5,$chars); # prints EOOv0
print code2num("EOOv0",$chars); # prints 241274432
=cut
#Math::BaseCnv
sub num2code {
return num2code($_[0],0,$_[1]) if @_==2;
my($num,$digits,$validchars,$start)=@_;
my $l=length($validchars);
my $key;
$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) }
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
=item * number systems
=item * currencies
=back
B<Examples:>
print conv( 2000, "meters", "miles" ); #prints 1.24274238447467
print conv( 2.1, 'km', 'm'); #prints 2100
print conv( 70,"cm","in"); #prints 27.5590551181102
print conv( 4,"USD","EUR"); #prints 3.20481552905431 (depending on todays rates)
print conv( 4000,"b","kb"); #prints 3.90625 (1 kb = 1024 bytes)
print conv( 4000,"b","Kb"); #prints 4 (1 Kb = 1000 bytes)
print conv( 1000,"mb","kb"); #prints 1024000
print conv( 101010,"bin","roman"); #prints XLII
print conv( "DCCXLII","roman","oct"); #prints 1346
B<Units, types of measurement and currencies supported by C<conv> are:>
Note: units starting with the symbol _ means that all metric
prefixes from yocto 10^-24 to yotta 10^+24 is supported, so _m means
km, cm, mm, µm and so on. And _N means kN, MN GN and so on.
Note2: Many units have synonyms: m, meter, meters ...
acceleration: g, g0, m/s2, mps2
angle: binary_degree, binary_radian, brad, deg, degree, degrees,
gon, grad, grade, gradian, gradians, hexacontade, hour,
new_degree, nygrad, point, quadrant, rad, radian, radians,
sextant, turn
area: a, ar, are, ares, bunder, ca, centiare, cho, cm2,
daa, decare, decares, deciare, dekar,
djerib, m2, dunam, dönöm, earths, feddan, ft2, gongqing, ha
ha, hectare, hectares, hektar, jerib, km2, m2, manzana,
mi2, mm2, mu, qing, rai, sotka,
sqcm, sqft, sqkm, sqm, sqmi, sqmm
stremmata, um2, µm2
bytes: Eb, Gb, Kb, KiB, Mb, Pb, Tb, Yb, Zb, b, byte,
kb, kilobyte, mb, megabyte,
gb, gigabyte, tb, terabyte,
pb, petabyte, eb, exabyte,
zb, zettabyte, yb, yottabyte
charge: As, C, _e, coulomb, e
current: A, _A, N/m2
energy: BTU, Btu, J, Nm, W/s, Wh, Wps, Ws, _J, _eV,
cal, calorie, calories, eV, electronvolt, BeV,
erg, ergs, foot-pound, foot-pounds, ftlb, joule, kWh, MWh, GWh, TWh
kcal, kilocalorie, kilocalories,
newtonmeter, newtonmeters, th, thermie
force: N, _N, dyn, dyne, dynes, lb, newton
length: NM, _m, _pc, astronomical unit, au, chain, ft, furlong,
in, inch, inches, km, league, lightyear, ls, ly,
m, meter, meters, mi, mil, mile, miles,
nautical mile, nautical miles, nmi,
parsec, pc, planck, yard, yard_imperical, yd, Å, ångstrøm, angstrom
mass: Da, _eV, _g, bag, carat, ct, dwt, eV, electronvolt, g,
grain, grains, gram, grams, kilo, kilos, kt, lb, lb_av,
lb_t, lb_troy, lbs, ounce, ounce_av, ounce_troy, oz, oz_av, oz_t,
pennyweight, pound, pound_av, pound_metric, pound_troy, pounds,
pwt, seer, sl, slug, solar_mass, st, stone, t, tonn, tonne, tonnes, u, wey
mileage: mpg, l/100km, l/km, l/10km, lp10km, l/mil, liter_pr_100km, liter_pr_km, lp100km
money: AED, ARS, AUD, BGN, BHD, BND, BRL, BWP, CAD, CHF, CLP, CNY,
COP, CZK, DKK, EUR, GBP, HKD, HRK, HUF, IDR, ILS, INR, IRR,
ISK, JPY, KRW, KWD, KZT, LKR, LTL, LVL, LYD, MUR, MXN, MYR,
NOK, NPR, NZD, OMR, PHP, PKR, PLN, QAR, RON, RUB, SAR, SEK,
SGD, THB, TRY, TTD, TWD, USD, VEF, ZAR, BTC, LTC, mBTC, XBT
Currency rates are automatically updated from the net
at least every 24h since last update (on linux/cygwin).
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
Left or right pads a string to the given length by adding one or more spaces at the end for I<rpad> or at the start for I<lpad>.
B<Input:> First argument: string to be padded. Second argument: length of the output. Optional third argument: character(s) used to pad.
Default is space.
rpad('gomle',9); # 'gomle '
lpad('gomle',9); # ' gomle'
rpad('gomle',9,'-'); # 'gomle----'
lpad('gomle',9,'+'); # '++++gomle'
rpad('gomle',4); # 'goml'
lpad('gomle',4); # 'goml'
rpad('gomle',7,'xyz'); # 'gomlxy'
lpad('gomle',10,'xyz'); # 'xyzxygoml'
=head2 cpad
Center pads. Pads the string both on left and right equal to the given length. Centers the string. Pads right side first.
cpad('mat',5) eq ' mat '
cpad('mat',4) eq 'mat '
cpad('mat',6) eq ' mat '
cpad('mat',9) eq ' mat '
cpad('mat',5,'+') eq '+mat+'
cpad('MMMM',20,'xyzXYZ') eq 'xyzXYZxyMMMMxyzXYZxy'
=cut
sub upper {no warnings;my $s=@_?shift:$_;$s=~tr/a-zæøåäëïöü.âêîôûãõà èìòùáéÃóúýñð/A-ZÆØÅÄËÃÖÜ.ÂÊÎÔÛÃÕÀÈÌÒÙÃÉÃÓÚÃÑÃ/;$s}
sub lower {no warnings;my $s=@_?shift:$_;$s=~tr/A-ZÆØÅÄËÃÖÜ.ÂÊÎÔÛÃÕÀÈÌÒÙÃÉÃÓÚÃÑÃ/a-zæøåäëïöü.âêîôûãõà èìòùáéÃóúýñð/;$s}
sub trim {
return trim($_) if !@_;
return map trim($_), @_ if @_>1;
my $s=shift;
if(ref($s) eq 'SCALAR'){ $$s=~s,^\s+|(?<=\s)\s+|\s+$,,g; return $$s}
if(ref($s) eq 'ARRAY') { trim(\$_) for @$s; return $s }
$s=~s,^\s+|(?<=\s)\s+|\s+$,,g if defined $s;
$s;
}
sub rpad {
my($s,$l,$p)=@_;
$p=' ' if @_<3 or !length($p);
$s.=$p while length($s)<$l;
substr($s,0,$l);
}
sub lpad {
my($s,$l,$p)=@_;
$p=' ' if @_<3 or !length($p);
$l<length($s)
? substr($s,0,$l)
: substr($p x (1+$l/length($p)), 0, $l-length($s)).$s;
}
sub cpad {
my($s,$l,$p)=@_;
$p=' ' if @_<3 or !length($p);
my $ls=length($s);
return substr($s,0,$l) if $l<$ls;
$p=$p x (($l-$ls+2)/length($p));
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;
=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;
return @pw;
}
# =head1 veci
#
# Perls C<vec> takes 1, 2, 4, 8, 16, 32 and possibly 64 as its third argument.
#
# This limitation is removed with C<veci> (vec improved, but much slower)
#
# The third argument still needs to be 32 or lower (or possibly 64 or lower).
#
# =cut
#
# sub vecibs ($) {
# my($s,$o,$b,$new)=@_;
# if($b=~/^(1|2|4|8|16|32|64)$/){
# return vec($s,$o,$b)=$new if @_==4;
# return vec($s,$o,$b);
# }
# my $bb=$b<4?4:$b<8?8:$b<16?16:$b<32?32:$b<64?64:die;
# my $ob=int($o*$b/$bb);
# my $v=vec($s,$ob,$bb)*2**$bb+vec($s,$ob+1,$bb);
# $v & (2**$b-1)
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
on your web server (or perhaps naming the file .cgi is enough), and C<chmod +x
/.../cgi-bin/script> and the URL
L<http://some.server.somewhere/cgi-bin/script?name=HAL> will print
C<My name is HAL> to the web page.
L<http://some.server.somewhere/cgi-bin/script?name=Bond&name=+James+Bond> will print C<My name is Bond, James Bond>.
=cut
sub webparams {
my $query=shift();
$query=$ENV{QUERY_STRING} if !defined $query;
if(!defined $query and $ENV{REQUEST_METHOD} eq "POST"){
read(STDIN,$query , $ENV{CONTENT_LENGTH});
$ENV{QUERY_STRING}=$query;
}
my %R;
for(split("&",$query)){
next if !length($_);
my($nkl,$verdi)=map urldec($_),split("=",$_,2);
$R{$nkl}=exists$R{$nkl}?"$R{$nkl},$verdi":$verdi;
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.
Works like perls C<mkdir()> except that C<makedir()> will create nesessary parent directories if they dont exists.
First input argument: A directory name (absolute, starting with C< / > or relative).
Second input argument: (optional) permission bits. Using the normal C<< 0777^umask() >> as the default if no second input argument is provided.
Example:
makedir("dirB/dirC")
...will create directory C<dirB> if it does not already exists, to be able to create C<dirC> inside C<dirB>.
Returns true on success, otherwise false.
C<makedir()> memoizes directories it has checked for existence before (trading memory and for speed).
Thus directories removed during running the script is not discovered by makedir.
See also C<< perldoc -f mkdir >>, C<< man umask >>
=cut
our %MAKEDIR;
sub makedir {
my($d,$p,$dd)=@_;
$p=0777^umask() if !defined$p;
(
$MAKEDIR{$d} or -d$d or mkdir($d,$p) #or croak("mkdir $d, $p")
or ($dd)=($d=~m,^(.+)/+([^/]+)$,) and makedir($dd,$p) and mkdir($d,$p) #or die;
) and ++$MAKEDIR{$d};
}
=head2 md5sum
B<Input:> a filename (or a scalar ref to a string, see below)
B<Output:> a string of 32 hexadecimal chars from 0-9 or a-f.
Example, the md5sum gnu/linux command without options could be implementet like this:
use Acme::Tools;
print eval{ md5sum($_)." $_\n" } || $@ for @ARGV;
This sub requires L<Digest::MD5>, which is a core perl-module since
version 5.?.? It does not slurp the files or spawn new processes.
If the input argument is a scalar ref then the MD5 of the string referenced is returned in hex.
=cut
sub md5sum {
require Digest::MD5;
my $fn=shift;
return Digest::MD5::md5_hex($$fn) if ref($fn) eq 'SCALAR';
croak "md5sum: $fn is a directory (no md5sum)" if -d $fn;
open my $FH, '<', $fn or croak "Could not open file $fn for md5sum() $!";
binmode($FH);
my $r = eval { Digest::MD5->new->addfile($FH)->hexdigest };
croak "md5sum on $fn failed ($@)\n" if $@;
$r;
}
=head2 which
Returns the first executable program in $ENV{PATH} paths (split by : colon) with the given name.
echo $PATH
perl -MAcme::Tools -le 'print which("gzip")' # maybe prints /bin/gzip
=head2 read_conf
B<First argument:> A file name or a reference to a string with settings in the format described below.
B<Second argument, optional:> A reference to a hash. This hash will have the settings from the file (or stringref).
The hash do not have to be empty beforehand.
Returns a hash with the settings as in this examples:
my %conf = read_conf('/etc/your/thing.conf');
print $conf{sectionA}{knobble}; #prints ABC if the file is as shown below
print $conf{sectionA}{gobble}; #prints ZZZ, the last gobble
print $conf{switch}; #prints OK here as well, unsectioned value
print $conf{part2}{password}; #prints oh:no= x
File use for the above example:
switch: OK #before first section, the '' (empty) section
[sectionA]
knobble: ABC
gobble: XYZ #this gobble is overwritten by the gobble on the next line
gobble: ZZZ
[part2]
password: oh:no= x #should be better
text: { values starting with { continues
until reaching a line with }
Everything from # and behind is regarded comments and ignored. Comments can be on any line.
To keep a # char, put a \ in front of it.
A C< : > or C< = > separates keys and values. Spaces at the beginning or end of lines are
ignored (after removal of #comments), as are any spaces before and after : and = separators.
Empty lines or lines with no C< : > or C< = > is also ignored. Keys and values can contain
internal spaces and tabs, but not at the beginning or end.
Multi-line values must start and end with { and }. Using { and } keep spaces at the start
or end in both one-line and multi-line values.
Sections are marked with C<< [sectionname] >>. Section names, keys and values is case
sensitive. C<Key:values> above the first section or below and empty C<< [] >> is placed
both in the empty section in the returned hash and as top level key/values.
C<read_conf> can be a simpler alternative to the core module L<Config::Std> which has
its own hassles.
$Acme::Tools::Read_conf_empty_section=1; #default 0 (was 1 in version 0.16)
my %conf = read_conf('/etc/your/thing.conf');
print $conf{''}{switch}; #prints OK with the file above
print $conf{switch}; #prints OK here as well
=cut
our $Read_conf_empty_section=0;
sub read_conf {
my($fn,$hr)=(@_,{});
my $conf=ref($fn)?$$fn:readfile($fn);
$conf=~s,\s*(?<!\\)#.*,,g;
my($section,@l)=('',split"\n",$conf);
while(@l) {
my $l=shift@l;
if( $l=~/^\s*\[\s*(.*?)\s*\]/ ) {
$section=$1;
$$hr{$1}||={};
}
elsif( $l=~/^\s*([^\:\=]+?)\s*[:=]\s*(.*?)\s*$/ ) {
my $ml=sub{my$v=shift;$v.="\n".shift@l while $v=~/^\{[^\}]*$/&&@l;$v=~s/^\{(.*)\}\s*$/$1/s;$v=~s,\\#,#,g;$v};
my $v=&$ml($2);
$$hr{$section}{$1}=$v if length($section) or $Read_conf_empty_section;
$$hr{$1}=$v if !length($section);
}
}
%$hr;
}
# my $incfn=sub{return $1 if $_[0]=~m,^(/.+),;my$f=$fn;$f=~s,[^/]+$,$_[0],;$f};
# s,<INCLUDE ([^>]+)>,"".readfile(&$incfn($1)),eg; #todo
=head2 openstr
# returned from openstr:
open my $FH, openstr("fil.txt") or die; # fil.txt
open my $FH, openstr("fil.gz") or die; # zcat fil.gz |
open my $FH, openstr("fil.bz2") or die; # bzcat fil.bz2 |
open my $FH, openstr("fil.xz") or die; # xzcat fil.xz |
open my $FH, openstr(">fil.txt") or die; # > fil.txt
open my $FH, openstr(">fil.gz") or die; # | gzip > fil.gz
open my $FH, openstr(">fil.bz2") or die; # | bzip2 > fil.bz2
open my $FH, openstr(">fil.xz") or die; # | xz > fil.bz2
Environment variable PATH is used. So in the examples above, /bin/gzip
is returned instead of gzip if /bin is the first directory in
$ENV{PATH} containing an executable file gzip. Dirs /usr/bin, /bin and
/usr/local/bin is added to PATH in openstr(). They are checked even if
PATH is empty.
See also C<writefile()> and C<readfile()> for automatic compression and decompression using C<openstr>.
B<Examples:>
Prints C<< 3. july 1997 >> if thats the dato today:
perl -MAcme::Tools -le 'print timestr("D. month YYYY")'
print tms("HH24:MI"); # prints 23:55 if thats the time now
tms("HH24:MI",time()); # ...same,since time() is the default
tms("HH:MI",time()-5*60); # 23:50 if that was the time 5 minutes ago
tms("HH:MI",time()-5*60*60); # 18:55 if thats the time 5 hours ago
tms("Day Month Dth YYYY HH:MI"); # Saturday July 1st 2004 23:55 (big S, big J)
tms("Day D. Month YYYY HH:MI"); # Saturday 8. July 2004 23:55 (big S, big J)
tms("DAY D. MONTH YYYY HH:MI"); # SATURDAY 8. JULY 2004 23:55 (upper)
tms("dy D. month YYYY HH:MI"); # sat 8. july 2004 23:55 (small s, small j)
tms("Dy DD. MON YYYY HH12:MI am"); # Sat 08. JUL 2004 11:55 pm (HH12, am becomes pm if after 12)
tms("DD-MON-YYYY"); # 03-MAY-2004 (mon, english)
The following list of codes in the first argument will be replaced:
YYYY Year, four digits
YY Year, two digits, i.e. 04 instead of 2004
yyyy Year, four digits, but nothing if its the current year
YYYY|HH:MI Year if its another year than the current, a time in hours and minutes elsewise
MM Month, two digits. I.e. 08 for August
DD Day of month, two digits. I.e. 01 (not 1) for the first day in a month
D Day of month, one digit. I.e. 1 (not 01)
HH Hour. From 00 to 23.
HH24 Same as HH.
HH12 12 becomes 12 (never 00), 13 becomes 01, 14 02 and so on.
Note: 00 after midnight becomes 12 (am). Tip: always include the code
am in a format string that uses HH12.
MI Minutt. Fra 00 til 59.
SS Sekund. Fra 00 til 59.
am Becomes am or pm
pm Same
AM Becomes AM or PM (upper case)
PM Same
Month The full name of the month in English from January to December
MONTH Same in upper case (JANUARY)
month Same in lower case (january)
Mont Jan Feb Mars Apr May June July Aug Sep Oct Nov Dec
Mont. Jan. Feb. Mars Apr. May June July Aug. Sep. Oct. Nov. Dec. (always four chars)
Mon Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec (always three chars)
Day The full name of the weekday. Sunday to Saturday
Dy Three letters: Sun Mon Tue Wed Thu Fri Sat
DAY Upper case
DY Upper case
Dth 1st 2nd 3rd 4th 5th ... 11th 12th ... 20th 21st 22nd 23rd 24th ... 30th 31st
WW Week number of the year 01-53 according to the ISO8601-definition (which most countries uses)
WWUS Week number of the year 01-53 according to the most used definition in the USA.
Other definitions also exists.
epoch Converts a time string from YYYYMMDD-HH24:MI:SS, YYYYMMDD-HH24:MI:SS, YYYYMMDDTHH:MI:SS,
YYYY-MM-DDTHH:MI:SS or YYYYMMDD to the number of seconds since January 1st 1970.
Commonly known as the Unix epoch.
JDN Julian day number. Integer. The number of days since the day starting at noon on January 1 4713 BC
JD Same as JDN but a float accounting for the time of day
B<Third argument:> (optional) Is_date. False|true, default false. If true, the second argument is
interpreted as a date of the form YYYYMMDD, not as a number of seconds since epoch (January 1st 1970).
=cut
#Se også L</tidstrk> og L</tidstr>
our $Tms_pattern;
our %Tms_str=
('MÃ…NED' => [4, 'JANUAR','FEBRUAR','MARS','APRIL','MAI','JUNI','JULI',
'AUGUST','SEPTEMBER','OKTOBER','NOVEMBER','DESEMBER' ],
'MÃ¥ned' => [4, 'Januar','Februar','Mars','April','Mai','Juni','Juli',
'August','September','Oktober','November','Desember'],
'måned' => [4, 'januar','februar','mars','april','mai','juni','juli',
'august','september','oktober','november','desember'],
'MÃ…NE.' => [4, 'JAN.','FEB.','MARS','APR.','MAI','JUNI','JULI','AUG.','SEP.','OKT.','NOV.','DES.'],
'MÃ¥ne.' => [4, 'Jan.','Feb.','Mars','Apr.','Mai','Juni','Juli','Aug.','Sep.','Okt.','Nov.','Des.'],
'måne.' => [4, 'jan.','feb.','mars','apr.','mai','juni','juli','aug.','sep.','okt.','nov.','des.'],
'MÃ…NE' => [4, 'JAN','FEB','MARS','APR','MAI','JUNI','JULI','AUG','SEP','OKT','NOV','DES'],
'MÃ¥ne' => [4, 'Jan','Feb','Mars','Apr','Mai','Juni','Juli','Aug','Sep','Okt','Nov','Des'],
'måne' => [4, 'jan','feb','mars','apr','mai','juni','juli','aug','sep','okt','nov','des'],
'MÃ…N' => [4, 'JAN','FEB','MAR','APR','MAI','JUN','JUL','AUG','SEP','OKT','NOV','DES'],
'MÃ¥n' => [4, 'Jan','Feb','Mar','Apr','Mai','Jun','Jul','Aug','Sep','Okt','Nov','Des'],
'mån' => [4, 'jan','feb','mar','apr','mai','jun','jul','aug','sep','okt','nov','des'],
'MONTH' => [4, 'JANUARY','FEBRUARY','MARCH','APRIL','MAY','JUNE','JULY',
'AUGUST','SEPTEMBER','OCTOBER','NOVEMBER','DECEMBER'],
'Month' => [4, 'January','February','March','April','May','June','July',
'August','September','October','November','December'],
'month' => [4, 'january','february','march','april','may','june','july',
'august','september','october','november','december'],
'MONT.' => [4, 'JAN.','FEB.','MAR.','APR.','MAY','JUNE','JULY','AUG.','SEP.','OCT.','NOV.','DEC.'],
'Mont.' => [4, 'Jan.','Feb.','Mar.','Apr.','May','June','July','Aug.','Sep.','Oct.','Nov.','Dec.'],
'mont.' => [4, 'jan.','feb.','mar.','apr.','may','june','july','aug.','sep.','oct.','nov.','dec.'],
'MONT' => [4, 'JAN','FEB','MAR','APR','MAY','JUNE','JULY','AUG','SEP','OCT','NOV','DEC'],
'Mont' => [4, 'Jan','Feb','Mar','Apr','May','June','July','Aug','Sep','Oct','Nov','Dec'],
'mont' => [4, 'jan','feb','mar','apr','may','june','july','aug','sep','oct','nov','dec'],
'MON' => [4, 'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'],
'Mon' => [4, 'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'],
'mon' => [4, 'jan','feb','mar','apr','may','jun','jul','aug','sep','oct','nov','dec'],
'DAY' => [6, 'SUNDAY','MONDAY','TUESDAY','WEDNESDAY','THURSDAY','FRIDAY','SATURDAY'],
'Day' => [6, 'Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'],
'day' => [6, 'sunday','monday','tuesday','wednesday','thursday','friday','saturday'],
'DY' => [6, 'SUN','MON','TUE','WED','THU','FRI','SAT'],
'Dy' => [6, 'Sun','Mon','Tue','Wed','Thu','Fri','Sat'],
'dy' => [6, 'sun','mon','tue','wed','thu','fri','sat'],
'DAG' => [6, 'SØNDAG','MANDAG','TIRSDAG','ONSDAG','TORSDAG','FREDAG','LØRDAG'],
'Dag' => [6, 'Søndag','Mandag','Tirsdag','Onsdag','Torsdag','Fredag','Lørdag'],
'dag' => [6, 'søndag','mandag','tirsdag','onsdag','torsdag','fredag','lørdag'],
'DG' => [6, 'Søn','MAN','TIR','ONS','TOR','FRE','LØR'],
'Dg' => [6, 'SØn','Man','Tir','Ons','Tor','Fre','Lør'],
'dg' => [6, 'søn','man','tir','ons','tor','fre','lør'],
);
my $_tms_inited=0;
sub tms_init {
return if $_tms_inited++;
for(qw(MAANED Maaned maaned MAAN Maan maan),'MAANE.','Maane.','maane.'){
$Tms_str{$_}=$Tms_str{replace($_,"aa","Ã¥","AA","Ã…")};
}
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
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."
[@_[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:
my $c = permute { print @_,"\n"; rand()<.5 } "a".."d"; # probably prints less than 24 strings
print "count: $c\n"; # prints random number up to 24 = 4*3*2*1 = 4!
=head2 permute_continue
my @abc = ("a", "b", "c");
my @start = ("b", "a", "c"); # starting sequence to continue from
my $c = permute_continue { print @_,"\n" } \@abc, \@start; # prints four lines: bac bca cab cba
my $c = permute { print @_,"\n" } \@abc, \@start; # same, =permute_continue when coreref+arrayref+arrayref
print "count: $c\n"; # prints 6-2 = 3*2*1-2 = 3!-2
The permute BLOCK needs to return true (which print does) for permute to continue:
my $c = permute { print @_,"\n"; rand()<.5 } "a".."d"; # probably prints less than 24 strings
print "count: $c\n"; # prints random number up to 24 = 4*3*2*1 = 4!
=cut
sub perm {
my(@i,@r) = 0..$#_;
@_ || return;
while ( push @r, [@_[@i]] ) {
my $p = $#i || last;
--$p || last while $i[$p-1] > $i[$p];
push @i, reverse splice @i, my$q=$p;
++$q while $i[$p-1] > $i[$q];
@i[$p-1,$q] = @i[$q,$p-1];
}
@r
}
sub permute (&@) {
return permute_continue(@_) if 'CODE,ARRAY,ARRAY' eq join',',map ref,@_;
my $f = shift;
my @i = 0..$#_;
my $n = 0;
@_ || do{ &$f(@_); return 0 };
while ( ++$n and &$f(@_[@i]) ) {
my $p = $#i || last;
--$p || last while $i[$p-1] > $i[$p];
push @i, reverse splice @i, my$q=$p;
++$q while $i[$p-1] > $i[$q];
@i[$p-1,$q] = @i[$q,$p-1];
}
$n;
}
#Fischer-Krause permutation starting from a specific sequence, for example to farm out permute to more than one process
sub permute_continue (&\@\@) {
my ($f,$begin,$from) = @_;
my %h; @h{@$begin} = 0 .. $#$begin;
my @idx = @h{@$from};
my $n = 0;
while ( ++$n and &$f(@$begin[@idx]) ) {
my $p = $#idx || last;
--$p || last while $idx[$p-1] > $idx[$p];
push @idx, reverse splice @idx, my$q=$p;
++$q while $idx[$p-1] > $idx[$q];
@idx[$p-1,$q]=@idx[$q,$p-1];
}
$n
}
=head2 cart
Cartesian product
B<Easy usage:>
Input: two or more arrayrefs with accordingly x, y, z and so on number of elements.
Output: An array of x * y * z number of arrayrefs. The arrays being the cartesian product of the input arrays.
It can be useful to think of this as joins in SQL. In C<select> statements with
more than one table behind C<from>, but without any C<where> condition to join the tables.
B<Advanced usage, with condition(s):>
B<Input:>
- Either two or more arrayrefs with x, y, z and so on number of elements.
- Or coderefs to subs containing condition checks. Somewhat like C<where> conditions in SQL.
B<Output:> An array of x * y * z number of arrayrefs (the cartesian product)
minus the ones that did not fulfill the condition(s).
This of is as joins with one or more where conditions as coderefs.
The coderef input arguments can be placed last or among the array refs
to save both runtime and memory if the conditions depend on
arrays further back.
B<Examples, this:>
for(cart(\@a1,\@a2,\@a3)){
my($a1,$a2,$a3) = @$_;
print "$a1,$a2,$a3\n";
}
Prints the same as this:
for my $a1 (@a1){
for my $a2 (@a2){
for my $a3 (@a3){
print "$a1,$a2,$a3\n";
}
sub tablestring {
my $tab=shift;
my %o=$_[0] ? %{shift()} : ();
my $remove_empty = $o{remove_empty_columns};
my $no_multiline_space = $o{no_multiline_space};
my $nodup = $o{nodup}||0;
my $no_header_line = $o{no_header_line};
my $pagesize = exists $o{pagesize} ? $o{pagesize}-3 : 9999999;
my $left_force = $o{left};
my(@width,@left,@height,@not_empty,@nodup);
my $head=1;
my $i=0;
my $j;
for(@$tab){
$j=0;
$height[$i]=0;
my $nodup_rad=$nodup;
if(ref($_) eq 'ARRAY'){
for(@$_){
my $cell=$_;
$width[$j]||=0;
if($nodup_rad and $i>0 and $$tab[$i][$j] eq $$tab[$i-1][$j] || ($nodup_rad=0)){
$cell=$nodup==1?"":$nodup;
$nodup[$i][$j]=1;
}
else{
my $height=0;
my $wider;
no warnings;
$not_empty[$j]=1 if !$head && length($cell)>0;
for(split("\n",$cell)){
$wider=/<input.+type=text.+size=(\d+)/i?$1:0; #hm
s/<[^>]+>//g;
$height++;
s/>/>/g;
s/</</g;
$width[$j]=length($_)+1+$wider if length($_)+1+$wider>$width[$j];
$left[$j]=1 if $_ && !/^\s*[\-\+]?(\d+|\d*\.\d+)\s*\%?$/ && !$head;
}
if( $height>1 && !$no_multiline_space){
$height++ if !$head;
$height[$i-1]++ if $i>1 && $height[$i-1]==1;
}
$height[$i]=$height if $height>$height[$i];
}
$j++;
}
}
else{
$height[$i]=1;
$no_header_line=1;
}
$head=0;
$i++;
}
$i=$#height;
$j=$#width;
if($i==0 or $left_force) { @left=map{1}(0..$j) }
else { for(0..$j){ $left[$_]=1 if !$not_empty[$_] } }
my @tabout;
my $row_start_line=0;
my @header;
my $header_last;
for my $x (0..$i){
if($$tab[$x] eq '-'){
my @tegn=map {$$tab[$x-1][$_]=~/\S/?"-":" "} (0..$j);
$tabout[$row_start_line]=join(" ",map {$tegn[$_] x ($width[$_]-1)} (0..$j));
}
else{
for my $y (0..$j){
next if $remove_empty && !$not_empty[$y];
no warnings;
my @cell = !$header_last&&$nodup&&$nodup[$x][$y]
? ($nodup>0?():((" " x (($width[$y]-length($nodup))/2)).$nodup))
: split("\n",$$tab[$x][$y]);
for(0..($height[$x]-1)){
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');
print 34.3 - 34.0; # 0.299999999999997
print nicenum( 14.3 - 14.0 ); # 0.3
print nicenum( 34.3 - 34.0 ); # 0.3
=cut
our $Nicenum;
sub nicenum { #hm
$Nicenum=$_[0];
$Nicenum=~s/([\.,]\d*)((\d)\3\3\3\3\3)\d$/$1$2$3$3$3$3$3$3$3$3$3/;
my $r=0+$Nicenum;
#warn "nn $_[0] --> $Nicenum --> $r\n";
$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));
}
-e With -t xz (or 2xz) passes -e to xz (-9e = extreme compression)
-L rate With -p. Slow down, ex: -L 200K means 200 kilobytes per second
-D sec With -p. Only turn on progress meter (pv) after x seconds
-i sec With -p. Info update rate
-l With -p. Line mode
-I With -p. Show ETA as time of arrival as well as time left
-q With -p. Quiet. Useful with -L to limit rate, but no output
The options -L -D -i -l -I -q implicitly turns on -p. Those options are passed
through to pv. See: man pv.
=head3 due
Like C<du> command but views space used by file extentions instead of dirs. Options:
due [-options] [dirs] [files]
due -h View bytes "human readable", i.e. C<8.72 MB> instead of C<9145662 b> (bytes)
due -k | -m View bytes in kilobytes | megabytes (1024 | 1048576)
due -K Like -k but uses 1000 instead of 1024
due -z View two extentions if .z .Z .gz .bz2 .rz or .xz (.tar.gz, not just .gz)
due -M Also show min, medium and max date (mtime) of files, give an idea of their age
due -C Like -M, but create time instead (ctime)
due -A Like -M, but access time instead (atime)
due -P Also show 10, 50 (medium) and 90 percentile of file date
due -MP Both -M and -P, shows min, 10p, 50p, 90p and max
due -a Sort output alphabetically by extention (default order is by size)
due -c Sort output by number of files
due -i Ignore case, .GZ and .gz is the same, output in lower case
due -t Adds time of day to -M and -P output
due -e 'regex' Exclude files (full path) matching regex. Ex: due -e '\.git'
TODO: due -l TODO: Exclude hardlinks (dont count "same" file more than once, "man du")
ls -l | due Parses output of ls -l, find -ls, tar tvf for size+filename and reports
find | due List of filenames from stdin produces same as just command 'due'
ls | due Reports on just files in current dir without recursing into subdirs
=head3 finddup
Find duplicate files. Three steps to speed this up in case of many
large files: 1) Find files of same size, 2) of those: find files with
the same first 8 kilobytes, 3) of those: find duplicate files by
finding the MD5sums of the whole files.
finddup [-d -s -h] paths/ files/* ... #reports (+deletes with -d) duplicate files
#-s for symlinkings dups, -h for hardlink
finddup <files> # print duplicate files, <files> might be filenames and directories
finddup -a <files> # print duplicate files, also print the first file
finddup -d <files> # delete duplicate files, use -v to also print them before deletion
finddup -s <files> # make symbolic links of duplicate files
finddup -h <files> # make hard links of duplicate files
finddup -v ... # verbose, print before -d, -s or -h
finddup -n -d <files> # dry run: show rm commands without actually running them
finddup -n -s <files> # dry run: show ln commands to make symlinks of duplicate files todo:NEEDS FIX!
finddup -n -h <files> # dry run: show ln commands to make hard links of duplicate files
finddup -q ... # quiet
finddup -k o # keep oldest with -d, -s, -h, consider newer files duplicates
finddup -k n # keep newest with -d, -s, -h, consider older files duplicates
finddup -k O # same as -k o, just use access time instead of modify time
finddup -k N # same as -k n, just use access time instead of modify time
finddup -0 ... # use ascii 0 instead of the normal \n, for xargs -0
finddup -P n # use n bytes from start of file in 1st md5 check (default 8192)
finddup -p # view progress in last and slowest of the three steps
Default ordering of files without C<-k n> or C<-k o> is the order they
are mentioned on the command line. For directory args the order might be
random: use C<< dir/* >> to avoid that (but then dot files are not included).
=cut
sub install_acme_command_tools {
my $dir=(grep -d$_, @_, '/usr/local/bin', '/usr/bin')[0];
for( qw( conv due xcat freq finddup ccmd trunc wipe rttop z2z 2gz 2gzip 2bz2 2bzip2 2xz resubst zsize) ){
unlink("$dir/$_");
writefile("$dir/$_", "#!$^X\nuse Acme::Tools;\nAcme::Tools::cmd_$_(\@ARGV);\n");
sys("/bin/chmod +x $dir/$_"); #hm umask
print "Wrote executable $dir/$_\n";
}
}
sub cmd_conv { print conv(@ARGV)."\n" }
our @Due_fake_stdin;
#TODO: output from tar tvf and ls and find -ls
sub cmd_due {
my %o;
my @argv=opts("zkKmhciMCAPate:lE:t",\%o,@_);
require File::Find;
no warnings 'uninitialized';
die"$0: -l not implemented yet\n" if $o{l}; #man du: default is not to count hardlinks more than once, with -l it does
die"$0: -h, -k or -m can not be used together\n" if $o{h}+$o{k}+$o{m}>1;
die"$0: -c and -a can not be used together\n" if $o{a}+$o{c}>1;
die"$0: -k and -m can not be used together\n" if $o{k}+$o{m}>1;
die"$0: -M, -C, -A can not be used together\n" if $o{M}+$o{C}+$o{A}>1;
my(%c,%b,$cnt,$bts,%xtime);
my $zext=$o{z}?'(\.(z|Z|gz|bz2|xz|rz|kr|lrz|rz))?':'';
$o{E}||=11;
my $r=qr/(\.[^\.\/]{1,$o{E}}$zext)$/i;
my $qrexcl=exists$o{e}?qr/$o{e}/:0;
#TODO: ought to work: tar cf - .|tar tvf -|due
my $x=$o{M}?9:$o{C}?10:$o{A}?8:9;
if(-p STDIN or @Due_fake_stdin){
die "due: can not combine STDIN and args\n" if @argv;
my $stdin=join"",map"$_\n",@Due_fake_stdin; #test
open(local *STDIN, '<', \$stdin) or die "ERR: $! $?\n" if $stdin;
my $rl=qr/(^| )\-[rwx\-sS]{9}\s+(?:\d )?(?:[\w\-]+(?:\/|\s+)[\w\-]+)\s+(\d+)\s+.*?([^\/]*\.[\w,\-]+)?$/;
my $MorP=$o{M}||$o{C}||$o{A}||$o{P}?"due: -M, -C, -A and -P not yet implemented for STDIN unless list of filenames only\n":0;
while(<STDIN>){
chomp;
next if /\/$/;
my($f,$sz,$xtime)=(/$rl/?($3,$2):-f$_?($_,(stat)[7,$x]):next);
# 1576142 240 -rw-r--r-- 1 root root 242153 april 4 2016 /opt/wine-staging/share/wine/wine.inf
my $ext=$f=~$r?$1:'';
$ext=lc($ext) if $o{i};
$cnt++; $c{$ext}++;
$bts+=$sz; $b{$ext}+=$sz;
defined $xtime and $xtime{$ext}.=",$xtime" or die $MorP if $MorP;
}
}
else { #hm DRY
@argv=('.') if !@argv;
File::Find::find({follow=>0, wanted =>
sub {
return if !-f$_;
#todo: BUG! abc/def/file -> ghi/file should be abc/def/file -> ../../ghi/file
return if $o{q} or $o{n}; #quiet or dryrun
&$print("$_$nl") for @r;
}
#http://stackoverflow.com/questions/11900239/can-i-cache-the-output-of-a-command-on-linux-from-cli
our $Ccmd_cache_dir='/tmp/acme-tools-ccmd-cache';
our $Ccmd_cache_expire=15*60; #default 15 minutes
sub cmd_ccmd {
require Digest::MD5;
my $cmd=join" ",@_;
my $d="$Ccmd_cache_dir/".username();
makedir($d);
my $md5=Digest::MD5::md5_hex($cmd);
my($fno,$fne)=map"$d/cmd.$md5.std$_","out","err";
my $too_old=sub{time()-(stat(shift))[9] >= $Ccmd_cache_expire};
unlink grep &$too_old($_), <$d/*.std???>;
sys("($cmd) > $fno 2> $fne") if !-e$fno or &$too_old($fno);
print STDOUT "".readfile($fno);
print STDERR "".readfile($fne);
}
sub cmd_trunc { die "todo: trunc not ready yet"} #truncate a file, size 0, keep all other attr
#todo: wipe -n 4 filer* #virker ikke! tror det er args() eller opts() som ikke virker
sub cmd_wipe {
my %o;
my @argv=opts("n:k0123456789",\%o,@_);
die if 1<grep exists$o{$_},'n',0..9;
$o{$_} and $o{n}=$_ for 0..9;
wipe($_,$o{n},$o{k}) for @argv;
}
sub which { my $prog=shift; -x "$_/$prog" and return "$_/$prog" for split /:/, $ENV{PATH} }
sub cmd_2gz {cmd_z2z("-t","gz", @_)}
sub cmd_2gzip {cmd_z2z("-t","gz", @_)}
sub cmd_2bz2 {cmd_z2z("-t","bz2",@_)}
sub cmd_2bzip2 {cmd_z2z("-t","bz2",@_)}
sub cmd_2xz {cmd_z2z("-t","xz", @_)}
#todo: sub cmd_7z
#todo: .tgz same as .tar.gz (but not .tbz2/.txz)
sub cmd_z2z {
my %o;
my $pvopts="L:D:i:lIq";
my @argv=opts("pt:kvhon123456789es:$pvopts",\%o,@_);
my $t=repl(lc$o{t},qw/gzip gz bzip2 bz2/);
die "due: unknown compression type $o{t}, known are gz, bz2 and xz" if $t!~/^(gz|bz2|xz)$/;
$o{p}=1 if!defined$o{p} and grep$pvopts=~/$_/,keys%o;
delete $o{e} if $o{e} and $o{t} ne 'xz' and warn "-e available only for type xz\n";
my $sum=sum(map -s$_,@argv);
print "Converting ".@argv." files, total ".bytes_readable($sum)."\n" if $o{v} and @argv>1;
my $cat='cat';
if($o{p}){ if(which('pv')){ $cat='pv' } else { warn repl(<<"",qr/^\s+/) } }
due: pv for -p not found, install with sudo yum install pv, sudo apt-get install pv or similar
$o{$_} and $o{$_}=" " for qw(l q); #still true, but no cmd arg for:
$o{I} and $o{I}="-pterb";
exists$o{$_} and $cat=~s,pv,pv -$_ $o{$_}, for $pvopts=~/(\w)/g; #warn "cat: $cat\n";
my $sumnew=0;
my $start=time_fp();
my($i,$bsf)=(0,0);#bytes so far
$Eta{'z2z'}=[];eta('z2z',0,$sum);
#@argv=map$$_[1],sort{$$a[0]cmp$$b[0]}map{[$opt{
for(@argv){
my $new=$_; $new=~s/(\.(gz|bz2|xz))?$/.$t/i or die;
my $ext=defined($2)?lc($2):'';
my $same=/^$new$/; $new.=".tmp" if $same; die if $o{k} and $same;
next if !-e$_ and warn"$_ do not exists\n";
next if !-r$_ and warn"$_ is not readable\n";
next if -e$new and !$o{o} and warn"$new already exists, skipping (use -o to overwrite)\n";
my $unz={qw/gz gunzip bz2 bunzip2 xz unxz/}->{$ext}||'';
#todo: my $cntfile="/tmp/acme-tools-z2z-wc-c.$$";
#todo: my $cnt="tee >(wc -c>$cntfile)" if $ENV{SHELL}=~/bash/ and $o{v}; #hm dash vs bash
my $z= {qw/gz gzip bz2 bzip2 xz xz/}->{$t};
$z.=" -$_" for grep$o{$_},1..9,'e';
$z.=" -$_ $o{$_}" for grep exists$o{$_},'L';
my $cmd=qq($cat "$_"|$unz|$z>"$new");
#todo: "$cat $_|$unz|$cnt|$z>$new";
#cat /tmp/kontroll-linux.xz|unxz|tee >(wc -c>/tmp/p)|gzip|wc -c;cat /tmp/p
$cmd=~s,\|+,|,g; #print "cmd: $cmd\n";
sys($cmd);
chall($_,$new) or croak("$0 cannot chmod|chown|touch $new") if !$o{n};
my($szold,$sznew)=map{-s$_}($_,$new);
$bsf+=-s$_;
unlink $_ if !$o{k};
rename($new, replace($new,qr/.tmp$/)) or die if $same;
if($o{v}){
$sumnew+=$sznew;
my $pr=sprintf"%0.1f%%",$szold?100*$sznew/$szold:0;
#todo: my $szuncmp=-s$cntfile&&time()-(stat($cntfile))[9]<10 ? qx(cat $cntfile) : '';
#todo: $o{h} ? printf("%6.1f%% %9s => %9s => %9s %s\n", $pr,(map bytes_readable($_),$szold,$szuncmp,$sznew),$_)
#todo: : printf("%6.1f%% %11d b => %11d b => %11 b %s\n",$pr,$szold,$szuncmp,$sznew,$_)
my $str= $o{h}
? sprintf("%-7s %9s => %9s", $pr,(map bytes_readable($_),$szold,$sznew))
: sprintf("%-7s %11d b => %11d b", $pr,$szold,$sznew);
if(@argv>1){
$i++;
$str=$i<@argv
? " ETA:".sprintf("%-8s",sec_readable(eta('z2z',$bsf,$sum)-time_fp()))." $str"
: " TA: 0s $str"
if $sum>1e6;
$str="$i/".@argv." $str";
}
print "$str $new\n";
}
}
if($o{v} and @argv>1){
my $bytes=$o{h}?'':'bytes ';
my $str=
sprintf "%d files compressed in %.3f seconds from %s to %s $bytes (%s bytes) %.1f%% of original\n",
0+@argv,
time_fp()-$start,
(map{$o{h}?bytes_readable($_):$_}($sum,$sumnew,$sumnew-$sum)),
100*$sumnew/$sum;
$str=~s,\((\d),(+$1,;
print $str;
}
}
=head2 args
Parses command line options and arguments:
my %opt;
my @argv=Acme::Tools::args('i:nJ123',\%opt,@ARGV); #returns remaining command line elements after C<-o ptions> are parsed into C<%opt>.
Uses C<Getopt::Std::getopts()>. First arg names the different one char
options and an optional C<:> behind the letter or digit marks that the
switch takes an argument.
=cut
sub args {
my $switches=shift;
my $hashref=shift;
my $re_sw='^([a-z0-9]:?)+$';
croak "ERR: args: first arg $switches dont match $re_sw\n" if $switches !~ /$re_sw/i;
croak "ERR: second arg to args() not hashref\n" if ref($hashref) ne 'HASH';
local @ARGV=@_;
require Getopt::Std;
Getopt::Std::getopts($switches => $hashref);
(@ARGV);
}
sub opts {
my($def, $hashref, @a)=@_;
@a=@ARGV if @_<=2;
my %def=map{/(\w)(:?)/;($1=>$2?2:1)}$def=~/(\w:?)/g;
my $o1=join"",grep$def{$_}==1,sort keys%def;
my $o= join"", sort keys%def;
my @r;
while(@a){
my $a=shift(@a);
if($a=~/^-([$o1])([$o].*)$/){
unshift@a,"-$1","-$2";
}
elsif($a=~/^-(\w)(.*)$/){
my $d=$def{$1}//0;
push@{$$hashref{$1}},$d==1 && length($2) ? croak"opt -$1 has no arg (is $2 here)"
:$d==1 ? 1
:$d==2 && length($2) ? $2
:$d==2 ? shift(@a)
:croak"unknown opt -$1";
}
elsif($a eq '--'){
last;
}
else {
push @r, $a;
}
}
$_=join",",@$_ for values %$hashref;
( run in 0.760 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )