Result:
found more than 684 distributions - search limited to the first 2001 files matching your query
( run in 1.403 )
Acme-Tie-Formatted
view release on metacpan or search on metacpan
lib/Acme/Tie/Formatted.pm view on Meta::CPAN
# to be formatted.
return '' unless @args;
# Format arguments and return.
local $_;
return join($", map { sprintf($format, $_) } @args);
}
# Stolen directly from Tie::Comma.
# Invalidate all other hash access.
use subs qw(
Acme-Time-Baby
view release on metacpan or search on metacpan
ok(1); # If we made it this far, we're ok.
#########################
my $i = 0;
my %numbers = map {$_ => ++$i} qw /one two three four five six seven eight
nine ten eleven twelve/;
foreach my $hours (1 .. 24) {
foreach my $minutes (0 .. 59) {
my $r = babytime "$hours:$minutes";
Acme-Time-Constant
view release on metacpan or search on metacpan
# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.009.
.gitignore
.mailmap
.perltidyrc
.travis.yml
Changes
INSTALL.SKIP
LICENSE
Acme-Tools
view release on metacpan or search on metacpan
=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
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
See: L<http://en.wikipedia.org/wiki/Units_of_measurement>
=cut
#TODO: @arr2=conv(\@arr1,"from","to") # should be way faster than:
#TODO: @arr2=map conv($_,"from","to"),@arr1
#TODO: conv(123456789,'b','h'); # h converts to something human-readable
our %conv=(
length=>{
m => 1,
sub conv {
my($num,$from,$to)=@_;
croak "conf requires 3 args" if @_!=3;
conv_prepare() if !$conv_prepare_time;
my $types=sub{ my $unit=shift; [sort grep$conv{$_}{$unit}, keys%conv] };
my @types=map{ my $ru=$_; my $r;$r=&$types($_) and @$r and $$ru=$_ and last for ($$ru,uc($$ru),lc($$ru)); $r }(\$from,\$to);
my @err=map "Unit ".[$from,$to]->[$_]." is unknown",grep!@{$types[$_]},0..1;
my @type=intersect(@types);
push @err, "from=$from and to=$to has more than one possible conversions: ".join(", ", @type) if @type>1;
push @err, "from $from (".(join(",",@{$types[0]})||'?').") and "
."to $to (" .(join(",",@{$types[1]})||'?').") has no known common dimension (unit type).\n" if @type<1;
croak join"\n",map"conv: $_",@err if @err;
my $type=$type[0];
conv_prepare_money() if $type eq 'money' and time() >= $conv_prepare_money_time + $Currency_rates_expire;
return conv_temperature(@_) if $type eq 'temperature';
return conv_numbers(@_) if $type eq 'numbers';
my $c=$conv{$type};
# print STDERR "$num $from => $to from=$ff to=$ft r=$r\n";
return $r;
}
sub conv_temperature { #http://en.wikipedia.org/wiki/Temperature#Conversion
my($t,$from,$to)=(shift(),map uc(substr($_,0,1)),@_);
$from=~s/K/C/ and $t-=273.15;
#$from=~s/R/F/ and $t-=459.67; #rankine
return $t if $from eq $to;
{CK=>sub{$t+273.15},
FC=>sub{($t-32)*5/9},
=cut
our $Distance_factor = $PI / 180;
sub acos { atan2( sqrt(1 - $_[0] * $_[0]), $_[0] ) }
sub distance_great_circle {
my($lat1,$lon1,$lat2,$lon2)=map $Distance_factor*$_, @_;
my($Re,$Rp)=( 6378137.0, 6356752.3 ); #earth equatorial and polar radius
my $R=$Re-($Re-$Rp)*sin(abs($lat1+$lat2)/2); #approx
return $R*acos(sin($lat1)*sin($lat2)+cos($lat1)*cos($lat2)*cos($lon2-$lon1))
}
sub distance {
my($lat1,$lon1,$lat2,$lon2)=map $Distance_factor*$_, @_;
my $a= sin(($lat2-$lat1)/2)**2
+ sin(($lon2-$lon1)/2)**2 * cos($lat1) * cos($lat2);
my $sqrt_a =sqrt($a); $sqrt_a =1 if $sqrt_a >1;
my $sqrt_1ma=sqrt(1-$a); $sqrt_1ma=1 if $sqrt_1ma>1;
my $c=2*atan2($sqrt_a,$sqrt_1ma);
=cut
sub bigi {
eval q(use Math::BigInt try=>"GMP") if !$INC{'Math/BigInt.pm'};
if (wantarray) { return (map Math::BigInt->new($_),@_) }
else { return Math::BigInt->new($_[0]) }
}
sub bigf {
eval q(use Math::BigFloat try=>"GMP") if !$INC{'Math/BigFloat.pm'};
if (wantarray) { return (map Math::BigFloat->new($_),@_) }
else { return Math::BigFloat->new($_[0]) }
}
sub bigr {
eval q(use Math::BigRat try=>"GMP") if !$INC{'Math/BigRat.pm'};
if (wantarray) { return (map Math::BigRat->new($_),@_) }
else { return Math::BigRat->new($_[0]) }
}
sub big {
wantarray
? (map /\./ ? bigf($_) : /\// ? bigr($_) : bigi($_), @_)
: $_[0]=~/\./ ? bigf($_[0]) : $_[0]=~/\// ? bigr($_[0]) : bigi($_[0]);
}
sub bigscale {
@_==1 or croak "bigscale requires one and only one argument";
my $scale=shift();
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
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 trigram { sliding($_[0],$_[1]||3) }
sub sliding {
my($s,$w)=@_;
return map substr($s,$_,$w), 0..length($s)-$w if !ref($s);
return map [@$s[$_..$_+$w-1]], 0..@$s-$w if ref($s) eq 'ARRAY';
}
sub chunks {
my($s,$w)=@_;
return $s=~/(.{1,$w})/g if !ref($s);
return map [@$s[$_*$w .. min($_*$w+$w-1,$#$s)]], 0..$#$s/$w if ref($s) eq 'ARRAY';
}
sub chars { split//, shift }
=head2 repl
sim("Donald Duck", "Donald E. Knuth"); # returns 0.615
sim("Kalle Anka", "Kalle And")' # returns 0.842
sim("Kalle Anka", "Kalle Anka"); # returns 1
sim("Kalle Anka", "kalle anka"); # returns 0.8
sim(map lc, "Kalle Anka", "kalle anka"); # returns 1
Todo: more doc
=cut
=cut
sub sim_perm {
require String::Similarity;
my($s1,$s2)=map {s/^\s*(.+?)\s*$/$1/;$_} map upper($_), @_; #/r v5.14
croak if !length($s1) or !length($s2);
my $max;
for(cart([permutations(split(/[\s,]+/,$s1))],
[permutations(split(/[\s,]+/,$s2))])) {
my($n1,$n2)=@$_;
if(@$n1>@$n2){ pop@$n1 while @$n1>@$n2 }
else { pop@$n2 while @$n1<@$n2 }
my($str1,$str2)=map join(" ",@$_),($n1,$n2);
if(defined $max){
my $sim=String::Similarity::similarity($str1,$str2,$max);
$max=$sim if $sim>$max;
}
else {
binsearch(10,[5,10,15,20]); # 1
binsearch(10,[20,15,10,5],undef,sub{$_[1]<=>$_[0]}); # 2 search arrays sorted numerically in opposite order
binsearch("c",["a","b","c","d"],undef,sub{$_[0]cmp$_[1]}); # 2 search arrays sorted alphanumerically
binsearchstr("b",["a","b","c","d"]); # 1 search arrays sorted alphanumerically
my @data=( map { {num=>$_, sqrt=>sqrt($_), square=>$_**2} }
grep !$_%7, 1..1000000 );
my $i = binsearch( {num=>913374}, \@data, undef, sub {$_[0]{num} <=> $_[1]{num}} );
my $i = binsearch( {num=>913374}, \@data, undef, 'num' ); #same as previous line
my $found_hashref = defined $i ? $data[$i] : undef;
=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;
sub sortedstr { $_[$_] gt $_[$_+1] and return 0 for 0..$#$_-1; return 1 }
sub sortby {
my($arr,@by)=@_;
die if grep/^-/,@by; #hm 4now todo! - dash meaning descending order
my $pattern=join(" ",map"%-40s",@by);#hm 4now bad, cant handle numeric sort
map$$_[0],
sort{$$a[1]cmp$$b[1]}
map[$_,sprintf($pattern,@$_{@by})],
@$arr;
}
=head2 subarrays
[ 'c'],
['a', 'c'],
[ 'b','c'],
['a','b','c'] );
sub subarrays { map { my $n = 2*$_; [ grep {($n/=2)%2} @_ ] } 1 .. 2**@_-1 } #implemented as
=cut
sub subarrays { map { my $n = 2*$_; [ grep {($n/=2)%2} @_ ] } 1 .. 2**@_-1 }
=head2 part
B<Input:> A code-ref and a list
=cut
sub part (&@) { my($c,@r)=(shift,[],[]); push @{ $r[ &$c?0:1 ] }, $_ for @_; @r }
sub parth (&@) { my($c,%r)=(shift); push @{ $r{ &$c } }, $_ for @_; %r }
sub parta (&@) { my($c,@r)=(shift); push @{ $r[ &$c ] }, $_ for @_; @r }
#sub mapn (&$@) { ... } like map but @_ contains n elems at a time, n=1 is map
=head2 refa
=head2 refh
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
fix_colnames=>0,
);
my %conf=(%def,(@_<2?():%$conf));
# $conf{$_}||=$def{$_} for keys%def;
my %col;
map $col{$_}++, keys %$_ for @$aoh;
my @col=sort keys %col;
my @colerr=grep!/^[a-z]\w+$/i,@col;
croak "Invalid column name(s): @colerr" if @colerr and !$conf{fix_colnames};
my(%t,%tdb);
for my $c (@col){
$t{$c}=$t;
$tdb{$c}=$tdb;
}
my $sql;
$sql="create table $conf{name} (".
join(",",map sprintf("\n %-30s %s",do{s/\W+//g;$_},$tdb{$_}), @col). "\n);\n\n" if $conf{create};
my $val=sub{my($v,$t)=@_;defined$v or $v="";!length($v)?'null':$t eq 'number' ? $v : "'".repl($v,"\'","''")."'"};
for my $r (@$aoh){
my $v=join",",map &$val($$r{$_},$t{$_}), @col;
$sql.="insert into $conf{name} values ($v);\n";
}
$sql="drop table $conf{name};\n\n$sql" if $conf{drop}==1;
$sql="drop table if exists $conf{name};\n\n$sql" if $conf{drop}>=2;
$sql="$conf{begin}\n$sql" if $conf{begin};
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 "Median = " . percentile(50, 1,2,3,4); # 2.5
This:
@data=(11, 5, 3, 5, 7, 3, 1, 17, 4, 2, 6, 4, 12, 9, 0, 5);
@p = map percentile($_,@data), (25, 50, 75);
Is the same as this:
@p = percentile([25, 50, 75], @data);
$dice=random({1=>1, 2=>1, 3=>1, 4=>1, 5=>1, 6=>2}); # weighted dice with 6 being twice as likely as the others
@dice=random({1=>1, 2=>1, 3=>1, 4=>1, 5=>1, 6=>2},10); # 10 weighted dice tosses
print random({head=>0.4999,tail=>0.4999,edge=>0.0002}); # coin toss (sum 1 here but not required to be)
print random(2); # prints 0, 1 or 2
print 2**random(7); # prints 1, 2, 4, 8, 16, 32, 64 or 128
@dice=map random([1..6]), 1..10; # as third example above, but much slower
perl -MAcme::Tools -le 'print for random({head=>0.499,tail=>0.499,edge=>0.002},10000);' | sort | uniq -c
=cut
sub random {
my($from,$to)=@_;
my $ref=ref($from);
if($ref eq 'ARRAY'){
my @r=map $$from[rand@$from], 1..$to||1;
return @_>1?@r:$r[0];
}
elsif($ref eq 'HASH') {
my @k=keys%$from;
my $max;do{no warnings 'uninitialized';$_>$max and $max=$_ or $_<0 and croak"negative weight" for values%$from};
my @r=map {my$r;1 while $$from{$r=$k[rand@k]}<rand($max);$r} 1..$to||1;
return @_>1?@r:$r[0];
}
($from,$to)=(0,$from) if @_==1;
($from,$to)=($to,$from) if $from>$to;
return int($from+rand(1+$to-$from));
B<Output:> One or more pseudo-random numbers with a Gaussian distribution. Also known as a Bell curve or Normal distribution.
Example:
my @I=random_gauss(100, 15, 100000); # produces 100000 pseudo-random numbers, average=100, stddev=15
#my @I=map random_gauss(100, 15), 1..100000; # same but more than three times slower
print "Average is: ".avg(@I)."\n"; # prints a number close to 100
print "Stddev is: ".stddev(@I)."\n"; # prints a number close to 15
my @M=grep $_>100+15*2, @I; # those above 130
print "Percent above two stddevs: ".(100*@M/@I)."%\n"; #prints a number close to 2.2%
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()>.
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) }
}
print join(", ", distinct(4,9,3,4,"abc",3,"abc")); # 3, 4, 9, abc
print join(", ", distinct(4,9,30,4,"abc",30,"abc")); # 30, 4, 9, abc note: alphanumeric sort
=cut
sub distinct { sort keys %{{map {($_,1)} @_}} }
=head2 in
Returns I<1> (true) if first argument is in the list of the remaining arguments. Uses the perl-operator C<< eq >>.
perl -MAcme::Tools -le 'print join ",", union([1,2,3],[2,3,3,4,4])' # 1,2,3,4
=cut
sub union { my %seen; grep !$seen{$_}++, map @{shift()},@_ }
=head2 minus
Input: Two arrayrefs.
Output: An array containing all elements in the first input array but not in the second.
=cut
sub minus {
my %seen;
my %notme=map{($_=>1)}@{$_[1]};
grep !$notme{$_}&&!$seen{$_}++, @{$_[0]};
}
=head2 intersect
Output: C<< 4 3 five >>
=cut
sub intersect {
my %first=map{($_=>1)}@{$_[0]};
my %seen;
return grep{$first{$_}&&!$seen{$_}++}@{$_[1]};
}
=head2 not_intersect
=cut
sub a2h {
my @col=@{shift@_};
map { my%h;@h{@col}=@$_;\%h} @_;
}
sub h2a {
my %c;
map $c{$_}++, keys%$_ for @_;
my @c=sort{$c{$a}<=>$c{$b} or $a cmp $b}keys%c;
(\@c,map[@$_{@c}],@_);
}
=head1 COMPRESSION
L</zipb64>, L</unzipb64>, L</zipbin>, L</unzipbin>, L</gzip>, and L</gunzip>
$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;
}
return %R;
}
$f=~s/<t(d|r|h).*?>/\l$1$s/gsi;
$f=~s/\s*<.*?>\s*/ /gsi;
my @t=split("r$s",$f);shift @t;
$r||=sub{s/&(#160|nbsp);/ /g;s/&/&/g;s/^\s*(.*?)\s*$/$1/s;
s/(\d) (\d)/$1$2/g if /^[\d \.\,]+$/};
for(@t){my @r=split/[dh]$s/;shift@r;$_=[map{&$r;$_}@r]}
@t;
}
=head1 FILES, DIRECTORIES
B<Output:>
A list of all files in it, except of C<.> and C<..> (on linux/unix systems, all directories have a C<.> and C<..> directory).
The names of all types of files are returned: normal files, directories, symbolic links,
pipes, semaphores. That is every thing shown by C<ls -la> except C<.> and C<..>
C<readdirectory> do not recurce down into subdirectories (but see example below).
B<Example:>
Sometimes calling the built ins C<opendir>, C<readdir> and C<closedir> seems a tad tedious, since this:
my $dir="/usr/bin";
opendir(D,$dir);
my @files=map "$dir/$_", grep {!/^\.\.?$/} readdir(D);
closedir(D);
Is the same as this:
my @files=readdirectory("/usr/bin");
B<Example:>
How to get all files in the C</tmp> directory including all subdirectories below of any depth:
my @files=("/tmp");
map {-d $_ and unshift @files,$_ or push @files,$_} readdirectory(shift(@files)) while -d $files[0];
...or to avoid symlinks and only get real files:
map {-d and !-l and unshift @files,$_ or -f and !-l and push @files,$_} readdirectory(shift(@files)) while -d $files[0];
=cut
sub readdirectory {
my $dir=shift;
opendir(my $D,$dir);
my @filer=map "$dir/$_", grep {!/^\.\.?$/} readdir($D);
closedir($D);
return @filer;
}
=head2 basename
=cut
our @Openstrpath=(grep$_,split(":",$ENV{PATH}),qw(/usr/bin /bin /usr/local/bin));
our $Magic_openstr=1;
sub openstr_prog { @Openstrpath or return $_[0];(grep -x$_, map "$_/$_[0]", @Openstrpath)[0] or croak"$_[0] not found" }
sub openstr {
my($fn,$ext)=(shift()=~/^(.*?(?:\.(t?gz|bz2|xz))?)$/i);
return $fn if !$ext or !$Magic_openstr;
$fn =~ /^\s*>/
? "| ".(openstr_prog({qw/gz gzip bz2 bzip2 xz xz tgz gzip/ }->{lc($ext)})).$fn
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","Ã…")};
}
$Tms_pattern=join("|",map{quotemeta($_)}
sort{length($b)<=>length($a)}
keys %Tms_str);
#without sort "måned" could be "mared" because "mån"=>"mar"
}
elsif($s=~/^((?:17|18|19|20|21)\d\d)(0[1-9]|1[012])(0[1-9]|[12]\d|3[01])$/){#hm
$s="$1-$2-$3T00:00:00";
}
return Date::Parse::str2time($s) if !@_;
return tms(Date::Parse::str2time($s),shift(@_)) if 0+@_ == 1;
return map tms(Date::Parse::str2time($s),$_), @_;
}
sub date_ok {
my($y,$m,$d)=@_;
return date_ok($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/;
( $day, $month ) = easter( 2012 ); # $day == 8 and $month == 4
Example 2:
my @e=map sprintf("%02d%02d", reverse(easter($_))), 1800..300000;
print "First: ".min(@e)." Last: ".max(@e)."\n"; # First: 0322 Last: 0425
Note: The Spencer Jones formula differs Oudins used in C<easter()> in some years
before 1498. However, in that period the Julian calendar with a different formula was
used anyway. Countries introduced the current Gregorian calendar between 1583 and 1926.
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]);
The first argument is tested against the second, fourth, sixth and so on,
and then the third, fifth, seventh and so on is
returned if decode() finds an equal string or number.
In the above example: 123 maps to 3, 124 maps to 4 and the last argument $a is returned elsewise.
More examples:
my $a=123;
print decode($a, 123=>3, 214=>7, $a); # also 3, note that => is synonym for , (comma) in perl
Note: Filtering with hash lookups are WAY faster.
Source:
sub qrlist (@) { my $str=join"|",map quotemeta, @_; qr/^($str)$/ }
=cut
sub qrlist (@) {
my $str=join"|",map quotemeta,@_;
return qr/^($str)$/;
}
=head2 ansicolor
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.
#TODO: see t/test_perm.pl and t/test_perm2.pl
sub permutations {
my $code=ref($_[0]) eq 'CODE' ? shift() : undef;
$code and @_<6 and return map &$code(@$_),permutations(@_);
return [@_] if @_<2;
return ([@_[0,1]],[@_[1,0]]) if @_==2;
}
@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 @a1 = (1,2);
my @a2 = (10,20,30);
my @a3 = (100,200,300,400);
my $s = join"", map "*".join(",",@$_), cart(\@a1,\@a2,\@a3);
ok( $s eq "*1,10,100*1,10,200*1,10,300*1,10,400*1,20,100*1,20,200"
."*1,20,300*1,20,400*1,30,100*1,30,200*1,30,300*1,30,400"
."*2,10,100*2,10,200*2,10,300*2,10,400*2,20,100*2,20,200"
."*2,20,300*2,20,400*2,30,100*2,30,200*2,30,300*2,30,400");
$s=join"",map "*".join(",",@$_), cart(\@a1,\@a2,\@a3,sub{sum(@$_)%3==0});
ok( $s eq "*1,10,100*1,10,400*1,20,300*1,30,200*2,10,300*2,20,200*2,30,100*2,30,400");
B<Example, hash-mode:>
Returns hashrefs instead of arrayrefs:
sub cart {
my @ars=@_;
if(!ref($_[0])){ #if hash-mode detected
my(@k,@v); push@k,shift@ars and push@v,shift@ars while @ars;
return map{my%h;@h{@k}=@$_;\%h}cart(@v);
}
my @res=map[$_],@{shift@ars};
for my $ar (@ars){
@res=grep{&$ar(@$_)}@res and next if ref($ar) eq 'CODE';
@res=map{my$r=$_;map{[@$r,$_]}@$ar}@res;
}
return @res;
}
sub cart_easy { #not tested, not exported http://stackoverflow.com/questions/2457096/in-perl-how-can-i-get-the-cartesian-product-of-multiple-sets
my $last = pop @_;
@_ ? (map {my$left=$_; map [@$left, $_], @$last } cart_easy(@_) )
: (map [$_], @$last);
}
=head2 reduce
From: Why Functional Programming Matters: L<http://www.md.chalmers.se/~rjmh/Papers/whyfp.pdf> L<http://www.cse.chalmers.se/~rjmh/Papers/whyfp.html>
1998 Per 182 183 76 74
1998 Tone 70 71
.
my @reportB=pivot([map{$_=[@$_[0,3,2,1,4]]}(@t=@table)],"Year","Season");
print "\n\nReport B\n\n".tablestring(\@reportB);
Will print:
Report B
1998 Summer 171 168 182 64 62 76 70
1998 Winter 171 168 183 64 62 74 71
.
my @reportC=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name","Attributt");
print "\n\nReport C\n\n".tablestring(\@reportC);
Will print:
Report C
Per Weight 75 73 76 74
Tone Weight 70 69 70 71
.
my @reportD=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name");
print "\n\nReport D\n\n".tablestring(\@reportD);
Will print:
Report D
$feltfinnes{$felt}++;
$feltfinnes{"%$felt"}++ if $opt_pro;
}
my @feltfinnes = sort $sortsub_bortover keys%feltfinnes;
push @feltfinnes, "Sum" if $opt_sum;
my @t=([@vertikalefelt,map{replace($_,$;,"\n")}@feltfinnes]);
#print serialize(\@feltfinnes,'feltfinnes');
#print serialize(\%h,'h');
#print "H = ".join(", ",sort _sortsub keys%h)."\n";
for my $rad (sort $sortsub_nedover keys(%h)){
my @rad=(split($;,$rad),
map { defined($_)?$_:exists$opt{undefined}?$opt{undefined}:undef }
map {
if(/^\%/ and defined $opt_pro){
my $sum=$h{$rad}{Sum};
my $verdi=$h{$rad}{$_};
if($sum!=0){
defined $verdi
}
}
@feltfinnes);
push(@t,[@rad]);
}
push(@t,"-",["Sum",(map{""}(2..$antned)),map{print "<$_>\n";$sum{$_}}@feltfinnes]) if $opt_sum;
return @t;
}
# default sortsub for pivot()
$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;
=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
sub brainfu2perl {
my($bf,$inp)=@_;
my $perl='my($c,$inp,$o,@b)=(0,\''.$inp.'\'); no warnings; sub out{$o.=chr($b[$c]) for 1..$_[0]||1}'."\n";
$perl.='sub inp{$inp=~s/(.)//s and $b[$c]=ord($1)}'."\n" if $inp and $bf=~/,/;
$perl.=join("",map/\+/?'++$b[$c];':/\-/?'--$b[$c];':/\[/?'while($b[$c]){':/\]/?'}':/>/?'++$c;':/</?'--$c;':/\./?'out;':/\,/?'inp;':'',split//,$bf).'$o;';
$perl;
}
sub brainfu2perl_optimized {
my $perl=brainfu2perl(@_);
key_count => 0,
overflow => {},
version => $Acme::Tools::VERSION,
};
croak "Error rate ($$bf{error_rate}) should be larger than 0 and smaller than 1" if $$bf{error_rate}<=0 or $$bf{error_rate}>=1;
@$bf{'min_hashfuncs','max_hashfuncs'}=(map$arg{hashfuncs},1..2) if $arg{hashfuncs};
@$bf{'filterlength','hashfuncs'}=bfdimensions($bf); #m and k
$$bf{filter}=pack("b*", '0' x ($$bf{filterlength}*$$bf{counting_bits}) ); #hm x new empty filter
$$bf{unpack}= $$bf{filterlength}<=2**16/4 ? "n*" # /4 alleviates skewing if m just slightly < 2**x
:$$bf{filterlength}<=2**32/4 ? "N*"
: "Q*";
return $bf;
}
sub bfaddbf {
my($bf,$bf2)=@_;
my $differror=join"\n",
map "Property $_ differs ($$bf{$_} vs $$bf2{$_})",
grep $$bf{$_} ne $$bf2{$_},
qw/capacity counting_bits adaptive hashfuncs filterlength/; #not error_rate
croak $differror if $differror;
croak "Can not add adaptive bloom filters" if $$bf{adaptive};
my $count=$$bf{key_count}+$$bf2{key_count};
return if !@keys;
my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys;
my($m,$k,$up,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','counting_bits','adaptive'};
my $wa=wantarray();
if(!$adaptive){ # normal bloom filter or counting bloom filter
return map {
my $match = 1; # match if every bit is on
my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k;
vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1;
return $match if !$wa;
$match;
} @$keysref;
}
else { # adaptive bloom filter
return map {
my($match,$i,$key,$bit,@h)=(1,0,$_);
for(0..$$bf{filterlength}-1){
$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h;
my $pos=shift(@h) % $m;
$bit=vec($$bf{filter}, $pos, 1);
return $match if !$wa;
$match;
} @$keysref;
}
}
sub bfgrep { # just a copy of bfcheck with map replaced by grep
require Digest::MD5;
my($bf,@keys)=@_;
return if !@keys;
my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys;
my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'};
#crontab -e
#01 4,10,16,22 * * * /usr/bin/perl -MAcme::Tools -e'Acme::Tools::_update_currency_file("/var/www/html/currency-rates")' > /dev/null 2>&1
sub _update_currency_file { #call from cron
my $fn=shift()||'/var/www/html/currency-rates';
my %exe=map+($_=>"/usr/bin/$_"),qw/curl ci/;-x$_ or croak for values %exe;
open my $F, '>', $fn or die"ERROR: Could not write file $fn ($!)\n";
print $F "#-- Currency rates ".localtime()." (".time().")\n";
print $F "# File generated by Acme::Tools version $VERSION\n";
print $F "# Updated every 6th hour on http://calthis.com/currency-rates\n";
print $F "NOK 1.000000000\n";
my $amount=1000;
my $data=qx($exe{curl} -s "https://www.x-rates.com/table/?from=NOK&amount=$amount");
$data=~s,to=([A-Z]{3})(.)>,$2>$1</td><td>,g;
my @data=ht2t($data,"Alphabetical order"); shift @data;
@data=map "$$_[1] ".($$_[4]>1e-2?$$_[4]:$$_[2]?sprintf("%.8f",$amount/$$_[2]):0)."\n",@data;
my %data=map split,@data;
my $json=qx( $exe{curl} -s https://api.coinmarketcap.com/v1/ticker/ );
eval "require JSON;"; croak if $@;
my $arr=JSON::decode_json($json);
for my $c (qw(BTC LTC XBT ETH XRP BCH ETC)) {
my @a=grep$$_{symbol} eq $c,@$arr;
$s=~tr,0-9a-zA-Z+=/,,cd;
if($Fix_unbase64){ $s.='=' while length($s)%4 }
croak "unbase64 failed: length ".length($s)." not multiple of 4" if length($s)%4;
$s=~s/=+$//;
$s=~tr|A-Za-z0-9+/| -_|;
length($s) ? unpack("u",join'',map(chr(32+length($_)*3/4).$_,$s=~/(.{1,60})/gs)) : "";
}
=head1 COMMANDS
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;
: (sort{$b{$a}<=>$b{$b} or $a cmp $b}keys%c);
my $perc=!$o{M}&&!$o{C}&&!$o{A}&&!$o{P}?sub{""}:
sub{
my @p=$o{P}?(10,50,90):(50);
my @m=@_>0 ? do {grep$_, split",", $xtime{$_[0]}}
: do {grep$_, map {split","} values %xtime};
my @r=percentile(\@p,@m);
@r=(min(@m),@r,max(@m)) if $o{M}||$o{C}||$o{A};
@r=map int($_), @r;
my $fmt=$o{t}?'YYYY/MM/DD-MM:MI:SS':'YYYY/MM/DD';
@r=map tms($_,$fmt), @r;
" ".join(" ",@r);
};
my $width=max( 10, grep $_, map length($_), @e );
@e=@e[-10..-1] if $o{t} and @e>10; #-t tail
printf("%-*s %8d $f %7.2f%%%s\n",$width,$_,$c{$_},&$s($b{$_}),100*$b{$_}/$bts,&$perc($_)) for @e;
printf("%-*s %8d $f %7.2f%%%s\n",$width,"Sum",$cnt,&$s($bts),100,&$perc());
}
sub cmd_resubst {
my $zo="123456789e";
my @argv=opts("f:t:vno:gi$zo",\%o,@_);
if(exists$o{t}){ $o{t}=~s,\\,\$, } else { $o{t}='' }
my($i,$tc,$tbfr,$tbto)=(0,0,0,0);
for my $file (@argv){
my $zopt=join" ",map"-$_",grep$o{$_},split//,$zo;
my $oext=$o{o}?$o{o}:$file=~/\.(gz|bz2|xz)$/i?$1:'';
my $open_out_pre=$oext?"|".openstr_prog({qw/gz gzip bz2 bzip2 xz xz/}->{lc($oext)})." $zopt":'';
my $open_out="$open_out_pre > $file.tmp$$";
my $open_in=openstr($file);
# die srlz(\%o,'o','',1);
close($FH);
}
}
sub cmd_freq {
my(@f,$i);
map $f[$_]++, unpack("C*",$_) while <>;
my $s=" " x 12;map{print"$_$s$_$s$_\n"}("BYTE CHAR COUNT","---- ----- -------");
my %m=(145,"DOS-æ",155,"DOS-ø",134,"DOS-å",146,"DOS-Æ",157,"DOS-Ø",143,"DOS-Å",map{($_," ")}0..31);
printf("%4d %5s%8d".(++$i%3?$s:"\n"),$_,$m{$_}||chr,$f[$_]) for grep$f[$_],0..255;print "\n";
my @no=grep!$f[$_],0..255; print "No bytes for these ".@no.": ".join(" ",@no)."\n";
}
sub cmd_deldup {
cmd_finddup('-d',@_);
# die "todo: finddup not ready yet"
my %o;
my @argv=opts("ak:dhsnqv0P:FMRp",\%o,@_); $o{P}=1024*8 if!defined$o{P}; $o{k}='' if!defined$o{k};
croak"ERR: cannot combine -a with -d, -s or -h" if $o{a} and $o{d}||$o{s}||$o{h};
require File::Find;
@argv=map{
my @f;
if(-d$_){ File::Find::find({follow=>0,wanted=>sub{return if !-f$_;push@f,$File::Find::name;1}},$_) }
else { @f=($_) }
@f;
}@argv;
sub{-s$_[0]<=$o{P}?md5sum($_[0]):&$md5sum_1st_part($_[0])},
sub{md5sum($_[0])}
);
pop @checks if $o{M}; #4tst
my $i=0;
my %s=map{($_=>++$i)}@argv; #sort
my %f=map{($_=>[$_])}@argv; #also weeds out dupl params
for my $c (@checks){
my @f=map @{$f{$_}}, sort keys %f;
if($o{p} and $c eq $checks[-1]){ #view progress for last check, todo: eta() is wacky here! everywhere?
my $sum=@f?sum(map -s$_,@f):0;
my($corg,$cnt,$cntmb,$mb)=($c,0,0,$sum/1e6);
$c=sub{
$cntmb+=(-s$_[0])/1e6;
my $eol=++$cnt==@f?"\n":"\r";
print STDERR sprintf("%d/%d files checked (%d%%), %d/%d MB (%d%%), ETA in %d sec $eol",
my@r=sort{$s{$$a[0]}<=>$s{$$b[0]}}values%f;
my $si={qw(o 9 n 9 O 8 N 8)}->{$o{k}}; #stat index: 9=mtime, 8=atime
my $sort=lc$o{k} eq 'o' ? sub{sprintf"%011d%9d", (stat($_[0]))[$si],$s{$_[0]}}
:lc$o{k} eq 'n' ? sub{sprintf"%011d%9d",1e11-(stat($_[0]))[$si],$s{$_[0]}}
: sub{sprintf "%9d", $s{$_[0]}};
@$_=map$$_[1],sort{$$a[0]cmp$$b[0]}map[&$sort($_),$_],@$_ for @r;
my %of; #dup of
for my $r (@r){
$of{$_}=$$r[0] for @$r[1..$#$r];
}
my $nl=$o{0}?"\x00":"\n";
my $print=sub{$o{q} or print $_[0]};
my $do=sub{ $o{v} && &$print("$_[0]$nl"); qx($_[0]) };
my $go=sub{ $o{n} ? &$print("$_[0]$nl") : &$do($_[0]) };
&$print(join$nl,map join("",map"$_$nl",@$_),@r) and return if $o{a};
@r=map@$_[1..$#$_],@r;
return @r if $o{R}; #hm
unlink@r if $o{d}||$o{s}||$o{h} and !$o{n}; #delete duplicates
map &$go(qq(rm "$_") ),@r if $o{d}&& $o{n}; #delete duplicates, dryrun
map &$go(qq(ln "$of{$_}" "$_")),@r if $o{h}; #replace duplicates with hardlink
map &$go(qq(ln -s "$of{$_}" "$_")),@r if $o{s}; #replace duplicates with symlink,
#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
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);
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
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";
#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"
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;
}
}
}
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);
next if !$sf;
my(@t,@s);
for my $prog (@prog){
next if !qx(which $prog);
my @l=1..9;
push @l,map"e$_",1..9 if $prog eq 'xz' and $o{e};
@l=map"e$_",1..9 if $prog eq 'xz' and $o{E};
@l=map 10+$_,@l if $prog eq 'zstd';
@l=map"q $_",3..11 if $prog eq 'brotli';
printf "%-6s",$prog;
push @t, $prog, [] if $o{t};
push @s, $prog, [] if $o{p} and $o{s};
for my $l (@l){ #level
my $t=time_fp();
our $Wget;
our $Self_update_url='https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm'; #todo: change site
sub self_update {
#in($^O,'linux','cygwin') or die"ERROR: self_update works on linux and cygwin only";
$Wget||=(grep -x$_,map"$_/wget",'/usr/bin','/bin','/usr/local/bin','.')[0]; #hm --no-check-certificate
-x$Wget or die"ERROR: wget ($Wget) executable not found\n";
my $d=dirname(__FILE__);
sys("cd $d; ls -l Tools.pm; md5sum Tools.pm");
sys("cd $d; $Wget -N ".($ARGV[0]||$Self_update_url));
sys("cd $d; ls -l Tools.pm; md5sum Tools.pm");
Acme-Types-NonStandard
view release on metacpan or search on metacpan
t/00-report-prereqs.t view on Meta::CPAN
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
else {
splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports;
}
push @full_reports, "\n";
}
}
Acme-UNIVERSAL-can-t
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
my %WriteMakefileArgs = (
ABSTRACT => $meta->{abstract},
AUTHOR => ($EUMM >= 6.5702 ? $meta->{author} : $meta->{author}[0]),
DISTNAME => $meta->{name},
VERSION => $meta->{version},
EXE_FILES => [ map $_->{file}, values %{ $meta->{x_provides_scripts} || {} } ],
NAME => do { my $n = $meta->{name}; $n =~ s/-/::/g; $n },
test => { TESTS => "t/*.t" },
%dynamic_config,
);
Makefile.PL view on Meta::CPAN
}
{
my ($minperl) = reverse sort(
grep defined && /^[0-9]+(\.[0-9]+)?$/,
map $meta->{prereqs}{$_}{requires}{perl},
qw( configure build runtime )
);
if (defined($minperl))
{
Acme-UNIVERSAL-new
view release on metacpan or search on metacpan
lib/Acme/UNIVERSAL/new.pm view on Meta::CPAN
}
sub get_symbols
{
my $table = shift;
return map { my $name = $_; s/::$//; $name => $_ }
grep { /::$/ }
keys %$table;
}
sub get_ref
Acme-UPnP
view release on metacpan or search on metacpan
lib/Acme/UPnP.pm view on Meta::CPAN
$service_type = $svc_type;
$self->_emit( device_found => { name => 'UPnP Gateway' } );
return 1;
}
method map_port ( $int_port, $ext_port, $proto, $desc ) {
return 0 unless $control_url;
my $local_ip = $self->_get_local_ip();
my $args = {
NewRemoteHost => '',
NewExternalPort => $ext_port,
lib/Acme/UPnP.pm view on Meta::CPAN
NewEnabled => 1,
NewPortMappingDescription => $desc,
NewLeaseDuration => 0
};
if ( $self->_send_soap( AddPortMapping => $args ) ) {
$self->_emit( map_success => { int_p => $int_port, ext_p => $ext_port, proto => $proto, desc => $desc } );
return 1;
}
else {
$self->_emit( map_failed => { err_c => 500, err_d => 'SOAP Failed' } );
return 0;
}
}
method unmap_port ( $ext_port, $proto ) {
return 0 unless $control_url;
my $args = { NewRemoteHost => '', NewExternalPort => $ext_port, NewProtocol => $proto };
if ( $self->_send_soap( DeletePortMapping => $args ) ) {
$self->_emit( unmap_success => { ext_p => $ext_port, proto => $proto } );
return 1;
}
$self->_emit( unmap_failed => { err_c => 500, err_d => 'SOAP Failed' } );
return 0;
}
method get_external_ip () {
return undef unless $control_url;
Acme-Umlautify
view release on metacpan or search on metacpan
lib/Acme/Umlautify.pm view on Meta::CPAN
push our @ISA, 'Exporter';
our @EXPORT = qw/umlautify umlautify_latin/;
our @EXPORT_OK = qw/umlautify umlautify_latin/;
our %map = ( A => 196, E => 203, I => 207, O => 214, U => 220, a => 228,
e => 235, i => 239, o => 246, u => 252, y => 255 );
sub new {
bless({},$_[0]);
}
lib/Acme/Umlautify.pm view on Meta::CPAN
return $self->umlautify(@_);
}
sub umlautify {
shift @_ if ref $_[0] eq 'Acme::Umlautify';
my @out = map { join '', map { $_ =~ /[\s\t\n]/ ? $_ : "$_\x{0308}" } split '', $_; } @_;
return wantarray ? @out : $out[0];
}
sub umlautify_latin {
shift @_ if ref $_[0] eq 'Acme::Umlautify';
our %map;
my @out = map { join '', map { $_=chr($map{$_}) if $map{$_}; $_ } split '', $_; } @_;
return wantarray ? @out : $out[0];
}
__END__
Acme-Unicodify
view release on metacpan or search on metacpan
t/00-report-prereqs.t view on Meta::CPAN
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
else {
splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports;
}
push @full_reports, "\n";
}
}
Acme-Urinal
view release on metacpan or search on metacpan
lib/Acme/Urinal.pm view on Meta::CPAN
sub new {
my ($class, $resources) = @_;
if (ref $resources) {
return bless [ map { [ 0, $_ ] } @$resources ], $class;
}
elsif ($resources > 0) {
return bless [ map { [ 0, $_ ] } 0 .. ($resources - 1) ], $class;
}
else {
croak "incorrect argument";
}
}
Acme-UseStrict
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
my %WriteMakefileArgs = (
ABSTRACT => $meta->{abstract},
AUTHOR => ($EUMM >= 6.5702 ? $meta->{author} : $meta->{author}[0]),
DISTNAME => $meta->{name},
VERSION => $meta->{version},
EXE_FILES => [ map $_->{file}, values %{ $meta->{x_provides_scripts} || {} } ],
NAME => do { my $n = $meta->{name}; $n =~ s/-/::/g; $n },
test => { TESTS => "t/*.t" },
%dynamic_config,
);
Makefile.PL view on Meta::CPAN
}
{
my ($minperl) = reverse sort(
grep defined && /^[0-9]+(\.[0-9]+)?$/,
map $meta->{prereqs}{$_}{requires}{perl},
qw( configure build runtime )
);
if (defined($minperl))
{
Acme-VOYAGEGROUP-ConferenceRoom
view release on metacpan or search on metacpan
lib/Acme/VOYAGEGROUP/ConferenceRoom/Output/Color.pm view on Meta::CPAN
sub convert {
my $class = shift;
my $lines = shift;
join "\n", map { $_ =~ s!(/+)!\e[31m$1\e[m!; $_ } @{$lines};
}
1;
Acme-VarMess
view release on metacpan or search on metacpan
inc/Module/Install/AutoInstall.pm view on Meta::CPAN
require CPANPLUS;CPANPLUS::install$p};eval"use $p $v;1"or eval{
require CPAN;CPAN::install$p};eval"use $p $v;1"||die"*** Please
manually install $p $v from cpan.org first...\n"}}}
# Flatten array of arrays into a single array
my @core = map @$_, map @$_, grep ref,
$self->build_requires, $self->requires;
while ( @core and @_ > 1 and $_[0] =~ /^-\w+$/ ) {
push @core, splice(@_, 0, 2);
}
Acme-Version-Hex
view release on metacpan or search on metacpan
CONTRIBUTING view on Meta::CPAN
If you send me a patch or pull request, your name and email address will be
included in the documentation as a contributor (using the attribution on the
commit or patch), unless you specifically request for it not to be. If you
wish to be listed under a different name or address, you should submit a pull
request to the .mailmap file to contain the correct mapping.
This file was generated via Dist::Zilla::Plugin::GenerateFile::ShareDir 0.005 from a
template file originating in Dist-Zilla-PluginBundle-Author-ETHER-0.092.
Acme-VerySign
view release on metacpan or search on metacpan
lib/Acme/VerySign.pm view on Meta::CPAN
# Note that we deliberately omit function names that exist
# in the %_BARRED hash
my (@subs, @orig);
my $sym = Devel::Symdump->new($pkg);
@orig = @subs = grep { ! $_BARRED{$_} }
map { s/${pkg}:://; $_ }
grep { defined &{$_} } $sym->functions($pkg);
# Transform all of the subroutine names
foreach (@{$CONF{xform}}) {
croak "Invalid transformer passed to Acme::VerySign\n"
lib/Acme/VerySign.pm view on Meta::CPAN
####################################################################
# unique that array
my %orig = map { $_ => 1 } @orig;
my $this = bless [keys %orig], $class;
return $this;
}
sub as_string { "64.94.110.11" }
Acme-W
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map {
$_ . '0' x (3 - length $_)
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
Acme-Waterkip
view release on metacpan or search on metacpan
t/00-compile.t view on Meta::CPAN
for my $lib (@module_files)
{
# see L<perlfaq8/How can I capture STDERR from an external command?>
my $stderr = IO::Handle->new;
diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} }
$^X, @switches, '-e', "require q[$lib]"))
if $ENV{PERL_COMPILE_TEST_DEBUG};
my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]");
binmode $stderr, ':crlf' if $^O eq 'MSWin32';
Acme-What
view release on metacpan or search on metacpan
examples/weather.pl view on Meta::CPAN
);
my ($temperature) = XML::LibXML
-> load_xml(location => $xml_location)
-> findnodes('//yweather:condition/@temp')
-> map(sub { $_->value });
return "$temperature $unit";
}
local $^F = 1;
Acme-Win32-PEPM
view release on metacpan or search on metacpan
lib/Win32/PEPM.pm view on Meta::CPAN
a .pm that can be C<do>, C<require>d, or C<use>d, and the same .pm is a 100%
real DLL containing XS code. The generated file meets the file format standards
of both a .pm and a PE (Portable Executable) DLL and uses no temp files.
The author of this module sees this module as a joke since with this
"packager", the .pm text is stored uncompressed in the .dll, and there is no
sane reason to keep .pm text memory mapped into a process since after
parsing/compiling .pm, the .pm text is never referenced again, yet with this
"packager", if the XS DLL is loaded, so is the .pm text, into the process.
The resulting .pm that is built can not be edited even though it mostly looks
like plain text. If it is edited, the DLL will be corrupt. The resulting .pm,
Acme-Working-Out-Dependencies-From-META-files-Will-Be-Wrong-At-Some-Point-Like-This-Module-For-Instance
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
my $count = scalar keys %possibles;
my $prereqs_pm = { };
$prereqs_pm->{$_} = $possibles{$_}
for map { ( keys %possibles )[ int rand $count-1 ] } (0 .. 10);
WriteMakefile (
NAME => 'Acme::Working::Out::Dependencies::From::META::files::Will::Be::Wrong::At::Some::Point::Like::This::Module::For::Instance',
VERSION_FROM => 'lib/Acme/Working/Out/Dependencies/From/META/files/Will/Be/Wrong/At/Some/Point/Like/This/Module/For/Instance.pm',
PREREQ_PM => $prereqs_pm,
Acme-YAPC-Asia-2012-LTthon-Hakushu
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map {
$_ . '0' x (3 - length $_)
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
Acme-YAPC-Okinawa-Bus
view release on metacpan or search on metacpan
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
}
else {
$opt{'compat-version'} = 5;
}
my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
? ( $1 => {
($2 ? ( base => $2 ) : ()),
($3 ? ( todo => $3 ) : ()),
(index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
(index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
_aMY_CXT|5.007003||p
_add_range_to_invlist|||
_append_range_to_invlist|||
_core_swash_init|||
_get_encoding|||
_get_regclass_nonbitmap_data|||
_get_swash_invlist|||
_invlist_array_init|||n
_invlist_contains_cp|||n
_invlist_contents|||
_invlist_dump|||
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
ptr_table_free||5.009005|
ptr_table_new||5.009005|
ptr_table_split||5.009005|
ptr_table_store||5.009005|
push_scope|||
put_charclass_bitmap_innards|||
put_code_point|||
put_range|||
pv_display|5.006000||p
pv_escape|5.009004||p
pv_pretty|5.009004||p
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
$replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
$replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
$replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
my @deps = map { s/\s+//g; $_ } split /,/, $3;
my $d;
for $d (map { s/\s+//g; $_ } split /,/, $1) {
push @{$depends{$d}}, @deps;
}
}
$need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
exit 0;
}
my @files;
my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
my $srcext = join '|', map { quotemeta $_ } @srcext;
if (@ARGV) {
my %seen;
for (@ARGV) {
if (-e) {
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
$File::Find::name =~ /($srcext)$/i
and push @files, $File::Find::name;
}, '.');
};
if ($@) {
@files = map { glob "*$_" } @srcext;
}
}
if (!@ARGV || $opt{filter}) {
my(@in, @out);
my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
for (@files) {
my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i;
push @{ $out ? \@out : \@in }, $_;
}
if (@ARGV && @out) {
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
my($func, $seen) = @_;
return () unless exists $depends{$func};
$seen = {%{$seen||{}}};
return () if $seen->{$func}++;
my %s;
grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
}
sub parse_version
{
my $ver = shift;
Acme-YBFOD
view release on metacpan or search on metacpan
lib/YourBrainForOnceDude.pm view on Meta::CPAN
package YourBrainForOnceDude;
our $VERSION = '0.18';
require Acme::Buffy;
INIT {
local $/; my @magic = qw(-11 3 5 -3 11);
my @brains=Acme::Buffy::_unslay(($B=<DATA>)=~s/(r(a(i(n))))/join'.',map"chr(ord(\$$_)+$magic[$_])",(1..4)/geieio,$B)=~/(.*?\012)/g;
END {printf $brains[int rand(@brains)], __PACKAGE__}
}
__DATA__
BRaiN bRAIN BRaiN bRAIN BraIN BrAIN bRAiN BrAIN BRAin braIN BRAiN BraIN brain brAIn BRAiN BrAIN BRain BrAIn bRAiN BraIN BRaiN BrAIn BRAin BraIN BrAiN BraiN bRAin BRaIN BraIN Brain bRaiN BrAIN BRaiN BrAiN bRAin BraIN brain brAiN bRaiN brAIN bRAIn braI...
Acme-Your
view release on metacpan or search on metacpan
lib/Acme/Your/Filter.pm view on Meta::CPAN
$assign = $tree->[-2];
}
my @ids = _walk_tree($tree);
my $new_statement = join('', map { _variable_declaration($pattern, $_) } @ids );
if ($assign) {
$new_statement .= "(". join(', ', @ids) .") = $assign;";
}
#print $new_statement;
return $new_statement;
Acme-Zalgo
view release on metacpan or search on metacpan
lib/Acme/Zalgo.pm view on Meta::CPAN
\x{0347}\x{0348}\x{0349}\x{034d}
\x{034e}\x{0353}\x{0354}\x{0355}
\x{0356}\x{0359}\x{035a}\x{0323}
HE_COMES
our @ZALGO = map { my $s = $_; $s =~ s/\s+//g; $s } grep {$_} split qr/^#.*?$/ms, $chars;
use Carp;
sub randint {
my ($min, $max) = @_;
Acme-ZeroWidth
view release on metacpan or search on metacpan
lib/Acme/ZeroWidth.pm view on Meta::CPAN
sub to_zero_width {
my ($visible) = @_;
my $not_visible = join "\x{200d}",
map { s/1/\x{200b}/g; s/0/\x{200c}/g; $_ }
map { unpack 'B*', $_ } split //,
$visible;
return $not_visible;
}
sub from_zero_width {
my ($not_visible) = @_;
return join '', map { pack 'B*', $_ }
map { s/\x{200b}/1/g; s/\x{200c}/0/g; $_ } split /\x{200d}/, $not_visible;
}
1;
__END__
Acme-ZydecoTesting-App1
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
my %WriteMakefileArgs = (
ABSTRACT => $meta->{abstract},
AUTHOR => ($EUMM >= 6.5702 ? $meta->{author} : $meta->{author}[0]),
DISTNAME => $meta->{name},
VERSION => $meta->{version},
EXE_FILES => [ map $_->{file}, values %{ $meta->{x_provides_scripts} || {} } ],
NAME => do { my $n = $meta->{name}; $n =~ s/-/::/g; $n },
test => { TESTS => "t/*.t" },
%dynamic_config,
);
Makefile.PL view on Meta::CPAN
}
{
my ($minperl) = reverse sort(
grep defined && /^[0-9]+(\.[0-9]+)?$/,
map $meta->{prereqs}{$_}{requires}{perl},
qw( configure build runtime )
);
if (defined($minperl))
{
Acme-emcA
view release on metacpan or search on metacpan
inc/Module/Install/Makefile.pm view on Meta::CPAN
die "tests_recursive dir '$dir' does not exist";
}
require File::Find;
%test_dir = ();
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
inc/Module/Install/Makefile.pm view on Meta::CPAN
}
# merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ }
map { @$_ }
grep $_,
($self->build_requires, $self->requires)
);
# merge both kinds of requires into prereq_pm
inc/Module/Install/Makefile.pm view on Meta::CPAN
. "but we need version >= $perl_version";
}
$args->{INSTALLDIRS} = $self->installdirs;
my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
if (my $preop = $self->admin->preop($user_preop)) {
$args{dist} = $preop;
}
Acme-eng2kor
view release on metacpan or search on metacpan
lib/Acme/eng2kor.pm view on Meta::CPAN
);
sub translate {
my ($self, $word) = @_;
map { s/^\s+//; s/\s+$// } $word if defined $word;
return $self->_google_translate($word);
}
sub _google_translate {
( run in 1.403 second using v1.01-cache-2.11-cpan-39bf76dae61 )