Acme-Tools
view release on metacpan or search on metacpan
my($sec,$mic)=Time::HiRes::gettimeofday();
return $sec*1000+$mic/1e3;
}
=head2 sleep_fp
sleep_fp() work as the built in C<< sleep() >> but also accepts fractional seconds:
sleep_fp(0.020); # sleeps for 20 milliseconds
Sub sleep_fp do a C<require Time::HiRes>, thus it might take some
extra time the first call. To avoid that, add C<< use Time::HiRes >>
to your code. Sleep_fp should not be trusted for accuracy to more than
a tenth of a second. Virtual machines tend to be less accurate (sleep
longer) than physical ones. This was tested on VMware and RHEL
(Linux). See also L<Time::HiRes>.
=head2 sleeps
=head2 sleepms
=head2 sleepus
=head2 sleepns
sleep_fp(0.020); #sleeps for 20 milliseconds
sleeps(0.020); #sleeps for 20 milliseconds, sleeps() is a synonym to sleep_fp()
sleepms(20); #sleeps for 20 milliseconds
sleepus(20000); #sleeps for 20000 microseconds = 20 milliseconds
sleepns(20000000); #sleeps for 20 million nanoseconds = 20 milliseconds
=cut
sub sleep_fp { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) }
sub sleeps { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) }
sub sleepms { eval{require Time::HiRes} or (sleep(shift()/1e3),return);Time::HiRes::sleep(shift()/1e3) }
sub sleepus { eval{require Time::HiRes} or (sleep(shift()/1e6),return);Time::HiRes::sleep(shift()/1e6) }
sub sleepns { eval{require Time::HiRes} or (sleep(shift()/1e9),return);Time::HiRes::sleep(shift()/1e9) }
=head2 eta
Estimated time of arrival (ETA).
for(@files){
...do work on file...
my $eta = eta( ++$i, 0+@files ); # file now, number of files
print "" . localtime($eta);
}
TODO: eta is borken and out of wack, good idea?: http://en.wikipedia.org/wiki/Kalman_filter
=head2 etahhmm
...NOT YET
=cut
our %Eta;
our $Eta_forgetfulness=2;
sub eta {
my($id,$pos,$end,$time_fp)=( @_==2 ? (join(";",caller()),@_) : @_ );
$time_fp||=time_fp();
my $a=$Eta{$id}||=[];
push @$a, [$pos,$time_fp];
@$a=@$a[map$_*2,0..@$a/2] if @$a>40; #hm 40
splice(@$a,-2,1) if @$a>1 and $$a[-2][0]==$$a[-1][0]; #same pos as last
return undef if @$a<2;
my @eta;
for(2..@$a){
push @eta, $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-$_][1])/($$a[-1][0]-$$a[-$_][0]);
}
my($sum,$sumw,$w)=(0,0,1);
for(@eta){
$sum+=$w*$_;
$sumw+=$w;
$w/=$Eta_forgetfulness;
}
my $avg=$sum/$sumw;
return $avg;
# return avg(@eta);
#return $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-2][1])/($$a[-1][0]-$$a[-2][0]);
1;
}
=head2 sleep_until
sleep_until(0.5) sleeps until half a second has passed since the last
call to sleep_until. This example starts the next job excactly ten
seconds after the last job started even if the last job lasted for a
while (but not more than ten seconds):
for(@jobs){
sleep_until(10);
print localtime()."\n";
...heavy job....
}
Might print:
Thu Jan 12 16:00:00 2012
Thu Jan 12 16:00:10 2012
Thu Jan 12 16:00:20 2012
...and so on even if the C<< ...heavy job... >>-part takes more than a
second to complete. Whereas if sleep(10) was used, each job would
spend more than ten seconds in average since the work time would be
added to sleep(10).
Note: sleep_until() will remember the time of ANY last call of this sub,
not just the one on the same line in the source code (this might change
in the future). The first call to sleep_until() will be the same as
sleep_fp() or Perl's own sleep() if the argument is an integer.
=cut
our $Time_last_sleep_until;
sub sleep_until {
my $s=@_==1?shift():0;
my $time=time_fp();
my $sleep=$s-($time-nvl($Time_last_sleep_until,0));
$Time_last_sleep_until=time;
sleep_fp($sleep) if $sleep>0;
}
my %thr;
sub throttle {
my($times,$mintime,$what)=@_;
$what||=join(":",@{[caller(1)]}[3,2]);
$thr{$what}||=[];
my $thr=$thr{$what};
push @$thr,time_fp();
return if @$thr<$times;
my $since=$$thr[-1]-shift(@$thr);
my $sleep=$since<$mintime?$mintime-$since:0;
sleep_fp($sleep);
return $sleep;
}
=head2 leapyear
B<Input:> A year. A four digit number.
B<Output:> True (1) or false (0) of whether the year is a leap year or
not. (Uses current calendar even for periods before leapyears was used).
print join(", ",grep leapyear($_), 1900..2014)."\n";
1904, 1908, 1912, 1916, 1920, 1924, 1928, 1932, 1936, 1940, 1944, 1948, 1952, 1956,
1960, 1964, 1968, 1972, 1976, 1980, 1984, 1988, 1992, 1996, 2000, 2004, 2008, 2012
Note: 1900 is not a leap year, but 2000 is. Years divided by 100 is a leap year only
if it can be divided by 400.
=cut
sub leapyear{$_[0]%400?$_[0]%100?$_[0]%4?0:1:0:1} #bool
#http://rosettacode.org/wiki/Levenshtein_distance#Perl
our %ldist_cache;
sub ldist {
my($s,$t,$l) = @_;
return length($t) if !$s;
return length($s) if !$t;
%ldist_cache=() if !$l and 1000<0+%ldist_cache;
$ldist_cache{$s,$t} ||=
do {
my($s1,$t1) = ( substr($s,1), substr($t,1) );
substr($s,0,1) eq substr($t,0,1)
? ldist($s1,$t1)
: 1 + min( ldist($s1,$t1,1+$l), ldist($s,$t1,1+$l), ldist($s1,$t,1+$l) );
};
}
=head1 OTHER
=head2 nvl
The I<no value> function (or I<null value> function)
C<nvl()> takes two or more arguments. (Oracles nvl-function take just two)
Returns the value of the first input argument with length() > 0.
Return I<undef> if there is no such input argument.
In perl 5.10 and perl 6 this will most often be easier with the C< //
> operator, although C<nvl()> and C<< // >> treats empty strings C<"">
differently. Sub nvl here considers empty strings and undef the same.
Those can contain other refs and strings in a deep data structure.
Limitations:
- Code refs are not handled (just returns C<sub{die()}>)
- Regex, class refs and circular recursive structures are also not handled.
B<Examples:>
$a = 'test';
@b = (1,2,3);
%c = (1=>2, 2=>3, 3=>5, 4=>7, 5=>11);
%d = (1=>2, 2=>3, 3=>\5, 4=>7, 5=>11, 6=>[13,17,19,{1,2,3,'asdf\'\\\''}],7=>'x');
print serialize(\$a,'a');
print serialize(\@b,'tab');
print serialize(\%c,'c');
print serialize(\%d,'d');
print serialize(\("test'n roll",'brb "brb"'));
print serialize(\%d,'d',undef,1);
Prints accordingly:
$a='test';
@tab=('1','2','3');
%c=('1','2','2','3','3','5','4','7','5','11');
%d=('1'=>'2','2'=>'3','3'=>\'5','4'=>'7','5'=>'11','6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}]);
('test\'n roll','brb "brb"');
%d=('1'=>'2',
'2'=>'3',
'3'=>\'5',
'4'=>'7',
'5'=>'11',
'6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}],
'7'=>'x');
Areas of use:
- Debugging (first and foremost)
- Storing arrays and hashes and data structures of those on file, database or sending them over the net
- eval earlier stored string to get back the data structure
Be aware of the security implications of C<eval>ing a perl code string
stored somewhere that unauthorized users can change them! You are
probably better of using L<YAML::Syck> or L<Storable> without
enabling the CODE-options if you have such security issues.
More on decompiling Perl-code: L<Storable> or L<B::Deparse>.
=head2 dserialize
Debug-serialize, dumping data structures for you to look at.
Same as C<serialize()> but the output is given a newline every 80th character.
(Every 80th or whatever C<$Acme::Tools::Dserialize_width> contains)
=cut
our $Dserialize_width=80;
sub _kallstack { my $tilbake=shift||0; my @c; my $ret; $ret.=serialize(\@c,"caller$tilbake") while @c=caller(++$tilbake); $ret }
sub dserialize{join "\n",serialize(@_)=~/(.{1,$Dserialize_width})/gs}
sub serialize {
no warnings;
my($r,$name,$filename,$level)=@_;
my @r=(undef,undef,($level||0)-1);
if($filename){
open my $fh, '>', $filename or croak("FEIL: could not open file $filename\n" . _kallstack());
my $ret=serialize($r,$name,undef,$level);
print $fh "$ret\n1;\n";
close($fh);
return $ret;
}
if(ref($r) eq 'SCALAR'){
return "\$$name=".serialize($r,@r).";\n" if $name;
return "undef" unless defined $$r;
my $ret=$$r;
$ret=~s/\\/\\\\/g;
$ret=~s/\'/\\'/g;
return "'$ret'";
}
elsif(ref($r) eq 'ARRAY'){
return "\@$name=".serialize($r,@r).";\n" if $name;
my $ret="(";
for(@$r){
$ret.=serialize(\$_,@r).",";
$ret.="\n" if $level>=0;
}
$ret=~s/,$//;
$ret.=")";
$ret.=";\n" if $name;
return $ret;
}
elsif(ref($r) eq 'HASH'){
return "\%$name=".serialize($r,@r).";\n" if $name;
my $ret="(";
for(sort keys %$r){
$ret.=serialize(\$_,@r)."=>".serialize(\$$r{$_},@r).",";
$ret.="\n" if $level>=0;
}
$ret=~s/,$//;
$ret.=")";
$ret.=";\n" if $name;
return $ret;
}
elsif(ref($$r) eq 'ARRAY'){
return "\@$name=".serialize($r,@r).";\n" if $name;
my $ret="[";
for(@$$r){
$ret.=serialize(\$_,@r).",";
$ret.="\n" if !defined $level or $level>=0;
}
$ret=~s/,$//;
$ret.="]";
$ret.=";\n" if $name;
return $ret;
}
elsif(ref($$r) eq 'HASH'){
return "\%$name=".serialize($r,@r).";\n" if $name;
my $ret="{";
for(sort keys %$$r){
$ret.=serialize(\$_,@r)."=>".serialize(\$$$r{$_},@r).",";
$ret.="\n" if $level>=0;
}
$ret=~s/,$//;
$ret.="}";
$ret.=";\n" if $name;
return $ret;
}
elsif(ref($$r) eq 'SCALAR'){
return "\\".serialize($$r,@r);
}
elsif(ref($r) eq 'LVALUE'){
my $s="$$r";
return serialize(\$s,@r);
}
elsif(ref($$r) eq 'CODE'){
#warn "Tried to serialize CODE";
return 'sub{croak "Can not serialize CODE-references, see perhaps B::Deparse and Storable"}'
}
elsif(ref($$r) eq 'GLOB'){
warn "Tried to serialize a GLOB";
return '\*STDERR'
}
else{
my $tilbake;
my($pakke,$fil,$line,$sub,$hasargs,$wantarray);
($pakke,$fil,$line,$sub,$hasargs,$wantarray)=caller($tilbake++) until $sub ne 'serialize' || $tilbake>20;
croak("serialize() argument should be reference!\n".
"\$r=$r\n".
"ref(\$r) = ".ref($r)."\n".
"ref(\$\$r) = ".ref($$r)."\n".
"kallstack:\n". _kallstack());
}
}
=head2 srlz
Synonym to L</serialize>, but remove unnecessary single quote chars around
C<< \w+ >>-keys and number values (except numbers with leading zeros). Example:
serialize:
%s=('action'=>{'del'=>'0','ins'=>'0','upd'=>'18'},'post'=>'1348','pre'=>'1348',
'updcol'=>{'Laerestednr'=>'18','Studietypenr'=>'18','Undervisningssted'=>'7','Url'=>'11'},
'where'=>'where 1=1');
srlz:
%s=(action=>{del=>0,ins=>0,upd=>18},post=>1348,pre=>1348,
updcol=>{Laerestednr=>18,Studietypenr=>18,Undervisningssted=>7,Url=>11},
where=>'where 1=1');
Todo: update L</serialize> to do the same, but in the right way. (For now
srlz runs the string from serialize() through two C<< s/// >>, this will break
in certain cases). L</srlz> will be kept as a synonym (or the other way around).
=cut
sub srlz {
my $s=serialize(@_);
$s=~s,'(\w+)'=>,$1=>,g;
$s=~s,=>'([+-]?(0|[1-9]\d*)(\.\d+)?([eE][-+]?\d+)?)',=>$1,g; #ikke ledende null! hm
$s;
}
=head2 cnttbl
my %nordic_country_population=(Norway=>5214890,Sweden=>9845155,Denmark=>5699220,Finland=>5496907,Iceland=>331310);
print cnttbl(\%nordic_country_population);
Iceland 331310 1.25%
Norway 5214890 19.61%
Finland 5496907 20.67%
Denmark 5699220 21.44%
Sweden 9845155 37.03%
SUM 26587482 100.00%
Todo: Levels...:
my %sales=(
Toyota=>{Prius=>19,RAV=>12,Auris=>18,Avensis=>7},
Volvo=>{V40=>14, XC90=>4},
Nissan=>{Leaf=>19,Qashqai=>17},
Tesla=>{ModelS=>8}
);
print cnttbl(\%sales);
Toyota SUM 56
Volvo SUM 18
Same as ref, but goes deeper.
print ref_deep( { 10=>[1,'ten'], 100=>[2,'houndred'], 1000=>[3,'thousand'] } ); # prints HASH_of_ARRAYS
print ref_deep( { 10=>'ten', 100=>[2,'houndred'], 1000=>[3,'thousand'] } ); # prints same (mixed, deepest)
print ref_deep( { 1=>[{a=>3,b=>6},{a=>1,b=>8}], 5=>[{a=>2,b=>5},{a=>7,b=>1}] } ); # HASH_of_ARRAYS_of_HASHES
(Todo, not supported: circular, alternatives for mixed)
=cut
sub ref_deep {
my $s=shift; #
}
=head2 nicenum
print 14.3 - 14.0; # 0.300000000000001
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));
}
Returns undef, 0 or 1. Undef if its the first time C<changed> is
called on that perl line. 0 if not the first time and the parameters
differ from the last call on that line. 1 if not the first time and
the parameters is the exact same as they where on the previous call on
that line of perl source code.
=cut
our %Changed_lastval;
sub changed {
my $now=join($;,@_);
my $key=join($;,caller());
my $e=exists $Changed_lastval{$key};
if($e){
my $last=$Changed_lastval{$key};
return 0 if defined $last and defined $now and $last eq $now
or !defined $last and !defined $now;
}
$Changed_lastval{$key}=$now;
return $e?1:undef;
}
#todo: sub unbless eller sub damn
#todo: ..se også: use Data::Structure::Util qw/unbless/;
#todo: ...og: Acme::Damn sin damn()
#todo? sub swap($$) http://www.idg.no/computerworld/article242008.ece
#todo? catal
#todo?
#void quicksort(int t, int u) int i, m; if (t >= u) return; swap(t, randint(t, u)); m = t; for (i = t + 1; i <= u; i++) if (x[i] < x[t]) swap(++m, i); swap(t, m) quicksort(t, m-1); quicksort(m+1, u);
=head1 JUST FOR FUN
=head2 brainfu
B<Input:> one or two arguments
First argument: a string, source code of the brainfu
language. String containing the eight charachters + - < > [ ] . ,
Every other char is ignored silently.
Second argument: if the source code contains commas (,) the second
argument is the input characters in a string.
B<Output:> The resulting output from the program.
Example:
print brainfu(<<""); #prints "Hallo Verden!\n"
++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>---.+++++++++++..+++.>++.<<++++++++++++++
.>----------.+++++++++++++.--------------.+.+++++++++.>+.>.
See L<http://en.wikipedia.org/wiki/Brainfuck>
=head2 brainfu2perl
Just as L</brainfu> but instead it return the perl code to which the
brainfu code is translated. Just C<< eval() >> this perl code to run.
Example:
print brainfu2perl('>++++++++[<++++++++>-]<++++++++.>++++++[<++++++>-]<---.');
Prints this string:
my($c,$o,@b)=(0); sub out{$o.=chr($b[$c]) for 1..$_[0]||1}
++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
++$b[$c];++$c;--$b[$c];}--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
++$b[$c];++$b[$c];out;++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$c;--$b[$c];}
--$c;--$b[$c];--$b[$c];--$b[$c];out;$o;
( run in 2.088 seconds using v1.01-cache-2.11-cpan-75ffa21a3d4 )