Acme-Tools
view release on metacpan or search on metacpan
0.27 Feb 2020 Small fixes for some platforms
0.26 Jan 2020 Convert subs: base bin2dec bin2hex bin2oct dec2bin dec2hex dec2oct
hex2bin hex2dec hex2oct oct2bin oct2dec oct2hex
Array subs: joinr perm permute permute_continue pile sortby subarrays
Other subs: btw in_iprange ipnum_ok iprange_ok opts s2t
0.24 Feb 2019 Fixed failes on perl 5.16 and older
0.23 Jan 2019 Subs: logn, egrep, which. More UTF-8 "oriented" (lower, upper, ...)
Commands: zsize, finddup, due (improved), conv (improved, [MGT]?Wh
and many more units), due -M for stdin of filenames.
0.22 Feb 2018 Subs: subarr, sim, sim_perm, aoh2sql. command: resubst
0.21 Mar 2017 Improved nicenum() and its tests
0.20 Mar 2017 Subs: a2h cnttbl h2a log10 log2 nicenum rstddev sec_readable
throttle timems refa refaa refah refh refha refhh refs
eachr globr keysr popr pushr shiftr splicer unshiftr valuesr
Commands: 2bz2 2gz 2xz z2z
0.172 Dec 2015 Subs: curb openstr pwgen sleepms sleepnm srlz tms username
self_update install_acme_command_tools
Commands: conv due freq wipe xcat (see "Commands")
0.16 Feb 2015 bigr curb cpad isnum parta parth read_conf resolve_equation
roman2int trim. Improved: conv (numbers currency) range ("derivatives")
bigscale
nvl
repl
replace
decode
decode_num
between
btw
curb
bound
log10
log2
logn
distinct
in
in_num
uniq
union
union_all
minus
minus_all
intersect
intersect_all
bfgrepnot
bfdelete
bfstore
bfretrieve
bfclone
bfdimensions
$PI
install_acme_command_tools
$Dbh
dlogin
dlogout
drow
drows
drowc
drowsc
dcols
dpk
dsel
ddo
dins
dupd
=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.
if(length($2)>$max){
$l=$_;
$te="$1$3"-$1;
$max=length($2);
}
}
}
return fractional($n) if !$l and !recursed() and $dec>6 and substr($n,-1) and substr($n,-1)--;
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();
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.
$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 }
$num=1 if !defined $num;
croak "random_gauss should not have more than 3 arguments" if @_>3;
my @r;
while (@r<$num) {
my($x1,$x2,$w);
do {
$x1=2.0*rand()-1.0;
$x2=2.0*rand()-1.0;
$w=$x1*$x1+$x2*$x2;
} while $w>=1.0;
$w=sqrt(-2.0*log($w)/$w) * $stddev;
push @r, $x1*$w + $avg,
$x2*$w + $avg;
}
pop @r if @r > $num;
return $r[0] if @_<3;
return @r;
}
=head2 mix
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.
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 $! $?");
=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
printf "The filter is %.1f%% filled\n",$percent; #prints 50.0% or so if filled to capacity
Sums the counters for counting bloom filters (much slower than for non counting).
=head2 bfdimensions
Input, two numeric arguments: Capacity and error_rate.
Outputs an array of two numbers: m and k.
m = - n * log(p) / log(2)**2 # n = capacity, m = bits in filter (divide by 8 to get bytes)
k = log(1/p) / log(2) # p = error_rate, uses perls internal log() with base e (2.718)
...that is: m = the best number of bits in the filter and k = the best
number of hash functions optimized for the given capacity (n) and
error_rate (p). Note that k is a dependent only of the error_rate. At
about two percent error rate the bloom filter needs just the same
number of bytes as the number of keys.
Storage (bytes):
Capacity Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate
0.000000001 0.00000001 0.0000001 0.000001 0.00001 0.0001 0.001 0.01 0.02141585 0.1 0.5 0.99
time perl -e'use Digest::MD5 qw(md5);md5("asdf$_") for 1..10e6' #5.56 sec
time perl -e'use String::CRC32;crc32("asdf$_") for 1..10e6' #2.79 sec, faster but not per bit
time perl -e'use Digest::SHA qw(sha512);sha512("asdf$_") for 1..10e6' #36.10 sec, too slow (sha1, sha224, sha256 and sha384 too)
Md5 seems to be an ok choice both for speed and avoiding collitions due to skewed data keys.
=head2 Theory and math behind bloom filters
L<http://www.internetmathematics.org/volumes/1/4/Broder.pdf>
L<http://blogs.sun.com/jrose/entry/bloom_filters_in_a_nutshell>
L<http://pages.cs.wisc.edu/~cao/papers/summary-cache/node8.html>
See also Scaleable Bloom Filters: L<http://gsd.di.uminho.pt/members/cbm/ps/dbloom.pdf> (not implemented in Acme::Tools)
...and perhaps L<http://intertrack.naist.jp/Matsumoto_IEICE-ED200805.pdf>
=cut
sub bfinit {
sub bfclone {
require Storable;
return Storable::dclone(@_); #could be faster
}
sub bfdimensions_old {
my($n,$p,$mink,$maxk, $k,$flen,$m)=
@_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'},1)
:@_==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";
printf "%9.3fs ",$_ for @{shift@t}; print "\n";
}
}
unlink $argv[0] if $stdin;
}
sub cmd_rttop { die "rttop: not implemented here yet.\n" }
sub cmd_whichpm { die "whichpm: not implemented here yet.\n" } #-a (all, inkl VERSION og ls -l)
sub cmd_catal { die "catal: not implemented here yet.\n" } #-a (all, inkl VERSION og ls -l)
#todo: cmd_tabdiff (fra sonyk)
#todo: cmd_catlog (ala catal med /etc/catlog.conf, default er access_log)
=head1 DATABASE STUFF - NOT IMPLEMENTED YET
Uses L<DBI>. Comming soon...
$Dbh
dlogin
dlogout
drow
drows
drowc
drowsc
dcols
dpk
dsel
ddo
dins
dupd
sub dtype {
my $connstr=shift;
return 'SQLite' if $connstr=~/(\.sqlite|sqlite:.*\.db)$/i;
return 'Oracle' if $connstr=~/\@/;
return 'Pg' if 1==2;
die;
}
our($Dbh,@Dbh,%Sth);
our %Dbattr=(RaiseError => 1, AutoCommit => 0); #defaults
sub dlogin {
my $connstr=shift();
my %attr=(%Dbattr,@_);
my $type=dtype($connstr);
my($dsn,$u,$p)=('','','');
if($type eq 'SQLite'){
$dsn=$connstr;
}
elsif($type eq 'Oracle'){
($u,$p,$dsn)=($connstr=~m,(.+?)(/.+?)?\@(.+),);
}
elsif($type eq 'Pg'){
croak "todo";
}
else{
croak "dblogin: unknown database type for connection string $connstr\n";
}
$dsn="dbi:$type:$dsn";
push @Dbh, $Dbh if $Dbh; #local is better?
require DBI;
$Dbh=DBI->connect($dsn,$u,$p,\%attr); #connect_cached?
}
sub dlogout {
$Dbh->disconnect;
$Dbh=pop@Dbh if @Dbh;
}
sub drow {
my($q,@b)=_dattrarg(@_);
#my $sth=do{$Sth{$Dbh,$q} ||= $Dbh->prepare_cached($q)};
my $sth=$Dbh->prepare_cached($q);
$sth->execute(@b);
my @r=$sth->fetchrow_array;
$sth->finish if $$Dbh{Driver}{Name} eq 'SQLite';
# - https://rt.cpan.org/Dist/Display.html?Queue=Acme-Tools
# http://en.wikipedia.org/wiki/Birthday_problem#Approximations
# memoize_expire() http://perldoc.perl.org/Memoize/Expire.html
# memoize_file_expire()
# memoize_limit_size() #lru
# memoize_file_limit_size()
# memoize_memcached http://search.cpan.org/~dtrischuk/Memoize-Memcached-0.03/lib/Memoize/Memcached.pm
# hint on http://perl.jonallen.info/writing/articles/install-perl-modules-without-root
# sub mycrc32 { #http://billauer.co.il/blog/2011/05/perl-crc32-crc-xs-module/ eller String::CRC32::crc32 som er 100 x raskere enn Digest::CRC::crc32
# my ($input, $init_value, $polynomial) = @_;
# $init_value = 0 unless (defined $init_value);
# $polynomial = 0xedb88320 unless (defined $polynomial);
# my @lookup_table;
# for (my $i=0; $i<256; $i++) {
# my $x = $i;
# for (my $j=0; $j<8; $j++) {
# if ($x & 1) {
# $x = ($x >> 1) ^ $polynomial;
# } else {
0.27 Feb 2020 Small fixes for some platforms
0.26 Jan 2020 Convert subs: base bin2dec bin2hex bin2oct dec2bin dec2hex dec2oct
hex2bin hex2dec hex2oct oct2bin oct2dec oct2hex
Array subs: joinr perm permute permute_continue pile sortby subarrays
Other subs: btw in_iprange ipnum_ok iprange_ok opts s2t
0.24 Feb 2019 fixed failes on perl 5.16 and older
0.23 Jan 2019 Subs: logn, egrep, which. More UTF-8 "oriented" (lower, upper, ...)
Commands: zsize, finddup, due (improved), conv (improved, [MGT]?Wh
and many more units), due -M for stdin of filenames.
0.22 Feb 2018 Subs: subarr, sim, sim_perm, aoh2sql. command: resubst
0.21 Mar 2017 Improved nicenum() and its tests
0.20 Mar 2017 Subs: a2h cnttbl h2a log10 log2 nicenum rstddev sec_readable
throttle timems refa refaa refah refh refha refhh refs
eachr globr keysr popr pushr shiftr splicer unshiftr valuesr
Commands: 2bz2 2gz 2xz z2z
0.172 Dec 2015 Subs: curb openstr pwgen sleepms sleepnm srlz tms username
self_update install_acme_command_tools
Commands: conv due freq wipe xcat (see "Commands")
0.16 Feb 2015 bigr curb cpad isnum parta parth read_conf resolve_equation
roman2int trim. Improved: conv (numbers currency) range ("derivatives")
t/04_resolve.t view on Meta::CPAN
# perl Makefile.PL && make && perl -Iblib/lib t/04_resolve.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 17;
if($ENV{ATDEBUG}){
deb "Resolve: ".resolve(sub{my($x)=(@_); $x**2 - 4*$x -1},20,2)."\n";
deb "Resolve: ".resolve(sub{my($x)=@_; $x**log($x)-$x},0,3)."\n";
deb "Resolve: ".resolve(sub{$_[0]})." iters=$Acme::Tools::Resolve_iterations\n";
}
my $e;
ok(resolve(sub{my($x)=@_; $x**2 - 4*$x -21}) == -3 ,'first solution');
ok(($e=resolve(sub{ $_**2 - 4*$_ - 21 })) == -3 ,"first solution with \$_ (=$e)");
ok(resolve(sub{$_**2 - 4*$_ -21},0,3) == 7 ,'second solution, start 3');
ok(resolve(sub{my($x)=@_; $x**2 - 4*$x -21},0,2) == 7 ,'second solution, start 2');
my $f=sub{ $_**2 - 4*$_ - 21 };
ok(do{my$r=resolve($f,0,2); $r== 7} ,'second solution, start 2');
t/04_resolve.t view on Meta::CPAN
ok(!defined $Resolve_iterations);
ok(!defined $Resolve_last_estimate);
my $c;
eval{$e=resolve(sub{$c++; sleep_fp(0.02); $_**2 - 4*$_ -21},0,.02,undef,undef,0.05)};
deb "x=$e, est=$Resolve_last_estimate, iters=$Resolve_iterations, time=$Resolve_time, c=$c -- $@\n";
ok($@=~/Could not resolve, perhaps too little time given/,'ok $@');
my$no=0;sub isr{is( ($e=$_[0]), $_[1], "r".(++$no).": e=$e, iters=$Resolve_iterations")}
isr( sprintf("%.12f",resolve(sub{3*$_ + $_**4 - 12})), '1.632498783713' ); #*)
isr( log(resolve(sub{ $_**log($_)-$_},0,2)), 1);
isr( resolve(sub{$_**2+7*$_-60},0,1), 5);
isr( resolve_equation("x^2+7x-60"), 5);
#*) http://www.quickmath.com/webMathematica3/quickmath/equations/solve/basic.jsp#c=solve_stepssolveequation&v1=3x%2Bx%5E4-12%3D0&v2=x
t/05_distance.t view on Meta::CPAN
#perl Makefile.PL;make;perl -Iblib/lib t/05_distance.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 4;
#--oslo-rio = 10434.047 meter iflg http://www.daftlogic.com/projects-google-maps-distance-calculator.htm
my @oslo=(59.933983, 10.756037);
my @rio=(-22.97673,-43.19508);
my @london=(51.507726,-0.128079); #1156
my @jakarta=(-6.175381,106.828176); # 10936
my @test=( ['@oslo,@rio', 10431.5],
['@rio, @oslo', 10431.5],
['@oslo,@london', 1153.6],
['@oslo,@jakarta', 10936.0] );
my $d; ok( between( ($d=distance(eval$$_[0])/1000)/$$_[1], 0.999, 1.001 ), "distance $$_[0], $$_[1] and $d" ) for @test;
# perl Makefile.PL; make; perl -Iblib/lib t/24_db.t
no strict;
no warnings;
#use lib '.'; BEGIN{require 't/common.pl'}
use Acme::Tools;
use Test::More tests => 10;
ok(1) for 1..10;exit;#4now
my $f='/tmp/acme-tools.sqlite'; unlink($f);
print repl($f,'x','y'),"\n";
dlogin($f);
ddo(<<"");
create table tst (
a integer primary key,
b varchar2,
c date
)
ddo("insert into tst values ".
join",",
map "(".join(",",$_,$_%2?"'XYZ'":"'ABC'",time_fp()).")",
1..100);
dcommit();
ok( 100 == drow("select sum(1) from tst") );
ok( 50 == drow("select sum(1) from tst where b = ? and c <= ?", 'ABC',time_fp()) );
ok( 50 == drow("select sum(1) from tst where b = ? and c <= ?", 'XYZ',time_fp()) );
ok(1);
dlogout();
t/test_pi.pl view on Meta::CPAN
__END__
@fak https://en.wikipedia.org/wiki/Factorial
Visste du at den matematiske formelen for volumet til en pizza med tykkelse a og radius z er pi z z a?
Did you know that the volume of a pizza with thickness a and radius z is pi z z a?
wget https://gmplib.org/download/misc/gmp-chudnovsky.c
sudo apt-get install libgmpv4-dev
gcc -s -Wall -o gmp-chudnovsky gmp-chudnovsky.c -lgmp -lm
wget http://beej.us/blog/data/pi-chudnovsky-gmp/chudnovsky_c.txt; mv chudnovsky_c.txt chudnovsky.c
gcc -O2 -Wall -o chudnovsky chudnovsky.c -lgmp
time ./chudnovsky 1000 #3.141592.......... 1000 decimals in 0.004s, 10000 in 0.22s, 100000 in 42s
wget http://www.angio.net/pi/digits/pi1000000.txt
time perl -nle'print $-[0]." ".($+[0]-$-[0])." ".substr($_,$-[0],$+[0]-$-[0]) while /(\d)\1\1\1\1\1+/g' pi1000000.txt #pos of 6+ consec same decs
( run in 0.571 second using v1.01-cache-2.11-cpan-49f99fa48dc )