Acme-Tools
view release on metacpan or search on metacpan
sub valuesr { values( %{shift()} ) }
sub eachr { ref($_[0]) eq 'HASH' ? each(%{shift()})
#:ref($_[0]) eq 'ARRAY' ? each(@{shift()}) # perl 5.8.8 cannot compile each on array! eval?
: croak("eachr needs hashref or arrayref got '".ref($_[0])."'") }
sub joinr {join(shift(),@{shift()})}
#sub mapr # som scala: hvis map faar subref se kalles den sub paa hvert elem og resultatet returneres
#sub eachr { each(%{shift()}) }
=head2 pile
B<Input:> a pile size s and a list
B<Output:> A list of lists of length s or the length of the remainer in
the last list. Piles together the input list in lists of the given size.
my @list=(1,2,3,4,5,6,7,8,9,10);
my @piles = pile(3, @list ); # ([1,2,3], [4,5,6], [7,8,9], [10])
my $i=0;
my @piles = parta {$i++/3} @list; # same as above pile(3, @list)
=cut
sub pile { my $size=shift; my @r; for (@_){ push@r,[] if !@r or 0+@{$r[-1]}>=$size; push @{$r[-1]}, $_ } @r }
=head2 aoh2sql
my @oceania=(
{Area=>undef, Capital=>'Pago Pago', Code=>'AS', Name=>'American Samoa', Population=>54343},
{Area=>7686850, Capital=>'Canberra', Code=>'AU', Name=>'Australia', Population=>22751014},
{Area=>undef, Capital=>'West Island', Code=>'CC', Name=>'Cocos (Keeling) Islands', Population=>596},
{Area=>240, Capital=>'Avarua', Code=>'CK', Name=>'Cook Islands', Population=>9838},
{Area=>undef, Capital=>'Flying Fish Cove', Code=>'CX', Name=>'Christmas Island', Population=>1530},
{Area=>18270, Capital=>'Suva', Code=>'FJ', Name=>'Fiji', Population=>909389},
{Area=>702, Capital=>'Palikir', Code=>'FM', Name=>'Micronesia, Federated States of', Population=>105216},
{Area=>549, Capital=>'Hagatna (Agana)', Code=>'GU', Name=>'Guam', Population=>161785},
{Area=>811, Capital=>'Tarawa', Code=>'KI', Name=>'Kiribati', Population=>105711},
{Area=>181.3, Capital=>'Majuro', Code=>'MH', Name=>'Marshall Islands', Population=>72191},
{Area=>19060, Capital=>'Noumea', Code=>'NC', Name=>'New Caledonia', Population=>271615},
{Area=>undef, Capital=>'Kingston', Code=>'NF', Name=>'Norfolk Island', Population=>2210},
{Area=>21, Capital=>'Yaren District', Code=>'NR', Name=>'Nauru', Population=>9540},
{Area=>260, Capital=>'Alofi', Code=>'NU', Name=>'Niue', Population=>1190},
{Area=>268680, Capital=>'Wellington', Code=>'NZ', Name=>'New Zealand', Population=>4438393},
{Area=>undef, Capital=>'Papeete', Code=>'PF', Name=>'French Polynesia', Population=>282703},
{Area=>462840, Capital=>'Port Moresby', Code=>'PG', Name=>'Papua New Guinea', Population=>6672429},
{Area=>undef, Capital=>'Adamstown', Code=>'PN', Name=>'Pitcairn', Population=>48},
{Area=>458, Capital=>'Melekeok', Code=>'PW', Name=>'Palau', Population=>21265},
{Area=>28450, Capital=>'Honiara', Code=>'SB', Name=>'Solomon Islands', Population=>622469},
{Area=>undef, Capital=>undef, Code=>'TK', Name=>'Tokelau', Population=>1337},
{Area=>26, Capital=>'Funafuti', Code=>'TV', Name=>'Tuvalu', Population=>10869},
{Area=>12200, Capital=>'Port-Vila', Code=>'VU', Name=>'Vanuatu', Population=>272264},
{Area=>undef, Capital=>'Mata-Utu', Code=>'WF', Name=>'Wallis and Futuna', Population=>15500},
{Area=>2944, Capital=>'Apia', Code=>'WS', Name=>'Samoa (Western)', Population=>197773}
);
print aoh2sql(\@oceania,{
name=>'country',
drop=>2,
#number=>'numeric', #default
#varchar=>'varchar', #default, change to varchar2 if Oracle
#date=>'date', #default, perhaps change to 'timestamp with time zone' if postgres
#varchar_maxlen=>4000, #default, 4000 (used to be?) is max in Oracle
#create=>1, #default, use 0 to dont include create table
#drop=>0, #default 0: dont include drop table x; 1: drop table x; 2: drop table if exists x;
#end=>"commit;\n",
#begin=>"begin;\n",
#fix_colnames=>0,
});
Returns:
begin;
drop table if exists country;
create table country (
Area numeric(9,1),
Capital varchar(16),
Code varchar(2) not null,
Name varchar(36) not null,
Population numeric(9)
);
insert into country values (null,'Pago Pago','AS','American Samoa',54343);
insert into country values (7686850,'Canberra','AU','Australia',22751014);
insert into country values (null,'West Island','CC','Cocos (Keeling) Islands',596);
insert into country values (240,'Avarua','CK','Cook Islands',9838);
insert into country values (null,'Flying Fish Cove','CX','Christmas Island',1530);
insert into country values (18270,'Suva','FJ','Fiji',909389);
insert into country values (702,'Palikir','FM','Micronesia, Federated States of',105216);
insert into country values (549,'Hagatna (Agana)','GU','Guam',161785);
insert into country values (811,'Tarawa','KI','Kiribati',105711);
insert into country values (181.3,'Majuro','MH','Marshall Islands',72191);
insert into country values (19060,'Noumea','NC','New Caledonia',271615);
insert into country values (null,'Kingston','NF','Norfolk Island',2210);
insert into country values (21,'Yaren District','NR','Nauru',9540);
insert into country values (260,'Alofi','NU','Niue',1190);
insert into country values (268680,'Wellington','NZ','New Zealand',4438393);
insert into country values (null,'Papeete','PF','French Polynesia',282703);
insert into country values (462840,'Port Moresby','PG','Papua New Guinea',6672429);
insert into country values (null,'Adamstown','PN','Pitcairn',48);
insert into country values (458,'Melekeok','PW','Palau',21265);
insert into country values (28450,'Honiara','SB','Solomon Islands',622469);
insert into country values (null,null,'TK','Tokelau',1337);
insert into country values (26,'Funafuti','TV','Tuvalu',10869);
insert into country values (12200,'Port-Vila','VU','Vanuatu',272264);
insert into country values (null,'Mata-Utu','WF','Wallis and Futuna',15500);
insert into country values (2944,'Apia','WS','Samoa (Western)',197773);
commit;
=cut
sub aoh2sql {
my($aoh,$conf)=@_;
my %def=( #defaults
name=>'my_table',
number=>'numeric',
varchar=>'varchar',
date=>'date',
varchar_maxlen=>4000,
if($jump>0){ while($x<$y){ push @r, $x; $x+=$jump } }
else { while($x>$y){ push @r, $x; $x+=$jump } }
return @r;
}
#jumps derivative, double der., trippled der usw
sub _range_accellerated {
my($x,$y,@jump)=@_;
my @r;
my $test = $jump[0]>=0 ? sub{$x<$y} : sub{$x>$y};
while(&$test()){
push @r, $x;
$x+=$jump[0];
$jump[$_-1]+=$jump[$_] for 1..$#jump;
}
return @r;
}
=head2 globr
Works like and uses Perls builtin C<< glob() >> but adds support for ranges
with C<< {from..to} >> and C<< {from..to..step} >>. Like brace expansion in bash.
Examples:
my @arr = glob "X{a,b,c,d}Z"; # @arr now have four elements: XaZ XbZ XcZ XdZ
my @arr = globr "X{a,b,c,d}Z"; # same as above
my @arr = globr "X{a..d}Z"; # same as above
my @arr = globr "X{a..f..2}"; # step 2, returns array: Xa Xc Xe
my @arr = globr "{aa..bz..13}Z"; # aaZ anZ baZ bnZ
my @arr = globr "{1..12}b"; # 1b 2b 3b 4b 5b 6b 7b 8b 9b 10b 11b 12b
my @arr = globr "{01..11}b"; # 01b 02b 03b 04b 05b 06b 07b 08b 09b 10b 11b (keep leading zero)
my @arr = globr "{01..12..3}b"; # 01b 04b 07b 10b
=cut
sub globr($) {
my $p=shift;
$p=~s{
\{(-?\w+)\.\.(-?\w+)(\.\.(-?\d+))?\}
}{
my $i=0;
my @r=$1 le $2 ? ($1..$2) : reverse($2..$1);
@r=grep !($i++%$4),@r if $4;
"{" . join(",",@r) . "}"
}xeg;
glob $p;
}
=head2 permutations
How many ways (permutations) can six people be placed around a table:
One person: one way
Two persons: two ways (they can swap places)
Three persons: 6
Four persons: 24
Five persons: 120
Six persons: 720
The formula is C<x!> where the postfix unary operator C<!>, also known as I<faculty> is defined as:
C<x! = x * (x-1) * (x-2) ... * 1>. Example: C<5! = 5 * 4 * 3 * 2 * 1 = 120>.Run this to see the 100 first C<< n! >>
perl -MAcme::Tools -le'$i=big(1);print "$_!=",$i*=$_ for 1..100'
1! = 1
2! = 2
3! = 6
4! = 24
5! = 120
6! = 720
7! = 5040
8! = 40320
9! = 362880
10! = 3628800
.
.
.
100! = 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000
C<permutations()> takes a list and return a list of arrayrefs for each
of the permutations of the input list:
permutations('a','b'); #returns (['a','b'],['b','a'])
permutations('a','b','c'); #returns (['a','b','c'],['a','c','b'],
# ['b','a','c'],['b','c','a'],
# ['c','a','b'],['c','b','a'])
Up to five input arguments C<permutations()> is probably as fast as it
can be in this pure perl implementation (see source). For more than
five, it could be faster. How fast is it now: Running with different
n, this many time took that many seconds:
n times seconds
-- ------- ---------
2 100000 0.32
3 10000 0.09
4 10000 0.33
5 1000 0.18
6 100 0.27
7 10 0.21
8 1 0.17
9 1 1.63
10 1 17.00
If the first argument is a coderef, that sub will be called for each permutation and the return from those calls with be the real return from C<permutations()>. For example this:
print for permutations(sub{join"",@_},1..3);
...will print the same as:
print for map join("",@$_), permutations(1..3);
...but the first of those two uses less RAM if 3 has been say 9.
Changing 3 with 10, and many computers hasn't enough memory
for the latter.
The examples prints:
123
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
Nissan SUM 36
Tesla SUM 8
SUM SUM 56 100%
=cut
sub cnttbl {
my $hr=shift;
my $maxlen=max(3,map length($_),keys%$hr);
join"",ref((values%$hr)[0])
?do{ map {my$o=$_;join("",map rpad($$o[0],$maxlen)." $_\n",split("\n",$$o[1]))}
map [$_,cnttbl($$hr{$_})],
sort keys%$hr }
:do{ my $sum=sum(values%$hr);
my $fmt=repl("%-xs %yd %6.2f%%\n",x=>$maxlen,y=>length($sum));
map sprintf($fmt,@$_,100*$$_[1]/$sum),
(map[$_,$$hr{$_}],sort{$$hr{$a}<=>$$hr{$b} or $a cmp $b}keys%$hr),
(['SUM',$sum]) }
}
=head2 ref_deep
( run in 1.232 second using v1.01-cache-2.11-cpan-5735350b133 )