Acme-Tools
view release on metacpan or search on metacpan
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);
my($Re,$Rp)=( 6378137.0, 6356752.3 ); #earth equatorial and polar radius
my $R=$Re-($Re-$Rp)*sin(abs($lat1+$lat2)/2); #approx
return $c*$R;
}
=head2 big
=head2 bigi
=head2 bigf
=head2 bigr
=head2 bigscale
big, bigi, bigf, bigr and bigscale are sometimes convenient shorthands for using
C<< Math::BigInt->new() >>, C<< Math::BigFloat->new() >> and C<< Math::BigRat->new() >>
(preferably with the GMP for faster calculations). Examples:
my $num1 = big(3); #returns a new Math::BigInt-object
my $num2 = big('3.0'); #returns a new Math::BigFloat-object
my $num3 = big(3.0); #returns a new Math::BigInt-object
my $num4 = big(3.1); #returns a new Math::BigFloat-object
my $num5 = big('2/7'); #returns a new Math::BigRat-object
my($i1,$f1,$i2,$f2) = big(3,'3.0',3.0,3.1); #returns the four new numbers, as the above four lines
#uses wantarray
print 2**200; # 1.60693804425899e+60
print big(2)**200; # 1606938044258990275541962092341162602522202993782792835301376
print 2**big(200); # 1606938044258990275541962092341162602522202993782792835301376
print big(2**200); # 1606938044258990000000000000000000000000000000000000000000000
print 1/7; # 0.142857142857143
print 1/big(7); # 0 because of integer arithmetics
print 1/big(7.0); # 0 because 7.0 is viewed as an integer, see bigf below
print 1/big('7.0'); # 0.1428571428571428571428571428571428571429
print 1/bigf(7); # 0.1428571428571428571428571428571428571429
print bigf(1/7); # 0.142857142857143 probably not what you wanted
print 1/bigf(7); # 0.1428571428571428571428571428571428571429
bigscale(80); # for increased precesion (default is 40)
print 1/bigf(7); # 0.14285714285714285714285714285714285714285714285714285714285714285714285714285714
In C<big()> the characters C<< . >> and C<< / >> will make it return a
Math::BigFloat- and Math::BigRat-object accordingly. Or else a Math::BigInt-object is returned.
Instead of guessing, use C<bigi>, C<bigf> and C<bigr> to return what you want.
B<Note:> Acme::Tools does not depend on Math::BigInt and
Math::BigFloat and GMP, but these four big*-subs do (by C<require>).
To use big, bigi, bigf and bigr effectively you should
install Math::BigInt::GMP and Math::BigFloat::GMP like this:
sudo cpanm Math::BigFloat Math::GMP Math::BingInt::GMP # or
sudo cpan Math::BigFloat Math::GMP Math::BingInt::GMP # or
sudo yum install perl-Math-BigInt-GMP perl-Math-GMP # on RedHat, RHEL or
sudo apt-get install libmath-bigint-gmp-perl libmath-gmp-perl # on Ubuntu or some other way
Unless GMP is installed for perl like this, the Math::Big*-modules
will fall back to using similar but slower built in modules. See: L<https://gmplib.org/>
=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();
eval q(use Math::BigInt try=>"GMP") if !$INC{'Math/BigInt.pm'};
eval q(use Math::BigFloat try=>"GMP") if !$INC{'Math/BigFloat.pm'};
eval q(use Math::BigRat try=>"GMP") if !$INC{'Math/BigRat.pm'};
Math::BigInt->div_scale($scale);
Math::BigFloat->div_scale($scale);
Math::BigRat->div_scale($scale);
return;
}
#my $R_authalic=6371007.2; #earth radius in meters, mean, Authalic radius, real R varies 6353-6384km, http://en.wikipedia.org/wiki/Earth_radius
#*)
# ( 6378157.5, 6356772.2 ) #hmm
#my $e=0.081819218048345;#sqrt(1 - $b**2/$a**2); #eccentricity of the ellipsoid
#my($a,$b)=( 6378137.0, 6356752.3 ); #earth equatorial and polar radius
#warn "e=$e\n";
#warn "t=".(1 - $e**2)."\n";
#warn "n=".((1 - $e**2 * sin(($lat1+$lat1)/2)**2)**1.5)."\n";
#my $t=1 - $e**2;
#my $n=(1 - $e**2 * sin(($lat1+$lat1)/2)**2)**1.5;
#warn "t=$t\n";
#warn "n=$n\n";
else { croak "pwgen: invalid req type $r ".ref($r) }
}
push@pw,$pw;
}
$Pwgen_sec=time_fp()-$t;
return $pw[0] if $num==1;
return @pw;
}
# =head1 veci
#
# Perls C<vec> takes 1, 2, 4, 8, 16, 32 and possibly 64 as its third argument.
#
# This limitation is removed with C<veci> (vec improved, but much slower)
#
# The third argument still needs to be 32 or lower (or possibly 64 or lower).
#
# =cut
#
# sub vecibs ($) {
# my($s,$o,$b,$new)=@_;
# if($b=~/^(1|2|4|8|16|32|64)$/){
# return vec($s,$o,$b)=$new if @_==4;
# return vec($s,$o,$b);
# }
# my $bb=$b<4?4:$b<8?8:$b<16?16:$b<32?32:$b<64?64:die;
# my $ob=int($o*$b/$bb);
# my $v=vec($s,$ob,$bb)*2**$bb+vec($s,$ob+1,$bb);
# $v & (2**$b-1)
# }
=head1 SETS
=head2 distinct
Returns the values of the input list, sorted alfanumerically, but only
one of each value. This is the same as L</uniq> except uniq does not
sort the returned list.
Example:
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 >>.
Otherwise it returns I<0> (false).
print in( 5, 1,2,3,4,6); # 0
print in( 4, 1,2,3,4,6); # 1
print in( 'a', 'A','B','C','aa'); # 0
print in( 'a', 'A','B','C','a'); # 1
I guess in perl 5.10 or perl 6 you could use the C<< ~~ >> operator instead.
=head2 in_num
Just as sub L</in>, but for numbers. Internally uses the perl operator C<< == >> instead of C< eq >.
print in(5000, '5e3'); # 0
print in(5000, 5e3); # 1 since 5e3 is converted to 5000 before the call
print in_num(5000, 5e3); # 1
print in_num(5000, '+5.0e03'); # 1
=cut
sub in { no warnings 'uninitialized'; my $val=shift; $_ eq $val and return 1 for @_; return 0 }
sub in_num { no warnings 'uninitialized'; my $val=shift; $_ == $val and return 1 for @_; return 0 }
=head2 union
Input: Two arrayrefs. (Two lists, that is)
Output: An array containing all elements from both input lists, but no element more than once even if it occurs twice or more in the input.
Example, prints 1,2,3,4:
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.
Example:
perl -MAcme::Tools -le 'print join " ", minus( ["five", "FIVE", 1, 2, 3.0, 4], [4, 3, "FIVE"] )'
Output is C<< five 1 2 >>.
=cut
sub minus {
my %seen;
my %notme=map{($_=>1)}@{$_[1]};
grep !$notme{$_}&&!$seen{$_}++, @{$_[0]};
}
=head2 intersect
Input: Two arrayrefs
Output: An array containing all elements which exists in both input arrays.
Example:
perl -MAcme::Tools -le 'print join" ", intersect( ["five", 1, 2, 3.0, 4], [4, 2+1, "five"] )' # 4 3 five
Output: C<< 4 3 five >>
our $Ipnum;
sub ipnum_ok {
my $ipnum=shift;
$Ipnum=undef;
eval{
die "malformed ipnum $ipnum\n" if not $ipnum=~/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
die "invalid ipnum $ipnum\n" if grep$_>255,$1,$2,$3,$4;
$Ipnum=$1*256**3 + $2*256**2 + $3*256 + $4;
};
my$r=($Ipnum_errmsg=$@) ? 0 : 1;
$r
}
our $Iprange_errmsg;
our $Iprange_start;
sub iprange_ok {
my $iprange=shift;
$Iprange_start=undef;
my($r,$m);
eval{
die "malformed iprange $iprange\n" if not $iprange=~m|^(\d+)\.(\d+)\.(\d+)\.(\d+)(?:/(\d+))$|;
die "iprange part should be 0-255\n" if grep$_<0||$_>255,$1,$2,$3,$4;
die "iprange mask should be 0-32\n" if defined$5 and $5>32;
($r,$m)=($1*256**3+$2*256**2+$3*256+$4,32-$5);
};
return if $Iprange_errmsg=$@;
my $x=$r>>$m<<$m;
return if $r!=$x and $Iprange_errmsg=sprintf("need zero in last %d bits, should be %d.%d.%d.%d/%d",
$m, $x>>24, ($x>>16)&255, ($x>>8)&255, $x&255, 32-$m);
$Iprange_start=$r;
return 1;
}
sub in_iprange {
my($ipnum,$iprange)=@_;
croak $Ipnum_errmsg if !ipnum_ok($ipnum);
croak $Iprange_errmsg if !iprange_ok($iprange=~m|/\d+$| ? $iprange : "$iprange/32");
"$iprange/32"=~m|/(\d+)| or die;
$Ipnum>=$Iprange_start &&
$Ipnum<=$Iprange_start + 2**(32-$1)-1;
}
=head2 webparams
B<Input:> (optional)
Zero or one input argument: A string of the same type often found behind the first question mark (C<< ? >>) in URLs.
This string can have one or more parts separated by C<&> chars.
Each part consists of C<key=value> pairs (with the first C<=> char being the separation char).
Both C<key> and C<value> can be url-encoded.
If there is no input argument, C<webparams> uses C<< $ENV{QUERY_STRING} >> instead.
If also C<< $ENV{QUERY_STRING} >> is lacking, C<webparams()> checks if C<< $ENV{REQUEST_METHOD} eq 'POST' >>.
In that case C<< $ENV{CONTENT_LENGTH} >> is taken as the number of bytes to be read from C<STDIN>
and those bytes are used as the missing input argument.
The environment variables QUERY_STRING, REQUEST_METHOD and CONTENT_LENGTH is
typically set by a web server following the CGI standard (which Apache and
most of them can do I guess) or in mod_perl by Apache. Although you are
probably better off using L<CGI>. Or C<< $R->args() >> or C<< $R->content() >> in mod_perl.
B<Output:>
C<webparams()> returns a hash of the key/value pairs in the input argument. Url-decoded.
If an input string has more than one occurrence of the same key, that keys value in the returned hash will become concatenated each value separated by a C<,> char. (A comma char)
Examples:
use Acme::Tools;
my %R=webparams();
print "Content-Type: text/plain\n\n"; # or rather \cM\cJ\cM\cJ instead of \n\n to be http-compliant
print "My name is $R{name}";
Storing those four lines in a file in the directory designated for CGI-scripts
on your web server (or perhaps naming the file .cgi is enough), and C<chmod +x
/.../cgi-bin/script> and the URL
L<http://some.server.somewhere/cgi-bin/script?name=HAL> will print
C<My name is HAL> to the web page.
L<http://some.server.somewhere/cgi-bin/script?name=Bond&name=+James+Bond> will print C<My name is Bond, James Bond>.
=cut
sub webparams {
my $query=shift();
$query=$ENV{QUERY_STRING} if !defined $query;
if(!defined $query and $ENV{REQUEST_METHOD} eq "POST"){
read(STDIN,$query , $ENV{CONTENT_LENGTH});
$ENV{QUERY_STRING}=$query;
}
my %R;
for(split("&",$query)){
next if !length($_);
my($nkl,$verdi)=map urldec($_),split("=",$_,2);
$R{$nkl}=exists$R{$nkl}?"$R{$nkl},$verdi":$verdi;
}
return %R;
}
=head2 urlenc
Input: a string
Output: the same string URL encoded so it can be sent in URLs or POST requests.
In URLs (web addresses) certain characters are illegal. For instance I<space> and I<newline>.
And certain other chars have special meaning, such as C<+>, C<%>, C<=>, C<?>, C<&>.
These illegal and special chars needs to be encoded to be sent in
URLs. This is done by sending them as C<%> and two hex-digits. All
chars can be URL encodes this way, but it's necessary just on some.
Example:
$search="Østdal, Åge";
my $url="http://machine.somewhere.com/search?q=" . urlenc($search);
print $url;
( run in 0.535 second using v1.01-cache-2.11-cpan-e1769b4cff6 )