File Coverage

blib/lib/Acme/Tools.pm

Criterion	Covered	Total	%
statement	1233	1742	70.7
branch	636	1126	56.4
condition	306	602	50.8
subroutine	179	263	68.0
pod	142	186	76.3
total	2496	3919	63.6

#!/usr/bin/perl
package Acme::Tools;

our $VERSION = '0.172';   #new version: C-s ny versjon

use 5.008;     #Perl 5.8 was released July 18th 2002
use strict;
use warnings;
use Carp;

require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( all => [ qw() ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{all} } );
our @EXPORT = qw(
  min
  max
  mins
  maxs
  sum
  avg
  geomavg
  harmonicavg
  stddev
  median
  percentile
  $Resolve_iterations
  $Resolve_last_estimate
  resolve
  resolve_equation
  conv
  rank
  rankstr
  eqarr
  sorted
  sortedstr
  pushsort
  pushsortstr
  binsearch
  binsearchstr
  random
  random_gauss
  big
  bigi
  bigf
  bigr
  bigscale
  nvl
  repl
  replace
  decode
  decode_num
  between
  curb bound
  distinct
  in
  in_num
  uniq
  union
  union_all
  minus
  minus_all
  intersect
  intersect_all
  not_intersect
  mix
  zip
  subhash
  hashtrans
  zipb64
  zipbin
  unzipb64
  unzipbin
  gzip
  gunzip
  bzip2
  bunzip2
  ipaddr
  ipnum
  webparams
  urlenc
  urldec
  ht2t
  chall
  makedir
  qrlist
  ansicolor
  ccn_ok
  KID_ok
  writefile
  readfile
  readdirectory
  basename
  dirname
  wipe
  username
  range
  permutations
  trigram
  sliding
  chunks
  chars
  cart
  reduce
  int2roman
  roman2int
  num2code
  code2num
  gcd
  lcm
  pivot
  tablestring
  upper
  lower
  trim
  rpad
  lpad
  cpad
  dserialize
  serialize
  srlz
  bytes_readable
  distance
  tms
  easter
  time_fp
  sleep_fp
  sleeps
  sleepms
  sleepus
  sleepns
  eta
  sys
  recursed
  md5sum
  pwgen
  read_conf
  openstr
  ldist
  $Re_isnum
  isnum
  part
  parth
  parta
  ed
  $Edcursor
  brainfu
  brainfu2perl
  brainfu2perl_optimized
  bfinit
  bfsum
  bfaddbf
  bfadd
  bfcheck
  bfgrep
  bfgrepnot
  bfdelete
  bfstore
  bfretrieve
  bfclone
  bfdimensions
  $PI
  install_acme_command_tools

  $Dbh
  dlogin
  dlogout
  drow
  drows
  drowc
  drowsc
  dcols
  dpk
  dsel
  ddo
  dins
  dupd
  ddel
  dcommit
  drollback
);

our $PI = '3.141592653589793238462643383279502884197169399375105820974944592307816406286';

=head1 NAME

Acme::Tools - Lots of more or less useful subs lumped together and exported into your namespace

=head1 SYNOPSIS

 use Acme::Tools;

 print sum(1,2,3);                   # 6
 print avg(2,3,4,6);                 # 3.75

 my @list = minus(\@listA, \@listB); # set operations
 my @list = union(\@listA, \@listB); # set operations

 print length(gzip("abc" x 1000));   # far less than 3000

 writefile("/dir/filename",$string); # convenient
 my $s=readfile("/dir/filename");    # also conventient

 print "yes!" if between($pi,3,4);

 print percentile(0.05, @numbers);

 my @even = range(1000,2000,2);      # even numbers between 1000 and 2000
 my @odd  = range(1001,2001,2);

 my $dice = random(1,6);
 my $color = random(['red','green','blue','yellow','orange']);

 ...and more.

=encoding utf8

=head1 ABSTRACT

About 120 more or less useful perl subroutines lumped together and exported into your namespace.

=head1 DESCRIPTION

Subs created and collected since the mid-90s.

=head1 INSTALLATION

 sudo cpan Acme::Tools
 sudo cpanm Acme::Tools   # after: sudo apt-get install cpanminus make   # for Ubuntu 12.04

=head1 EXPORT

Almost every sub, about 90 of them.

Beware of namespace pollution. But what did you expect from an Acme module?

=head1 NUMBERS

=head2 num2code

See L

=head2 code2num

C convert numbers (integers) from the normal decimal system to some arbitrary other number system.
That can be binary (2), oct (8), hex (16) or others.

Example:

 print num2code(255,2,"0123456789ABCDEF");  # prints FF
 print num2code( 14,2,"0123456789ABCDEF");  # prints 0E

...because 255 are converted to hex FF (base C<< length("0123456789ABCDEF") >> ) which is 2 digits of 0-9 or A-F.
...and 14 are converted to 0E, with leading 0 because of the second argument 2.

Example:

 print num2code(1234,16,"01")

Prints the 16 binary digits 0000010011010010 which is 1234 converted to binary zeros and ones.

To convert back:

 print code2num("0000010011010010","01");  #prints 1234

C can be used to compress numeric IDs to something shorter:

 $chars="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-_";
 print num2code("241274432",5,$chars);     # prints EOOv0
 print code2num("EOOv0",$chars);           # prints 241274432

=cut

#Math::BaseCnv

sub num2code {
  my($num,$digits,$validchars,$start)=@_;
  my $l=length($validchars);
  my $key;
  no warnings;
  croak if $num<$start;
  $num-=$start;
  for(1..$digits){
    $key=substr($validchars,$num%$l,1).$key;
    $num=int($num/$l);
  }
  croak if $num>0;
  return $key;
}

sub code2num {
  my($code,$validchars,$start)=@_; $start=0 if !defined $start;
  my $l=length($validchars);
  my $num=0;
  $num=$num*$l+index($validchars,$_) for split//,$code;
  return $num+$start;
}


=head2 gcd

I< C<">The Euclidean algorithm (also called Euclid's algorithm) is an
algorithm to determine the greatest common divisor (gcd) of two
integers. It is one of the oldest algorithms known, since it appeared
in the classic Euclid's Elements around 300 BC. The algorithm does not
require factoring.C<"> >

B two or more positive numbers (integers, without decimals that is)

B an integer

B

  print gcd(12, 8);   # prints 4

Because the (prime number) factors of  12  is  2 * 2 * 3 and the factors of 8 is 2 * 2 * 2
and the common ('overlapping') factors for both 12 and 8 is then 2 * 2 and the result becomes 4.

B:

  print gcd(90, 135, 315);               # prints 45
  print gcd(2*3*3*5, 3*3*3*5, 3*3*5*7);  # prints 45 ( = 3*3*5 which is common to all three args)

Implementation:

 sub gcd { my($a,$b,@r)=@_; @r ? gcd($a,gcd($b,@r)) : $b==0 ? $a : gcd($b, $a % $b) }

L

L

=cut

sub gcd { my($a,$b,@r)=@_; @r ? gcd($a,gcd($b,@r)) : $b==0 ? $a : gcd($b, $a % $b) }

=head2 lcm

C finds the Least Common Multiple of two or more numbers (integers).

B two or more positive numbers (integers)

B an integer number

Example: C< 2/21 + 1/6 = 4/42 + 7/42 = 11/42>

Where 42 = lcm(21,6).

B

  print lcm(45,120,75);   # prints 1800

Because the factors are:

  45 = 2^0 * 3^2 * 5^1
 120 = 2^3 * 3^1 * 5^1
  75 = 2^0 * 3^1 * 5^2

Take the bigest power of each primary number (2, 3 and 5 here).
Which is 2^3, 3^2 and 5^2. Multiplied this is 8 * 9 * 25 = 1800.

 sub lcm { my($a,$b,@r)=@_; @r ? lcm($a,lcm($b,@r)) : $a*$b/gcd($a,$b) }

Seems to works with L as well: (C of all integers from 1 to 200)

 perl -MAcme::Tools -MMath::BigInt -le'print lcm(map Math::BigInt->new($_),1..200)'

 337293588832926264639465766794841407432394382785157234228847021917234018060677390066992000

=cut

sub lcm { my($a,$b,@r)=@_; @r ? lcm($a,lcm($b,@r)) : $a*$b/gcd($a,$b) }

=head2 resolve

Resolves an equation by Newtons method.

B 1-6 arguments. At least one argument.

First argument: must be a coderef to a subroutine (a function)

Second argument: if present, the target, f(x)=target. Default 0.

Third argument: a start position for x. Default 0.

Fourth argument: a small delta value. Default 1e-4 (0.0001).

Fifth argument: a maximum number of iterations before resolve gives up
and carps. Default 100 (if fifth argument is not given or is
undef). The number 0 means infinite here.  If the derivative of the
start position is zero or close to zero more iterations are typically
needed.

Sixth argument: A number of seconds to run before giving up.  If both
fifth and sixth argument is given and > 0, C stops at
whichever comes first.

B returns the number C for C = 0

...or equal to the second input argument if present.

B

The equation C<< x^2 - 4x - 21 = 0 >> has two solutions: -3 and 7.

The result of C will depend on the start position:

 print resolve { $_**2 - 4*$_ - 21 };                         # -3 with $_ as your x
 print resolve(sub{ my $x=shift; $x**2 - 4*$x - 21 });        # -3 more elaborate call
 print resolve(sub{ my $x=shift; $x**2 - 4*$x - 21 },0,3);    # 7  with start position 3
 print "Iterations: $Acme::Tools::Resolve_iterations\n";      # 3 or larger, about 10-15 is normal

The variable C< $Acme::Tools::Resolve_iterations > (which is exported) will be set
to the last number of iterations C used. Also if C dies (carps).

The variable C< $Acme::Tools::Resolve_last_estimate > (which is exported) will be
set to the last estimate. This number will often be close to the solution and can
be used even if C dies (carps).

B

If either second, third or fourth argument is an instance of L, so will the result be:

 use Acme::Tools;
 my $equation = sub{ $_ - 1 - 1/$_ };
 my $gr1 = resolve( $equation, 0,      1  ); #
 my $gr2 = resolve( $equation, 0, bigf(1) ); # 1/2 + sqrt(5)/2
 bigscale(50);
 my $gr3 = resolve( $equation, 0, bigf(1) ); # 1/2 + sqrt(5)/2

 print 1/2 + sqrt(5)/2, "\n";
 print "Golden ratio 1: $gr1\n";
 print "Golden ratio 2: $gr2\n";
 print "Golden ratio 3: $gr3\n";

Output:

 1.61803398874989
 Golden ratio 1: 1.61803398874989
 Golden ratio 2: 1.61803398874989484820458683436563811772029300310882395927211731893236137472439025
 Golden ratio 3: 1.6180339887498948482045868343656381177203091798057610016490334024184302360920167724737807104860909804

See:

L

L

L

TODO: fix fail for div by 0, e.g.:

 perl -MAcme::Tools -le'for(map$_/10,-4..20){printf"%9.4f  %s\n",$_,3*$_+$_**4-12}print resolve(sub{$x=shift;3*$x+$x**4-12},0,1)'
 resolve(sub{ my $x=shift; $x**2 - 4*$x - 21 },undef,1.9)
 resolve_equation "x + 13*(3-x) = 17 - 1/x"

=cut

our $Resolve_iterations;
our $Resolve_last_estimate;

#sub resolve(\[&$]@) {
sub resolve(&@) {
  my($f,$g,$start,$delta,$iters,$sec)=@_;
  $g=0         if !defined $g;
  $start=0     if !defined $start;
  $delta=1e-4  if !defined $delta;
  $iters=100   if !defined $iters;
  $sec=0       if !defined $sec;
  $iters=13e13 if $iters==0;
  croak "Iterations ($iters) or seconds ($sec) can not be a negative number" if $iters<0 or $sec<0;
  $Resolve_iterations=undef;
  $Resolve_last_estimate=undef;
  croak "Should have at least 1 argument, a coderef" if !@_;
  croak "First argument should be a coderef" if ref($f) ne 'CODE';

  my @x=($start);
  my $time_start=$sec>0?time_fp():undef;
  my $timeout=0;
  my $ds=ref($start) eq 'Math::BigFloat' ? Math::BigFloat->div_scale() : undef;
  my $fx=sub{
    local$_=$_[0];
    my $fx=&$f($_);
    if($fx=~/x/ and $fx=~/^[ \(\)\.\d\+\-\*\/x\=]+$/){
      $fx=~s/^(.*)=(.*)$/($1)-($2)/;
      $fx=~s,x,\$_,g;
      $f=eval"sub{$fx}";
      $fx=&$f($_);
    }
    $fx
  };
  for my $n (0..$iters-1){
    my $fd= &$fx($x[$n]+$delta*0.5) - &$fx($x[$n]-$delta*0.5);
    $fd   = &$fx($x[$n]+$delta*0.6) - &$fx($x[$n]-$delta*0.4) if $fd==0; #wiggle...
    $fd   = &$fx($x[$n]+$delta*0.3) - &$fx($x[$n]-$delta*0.7) if $fd==0;
    #warn "n=$n  fd=$fd\n";
    croak "Div by zero: df(x) = $x[$n] at n'th iteration, n=$n" if $fd==0;
    $Resolve_last_estimate=
    $x[$n+1]=$x[$n]-(&$fx($x[$n])-$g)/($fd/$delta);
    $Resolve_iterations=$n;
    last if $n>3 and $x[$n+1]==$x[$n] and $x[$n]==$x[$n-1];
    last if $n>3 and ref($x[$n+1]) eq 'Math::BigFloat' and substr($x[$n+1],0,$ds) eq substr($x[$n],0,$ds); #hm
    croak "Could not resolve, perhaps too little time given ($sec), iteratons=$n"
      if $sec>0 and time_fp()-$time_start>$sec and $timeout=1;
    #warn "$n: ".$x[$n+1]."\n";
  }
  croak "Could not resolve, perhaps too few iterations ($iters)" if @x>=$iters;
  return $x[-1];
}

=head2 resolve_equation

This prints 2:

 print resolve_equation "x + 13*(3-x) = 17 - x"

A string containing at least one x is converted into a perl function.
Then x is found by using L. The string conversion is done by
replacing every x with $_ and if a C< = > char is present it converts
C< leftside = rightside > into C< (leftside) - (rightside) = 0 > which
is the default behaviour of L.

=cut

#sub resolve_equation { my $e=shift;$e=~s/x/\$_/g;$e=~s/(.*)=(.*)/($1)-($2)/;resolve sub{eval$e},@_ }
sub resolve_equation { my $e=shift;resolve sub{$e},@_ }

=head2 conv

Converts between:

=over 4

=item * units of measurement

=item * number systems

=item * currencies

=back

B

 print conv( 2000, "meters", "miles" );  #prints 1.24274238447467
 print conv( 2.1, 'km', 'm');            #prints 2100
 print conv( 70,"cm","in");              #prints 27.5590551181102
 print conv( 4,"USD","EUR");             #prints 3.20481552905431 (depending on todays rates)
 print conv( 4000,"b","kb");             #prints 3.90625 (1 kb = 1024 bytes)
 print conv( 4000,"b","Kb");             #prints 4       (1 Kb = 1000 bytes)
 print conv( 1000,"mb","kb");            #prints 1024000
 print conv( 101010,"bin","roman");      #prints XLII
 print conv( "DCCXLII","roman","oct");   #prints 1346

B are:>

Note: units starting with the symbol _ means that all metric
prefixes from yocto 10^-24 to yotta 10^+24 is supported, so _m means
km, mm, cm, µm and so on. And _N means kN, MN GN and so on.

Note2: Many units have synonyms: m, meter, meters ...

 acceleration: g, g0, m/s2, mps2

 angle:        binary_degree, binary_radian, brad, deg, degree, degrees,
               gon, grad, grade, gradian, gradians, hexacontade, hour,
               new_degree, nygrad, point, quadrant, rad, radian, radians,
               sextant, turn

 area:         a, ar, are, ares, bunder, ca, centiare, cho, cm2,
               daa, decare, decares, deciare, dekar,
               djerib, m2, dunam, dönüm, earths, feddan, ft2, gongqing, ha
               ha, hectare, hectares, hektar, jerib, km2, m2, manzana,
               mi2, mm2, mu, qing, rai, sotka,
               sqcm, sqft, sqkm, sqm, sqmi, sqmm
               stremmata, um2, µm2

 bytes:        Eb, Gb, Kb, KiB, Mb, Pb, Tb, Yb, Zb, b, byte,
               kb, kilobyte,  mb, megabyte,
               gb, gigabyte,  tb, terabyte,
               pb, petabyte,  eb, exabyte,
               zb, zettabyte, yb, yottabyte

 charge:       As, C, _e, coulomb, e

 current:      A, _A, N/m2

 energy:       BTU, Btu, J, Nm, W/s, Wh, Wps, Ws, _J, _eV,
               cal, calorie, calories, eV, electronvolt,
               erg, ergs, foot-pound, foot-pounds, ftlb, joule, kWh,
               kcal, kilocalorie, kilocalories,
               newtonmeter, newtonmeters, th, thermie

 force:        N, _N, dyn, dyne, dynes, lb, newton

 length:       NM, _m, _pc, astronomical unit, au, chain, ft, furlong,
               in, inch, inches, km, league, lightyear, ls, ly,
               m, meter, meters, mi, mil, mile, miles,
               nautical mile, nautical miles, nmi,
               parsec, pc, planck, yard, yard_imperical, yd, Å, ångstrøm

 mass:         Da, _eV, _g, bag, carat, ct, dwt, eV, electronvolt, g,
               grain, grains, gram, grams, kilo, kilos, kt, lb, lb_av,
               lb_t, lb_troy, lbs, ounce, ounce_av, ounce_troy, oz, oz_av, oz_t,
               pennyweight, pound, pound_av, pound_metric, pound_troy, pounds,
               pwt, seer, sl, slug, solar_mass, st, stone, t, tonn, tonne, tonnes, u, wey

 mileage:      mpg, l/100km, l/km, l/10km, lp10km, l/mil, liter_pr_100km, liter_pr_km, lp100km

 money:        AED, ARS, AUD, BGN, BHD, BND, BRL, BWP, CAD, CHF, CLP, CNY,
               COP, CZK, DKK, EUR, GBP, HKD, HRK, HUF, IDR, ILS, INR, IRR,
               ISK, JPY, KRW, KWD, KZT, LKR, LTL, LVL, LYD, MUR, MXN, MYR,
               NOK, NPR, NZD, OMR, PHP, PKR, PLN, QAR, RON, RUB, SAR, SEK,
               SGD, THB, TRY, TTD, TWD, USD, VEF, ZAR,      BTC, LTC, mBTC, XBT
               Currency rates are automatically updated from the net
               at least every 24h since last update (on linux/cygwin).

 numbers:      dec, hex, bin, oct, roman, dozen, doz, dz, dusin, gross, gro,
               gr, great_gross, small_gross  (not supported: decimal numbers)

 power:        BTU, BTU/h, BTU/s, BTUph, GWhpy, J/s, Jps, MWhpy, TWhpy,
               W, Whpy, _W, ftlb/min, ftlb/s, hk, hp, kWh/yr, kWhpy

 pressure:     N/m2, Pa, _Pa, at, atm, bar, mbar, pascal, psi, torr

 radioactivity: Bq, becquerel, curie

 speed:        _m/s, km/h, km/t, kmh, kmph, kmt, m/s, mi/h, mph, mps,
               kn, knot, knots, kt, mach, machs, c, fps, ft/s, ftps

 temperature:  C, F, K, celsius, fahrenheit, kelvin

 time:         _s, biennium, century, d, day, days, decade, dy, fortnight,
               h, hour, hours, hr, indiction, jubilee, ke, lustrum, m,
               millennium, min, minute, minutes, mo, moment, mon, month,
               olympiad, quarter, s, season, sec, second, seconds, shake,
               tp, triennium, w, week, weeks, y, y365, ySI, ycommon,
               year, years, ygregorian, yjulian, ysideral, ytropical

 volume:        l, L, _L, _l, cm3, m3, ft3, in3, liter, liters, litre, litres,
                gal, gallon, gallon_imp, gallon_uk, gallon_us, gallons,
                pint, pint_imp, pint_uk, pint_us, tsp, tablespoon, teaspoon,
                floz, floz_uk, therm, thm, fat, bbl, Mbbl, MMbbl, drum

See: L

=cut

#TODO:  @arr2=conv(\@arr1,"from","to")         # is 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,
		  _m      => 1,
		  meter   => 1,
		  meters  => 1,
		  km      => 1000,
		  mil     => 10000,                   #scandinavian #also: inch/1000!
		  in      => 0.0254,
		  inch    => 0.0254,
		  inches  => 0.0254,
		  ft      => 0.0254*12,               #0.3048 m
		  feet    => 0.0254*12,               #0.3048 m
		  yd      => 0.0254*12*3,             #0.9144 m
		  yard    => 0.0254*12*3,             #0.9144 m
		  yards   => 0.0254*12*3,             #0.9144 m
		  fathom  => 0.0254*12*3*2,           #1.8288 m
		  fathoms => 0.0254*12*3*2,           #1.8288 m
		  chain   => 0.0254*12*3*22,          #20.1168 m
		  chains  => 0.0254*12*3*22,          #20.1168 m
		  furlong => 0.0254*12*3*22*10,       #201.168 m
		  furlongs=> 0.0254*12*3*22*10,       #201.168 m
		  mi      => 0.0254*12*3*22*10*8,     #1609.344 m
		  mile    => 0.0254*12*3*22*10*8,     #1609.344 m
		  miles   => 0.0254*12*3*22*10*8,
		  league  => 0.0254*12*3*22*10*8*3,   #4828.032 m
		  leagues => 0.0254*12*3*22*10*8*3,   #4828.032 m
		  yard_imperical     => 0.914398416,
                  NM                 => 1852,           #nautical mile
                  nmi                => 1852,           #nautical mile
                  'nautical mile'    => 1852,
                  'nautical miles'   => 1852,
                  'Å'                => 1e-10,
                  'ångstrøm'         => 1e-10,
		  ly                 => 299792458*3600*24*365.25,
		  lightyear          => 299792458*3600*24*365.25, # = 9460730472580800 by def
		  ls                 => 299792458,      #light-second
                  pc                 => 3.0857e16,      #3.26156 ly
                 _pc                 => 3.0857e16,      #3.26156 ly
                  parsec             => 3.0857e16,
                  au                 => 149597870700, # by def, earth-sun
                 'astronomical unit' => 149597870700,
		  planck             => 1.61619997e-35, #planck length
		  #Norwegian (old) lengths:
		  tomme   => 0.0254,
		  tommer  => 0.0254,
		  fot     => 0.0254*12,               #0.3048m
		  alen    => 0.0254*12*2,             #0.6096m
		  favn    => 0.0254*12*2*3,           #1.8288m
		  kvart   => 0.0254*12*2/4,           #0.1524m a quarter alen
		 },
	 mass  =>{ #https://en.wikipedia.org/wiki/Unit_conversion#Mass
		  g            => 1,
		  _g           => 1,
		  gram         => 1,
		  grams        => 1,
		  kilo         => 1000,
		  kilos        => 1000,
		  t            => 1000000,
		  tonn         => 1000000,
		  tonne        => 1000000,
		  tonnes       => 1000000,
		  seer         => 933.1,
		  lb           => 453.59237,
		  lbs          => 453.59237,
		  lb_av        => 453.59237,
		  lb_t         => 373.2417216,   #5760 grains
		  lb_troy      => 373.2417216,
		  pound        => 453.59237,
		  pounds       => 453.59237,
                  pound_av     => 453.59237,
                  pound_troy   => 373.2417216,
                  pound_metric => 500,
		  ounce        => 28,            # US food, 28g
		  ounce_av     => 453.59237/16,  # avoirdupois  lb/16 = 28.349523125g
		  ounce_troy   => 31.1034768,    # lb_troy / 12
		  oz           => 28,            # US food, 28g
		  oz_av        => 453.59237/16,  # avoirdupois  lb/16 = 28.349523125g
		  oz_t         => 31.1034768,    # lb_troy / 12,
		  grain        => 64.79891/1000, # 453.59237/7000
		  grains       => 64.79891/1000,
                  pennyweight  => 31.1034768 / 20,
                  pwt          => 31.1034768 / 20,
                  dwt          => 31.1034768 / 20,
                  st           => 6350.29318,               # 14 lb_av
                  stone        => 6350.29318,
		  wey          => 114305.27724,             # 252 lb  =  18 stone
                  carat        => 0.2,
                  ct           => 0.2,                      #carat (metric)
                  kt           => 64.79891/1000 * (3+1/6),  #carat/karat
                  u            => 1.66053892173e-30, #atomic mass carbon-12
                  Da           => 1.66053892173e-30, #atomic mass carbon-12
    		  slug         => 14600,
    		  sl           => 14600,
                  eV           => 1.783e-33,    #e=mc2
                  _eV          => 1.783e-33,
		  electronvolt => 1.783e-33,
                 'solar mass'  => 1.99e33,
                  solar_mass   => 1.99e33,
                  bag          => 60*1000, #60kg coffee
		 },
	 area  =>{               # https://en.wikipedia.org/wiki/Unit_conversion#Area
                  m2      => 1,
                  dm2     => 0.1**2,
                  cm2     => 0.01**2,
                  mm2     => 0.001**2,
		 'µm2'    => 1e-6**2,
		  um2     => 1e-6**2,
                  sqm     => 1,
                  sqcm    => 0.01**2,
                  sqmm    => 0.001**2,
                  km2     => 1000**2,
                  sqkm    => 1000**2,
                  a       => 100,
                  ar      => 100,
                  are     => 100,
                  ares    => 100,
                  dekar   => 1000,
                  decare  => 1000,
                  decares => 1000,
                  daa     => 1000,
                 'mål'    => 1000,
                  ha      => 10000,
                  hektar  => 10000,
                  hectare => 10000,
                  hectares=> 10000,
                  ft2     => (0.0254*12)**2,
                  sqft    => (0.0254*12)**2,
		  mi2     => 1609.344**2,
		  sqmi    => 1609.344**2,
                  yd2     => (0.0254*12*3)**2, #square yard
                  sqyd    => (0.0254*12*3)**2,
                  yard2   => (0.0254*12*3)**2,
                  sqyard  => (0.0254*12*3)**2,
                  rood      => 1210*(0.0254*12)**2,  # 1/4 acres
                  roods     => 1210*(0.0254*12)**2,  # 1/4 acres
		  ac        => 4840*(0.0254*12)**2,  # 4840 square yards
		  acre      => 4840*(0.0254*12)**2,
		  acres     => 4840*(0.0254*12)**2,
                  homestead => 4840*(0.0254*12)**2 *160,      #160 acres US Surveyors or 1/4 sqmiles
                  township  => 4840*(0.0254*12)**2 *160*144,  #144 homesteads or 36 sqmiles
                  perches   => 4840*(0.0254*12)**2 /160,      #160 perches = 1 acre in sri lanka
		  sotka     => 100,       #russian are
                  jerib     => 10000,     #iran hectare
                  djerib    => 10000,     #turkish hectare
		  gongqing  => 10000,     #chinese hectare
                  manzana   => 10000,     #argentinian hectare
                  bunder    => 10000,     #dutch hectare
                  centiare  => 1,
                  deciare   => 10,
                  ca        => 1,
                  mu        => 10000/15,    #China
                  qing      => 10000/0.15,  #China
                  dunam     => 10000/10,    #Middle East
                 'dönüm'    => 10000/10,    #Middle East
                  stremmata =>10000/10,    #Greece
                  rai       => 10000/6.25,  #Thailand
                  cho       => 10000/1.008, #Japan
                  feddan    => 10000/2.381, #Egypt
                  earths    => 510072000*1000**2, #510072000 km2, surface area of earth
		  barn      => 1e-28,       #physics
                  outhouse  => 1e-34,       #physics
                  shed      => 1e-52,       #physics
        	 },
	 volume=>{
		  l         => 1,
		  L         => 1,
		  _L        => 1,
		  _l        => 1,
		  liter     => 1,
		  liters    => 1,
		  litre     => 1,
		  litres    => 1,
		  gal       => 231*2.54**3/1000, #3.785411784, #231 cubic inches
		  gallon    => 231*2.54**3/1000,
		  gallons   => 231*2.54**3/1000,
		  gallon_us => 231*2.54**3/1000,
		  gallon_uk => 4.54609,
		  gallon_imp=> 4.54609,
		  gallon_us_dry => 4.40488377086, # ~ 9.25**2*pi*2.54**3/1000 L
		  m3        => 10**3,      #1000 L
		  cm3       => 0.1**3,     #0.001 L
                  in3       => 0.254**3,   #0.016387064 L
                  ft3       => (0.254*12)**3,
		  tablespoon=> 3.785411784/256,       #14.78676478125 mL
		  tsp       => 3.785411784/256/3,     #4.92892159375 mL
		  teaspoon  => 3.785411784/256/3,     #4.92892159375 mL
                  floz      => 3.785411784/128,       #fluid ounce US
                  floz_uk   => 4.54609/160,           #fluid ounce UK
                  pint      => 4.54609/8,             #0.56826125 L
                  pint_uk   => 4.54609/8,
                  pint_imp  => 4.54609/8,
                  pint_us   => 3.785411784/8,         #0.473176473
		  therm     => 2.74e3,                #? 100000BTUs?   (!= thermie)
		  thm       => 2.74e3,                #?               (!= th)
                  fat       => 42*231*2.54**3/1000,
                  bbl       => 42*231*2.54**3/1000,   #oil barrel ~159 liters https://en.wikipedia.org/wiki/Barrel_(unit)
		  Mbbl      => 42*231*2.54**3,        #mille (thousand) oil barrels
		  MMbbl     => 42*231*2.54**3*1000,   #mille mille (million) oil barrels
		  drum      => 200,
		  #Norwegian:
                  meterfavn => 2 * 2 * 0.6,           #ved 2.4 m3
                  storfavn  => 2 * 2 * 3,             #ved 12 m3
		 },
	 time  =>{
		  s           => 1,
		  _s          => 1,
		  sec         => 1,
		  second      => 1,
		  seconds     => 1,
		  m           => 60,
		  min         => 60,
		  minute      => 60,
		  minutes     => 60,
		  h           => 60*60,
		  hr          => 60*60,
		  hour        => 60*60,
		  hours       => 60*60,
		  d           => 60*60*24,
		  dy          => 60*60*24,
		  day         => 60*60*24,
		  days        => 60*60*24,
		  w           => 60*60*24*7,
		  week        => 60*60*24*7,
		  weeks       => 60*60*24*7,
		  mo	      => 60*60*24 * 365.2425/12,
		  mon	      => 60*60*24 * 365.2425/12,
		  month	      => 60*60*24 * 365.2425/12,
		  quarter     => 60*60*24 * 365.2425/12 * 3, #3 months
		  season      => 60*60*24 * 365.2425/12 * 3, #3 months
		  y           => 60*60*24 * 365.2425, # 365+97/400    #97 leap yers in 400 years
		  year        => 60*60*24 * 365.2425,
		  years       => 60*60*24 * 365.2425,
		  yjulian     => 60*60*24 * 365.25,   # 365+1/4
		  y365        => 60*60*24 * 365,      # finance/science
		  ycommon     => 60*60*24 * 365,      # finance/science
		  ygregorian  => 60*60*24 * 365.2425, # 365+97/400
		 #ygaussian   => 365+(6*3600+9*60+56)/(24*3600),  # 365+97/400
                  ytropical   => 60*60*24 * 365.24219,
                  ysideral    => 365.256363004,
		  ySI         => 60*60*24*365.25, #31556925.9747
                  decade      =>   10 * 60*60*24*365.2425,
                  biennium    =>    2 * 60*60*24*365.2425,
                  triennium   =>    3 * 60*60*24*365.2425,
                  olympiad    =>    4 * 60*60*24*365.2425,
                  lustrum     =>    5 * 60*60*24*365.2425,
                  indiction   =>   15 * 60*60*24*365.2425,
		  jubilee     =>   50 * 60*60*24*365.2425,
		  century     =>  100 * 60*60*24*365.2425,
		  millennium  => 1000 * 60*60*24*365.2425,
                  shake       => 1e-8,
                  moment      => 3600/40,  #1/40th of an hour, used by Medieval Western European computists
		  ke          => 864,      #1/100th of a day, trad Chinese, 14m24s
		  fortnight   => 14*24*3600,
                  tp          => 5.3910632e-44,  #planck time, time for ligth to travel 1 planck length
		 },
          speed=>{
                 'm/s'      => 1,
                '_m/s'      => 1,
                  mps       => 1,
                  mph       => 1609.344/3600,
                 'mi/h'     => 1609.344/3600,
                  kmh       => 1/3.6,
                  kmph      => 1/3.6,
                 'km/h'     => 1/3.6,
                  kmt       => 1/3.6, # t=time or temps (scandinavian and french and dutch)
                 'km/t'     => 1/3.6,
 		  kn        => 1852/3600,
 		  kt        => 1852/3600,
 		  knot      => 1852/3600,
 		  knop      => 1852/3600,    #scandinavian
 		  knots     => 1852/3600,
		  c         => 299792458,    #speed of light
		  mach      => 340.3,        #speed of sound
		  machs     => 340.3,
                  fps       => 0.3048, #0.0254*12
                  ftps      => 0.3048,
                 'ft/s'     => 0.3048,
                 },
	  acceleration=>{
                 'm/s2'     => 1,
                 'mps2'     => 1,
                  g         => 9.80665,
                  g0        => 9.80665,
                  #0-100kmh or ca 0-60 mph x seconds...
                 },
         temperature=>{  #http://en.wikipedia.org/wiki/Temperature#Conversion
                  C=>1, F=>1, K=>1, celsius=>1, fahrenheit=>1, kelvin=>1
                 },
         radioactivity=>{
                  Bq          => 1,
		  becquerel   => 1,
		  curie       => 3.7e10,
                 },
         current=> {
                  A     => 1,
                  _A    => 1,
                 'N/m2' => 2e-7,
	         },
         charge=>{
                  e       => 1,
                  _e      => 1,
                  C       => 6.24150964712042e+18,
                  coulomb => 6.24150964712042e+18,
                  As      => 6.24150964712042e+18,
                 #Faraday unit of charge ???
                 },
         power=> {
                  W        => 1,
 		  _W       => 1,
                 'J/s'     => 1,
                  Jps      => 1,
                  hp       => 746,
                  hk       => 746,  #hestekrefter (norwegian, scandinavian)
		 'kWh/yr'  => 1000    * 3600/(24*365), #kWh annually
                  Whpy     =>           3600/(24*365), #kWh annually
                  kWhpy    => 1000    * 3600/(24*365), #kWh annually
                  MWhpy    => 1000**2 * 3600/(24*365), #kWh annually
                  GWhpy    => 1000**3 * 3600/(24*365), #kWh annually
                  TWhpy    => 1000**4 * 3600/(24*365), #kWh annually
		  BTU      => 1055.05585262/3600,                    #
		  BTUph    => 1055.05585262/3600,
		 'BTU/h'   => 1055.05585262/3600,
		 'BTU/s'   => 1055.05585262,
		 'ftlb/s'  => 746/550,
		 'ftlb/min'=> 746/550/60,
                 },
         energy=>{
                   joule        => 1,
                   J            => 1,
                   _J           => 1,
                   Ws           => 1,
                   Wps          => 1,
                  'W/s'         => 1,
                   Nm           => 1,
                   newtonmeter  => 1,
                   newtonmeters => 1,
                   Wh           => 3600,
                   kWh          => 3600000, #3.6 million J
                   cal          => 4.1868,          # ~ 3600/860
		   calorie      => 4.1868,
		   calories     => 4.1868,
                   kcal         => 4.1868*1000,
		   kilocalorie  => 4.1868*1000,
		   kilocalories => 4.1868*1000,
		   BTU          => 4.1868 * 252, # = 1055.0736 or is 1055.05585262 right?
		   Btu          => 4.1868 * 252,
		   ftlb         => 746/550,      # ~ 1/0.7375621
		  'foot-pound'  => 746/550,
		  'foot-pounds' => 746/550,
		   erg          => 1e-7,
		   ergs         => 1e-7,
                   eV           => 1.60217656535e-19,
                   _eV          => 1.60217656535e-19,
  		   electronvolt => 1.60217656535e-19,
                   thermie      => 4.1868e6,
                   th           => 4.1868e6,
                 },
         force=> {
	          newton=> 1,
	          N     => 1,
	          _N    => 1,
                  dyn   => 1e-5,
                  dyne  => 1e-5,
                  dynes => 1e-5,
		  lb    => 4.448222,
                 },
         pressure=>{
                  Pa      => 1,
                  _Pa     => 1,
                  pascal  => 1,
                 'N/m2'   => 1,
                  bar     => 100000.0,
                  mbar    => 100.0,
                  at      =>  98066.5,   #technical atmosphere
		  atm     => 101325.0,     #standard atmosphere
		  torr    => 133.3224,
                  psi     => 6894.8,     #pounds per square inch
                 },
         bytes=> {
                  b     => 1,
                  kb    => 1024,         #2**10
                  mb    => 1024**2,      #2**20 = 1048576
		  gb    => 1024**3,      #2**30 = 1073741824
		  tb    => 1024**4,      #2**40 = 1099511627776
		  pb    => 1024**5,      #2**50 = 1.12589990684262e+15
		  eb    => 1024**6,      #2**60 =
		  zb    => 1024**7,      #2**70 =
		  yb    => 1024**8,      #2**80 =
                  KiB   => 1024,         #2**10
                  KiB   => 1024**2,      #2**20 = 1048576
		  KiB   => 1024**3,      #2**30 = 1073741824
		  KiB   => 1024**4,      #2**40 = 1099511627776
		  KiB   => 1024**5,      #2**50 = 1.12589990684262e+15
		  KiB   => 1024**6,      #2**60 =
		  KiB   => 1024**7,      #2**70 =
		  KiB   => 1024**8,      #2**80 =
                  Kb    => 1000,         #2**10
                  Mb    => 1000**2,      #2**20 = 1048576
		  Gb    => 1000**3,      #2**30 = 1073741824
		  Tb    => 1000**4,      #2**40 = 1099511627776
		  Pb    => 1000**5,      #2**50 = 1.12589990684262e+15
		  Eb    => 1000**6,      #2**60 =
		  Zb    => 1000**7,      #2**70 =
		  Yb    => 1000**8,      #2**80 =
                  byte      => 1,
                  kilobyte  => 1024,         #2**10
                  megabyte  => 1024**2,      #2**20 = 1048576
		  gigabyte  => 1024**3,      #2**30 = 1073741824
		  terabyte  => 1024**4,      #2**40 = 1099511627776
		  petabyte  => 1024**5,      #2**50 = 1.12589990684262e+15
		  exabyte   => 1024**6,      #2**60 =
		  zettabyte => 1024**7,      #2**70 =
		  yottabyte => 1024**8,      #2**80 =
                 },
         milage=>{                                #fuel consumption
                 'l/mil'          => 1,
                 'l/10km'         => 1,
                 'lp10km'         => 1,
                 'l/km'           => 10,
                 'l/100km'        => 1/10,
                  lp100km         => 1/10,
                  liter_pr_100km  => 1/10,
                  liter_pr_km     => 10,
                  mpg             => -23.5214584,      #negative signals inverse
         },
#         light=> {
#                   cd => 1,
#                   candela => 1,
#                 },
#         lumens
#         lux
         angle =>{
		  turn          => 1,
                  rad           => 1/(2*$PI), # 2 * pi
                  radian        => 1/(2*$PI), # 2 * pi
                  radians       => 1/(2*$PI), # 2 * pi
                  deg           => 1/360,                                # 4 * 90
                  degree        => 1/360,                                # 4 * 90
                  degrees       => 1/360,                                # 4 * 90
                  grad          => 1/400,
                  gradian       => 1/400,
                  gradians      => 1/400,
                  grade         => 1/400, #french revolutionary unit
                  gon           => 1/400,
                  new_degree    => 1/400,
                  nygrad        => 1/400, #scandinavian
		  quadrant      => 1/4,
 		  sextant       => 1/6,
		  hour          => 1/24,
		  point         => 1/32,  #used in navigation
		  hexacontade   => 1/60,
		  binary_degree => 1/256,
		  binary_radian => 1/256,
		  brad          => 1/256,
                 },
	 money =>{                        # rates at dec 17 2015
                  AED => 2.389117,        #
                  ARS => 0.895122,        #
                  AUD => 6.253619,        #
                  BGN => 4.847575,        #
                  BHD => 23.267384,       #
                  BND => 6.184624,        #
                  BRL => 2.260703,        #
                  BTC => 3910.932213547,  #bitcoin
                  BWP => 0.794654,        #
                  CAD => 6.289957,        #
                  CHF => 8.799974,        #
                  CLP => 0.012410,        #
                  CNY => 1.353406,        #
                  COP => 0.00262229,      #
                  CZK => 0.351171,        #
                  DKK => 1.271914,        #
                  EUR => 9.489926,        #
                  GBP => 13.069440,       #
                  HKD => 1.131783,        #
                  HRK => 1.240878,        #
                  HUF => 0.029947,        #
                  IDR => 0.00062471,      #
                  ILS => 2.254456,        #
                  INR => 0.132063,        #
                  IRR => 0.00029370,      #
                  ISK => 0.067245,        #
                  JPY => 0.071492,        #
                  KRW => 0.00739237,      #
                  KWD => 28.862497,       #
                  KZT => 0.027766,        #
                  LKR => 0.061173,        #
                  LTC => 31.78895354018,  #litecoin
                  LTL => 2.748472,        #
                  LVL => 13.503025,       #
                  LYD => 6.296978,        #
                  MUR => 0.240080,        #
                  MXN => 0.515159,        #
                  MYR => 2.032465,        #
                  NOK => 1.000000000,     #norwegian kroner
                  NPR => 0.084980,        #
                  NZD => 5.878331,        #
                  OMR => 22.795994,       #
                  PHP => 0.184839,        #
                  PKR => 0.083779,        #
                  PLN => 2.207243,        #
                  QAR => 2.409162,        #
                  RON => 2.101513,        #
                  RUB => 0.122991,        #
                  SAR => 2.339745,        #
                  SEK => 1.023591,        #
                  SGD => 6.184624,        #
                  THB => 0.242767,        #
                  TRY => 2.994338,        #
                  TTD => 1.374484,        #
                  TWD => 0.265806,        #
                  USD => 8.774159,        #
                  VEF => 1.395461,        #
                  ZAR => 0.576487,        #
                  XBT => 3910.932213547, # bitcoin
                 mBTC => 3910.932213547, # bitcoin
                 mXBT => 3910.932213547, # bitcoin
		 },
          numbers =>{
	    dec=>1,hex=>1,bin=>1,oct=>1,roman=>1,      des=>1,#des: spelling error in v0.15-0.16
            dusin=>1,dozen=>1,doz=>1,dz=>1,gross=>144,gr=>144,gro=>144,great_gross=>12*144,small_gross=>10*12,
          }
	);
our $conv_prepare_time=0;
our $conv_prepare_money_time=0;
sub conv_prepare {
  my %b    =(da  =>1e+1, h    =>1e+2, k    =>1e+3, M     =>1e+6,          G   =>1e+9, T   =>1e+12, P    =>1e+15, E   =>1e+18, Z    =>1e+21, Y    =>1e+24, H    =>1e+27);
  my %big  =(deca=>1e+1, hecto=>1e+2, kilo =>1e+3, mega  =>1e+6,          giga=>1e+9, tera=>1e+12, peta =>1e+15, exa =>1e+18, zetta=>1e+21, yotta=>1e+24, hella=>1e+27);
  my %s    =(d   =>1e-1, c    =>1e-2, m    =>1e-3,'µ'    =>1e-6, u=>1e-6, n   =>1e-9, p   =>1e-12, f    =>1e-15, a   =>1e-18, z    =>1e-21, y    =>1e-24);
  my %small=(deci=>1e-1, centi=>1e-2, milli=>1e-3, micro =>1e-6,          nano=>1e-9, pico=>1e-12, femto=>1e-15, atto=>1e-18, zepto=>1e-21, yocto=>1e-24);
  # myria=> 10000              #obsolete
  # demi => 1/2, double => 2   #obsolete
  # lakh => 1e5, crore => 1e7  #south	asian
  my %x = (%s,%b);
  for my $type (keys%conv) {
    for(grep/^_/,keys%{$conv{$type}}) {
      my $c=$conv{$type}{$_};
      delete$conv{$type}{$_};
      my $unit=substr($_,1);
      $conv{$type}{$_.$unit}=$x{$_}*$c for keys%x;
    }
  }
  $conv_prepare_time=time();
}

our $Currency_rates_url = 'http://calthis.com/currency-rates';
our $Currency_rates_expire = 6*3600;
sub conv_prepare_money {
  eval {
    require LWP::Simple;
    my $td=$^O=~/^(?:linux|cygwin)$/?"/tmp":"/tmp"; #hm wrong!
    my $fn="$td/acme-tools-currency-rates.data";
    if( !-e$fn  or  time() - (stat($fn))[9] >= $Currency_rates_expire){
      LWP::Simple::getstore($Currency_rates_url,"$fn.$$.tmp"); # get ... see getrates.cmd
      die "nothing downloaded" if !-s"$fn.$$.tmp";
      rename "$fn.$$.tmp",$fn;
      chmod 0666,$fn;
    }
    my $d=readfile($fn);
    my %r=$d=~/^\s*([A-Z]{3}) +(\d+\.\d+)\b/gm;
    $r{lc($_)}=$r{$_} for keys%r;
    #warn serialize([minus([sort keys(%r)],[sort keys(%{$conv{money}})])],'minus'); #ARS,AED,COP,BWP,LVL,BHD,NPR,LKR,QAR,KWD,LYD,SAR,KZT,CLP,IRR,VEF,TTD,OMR,MUR,BND
    #warn serialize([minus([sort keys(%{$conv{money}})],[sort keys(%r)])],'minus'); #LTC,I44,BTC,BYR,TWI,NOK,XDR
    $conv{money}={%{$conv{money}},%r} if keys(%r)>20;
  };
  carp "conv: conv_prepare_money (currency conversion automatic daily updated rates) - $@\n" if $@;
  $conv{money}{"m$_"}=$conv{money}{$_}/1000 for qw/BTC XBT/;
  $conv_prepare_money_time=time();
  1; #not yet
}

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 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};
  my($cf,$ct)=@{$conv{$type}}{$from,$to};
  my $r= $cf>0 && $ct<0 ? -$ct/$num/$cf
       : $cf<0 && $ct>0 ? -$cf/$num/$ct
       :                   $cf*$num/$ct;
  #  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},
   CF=>sub{$t*9/5+32},
   FK=>sub{($t-32)*5/9+273.15},
  }->{$from.$to}->();
}

sub conv_numbers {
  my($n,$fr,$to)=@_;
  my $dec=$fr eq 'dec'                    ? $n
         :$fr eq 'hex'                    ? hex($n)
         :$fr eq 'oct'                    ? oct($n)
         :$fr eq 'bin'                    ? oct("0b$n")
         :$fr =~ /^(dusin|dozen|doz|dz)$/ ? $n*12
         :$fr =~ /^(gross|gr|gro)$/       ? $n*144
         :$fr eq 'great_gross'            ? $n*12*144
         :$fr eq 'small_gross'            ? $n*12*10
         :$fr eq 'skokk'                  ? $n*60           #norwegian unit
         :$fr eq 'roman'                  ? roman2int($n)
         :$fr eq 'des'                    ? $n
         :croak "Conv from $fr not supported yet";
  my $ret=$to eq 'dec'                    ? $dec
         :$to eq 'hex'                    ? sprintf("%x",$dec)
         :$to eq 'oct'                    ? sprintf("%o",$dec)
         :$to eq 'bin'                    ? sprintf("%b",$dec)
         :$to =~ /^(dusin|dozen|doz|dz)$/ ? $dec/12
         :$to =~ /^(gross|gr|gro)$/       ? $dec/144
         :$to eq 'great_gross'            ? $dec/(12*144)
         :$to eq 'small_gross'            ? $dec/(12*10)
         :$to eq 'skokk'                  ? $dec/60
         :$to eq 'roman'                  ? int2roman($dec)
         :$to eq 'des'                    ? $dec
         :croak "Conv to $to not suppoerted yet";
  $ret;
}
#http://en.wikipedia.org/wiki/Norwegian_units_of_measurement


=head2 bytes_readable

Input: a number

Output:

the number with a B behind if the number is less than 1000

the number divided by 1024 with two decimals and "kB" behind if the number is less than 1024*1000

the number divided by 1048576 with two decimals and "MB" behind if the number is less than 1024*1024*1000

the number divided by 1073741824 with two decimals and "GB" behind if the number is less than 1024*1024*1024*1000

the number divided by 1099511627776 with two decimals and "TB" behind otherwise

Examples:

 print bytes_readable(999);                              # 999 B
 print bytes_readable(1000);                             # 1000 B
 print bytes_readable(1001);                             # 0.98 kB
 print bytes_readable(1024);                             # 1.00 kB
 print bytes_readable(1153433.6);                        # 1.10 MB
 print bytes_readable(1181116006.4);                     # 1.10 GB
 print bytes_readable(1209462790553.6);                  # 1.10 TB
 print bytes_readable(1088516511498.24*1000);            # 990.00 TB

=cut

sub bytes_readable {
  my $bytes=shift();
  return undef if !defined $bytes;
  return "$bytes B"                      if abs($bytes)<=2** 0*1000; #bytes
  return sprintf("%.2f kB",$bytes/2**10) if abs($bytes)<2**10*1000; #kilobyte
  return sprintf("%.2f MB",$bytes/2**20) if abs($bytes)<2**20*1000; #megabyte
  return sprintf("%.2f GB",$bytes/2**30) if abs($bytes)<2**30*1000; #gigabyte
  return sprintf("%.2f TB",$bytes/2**40) if abs($bytes)<2**40*1000; #terrabyte
  return sprintf("%.2f PB",$bytes/2**50); #petabyte, exabyte, zettabyte, yottabyte
}

=head2 int2roman

Converts integers to roman numbers.

B

 print int2roman(1234);   # prints MCCXXXIV
 print int2roman(1971);   # prints MCMLXXI

(Adapted subroutine from Peter J. Acklam, jacklam(&)math.uio.no)

 I = 1
 V = 5
 X = 10
 L = 50
 C = 100     (centum)
 D = 500
 M = 1000    (mille)

See also L.

See L for more.

=head2 roman2int

 roman2int("MCMLXXI") == 1971

=cut

#alternative algorithm: http://www.rapidtables.com/convert/number/how-number-to-roman-numerals.htm
sub int2roman {
  my($n,@p)=(shift,[],[1],[1,1],[1,1,1],[1,2],[2],[2,1],[2,1,1],[2,1,1,1],[1,3],[3]);
    !defined($n)? undef
  : !length($n) ? ""
  : int($n)!=$n ? croak"int2roman: $n is not an integer"
  : $n==0       ? ""
  : $n<0        ? "-".int2roman(-$n)
  : $n>3999     ? "M".int2roman($n-1000)
  : join'',@{[qw/I V X L C D M/]}[map{my$i=$_;map($_+5-$i*2,@{$p[$n/10**(3-$i)%10]})}(0..3)];
}

sub roman2int {
  my($r,$n,%c)=(shift,0,'',0,qw/I 1 V 5 X 10 L 50 C 100 D 500 M 1000/);
  $r=~s/^-//?-roman2int($r):
  $r=~s/(C?)([DM])|(X?)([LCDM])|(I?)([VXLCDM])|(I)|(.)/
        croak "roman2int: Invalid number $r" if $8;
        $n += $c{$2||$4||$6||$7} - $c{$1||$3||$5||''}; ''/eg && $n
}

#sub roman2int_slow {
#  my $r=shift;
#     $r=~s,^\-,,  ?    0-roman2int($r)
#   : $r=~s,^M,,i  ? 1000+roman2int($r)
#   : $r=~s,^CM,,i ?  900+roman2int($r)
#   : $r=~s,^D,,i  ?  500+roman2int($r)
#   : $r=~s,^CD,,i ?  400+roman2int($r)
#   : $r=~s,^C,,i  ?  100+roman2int($r)
#   : $r=~s,^XC,,i ?   90+roman2int($r)
#   : $r=~s,^L,,i  ?   50+roman2int($r)
#   : $r=~s,^XL,,i ?   40+roman2int($r)
#   : $r=~s,^X,,i  ?   10+roman2int($r)
#   : $r=~s,^IX,,i ?    9+roman2int($r)
#   : $r=~s,^V,,i  ?    5+roman2int($r)
#   : $r=~s,^IV,,i ?    4+roman2int($r)
#   : $r=~s,^I,,i  ?    1+roman2int($r)
#   : !length($r)  ?    0
#   : croak "Invalid roman number $r";
#}

=head2 distance

B the four decimal numbers of two GPS positions: latutude1, longitude1, latitude2, longitude2

B the air distance in meters between the two points

Calculation is done using the Haversine Formula for spherical distance:

  a = sin((lat2-lat1)/2)^2
    + sin((lon2-lon1)/2)^2 * cos(lat1) * cos(lat2);

  c = 2 * atan2(min(1,sqrt(a)),
	        min(1,sqrt(1-a)))

  distance = c * R

With earth radius set to:

  R = Re - (Re-Rp) * sin(abs(lat1+lat2)/2)

Where C (equatorial radius) and C (polar radius).

B

 my @oslo = ( 59.93937,  10.75135);    # oslo in norway
 my @rio  = (-22.97673, -43.19508);    # rio in brazil

 printf "%.1f km\n",   distance(@oslo,@rio)/1000;                  # 10431.7 km
 printf "%.1f km\n",   distance(@rio,@oslo)/1000;                  # 10431.7 km
 printf "%.1f nmi\n",  distance(@oslo,@rio)/1852.000;              # 5632.7 nmi   (nautical miles)
 printf "%.1f miles\n",distance(@oslo,@rio)/1609.344;              # 6481.9 miles
 printf "%.1f miles\n",conv(distance(@oslo,@rio),"meters","miles");# 6481.9 miles

See L

and L

and L

and L, but Acme::Tools::distance() is about 8 times faster.

=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);
  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
  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 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, C and C to return what you want.

B Acme::Tools does not depend on Math::BigInt and
Math::BigFloat and GMP, but these four big*-subs do (by C).
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

=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";
    #$a * (1 - $e**2) / ((1 - $e**2 * sin(($lat1+$lat2)/2)**2)**1.5); #hmm avg lat
    #$R=$a * $t/$n;

#=head2 fractional
#=cut

sub fractional { #http://mathcentral.uregina.ca/QQ/database/QQ.09.06/h/lil1.html
  carp "fractional: NOT FINISHED";
  my $n=shift;
  print "----fractional n=$n\n";
  my $nn=$n; my $dec;
  $nn=~s,\.(\d+)$,$dec=length($1);$1.,;
  my $l;
  my $max=0;
  my($te,$ne);
  for(1..length($nn)/2){
    if( $nn=~/^(\d*?)((.{$_})(\3)+)$/ ){
      print "_ = $_ ".length($2)."\n";
      if(length($2)>$max){
        $l=$_;
	$te="$1$3"-$1;
        $max=length($2);
      }
    }
  }
  return fractional($n) if !$l and !recursed() and $dec>6 and substr($n,-1) and substr($n,-1)--;
  print "l=$l max=$max\n";
  $ne="9" x $l;
  print log($n),"\n";
  my $st=sub{print "status: ".($te/$ne)."   n=$n   ".($n/$te*$ne)."\n"};
  while($n/$te*$ne<0.99){ &$st(); $ne*=10 }
  while($te/$n/$ne<0.99){ &$st(); $te*=10 }
  &$st();
  while(1){
    my $d=gcd($te,$ne); print "gcd=$d\n";
    last if $d==1;
    $te/=$d; $ne/=$d;
  }
  &$st();
  wantarray ? ($te,$ne) : "$te/$ne"; #gcd()
}

=head2 isnum

B String to be tested on regexp C<< /^ \s* [\-\+]? (?: \d*\.\d+ | \d+ ) (?:[eE][\-\+]?\d+)?\s*$/x >>. If no argument is given isnum checks C<< $_ >>.

B True or false (1 or 0)

=cut

our $Re_isnum=qr/^ \s* [\-\+]? (?: \d*\.\d+ | \d+ ) (?:[eE][\-\+]?\d+)?\s*$/x;
sub isnum {(@_?$_[0]:$_)=~$Re_isnum}

=head2 between

Input: Three arguments.

Returns: Something I if the first argument is numerically between the two next.

=cut

sub between {
  my($test,$fom,$tom)=@_;
  no warnings;
  return $fom<$tom ? $test>=$fom&&$test<=$tom
                   : $test>=$tom&&$test<=$fom;
}

=head2 curb

B Three arguments: value, minumum, maximum.

B Returns the value if its between the given minumum and maximum.
Returns minimum if the value is less or maximum if the value is more.

 my $v = 234;
 print curb( $v, 200, 250 );    #prints 234
 print curb( $v, 150, 200 );    #prints 200
 print curb( $v, 250, 300 );    #prints 250
 print curb(\$v, 250, 300 );    #prints 250 and changes $v
 print $v;                      #prints 250

In the last example $v is changed because the argument is a reference. (To keep backward compatability, C<< bound() >> is a synonym for C<< curb() >>)

=cut

sub curb {
  my($val,$min,$max)=@_;
  croak "curb: wrong args" if @_!=3 or !defined$min or !defined$max or !defined$val or $min>$max;
  return $$val=curb($$val,$min,$max) if ref($val) eq 'SCALAR';
  $val < $min ? $min :
  $val > $max ? $max :
                $val;
}
sub bound { curb(@_) }

=head1 STRINGS

=head2 upper

=head2 lower

Returns input string as uppercase or lowercase.

Can be used if Perls build in C and C for some reason does not convert æøå or other latin letters outsize a-z.

Converts C<< æøåäëïöüÿâêîôûãõàèìòùáéíóúýñð >> to and from C<< ÆØÅÄËÏÖÜ?ÂÊÎÔÛÃÕÀÈÌÒÙÁÉÍÓÚÝÑÐ >>

See also C<< perldoc -f uc >> and C<< perldoc -f lc >>

=head2 trim

Removes space from the beginning and end of a string. Whitespace (C<< \s >>) that is.
And removes any whitespace inside the string of more than one char, leaving the first whitespace char. Thus:

 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

Left or right pads a string to the given length by adding one or more spaces at the end for  I or at the start for I.

B First argument: string to be padded. Second argument: length of the output. Optional third argument: character(s) used to pad.
Default is space.

 rpad('gomle',9);         # 'gomle    '
 lpad('gomle',9);         # '    gomle'
 rpad('gomle',9,'-');     # 'gomle----'
 lpad('gomle',9,'+');     # '++++gomle'
 rpad('gomle',4);         # 'goml'
 lpad('gomle',4);         # 'goml'
 rpad('gomle',7,'xyz');   # 'gomlxy'
 lpad('gomle',10,'xyz');  # 'xyzxygoml'

=head2 cpad

Center pads. Pads the string both on left and right equal to the given length. Centers the string. Pads right side first.

 cpad('mat',5)            eq ' mat '
 cpad('mat',4)            eq 'mat '
 cpad('mat',6)            eq ' mat  '
 cpad('mat',9)            eq '   mat   '
 cpad('mat',5,'+')        eq '+mat+'
 cpad('MMMM',20,'xyzXYZ') eq 'xyzXYZxyMMMMxyzXYZxy'

=cut

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;
  $s;
}

sub rpad {
  my($s,$l,$p)=@_;
  $p=' ' if @_<3 or !length($p);
  $s.=$p while length($s)<$l;
  substr($s,0,$l);
}

sub lpad {
  my($s,$l,$p)=@_;
  $p=' ' if @_<3 or !length($p);
  $l
  ? substr($s,0,$l)
  : substr($p x (1+$l/length($p)), 0, $l-length($s)).$s;
}

sub cpad {
  my($s,$l,$p)=@_;
  $p=' ' if @_<3 or !length($p);
  my $ls=length($s);
  return substr($s,0,$l) if $l<$ls;
  $p=$p x (($l-$ls+2)/length($p));
  substr($p, 0, ($l-$ls  )/2) . $s .
  substr($p, 0, ($l-$ls+1)/2);
}

sub cpad_old {
  my($s,$l,$p)=@_;
  $p=' ' if !length($p);
  return substr($s,0,$l) if $l
  my $i=0;
  while($l>length($s)){
    my $pc=substr($p,($i==int($i)?1:-1)*($i%length($p)),1);
    $i==int($i) ? ($s.=$pc) : ($s=$pc.$s);
    $i+=1/2;
  }
  $s;
}

=head2 trigram

B A string (i.e. a name). And an optional x (see example 2)

B A list of this strings trigrams (See examlpe)

B

 print join ", ", trigram("Kjetil Skotheim");

Prints:

 Kje, jet, eti, til, il , l S,  Sk, Sko, kot, oth, the, hei, eim

B

Default is 3, but here 4 is used instead in the second optional input argument:

 print join ", ", trigram("Kjetil Skotheim", 4);

And this prints:

 Kjet, jeti, etil, til , il S, l Sk,  Sko, Skot, koth, othe, thei, heim

C was created for "fuzzy" name searching. If you have a database of many names,
addresses, phone numbers, customer numbers etc. You can use trigram() to search
among all of those at the same time. If the search form only has one input field.
One general search box.

Store all of the trigrams of the trigram-indexed input fields coupled
with each person, and when you search, you take each trigram of you
query string and adds the list of people that has that trigram. The
search result should then be sorted so that the persons with most hits
are listed first. Both the query strings and the indexed database
fields should have a space added first and last before C-ing
them.

This search algorithm is not includes here yet...

C should perhaps have been named ngram for obvious reasons.

=head2 sliding

Same as trigram (except there is no default width). Works also with arrayref instead of string.

Example:

 sliding( ["Reven","rasker","over","isen"], 2 )

Result:

  ( ['Reven','rasker'], ['rasker','over'], ['over','isen'] )

=head2 chunks

Splits strings and arrays into chunks of given size:

 my @a = chunks("Reven rasker over isen",7);
 my @b = chunks([qw/Og gubben satt i kveldinga og koste seg med skillinga/], 3);

Resulting arrays:

 ( 'Reven r', 'asker o', 'ver ise', 'n' )
 ( ['Og','gubben','satt'], ['i','kveldinga','og'], ['koste','seg','med'], ['skillinga'] )

=head2 chars

 chars("Tittentei");     # ('T','i','t','t','e','n','t','e','i')

=cut

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

Synonym for replace().

=head2 replace

Return the string in the first input argument, but where pairs of search-replace strings (or rather regexes) has been run.

Works as C in Oracle, or rather regexp_replace() in Oracle 10 and onward. Except that this C accepts more than three arguments.

Examples:

 print replace("water","ater","ine");  # Turns water into wine
 print replace("water","ater");        # w
 print replace("water","at","eath");   # weather
 print replace("water","wa","ju",
                       "te","ic",
                       "x","y",        # No x is found, no y is returned
                       'r$',"e");      # Turns water into juice. 'r$' says that the r it wants
                                       # to change should be the last letters. This reveals that
                                       # second, fourth, sixth and so on argument is really regexs,
                                       # not normal strings. So use \ (or \\ inside "") to protect
                                       # the special characters of regexes. You probably also
                                       # should write qr/regexp/ instead of 'regexp' if you make
                                       # use of regexps here, just to make it more clear that
                                       # these are really regexps, not strings.

 print replace('JACK and JUE','J','BL'); # prints BLACK and BLUE
 print replace('JACK and JUE','J');      # prints ACK and UE
 print replace("abc","a","b","b","c");   # prints ccc           (not bcc)

If the first argument is a reference to a scalar variable, that variable is changed "in place".

Example:

 my $str="test";
 replace(\$str,'e','ee','s','S');
 print $str;                         # prints teeSt

=cut

sub replace { repl(@_) }
sub repl {
  my $str=shift;
  return $$str=replace($$str,@_) if ref($str) eq 'SCALAR';
 #return ? if ref($str) eq 'ARRAY';
 #return ? if ref($str) eq 'HASH';
  while(@_){
    my($fra,$til)=(shift,shift);
    defined $til ? $str=~s/$fra/$til/g : $str=~s/$fra//g;
  }
  return $str;
}


=head1 ARRAYS

=head2 min

Returns the smallest number in a list. Undef is ignored.

 @lengths=(2,3,5,2,10,undef,5,4);
 $shortest = min(@lengths);   # returns 2

Note: The comparison operator is perls C<< < >>> which means empty strings is treated as C<0>, the number zero. The same goes for C, except of course C<< > >> is used instead.

 min(3,4,5)       # 3
 min(3,4,5,undef) # 3
 min(3,4,5,'')    # returns the empty string

=head2 max

Returns the largest number in a list. Undef is ignored.

 @heights=(123,90,134,undef,132);
 $highest = max(@heights);   # 134

=head2 mins

Just as L, except for strings.

 print min(2,7,10);          # 2
 print mins("2","7","10");   # 10
 print mins(2,7,10);         # 10

=head2 maxs

Just as L, except for strings.

 print max(2,7,10);          # 10
 print maxs("2","7","10");   # 7
 print maxs(2,7,10);         # 7

=cut

sub min  {my $min;for(@_){ $min=$_ if defined($_) and !defined($min) || $_ < $min } $min }
sub mins {my $min;for(@_){ $min=$_ if defined($_) and !defined($min) || $_ lt $min} $min }
sub max  {my $max;for(@_){ $max=$_ if defined($_) and !defined($max) || $_ > $max } $max }
sub maxs {my $max;for(@_){ $max=$_ if defined($_) and !defined($max) || $_ gt $max} $max }

=head2 zip

B Two or more arrayrefs. A number of equal sized arrays
containing numbers, strings or anything really.

B An array of those input arrays zipped (interlocked, merged) into each other.

 print join " ", zip( [1,3,5], [2,4,6] );               # 1 2 3 4 5 6
 print join " ", zip( [1,4,7], [2,5,8], [3,6,9] );      # 1 2 3 4 5 6 7 8 9

Example:

zip() creates a hash where the keys are found in the first array and values in the secord in the correct order:

 my @media = qw/CD DVD VHS LP Blueray/;
 my @count = qw/20 12  2   4  3/;
 my %count = zip(\@media,\@count);                 # or zip( [@media], [@count] )
 print "I got $count{DVD} DVDs\n";                 # I got 12 DVDs

Dies (croaks) if the two lists are of different sizes

...or any input argument is not an array ref.

=cut

sub zip {
  my @t=@_;
  ref($_) ne 'ARRAY' and croak "ERROR: zip should have arrayrefs as arguments" for @t;
  @{$t[$_]} != @{$t[0]} and croak "ERROR: zip should have equal sized arrays" for 1..$#t;
  my @res;
  for my $i (0..@{$t[0]}-1){
    push @res, $$_[$i] for @t;
  }
  return @res;
}


=head2 pushsort

Adds one or more element to a numerically sorted array and keeps it sorted.

  pushsort @a, 13;                         # this...
  push     @a, 13; @a = sort {$a<=>$b} @a; # is the same as this, but the former is faster if @a is large

=head2 pushsortstr

Same as pushsort except that the array is kept sorted alphanumerically (cmp) instead of numerically (<=>). See L.

  pushsort @a, "abc";                      # this...
  push     @a, "abc"; @a = sort @a;        # is the same as this, but the former is faster if @a is large

=cut

our $Pushsort_cmpsub=undef;
sub pushsort (\@@) {
  my $ar=shift;

  #not needed but often faster
  if(!defined $Pushsort_cmpsub and @$ar+@_<100){ #hm speedup?
    @$ar=(sort {$a<=>$b} (@$ar,@_));
    return 0+@$ar;
  }

  for my $v (@_){

    #not needed but often faster
    if(!defined $Pushsort_cmpsub){ #faster rank() in most cases
      push    @$ar, $v and next if $v>=$$ar[-1];
      unshift @$ar, $v and next if $v< $$ar[0];
    }

    splice @$ar, binsearch($v,$ar,1,$Pushsort_cmpsub)+1, 0, $v;
  }
  0+@$ar
}
sub pushsortstr(\@@){ local $Pushsort_cmpsub=sub{$_[0]cmp$_[1]}; pushsort(@_) } #speedup: copy sub pushsort

=head2 binsearch

Returns the position of an element in a numerically sorted array. Returns undef if the element is not found.

B Two, three or four arguments

B the element to find. Usually a number.

B a reference to the array to search in. The array
should be sorted in ascending numerical order (se exceptions below).

B  Optional. Default false.

If present, whether result I should return undef or a fractional position.

If the third argument is false binsearcg returns undef if the element is not found.

If the third argument is true binsearch returns 0.5 plus closest position below the searched value.

Returns C< last position + 0.5 > if the searched element is greater than all elements in the sorted array.

Returns C< -0.5 > if the searched element is less than all elements in the sorted array.

Fourth argument: Optional. Default C<< sub { $_[0] <=> $_[1] } >>.

If present, the fourth argument is a code-ref that alters the way binsearch compares two elements.

B

 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

=head2 binsearchstr

Same as binsearch except that the arrays is sorted alphanumerically
(cmp) instead of numerically (<=>) and the searched element is a
string, not a number. See L.

=cut

our $Binsearch_steps;
our $Binsearch_maxsteps=100;
sub binsearch {
  my($search,$aref,$insertpos,$cmpsub)=@_; #search pos of search in array
  croak "binsearch did not get arrayref as second arg" if ref($aref) ne 'ARRAY';
  croak "binsearch got fourth arg which is not a code-ref" if $cmpsub and ref($cmpsub) ne 'CODE';
  return $insertpos ? -0.5 : undef if !@$aref;
  my($min,$max)=(0,$#$aref);
  $Binsearch_steps=0;
  while (++$Binsearch_steps <= $Binsearch_maxsteps) {
    my $middle=int(($min+$max+0.5)/2);
    my $middle_value=$$aref[$middle];

    #croak "binsearch got non-sorted array" if !$cmpsub and $$aref[$min]>$$aref[$min]
    #                                       or  $cmpsub and &$cmpsub($$aref[$min],$$aref[$min])>0;

    if(   !$cmpsub and $search < $middle_value
    or     $cmpsub and &$cmpsub($search,$middle_value) < 0  ) {      #print "<\n";
      $max=$min, next                   if $middle == $max and $min != $max;
      return $insertpos ? $middle-0.5 : undef if $middle == $max;
      $max=$middle;
    }
    elsif( !$cmpsub and $search > $middle_value
    or      $cmpsub and &$cmpsub($search,$middle_value) > 0 ) {      #print ">\n";
      $min=$max, next                   if $middle == $min and $max != $min;
      return $insertpos ? $middle+0.5 : undef if $middle == $min;
      $min=$middle;
    }
    else {                                                           #print "=\n";
      return $middle;
    }
  }
  croak "binsearch exceded $Binsearch_maxsteps steps";
}

sub binsearchfast { # binary search routine finds index just below value
  my ($x,$v)=@_;
  my ($klo,$khi)=(0,$#{$x});
  my $k;
  while (($khi-$klo)>1) {
    $k=int(($khi+$klo)/2);
    if ($$x[$k]>$v) { $khi=$k; } else { $klo=$k; }
  }
  return $klo;
}


sub binsearchstr {binsearch(@_[0..2],sub{$_[0]cmp$_[1]})}

=head2 rank

B Two or three arguments. N and an arrayref for the list to look at.

In scalar context: Returns the nth smallest number in an array. The array doesn't have to be sorted.

In array context: Returns the n smallest numbers in an array.

To return the n(th) largest number(s) instead of smallest, just negate n.

An optional third argument can be a sub that is used to compare the elements of the input array.

Examples:

 my $second_smallest = rank(2, [11,12,13,14]);  # 12
 my @top10           = rank(-10, [1..100]);     # 100, 99, 98, 97, 96, 95, 94, 93, 92, 91
 my $max             = rank(-1, [101,102,103,102,101]); #103
 my @contest         = ({name=>"Alice",score=>14},{name=>"Bob",score=>13},{name=>"Eve",score=>12});
 my $second          = rank(2, \@contest, sub{$_[1]{score}<=>$_[0]{score}})->{name}; #Bob

=head2 rankstr

Just as C but sorts alphanumerically (strings, cmp) instead of numerically.

=cut

sub rank {
  my($rank,$aref,$cmpsub)=@_;
  if($rank<0){
    $cmpsub||=sub{$_[0]<=>$_[1]};
    return rank(-$rank,$aref,sub{0-&$cmpsub});
  }
  my @sort;
  local $Pushsort_cmpsub=$cmpsub;
  for(@$aref){
    pushsort @sort, $_;
    pop @sort if @sort>$rank;
  }
  return wantarray ? @sort : $sort[$rank-1];
}
sub rankstr {wantarray?(rank(@_,sub{$_[0]cmp$_[1]})):rank(@_,sub{$_[0]cmp$_[1]})}

=head2 eqarr

B Two or more references to arrays.

B True (1) or false (0) for whether or not the arrays are numerically I alphanumerically equal.
Comparing each element in each array with both C< == > and C< eq >.

Examples:

 eqarr([1,2,3],[1,2,3],[1,2,3]); # 1 (true)
 eqarr([1,2,3],[1,2,3],[1,2,4]); # 0 (false)
 eqarr([1,2,3],[1,2,3,4]);       # undef (different size, false)
 eqarr([1,2,3]);                 # croak (should be two or more arrays)
 eqarr([1,2,3],1,2,3);           # croak (not arraysrefs)

=cut

sub eqarr {
  my @arefs=@_;
  croak if @arefs<2;
  ref($_) ne 'ARRAY' and croak for @arefs;
  @{$arefs[0]} != @{$arefs[$_]} and return undef for 1..$#arefs;
  my $ant;

  for my $ar (@arefs[1..$#arefs]){
    for(0..@$ar-1){
      ++$ant and $ant>100 and croak ">100";  #TODO: feiler ved sammenligning av to tabeller > 10000(?) tall
      return 0 if $arefs[0][$_] ne $$ar[$_]
   	       or $arefs[0][$_] != $$ar[$_];
    }
  }
  return 1;
}

=head2 sorted

Return true if the input array is numerically sorted.

  @a=(1..10); print "array is sorted" if sorted @a;  #true

Optionally the last argument can be a comparison sub:

  @person=({Rank=>1,Name=>'Amy'}, {Rank=>2,Name=>'Paula'}, {Rank=>3,Name=>'Ruth'});
  print "Persons are sorted" if sorted @person, sub{$_[0]{Rank}<=>$_[1]{Rank}};

=head2 sortedstr

Return true if the input array is Inumerically sorted.

  @a=(1..10);      print "array is sorted" if sortedstr @a; #false
  @a=("01".."10"); print "array is sorted" if sortedstr @a; #true

=cut

sub sorted (\@@) {
  my($a,$cmpsub)=@_;
  for(0..$#$a-1){
    return 0 if !$cmpsub and $$a[$_]>$$a[$_+1]
             or  $cmpsub and &$cmpsub($$a[$_],$$a[$_+1])>0;
  }
  return 1;
}
sub sortedstr { sorted(@_,sub{$_[0]cmp$_[1]}) }

=head2 part

B A code-ref and a list

B Two array-refs

Like C but returns the false list as well. Partitions a list
into two lists where each element goes into the first or second list
whether the predicate (a code-ref) is true or false for that element.

 my( $odd, $even ) = part {$_%2} (1..8);
 print for @$odd;   #prints 1 3 5 7
 print for @$even;  #prints 2 4 6 8

(Works like C< partition() > in the Scala programming language)

=head2 parth

Like C but returns any number of lists.

B A code-ref and a list

B A hash where the returned values from the code-ref are keys and the values are arrayrefs to the list elements which gave those keys.

 my %hash = parth { uc(substr($_,0,1)) } ('These','are','the','words','of','this','array');
 print serialize(\%hash);

Result:

 %hash = (  T=>['These','the','this'],
            A=>['are','array'],
            O=>['of'],
            W=>['words']                )

=head2 parta

Like L but returns an array of lists.

 my @a = parta { length } qw/These are the words of this array/;

Result:

 @a = ( undef, undef, ['of'], ['are','the'], ['this'], ['These','words','array'] )

Two undefs at first (index positions 0 and 1) since there are no words of length 0 or 1 in the input array.

=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

=head1 STATISTICS

=head2 sum

Returns the sum of a list of numbers. Undef is ignored.

 print sum(1,3,undef,8);   # 12
 print sum(1..1000);       # 500500
 print sum(undef);         # undef

=cut

sub sum { my $sum; no warnings; defined($_) and $sum+=$_ for @_; $sum }

=head2 avg

Returns the I number of a list of numbers. That is C

 print avg(  2, 4, 9);   # 5      (2+4+9) / 3 = 5
 print avg( [2, 4, 9] ); # 5      pass by reference, same result but faster for large arrays

Also known as I.

Pass by reference: If one argument is given and it is a reference to an array,
this array is taken as the list of numbers. This mode is about twice as fast
for 10000 numbers or more. It most likely also saves memory.

=cut

sub avg {
  my($sum,$n,@a)=(0,0);
  no warnings;
  if( @_==0 )                          { return undef             }
  if( @_==1 and ref($_[0]) eq 'ARRAY' ){ @a=grep defined,@{$_[0]} }
  else                                 { @a=grep defined,@_       }
  if( @a==0 )                          { return undef             }
  $sum+=$_ for @a;
  return $sum/@a
}

=head2 geomavg

Returns the I (a.k.a I) 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 (a.k.a I) of a list of numbers. L

 print harmonicavg(10,11,12);               # 3 / ( 1/10 + 1/11 + 1/12) = 10.939226519337

=cut

sub harmonicavg { my $s; $s+=1/$_ for @_; @_/$s }

=head2 variance

C<< variance = ( sum (x[i]-Average)**2)/(n-1) >>

=cut

sub variance {
  my $sumx2; $sumx2+=$_*$_ for @_;
  my $sumx; $sumx+=$_ for @_;
  (@_*$sumx2-$sumx*$sumx)/(@_*(@_-1));
}

=head2 stddev

C<< Standard_Deviation = sqrt(variance) >>

Standard deviation (stddev) is a measurement of the width of a normal
distribution where one stddev on each side of the mean covers 68% and
two stddevs 95%.  Normal distributions are sometimes called Gauss curves
or Bell shapes. L

 stddev(4,5,6,5,6,4,3,5,5,6,7,6,5,7,5,6,4)         # = 1.0914103126635
 avg(@testscores) + stddev(@testscores)            # = the score for IQ = 115 (by one definition)
 avg(@testscores) - stddev(@testscores)            # = the score for IQ = 85

=cut

sub stddev {
  return undef        if @_==0;
  return stddev(\@_)  if @_>0 and !ref($_[0]);
  my $ar=shift;
  return undef        if @$ar==0;
  return 0            if @$ar==1;
  my $sumx2; $sumx2 += $_*$_ for @$ar;
  my $sumx;  $sumx  += $_    for @$ar;
  sqrt( (@$ar*$sumx2-$sumx*$sumx)/(@$ar*(@$ar-1)) );
}

=head2 median

Returns the median value of a list of numbers. The list do not have to
be sorted.

Example 1, list having an odd number of numbers:

 print median(1, 100, 101);   # 100

100 is the middlemost number after sorting.

Example 2, an even number of numbers:

 print median(1005, 100, 101, 99);   # 100.5

100.5 is the average of the two middlemost numbers.

=cut

sub median {
  no warnings;
  my @list = sort {$a<=>$b} @_;
  my $n=@list;
  $n%2 ?  $list[($n-1)/2]
       : ($list[$n/2-1] + $list[$n/2])/2;
}


=head2 percentile

Returns one or more percentiles of a list of numbers.

Percentile 50 is the same as the I, percentile 25 is the first
quartile, 75 is the third quartile.

B

First argument is your wanted percentile, or a refrence to a list of percentiles you want from the dataset.

If the first argument to percentile() is a scalar, this percentile is returned.

If the first argument is a reference to an array, then all those percentiles are returned as an array.

Second, third, fourth and so on argument are the numbers from which you want to find the percentile(s).

B

This finds the 50-percentile (the median) to the four numbers 1, 2, 3 and 4:

 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);

But the latter is faster, especially if @data is large since it sorts
the numbers only once internally.

B

Data: 1, 4, 6, 7, 8, 9, 22, 24, 39, 49, 555, 992

Average (or mean) is 143

Median is 15.5 (which is the average of 9 and 22 who both equally lays in the middle)

The 25-percentile is 6.25 which are between 6 and 7, but closer to 6.

The 75-percentile is 46.5, which are between 39 and 49 but close to 49.

Linear interpolation is used to find the 25- and 75-percentile and any
other x-percentile which doesn't fall exactly on one of the numbers in
the set.

B

As you saw, 6.25 are closer to 6 than to 7 because 25% along the set of
the twelve numbers is closer to the third number (6) than to he fourth
(7). The median (50-percentile) is also really interpolated, but it is
always in the middle of the two center numbers if there are an even count
of numbers.

However, there is two methods of interpolation:

Example, we have only three numbers: 5, 6 and 7.

Method 1: The most common is to say that 5 and 7 lays on the 25- and
75-percentile. This method is used in Acme::Tools.

Method 2: In Oracle databases the least and greatest numbers
always lay on the 0- and 100-percentile.

As an argument on why Oracles (and others?) definition is not the best way is to
look at your data as for instance temperature measurements.  If you
place the highest temperature on the 100-percentile you are sort of
saying that there can never be a higher temperatures in future measurements.

A quick non-exhaustive Google survey suggests that method 1 here is most used.

The larger the data sets, the less difference there is between the two methods.

B

In method one, when you want a percentile outside of any possible
interpolation, you use the smallest and second smallest to extrapolate
from. For instance in the data set C<5, 6, 7>, if you want an
x-percentile of x < 25, this is below 5.

If you feel tempted to go below 0 or above 100, C will
I (or I to be more precise)

Another method could be to use "soft curves" instead of "straight
lines" in interpolation. Maybe B-splines or Bezier curves. This is not
used here.

For large sets of data Hoares algorithm would be faster than the
simple straightforward implementation used in C
here. Hoares don't sort all the numbers fully.

B

 Data: 1, 4, 6, 7, 8, 9, 22, 24, 39, 49, 555, 992

 Percentile  Method 1                    Method 2
             (Acme::Tools::percentile  (Oracle)
             and others)
 ----------- --------------------------- ---------
 0           -2                          1
 1           -1.61                       1.33
 25          6.25                        6.75
 50 (median) 15.5                        15.5
 75          46.5                        41.5
 99          1372.19                     943.93
 100         1429                        992

Found like this:

 perl -MAcme::Tools -le 'print for percentile([0,1,25,50,75,99,100], 1,4,6,7,8,9,22,24,39,49,555,992)'

And like this in Oracle-databases:

 create table tmp (n number);
 insert into tmp values (1); insert into tmp values (4); insert into tmp values (6);
 insert into tmp values (7); insert into tmp values (8); insert into tmp values (9);
 insert into tmp values (22); insert into tmp values (24); insert into tmp values (39);
 insert into tmp values (49); insert into tmp values (555); insert into tmp values (992);
 select
   percentile_cont(0.00) within group(order by n) per0,
   percentile_cont(0.01) within group(order by n) per1,
   percentile_cont(0.25) within group(order by n) per25,
   percentile_cont(0.50) within group(order by n) per50,
   percentile_cont(0.75) within group(order by n) per75,
   percentile_cont(0.99) within group(order by n) per99,
   percentile_cont(1.00) within group(order by n) per100
 from tmp;

(Oracle also provides a similar function: C where I
is short for I, meaning no interpolation is taking
place. Instead the closest number from the data set is picked.)

=cut

sub percentile {
  my(@p,@t,@ret);
  if(ref($_[0]) eq 'ARRAY'){ @p=@{shift()} }
  elsif(not ref($_[0]))    { @p=(shift())  }
  else{croak()}
  @t=@_;
  return if !@p;
  croak if !@t;
  @t=sort{$a<=>$b}@t;
  push@t,$t[0] if @t==1;
  for(@p){
    croak if $_<0 or $_>100;
    my $i=(@t+1)*$_/100-1;
    push@ret,
      $i<0       ? $t[0]+($t[1]-$t[0])*$i:
      $i>$#t     ? $t[-1]+($t[-1]-$t[-2])*($i-$#t):
      $i==int($i)? $t[$i]:
                   $t[$i]*(int($i+1)-$i) + $t[$i+1]*($i-int($i));
  }
  return @p==1 ? $ret[0] : @ret;
}

=head1 RANDOM

=head2 random

B One or two arguments.

B

If two integer arguments: returns a random integer between the integers in argument one and two.

If the first argument is an arrayref: returns a random member of that array without changing the array.

If the first argument is an arrayref and there is a second arg: return that many random members of that array

If the first argument is an hashref and there is no second arg: return a random key weighted by the values of that hash

If the first argument is an hashref and there is a second arg: return that many random keys weighted by the values of that hash

If there is no second argument and the first is an integer, a random integer between 0 and that number is returned. Including 0 and the number itself.

B

 $dice=random(1,6);                                      # 1, 2, 3, 4, 5 or 6
 $dice=random([1..6]);                                   # same as previous
 @dice=random([1..6],10);                                # 10 dice tosses
 $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]}
    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));
}
#todo?: https://en.wikipedia.org/wiki/Irwin%E2%80%93Hall_distribution

=head2 random_gauss

Returns an pseudo-random number with a Gaussian distribution instead
of the uniform distribution of perls C or C in this
module.  The algorithm is a variation of the one at
L which is both faster
and better than adding a long series of C.

Uses perls C function internally.

B 0 - 3 arguments.

First argument: the average of the distribution. Default 0.

Second argument: the standard deviation of the distribution. Default 1.

Third argument: If a third argument is present, C
returns an array of that many pseudo-random numbers. If there is no
third argument, a number (a scalar) is returned.

B 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%

Example 2:

 my $num=1e6;
 my @h; $h[$_/2]++ for random_gauss(100,15, $num);
 $h[$_] and printf "%3d - %3d %6d %s\n",
   $_*2,$_*2+1,$h[$_],'=' x ($h[$_]*1000/$num)
     for 1..200/2;

...prints an example of the famous Bell curve:

  44 -  45     70
  46 -  47    114
  48 -  49    168
  50 -  51    250
  52 -  53    395
  54 -  55    588
  56 -  57    871
  58 -  59   1238 =
  60 -  61   1807 =
  62 -  63   2553 ==
  64 -  65   3528 ===
  66 -  67   4797 ====
  68 -  69   6490 ======
  70 -  71   8202 ========
  72 -  73  10577 ==========
  74 -  75  13319 =============
  76 -  77  16283 ================
  78 -  79  20076 ====================
  80 -  81  23742 =======================
  82 -  83  27726 ===========================
  84 -  85  32205 ================================
  86 -  87  36577 ====================================
  88 -  89  40684 ========================================
  90 -  91  44515 ============================================
  92 -  93  47575 ===============================================
  94 -  95  50098 ==================================================
  96 -  97  52062 ====================================================
  98 -  99  53338 =====================================================
 100 - 101  52834 ====================================================
 102 - 103  52185 ====================================================
 104 - 105  50472 ==================================================
 106 - 107  47551 ===============================================
 108 - 109  44471 ============================================
 110 - 111  40704 ========================================
 112 - 113  36642 ====================================
 114 - 115  32171 ================================
 116 - 117  28166 ============================
 118 - 119  23618 =======================
 120 - 121  19873 ===================
 122 - 123  16360 ================
 124 - 125  13452 =============
 126 - 127  10575 ==========
 128 - 129   8283 ========
 130 - 131   6224 ======
 132 - 133   4661 ====
 134 - 135   3527 ===
 136 - 137   2516 ==
 138 - 139   1833 =
 140 - 141   1327 =
 142 - 143    860
 144 - 145    604
 146 - 147    428
 148 - 149    275
 150 - 151    184
 152 - 153    111
 154 - 155     67

=cut

sub random_gauss {
  my($avg,$stddev,$num)=@_;
  $avg=0    if !defined $avg;
  $stddev=1 if !defined $stddev;
  $num=1    if !defined $num;
  croak "random_gauss should not have more than 3 arguments" if @_>3;
  my @r;
  while (@r<$num) {
    my($x1,$x2,$w);
    do {
      $x1=2.0*rand()-1.0;
      $x2=2.0*rand()-1.0;
      $w=$x1*$x1+$x2*$x2;
    } while $w>=1.0;
    $w=sqrt(-2.0*log($w)/$w) * $stddev;
    push @r,  $x1*$w + $avg,
              $x2*$w + $avg;
  }
  pop @r if @r > $num;
  return $r[0] if @_<3;
  return @r;
}

=head2 mix

Mixes an array in random order. In-place if given an array reference or not if given an array.

C could also have been named C, as in shuffling a deck of cards.

Example:

This:

 print mix("a".."z"),"\n" for 1..3;

...could write something like:

 trgoykzfqsduphlbcmxejivnwa
 qycatilmpgxbhrdezfwsovujkn
 ytogrjialbewcpvndhkxfzqsmu

B

=over 4

=item 1.
Either a reference to an array as the only input. This array will then be mixed I. The array will be changed:

This: C<< @a=mix(@a) >> is the same as:  C<< mix(\@a) >>.

=item 2.
Or an array of zero, one or more elements.

=back

Note that an input-array which COINCIDENTLY SOME TIMES has one element
(but more other times), and that element is an array-ref, you will
probably not get the expected result.

To check distribution:

 perl -MAcme::Tools -le 'print mix("a".."z") for 1..26000'|cut -c1|sort|uniq -c|sort -n

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, which is not a typo, see further down here)

Note: C is approximately four times faster. Both respects the Perl built-in C.

=cut

sub mix {
  if(@_==1 and ref($_[0]) eq 'ARRAY'){ #kun ett arg, og det er ref array
    my $r=$_[0];
    push@$r,splice(@$r,rand(@$r-$_),1) for 0..(@$r-1);
    return $r;
  }
  else{
    my@e=@_;
    push@e,splice(@e,rand(@e-$_),1) for 0..$#e;
    return @e;
  }
}

=head2 pwgen

Generates random passwords.

B 0-n args

* First arg: length of password(s), default 8

* Second arg: number of passwords, default 1

* Third arg: string containing legal chars in password, default A-Za-z0-9,-./&%_!

* Fourth to n'th arg: list of requirements for passwords, default if the third arg is false/undef (so default third arg is used) is:

 sub{/^[a-zA-Z0-9].*[a-zA-Z0-9]$/ and /[a-z]/ and /[A-Z]/ and /\d/ and /[,-.\/&%_!]/}

...meaning the password should:
* start and end with: a letter a-z (lower- or uppercase) or a digit 0-9
* should contain at least one char from each of the groups lower, upper, digit and special char

To keep the default requirement-sub but add additional ones just set the fourth arg to false/undef
and add your own requirements in the fifth arg and forward (examples below). Sub pwgen uses perls
own C internally.

C<< $Acme::Tools::Pwgen_max_sec >> and C<< $Acme::Tools::Pwgen_max_trials >> can be set to adjust for how long
pwgen tries to find a password. Defaults for those are 0.01 and 10000.
Whenever one of the two limits is reached, a first generates a croak.

Examples:

 my $pw=pwgen();             # a random 8 chars password A-Z a-z 0-9 ,-./&%!_ (8 is default length)
 my $pw=pwgen(12);           # a random 12 chars password A-Z a-z 0-9 ,-./&%!_
 my @pw=pwgen(0,10);         # 10 random 8 chars passwords, containing the same possible chars
 my @pw=pwgen(0,1000,'A-Z'); # 1000 random 8 chars passwords containing just uppercase letters from A to Z

 pwgen(3);                                # dies, defaults require chars in each of 4 group (see above)
 pwgen(5,1,'A-C0-9',  qr/^\D{3}\d{2}$/);  # a 5 char string starting with three A, B or Cs and endring with two digits
 pwgen(5,1,'ABC0-9',sub{/^\D{3}\d{2}$/}); # same as above

Examples of adding additional requirements to the default ones:

 my @pwreq = ( qr/^[A-C]/ );
 pwgen(8,1,'','',@pwreq);    # use defaults for allowed chars and the standard requirements
                             # but also demand that the password must start with A, B or C

 push @pwreq, sub{ not /[a-z]{3}/i };
 pwgen(8,1,'','',@pwreq);    # as above and in addition the password should not contain three
                             # or more consecutive letters (to avoid "offensive" words perhaps)

=cut

our $Pwgen_max_sec=0.01;     #max seconds/password before croak (for hard to find requirements)
our $Pwgen_max_trials=10000; #max trials/password  before croak (for hard to find requirements)
our $Pwgen_sec=0;            #seconds used in last call to pwgen()
our $Pwgen_trials=0;         #trials in last call to pwgen()
sub pwgendefreq{/^[a-z\d].*[a-z\d]$/i and /[a-z]/ and /[A-Z]/ and /\d/ and /[,-.\/&%_!]/}
sub pwgen {
  my($len,$num,$chars,@req)=@_;
  $len||=8;
  $num||=1;
  $chars||='A-Za-z0-9,-./&%_!';
  $req[0]||=\&pwgendefreq if !$_[2];
  $chars=~s/([$_])-([$_])/join("","$1".."$2")/eg  for ('a-z','A-Z','0-9');
  my($c,$t,@pw)=(length($chars),time_fp());
  ($Pwgen_trials,$Pwgen_sec)=(0,0);
  TRIAL:
  while(@pw<$num){
    croak "pwgen timeout after $Pwgen_trials trials"
      if ++$Pwgen_trials >= $Pwgen_max_trials
      or time_fp()-$t > $Pwgen_max_sec*$num;
    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) }
    }
    push@pw,$pw;
  }
  $Pwgen_sec=time_fp()-$t;
  return $pw[0] if $num==1;
  return @pw;
}

# =head1 veci
#
# Perls C takes 1, 2, 4, 8, 16, 32 and possibly 64 as its third argument.
#
# This limitation is removed with C (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 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 { return 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, 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;
  for(@_){ return 1 if $_ eq $val }
  return 0;
}

sub in_num {
  no warnings 'uninitialized';
  my $val=shift;
  for(@_){ return 1 if $_ == $val }
  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 >>

=cut

sub intersect {
  my %first=map{($_=>1)}@{$_[0]};
  my %seen;
  return grep{$first{$_}&&!$seen{$_}++}@{$_[1]};
}

=head2 not_intersect

Input: Two arrayrefs

Output: An array containing all elements member of just one of the input arrays (not both).

Example:

 perl -MAcme::Tools -le ' print join " ", not_intersect( ["five", 1, 2, 3.0, 4], [4, 2+1, "five"] )'

The output is C<< 1 2 >>.

=cut

sub not_intersect {
  my %code;
  my %seen;
  for(@{$_[0]}){$code{$_}|=1}
  for(@{$_[1]}){$code{$_}|=2}
  return grep{$code{$_}!=3&&!$seen{$_}++}(@{$_[0]},@{$_[1]});
}

=head2 uniq

Input:    An array of strings (or numbers)

Output:   The same array in the same order, except elements which exists earlier in the list.

Same as L but distinct sorts the returned list, I does not.

Example:

 my @t=(7,2,3,3,4,2,1,4,5,3,"x","xx","x",02,"07");
 print join " ", uniq @t;                          # prints  7 2 3 4 1 5 x xx 07

=cut

sub uniq(@) { my %seen; grep !$seen{$_}++, @_ }

=head1 HASHES

=head2 subhash

Copies a subset of keys/values from one hash to another.

B First argument is a reference to a hash. The rest of the arguments are a list of the keys of which key/value-pair you want to be copied.

B The hash consisting of the keys and values you specified.

Example:

 %population = ( Norway=>5000000, Sweden=>9500000, Finland=>5400000,
                 Denmark=>5600000, Iceland=>320000,
                 India => 1.21e9, China=>1.35e9, USA=>313e6, UK=>62e6 );

 %scandinavia = subhash( \%population , 'Norway', 'Sweden', 'Denmark' ); # this and
 %scandinavia = (Norway=>5000000,Sweden=>9500000,Denmark=>5600000);      # this is the same

 print "Population of $_ is $scandinavia{$_}\n" for keys %scandinavia;

...prints the populations of the three scandinavian countries.

Note: The values are NOT deep copied when they are references. (Use C<< Storable::dclone() >> to do that).

Note2: For perl version 5.20+ subhashes (hash slices returning keys as well as values) is built in like this:

 %scandinavia = %population{'Norway','Sweden','Denmark'};

=cut

sub subhash {
  my $hr=shift;
  my @r;
  for(@_){ push@r,($_=>$$hr{$_}) }
  return @r;
}

=head2 hashtrans

B a reference to a hash of hashes

B a hash like the input-hash, but matrix transposed (kind of). Think of it as if X and Y has swapped places.

 %h = ( 1 => {a=>33,b=>55},
        2 => {a=>11,b=>22},
        3 => {a=>88,b=>99} );
 print serialize({hashtrans(\%h)},'v');

Gives:

 %v=( 'a'=>{'1'=>'33','2'=>'11','3'=>'88'},
      'b'=>{'1'=>'55','2'=>'22','3'=>'99'} );

=cut

#Hashtrans brukes automatisk når første argument er -1 i sub hashtabell()

sub hashtrans {
  my $h=shift;
  my %new;
  for my $k (keys%$h){
    my $r=$$h{$k};
    for(keys%$r){
      $new{$_}{$k}=$$r{$_};
    }
  }
  return %new;
}

=head1 COMPRESSION

L, L, L, L, L, and L
compresses and uncompresses strings to save space in disk, memory,
database or network transfer. Trades time for space. (Beware of wormholes)

=head2 zipb64

Compresses the input (text or binary) and returns a base64-encoded string of the compressed binary data.
No known limit on input length, several MB has been tested, as long as you've got the RAM...

B One or two strings.

First argument: The string to be compressed.

Second argument is optional: A I string.

B a base64-kodet string of the compressed input.

The use of an optional I string will result in an even
further compressed output in the dictionary string is somewhat similar
to the string that is compressed (the data in the first argument).

If x relatively similar string are to be compressed, i.e. x number
automatic of email responses to some action by a user, it will pay of
to choose one of those x as a dictionary string and store it as
such. (You will also use the same dictionary string when decompressing
using L.

The returned string is base64 encoded. That is, the output is 33%
larger than it has to be.  The advantage is that this string more
easily can be stored in a database (without the hassles of CLOB/BLOB)
or perhaps easier transfer in http POST requests (it still needs some
url-encoding, normally). See L and L for the
same without base 64 encoding.

Example 1, normal compression without dictionary:

  $txt = "Test av komprimering, hva skjer? " x 10;  # ten copies of this norwegian string, $txt is now 330 bytes (or chars rather...)
  print length($txt)," bytes input!\n";             # prints 330
  $zip = zipb64($txt);                              # compresses
  print length($zip)," bytes output!\n";            # prints 65
  print $zip;                                       # prints the base64 string ("noise")

  $output=unzipb64($zip);                              # decompresses
  print "Hurra\n" if $output eq $txt;               # prints Hurra if everything went well
  print length($output),"\n";                       # prints 330

Example 2, same compression, now with dictionary:

  $txt = "Test av komprimering, hva skjer? " x 10;  # Same original string as above
  $dict = "Testing av kompresjon, hva vil skje?";   # dictionary with certain similarities
                                                    # of the text to be compressed
  $zip2 = zipb64($txt,$dict);                          # compressing with $dict as dictionary
  print length($zip2)," bytes output!\n";           # prints 49, which is less than 65 in ex. 1 above
  $output=unzipb64($zip2,$dict);                       # uses $dict in the decompressions too
  print "Hurra\n" if $output eq $txt;               # prints Hurra if everything went well


Example 3, dictionary = string to be compressed: (out of curiosity)

  $txt = "Test av komprimering, hva skjer? " x 10;  # Same original string as above
  $zip3 = zipb64($txt,$txt);                           # hmm
  print length($zip3)," bytes output!\n";           # prints 25
  print "Hurra\n" if unzipb64($zip3,$txt) eq $txt;     # hipp hipp ...

zipb64() and zipbin() is really just wrappers around L and C & co there.

=cut

sub zipb64 {
  require MIME::Base64;
  return MIME::Base64::encode_base64(zipbin(@_));
}


=head2 zipbin

C does the same as C except that zipbin()
does not base64 encode the result. Returns binary data.

See L for documentation.

=cut

sub zipbin {
  require Compress::Zlib;
  my($data,$dict)=@_;
  my $x=Compress::Zlib::deflateInit(-Dictionary=>$dict||'',-Level=>Compress::Zlib::Z_BEST_COMPRESSION()) or croak();
  my($output,$status)=$x->deflate($data); croak() if $status!=Compress::Zlib::Z_OK();
  my($out,$status2)=$x->flush(); croak() if $status2!=Compress::Zlib::Z_OK();
  return $output.$out;
}

=head2 unzipb64

Opposite of L.

Input:

First argument: A string made by L

Second argument: (optional) a dictionary string which where used in L.

Output: The original string (be it text or binary).

See L.

=cut

sub unzipb64 {
  my($data,$dict)=@_;
  require MIME::Base64;
  unzipbin(MIME::Base64::decode_base64($data),$dict);
}

=head2 unzipbin

C does the same as L except that C
wants a pure binary compressed string as input, not base64.

See L for documentation.

=cut

sub unzipbin {
  require Compress::Zlib;
  require Carp;
  my($data,$dict)=@_;
  my $x=Compress::Zlib::inflateInit(-Dictionary=>$dict||'') or croak();
  my($output,$status)=$x->inflate($data);
  croak() if $status!=Compress::Zlib::Z_STREAM_END();
  return $output;
}

=head2 gzip

B A string you want to compress. Text or binary.

B The binary compressed representation of that input string.

C is really the same as C< Compress:Zlib::memGzip() > except
that C just returns the input-string if for some reason L
could not be C. Not installed or not found.  (L is a built in module in newer perl versions).

C uses the same compression algorithm as the well known GNU program gzip found in most unix/linux/cygwin distros. Except C does this in-memory. (Both using the C-library C).

=cut

sub gzip {
  my $s=shift();
  eval{     # tries gzip, if it works it works, else returns the input
    require Compress::Zlib;
    $s=Compress::Zlib::memGzip(\$s);
  };undef$@;
  return $s;
}

=head2 gunzip

B A binary compressed string. I.e. something returned from
C earlier or read from a C<< .gz >> file.

B The original larger non-compressed string. Text or binary.

=cut

sub gunzip {
  my $s=shift();
  eval {
    require Compress::Zlib;
    $s=Compress::Zlib::memGunzip(\$s);
  };undef$@;
  return $s;
}

=head2 bzip2

See L and L.

C and C works just as  C and C,
but use another compression algorithm. This is usually better but slower
than the C-algorithm. Especially in the compression. Decompression speed is less different.

See also C, C and L

=cut

sub bzip2 {
  my $s=shift();
  eval { require Compress::Bzip2; $s=Compress::Bzip2::memBzip($s) }; undef$@;
  return $s;
}

=head2 bunzip2

Decompressed something compressed by bzip2() or the data from a C<.bz2> file. See L.

=cut

sub bunzip2 {
  my $s=shift();
  eval { require Compress::Bzip2; $s=Compress::Bzip2::memBunzip($s) }; undef$@;
  return $s;
}


=head1 NET, WEB, CGI-STUFF

=head2 ipaddr

B an IP-number

B either an IP-address I or an empty string
if the DNS lookup didn't find anything.

Example:

 perl -MAcme::Tools -le 'print ipaddr("129.240.8.200")'  # prints www.uio.no

Uses perls C internally.

C memoizes the results internally (using the
C<%Acme::Tools::IPADDR_memo> hash) so only the first loopup on a
particular IP number might take some time.

Some few DNS loopups can take several seconds.
Most is done in a fraction of a second. Due to this slowness, medium to high traffic web servers should
probably turn off hostname lookups in their logs and just log IP numbers by using
C in Apache C and then use I afterwards if necessary.

=cut

our %IPADDR_memo;
sub ipaddr {
  my $ipnr=shift;
  #NB, 2-tallet på neste kodelinje er ikke det samme på alle os,
  #men ser ut til å funke i linux og hpux. Den Riktige Måten(tm)
  #er konstanten AF_INET i Socket eller IO::Socket-pakken.
  return $IPADDR_memo{$ipnr} ||= gethostbyaddr(pack("C4",split("\\.",$ipnr)),2);
}

=head2 ipnum

C does the opposite of C

Does an attempt of converting an IP address (hostname) to an IP number.
Uses DNS name servers via perls internal C.
Return empty string (undef) if unsuccessful.

 print ipnum("www.uio.no");   # prints 129.240.13.152

Does internal memoization via the hash C<%Acme::Tools::IPNUM_memo>.

=cut

our %IPNUM_memo;
sub ipnum {
  my $ipaddr=shift;
  #croak "No $ipaddr" if !length($ipaddr);
  return $IPNUM_memo{$ipaddr} if exists $IPNUM_memo{$ipaddr};
  my $h=gethostbyname($ipaddr);
  #croak "No ipnum for $ipaddr" if !$h;
  return if !defined $h;
  my $ipnum = join(".",unpack("C4",$h));
  $IPNUM_memo{$ipaddr} = $ipnum=~/^(\d+\.){3}\d+$/ ? $ipnum : undef;
  return $IPNUM_memo{$ipaddr};
}

=head2 webparams

B (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 pairs (with the first C<=> char being the separation char).

Both C and C can be url-encoded.

If there is no input argument, C uses C<< $ENV{QUERY_STRING} >> instead.

If also  C<< $ENV{QUERY_STRING} >> is lacking, C 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
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. Or C<< $R->args() >> or C<< $R->content() >> in mod_perl.

B

C 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
/.../cgi-bin/script> and the URL
L will print
C to the web page.

L will print C.

=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 and I.
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;

Prints C<< http://machine.somewhere.com/search?q=%D8stdal%2C%20%C5ge >>

=cut

sub urlenc {
  my $str=shift;
  $str=~s/([^\w\-\.\/\,\[\]])/sprintf("%%%02x",ord($1))/eg; #more chars is probably legal...
  return $str;
}

=head2 urldec

Opposite of L.

Example, this returns 'C< ø>'. That is space and C<< ø >>.

 urldec('+%C3')

=cut

sub urldec {
  my $str=shift;
  $str=~s/\+/ /gs;
  $str=~s/%([a-f\d]{2})/pack("C", hex($1))/egi;
  return $str;
}

=head2 ht2t

C is short for I.

This sub extracts an html-C<<  >>s and returns its C<< s >> 




3528




 





 





 





 





 





 



 and C<< s >> as an array of arrayrefs. And strips away any html 




3529




 





 





 





 





 





 



 inside the C<< s >> as well. 




3530




 





 





 





 





 





 



   




3531




 





 





 





 





 





 



  my @table = ht2t($html,'some string occuring before the  you want'); 




3532




 





 





 





 





 





 



   




3533




 





 





 





 





 





 



 Input: One or two arguments. 




3534




 





 





 





 





 





 



   




3535




 





 





 





 





 





 



 First argument: the html where a C<<  >> is to be found and converted. 




3536




 





 





 





 





 





 



   




3537




 





 





 





 





 





 



 Second argument: (optional) If the html contains more than one C<< 




3538




 





 





 





 





 





 



  >>, and you do not want the first one, applying a second 




3539




 





 





 





 





 





 



 argument is a way of telling C which to capture: the one with this word 




3540




 





 





 





 





 





 



 or string occurring before it. 




3541




 





 





 





 





 





 



   




3542




 





 





 





 





 





 



 Output: An array of arrayrefs. 




3543




 





 





 





 





 





 



   




3544




 





 





 





 





 





 



 C is a quick and dirty way of scraping (or harvesting as it is 




3545




 





 





 





 





 





 



 also called) data from a web page. Look too L to do this 




3546




 





 





 





 





 





 



 more accurate. 




3547




 





 





 





 





 





 



   




3548




 





 





 





 





 





 



 Example: 




3549




 





 





 





 





 





 



   




3550




 





 





 





 





 





 



  use Acme::Tools; 




3551




 





 





 





 





 





 



  use LWP::Simple; 




3552




 





 





 





 





 





 



  my $url = "http://en.wikipedia.org/wiki/List_of_countries_by_population"; 




3553




 





 





 





 





 





 



  for( ht2t( get($url), "Countries" ) ) { 




3554




 





 





 





 





 





 



    my($rank, $country, $pop) = @$_; 




3555




 





 





 





 





 





 



    $pop =~ s/,//g; 




3556




 





 





 





 





 





 



    printf "%3d | %-32s | %9d\n", @$_ if $pop>0; 




3557




 





 





 





 





 





 



  } 




3558




 





 





 





 





 





 



   




3559




 





 





 





 





 





 



 Output: 




3560




 





 





 





 





 





 



   




3561




 





 





 





 





 





 



   1 | China                            | 1367740000 




3562




 





 





 





 





 





 



   2 | India                            | 1262090000 




3563




 





 





 





 





 





 



   3 | United States                    | 319043000 




3564




 





 





 





 





 





 



   4 | Indonesia                        | 252164800 




3565




 





 





 





 





 





 



   5 | Brazil                           | 203404000 




3566




 





 





 





 





 





 



   




3567




 





 





 





 





 





 



 ...and so on. 




3568




 





 





 





 





 





 



   




3569




 





 





 





 





 





 



 =cut 




3570




 





 





 





 





 





 



   




3571




 





 





 





 





 





 



 sub ht2t { 




3572




9




  
100
  



  
100
  



  
9
  



  
1
  




451



   my($f,$s,$r)=@_; 1>@_||@_>3 and croak; $s='' if @_==1; 




 




9




  
100
  




 





 





 





314



   




 




7





 





 





 





 





17



   




3573




7





 





 





 





 





121



   $f=~s,.*?($s).*?(




3574




28





 





 




  
28
  




 





835971



   my $e=0;$e++ while index($f,$s=chr($e))>=$[; 




 




28





 





 





 





 





13345



   




 




28





 





 





 





 





104398



   




 




7





 





 





 





 





13



   




 




7





 





 





 





 





36



   




3575




7





 





 





 





 





85



   $f=~s//\l$1$s/gsi; 




3576




7





 





 





 





 





54



   $f=~s/\s*<.*?>\s*/ /gsi; 




3577




7





 





 





 





 





66



   my @t=split("r$s",$f);shift @t; 




 




7





 





 





 





 





12



   




3578




20





 





 




  
20
  




 





32



   $r||=sub{s/&(#160|nbsp);/ /g;s/&/&/g;s/^\s*(.*?)\s*$/$1/s; 




 




20





 





 





 





 





28



   




 




20





 





 





 





 





81



   




3579




7




  
100
  



  
100
  




 





 





38



 	   s/(\d) (\d)/$1$2/g if /^[\d \.\,]+$/}; 




 




20





 





 





 





 





71



   




3580




7





 





 





 





 





16



   for(@t){my @r=split/[dh]$s/;shift@r;$_=[map{&$r;$_}@r]} 




 




9





 





 





 





 





52



   




 




9





 





 





 





 





14



   




 




9





 





 





 





 





16



   




 




20





 





 





 





 





31



   




 




20





 





 





 





 





64



   




3581




7





 





 





 





 





38



   @t; 




3582




 





 





 





 





 





 



 } 




3583




 





 





 





 





 





 



   




3584




 





 





 





 





 





 



 =head1 FILES, DIRECTORIES 




3585




 





 





 





 





 





 



   




3586




 





 





 





 





 





 



 =head2 writefile 




3587




 





 





 





 





 





 



   




3588




 





 





 





 





 





 



 Justification: 




3589




 





 





 





 





 





 



   




3590




 





 





 





 





 





 



 Perl needs three or four operations to make a file out of a string: 




3591




 





 





 





 





 





 



   




3592




 





 





 





 





 





 



  open my $FILE, '>', $filename  or die $!; 




3593




 





 





 





 





 





 



  print $FILE $text; 




3594




 





 





 





 





 





 



  close($FILE); 




3595




 





 





 





 





 





 



   




3596




 





 





 





 





 





 



 This is way simpler: 




3597




 





 





 





 





 





 



   




3598




 





 





 





 





 





 



  writefile($filename,$text); 




3599




 





 





 





 





 





 



   




3600




 





 





 





 





 





 



 Sub writefile opens the file i binary mode (C) and has two usage modes: 




3601




 





 





 





 





 





 



   




3602




 





 





 





 





 





 



 B Two arguments 




3603




 





 





 





 





 





 



   




3604




 





 





 





 





 





 



 B is the filename. If the file exists, its overwritten. 




3605




 





 





 





 





 





 



 If the file can not be opened for writing, a die (a croak really) happens. 




3606




 





 





 





 





 





 



   




3607




 





 





 





 





 





 



 B is one of: 




3608




 





 





 





 





 





 



   




3609




 





 





 





 





 





 



 =over 4 




3610




 





 





 





 





 





 



   




3611




 





 





 





 





 





 



 =item * Either a scaler. That is a normal string to be written to the file. 




3612




 





 





 





 





 





 



   




3613




 





 





 





 





 





 



 =item * Or a reference to a scalar. That referred text is written to the file. 




3614




 





 





 





 





 





 



   




3615




 





 





 





 





 





 



 =item * Or a reference to an array of scalars. This array is the written to the 




3616




 





 





 





 





 





 



  file element by element and C<< \n >> is automatically appended to each element. 




3617




 





 





 





 





 





 



   




3618




 





 





 





 





 





 



 =back 




3619




 





 





 





 





 





 



   




3620




 





 





 





 





 





 



 Alternativelly, you can write several files at once. 




3621




 





 





 





 





 





 



   




3622




 





 





 





 





 





 



 Example, this: 




3623




 





 





 





 





 





 



   




3624




 





 





 





 





 





 



  writefile('file1.txt','The text....tjo'); 




3625




 





 





 





 





 





 



  writefile('file2.txt','The text....hip'); 




3626




 





 





 





 





 





 



  writefile('file3.txt','The text....and hop'); 




3627




 





 





 





 





 





 



   




3628




 





 





 





 





 





 



 ...is the same as this: 




3629




 





 





 





 





 





 



   




3630




 





 





 





 





 





 



  writefile([ 




3631




 





 





 





 





 





 



    ['file1.txt','The text....tjo'], 




3632




 





 





 





 





 





 



    ['file2.txt','The text....hip'], 




3633




 





 





 





 





 





 



    ['file3.txt','The text....and hop'], 




3634




 





 





 





 





 





 



  ]); 




3635




 





 





 





 





 





 



   




3636




 





 





 





 





 





 



 B Nothing (for the time being). Cs (C really) if something goes wrong. 




3637




 





 





 





 





 





 



   




3638




 





 





 





 





 





 



 =cut 




3639




 





 





 





 





 





 



   




3640




 





 





 





 





 





 



 #todo: use openstr() as in readfile(), transparently gzip .gz filenames and so on 




3641




 





 





 





 





 





 



 sub writefile { 




3642




4





 





 




  
4
  



  
1
  




70151



     my($filename,$text)=@_; 




3643




4




  
 50
  




 





 





 





25



     if(ref($filename) eq 'ARRAY'){ 




3644



  
0
  




 





 





 





 





0



 	writefile(@$_) for @$filename; 




3645



  
0
  




 





 





 





 





0



 	return; 




3646




 





 





 





 





 





 



     } 




3647




4




  
 50
  



  
 33
  




 





 





306



     open(WRITEFILE,">",$filename) and binmode(WRITEFILE) or croak($!); 




3648




4




  
 50
  



  
 33
  




 





 





41



     if(!defined $text or !ref($text)){ 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




3649




4





 





 





 





 





733



 	print WRITEFILE $text; 




3650




 





 





 





 





 





 



     } 




3651




 





 





 





 





 





 



     elsif(ref($text) eq 'SCALAR'){ 




3652



  
0
  




 





 





 





 





0



 	print WRITEFILE $$text; 




3653




 





 





 





 





 





 



     } 




3654




 





 





 





 





 





 



     elsif(ref($text) eq 'ARRAY'){ 




3655



  
0
  




 





 





 





 





0



 	print WRITEFILE "$_\n" for @$text; 




3656




 





 





 





 





 





 



     } 




3657




 





 





 





 





 





 



     else { 




3658



  
0
  




 





 





 





 





0



 	croak; 




3659




 





 





 





 





 





 



     } 




3660




4





 





 





 





 





167



     close(WRITEFILE); 




3661




4





 





 





 





 





15



     return; 




3662




 





 





 





 





 





 



 } 




3663




 





 





 





 





 





 



   




3664




 





 





 





 





 





 



 =head2 readfile 




3665




 





 





 





 





 





 



   




3666




 





 





 





 





 





 



 Just as with L you can read in a whole file in one operation with C. Instead of: 




3667




 





 





 





 





 





 



   




3668




 





 





 





 





 





 



  open my $FILE,'<', $filename or die $!; 




3669




 





 





 





 





 





 



  my $data = join"",<$FILE>; 




3670




 





 





 





 





 





 



  close($FILE); 




3671




 





 





 





 





 





 



   




3672




 





 





 





 





 





 



 This is simpler: 




3673




 





 





 





 





 





 



   




3674




 





 





 





 





 





 



  my $data = readfile($filename); 




3675




 





 





 





 





 





 



   




3676




 





 





 





 





 





 



 B 




3677




 





 





 





 





 





 



   




3678




 





 





 





 





 





 



 Reading the content of the file to a scalar variable: (Any content in C<$data> will be overwritten) 




3679




 





 





 





 





 





 



   




3680




 





 





 





 





 





 



  my $data; 




3681




 





 





 





 





 





 



  readfile('filename.txt',\$data); 




3682




 





 





 





 





 





 



   




3683




 





 





 





 





 





 



 Reading the lines of a file into an array: 




3684




 





 





 





 





 





 



   




3685




 





 





 





 





 





 



  my @lines; 




3686




 





 





 





 





 





 



  readfile('filnavn.txt',\@lines); 




3687




 





 





 





 





 





 



  for(@lines){ 




3688




 





 





 





 





 





 



    ... 




3689




 





 





 





 





 





 



  } 




3690




 





 





 





 





 





 



   




3691




 





 





 





 





 





 



 Note: Chomp is done on each line. That is, any newlines (C<< \n >>) will be removed. 




3692




 





 





 





 





 





 



 If C<@lines> is non-empty, this will be lost. 




3693




 





 





 





 





 





 



   




3694




 





 





 





 





 





 



 Sub readfile is context aware. If an array is expected it returns an array of the lines without a trailing C<< \n >>. 




3695




 





 





 





 





 





 



 The last example can be rewritten: 




3696




 





 





 





 





 





 



   




3697




 





 





 





 





 





 



  for(readfile('filnavn.txt')){ 




3698




 





 





 





 





 





 



    ... 




3699




 





 





 





 





 





 



  } 




3700




 





 





 





 





 





 



   




3701




 





 





 





 





 





 



 With two input arguments, nothing (undef) is returned from C. 




3702




 





 





 





 





 





 



   




3703




 





 





 





 





 





 



 =cut 




3704




 





 





 





 





 





 



   




3705




 





 





 





 





 





 



 #http://blogs.perl.org/users/leon_timmermans/2013/05/why-you-dont-need-fileslurp.html 




3706




 





 





 





 





 





 



 #todo: readfile with grep-filter code ref in a third arg (avoid reading all into mem) 




3707




 





 





 





 





 





 



   




3708




 





 





 





 





 





 



 sub readfile { 




3709




12





 





 




  
12
  



  
1
  




11518



   my($filename,$ref)=@_; 




3710




12




  
100
  




 





 





 





59



   if(@_==1){ 




3711




6




  
100
  




 





 





 





22



     if(wantarray){ my @data; readfile($filename,\@data); return @data } 




 




1





 





 





 





 





3



   




 




1





 





 





 





 





5



   




 




1





 





 





 





 





4976



   




3712




5





 





 





 





 





8



     else         { my $data; readfile($filename,\$data); return $data } 




 




5





 





 





 





 





457



   




 




5





 





 





 





 





698



   




3713




 





 





 





 





 





 



   } 




3714




 





 





 





 





 





 



   else { 




3715




6




  
 50
  




 





 





 





46



     open my $fh,openstr($filename) or croak("ERROR: readfile $! $?"); 




3716




6




  
100
  




 





 





 





30



     if   ( ref($ref) eq 'SCALAR') { $$ref=join"",<$fh> } 




 




5




  
 50
  




 





 





 





6899



   




3717




1





 





 





 





 





18



     elsif( ref($ref) eq 'ARRAY' ) { while(my $l=<$fh>){ chomp($l); push @$ref, $l } } 




 




20003





 





 





 





 





20569



   




 




20003





 





 





 





 





54199



   




3718



  
0
  




 





 





 





 





0



     else { croak "ERROR: Second arg to readfile should be a ref to a scalar og array" } 




3719




6





 





 





 





 





1166



     close($fh); 




3720




6





 





 





 





 





38



     return;#? 




3721




 





 





 





 





 





 



   } 




3722




 





 





 





 





 





 



 } 




3723




 





 





 





 





 





 



   




3724




 





 





 





 





 





 



 =head2 readdirectory 




3725




 





 





 





 





 





 



   




3726




 





 





 





 





 





 



 B 




3727




 





 





 





 





 





 



   




3728




 





 





 





 





 





 



 Name of a directory. 




3729




 





 





 





 





 





 



   




3730




 





 





 





 





 





 



 B 




3731




 





 





 





 





 





 



   




3732




 





 





 





 





 





 



 A list of all files in it, except of  C<.> and C<..>  (on linux/unix systems, all directories have a C<.> and C<..> directory). 




3733




 





 





 





 





 





 



   




3734




 





 





 





 





 





 



 The names of all types of files are returned: normal files, directories, symbolic links, 




3735




 





 





 





 





 





 



 pipes, semaphores. That is every thing shown by C except C<.> and C<..> 




3736




 





 





 





 





 





 



   




3737




 





 





 





 





 





 



 C do not recurce down into subdirectories (but see example below). 




3738




 





 





 





 





 





 



   




3739




 





 





 





 





 





 



 B 




3740




 





 





 





 





 





 



   




3741




 





 





 





 





 





 



   my @files = readdirectory("/tmp"); 




3742




 





 





 





 





 





 



   




3743




 





 





 





 





 





 



 B 




3744




 





 





 





 





 





 



   




3745




 





 





 





 





 





 



 Sometimes calling the built ins C, C and C seems a tad tedious, since this: 




3746




 





 





 





 





 





 



   




3747




 





 





 





 





 





 



  my $dir="/usr/bin"; 




3748




 





 





 





 





 





 



  opendir(D,$dir); 




3749




 





 





 





 





 





 



  my @files=map "$dir/$_", grep {!/^\.\.?$/} readdir(D); 




3750




 





 





 





 





 





 



  closedir(D); 




3751




 





 





 





 





 





 



   




3752




 





 





 





 





 





 



 Is the same as this: 




3753




 





 





 





 





 





 



   




3754




 





 





 





 





 





 



  my @files=readdirectory("/usr/bin"); 




3755




 





 





 





 





 





 



   




3756




 





 





 





 





 





 



 See also: L 




3757




 





 





 





 





 





 



   




3758




 





 





 





 





 





 



 B 




3759




 





 





 





 





 





 



   




3760




 





 





 





 





 





 



 On huge directories with perhaps tens or houndreds of thousands of 




3761




 





 





 





 





 





 



 files, readdirectory() will consume more memory than perls 




3762




 





 





 





 





 





 



 opendir/readdir. This isn't usually a concern anymore for modern 




3763




 





 





 





 





 





 



 computers with gigabytes of RAM, but might be the rationale behind 




3764




 





 





 





 





 





 



 Perls more tedious way created in the 80s.  The same argument goes for 




3765




 





 





 





 





 





 



 file slurping. On the other side it's also a good practice to never 




3766




 





 





 





 





 





 



 assume to much on available memory and the number of files if you 




3767




 





 





 





 





 





 



 don't know for certain that enough memory is available whereever your 




3768




 





 





 





 





 





 



 code is run or that the size of the directory is limited. 




3769




 





 





 





 





 





 



   




3770




 





 





 





 





 





 



 B 




3771




 





 





 





 





 





 



   




3772




 





 





 





 





 





 



 How to get all files in the C directory including all subdirectories below of any depth: 




3773




 





 





 





 





 





 



   




3774




 





 





 





 





 





 



  my @files=("/tmp"); 




3775




 





 





 





 





 





 



  map {-d $_ and unshift @files,$_ or push @files,$_} readdirectory(shift(@files)) while -d $files[0]; 




3776




 





 





 





 





 





 



   




3777




 





 





 





 





 





 



 ...or to avoid symlinks and only get real files: 




3778




 





 





 





 





 





 



   




3779




 





 





 





 





 





 



  map {-d and !-l and unshift @files,$_ or -f and !-l and push @files,$_} readdirectory(shift(@files)) while -d $files[0]; 




3780




 





 





 





 





 





 



   




3781




 





 





 





 





 





 



 =cut 




3782




 





 





 





 





 





 



   




3783




 





 





 





 





 





 



 sub readdirectory { 




3784



  
0
  




 





 




  
0
  



  
1
  




0



   my $dir=shift; 




3785



  
0
  




 





 





 





 





0



   opendir(my $D,$dir); 




3786



  
0
  




 





 





 





 





0



   my @filer=map "$dir/$_", grep {!/^\.\.?$/} readdir($D); 




 



  
0
  




 





 





 





 





0



   




3787



  
0
  




 





 





 





 





0



   closedir($D); 




3788



  
0
  




 





 





 





 





0



   return @filer; 




3789




 





 





 





 





 





 



 } 




3790




 





 





 





 





 





 



   




3791




 





 





 





 





 





 



 =head2 basename 




3792




 





 





 





 





 





 



   




3793




 





 





 





 





 





 



 The basename and dirname functions behaves like the *nix shell commands with the same names. 




3794




 





 





 





 





 





 



   




3795




 





 





 





 





 





 



 B One or two arguments: Filename and an optional suffix 




3796




 





 





 





 





 





 



   




3797




 





 





 





 





 





 



 B Returns the filename with any directory and (if given) the suffix removed. 




3798




 





 





 





 





 





 



   




3799




 





 





 





 





 





 



  basename('/usr/bin/perl')                   # returns 'perl' 




3800




 





 





 





 





 





 



  basename('/usr/local/bin/report.pl','.pl')  # returns 'report' since .pl at the end is removed 




3801




 





 





 





 





 





 



  basename('report2.pl','.pl')                # returns 'report2' 




3802




 





 





 





 





 





 



  basename('report2.pl','.\w+')               # returns 'report2.pl', probably not what you meant 




3803




 





 





 





 





 





 



  basename('report2.pl',qr/.\w+/)             # returns 'report2', use qr for regex 




3804




 





 





 





 





 





 



   




3805




 





 





 





 





 





 



 =head2 dirname 




3806




 





 





 





 





 





 



   




3807




 





 





 





 





 





 



 B A filename including path 




3808




 





 





 





 





 





 



   




3809




 





 





 





 





 





 



 B Removes the filename path and returns just the directory path up until but not including 




3810




 





 





 





 





 





 



 the last /. Return just a one char C<< . >> (period string) if there is no directory in the input. 




3811




 





 





 





 





 





 



   




3812




 





 





 





 





 





 



  dirname('/usr/bin/perl')                    # returns '/usr/bin' 




3813




 





 





 





 





 





 



  dirname('perl')                             # returns '.' 




3814




 





 





 





 





 





 



   




3815




 





 





 





 





 





 



 =head2 username 




3816




 





 





 





 





 





 



   




3817




 





 





 





 





 





 



 Returns the current linux/unix username, for example the string root 




3818




 





 





 





 





 





 



   




3819




 





 





 





 





 





 



  print username();                        #just (getpwuid($<))[0] but more readable perhaps 




3820




 





 





 





 





 





 



   




3821




 





 





 





 





 





 



 =cut 




3822




 





 





 





 





 





 



   




3823




8




  
100
  




 




  
8
  



  
1
  




3286



 sub basename { my($f,$s)=(@_,'');$s=quotemeta($s)if!ref($s);$f=~m,^(.*/)?([^/]*?)($s)?$,;$2 } 




 




8





 





 





 





 





25



   




 




8





 





 





 





 





226



   




 




8





 





 





 





 





38



   




3824




2




  
100
  



  
 66
  



  
2
  



  
1
  




438



 sub dirname  { $_[0]=~m,^(.*)/,;defined($1) && length($1) ? $1 : '.' } 




 




2





 





 





 





 





23



   




3825



  
0
  




 





 




  
0
  



  
1
  




0



 sub username { (getpwuid($<))[0] } 




3826




 





 





 





 





 





 



   




3827




 





 





 





 





 





 



 =head2 wipe 




3828




 





 





 





 





 





 



   




3829




 





 





 





 





 





 



 Deletes a file by "wiping" it on the disk. Overwrites the file before deleting. (May not work properly on SSDs) 




3830




 





 





 





 





 





 



   




3831




 





 





 





 





 





 



 B 




3832




 





 





 





 





 





 



 * Arg 1: A filename 




3833




 





 





 





 





 





 



 * Optional arg 2: number of times to overwrite file. Default is 3 if omitted, 0 or undef 




3834




 





 





 





 





 





 



 * Optional arg 3: keep (true/false), wipe() but no delete of file 




3835




 





 





 





 





 





 



   




3836




 





 





 





 





 





 



 B Same as the C (remove file): 1 for success, 0 or false for failure. 




3837




 





 





 





 





 





 



   




3838




 





 





 





 





 





 



 See also: L, L 




3839




 





 





 





 





 





 



   




3840




 





 





 





 





 





 



 =cut 




3841




 





 





 





 





 





 



   




3842




 





 





 





 





 





 



 sub wipe { 




3843




2





 





 




  
2
  



  
1
  




704



   my($file,$times,$keep)=@_; 




3844




2





 




  
100
  




 





 





14



   $times||=3; 




3845




2




  
 50
  



  
 33
  




 





 





82



   croak "ERROR: File $file nonexisting\n" if not -f $file or not -e $file; 




3846




2





 





 





 





 





28



   my $size=-s$file; 




3847




2




  
 50
  




 





 





 





78



   open my $WIFH, '+<', $file or croak "ERROR: Unable to open $file: $!\n"; 




3848




2





 





 





 





 





5



   binmode($WIFH); 




3849




2





 





 





 





 





8



   for(1..$times){ 




3850




4





 





 





 





 





16



     my $block=chr(int(rand(256))) x 1024;#hm 




3851




4





 





 





 





 





10



     for(0..($size/1024)){ 




3852




73





 





 





 





 





521



       seek($WIFH,$_*1024,0); 




3853




73





 





 





 





 





142



       print $WIFH $block; 




3854




 





 





 





 





 





 



     } 




3855




 





 





 





 





 





 



   } 




3856




2





 





 





 





 





30



   close($WIFH); 




3857




2




  
100
  




 





 





 





141



   $keep || unlink($file); 




3858




 





 





 





 





 





 



 } 




3859




 





 





 





 





 





 



   




3860




 





 





 





 





 





 



 =head2 chall 




3861




 





 





 





 





 





 



   




3862




 





 





 





 





 





 



 Does chmod + utime + chown on one or more files. 




3863




 





 





 





 





 





 



   




3864




 





 





 





 





 





 



 Returns the number of files of which those operations was successful. 




3865




 





 





 





 





 





 



   




3866




 





 





 





 





 





 



 Mode, uid, gid, atime and mtime are set from the array ref in the first argument. 




3867




 





 





 





 





 





 



   




3868




 





 





 





 





 





 



 The first argument references an array which is exactly like an array returned from perls internal C -function. 




3869




 





 





 





 





 





 



   




3870




 





 





 





 





 





 



 Example: 




3871




 





 





 





 





 





 



   




3872




 





 





 





 





 





 



  my @stat=stat($filenameA); 




3873




 





 





 





 





 





 



  chall( \@stat,       $filenameB, $filenameC, ... );  # by stat-array 




3874




 





 





 





 





 





 



  chall( $filenameA,   $filenameB, $filenameC, ... );  # by file name 




3875




 





 





 





 





 





 



   




3876




 





 





 





 





 





 



 Copies the chmod, owner, group, access time and modify time from file A to file B and C. 




3877




 





 





 





 





 





 



   




3878




 





 





 





 





 





 



 See C, C, C, C 




3879




 





 





 





 





 





 



   




3880




 





 





 





 





 





 



 =cut 




3881




 





 





 





 





 





 



   




3882




 





 





 





 





 





 



   




3883




 





 





 





 





 





 



 sub chall { 




3884




 





 





 





 





 





 



   my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks ) 




3885




1




  
 50
  




 




  
1
  



  
1
  




28244



     = ref($_[0]) ? @{shift()} : stat(shift()); 




 




1





 





 





 





 





4



   




3886




1





 





 





 





 





2



   my $successful=0; 




3887




1




  
 50
  



  
 33
  




 





 





4



   for(@_){ chmod($mode,$_) && utime($atime,$mtime,$_) && chown($uid,$gid,$_) && $successful++ } 




 




1





 




  
 33
  




 





 





73



   




3888




1





 





 





 





 





3



   return $successful; 




3889




 





 





 





 





 





 



 } 




3890




 





 





 





 





 





 



   




3891




 





 





 





 





 





 



 =head2 makedir 




3892




 





 





 





 





 





 



   




3893




 





 





 





 





 





 



 Input: One or two arguments. 




3894




 





 





 





 





 





 



   




3895




 





 





 





 





 





 



 Works like perls C except that C will create nesessary parent directories if they dont exists. 




3896




 





 





 





 





 





 



   




3897




 





 





 





 





 





 



 First input argument: A directory name (absolute, starting with C< / > or relative). 




3898




 





 





 





 





 





 



   




3899




 





 





 





 





 





 



 Second input argument: (optional) permission bits. Using the normal C<< 0777^umask() >> as the default if no second input argument is provided. 




3900




 





 





 





 





 





 



   




3901




 





 





 





 





 





 



 Example: 




3902




 





 





 





 





 





 



   




3903




 





 





 





 





 





 



  makedir("dirB/dirC") 




3904




 





 





 





 





 





 



   




3905




 





 





 





 





 





 



 ...will create directory C if it does not already exists, to be able to create C inside C. 




3906




 





 





 





 





 





 



   




3907




 





 





 





 





 





 



 Returns true on success, otherwise false. 




3908




 





 





 





 





 





 



   




3909




 





 





 





 





 





 



 C memoizes directories it has checked for existence before (trading memory and for speed). 




3910




 





 





 





 





 





 



 Thus directories removed during running the script is not discovered by makedir. 




3911




 





 





 





 





 





 



   




3912




 





 





 





 





 





 



 See also C<< perldoc -f mkdir >>, C<< man umask >> 




3913




 





 





 





 





 





 



   




3914




 





 





 





 





 





 



 =cut 




3915




 





 





 





 





 





 



   




3916




 





 





 





 





 





 



 our %MAKEDIR; 




3917




 





 





 





 





 





 



   




3918




 





 





 





 





 





 



 sub makedir { 




3919



  
0
  




 





 




  
0
  



  
1
  




0



   my($d,$p,$dd)=@_; 




3920



  
0
  



  
  0
  




 





 





 





0



   $p=0777^umask() if !defined$p; 




3921




 





 





 





 





 





 



   ( 




3922




 





 





 





 





 





 



   $MAKEDIR{$d} or -d$d or mkdir($d,$p) #or croak("mkdir $d, $p") 




3923




 





 





 





 





 





 



   or ($dd)=($d=~m,^(.+)/+([^/]+)$,) and makedir($dd,$p) and mkdir($d,$p) #or die; 




3924



  
0
  



  
  0
  



  
  0
  




 





 





0



   ) and ++$MAKEDIR{$d}; 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




3925




 





 





 





 





 





 



 } 




3926




 





 





 





 





 





 



   




3927




 





 





 





 





 





 



 =head2 md5sum 




3928




 





 





 





 





 





 



   




3929




 





 





 





 





 





 



 B a filename. 




3930




 





 





 





 





 





 



   




3931




 





 





 





 





 





 



 B a string of 32 hexadecimal chars from 0-9 or a-f. 




3932




 





 





 





 





 





 



   




3933




 





 





 





 





 





 



 Example, the md5sum gnu/linux command without options could be implementet like this: 




3934




 





 





 





 





 





 



   




3935




 





 





 





 





 





 



  use Acme::Tools; 




3936




 





 





 





 





 





 



  print eval{ md5sum($_)."  $_\n" } || $@ for @ARGV; 




3937




 





 





 





 





 





 



   




3938




 





 





 





 





 





 



 This sub requires L, which is a core perl-module since 




3939




 





 





 





 





 





 



 version 5.?.?  It does not slurp the files or spawn new processes. 




3940




 





 





 





 





 





 



   




3941




 





 





 





 





 





 



 =cut 




3942




 





 





 





 





 





 



   




3943




 





 





 





 





 





 



 sub md5sum { 




3944




2





 





 




  
2
  



  
1
  




18



   require Digest::MD5; 




3945




2





 





 





 





 





4



   my $fn=shift; 




3946




2




  
100
  




 





 





 





212



   croak "md5sum: $fn is a directory (no md5sum)" if -d $fn; 




3947




1




  
 50
  




 





 





 





34



   open my $FH, '<', $fn or croak "Could not open file $fn for md5sum() $!"; 




3948




1





 





 





 





 





2



   binmode($FH); 




3949




1





 





 





 





 





3



   my $r = eval { Digest::MD5->new->addfile($FH)->hexdigest }; 




 




1





 





 





 





 





19



   




3950




1




  
 50
  




 





 





 





8



   croak "md5sum on $fn failed ($@)\n" if $@; 




3951




1





 





 





 





 





16



   $r; 




3952




 





 





 





 





 





 



 } 




3953




 





 





 





 





 





 



   




3954




 





 





 





 





 





 



 =head2 read_conf 




3955




 





 





 





 





 





 



   




3956




 





 





 





 





 





 



 B A file name or a reference to a string with settings in the format described below. 




3957




 





 





 





 





 





 



   




3958




 





 





 





 





 





 



 B A reference to a hash. This hash will have the settings from the file (or stringref). 




3959




 





 





 





 





 





 



 The hash do not have to be empty beforehand. 




3960




 





 





 





 





 





 



   




3961




 





 





 





 





 





 



 Returns a hash with the settings as in this examples: 




3962




 





 





 





 





 





 



   




3963




 





 





 





 





 





 



  my %conf = read_conf('/etc/your/thing.conf'); 




3964




 





 





 





 





 





 



  print $conf{sectionA}{knobble};  #prints ABC if the file is as shown below 




3965




 





 





 





 





 





 



  print $conf{sectionA}{gobble};   #prints ZZZ, the last gobble 




3966




 





 





 





 





 





 



  print $conf{switch};             #prints OK here as well, unsectioned value 




3967




 





 





 





 





 





 



  print $conf{part2}{password};    #prints oh:no= x 




3968




 





 





 





 





 





 



   




3969




 





 





 





 





 





 



 File use for the above example: 




3970




 





 





 





 





 





 



   




3971




 





 





 





 





 





 



  switch:    OK       #before first section, the '' (empty) section 




3972




 





 





 





 





 





 



  [sectionA] 




3973




 





 





 





 





 





 



  knobble:   ABC 




3974




 





 





 





 





 





 



  gobble:    XYZ      #this gobble is overwritten by the gobble on the next line 




3975




 





 





 





 





 





 



  gobble:    ZZZ 




3976




 





 





 





 





 





 



  [part2] 




3977




 





 





 





 





 





 



  password:  oh:no= x  #should be better 




3978




 





 





 





 





 





 



  text:      { values starting with { continues 




3979




 





 





 





 





 





 



               until reaching a line with } 




3980




 





 





 





 





 





 



   




3981




 





 





 





 





 





 



 Everything from # and behind is regarded comments and ignored. Comments can be on any line. 




3982




 





 





 





 





 





 



 To keep a # char, put a \ in front of it. 




3983




 





 





 





 





 





 



   




3984




 





 





 





 





 





 



 A C< : > or C< = > separates keys and values.  Spaces at the beginning or end of lines are 




3985




 





 





 





 





 





 



 ignored (after removal of #comments), as are any spaces before and after : and = separators. 




3986




 





 





 





 





 





 



   




3987




 





 





 





 





 





 



 Empty lines or lines with no C< : > or C< = > is also ignored. Keys and values can contain 




3988




 





 





 





 





 





 



 internal spaces and tabs, but not at the beginning or end. 




3989




 





 





 





 





 





 



   




3990




 





 





 





 





 





 



 Multi-line values must start and end with { and }. Using { and } keep spaces at the start 




3991




 





 





 





 





 





 



 or end in both one-line and multi-line values. 




3992




 





 





 





 





 





 



   




3993




 





 





 





 





 





 



 Sections are marked with C<< [sectionname] >>.  Section names, keys and values is case 




3994




 





 





 





 





 





 



 sensitive. C above the first section or below and empty C<< [] >> is placed 




3995




 





 





 





 





 





 



 both in the empty section in the returned hash and as top level key/values. 




3996




 





 





 





 





 





 



   




3997




 





 





 





 





 





 



 C can be a simpler alternative to the core module L which has 




3998




 





 





 





 





 





 



 its own hassles. 




3999




 





 





 





 





 





 



   




4000




 





 





 





 





 





 



  $Acme::Tools::Read_conf_empty_section=1;        #default 0 (was 1 in version 0.16) 




4001




 





 





 





 





 





 



  my %conf = read_conf('/etc/your/thing.conf'); 




4002




 





 





 





 





 





 



  print $conf{''}{switch};                        #prints OK with the file above 




4003




 





 





 





 





 





 



  print $conf{switch};                            #prints OK here as well 




4004




 





 





 





 





 





 



   




4005




 





 





 





 





 





 



 =cut 




4006




 





 





 





 





 





 



   




4007




 





 





 





 





 





 



 our $Read_conf_empty_section=0; 




4008




 





 





 





 





 





 



 sub read_conf { 




4009




3





 





 




  
3
  



  
1
  




18



   my($fn,$hr)=(@_,{}); 




4010




3




  
100
  




 





 





 





14



   my $conf=ref($fn)?$$fn:readfile($fn); 




4011




3





 





 





 





 





101



   $conf=~s,\s*(?




4012




3





 





 





 





 





32



   my($section,@l)=('',split"\n",$conf); 




4013




3





 





 





 





 





12



   while(@l) { 




4014




63





 





 





 





 





93



     my $l=shift@l; 




4015




63




  
100
  




 





 





 





330



     if( $l=~/^\s*\[\s*(.*?)\s*\]/ ) { 




 




 




  
100
  




 





 





 





 



   




4016




12





 





 





 





 





22



       $section=$1; 




4017




12





 




  
100
  




 





 





68



       $$hr{$1}||={}; 




4018




 





 





 





 





 





 



     } 




4019




 





 





 





 





 





 



     elsif( $l=~/^\s*([^\:\=]+)[:=]\s*(.*?)\s*$/ ) { 




4020




33





 




  
 66
  



  
33
  




 





108



       my $ml=sub{my$v=shift;$v.="\n".shift@l while $v=~/^\{[^\}]*$/&&@l;$v=~s/^\{(.*)\}\s*$/$1/s;$v=~s,\\#,#,g;$v}; 




 




33





 





 





 





 





71



   




 




33





 





 





 





 





168



   




 




33





 





 





 





 





68



   




 




33





 





 





 





 





52



   




 




33





 





 





 





 





60



   




4021




33





 





 





 





 





71



       my $v=&$ml($2); 




4022




33




  
100
  



  
 66
  




 





 





145



       $$hr{$section}{$1}=$v if length($section) or $Read_conf_empty_section; 




4023




33




  
100
  




 





 





 





175



       $$hr{$1}=$v if !length($section); 




4024




 





 





 





 





 





 



     } 




4025




 





 





 





 





 





 



   } 




4026




3





 





 





 





 





25



   %$hr; 




4027




 





 





 





 





 





 



 } 




4028




 





 





 





 





 





 



 #  my $incfn=sub{return $1 if $_[0]=~m,^(/.+),;my$f=$fn;$f=~s,[^/]+$,$_[0],;$f}; 




4029




 





 





 





 





 





 



 #    s,]+)>,"".readfile(&$incfn($1)),eg; #todo 




4030




 





 





 





 





 





 



   




4031




 





 





 





 





 





 



   




4032




 





 





 





 





 





 



 =head2 openstr 




4033




 





 





 





 





 





 



   




4034




 





 





 





 





 





 



                                             # returned from openstr: 




4035




 





 





 





 





 





 



   open my $FH, openstr("fil.txt")  or die;  # fil.txt 




4036




 





 





 





 





 





 



   open my $FH, openstr("fil.gz")   or die;  # zcat fil.gz | 




4037




 





 





 





 





 





 



   open my $FH, openstr("fil.bz2")  or die;  # bzcat fil.bz2 | 




4038




 





 





 





 





 





 



   open my $FH, openstr("fil.xz")   or die;  # xzcat fil.xz | 




4039




 





 





 





 





 





 



   open my $FH, openstr(">fil.txt") or die;  # > fil.txt 




4040




 





 





 





 





 





 



   open my $FH, openstr(">fil.gz")  or die;  # | gzip > fil.gz 




4041




 





 





 





 





 





 



   open my $FH, openstr(">fil.bz2") or die;  # | bzip2 > fil.bz2 




4042




 





 





 





 





 





 



   open my $FH, openstr(">fil.xz")  or die;  # | xz    > fil.bz2 




4043




 





 





 





 





 





 



   




4044




 





 





 





 





 





 



 Environment variable PATH is used. So in the examples above, /bin/gzip 




4045




 





 





 





 





 





 



 is returned instead of gzip if /bin is the first directory in 




4046




 





 





 





 





 





 



 $ENV{PATH} containing an executable file gzip. Dirs /usr/bin, /bin and 




4047




 





 





 





 





 





 



 /usr/local/bin is added to PATH in openstr(). They are checked even if 




4048




 





 





 





 





 





 



 PATH is empty. 




4049




 





 





 





 





 





 



   




4050




 





 





 





 





 





 



 =cut 




4051




 





 





 





 





 





 



   




4052




 





 





 





 





 





 



 our @Openstrpath=(grep$_,split(":",$ENV{PATH}),qw(/usr/bin /bin /usr/local/bin)); 




4053




 





 





 





 





 





 



 sub openstr { 




4054




14





 





 




  
14
  



  
1
  




4221



   my($fn,$ext)=(shift()=~/^(.*?(?:\.(t?gz|bz2|xz))?)$/i); 




4055




14




  
100
  




 





 





 





389



   return $fn if !$ext; 




4056




6




  
 50
  




 




  
6
  




 





42



   my $prog=sub{@Openstrpath or return $_[0];(grep -x$_, map "$_/$_[0]", @Openstrpath)[0] or die}; 




 




6




  
 50
  




 





 





 





26



   




 




6





 





 





 





 





108929



   




4057




 





 





 





 





 





 



   $fn =~ /^\s*>/ 




4058




 





 





 





 





 





 



       ?  "| ".(&$prog({qw/tgz gzip gz gzip bz2 bzip2 xz xz/   }->{lc($ext)})).$fn 




4059




6




  
100
  




 





 





 





89



       :        &$prog({qw/tgz zcat gz zcat bz2 bzcat xz xzcat/}->{lc($ext)})." $fn |"; 




4060




 





 





 





 





 





 



 } 




4061




 





 





 





 





 





 



   




4062




 





 





 





 





 





 



 =head1 TIME FUNCTIONS 




4063




 





 





 





 





 





 



   




4064




 





 





 





 





 





 



 =head2 tms - timestring, works somewhat like the Gnu/Linux C command and Oracle's C 




4065




 





 





 





 





 





 



   




4066




 





 





 





 





 





 



 Converts timestamps to more readable forms of time strings. 




4067




 





 





 





 





 





 



   




4068




 





 





 





 





 





 



 Converts seconds since I and time strings on the form C to other forms. 




4069




 





 





 





 





 





 



   




4070




 





 





 





 





 





 



 B One, two or three arguments. 




4071




 





 





 





 





 





 



   




4072




 





 





 





 





 





 



 B A format string. 




4073




 





 





 





 





 





 



   




4074




 





 





 





 





 





 



 B An epock C number or a time 




4075




 





 





 





 





 





 



 string of the form YYYYMMDD-HH24:MI:SS or YYYYMMDDTHH:MI:SS or 




4076




 





 





 





 





 





 



 YYYY-MM-DDTHH:MI:SS (in which T is litteral and HH is the 24-hour 




4077




 





 





 





 





 





 



 version of hours) or YYYYMMDD. Uses the current C if the 




4078




 





 





 





 





 





 



 second argument is missing. 




4079




 





 





 





 





 





 



   




4080




 





 





 





 





 





 



 TODO: Formats with % as in C (C<%Y%m%d> and so on) 




4081




 





 





 





 





 





 



   




4082




 





 





 





 





 





 



 B True or false. If true and first argument 




4083




 





 





 





 





 





 



 is eight digits: Its interpreted as a date like YYYYMMDD time string, 




4084




 





 





 





 





 





 



 not an epoch time.  If true and first argument is six digits its 




4085




 





 





 





 





 





 



 interpreted as a date like DDMMYY (not YYMMDD!). 




4086




 





 





 





 





 





 



   




4087




 





 





 





 





 





 



 B a date or clock string on the wanted form. 




4088




 





 





 





 





 





 



   




4089




 





 





 





 





 





 



 B 




4090




 





 





 





 





 





 



   




4091




 





 





 





 





 





 



 Prints C<< 3. july 1997 >> if thats the dato today: 




4092




 





 





 





 





 





 



   




4093




 





 





 





 





 





 



   perl -MAcme::Tools -le 'print timestr("D. month YYYY")' 




4094




 





 





 





 





 





 



   




4095




 





 





 





 





 





 



   print tms("HH24:MI");              # prints 23:55 if thats the time now 




4096




 





 





 





 





 





 



   tms("HH24:MI",time());             # ...same,since time() is the default 




4097




 





 





 





 





 





 



   tms("HH:MI",time()-5*60);          # 23:50 if that was the time 5 minutes ago 




4098




 





 





 





 





 





 



   tms("HH:MI",time()-5*60*60);       # 18:55 if thats the time 5 hours ago 




4099




 





 





 





 





 





 



   tms("Day Month Dth YYYY HH:MI");   # Saturday July 1st 2004 23:55    (big S, big J) 




4100




 





 





 





 





 





 



   tms("Day D. Month YYYY HH:MI");    # Saturday 8. July 2004 23:55     (big S, big J) 




4101




 





 





 





 





 





 



   tms("DAY D. MONTH YYYY HH:MI");    # SATURDAY 8. JULY 2004 23:55     (upper) 




4102




 





 





 





 





 





 



   tms("dy D. month YYYY HH:MI");     # sat 8. july 2004 23:55          (small s, small j) 




4103




 





 





 





 





 





 



   tms("Dy DD. MON YYYY HH12:MI am"); # Sat 08. JUL 2004 11:55 pm       (HH12, am becomes pm if after 12) 




4104




 





 





 





 





 





 



   tms("DD-MON-YYYY");                # 03-MAY-2004                     (mon, english) 




4105




 





 





 





 





 





 



   




4106




 





 





 





 





 





 



 The following list of codes in the first argument will be replaced: 




4107




 





 





 





 





 





 



   




4108




 





 





 





 





 





 



   YYYY    Year, four digits 




4109




 





 





 





 





 





 



   YY      Year, two digits, i.e. 04 instead of 2004 




4110




 





 





 





 





 





 



   yyyy    Year, four digits, but nothing if its the current year 




4111




 





 





 





 





 





 



   YYYY|HH:MI  Year if its another year than the current, a time in hours and minutes elsewise 




4112




 





 





 





 





 





 



   MM      Month, two digits. I.e. 08 for August 




4113




 





 





 





 





 





 



   DD      Day of month, two digits. I.e. 01 (not 1) for the first day in a month 




4114




 





 





 





 





 





 



   D       Day of month, one digit. I.e. 1 (not 01) 




4115




 





 





 





 





 





 



   HH      Hour. From 00 to 23. 




4116




 





 





 





 





 





 



   HH24    Same as HH. 




4117




 





 





 





 





 





 



   HH12    12 becomes 12 (never 00), 13 becomes 01, 14 02 and so on. 




4118




 





 





 





 





 





 



           Note: 00 after midnight becomes 12 (am). Tip: always include the code 




4119




 





 





 





 





 





 



           am in a format string that uses HH12. 




4120




 





 





 





 





 





 



   MI      Minutt. Fra 00 til 59. 




4121




 





 





 





 





 





 



   SS      Sekund. Fra 00 til 59. 




4122




 





 





 





 





 





 



   am      Becomes am or pm 




4123




 





 





 





 





 





 



   pm      Same 




4124




 





 





 





 





 





 



   AM      Becomes AM or PM (upper case) 




4125




 





 





 





 





 





 



   PM      Same 




4126




 





 





 





 





 





 



   




4127




 





 





 





 





 





 



   Month   The full name of the month in English from January to December 




4128




 





 





 





 





 





 



   MONTH   Same in upper case (JANUARY) 




4129




 





 





 





 





 





 



   month   Same in lower case (january) 




4130




 





 





 





 





 





 



   Mont    Jan Feb Mars Apr May June July Aug Sep Oct Nov Dec 




4131




 





 





 





 





 





 



   Mont.   Jan. Feb. Mars Apr. May June July Aug. Sep. Oct. Nov. Dec. (always four chars) 




4132




 





 





 





 





 





 



   Mon     Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec            (always three chars) 




4133




 





 





 





 





 





 



   




4134




 





 





 





 





 





 



   Day     The full name of the weekday. Sunday to Saturday 




4135




 





 





 





 





 





 



   Dy      Three letters: Sun Mon Tue Wed Thu Fri Sat 




4136




 





 





 





 





 





 



   DAY     Upper case 




4137




 





 





 





 





 





 



   DY      Upper case 




4138




 





 





 





 





 





 



   Dth     1st 2nd 3rd 4th 5th ... 11th 12th ... 20th 21st 22nd 23rd 24th ... 30th 31st 




4139




 





 





 





 





 





 



   




4140




 





 





 





 





 





 



   WW      Week number of the year 01-53 according to the ISO8601-definition (which most countries uses) 




4141




 





 





 





 





 





 



   WWUS    Week number of the year 01-53 according to the most used definition in the USA. 




4142




 





 





 





 





 





 



           Other definitions also exists. 




4143




 





 





 





 





 





 



   




4144




 





 





 





 





 





 



   epoch   Converts a time string from YYYYMMDD-HH24:MI:SS, YYYYMMDD-HH24:MI:SS, YYYYMMDDTHH:MI:SS, 




4145




 





 





 





 





 





 



           YYYY-MM-DDTHH:MI:SS or YYYYMMDD to the number of seconds since January 1st 1970. 




4146




 





 





 





 





 





 



           Commonly known as the Unix epoch. 




4147




 





 





 





 





 





 



   




4148




 





 





 





 





 





 



   JDN     Julian day number. Integer. The number of days since the day starting at noon on January 1 4713 BC 




4149




 





 





 





 





 





 



   JD      Same as JDN but a float accounting for the time of day 




4150




 





 





 





 





 





 



   




4151




 





 





 





 





 





 



 TODO:  sub smt() (tms backward... or something better named, converts the other way) 




4152




 





 





 





 





 





 



        As to_date and to_char in Oracle. Se maybe L instead 




4153




 





 





 





 





 





 



   




4154




 





 





 





 





 





 



 B (optional) Is_date. False|true, default false. If true, the second argument is 




4155




 





 





 





 





 





 



 interpreted as a date of the form YYYYMMDD, not as a number of seconds since epoch (January 1st 1970). 




4156




 





 





 





 





 





 



   




4157




 





 





 





 





 





 



 =cut 




4158




 





 





 





 





 





 



   




4159




 





 





 





 





 





 



 #Se også L og L 




4160




 





 





 





 





 





 



   




4161




 





 





 





 





 





 



 our $Tms_pattern; 




4162




 





 





 





 





 





 



 our %Tms_str= 




4163




 





 





 





 





 





 



 	  ('MÅNED' => [4, 'JANUAR','FEBRUAR','MARS','APRIL','MAI','JUNI','JULI', 




4164




 





 





 





 





 





 



 		          'AUGUST','SEPTEMBER','OKTOBER','NOVEMBER','DESEMBER' ], 




4165




 





 





 





 





 





 



 	   'Måned' => [4, 'Januar','Februar','Mars','April','Mai','Juni','Juli', 




4166




 





 





 





 





 





 



 		          'August','September','Oktober','November','Desember'], 




4167




 





 





 





 





 





 



 	   'måned' => [4, 'januar','februar','mars','april','mai','juni','juli', 




4168




 





 





 





 





 





 



 		          'august','september','oktober','november','desember'], 




4169




 





 





 





 





 





 



 	   'MÅNE.' => [4, 'JAN.','FEB.','MARS','APR.','MAI','JUNI','JULI','AUG.','SEP.','OKT.','NOV.','DES.'], 




4170




 





 





 





 





 





 



 	   'Måne.' => [4, 'Jan.','Feb.','Mars','Apr.','Mai','Juni','Juli','Aug.','Sep.','Okt.','Nov.','Des.'], 




4171




 





 





 





 





 





 



 	   'måne.' => [4, 'jan.','feb.','mars','apr.','mai','juni','juli','aug.','sep.','okt.','nov.','des.'], 




4172




 





 





 





 





 





 



 	   'MÅNE'  => [4, 'JAN','FEB','MARS','APR','MAI','JUNI','JULI','AUG','SEP','OKT','NOV','DES'], 




4173




 





 





 





 





 





 



 	   'Måne'  => [4, 'Jan','Feb','Mars','Apr','Mai','Juni','Juli','Aug','Sep','Okt','Nov','Des'], 




4174




 





 





 





 





 





 



 	   'måne'  => [4, 'jan','feb','mars','apr','mai','juni','juli','aug','sep','okt','nov','des'], 




4175




 





 





 





 





 





 



 	   'MÅN'   => [4, 'JAN','FEB','MAR','APR','MAI','JUN','JUL','AUG','SEP','OKT','NOV','DES'], 




4176




 





 





 





 





 





 



 	   'Mån'   => [4, 'Jan','Feb','Mar','Apr','Mai','Jun','Jul','Aug','Sep','Okt','Nov','Des'], 




4177




 





 





 





 





 





 



 	   'mån'   => [4, 'jan','feb','mar','apr','mai','jun','jul','aug','sep','okt','nov','des'], 




4178




 





 





 





 





 





 



 	   'MONTH' => [4, 'JANUARY','FEBRUARY','MARCH','APRIL','MAY','JUNE','JULY', 




4179




 





 





 





 





 





 



 		          'AUGUST','SEPTEMBER','OCTOBER','NOVEMBER','DECEMBER'], 




4180




 





 





 





 





 





 



 	   'Month' => [4, 'January','February','March','April','May','June','July', 




4181




 





 





 





 





 





 



 		          'August','September','October','November','December'], 




4182




 





 





 





 





 





 



 	   'month' => [4, 'january','february','march','april','may','june','july', 




4183




 





 





 





 





 





 



 		          'august','september','october','november','december'], 




4184




 





 





 





 





 





 



 	   'MONT.' => [4, 'JAN.','FEB.','MAR.','APR.','MAY','JUNE','JULY','AUG.','SEP.','OCT.','NOV.','DEC.'], 




4185




 





 





 





 





 





 



 	   'Mont.' => [4, 'Jan.','Feb.','Mar.','Apr.','May','June','July','Aug.','Sep.','Oct.','Nov.','Dec.'], 




4186




 





 





 





 





 





 



 	   'mont.' => [4, 'jan.','feb.','mar.','apr.','may','june','july','aug.','sep.','oct.','nov.','dec.'], 




4187




 





 





 





 





 





 



 	   'MONT'  => [4, 'JAN','FEB','MAR','APR','MAY','JUNE','JULY','AUG','SEP','OCT','NOV','DEC'], 




4188




 





 





 





 





 





 



 	   'Mont'  => [4, 'Jan','Feb','Mar','Apr','May','June','July','Aug','Sep','Oct','Nov','Dec'], 




4189




 





 





 





 





 





 



 	   'mont'  => [4, 'jan','feb','mar','apr','may','june','july','aug','sep','oct','nov','dec'], 




4190




 





 





 





 





 





 



 	   'MON'   => [4, 'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'], 




4191




 





 





 





 





 





 



 	   'Mon'   => [4, 'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'], 




4192




 





 





 





 





 





 



 	   'mon'   => [4, 'jan','feb','mar','apr','may','jun','jul','aug','sep','oct','nov','dec'], 




4193




 





 





 





 





 





 



 	   'DAY'   => [6, 'SUNDAY','MONDAY','TUESDAY','WEDNESDAY','THURSDAY','FRIDAY','SATURDAY'], 




4194




 





 





 





 





 





 



 	   'Day'   => [6, 'Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'], 




4195




 





 





 





 





 





 



 	   'day'   => [6, 'sunday','monday','tuesday','wednesday','thursday','friday','saturday'], 




4196




 





 





 





 





 





 



 	   'DY'    => [6, 'SUN','MON','TUE','WED','THU','FRI','SAT'], 




4197




 





 





 





 





 





 



 	   'Dy'    => [6, 'Sun','Mon','Tue','Wed','Thu','Fri','Sat'], 




4198




 





 





 





 





 





 



 	   'dy'    => [6, 'sun','mon','tue','wed','thu','fri','sat'], 




4199




 





 





 





 





 





 



 	   'DAG'   => [6, 'SØNDAG','MANDAG','TIRSDAG','ONSDAG','TORSDAG','FREDAG','LØRDAG'], 




4200




 





 





 





 





 





 



 	   'Dag'   => [6, 'Søndag','Mandag','Tirsdag','Onsdag','Torsdag','Fredag','Lørdag'], 




4201




 





 





 





 





 





 



 	   'dag'   => [6, 'søndag','mandag','tirsdag','onsdag','torsdag','fredag','lørdag'], 




4202




 





 





 





 





 





 



 	   'DG'    => [6, 'SØN','MAN','TIR','ONS','TOR','FRE','LØR'], 




4203




 





 





 





 





 





 



 	   'Dg'    => [6, 'Søn','Man','Tir','Ons','Tor','Fre','Lør'], 




4204




 





 





 





 





 





 



 	   'dg'    => [6, 'søn','man','tir','ons','tor','fre','lør'], 




4205




 





 





 





 





 





 



 	   ); 




4206




 





 





 





 





 





 



 my $_tms_inited=0; 




4207




 





 





 





 





 





 



 sub tms_init { 




4208




1




  
 50
  




 




  
1
  



  
0
  




7



   return if $_tms_inited++; 




4209




1





 





 





 





 





5



   for(qw(MAANED Maaned maaned MAAN Maan maan),'MAANE.','Maane.','maane.'){ 




4210




9





 





 





 





 





36



     $Tms_str{$_}=$Tms_str{replace($_,"aa","å","AA","Å")}; 




4211




 





 





 





 





 





 



   } 




4212




45





 





 





 





 





121



   $Tms_pattern=join("|",map{quotemeta($_)} 




4213




1





 





 





 





 





23



 			       sort{length($b)<=>length($a)} 




 




197





 





 





 





 





402



   




4214




 





 





 





 





 





 



 			       keys %Tms_str); 




4215




 





 





 





 





 





 



   #uten sort kan "måned" bli "mared", fordi "mån"=>"mar" 




4216




 





 





 





 





 





 



 } 




4217




 





 





 





 





 





 



   




4218




 





 





 




  
0
  



  
0
  




 



 sub totime { 




4219




 





 





 





 





 





 



   




4220




 





 





 





 





 





 



 } 




4221




 





 





 





 





 





 



   




4222




 





 





 





 





 





 



 sub date_ok { 




4223



  
0
  




 





 




  
0
  



  
0
  




0



   my($y,$m,$d)=@_; 




4224



  
0
  



  
  0
  



  
  0
  




 





 





0



   return date_ok($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/; 




4225



  
0
  



  
  0
  




 





 





 





0



   return 0 if $y!~/^\d\d\d\d$/; 




4226



  
0
  



  
  0
  



  
  0
  




 





 





0



   return 0 if $m<1||$m>12||$d<1||$d>(31,$y%4||$y%100==0&&$y%400?28:29,31,30,31,30,31,31,30,31,30,31)[$m-1]; 




 




 




  
  0
  



  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




4227



  
0
  




 





 





 





 





0



   return 1; 




4228




 





 





 





 





 





 



 } 




4229




 





 





 





 





 





 



   




4230




 





 





 





 





 





 



 sub weeknum { 




4231



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



   return weeknum(tms('YYYYMMDD')) if @_<1; 




4232



  
0
  



  
  0
  



  
  0
  




 





 





0



   return weeknum($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/; 




4233



  
0
  




 





 





 





 





0



   my($year,$month,$day)= @_; 




4234



  
0
  




 





 





 





 





0



   eval{ 




4235



  
0
  



  
  0
  




 





 





 





0



     if(@_<2){ 




 




 




  
  0
  




 





 





 





 



   




4236



  
0
  



  
  0
  




 





 





 





0



       if($year=~/^\d{8}$/) { ($year,$month,$day)=unpack("A4A2A2",$year) } 




 



  
0
  



  
  0
  




 





 





 





0



   




4237



  
0
  




 





 





 





 





0



       elsif($year>99999999){ ($year,$month,$day)=(localtime($year))[5,4,3]; $year+=1900; $month++ } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




4238



  
0
  




 





 





 





 





0



       else {die} 




4239




 





 





 





 





 





 



     } 




4240



  
0
  




 





 





 





 





0



     elsif(@_!=3){croak} 




4241



  
0
  



  
  0
  




 





 





 





0



     croak if !date_ok(sprintf("%04d%02d%02d",$year,$month,$day)); 




4242




 





 





 





 





 





 



   }; 




4243



  
0
  



  
  0
  




 





 





 





0



   croak "ERROR: Wrong args Acme::Tools::weeknum(".join(",",@_).")" if $@; 




4244




28





 





 




  
28
  




 





23013



   use integer;#heltallsdivisjon 




 




28





 





 





 





 





303



   




 




28





 





 





 





 





158



   




4245



  
0
  




 





 





 





 





0



   my $y=$year+4800-(14-$month)/12; 




4246



  
0
  




 





 





 





 





0



   my $j=$day+(153*($month+(14-$month)/12*12-3)+2)/5+365*$y+$y/4-$y/100+$y/400-32045; 




4247



  
0
  




 





 





 





 





0



   my $d=($j+31741-$j%7)%146097%36524%1461; 




4248



  
0
  




 





 





 





 





0



   return (($d-$d/1460)%365+$d/1460)/7+1; 




4249




 





 





 





 





 





 



 } 




4250




 





 





 





 





 





 



   




4251




 





 





 





 





 





 



 sub tms { 




4252




40




  
 50
  



  
 66
  



  
40
  



  
1
  




56004



   return undef if @_>1 and not defined $_[1]; #time=undef => undef 




4253




40




  
100
  




 





 





 





107



   if(@_==1){ 




4254




2





 





 





 





 





15



     my @lt=localtime(); 




4255




2




  
 50
  




 





 





 





13



     $_[0] eq 'YYYY'     and return 1900+$lt[5]; 




4256




2




  
 50
  




 





 





 





9



     $_[0] eq 'YYYYMMDD' and return sprintf("%04d%02d%02d",1900+$lt[5],1+$lt[4],$lt[3]);  




4257




2




  
100
  



  
 66
  




 





 





56



     $_[0] =~ $Re_isnum  and @lt=localtime($_[0]) and return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]);  




4258




 





 





 





 





 





 



   } 




4259




39





 





 





 





 





72



   my($format,$time,$is_date)=@_; 




4260




39




  
100
  




 





 





 





96



   $time=time_fp() if !defined$time; 




4261




39




  
100
  



  
100
  




 





 





326



   ($time,$format)=($format,$time) if @_>=2 and $format=~/^[\d+\:\-\.]+$/; #swap /hm/ 




4262




39





 





 





 





 





203



   my @lt=localtime($time); 




4263




 





 





 





 





 





 



   #todo? $is_date=0 if $time=~s/^\@(\-?\d)/$1/; #@n where n is sec since epoch makes it clear that its not a formatted, as in `date` 




4264




 





 





 





 





 





 



   #todo? date --date='TZ="America/Los_Angeles" 09:00 next Fri' #`info date` 




4265




 





 





 





 





 





 



   #      Fri Nov 13 18:00:00 CET 2015 




4266




 





 





 





 





 





 



   #date --date="next Friday"  #--date or -d 




4267




 





 





 





 





 





 



   #date --date="last friday" 




4268




 





 





 





 





 





 



   #date --date="2 days ago" 




4269




 





 





 





 





 





 



   #date --date="yesterday" #or tomorrow 




4270




 





 





 





 





 





 



   #date --date="-1 day"  #date --date='10 week' 




4271




 





 





 





 





 





 



   




4272




39




  
 50
  




 





 





 





102



   if( $is_date ){ 




4273



  
0
  



  
  0
  




 




  
0
  




 





0



     my $yy2c=sub{10+$_[0]>$lt[5]%100?"20":"19"}; #hm 10+ 




 



  
0
  




 





 





 





 





0



   




4274



  
0
  



  
  0
  




 





 





 





0



     $time=totime(&$yy2c($1)."$1$2$3")."000000" if $time=~/^(\d\d)(\d\d)(\d\d)$/; 




4275



  
0
  



  
  0
  




 





 





 





0



     $time=totime("$1$2${3}000000")             if $time=~/^((?:18|19|20)\d\d)(\d\d)(\d\d)$/; #hm 18-20? 




4276




 





 





 





 





 





 



   } 




4277




 





 





 





 





 





 



   else { 




4278




39




  
 50
  




 





 





 





141



     $time = yyyymmddhh24miss_time("$1$2$3$4$5$6") #yyyymmddhh24miss_time ??? 




4279




 





 





 





 





 





 



       if $time=~/^((?:19|20|18)\d\d)          #yyyy 




4280




 





 





 





 





 





 



                   (0[1-9]|1[012])             #mm 




4281




 





 





 





 





 





 



                   (0[1-9]|[12]\d|3[01]) \-?   #dd 




4282




 





 





 





 





 





 



                   ([01]\d|2[0-3])       \:?   #hh24 




4283




 





 





 





 





 





 



                   ([0-5]\d)             \:?   #mi 




4284




 





 





 





 





 





 



                   ([0-5]\d)             $/x;  #ss 




4285




 





 





 





 





 





 



   } 




4286




39




  
100
  




 





 





 





78



   tms_init() if !$_tms_inited; 




4287




39




  
100
  




 





 





 





108



   return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]) if !$format; 




4288




38





 





 





 





 





463



   my %p=('%'=>'%', 




4289




 





 





 





 





 





 



 	 a=>'Dy', 




4290




 





 





 





 





 





 



 	 A=>'Day', 




4291




 





 





 





 





 





 



 	 b=>'Mon', 




4292




 





 





 





 





 





 



 	 b=>'Month', 




4293




 





 





 





 





 





 



 	 c=>'Dy Mon D HH:MI:SS YYYY', 




4294




 





 





 





 





 





 



 	 C=>'CC', 




4295




 





 





 





 





 





 



 	 d=>'DD', 




4296




 





 





 





 





 





 



 	 D=>'MM/DD/YY', 




4297




 





 





 





 





 





 



 	 e=>'D', 




4298




 





 





 





 





 





 



 	 F=>'YYYY-MM-DD', 




4299




 





 





 





 





 





 



         #G=>'',  




4300




 





 





 





 





 





 



 	 h=>'Month', H=>'HH24', I=>'HH12', 




4301




 





 





 





 





 





 



 	 j=>'DoY', #day of year 




4302




 





 





 





 





 





 



 	 k=>'H24', _H=>'H24', 




4303




 





 





 





 





 





 



 	 l=>'H12', _I=>'H12', 




4304




 





 





 





 





 





 



 	 m=>'MM', M=>'MI', 




4305




 





 





 





 





 





 



 	 n=>"\n", 




4306




 





 





 





 





 





 



 	#N=>'NS', #sprintf%09d,1e9*(time_fp()-time()) #000000000..999999999 




4307




 





 





 





 





 





 



 	 p=>'AM', #AM|PM upper (yes, opposite: date +%H%M%S%P%p) 




4308




 





 





 





 





 





 



 	 P=>'am', #am|pm lower 




4309




 





 





 





 





 





 



 	 S=>'SS', 




4310




 





 





 





 





 





 



 	 t=>"\t", 




4311




 





 





 





 





 





 



 	 T=>'HH24:MI:SS', 




4312




 





 





 





 





 





 



 	 u=>'DoW',  #day of week 1..7, 1=mon 7=sun 




4313




 





 





 





 





 





 



 	 w=>'DoW0', #day of week 0..6, 1=mon 0=sun 




4314




 





 





 





 





 





 



 	#U=>'WoYs', #week num of year 00..53, sunday as first day of week 




4315




 





 





 





 





 





 



 	#V=>'UKE',  #ISO week num of year 01..53, monday as first day of week 




4316




 





 





 





 





 





 



 	#W=>'WoYm', #week num of year 00..53, monday as first day of week, not ISO! 




4317




 





 





 





 





 





 



 	#x=>$ENV{locale's date representation}, #e.g. MM/DD/YY 




4318




 





 





 





 





 





 



 	#X=>$ENV{locale's time representation}, #e.g. HH/MI/SS 




4319




 





 





 





 





 





 



 	 y=>'YY', 




4320




 





 





 





 





 





 



 	 Y=>'YYYY', 




4321




 





 





 





 





 





 



 	#z=>'TZHHMI', #time zone hour minute e.g. -0430 




4322




 





 





 





 





 





 



 	#':z'=>'TZHH:MI', 




4323




 





 





 





 





 





 



 	#'::z'=>'TZHH:MI:SS', 




4324




 





 





 





 





 





 



 	#':::z'=>'TZ', #number of :'s necessary precision, e.g. -02 or +03:30 




4325




 





 





 





 





 





 



 	#Z=>'TZN', #e.g. CET, EDT, ... 




4326




 





 





 





 





 





 



       ); 




4327




38





 





 





 





 





260



   my $pkeys=join"|",keys%p; 




4328




38





 





 





 





 





1641



   $format=~s,\%($pkeys),$p{$1},g; 




4329




38





 





 





 





 





459



   $format=~s/($Tms_pattern)/$Tms_str{$1}[1+$lt[$Tms_str{$1}[0]]]/g; 




4330




38





 





 





 





 





92



   $format=~s/YYYY              / 1900+$lt[5]                    /gxe; 




 




13





 





 





 





 





44



   




4331




38




  
  0
  




 





 





 





70



   $format=~s/(\s?)yyyy         / $lt[5]==(localtime)[5]?"":$1.(1900+$lt[5])/gxe; 




 



  
0
  




 





 





 





 





0



   




4332




38





 





 





 





 





65



   $format=~s/YY                / sprintf("%02d",$lt[5]%100)     /gxei; 




 




1





 





 





 





 





5



   




4333




38





 





 





 





 





67



   $format=~s|CC                | sprintf("%02d",(1900+$lt[5])/100) |gxei; 




 




2





 





 





 





 





10



   




4334




38





 





 





 





 





59



   $format=~s/MM                / sprintf("%02d",$lt[4]+1)       /gxe; 




 




5





 





 





 





 





25



   




4335




38





 





 





 





 





56



   $format=~s/mm                / sprintf("%d",$lt[4]+1)         /gxe; 




 



  
0
  




 





 





 





 





0



   




4336




38





 





 





 





 





57



   $format=~s,M/                ,               ($lt[4]+1).'/'   ,gxe; 




 




2





 





 





 





 





7



   




4337




38





 





 





 





 





52



   $format=~s,/M                ,           '/'.($lt[4]+1)       ,gxe; 




 




1





 





 





 





 





4



   




4338




38





 





 





 





 





62



   $format=~s/DD                / sprintf("%02d",$lt[3])         /gxe; 




 




6





 





 





 





 





25



   




4339




38





 





 





 





 





110



   $format=~s/d0w|dow0          / $lt[6]                         /gxei; 




 




4





 





 





 





 





11



   




4340




38




  
100
  




 





 





 





67



   $format=~s/dow               / $lt[6]?$lt[6]:7                /gxei; 




 




2





 





 





 





 





8



   




4341




38





 





 





 





 





81



   $format=~s/d0y|doy0          / $lt[7]                         /gxei; #0-364 (365 leap) 




 




2





 





 





 





 





7



   




4342




38





 





 





 





 





117



   $format=~s/doy               / $lt[7]+1                       /gxei; #1-365 (366 leap) 




 




1





 





 





 





 





4



   




4343




38





 





 





 





 





98



   $format=~s/D(?![AaGgYyEeNn]) / $lt[3]                         /gxe; #EN pga desember og wednesday 




 




5





 





 





 





 





15



   




4344




38





 





 





 





 





55



   $format=~s/dd                / sprintf("%d",$lt[3])           /gxe; 




 



  
0
  




 





 





 





 





0



   




4345




38




  
100
  



  
 50
  




 





 





88



   $format=~s/hh12|HH12         / sprintf("%02d",$lt[2]<13?$lt[2]||12:$lt[2]-12)/gxe; 




 




8





 





 





 





 





51



   




4346




38





 





 





 





 





86



   $format=~s/HH24|HH24|HH|hh   / sprintf("%02d",$lt[2])         /gxe; 




 




4





 





 





 





 





22



   




4347




38





 





 





 





 





77



   $format=~s/MI                / sprintf("%02d",$lt[1])         /gxei; 




 




12





 





 





 





 





42



   




4348




38





 




  
100
  




 





 





68



   $format=~s{SS\.([1-9])      }{ sprintf("%0*.$1f",3+$1,$lt[0]+(repl($time,qr/^[^\.]+/)||0)) }gxei; 




 




3





 





 





 





 





21



   




4349




38





 





 





 





 





64



   $format=~s/SS                / sprintf("%02d",$lt[0])         /gxei; 




 




4





 





 





 





 





16



   




4350




38




  
100
  




 





 





 





77



   $format=~s/am|pm             / $lt[2]<13 ? 'am' : 'pm'        /gxe; 




 




4





 





 





 





 





14



   




4351




38




  
100
  




 





 





 





75



   $format=~s/AM|PM             / $lt[2]<13 ? 'AM' : 'PM'        /gxe; 




 




4





 





 





 





 





13



   




4352




38





 





 





 





 





107



   $format=~s/WWI|WW            / sprintf("%02d",weeknum($time)) /gxei; 




 



  
0
  




 





 





 





 





0



   




4353




38





 





 





 





 





60



   $format=~s/W                 / weeknum($time)                 /gxei; 




 



  
0
  




 





 





 





 





0



   




4354




38





 





 





 





 





323



   $format; 




4355




 





 





 





 





 





 



 } 




4356




 





 





 





 





 





 



   




4357




 





 





 





 





 





 



 =head2 easter 




4358




 





 





 





 





 





 



   




4359




 





 





 





 





 





 



 Input: A year (a four digit number) 




4360




 





 





 





 





 





 



   




4361




 





 





 





 





 





 



 Output: array of two numbers: day and month of Easter Sunday that year. Month 3 means March and 4 means April. 




4362




 





 





 





 





 





 



   




4363




 





 





 





 





 





 



  sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30; 




4364




 





 





 





 





 





 



              (($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) } 




4365




 





 





 





 





 





 



   




4366




 





 





 





 





 





 



 ...is a "golfed" version of Oudins algorithm (1940) L 




4367




 





 





 





 





 





 



 (see also http://www.smart.net/~mmontes/ec-cal.html ) 




4368




 





 





 





 





 





 



   




4369




 





 





 





 





 





 



 Valid for any Gregorian year. Dates repeat themselves after 70499183 




4370




 





 





 





 





 





 



 lunations = 2081882250 days = ca 5699845 years. However, our planet will 




4371




 





 





 





 





 





 



 by then have a different rotation and spin time... 




4372




 





 





 





 





 





 



   




4373




 





 





 





 





 





 



 Example: 




4374




 





 





 





 





 





 



   




4375




 





 





 





 





 





 



  ( $day, $month ) = easter( 2012 ); # $day == 8 and $month == 4 




4376




 





 





 





 





 





 



   




4377




 





 





 





 





 





 



 Example 2: 




4378




 





 





 





 





 





 



   




4379




 





 





 





 





 





 



  my @e=map sprintf("%02d%02d", reverse(easter($_))), 1800..300000; 




4380




 





 





 





 





 





 



  print "First: ".min(@e)." Last: ".max(@e)."\n"; # First: 0322 Last: 0425 




4381




 





 





 





 





 





 



   




4382




 





 





 





 





 





 



 =cut 




4383




 





 





 





 





 





 



   




4384




28





 





 




  
28
  



  
1
  




53963



 sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30; 




 




28





 





 




  
5000
  




 





52



   




 




28





 





 





 





 





124



   




 




5000





 





 





 





 





11620



   




 




5000





 





 





 





 





6188



   




 




5000





 





 





 





 





8536



   




4385




5000




  
100
  



  
 66
  




 





 





24827



              (($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) } 




4386




 





 





 





 





 





 



   




4387




 





 





 





 





 





 



   




4388




 





 





 





 





 





 



 =head2 time_fp 




4389




 





 





 





 





 





 



   




4390




 





 





 





 





 





 



 No input arguments. 




4391




 





 





 





 





 





 



   




4392




 





 





 





 





 





 



 Return the same number as perls C except with decimals (fractions of a second, _fp as in floating point number). 




4393




 





 





 





 





 





 



   




4394




 





 





 





 





 





 



  print time_fp(),"\n"; 




4395




 





 





 





 





 





 



  print time(),"\n"; 




4396




 





 





 





 





 





 



   




4397




 





 





 





 





 





 



 Could write: 




4398




 





 





 





 





 





 



   




4399




 





 





 





 





 





 



  1116776232.38632 




4400




 





 





 





 





 





 



   




4401




 





 





 





 





 





 



 ...if that is the time now. 




4402




 





 





 





 





 





 



   




4403




 





 





 





 





 





 



 Or just: 




4404




 





 





 





 





 





 



   




4405




 





 





 





 





 





 



  1116776232 




4406




 





 





 





 





 





 



   




4407




 





 





 





 





 





 



 ...from perl's internal C if C isn't installed and available. 




4408




 





 





 





 





 





 



   




4409




 





 





 





 





 





 



   




4410




 





 





 





 





 





 



 =cut 




4411




 





 





 





 





 





 



   




4412




 





 





 





 





 





 



 sub time_fp {  # {return 0+gettimeofday} is just as well? 




4413




12416




  
 50
  




 




  
12416
  



  
1
  




19116



     eval{ require Time::HiRes } or return time(); 




 




12416





 





 





 





 





75841



   




4414




12416





 





 





 





 





47644



     my($sec,$mic)=Time::HiRes::gettimeofday(); 




4415




12416





 





 





 





 





53145



     return $sec+$mic/1e6; #1e6 not portable? 




4416




 





 





 





 





 





 



 } 




4417




 





 





 





 





 





 



   




4418




 





 





 





 





 





 



 =head2 sleep_fp 




4419




 





 





 





 





 





 



   




4420




 





 





 





 





 





 



 sleep_fp() work as the built in C<< sleep() >> but also accepts fractional seconds: 




4421




 





 





 





 





 





 



   




4422




 





 





 





 





 





 



  sleep_fp(0.020);  # sleeps for 20 milliseconds 




4423




 





 





 





 





 





 



   




4424




 





 





 





 





 





 



 Sub sleep_fp do a C, thus it might take some 




4425




 





 





 





 





 





 



 extra time the first call. To avoid that, add C<< use Time::HiRes >> 




4426




 





 





 





 





 





 



 to your code. Sleep_fp should not be trusted for accuracy to more than 




4427




 





 





 





 





 





 



 a tenth of a second. Virtual machines tend to be less accurate (sleep 




4428




 





 





 





 





 





 



 longer) than physical ones. This was tested on VMware and RHEL 




4429




 





 





 





 





 





 



 (Linux). See also L. 




4430




 





 





 





 





 





 



   




4431




 





 





 





 





 





 



 =head2 sleeps 




4432




 





 





 





 





 





 



   




4433




 





 





 





 





 





 



 =head2 sleepms 




4434




 





 





 





 





 





 



   




4435




 





 





 





 





 





 



 =head2 sleepus 




4436




 





 





 





 





 





 



   




4437




 





 





 





 





 





 



 =head2 sleepns 




4438




 





 





 





 





 





 



   




4439




 





 





 





 





 





 



  sleep_fp(0.020);   #sleeps for 20 milliseconds 




4440




 





 





 





 





 





 



  sleeps(0.020);     #sleeps for 20 milliseconds, sleeps() is a synonym to sleep_fp() 




4441




 





 





 





 





 





 



  sleepms(20);       #sleeps for 20 milliseconds 




4442




 





 





 





 





 





 



  sleepus(20000);    #sleeps for 20000 microseconds = 20 milliseconds 




4443




 





 





 





 





 





 



  sleepns(20000000); #sleeps for 20 million nanoseconds = 20 milliseconds 




4444




 





 





 





 





 





 



   




4445




 





 





 





 





 





 



 =cut 




4446




 





 





 





 





 





 



   




4447




13




  
 50
  




 




  
13
  



  
1
  




81



 sub sleep_fp { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) } 




 




13





 





 





 





 





156



   




 




13





 





 





 





 





221802



   




4448




1




  
 50
  




 




  
1
  



  
1
  




12



 sub sleeps   { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) } 




 




1





 





 





 





 





14



   




 




1





 





 





 





 





10162



   




4449




1




  
 50
  




 




  
1
  



  
1
  




18



 sub sleepms  { eval{require Time::HiRes} or (sleep(shift()/1e3),return);Time::HiRes::sleep(shift()/1e3) } 




 




1





 





 





 





 





24



   




 




1





 





 





 





 





10168



   




4450




1




  
 50
  




 




  
1
  



  
1
  




14



 sub sleepus  { eval{require Time::HiRes} or (sleep(shift()/1e6),return);Time::HiRes::sleep(shift()/1e6) } 




 




1





 





 





 





 





21



   




 




1





 





 





 





 





10158



   




4451




1




  
 50
  




 




  
1
  



  
1
  




13



 sub sleepns  { eval{require Time::HiRes} or (sleep(shift()/1e9),return);Time::HiRes::sleep(shift()/1e9) } 




 




1





 





 





 





 





19



   




 




1





 





 





 





 





10140



   




4452




 





 





 





 





 





 



   




4453




 





 





 





 





 





 



 =head2 eta 




4454




 





 





 





 





 





 



   




4455




 





 





 





 





 





 



 Estimated time of arrival (ETA). 




4456




 





 





 





 





 





 



   




4457




 





 





 





 





 





 



  for(@files){ 




4458




 





 





 





 





 





 



     ...do work on file... 




4459




 





 





 





 





 





 



     my $eta = eta( ++$i, 0+@files ); # file now, number of files 




4460




 





 





 





 





 





 



     print "" . localtime($eta); 




4461




 





 





 





 





 





 



  } 




4462




 





 





 





 





 





 



   




4463




 





 





 





 





 





 



  ..DOC MISSING.. 




4464




 





 





 





 





 





 



   




4465




 





 





 





 





 





 



 =head2 etahhmm 




4466




 





 





 





 





 





 



   




4467




 





 





 





 





 





 



  ...NOT YET 




4468




 





 





 





 





 





 



   




4469




 





 





 





 





 





 



 =cut 




4470




 





 





 





 





 





 



   




4471




 





 





 





 





 





 



 #http://en.wikipedia.org/wiki/Kalman_filter god idé? 




4472




 





 





 





 





 





 



 our %Eta; 




4473




 





 





 





 





 





 



 our $Eta_forgetfulness=2; 




4474




 





 





 





 





 





 



 sub eta { 




4475




2004




  
100
  




 




  
2004
  



  
1
  




15296



   my($id,$pos,$end,$time_fp)=( @_==2 ? (join(";",caller()),@_) : @_ ); 




4476




2004





 




  
 66
  




 





 





4544



   $time_fp||=time_fp(); 




4477




2004





 




  
100
  




 





 





4853



   my $a=$Eta{$id}||=[]; 




4478




2004





 





 





 





 





4265



   push @$a, [$pos,$time_fp]; 




4479




2004




  
100
  




 





 





 





5365



   @$a=@$a[map$_*2,0..@$a/2] if @$a>40;  #hm 40 




4480




2004




  
100
  



  
100
  




 





 





9090



   splice(@$a,-2,1) if @$a>1 and $$a[-2][0]==$$a[-1][0]; #same pos as last 




4481




2004




  
100
  




 





 





 





4117



   return undef if @$a<2; 




4482




2001





 





 





 





 





2410



   my @eta; 




4483




2001





 





 





 





 





3755



   for(2..@$a){ 




4484




58602





 





 





 





 





158569



     push @eta, $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-$_][1])/($$a[-1][0]-$$a[-$_][0]); 




4485




 





 





 





 





 





 



   } 




4486




2001





 





 





 





 





2940



   my($sum,$sumw,$w)=(0,0,1); 




4487




2001





 





 





 





 





3107



   for(@eta){ 




4488




58602





 





 





 





 





74926



     $sum+=$w*$_; 




4489




58602





 





 





 





 





70451



     $sumw+=$w; 




4490




58602





 





 





 





 





83675



     $w/=$Eta_forgetfulness; 




4491




 





 





 





 





 





 



   } 




4492




2001





 





 





 





 





2729



   my $avg=$sum/$sumw; 




4493




2001





 





 





 





 





6189



   return $avg; 




4494




 





 





 





 





 





 



 #  return avg(@eta); 




4495




 





 





 





 





 





 



  #return $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-2][1])/($$a[-1][0]-$$a[-2][0]); 




4496



  
0
  




 





 





 





 





0



   1; 




4497




 





 





 





 





 





 



 } 




4498




 





 





 





 





 





 



   




4499




 





 





 





 





 





 



 =head2 sleep_until 




4500




 





 





 





 





 





 



   




4501




 





 





 





 





 





 



 sleep_until(0.5) sleeps until half a second has passed since the last 




4502




 





 





 





 





 





 



 call to sleep_until. This example starts the next job excactly ten 




4503




 





 





 





 





 





 



 seconds after the last job started even if the last job lasted for a 




4504




 





 





 





 





 





 



 while (but not more than ten seconds): 




4505




 





 





 





 





 





 



   




4506




 





 





 





 





 





 



  for(@jobs){ 




4507




 





 





 





 





 





 



    sleep_until(10); 




4508




 





 





 





 





 





 



    print localtime()."\n"; 




4509




 





 





 





 





 





 



    ...heavy job.... 




4510




 





 





 





 





 





 



  } 




4511




 





 





 





 





 





 



   




4512




 





 





 





 





 





 



 Might print: 




4513




 





 





 





 





 





 



   




4514




 





 





 





 





 





 



  Thu Jan 12 16:00:00 2012 




4515




 





 





 





 





 





 



  Thu Jan 12 16:00:10 2012 




4516




 





 





 





 





 





 



  Thu Jan 12 16:00:20 2012 




4517




 





 





 





 





 





 



   




4518




 





 





 





 





 





 



 ...and so on even if the C<< ...heavy job... >>-part takes more than a 




4519




 





 





 





 





 





 



 second to complete. Whereas if sleep(10) was used, each job would 




4520




 





 





 





 





 





 



 spend more than ten seconds in average since the work time would be 




4521




 





 





 





 





 





 



 added to sleep(10). 




4522




 





 





 





 





 





 



   




4523




 





 





 





 





 





 



 Note: sleep_until() will remember the time of ANY last call of this sub, 




4524




 





 





 





 





 





 



 not just the one on the same line in the source code (this might change 




4525




 





 





 





 





 





 



 in the future). The first call to sleep_until() will be the same as 




4526




 





 





 





 





 





 



 sleep_fp() or Perl's own sleep() if the argument is an integer. 




4527




 





 





 





 





 





 



   




4528




 





 





 





 





 





 



 =cut 




4529




 





 





 





 





 





 



   




4530




 





 





 





 





 





 



 our $Time_last_sleep_until; 




4531




 





 





 





 





 





 



 sub sleep_until { 




4532



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



   my $s=@_==1?shift():0; 




4533



  
0
  




 





 





 





 





0



   my $time=time_fp(); 




4534



  
0
  




 





 





 





 





0



   my $sleep=$s-($time-nvl($Time_last_sleep_until,0)); 




4535



  
0
  




 





 





 





 





0



   $Time_last_sleep_until=time; 




4536



  
0
  



  
  0
  




 





 





 





0



   sleep_fp($sleep) if $sleep>0; 




4537




 





 





 





 





 





 



 } 




4538




 





 





 





 





 





 



   




4539




 





 





 





 





 





 



 =head2 leapyear 




4540




 





 





 





 





 





 



   




4541




 





 





 





 





 





 



 B A year. A four digit number. 




4542




 





 





 





 





 





 



   




4543




 





 





 





 





 





 



 B True (1) or false (0) of whether the year is a leap year or 




4544




 





 





 





 





 





 



 not. (Uses current calendar even for periods before leapyears was used). 




4545




 





 





 





 





 





 



   




4546




 





 





 





 





 





 



  print join(", ",grep leapyear($_), 1900..2014)."\n"; 




4547




 





 





 





 





 





 



   




4548




 





 





 





 





 





 



  1904, 1908, 1912, 1916, 1920, 1924, 1928, 1932, 1936, 1940, 1944, 1948, 1952, 1956, 




4549




 





 





 





 





 





 



  1960, 1964, 1968, 1972, 1976, 1980, 1984, 1988, 1992, 1996, 2000, 2004, 2008, 2012 




4550




 





 





 





 





 





 



   




4551




 





 





 





 





 





 



 Note: 1900 is not a leap year, but 2000 is. Years divided by 100 is a leap year only 




4552




 





 





 





 





 





 



 if it can be divided by 400. 




4553




 





 





 





 





 





 



   




4554




 





 





 





 





 





 



 =cut 




4555




 





 





 





 





 





 



   




4556



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub leapyear{$_[0]%400?$_[0]%100?$_[0]%4?0:1:0:1} #bool 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




4557




 





 





 





 





 





 



   




4558




 





 





 





 





 





 



 #http://rosettacode.org/wiki/Levenshtein_distance#Perl 




4559




 





 





 





 





 





 



 our %ldist_cache; 




4560




 





 





 





 





 





 



 sub ldist { 




4561



  
0
  




 





 




  
0
  



  
0
  




0



   my($s,$t,$l) = @_; 




4562



  
0
  



  
  0
  




 





 





 





0



   return length($t) if !$s; 




4563



  
0
  



  
  0
  




 





 





 





0



   return length($s) if !$t; 




4564



  
0
  



  
  0
  



  
  0
  




 





 





0



   %ldist_cache=() if !$l and 1000<0+%ldist_cache; 




4565




 





 





 





 





 





 



   $ldist_cache{$s,$t} ||= 




4566



  
0
  




 




  
  0
  




 





 





0



   do { 




4567



  
0
  




 





 





 





 





0



     my($s1,$t1) = ( substr($s,1), substr($t,1) ); 




4568



  
0
  



  
  0
  




 





 





 





0



     substr($s,0,1) eq substr($t,0,1) 




4569




 





 





 





 





 





 



       ? ldist($s1,$t1) 




4570




 





 





 





 





 





 



       : 1 + min( ldist($s1,$t1,1+$l), ldist($s,$t1,1+$l), ldist($s1,$t,1+$l) ); 




4571




 





 





 





 





 





 



   }; 




4572




 





 





 





 





 





 



 } 




4573




 





 





 





 





 





 



   




4574




 





 





 





 





 





 



 =head1 OTHER 




4575




 





 





 





 





 





 



   




4576




 





 





 





 





 





 



 =head2 nvl 




4577




 





 





 





 





 





 



   




4578




 





 





 





 





 





 



 The I function (or I function) 




4579




 





 





 





 





 





 



   




4580




 





 





 





 





 





 



 C takes two or more arguments. (Oracles nvl-function take just two) 




4581




 





 





 





 





 





 



   




4582




 





 





 





 





 





 



 Returns the value of the first input argument with length() > 0. 




4583




 





 





 





 





 





 



   




4584




 





 





 





 





 





 



 Return I if there is no such input argument. 




4585




 





 





 





 





 





 



   




4586




 





 





 





 





 





 



 In perl 5.10 and perl 6 this will most often be easier with the C< // 




4587




 





 





 





 





 





 



 > operator, although C and C<< // >> treats empty strings C<""> 




4588




 





 





 





 





 





 



 differently. Sub nvl here considers empty strings and undef the same. 




4589




 





 





 





 





 





 



   




4590




 





 





 





 





 





 



 =cut 




4591




 





 





 





 





 





 



   




4592




 





 





 





 





 





 



 sub nvl { 




4593




38




  
100
  



  
 66
  



  
38
  



  
1
  




285



   return $_[0] if defined $_[0] and length($_[0]) or @_==1; 




 




 





 




  
100
  




 





 





 



   




4594




22




  
100
  




 





 





 





83



   return $_[1] if @_==2; 




4595




9




  
100
  




 





 





 





36



   return nvl(@_[1..$#_]) if @_>2; 




4596




1





 





 





 





 





4



   return undef; 




4597




 





 





 





 





 





 



 } 




4598




 





 





 





 





 





 



   




4599




 





 





 





 





 





 



 =head2 decode_num 




4600




 





 





 





 





 





 



   




4601




 





 





 





 





 





 



 See L. 




4602




 





 





 





 





 





 



   




4603




 





 





 





 





 





 



 =head2 decode 




4604




 





 





 





 





 





 



   




4605




 





 





 





 





 





 



 C and C works just as Oracles C. 




4606




 





 





 





 





 





 



   




4607




 





 





 





 





 





 



 C and C accordingly uses perl operators C and C<==> for comparison. 




4608




 





 





 





 





 





 



   




4609




 





 





 





 





 





 



 Examples: 




4610




 





 





 





 





 





 



   




4611




 





 





 





 





 





 



  my $a=123; 




4612




 





 





 





 





 





 



  print decode($a, 123,3,  214,4, $a);     # prints 3 




4613




 





 





 





 





 





 



  print decode($a, 123=>3, 214=>4, $a);    # prints 3, same thing since => is synonymous to comma in Perl 




4614




 





 





 





 





 





 



   




4615




 





 





 





 





 





 



 The first argument is tested against the second, fourth, sixth and so on, 




4616




 





 





 





 





 





 



 and then the third, fifth, seventh and so on is 




4617




 





 





 





 





 





 



 returned if decode() finds an equal string or number. 




4618




 





 





 





 





 





 



   




4619




 





 





 





 





 





 



 In the above example: 123 maps to 3, 124 maps to 4 and the last argument $a is returned elsewise. 




4620




 





 





 





 





 





 



   




4621




 





 





 





 





 





 



 More examples: 




4622




 





 





 





 





 





 



   




4623




 





 





 





 





 





 



  my $a=123; 




4624




 





 





 





 





 





 



  print decode($a, 123=>3, 214=>7, $a);              # also 3,  note that => is synonym for , (comma) in perl 




4625




 





 





 





 





 





 



  print decode($a, 122=>3, 214=>7, $a);              # prints 123 




4626




 





 





 





 





 





 



  print decode($a,  123.0 =>3, 214=>7);              # prints 3 




4627




 





 





 





 





 





 



  print decode($a, '123.0'=>3, 214=>7);              # prints nothing (undef), no last argument default value here 




4628




 





 





 





 





 





 



  print decode_num($a, 121=>3, 221=>7, '123.0','b'); # prints b 




4629




 





 





 





 





 





 



   




4630




 





 





 





 





 





 



 Sort of: 




4631




 





 





 





 





 





 



   




4632




 





 





 





 





 





 



  decode($string, %conversion, $default); 




4633




 





 





 





 





 





 



   




4634




 





 





 





 





 





 



 The last argument is returned as a default if none of the keys in the keys/value-pairs matched. 




4635




 





 





 





 





 





 



   




4636




 





 





 





 





 





 



 A more perl-ish and often faster way of doing the same: 




4637




 





 





 





 





 





 



   




4638




 





 





 





 





 





 



  {123=>3, 214=>7}->{$a} || $a                       # (beware of 0) 




4639




 





 





 





 





 





 



   




4640




 





 





 





 





 





 



 =cut 




4641




 





 





 





 





 





 



   




4642




 





 





 





 





 





 



 sub decode { 




4643




4




  
 50
  




 




  
4
  



  
1
  




10



   croak "Must have a mimimum of two arguments" if @_<2; 




4644




4





 





 





 





 





6



   my $uttrykk=shift; 




4645




4




  
 50
  



  
100
  




 





 





11



   if(defined$uttrykk){ shift eq $uttrykk and return shift or shift for 1..@_/2 } 




 




4





 




  
 33
  




 





 





37



   




4646



  
0
  




 




  
  0
  




 





 





0



   else               { !defined shift    and return shift or shift for 1..@_/2 } 




 




 





 




  
  0
  




 





 





 



   




4647




2





 





 





 





 





8



   return shift; 




4648




 





 





 





 





 





 



 } 




4649




 





 





 





 





 





 



   




4650




 





 





 





 





 





 



 sub decode_num { 




4651




1




  
 50
  




 




  
1
  



  
1
  




5



   croak "Must have a mimimum of two arguments" if @_<2; 




4652




1





 





 





 





 





2



   my $uttrykk=shift; 




4653




1




  
 50
  



  
100
  




 





 





3



   if(defined$uttrykk){ shift == $uttrykk and return shift or shift for 1..@_/2 } 




 




1





 




  
 33
  




 





 





15



   




4654



  
0
  




 




  
  0
  




 





 





0



   else               { !defined shift    and return shift or shift for 1..@_/2 } 




 




 





 




  
  0
  




 





 





 



   




4655



  
0
  




 





 





 





 





0



   return shift; 




4656




 





 





 





 





 





 



 } 




4657




 





 





 





 





 





 



   




4658




 





 





 





 





 





 



 =head2 qrlist 




4659




 





 





 





 





 





 



   




4660




 





 





 





 





 





 



 Input: An array of values to be used to test againts for existence. 




4661




 





 





 





 





 





 



   




4662




 





 





 





 





 





 



 Output: A reference to a regular expression. That is a C 




4663




 





 





 





 





 





 



   




4664




 





 





 





 





 





 



 The regex sets $1 if it match. 




4665




 





 





 





 





 





 



   




4666




 





 





 





 





 





 



 Example: 




4667




 





 





 





 





 





 



   




4668




 





 





 





 





 





 



   my @list=qw/ABc XY DEF DEFG XYZ/; 




4669




 





 





 





 





 





 



   my $filter=qrlist("ABC","DEF","XY.");         # makes a regex of it qr/^(\QABC\E|\QDEF\E|\QXY.\E)$/ 




4670




 





 





 





 





 





 



   my @filtered= grep { $_ =~ $filter } @list;   # returns DEF and XYZ, but not XYZ because the . char is taken literally 




4671




 





 





 





 





 





 



   




4672




 





 





 





 





 





 



 Note: Filtering with hash lookups are WAY faster. 




4673




 





 





 





 





 





 



   




4674




 





 





 





 





 





 



 Source: 




4675




 





 





 





 





 





 



   




4676




 





 





 





 





 





 



  sub qrlist (@) { my $str=join"|",map quotemeta, @_; qr/^($str)$/ } 




4677




 





 





 





 





 





 



   




4678




 





 





 





 





 





 



 =cut 




4679




 





 





 





 





 





 



   




4680




 





 





 





 





 





 



 sub qrlist (@) { 




4681



  
0
  




 





 




  
0
  



  
1
  




0



   my $str=join"|",map quotemeta,@_; 




4682



  
0
  




 





 





 





 





0



   return qr/^($str)$/; 




4683




 





 





 





 





 





 



 } 




4684




 





 





 





 





 





 



   




4685




 





 





 





 





 





 



 =head2 ansicolor 




4686




 





 





 





 





 





 



   




4687




 





 





 





 





 





 



 Perhaps easier to use than L ? 




4688




 





 





 





 





 





 



   




4689




 





 





 





 





 





 



 B One argument. A string where the char C<¤> have special 




4690




 





 





 





 





 





 



 meaning and is replaced by color codings depending on the letter 




4691




 





 





 





 





 





 



 following the C<¤>. 




4692




 





 





 





 





 





 



   




4693




 





 





 





 





 





 



 B The same string, but with C<¤letter> replaced by ANSI color 




4694




 





 





 





 





 





 



 codes respected by many types terminal windows. (xterm, telnet, ssh, 




4695




 





 





 





 





 





 



 telnet, rlog, vt100, cygwin, rxvt and such...). 




4696




 





 





 





 





 





 



   




4697




 





 





 





 





 





 



 B 




4698




 





 





 





 





 





 



   




4699




 





 





 





 





 





 



  ¤r red 




4700




 





 





 





 





 





 



  ¤g green 




4701




 





 





 





 





 





 



  ¤b blue 




4702




 





 





 





 





 





 



  ¤y yellow 




4703




 





 





 





 





 





 



  ¤m magenta 




4704




 





 





 





 





 





 



  ¤B bold 




4705




 





 





 





 





 





 



  ¤u underline 




4706




 





 





 





 





 





 



  ¤c clear 




4707




 





 





 





 





 





 



  ¤¤ reset, quits and returns to default text color. 




4708




 





 





 





 





 





 



   




4709




 





 





 





 





 





 



 B 




4710




 





 





 





 





 





 



   




4711




 





 





 





 





 





 



  print ansicolor("This is maybe ¤ggreen¤¤?"); 




4712




 





 





 





 





 





 



   




4713




 





 





 





 





 





 



 Prints I where the word I is shown in green. 




4714




 





 





 





 





 





 



   




4715




 





 





 





 





 





 



 If L is not installed or not found, returns the input 




4716




 





 





 





 





 





 



 string with every C<¤> including the following code letters 




4717




 





 





 





 





 





 



 removed. (That is: ansicolor is safe to use even if Term::ANSIColor is 




4718




 





 





 





 





 





 



 not installed, you just don't get the colors). 




4719




 





 





 





 





 





 



   




4720




 





 





 





 





 





 



 See also L. 




4721




 





 





 





 





 





 



   




4722




 





 





 





 





 





 



 =cut 




4723




 





 





 





 





 





 



   




4724




 





 





 





 





 





 



 sub ansicolor { 




4725



  
0
  




 





 




  
0
  



  
1
  




0



   my $txt=shift; 




4726



  
0
  



  
  0
  




 





 





 





0



   eval{require Term::ANSIColor} or return replace($txt,qr/¤./); 




 



  
0
  




 





 





 





 





0



   




4727



  
0
  




 





 





 





 





0



   my %h=qw/r red  g green  b blue  y yellow  m magenta  B bold  u underline  c clear  ¤ reset/; 




4728



  
0
  




 





 





 





 





0



   my $re=join"|",keys%h; 




4729



  
0
  




 





 





 





 





0



   $txt=~s/¤($re)/Term::ANSIColor::color($h{$1})/ge; 




 



  
0
  




 





 





 





 





0



   




4730



  
0
  




 





 





 





 





0



   return $txt; 




4731




 





 





 





 





 





 



 } 




4732




 





 





 





 





 





 



   




4733




 





 





 





 





 





 



 =head2 ccn_ok 




4734




 





 





 





 





 





 



   




4735




 





 





 





 





 





 



 Checks if a Credit Card number (CCN) has correct control digits according to the LUHN-algorithm from 1960. 




4736




 





 





 





 





 





 



 This method of control digits is used by MasterCard, Visa, American Express, 




4737




 





 





 





 





 





 



 Discover, Diners Club / Carte Blanche, JCB and others. 




4738




 





 





 





 





 





 



   




4739




 





 





 





 





 





 



 B 




4740




 





 





 





 





 





 



   




4741




 





 





 





 





 





 



 A credit card number. Can contain non-digits, but they are removed internally before checking. 




4742




 





 





 





 





 





 



   




4743




 





 





 





 





 





 



 B 




4744




 





 





 





 





 





 



   




4745




 





 





 





 





 





 



 Something true or false. 




4746




 





 





 





 





 





 



   




4747




 





 





 





 





 





 



 Or more accurately: 




4748




 





 





 





 





 





 



   




4749




 





 





 





 





 





 



 Returns C (false) if the input argument is missing digits. 




4750




 





 





 





 





 





 



   




4751




 





 





 





 





 





 



 Returns 0 (zero, which is false) is the digits is not correct according to the LUHN algorithm. 




4752




 





 





 





 





 





 



   




4753




 





 





 





 





 





 



 Returns 1 or the name of a credit card company (true either way) if the last digit is an ok control digit for this ccn. 




4754




 





 





 





 





 





 



   




4755




 





 





 





 





 





 



 The name of the credit card company is returned like this (without the C<'> character) 




4756




 





 





 





 





 





 



   




4757




 





 





 





 





 





 



  Returns (wo '')                Starts on                Number of digits 




4758




 





 





 





 





 





 



  ------------------------------ ------------------------ ---------------- 




4759




 





 





 





 





 





 



  'MasterCard'                   51-55                    16 




4760




 





 





 





 





 





 



  'Visa'                         4                        13 eller 16 




4761




 





 





 





 





 





 



  'American Express'             34 eller 37              15 




4762




 





 





 





 





 





 



  'Discover'                     6011                     16 




4763




 





 





 





 





 





 



  'Diners Club / Carte Blanche'  300-305, 36 eller 38     14 




4764




 





 





 





 





 





 



  'JCB'                          3                        16 




4765




 





 





 





 





 





 



  'JCB'                          2131 eller 1800          15 




4766




 





 





 





 





 





 



   




4767




 





 





 





 





 





 



 And should perhaps have had: 




4768




 





 





 





 





 





 



   




4769




 





 





 





 





 





 



  'enRoute'                      2014 eller 2149          15 




4770




 





 





 





 





 





 



   




4771




 





 





 





 





 





 



 ...but that card uses either another control algorithm or no control 




4772




 





 





 





 





 





 



 digits at all. So C is never returned here. 




4773




 





 





 





 





 





 



   




4774




 





 





 





 





 





 



 If the control digits is valid, but the input does not match anything in the column C, 1 is returned. 




4775




 





 





 





 





 





 



   




4776




 





 





 





 





 





 



 (This is also the same control digit mechanism used in Norwegian KID numbers on payment bills) 




4777




 





 





 





 





 





 



   




4778




 





 





 





 





 





 



 The first digit in a credit card number is supposed to tell what "industry" the card is meant for: 




4779




 





 





 





 





 





 



   




4780




 





 





 





 





 





 



  MII Digit Value             Issuer Category 




4781




 





 





 





 





 





 



  --------------------------- ---------------------------------------------------- 




4782




 





 





 





 





 





 



  0                           ISO/TC 68 and other industry assignments 




4783




 





 





 





 





 





 



  1                           Airlines 




4784




 





 





 





 





 





 



  2                           Airlines and other industry assignments 




4785




 





 





 





 





 





 



  3                           Travel and entertainment 




4786




 





 





 





 





 





 



  4                           Banking and financial 




4787




 





 





 





 





 





 



  5                           Banking and financial 




4788




 





 





 





 





 





 



  6                           Merchandizing and banking 




4789




 





 





 





 





 





 



  7                           Petroleum 




4790




 





 





 





 





 





 



  8                           Telecommunications and other industry assignments 




4791




 





 





 





 





 





 



  9                           National assignment 




4792




 





 





 





 





 





 



   




4793




 





 





 





 





 





 



 ...although this has no meaning to C. 




4794




 





 





 





 





 





 



   




4795




 





 





 





 





 





 



 The first six digits is I, that is the bank 




4796




 





 





 





 





 





 



 (probably). The rest in the "account number", except the last digits, 




4797




 





 





 





 





 





 



 which is the control digit. Max length on credit card numbers are 19 




4798




 





 





 





 





 





 



 digits. 




4799




 





 





 





 





 





 



   




4800




 





 





 





 





 





 



 =cut 




4801




 





 





 





 





 





 



   




4802




 





 





 





 





 





 



 sub ccn_ok { 




4803



  
0
  




 





 




  
0
  



  
1
  




0



     my $ccn=shift(); #credit card number 




4804



  
0
  




 





 





 





 





0



     $ccn=~s/\D+//g; 




4805



  
0
  



  
  0
  




 





 





 





0



     if(KID_ok($ccn)){ 




4806



  
0
  



  
  0
  




 





 





 





0



 	return "MasterCard"                   if $ccn=~/^5[1-5]\d{14}$/; 




4807



  
0
  



  
  0
  




 





 





 





0



 	return "Visa"                         if $ccn=~/^4\d{12}(?:\d{3})?$/; 




4808



  
0
  



  
  0
  




 





 





 





0



 	return "American Express"             if $ccn=~/^3[47]\d{13}$/; 




4809



  
0
  



  
  0
  




 





 





 





0



 	return "Discover"                     if $ccn=~/^6011\d{12}$/; 




4810



  
0
  



  
  0
  




 





 





 





0



 	return "Diners Club / Carte Blanche"  if $ccn=~/^3(?:0[0-5]\d{11}|[68]\d{12})$/; 




4811



  
0
  



  
  0
  




 





 





 





0



 	return "JCB"                          if $ccn=~/^(?:3\d{15}|(?:2131|1800)\d{11})$/; 




4812



  
0
  




 





 





 





 





0



 	return 1; 




4813




 





 





 





 





 





 



     } 




4814




 





 





 





 





 





 



     #return "enRoute"                        if $ccn=~/^(?:2014|2149)\d{11}$/; #ikke LUHN-krav? 




4815



  
0
  




 





 





 





 





0



     return 0; 




4816




 





 





 





 





 





 



 } 




4817




 





 





 





 





 





 



   




4818




 





 





 





 





 





 



 =head2 KID_ok 




4819




 





 





 





 





 





 



   




4820




 





 





 





 





 





 



 Checks if a norwegian KID number has an ok control digit. 




4821




 





 





 





 





 





 



   




4822




 





 





 





 





 





 



 To check if a customer has typed the number correctly. 




4823




 





 





 





 





 





 



   




4824




 





 





 





 





 





 



 This uses the  LUHN algorithm (also known as mod-10) from 1960 which is also used 




4825




 





 





 





 





 





 



 internationally in control digits for credit card numbers, and Canadian social security ID numbers as well. 




4826




 





 





 





 





 





 



   




4827




 





 





 





 





 





 



 The algorithm, as described in Phrack (47-8) (a long time hacker online publication): 




4828




 





 





 





 





 





 



   




4829




 





 





 





 





 





 



  "For a card with an even number of digits, double every odd numbered 




4830




 





 





 





 





 





 



  digit and subtract 9 if the product is greater than 9. Add up all the 




4831




 





 





 





 





 





 



  even digits as well as the doubled-odd digits, and the result must be 




4832




 





 





 





 





 





 



  a multiple of 10 or it's not a valid card. If the card has an odd 




4833




 





 





 





 





 





 



  number of digits, perform the same addition doubling the even numbered 




4834




 





 





 





 





 





 



  digits instead." 




4835




 





 





 





 





 





 



   




4836




 





 





 





 





 





 



 B A KID-nummer. Must consist of digits 0-9 only, otherwise a die (croak) happens. 




4837




 





 





 





 





 





 



   




4838




 





 





 





 





 





 



 B 




4839




 





 





 





 





 





 



   




4840




 





 





 





 





 





 



 - Returns undef if the input argument is missing. 




4841




 





 





 





 





 





 



   




4842




 





 





 





 





 





 



 - Returns 0 if the control digit (the last digit) does not satify the LUHN/mod-10 algorithm. 




4843




 





 





 





 





 





 



   




4844




 





 





 





 





 





 



 - Returns 1 if ok 




4845




 





 





 





 





 





 



   




4846




 





 





 





 





 





 



 B L 




4847




 





 





 





 





 





 



   




4848




 





 





 





 





 





 



 =cut 




4849




 





 





 





 





 





 



   




4850




 





 





 





 





 





 



 sub KID_ok { 




4851



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



   croak "Non-numeric argument" if $_[0]=~/\D/; 




4852



  
0
  



  
  0
  




 





 





 





0



   my @k=split//,shift or return undef; 




4853



  
0
  




 





 





 





 





0



   my $s;$s+=pop(@k)+[qw/0 2 4 6 8 1 3 5 7 9/]->[pop@k] while @k; 




 



  
0
  




 





 





 





 





0



   




4854



  
0
  



  
  0
  




 





 





 





0



   $s%10==0?1:0; 




4855




 





 





 





 





 





 



 } 




4856




 





 





 





 





 





 



   




4857




 





 





 





 





 





 



   




4858




 





 





 





 





 





 



   




4859




 





 





 





 





 





 



 =head2 range 




4860




 





 





 





 





 





 



   




4861




 





 





 





 





 





 



 B 




4862




 





 





 





 





 





 



   




4863




 





 





 





 





 





 



 One or more numeric arguments: 




4864




 





 





 





 





 





 



   




4865




 





 





 





 





 





 



 First: x (first returned element) 




4866




 





 





 





 





 





 



   




4867




 





 





 





 





 





 



 Second: y (last but not including) 




4868




 





 





 





 





 





 



   




4869




 





 





 





 





 





 



 Third: step, default 1. The step between each returned element 




4870




 





 





 





 





 





 



   




4871




 





 





 





 





 





 



 If a fourth, fifth and so on arguments are given, they change the step for each returned element. As first derivative, second derivative. 




4872




 





 





 





 





 





 



   




4873




 





 





 





 





 





 



 B 




4874




 





 





 





 





 





 



   




4875




 





 





 





 





 





 



 If one argument: returns the array C<(0 .. x-1)> 




4876




 





 





 





 





 





 



   




4877




 





 





 





 





 





 



 If two arguments: returns the array C<(x .. y-1)> 




4878




 





 





 





 





 





 



   




4879




 





 





 





 





 





 



 If three arguments: The default step is 1. Use a third argument to use a different step. 




4880




 





 





 





 





 





 



   




4881




 





 





 





 





 





 



 B 




4882




 





 





 





 





 





 



   




4883




 





 





 





 





 





 



  print join ",", range(11);         # prints 0,1,2,3,4,5,6,7,8,9,10      (but not 11) 




4884




 





 





 





 





 





 



  print join ",", range(2,11);       # 2,3,4,5,6,7,8,9,10          (but not 11) 




4885




 





 





 





 





 





 



  print join ",", range(11,2,-1);    # 11,10,9,8,7,6,5,4,3 




4886




 





 





 





 





 





 



  print join ",", range(2,11,3);     # 2,5,8 




4887




 





 





 





 





 





 



  print join ",", range(11,2,-3);    # 11,8,5 




4888




 





 





 





 





 





 



  print join ",", range(11,2,+3);    # prints nothing 




4889




 





 





 





 





 





 



   




4890




 





 





 





 





 





 



  print join ", ",range(2,11,1,0.1);       # 2, 3, 4.1, 5.3, 6.6, 8, 9.5   adds 0.1 to step each time 




4891




 





 





 





 





 





 



  print join ", ",range(2,11,1,0.1,-0.01); # 2, 3, 4.1, 5.29, 6.56, 7.9, 9.3, 10.75 




4892




 





 





 





 





 





 



   




4893




 





 





 





 





 





 



 Note: In the Python language and others, C is a build in iterator (a 




4894




 





 





 





 





 





 



 generator), not an array. This saves memory for large sets and sometimes time. 




4895




 





 





 





 





 





 



 Use C in L to get a similar lazy generator in Perl. 




4896




 





 





 





 





 





 



   




4897




 





 





 





 





 





 



 =cut 




4898




 





 





 





 





 





 



   




4899




 





 





 





 





 





 



 sub range { 




4900




8




  
100
  




 




  
8
  



  
1
  




35



   return _range_accellerated(@_) if @_>3;  #se under 




4901




6





 





 





 





 





13



   my($x,$y,$jump)=@_; 




4902




6




  
100
  




 





 





 





71



   return (  0 .. $x-1 ) if @_==1; 




4903




5




  
100
  




 





 





 





21



   return ( $x .. $y-1 ) if @_==2; 




4904




4




  
 50
  



  
 33
  




 





 





28



   croak "Wrong number of arguments or jump==0" if @_!=3 or $jump==0; 




4905




4





 





 





 





 





6



   my @r; 




4906




4




  
100
  




 





 





 





11



   if($jump>0){  while($x<$y){ push @r, $x; $x+=$jump } } 




 




2





 





 





 





 





8



   




 




772





 





 





 





 





856



   




 




772





 





 





 





 





1292



   




4907




2





 





 





 





 





6



   else       {  while($x>$y){ push @r, $x; $x+=$jump } } 




 




12





 





 





 





 





18



   




 




12





 





 





 





 





21



   




4908




4





 





 





 





 





57



   return @r; 




4909




 





 





 





 





 





 



 } 




4910




 





 





 





 





 





 



   




4911




 





 





 





 





 





 



 #jumps derivative, double der., trippled der usw 




4912




 





 





 





 





 





 



 sub _range_accellerated { 




4913




2





 





 




  
2
  




 





6



   my($x,$y,@jump)=@_; 




4914




2





 





 





 





 





4



   my @r; 




4915




2




  
 50
  




 




  
0
  




 





10



   my $test = $jump[0]>=0 ? sub{$x<$y} : sub{$x>$y}; 




 




17





 





 





 





 





45



   




 



  
0
  




 





 





 





 





0



   




4916




2





 





 





 





 





6



   while(&$test()){ 




4917




15





 





 





 





 





23



     push @r, $x; 




4918




15





 





 





 





 





18



     $x+=$jump[0]; 




4919




15





 





 





 





 





50



     $jump[$_-1]+=$jump[$_] for 1..$#jump; 




4920




 





 





 





 





 





 



   } 




4921




2





 





 





 





 





29



   return @r; 




4922




 





 





 





 





 





 



 } 




4923




 





 





 





 





 





 



   




4924




 





 





 





 





 





 



 =head2 permutations 




4925




 





 





 





 





 





 



   




4926




 





 





 





 





 





 



 How many ways (permutations) can six people be placed around a table: 




4927




 





 





 





 





 





 



   




4928




 





 





 





 





 





 



  If one person:          one 




4929




 





 





 





 





 





 



  If two persons:         two     (they can swap places) 




4930




 





 





 





 





 





 



  If three persons:       six 




4931




 





 





 





 





 





 



  If four persons:         24 




4932




 





 





 





 





 





 



  If five persons:        120 




4933




 





 





 





 





 





 



  If six  persons:        720 




4934




 





 





 





 





 





 



   




4935




 





 





 





 





 





 



 The formula is C where the postfix unary operator C, also known as I is defined like: 




4936




 





 





 





 





 





 



 C. Example: C<5! = 5 * 4 * 3 * 2 * 1 = 120>.Run this to see the 100 first C<< n! >> 




4937




 





 





 





 





 





 



   




4938




 





 





 





 





 





 



  perl -MAcme::Tools -le'$i=big(1);print "$_!=",$i*=$_ for 1..100' 




4939




 





 





 





 





 





 



   




4940




 





 





 





 





 





 



   1!  = 1 




4941




 





 





 





 





 





 



   2!  = 2 




4942




 





 





 





 





 





 



   3!  = 6 




4943




 





 





 





 





 





 



   4!  = 24 




4944




 





 





 





 





 





 



   5!  = 120 




4945




 





 





 





 





 





 



   6!  = 720 




4946




 





 





 





 





 





 



   7!  = 5040 




4947




 





 





 





 





 





 



   8!  = 40320 




4948




 





 





 





 





 





 



   9!  = 362880 




4949




 





 





 





 





 





 



  10!  = 3628800 




4950




 





 





 





 





 





 



  . 




4951




 





 





 





 





 





 



  . 




4952




 





 





 





 





 





 



  . 




4953




 





 





 





 





 





 



  100! = 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000 




4954




 





 





 





 





 





 



   




4955




 





 





 





 





 





 



 C takes a list and return a list of arrayrefs for each 




4956




 





 





 





 





 





 



 of the permutations of the input list: 




4957




 





 





 





 





 





 



   




4958




 





 





 





 





 





 



  permutations('a','b');     #returns (['a','b'],['b','a']) 




4959




 





 





 





 





 





 



   




4960




 





 





 





 





 





 



  permutations('a','b','c'); #returns (['a','b','c'],['a','c','b'], 




4961




 





 





 





 





 





 



                             #         ['b','a','c'],['b','c','a'], 




4962




 





 





 





 





 





 



                             #         ['c','a','b'],['c','b','a']) 




4963




 





 





 





 





 





 



   




4964




 





 





 





 





 





 



 Up to five input arguments C is probably as fast as it 




4965




 





 





 





 





 





 



 can be in this pure perl implementation (see source). For more than 




4966




 





 





 





 





 





 



 five, it could be faster. How fast is it now: Running with different 




4967




 





 





 





 





 





 



 n, this many time took that many seconds: 




4968




 





 





 





 





 





 



   




4969




 





 





 





 





 





 



  n   times    seconds 




4970




 





 





 





 





 





 



  -- ------- --------- 




4971




 





 





 





 





 





 



   2  100000      0.32 




4972




 





 





 





 





 





 



   3  10000       0.09 




4973




 





 





 





 





 





 



   4  10000       0.33 




4974




 





 





 





 





 





 



   5  1000        0.18 




4975




 





 





 





 





 





 



   6  100         0.27 




4976




 





 





 





 





 





 



   7  10          0.21 




4977




 





 





 





 





 





 



   8  1           0.17 




4978




 





 





 





 





 





 



   9  1           1.63 




4979




 





 





 





 





 





 



  10  1          17.00 




4980




 





 





 





 





 





 



   




4981




 





 





 





 





 





 



 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. For example this: 




4982




 





 





 





 





 





 



   




4983




 





 





 





 





 





 



  print for permutations(sub{join"",@_},1..3); 




4984




 





 





 





 





 





 



   




4985




 





 





 





 





 





 



 ...will print the same as: 




4986




 





 





 





 





 





 



   




4987




 





 





 





 





 





 



  print for map join("",@$_), permutations(1..3); 




4988




 





 





 





 





 





 



   




4989




 





 





 





 





 





 



 ...but the first of those two uses less RAM if 3 has been say 9. 




4990




 





 





 





 





 





 



 Changing 3 with 10, and many computers hasn't enough memory 




4991




 





 





 





 





 





 



 for the latter. 




4992




 





 





 





 





 





 



   




4993




 





 





 





 





 





 



 The examples prints: 




4994




 





 





 





 





 





 



   




4995




 





 





 





 





 





 



  123 




4996




 





 





 





 





 





 



  132 




4997




 





 





 





 





 





 



  213 




4998




 





 





 





 





 





 



  231 




4999




 





 





 





 





 





 



  312 




5000




 





 





 





 





 





 



  321 




5001




 





 





 





 





 





 



   




5002




 





 





 





 





 





 



 If you just want to say calculate something on each permutation, 




5003




 





 





 





 





 





 



 but is not interested in the list of them, you just don't 




5004




 





 





 





 





 





 



 take the return. That is: 




5005




 





 





 





 





 





 



   




5006




 





 





 





 





 





 



  my $ant; 




5007




 





 





 





 





 





 



  permutations(sub{$ant++ if $_[-1]>=$_[0]*2},1..9); 




5008




 





 





 





 





 





 



   




5009




 





 





 





 





 





 



 ...is the same as: 




5010




 





 





 





 





 





 



   




5011




 





 





 





 





 





 



  $$_[-1]>=$$_[0]*2 and $ant++ for permutations(1..9); 




5012




 





 





 





 





 





 



   




5013




 





 





 





 





 





 



 ...but the first uses next to nothing of memory compared to the latter. They have about the same speed. 




5014




 





 





 





 





 





 



 (The examples just counts the permutations where the last number is at least twice as large as the first) 




5015




 





 





 





 





 





 



   




5016




 





 





 





 





 





 



 C was created to find all combinations of a persons 




5017




 





 





 





 





 





 



 name. This is useful in "fuzzy" name searches with 




5018




 





 





 





 





 





 



 L if you can not be certain what is first, middle 




5019




 





 





 





 





 





 



 and last names. In foreign or unfamiliar names it can be difficult to 




5020




 





 





 





 





 





 



 know that. 




5021




 





 





 





 





 





 



   




5022




 





 





 





 





 





 



 =cut 




5023




 





 





 





 





 





 



   




5024




 





 





 





 





 





 



 #TODO: se test_perl.pl 




5025




 





 





 





 





 





 



   




5026




 





 





 





 





 





 



 sub permutations { 




5027




2




  
 50
  




 




  
2
  



  
1
  




16



   my $code=ref($_[0]) eq 'CODE' ? shift() : undef; 




5028




2




  
 50
  



  
 33
  




 





 





11



   $code and @_<6 and return map &$code(@$_),permutations(@_); 




5029




 





 





 





 





 





 



   




5030




2




  
 50
  




 





 





 





7



   return [@_] if @_<2; 




5031




 





 





 





 





 





 



   




5032




2




  
100
  




 





 





 





19



   return ([@_[0,1]],[@_[1,0]]) if @_==2; 




5033




 





 





 





 





 





 



   




5034




1




  
 50
  




 





 





 





19



   return ([@_[0,1,2]],[@_[0,2,1]],[@_[1,0,2]], 




5035




 





 





 





 





 





 



 	  [@_[1,2,0]],[@_[2,0,1]],[@_[2,1,0]]) if @_==3; 




5036




 





 





 





 





 





 



   




5037



  
0
  



  
  0
  




 





 





 





0



   return ([@_[0,1,2,3]],[@_[0,1,3,2]],[@_[0,2,1,3]],[@_[0,2,3,1]], 




5038




 





 





 





 





 





 



 	  [@_[0,3,1,2]],[@_[0,3,2,1]],[@_[1,0,2,3]],[@_[1,0,3,2]], 




5039




 





 





 





 





 





 



 	  [@_[1,2,0,3]],[@_[1,2,3,0]],[@_[1,3,0,2]],[@_[1,3,2,0]], 




5040




 





 





 





 





 





 



 	  [@_[2,0,1,3]],[@_[2,0,3,1]],[@_[2,1,0,3]],[@_[2,1,3,0]], 




5041




 





 





 





 





 





 



 	  [@_[2,3,0,1]],[@_[2,3,1,0]],[@_[3,0,1,2]],[@_[3,0,2,1]], 




5042




 





 





 





 





 





 



 	  [@_[3,1,0,2]],[@_[3,1,2,0]],[@_[3,2,0,1]],[@_[3,2,1,0]]) if @_==4; 




5043




 





 





 





 





 





 



   




5044



  
0
  



  
  0
  




 





 





 





0



   return ([@_[0,1,2,3,4]],[@_[0,1,2,4,3]],[@_[0,1,3,2,4]],[@_[0,1,3,4,2]],[@_[0,1,4,2,3]], 




5045




 





 





 





 





 





 



 	  [@_[0,1,4,3,2]],[@_[0,2,1,3,4]],[@_[0,2,1,4,3]],[@_[0,2,3,1,4]],[@_[0,2,3,4,1]], 




5046




 





 





 





 





 





 



 	  [@_[0,2,4,1,3]],[@_[0,2,4,3,1]],[@_[0,3,1,2,4]],[@_[0,3,1,4,2]],[@_[0,3,2,1,4]], 




5047




 





 





 





 





 





 



 	  [@_[0,3,2,4,1]],[@_[0,3,4,1,2]],[@_[0,3,4,2,1]],[@_[0,4,1,2,3]],[@_[0,4,1,3,2]], 




5048




 





 





 





 





 





 



 	  [@_[0,4,2,1,3]],[@_[0,4,2,3,1]],[@_[0,4,3,1,2]],[@_[0,4,3,2,1]],[@_[1,0,2,3,4]], 




5049




 





 





 





 





 





 



 	  [@_[1,0,2,4,3]],[@_[1,0,3,2,4]],[@_[1,0,3,4,2]],[@_[1,0,4,2,3]],[@_[1,0,4,3,2]], 




5050




 





 





 





 





 





 



 	  [@_[1,2,0,3,4]],[@_[1,2,0,4,3]],[@_[1,2,3,0,4]],[@_[1,2,3,4,0]],[@_[1,2,4,0,3]], 




5051




 





 





 





 





 





 



 	  [@_[1,2,4,3,0]],[@_[1,3,0,2,4]],[@_[1,3,0,4,2]],[@_[1,3,2,0,4]],[@_[1,3,2,4,0]], 




5052




 





 





 





 





 





 



 	  [@_[1,3,4,0,2]],[@_[1,3,4,2,0]],[@_[1,4,0,2,3]],[@_[1,4,0,3,2]],[@_[1,4,2,0,3]], 




5053




 





 





 





 





 





 



 	  [@_[1,4,2,3,0]],[@_[1,4,3,0,2]],[@_[1,4,3,2,0]],[@_[2,0,1,3,4]],[@_[2,0,1,4,3]], 




5054




 





 





 





 





 





 



 	  [@_[2,0,3,1,4]],[@_[2,0,3,4,1]],[@_[2,0,4,1,3]],[@_[2,0,4,3,1]],[@_[2,1,0,3,4]], 




5055




 





 





 





 





 





 



 	  [@_[2,1,0,4,3]],[@_[2,1,3,0,4]],[@_[2,1,3,4,0]],[@_[2,1,4,0,3]],[@_[2,1,4,3,0]], 




5056




 





 





 





 





 





 



 	  [@_[2,3,0,1,4]],[@_[2,3,0,4,1]],[@_[2,3,1,0,4]],[@_[2,3,1,4,0]],[@_[2,3,4,0,1]], 




5057




 





 





 





 





 





 



 	  [@_[2,3,4,1,0]],[@_[2,4,0,1,3]],[@_[2,4,0,3,1]],[@_[2,4,1,0,3]],[@_[2,4,1,3,0]], 




5058




 





 





 





 





 





 



 	  [@_[2,4,3,0,1]],[@_[2,4,3,1,0]],[@_[3,0,1,2,4]],[@_[3,0,1,4,2]],[@_[3,0,2,1,4]], 




5059




 





 





 





 





 





 



 	  [@_[3,0,2,4,1]],[@_[3,0,4,1,2]],[@_[3,0,4,2,1]],[@_[3,1,0,2,4]],[@_[3,1,0,4,2]], 




5060




 





 





 





 





 





 



 	  [@_[3,1,2,0,4]],[@_[3,1,2,4,0]],[@_[3,1,4,0,2]],[@_[3,1,4,2,0]],[@_[3,2,0,1,4]], 




5061




 





 





 





 





 





 



 	  [@_[3,2,0,4,1]],[@_[3,2,1,0,4]],[@_[3,2,1,4,0]],[@_[3,2,4,0,1]],[@_[3,2,4,1,0]], 




5062




 





 





 





 





 





 



 	  [@_[3,4,0,1,2]],[@_[3,4,0,2,1]],[@_[3,4,1,0,2]],[@_[3,4,1,2,0]],[@_[3,4,2,0,1]], 




5063




 





 





 





 





 





 



 	  [@_[3,4,2,1,0]],[@_[4,0,1,2,3]],[@_[4,0,1,3,2]],[@_[4,0,2,1,3]],[@_[4,0,2,3,1]], 




5064




 





 





 





 





 





 



 	  [@_[4,0,3,1,2]],[@_[4,0,3,2,1]],[@_[4,1,0,2,3]],[@_[4,1,0,3,2]],[@_[4,1,2,0,3]], 




5065




 





 





 





 





 





 



 	  [@_[4,1,2,3,0]],[@_[4,1,3,0,2]],[@_[4,1,3,2,0]],[@_[4,2,0,1,3]],[@_[4,2,0,3,1]], 




5066




 





 





 





 





 





 



 	  [@_[4,2,1,0,3]],[@_[4,2,1,3,0]],[@_[4,2,3,0,1]],[@_[4,2,3,1,0]],[@_[4,3,0,1,2]], 




5067




 





 





 





 





 





 



 	  [@_[4,3,0,2,1]],[@_[4,3,1,0,2]],[@_[4,3,1,2,0]],[@_[4,3,2,0,1]],[@_[4,3,2,1,0]]) if @_==5; 




5068




 





 





 





 





 





 



   




5069



  
0
  




 





 





 





 





0



   my(@r,@p,@c,@i,@n); @i=(0,@_); @p=@c=1..@_; @n=1..@_-1; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5070




 





 





 





 





 





 



   PERM: 




5071



  
0
  




 





 





 





 





0



   while(1){ 




5072



  
0
  



  
  0
  




 





 





 





0



     if($code){if(defined wantarray){push(@r,&$code(@i[@p]))}else{&$code(@i[@p])}}else{push@r,[@i[@p]]} 




 



  
0
  



  
  0
  




 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5073



  
0
  



  
  0
  




 





 





 





0



     for my$i(@n){splice@p,$i,0,shift@p;next PERM if --$c[$i];$c[$i]=$i+1} 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5074




 





 





 





 





 





 



     return@r 




5075



  
0
  




 





 





 





 





0



   } 




5076




 





 





 





 





 





 



 } 




5077




 





 





 





 





 





 



   




5078




 





 





 





 





 





 



 =head2 cart 




5079




 





 





 





 





 





 



   




5080




 





 





 





 





 





 



 Cartesian product 




5081




 





 





 





 





 





 



   




5082




 





 





 





 





 





 



 B 




5083




 





 





 





 





 





 



   




5084




 





 





 





 





 





 



 Input: two or more arrayrefs with accordingly x, y, z and so on number of elements. 




5085




 





 





 





 





 





 



   




5086




 





 





 





 





 





 



 Output: An array of x * y * z number of arrayrefs. The arrays being the cartesian product of the input arrays. 




5087




 





 





 





 





 





 



   




5088




 





 





 





 





 





 



 It can be useful to think of this as joins in SQL. In C statements with 




5089




 





 





 





 





 





 



 more tables behind C, but without any C condition to join the tables. 




5090




 





 





 





 





 





 



   




5091




 





 





 





 





 





 



 B 




5092




 





 





 





 





 





 



   




5093




 





 





 





 





 





 



 B 




5094




 





 





 





 





 





 



   




5095




 





 





 





 





 





 



 - Either two or more arrayrefs with x, y, z and so on number of elements. 




5096




 





 





 





 





 





 



   




5097




 





 





 





 





 





 



 - Or coderefs to subs containing condition checks. Somewhat like C conditions in SQL. 




5098




 





 





 





 





 





 



   




5099




 





 





 





 





 





 



 B An array of x * y * z number of arrayrefs (the cartesian product) 




5100




 





 





 





 





 





 



 minus the ones that did not fulfill the condition(s). 




5101




 





 





 





 





 





 



   




5102




 





 





 





 





 





 



 This of is as joins with one or more where conditions as coderefs. 




5103




 





 





 





 





 





 



   




5104




 





 





 





 





 





 



 The coderef input arguments can be placed last or among the array refs 




5105




 





 





 





 





 





 



 to save both runtime and memory if the conditions depend on 




5106




 





 





 





 





 





 



 arrays further back. 




5107




 





 





 





 





 





 



   




5108




 





 





 





 





 





 



 B 




5109




 





 





 





 





 





 



   




5110




 





 





 





 





 





 



  for(cart(\@a1,\@a2,\@a3)){ 




5111




 





 





 





 





 





 



    my($a1,$a2,$a3) = @$_; 




5112




 





 





 





 





 





 



    print "$a1,$a2,$a3\n"; 




5113




 





 





 





 





 





 



  } 




5114




 





 





 





 





 





 



   




5115




 





 





 





 





 





 



 Prints the same as this: 




5116




 





 





 





 





 





 



   




5117




 





 





 





 





 





 



  for my $a1 (@a1){ 




5118




 





 





 





 





 





 



    for my $a2 (@a2){ 




5119




 





 





 





 





 





 



      for my $a3 (@a3){ 




5120




 





 





 





 





 





 



        print "$a1,$a2,$a3\n"; 




5121




 





 





 





 





 





 



      } 




5122




 





 





 





 





 





 



    } 




5123




 





 





 





 





 





 



  } 




5124




 





 





 





 





 





 



   




5125




 





 





 





 





 





 



 B (with a condition: the sum of the first two should be dividable with 3) 




5126




 





 





 





 





 





 



   




5127




 





 





 





 





 





 



  for( cart( \@a1, \@a2, sub{sum(@$_)%3==0}, \@a3 ) ) { 




5128




 





 





 





 





 





 



    my($a1,$a2,$a3)=@$_; 




5129




 





 





 





 





 





 



    print "$a1,$a2,$a3\n"; 




5130




 





 





 





 





 





 



  } 




5131




 





 





 





 





 





 



   




5132




 





 





 





 





 





 



 Prints the same as this: 




5133




 





 





 





 





 





 



   




5134




 





 





 





 





 





 



  for my $a1 (@a1){ 




5135




 





 





 





 





 





 



    for my $a2 (@a2){ 




5136




 





 





 





 





 





 



      next if 0==($a1+$a2)%3; 




5137




 





 





 





 





 





 



      for my $a3 (@a3){ 




5138




 





 





 





 





 





 



        print "$a1,$a2,$a3\n"; 




5139




 





 





 





 





 





 



      } 




5140




 





 





 





 





 





 



    } 




5141




 





 





 





 





 





 



  } 




5142




 





 





 





 





 





 



   




5143




 





 





 





 





 





 



 B 




5144




 





 





 





 





 





 



   




5145




 





 





 





 





 





 



  my @a1 = (1,2); 




5146




 





 





 





 





 





 



  my @a2 = (10,20,30); 




5147




 





 





 





 





 





 



  my @a3 = (100,200,300,400); 




5148




 





 





 





 





 





 



   




5149




 





 





 





 





 





 



  my $s = join"", map "*".join(",",@$_), cart(\@a1,\@a2,\@a3); 




5150




 





 





 





 





 





 



  ok( $s eq  "*1,10,100*1,10,200*1,10,300*1,10,400*1,20,100*1,20,200" 




5151




 





 





 





 





 





 



            ."*1,20,300*1,20,400*1,30,100*1,30,200*1,30,300*1,30,400" 




5152




 





 





 





 





 





 



            ."*2,10,100*2,10,200*2,10,300*2,10,400*2,20,100*2,20,200" 




5153




 





 





 





 





 





 



            ."*2,20,300*2,20,400*2,30,100*2,30,200*2,30,300*2,30,400"); 




5154




 





 





 





 





 





 



   




5155




 





 





 





 





 





 



  $s=join"",map "*".join(",",@$_), cart(\@a1,\@a2,\@a3,sub{sum(@$_)%3==0}); 




5156




 





 





 





 





 





 



  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"); 




5157




 





 





 





 





 





 



   




5158




 





 





 





 





 





 



 B 




5159




 





 





 





 





 





 



   




5160




 





 





 





 





 





 



 Returns hashrefs instead of arrayrefs: 




5161




 





 





 





 





 





 



   




5162




 





 





 





 





 





 



  my @cards=cart(             #5200 cards: 100 decks of 52 cards 




5163




 





 





 





 





 





 



    deck  => [1..100], 




5164




 





 





 





 





 





 



    value => [qw/2 3 4 5 6 7 8 9 10 J Q K A/], 




5165




 





 





 





 





 





 



    col   => [qw/heart diamond club star/], 




5166




 





 





 





 





 





 



  ); 




5167




 





 





 





 





 





 



  for my $card ( mix(@cards) ) { 




5168




 





 





 





 





 





 



    print "From deck number $$card{deck} we got $$card{value} $$card{col}\n"; 




5169




 





 





 





 





 





 



  } 




5170




 





 





 





 





 





 



   




5171




 





 





 





 





 





 



 Note: using sub-ref filters do not work (yet) in hash-mode. Use grep on result instead. 




5172




 





 





 





 





 





 



   




5173




 





 





 





 





 





 



 =cut 




5174




 





 





 





 





 





 



   




5175




 





 





 





 





 





 



 sub cart { 




5176




5





 





 




  
5
  



  
1
  




850



   my @ars=@_; 




5177




5




  
100
  




 





 





 





17



   if(!ref($_[0])){ #if hash-mode detected 




5178




1





 




  
 33
  




 





 





2



     my(@k,@v); push@k,shift@ars and push@v,shift@ars while @ars; 




 




1





 





 





 





 





13



   




5179




1





 





 





 





 





7



     return map{my%h;@h{@k}=@$_;\%h}cart(@v); 




 




24





 





 





 





 





26



   




 




24





 





 





 





 





68



   




 




24





 





 





 





 





44



   




5180




 





 





 





 





 





 



   } 




5181




4





 





 





 





 





6



   my @res=map[$_],@{shift@ars}; 




 




4





 





 





 





 





20



   




5182




4





 





 





 





 





9



   for my $ar (@ars){ 




5183




9




  
100
  



  
 50
  




 





 





26



     @res=grep{&$ar(@$_)}@res and next if ref($ar) eq 'CODE'; 




 




24





 





 





 





 





51



   




5184




8





 





 





 





 





13



     @res=map{my$r=$_;map{[@$r,$_]}@$ar}@res; 




 




34





 





 





 





 





38



   




 




34





 





 





 





 





49



   




 




120





 





 





 





 





257



   




5185




 





 





 





 





 





 



   } 




5186




4





 





 





 





 





63



   return @res; 




5187




 





 





 





 





 





 



 } 




5188




 





 





 





 





 





 



   




5189




 





 





 





 





 





 



 sub cart_easy { #not tested/exported http://stackoverflow.com/questions/2457096/in-perl-how-can-i-get-the-cartesian-product-of-multiple-sets 




5190



  
0
  




 





 




  
0
  



  
0
  




0



   my $last = pop @_; 




5191



  
0
  



  
  0
  




 





 





 





0



   @_ ? (map {my$left=$_; map [@$left, $_], @$last } cart_easy(@_) ) 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5192




 





 





 





 





 





 



      : (map [$_], @$last); 




5193




 





 





 





 





 





 



 } 




5194




 





 





 





 





 





 



   




5195




 





 





 





 





 





 



 =head2 reduce 




5196




 





 





 





 





 





 



   




5197




 





 





 





 





 





 



 From: Why Functional Programming Matters: L 




5198




 





 





 





 





 





 



   




5199




 





 





 





 





 





 



 L 




5200




 





 





 





 





 





 



   




5201




 





 





 





 





 





 



 DON'T TRY THIS AT HOME, C PROGRAMMERS. 




5202




 





 





 





 





 





 



   




5203




 





 





 





 





 





 



  sub reduce (&@) { 




5204




 





 





 





 





 





 



    my ($proc, $first, @rest) = @_; 




5205




 





 





 





 





 





 



    return $first if @rest == 0; 




5206




 





 





 





 





 





 



    local ($a, $b) = ($first, reduce($proc, @rest)); 




5207




 





 





 





 





 





 



    return $proc->(); 




5208




 





 





 





 





 





 



  } 




5209




 





 





 





 





 





 



   




5210




 





 





 





 





 





 



 Many functions can then be implemented with very little code. Such as: 




5211




 





 





 





 





 





 



   




5212




 





 





 





 





 





 



  sub mean { (reduce {$a + $b} @_) / @_ } 




5213




 





 





 





 





 





 



   




5214




 





 





 





 





 





 



 =cut 




5215




 





 





 





 





 





 



   




5216




 





 





 





 





 





 



 sub reduce (&@) { 




5217



  
0
  




 





 




  
0
  



  
1
  




0



   my ($proc, $first, @rest) = @_; 




5218



  
0
  



  
  0
  




 





 





 





0



   return $first if @rest == 0; 




5219




28





 





 




  
28
  




 





135865



   no warnings; 




 




28





 





 





 





 





61



   




 




28





 





 





 





 





32373



   




5220



  
0
  




 





 





 





 





0



   local ($a, $b) = ($first, reduce($proc, @rest)); 




5221



  
0
  




 





 





 





 





0



   return $proc->(); 




5222




 





 





 





 





 





 



 } 




5223




 





 





 





 





 





 



   




5224




 





 





 





 





 





 



   




5225




 





 





 





 





 





 



 =head2 pivot 




5226




 





 





 





 





 





 



   




5227




 





 





 





 





 





 



 Resembles the pivot table function in Excel. 




5228




 





 





 





 





 





 



   




5229




 





 





 





 





 





 



 C is used to spread out a slim and long table to a visually improved layout. 




5230




 





 





 





 





 





 



   




5231




 





 





 





 





 





 



 For instance spreading out the results of C-selects from SQL: 




5232




 





 





 





 





 





 



   




5233




 





 





 





 





 





 



  pivot( arrayref, columnname1, columnname2, ...) 




5234




 





 





 





 





 





 



   




5235




 





 





 





 





 





 



  pivot( ref_to_array_of_arrayrefs, @list_of_names_to_down_fields ) 




5236




 





 





 





 





 





 



   




5237




 





 





 





 





 





 



 The first argument is a ref to a two dimensional table. 




5238




 





 





 





 





 





 



   




5239




 





 





 





 





 





 



 The rest of the arguments is a list which also signals the number of 




5240




 





 





 





 





 





 



 columns from left in each row that is ending up to the left of the 




5241




 





 





 





 





 





 



 data table, the rest ends up at the top and the last element of 




5242




 





 





 





 





 





 



 each row ends up as data. 




5243




 





 





 





 





 





 



   




5244




 





 





 





 





 





 



                    top1 top1 top1 top1 




5245




 





 





 





 





 





 



  left1 left2 left3 top2 top2 top2 top2 




5246




 





 





 





 





 





 



  ----- ----- ----- ---- ---- ---- ---- 




5247




 





 





 





 





 





 



                    data data data data 




5248




 





 





 





 





 





 



                    data data data data 




5249




 





 





 





 





 





 



                    data data data data 




5250




 





 





 





 





 





 



   




5251




 





 





 





 





 





 



 Example: 




5252




 





 





 





 





 





 



   




5253




 





 





 





 





 





 



  my @table=( 




5254




 





 





 





 





 





 



                ["1997","Gerd", "Weight", "Summer",66], 




5255




 





 





 





 





 





 



                ["1997","Gerd", "Height", "Summer",170], 




5256




 





 





 





 





 





 



                ["1997","Per",  "Weight", "Summer",75], 




5257




 





 





 





 





 





 



                ["1997","Per",  "Height", "Summer",182], 




5258




 





 





 





 





 





 



                ["1997","Hilde","Weight", "Summer",62], 




5259




 





 





 





 





 





 



                ["1997","Hilde","Height", "Summer",168], 




5260




 





 





 





 





 





 



                ["1997","Tone", "Weight", "Summer",70], 




5261




 





 





 





 





 





 



   




5262




 





 





 





 





 





 



                ["1997","Gerd", "Weight", "Winter",64], 




5263




 





 





 





 





 





 



                ["1997","Gerd", "Height", "Winter",158], 




5264




 





 





 





 





 





 



                ["1997","Per",  "Weight", "Winter",73], 




5265




 





 





 





 





 





 



                ["1997","Per",  "Height", "Winter",180], 




5266




 





 





 





 





 





 



                ["1997","Hilde","Weight", "Winter",61], 




5267




 





 





 





 





 





 



                ["1997","Hilde","Height", "Winter",164], 




5268




 





 





 





 





 





 



                ["1997","Tone", "Weight", "Winter",69], 




5269




 





 





 





 





 





 



   




5270




 





 





 





 





 





 



                ["1998","Gerd", "Weight", "Summer",64], 




5271




 





 





 





 





 





 



                ["1998","Gerd", "Height", "Summer",171], 




5272




 





 





 





 





 





 



                ["1998","Per",  "Weight", "Summer",76], 




5273




 





 





 





 





 





 



                ["1998","Per",  "Height", "Summer",182], 




5274




 





 





 





 





 





 



                ["1998","Hilde","Weight", "Summer",62], 




5275




 





 





 





 





 





 



                ["1998","Hilde","Height", "Summer",168], 




5276




 





 





 





 





 





 



                ["1998","Tone", "Weight", "Summer",70], 




5277




 





 





 





 





 





 



   




5278




 





 





 





 





 





 



                ["1998","Gerd", "Weight", "Winter",64], 




5279




 





 





 





 





 





 



                ["1998","Gerd", "Height", "Winter",171], 




5280




 





 





 





 





 





 



                ["1998","Per",  "Weight", "Winter",74], 




5281




 





 





 





 





 





 



                ["1998","Per",  "Height", "Winter",183], 




5282




 





 





 





 





 





 



                ["1998","Hilde","Weight", "Winter",62], 




5283




 





 





 





 





 





 



                ["1998","Hilde","Height", "Winter",168], 




5284




 





 





 





 





 





 



                ["1998","Tone", "Weight", "Winter",71], 




5285




 





 





 





 





 





 



              ); 




5286




 





 





 





 





 





 



   




5287




 





 





 





 





 





 



 . 




5288




 





 





 





 





 





 



   




5289




 





 





 





 





 





 



  my @reportA=pivot(\@table,"Year","Name"); 




5290




 





 





 





 





 





 



  print "\n\nReport A\n\n".tablestring(\@reportA); 




5291




 





 





 





 





 





 



   




5292




 





 





 





 





 





 



 Will print: 




5293




 





 





 





 





 





 



   




5294




 





 





 





 





 





 



  Report A 




5295




 





 





 





 





 





 



   




5296




 





 





 





 





 





 



  Year Name  Height Height Weight Weight 




5297




 





 





 





 





 





 



             Summer Winter Summer Winter 




5298




 





 





 





 





 





 



  ---- ----- ------ ------ ------ ------ 




5299




 





 





 





 





 





 



  1997 Gerd  170    158    66     64 




5300




 





 





 





 





 





 



  1997 Hilde 168    164    62     61 




5301




 





 





 





 





 





 



  1997 Per   182    180    75     73 




5302




 





 





 





 





 





 



  1997 Tone                70     69 




5303




 





 





 





 





 





 



  1998 Gerd  171    171    64     64 




5304




 





 





 





 





 





 



  1998 Hilde 168    168    62     62 




5305




 





 





 





 





 





 



  1998 Per   182    183    76     74 




5306




 





 





 





 





 





 



  1998 Tone                70     71 




5307




 





 





 





 





 





 



   




5308




 





 





 





 





 





 



 . 




5309




 





 





 





 





 





 



   




5310




 





 





 





 





 





 



  my @reportB=pivot([map{$_=[@$_[0,3,2,1,4]]}(@t=@table)],"Year","Season"); 




5311




 





 





 





 





 





 



  print "\n\nReport B\n\n".tablestring(\@reportB); 




5312




 





 





 





 





 





 



   




5313




 





 





 





 





 





 



 Will print: 




5314




 





 





 





 





 





 



   




5315




 





 





 





 





 





 



  Report B 




5316




 





 





 





 





 





 



   




5317




 





 





 





 





 





 



  Year Season Height Height Height Weight Weight Weight Weight 




5318




 





 





 





 





 





 



              Gerd   Hilde  Per    Gerd   Hilde  Per    Tone 




5319




 





 





 





 





 





 



  ---- ------ ------ ------ -----  -----  ------ ------ ------ 




5320




 





 





 





 





 





 



  1997 Summer 170    168    182    66     62     75     70 




5321




 





 





 





 





 





 



  1997 Winter 158    164    180    64     61     73     69 




5322




 





 





 





 





 





 



  1998 Summer 171    168    182    64     62     76     70 




5323




 





 





 





 





 





 



  1998 Winter 171    168    183    64     62     74     71 




5324




 





 





 





 





 





 



   




5325




 





 





 





 





 





 



 . 




5326




 





 





 





 





 





 



   




5327




 





 





 





 





 





 



  my @reportC=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name","Attributt"); 




5328




 





 





 





 





 





 



  print "\n\nReport C\n\n".tablestring(\@reportC); 




5329




 





 





 





 





 





 



   




5330




 





 





 





 





 





 



 Will print: 




5331




 





 





 





 





 





 



   




5332




 





 





 





 





 





 



  Report C 




5333




 





 





 





 





 





 



   




5334




 





 





 





 





 





 



  Name  Attributt 1997   1997   1998   1998 




5335




 





 





 





 





 





 



                  Summer Winter Summer Winter 




5336




 





 





 





 





 





 



  ----- --------- ------ ------ ------ ------ 




5337




 





 





 





 





 





 



  Gerd  Height     170    158    171    171 




5338




 





 





 





 





 





 



  Gerd  Weight      66     64     64     64 




5339




 





 





 





 





 





 



  Hilde Height     168    164    168    168 




5340




 





 





 





 





 





 



  Hilde Weight      62     61     62     62 




5341




 





 





 





 





 





 



  Per   Height     182    180    182    183 




5342




 





 





 





 





 





 



  Per   Weight      75     73     76     74 




5343




 





 





 





 





 





 



  Tone  Weight      70     69     70     71 




5344




 





 





 





 





 





 



   




5345




 





 





 





 





 





 



 . 




5346




 





 





 





 





 





 



   




5347




 





 





 





 





 





 



  my @reportD=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name"); 




5348




 





 





 





 





 





 



  print "\n\nReport D\n\n".tablestring(\@reportD); 




5349




 





 





 





 





 





 



   




5350




 





 





 





 





 





 



 Will print: 




5351




 





 





 





 





 





 



   




5352




 





 





 





 





 





 



  Report D 




5353




 





 





 





 





 





 



   




5354




 





 





 





 





 





 



  Name  Height Height Height Height Weight Weight Weight Weight 




5355




 





 





 





 





 





 



        1997   1997   1998   1998   1997   1997   1998   1998 




5356




 





 





 





 





 





 



        Summer Winter Summer Winter Summer Winter Summer Winter 




5357




 





 





 





 





 





 



  ----- ------ ------ ------ ------ ------ ------ ------ ------ 




5358




 





 





 





 





 





 



  Gerd  170    158    171    171    66     64     64     64 




5359




 





 





 





 





 





 



  Hilde 168    164    168    168    62     61     62     62 




5360




 





 





 





 





 





 



  Per   182    180    182    183    75     73     76     74 




5361




 





 





 





 





 





 



  Tone                              70     69     70     71 




5362




 





 





 





 





 





 



   




5363




 





 





 





 





 





 



 Options: 




5364




 





 





 





 





 





 



   




5365




 





 





 





 





 





 



 Options to sort differently and show sums and percents are available. (...MORE DOC ON THAT LATER...) 




5366




 





 





 





 





 





 



   




5367




 





 





 





 





 





 



 See also L 




5368




 





 





 





 





 





 



   




5369




 





 





 





 





 





 



 =cut 




5370




 





 





 





 





 





 



   




5371




 





 





 





 





 





 



 sub pivot { 




5372




4





 





 




  
4
  



  
1
  




11



   my($tabref,@vertikalefelt)=@_; 




5373




4




  
 50
  




 





 





 





15



   my %opt=ref($vertikalefelt[-1]) eq 'HASH' ? %{pop(@vertikalefelt)} : (); 




 



  
0
  




 





 





 





 





0



   




5374




4




  
 50
  




 





 





 





16



   my $opt_sum=1 if $opt{sum}; 




5375




4




  
 50
  



  
  0
  




 





 





8



   my $opt_pro=exists $opt{prosent}?$opt{prosent}||0:undef; 




5376




4





 




  
 50
  




 





 





23



   my $sortsub          = $opt{'sortsub'}          || \&_sortsub; 




5377




4





 




  
 33
  




 





 





18



   my $sortsub_bortover = $opt{'sortsub_bortover'} || $sortsub; 




5378




4





 




  
 33
  




 





 





29



   my $sortsub_nedover  = $opt{'sortsub_nedover'}  || $sortsub; 




5379




 





 





 





 





 





 



   #print serialize(\%opt,'opt'); 




5380




 





 





 





 





 





 



   #print serialize(\$opt_pro,'opt_pro'); 




5381




4





 





 





 





 





7



   my $antned=0+@vertikalefelt; 




5382




4





 





 





 





 





7



   my $bakerst=-1+@{$$tabref[0]}; 




 




4





 





 





 





 





10



   




5383




4





 





 





 





 





5



   my(%h,%feltfinnes,%sum); 




5384




 





 





 





 





 





 



   #print "Bakerst<$bakerst>\n"; 




5385




4





 





 





 





 





9



   for(@$tabref){ 




5386




112





 





 





 





 





256



     my $rad=join($;,@$_[0..($antned-1)]); 




5387




112





 





 





 





 





222



     my $felt=join($;,@$_[$antned..($bakerst-1)]); 




5388




112





 





 





 





 





150



     my $verdi=$$_[$bakerst]; 




5389




112




  
 50
  




 





 





 





240



     length($rad) or $rad=' '; 




5390




112




  
 50
  




 





 





 





185



     length($felt) or $felt=' '; 




5391




112





 





 





 





 





227



     $h{$rad}{$felt}=$verdi; 




5392




112





 





 





 





 





239



     $h{$rad}{"%$felt"}=$verdi; 




5393




112




  
 50
  



  
 33
  




 





 





411



     if($opt_sum or defined $opt_pro){ 




5394



  
0
  




 





 





 





 





0



       $h{$rad}{Sum}+=$verdi; 




5395



  
0
  




 





 





 





 





0



       $sum{$felt}+=$verdi; 




5396



  
0
  




 





 





 





 





0



       $sum{Sum}+=$verdi; 




5397




 





 





 





 





 





 



     } 




5398




112





 





 





 





 





164



     $feltfinnes{$felt}++; 




5399




112




  
 50
  




 





 





 





319



     $feltfinnes{"%$felt"}++ if $opt_pro; 




5400




 





 





 





 





 





 



   } 




5401




4





 





 





 





 





26



   my @feltfinnes = sort $sortsub_bortover keys%feltfinnes; 




5402




4




  
 50
  




 





 





 





12



   push @feltfinnes, "Sum" if $opt_sum; 




5403




4





 





 





 





 





8



   my @t=([@vertikalefelt,map{replace($_,$;,"\n")}@feltfinnes]); 




 




23





 





 





 





 





42



   




5404




 





 





 





 





 





 



   #print serialize(\@feltfinnes,'feltfinnes'); 




5405




 





 





 





 





 





 



   #print serialize(\%h,'h'); 




5406




 





 





 





 





 





 



   #print "H = ".join(", ",sort _sortsub keys%h)."\n"; 




5407




4





 





 





 





 





18



   for my $rad (sort $sortsub_nedover keys(%h)){ 




5408




 





 





 





 





 





 



     my @rad=(split($;,$rad), 




5409




 





 





 





 





 





 



 	     map{ 




5410




23




  
 50
  



  
 33
  




 





 





154



 	       if(/^\%/ and defined $opt_pro){ 




 




120





 





 





 





 





309



   




5411



  
0
  




 





 





 





 





0



 		 my $sum=$h{$rad}{Sum}; 




5412



  
0
  




 





 





 





 





0



 		 my $verdi=$h{$rad}{$_}; 




5413



  
0
  



  
  0
  




 





 





 





0



 		 if($sum!=0){ 




5414



  
0
  



  
  0
  




 





 





 





0



 		   defined $verdi 




5415




 





 





 





 





 





 



                    ?sprintf("%*.*f",3+1+$opt_pro,$opt_pro,100*$verdi/$sum) 




5416




 





 





 





 





 





 



 		   :$verdi; 




5417




 





 





 





 





 





 



 		 } 




5418




 





 





 





 





 





 



 		 else{ 




5419



  
0
  



  
  0
  




 





 





 





0



 		   $verdi!=0?"div0":$verdi; 




5420




 





 





 





 





 





 



 		 } 




5421




 





 





 





 





 





 



 	       } 




5422




 





 





 





 





 





 



 	       else{ 




5423




120





 





 





 





 





243



 		 $h{$rad}{$_}; 




5424




 





 





 





 





 





 



 	       } 




5425




 





 





 





 





 





 



 	     } 




5426




 





 





 





 





 





 



 	     @feltfinnes); 




5427




23





 





 





 





 





84



     push(@t,[@rad]); 




5428




 





 





 





 





 





 



   } 




5429




4




  
 50
  




 





 





 





12



   push(@t,"-",["Sum",(map{""}(2..$antned)),map{print "<$_>\n";$sum{$_}}@feltfinnes]) if $opt_sum; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5430




4





 





 





 





 





53



   return @t; 




5431




 





 





 





 





 





 



 } 




5432




 





 





 





 





 





 



   




5433




 





 





 





 





 





 



 # default sortsub for pivot() 




5434




 





 





 





 





 





 



   




5435




 





 





 





 





 





 



 sub _sortsub { 




5436




28





 





 




  
28
  




 





160



   no warnings; 




 




28





 





 





 





 





47



   




 




28





 





 





 





 





13139



   




5437




 





 





 





 





 





 



   #my $c=($a<=>$b)||($a cmp $b); 




5438




 





 





 





 





 





 



   #return $c if $c; 




5439




 





 





 





 





 





 



   #printf "%-30s %-30s  ",replace($a,$;,','),replace($b,$;,','); 




5440




72





 





 




  
72
  




 





489



   my @a=split $;,$a; 




5441




72





 





 





 





 





470



   my @b=split $;,$b; 




5442




72





 





 





 





 





172



   for(0..$#a){ 




5443




110





 





 





 





 





232



     my $c=$a[$_]<=>$b[$_]; 




5444




110




  
100
  



  
 66
  




 





 





398



     return $c if $c and "$a[$_]$b[$_]"!~/[iI][nN][fF]|þ/i; # inf(inity) 




5445




96





 





 





 





 





125



     $c=$a[$_]cmp$b[$_]; 




5446




96




  
100
  




 





 





 





274



     return $c if $c; 




5447




 





 





 





 





 





 



   } 




5448



  
0
  




 





 





 





 





0



   return 0; 




5449




 





 





 





 





 





 



 } 




5450




 





 





 





 





 





 



   




5451




 





 





 





 





 





 



 =head2 tablestring 




5452




 





 





 





 





 





 



   




5453




 





 





 





 





 





 



 B a reference to an array of arrayrefs  -- a two dimensional table of strings and numbers 




5454




 





 





 





 





 





 



   




5455




 





 





 





 





 





 



 B a string containing the textual table -- a string of two or more lines 




5456




 





 





 





 





 





 



   




5457




 





 





 





 





 





 



 The first arrayref in the list refers to a list of either column headings (scalar) 




5458




 





 





 





 





 





 



 or ... (...more later...) 




5459




 





 





 





 





 





 



   




5460




 





 





 





 





 





 



 In this output table: 




5461




 





 





 





 





 





 



   




5462




 





 





 





 





 





 



 - the columns will not be wider than necessary by its widest value (any -tags are removed in every internal width-calculation) 




5463




 





 





 





 





 





 



   




5464




 





 





 





 





 





 



 - multi-lined cell values are handled also 




5465




 





 





 





 





 





 



   




5466




 





 





 





 





 





 



 - and so are html-tags, if the output is to be used inside -tags on a web page. 




5467




 





 





 





 





 





 



   




5468




 





 





 





 





 





 



 - columns with just numeric values are right justified (header row excepted) 




5469




 





 





 





 





 





 



   




5470




 





 





 





 





 





 



 Example: 




5471




 





 





 





 





 





 



   




5472




 





 





 





 





 





 



  print tablestring([ 




5473




 





 





 





 





 





 



    [qw/AA BB CCCC/], 




5474




 





 





 





 





 





 



    [123,23,"d"], 




5475




 





 





 





 





 





 



    [12,23,34], 




5476




 





 





 





 





 





 



    [77,88,99], 




5477




 





 





 





 





 





 



    ["lin\nes",12,"asdff\nfdsa\naa"],[0,22,"adf"] 




5478




 





 





 





 





 





 



  ]); 




5479




 





 





 





 





 





 



   




5480




 





 





 





 





 





 



 Prints this string of 11 lines: 




5481




 





 





 





 





 





 



   




5482




 





 





 





 





 





 



  AA  BB CCCC 




5483




 





 





 





 





 





 



  --- -- ----- 




5484




 





 





 





 





 





 



  123 23 d 




5485




 





 





 





 





 





 



  12  23 34 




5486




 





 





 





 





 





 



  77   8 99 




5487




 





 





 





 





 





 



   




5488




 





 





 





 





 





 



  lin 12 asdff 




5489




 





 





 





 





 





 



  es     fdsa 




5490




 





 





 





 





 





 



         aa 




5491




 





 





 





 





 





 



   




5492




 





 





 





 





 





 



  10  22 adf 




5493




 





 





 





 





 





 



   




5494




 





 





 





 





 





 



 As you can see, rows containing multi-lined cells gets an empty line before and after the row to separate it more clearly. 




5495




 





 





 





 





 





 



   




5496




 





 





 





 





 





 



 =cut 




5497




 





 





 





 





 





 



   




5498




 





 





 





 





 





 



 sub tablestring { 




5499




5





 





 




  
5
  



  
1
  




27



   my $tab=shift; 




5500




5




  
 50
  




 





 





 





14



   my %o=$_[0] ? %{shift()} : (); 




 



  
0
  




 





 





 





 





0



   




5501




5





 





 





 





 





8



   my $fjern_tom=$o{fjern_tomme_kolonner}; 




5502




5





 





 





 





 





8



   my $ikke_space=$o{ikke_space}; 




5503




5





 




  
 50
  




 





 





23



   my $nodup=$o{nodup}||0; 




5504




5





 





 





 





 





7



   my $ikke_hodestrek=$o{ikke_hodestrek}; 




5505




5




  
 50
  




 





 





 





13



   my $pagesize=exists $o{pagesize} ? $o{pagesize}-3 : 9999999; 




5506




5





 





 





 





 





6



   my $venstretvang=$o{venstre}; 




5507




5





 





 





 





 





6



   my(@bredde,@venstre,@hoeyde,@ikketom,@nodup); 




5508




5





 





 





 





 





7



   my $hode=1; 




5509




5





 





 





 





 





8



   my $i=0; 




5510




5





 





 





 





 





8



   my $j; 




5511




5





 





 





 





 





11



   for(@$tab){ 




5512




33





 





 





 





 





34



     $j=0; 




5513




33





 





 





 





 





43



     $hoeyde[$i]=0; 




5514




33





 





 





 





 





37



     my $nodup_rad=$nodup; 




5515




33




  
 50
  




 





 





 





72



     if(ref($_) eq 'ARRAY'){ 




5516




33





 





 





 





 





53



       for(@$_){ 




5517




210





 





 





 





 





272



 	my $celle=$_; 




5518




210





 




  
100
  




 





 





431



 	$bredde[$j]||=0; 




5519




210




  
 50
  



  
 33
  




 





 





582



 	if($nodup_rad and $i>0 and $$tab[$i][$j] eq $$tab[$i-1][$j] || ($nodup_rad=0)){ 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
 33
  




 





 





 



   




5520



  
0
  



  
  0
  




 





 





 





0



 	  $celle=$nodup==1?"":$nodup; 




5521



  
0
  




 





 





 





 





0



 	  $nodup[$i][$j]=1; 




5522




 





 





 





 





 





 



 	} 




5523




 





 





 





 





 





 



 	else{ 




5524




210





 





 





 





 





213



 	  my $hoeyde=0; 




5525




210





 





 





 





 





201



 	  my $bredere; 




5526




28





 





 




  
28
  




 





1335



 	  no warnings; 




 




28





 





 





 





 





1237



   




 




28





 





 





 





 





16611



   




5527




210




  
100
  



  
100
  




 





 





799



 	  $ikketom[$j]=1 if !$hode && length($celle)>0; 




5528




210





 





 





 





 





445



 	  for(split("\n",$celle)){ 




5529




236




  
 50
  




 





 





 





411



 	    $bredere=/




5530




236





 





 





 





 





277



 	    s/<[^>]+>//g; 




5531




236





 





 





 





 





239



 	    $hoeyde++; 




5532




236





 





 





 





 





265



 	    s/>/>/g; 




5533




236





 





 





 





 





258



 	    s/</




5534




236




  
100
  




 





 





 





585



 	    $bredde[$j]=length($_)+1+$bredere if length($_)+1+$bredere>$bredde[$j]; 




5535




236




  
100
  



  
100
  




 





 





1545



 	    $venstre[$j]=1 if $_ && !/^\s*[\-\+]?(\d+|\d*\.\d+)\s*\%?$/ && !$hode; 




 




 





 




  
100
  




 





 





 



   




5536




 





 





 





 





 





 



 	  } 




5537




210




  
100
  



  
 66
  




 





 





614



 	  if( $hoeyde>1 && !$ikke_space){ 




5538




25




  
100
  




 





 





 





53



 	    $hoeyde++ unless $hode; 




5539




25




  
100
  



  
100
  




 





 





69



 	    $hoeyde[$i-1]++ if $i>1 && $hoeyde[$i-1]==1; 




5540




 





 





 





 





 





 



 	  } 




5541




210




  
100
  




 





 





 





477



 	  $hoeyde[$i]=$hoeyde if $hoeyde>$hoeyde[$i]; 




5542




 





 





 





 





 





 



 	} 




5543




210





 





 





 





 





279



 	$j++; 




5544




 





 





 





 





 





 



       } 




5545




 





 





 





 





 





 



     } 




5546




 





 





 





 





 





 



     else{ 




5547



  
0
  




 





 





 





 





0



       $hoeyde[$i]=1; 




5548



  
0
  




 





 





 





 





0



       $ikke_hodestrek=1; 




5549




 





 





 





 





 





 



     } 




5550




33





 





 





 





 





37



     $hode=0; 




5551




33





 





 





 





 





50



     $i++; 




5552




 





 





 





 





 





 



   } 




5553




5





 





 





 





 





9



   $i=$#hoeyde; 




5554




5





 





 





 





 





7



   $j=$#bredde; 




5555




5




  
 50
  



  
 33
  




 





 





24



   if($i==0 or $venstretvang) { @venstre=map{1}(0..$j)                         } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5556




5




  
 50
  




 





 





 





11



   else { for(0..$j){ $venstre[$_]=1 if !$ikketom[$_] }  } 




 




33





 





 





 





 





68



   




5557




5





 





 





 





 





8



   my @tabut; 




5558




5





 





 





 





 





5



   my $rad_startlinje=0; 




5559




5





 





 





 





 





8



   my @overskrift; 




5560




 





 





 





 





 





 



   my $overskrift_forrige; 




5561




5





 





 





 





 





8



   for my $x (0..$i){ 




5562




33




  
 50
  




 





 





 





88



     if($$tab[$x] eq '-'){ 




5563



  
0
  



  
  0
  




 





 





 





0



       my @tegn=map {$$tab[$x-1][$_]=~/\S/?"-":" "} (0..$j); 




 



  
0
  




 





 





 





 





0



   




5564



  
0
  




 





 





 





 





0



       $tabut[$rad_startlinje]=join(" ",map {$tegn[$_] x ($bredde[$_]-1)} (0..$j)); 




 



  
0
  




 





 





 





 





0



   




5565




 





 





 





 





 





 



     } 




5566




 





 





 





 





 





 



     else{ 




5567




33





 





 





 





 





54



       for my $y (0..$j){ 




5568




210




  
 50
  



  
 33
  




 





 





464



 	next if $fjern_tom && !$ikketom[$y]; 




5569




28





 





 




  
28
  




 





1318



 	no warnings; 




 




28





 





 





 





 





49



   




 




28





 





 





 





 





22085



   




5570




 





 





 





 





 





 



 	 




5571




210




  
  0
  



  
 33
  




 





 





1343



 	my @celle= 




 




 




  
 50
  




 





 





 





 



   




5572




 





 





 





 





 





 



             !$overskrift_forrige&&$nodup&&$nodup[$x][$y] 




5573




 





 





 





 





 





 



 	    ?($nodup>0?():((" " x (($bredde[$y]-length($nodup))/2)).$nodup)) 




5574




 





 





 





 





 





 



             :split("\n",$$tab[$x][$y]); 




5575




210





 





 





 





 





434



 	for(0..($hoeyde[$x]-1)){ 




5576




261





 





 





 





 





310



 	  my $linje=$rad_startlinje+$_; 




5577




261





 




  
100
  




 





 





606



 	  my $txt=shift @celle || ''; 




5578




261




  
100
  



  
100
  




 





 





1489



 	  $txt=sprintf("%*s",$bredde[$y]-1,$txt) if length($txt)>0 && !$venstre[$y] && ($x>0 || $ikke_hodestrek); 




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 66
  




 





 





 



   




5579




261





 





 





 





 





374



 	  $tabut[$linje].=$txt; 




5580




261




  
100
  




 





 





 





431



 	  if($y==$j){ 




5581




42





 





 





 





 





185



 	    $tabut[$linje]=~s/\s+$//; 




5582




 





 





 





 





 





 



 	  } 




5583




 





 





 





 





 





 



 	  else{ 




5584




219





 





 





 





 





223



 	    my $bredere; 




5585




219




  
 50
  




 





 





 





399



 	       $bredere = $txt=~/




5586




219





 





 





 





 





275



 	    $txt=~s/<[^>]+>//g; 




5587




219





 





 





 





 





271



 	    $txt=~s/>/>/g; 




5588




219





 





 





 





 





245



 	    $txt=~s/</




5589




219





 





 





 





 





591



 	    $tabut[$linje].= ' ' x ($bredde[$y]-length($txt)-$bredere); 




5590




 





 





 





 





 





 



 	  } 




5591




 





 





 





 





 





 



 	} 




5592




 





 





 





 





 





 



       } 




5593




 





 





 





 





 





 



     } 




5594




33





 





 





 





 





45



     $rad_startlinje+=$hoeyde[$x]; 




5595




 





 





 





 





 





 



   




5596




 





 





 





 





 





 



     #--lage streker? 




5597




33




  
 50
  




 





 





 





63



     if(not $ikke_hodestrek){ 




5598




33




  
100
  



  
 33
  




 





 





155



       if($x==0){ 




 




 




  
 50
  



  
 33
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




5599




5





 





 





 





 





9



 	for my $y (0..$j){ 




5600




33




  
 50
  



  
 33
  




 





 





64



 	  next if $fjern_tom && !$ikketom[$y]; 




5601




33





 





 





 





 





68



 	  $tabut[$rad_startlinje].=('-' x ($bredde[$y]-1))." "; 




5602




 





 





 





 





 





 



 	} 




5603




5





 





 





 





 





8



 	$rad_startlinje++; 




5604




5





 





 





 





 





15



 	@overskrift=("",@tabut); 




5605




 





 





 





 





 





 



       } 




5606




 





 





 





 





 





 



       elsif( 




5607




 





 





 





 





 





 



 	    $x%$pagesize==0 || $nodup>0&&!$nodup[$x+1][$nodup-1] 




5608




 





 





 





 





 





 



 	    and $x+1<@$tab 




5609




 





 





 





 





 





 



 	    and !$ikke_hodestrek 




5610




 





 





 





 





 





 



 	    ) 




5611




 





 





 





 





 





 



       { 




5612



  
0
  




 





 





 





 





0



 	push(@tabut,@overskrift); 




5613



  
0
  




 





 





 





 





0



 	$rad_startlinje+=@overskrift; 




5614



  
0
  




 





 





 





 





0



 	$overskrift_forrige=1; 




5615




 





 





 





 





 





 



       } 




5616




 





 





 





 





 





 



       else{ 




5617




28





 





 





 





 





52



 	$overskrift_forrige=0; 




5618




 





 





 





 





 





 



       } 




5619




 





 





 





 





 





 



     } 




5620




 





 





 





 





 





 



   }#for x 




5621




5





 





 





 





 





56



   return join("\n",@tabut)."\n"; 




5622




 





 





 





 





 





 



 } 




5623




 





 





 





 





 





 



   




5624




 





 





 





 





 





 



 =head2 serialize 




5625




 





 





 





 





 





 



   




5626




 





 





 





 





 





 



 Returns a data structure as a string. See also C 




5627




 





 





 





 





 





 



 (serialize was created long time ago before Data::Dumper appeared on 




5628




 





 





 





 





 





 



 CPAN, before CPAN even...) 




5629




 





 





 





 





 





 



   




5630




 





 





 





 





 





 



 B One to four arguments. 




5631




 





 





 





 





 





 



   




5632




 





 





 





 





 





 



 First argument: A reference to the structure you want. 




5633




 





 





 





 





 





 



   




5634




 





 





 





 





 





 



 Second argument: (optional) The name the structure will get in the output string. 




5635




 





 





 





 





 





 



 If second argument is missing or is undef or '', it will get no name in the output. 




5636




 





 





 





 





 





 



   




5637




 





 





 





 





 





 



 Third argument: (optional) The string that is returned is also put 




5638




 





 





 





 





 





 



 into a created file with the name given in this argument.  Putting a 




5639




 





 





 





 





 





 



 C<< > >> char in from of the filename will append that file 




5640




 





 





 





 





 





 



 instead. Use C<''> or C to not write to a file if you want to 




5641




 





 





 





 





 





 



 use a fourth argument. 




5642




 





 





 





 





 





 



   




5643




 





 





 





 





 





 



 Fourth argument: (optional) A number signalling the depth on which newlines is used in the output. 




5644




 





 





 





 





 





 



 The default is infinite (some big number) so no extra newlines are output. 




5645




 





 





 





 





 





 



   




5646




 





 





 





 





 





 



 B A string containing the perl-code definition that makes that data structure. 




5647




 





 





 





 





 





 



 The input reference (first input argument) can be to an array, hash or a string. 




5648




 





 





 





 





 





 



 Those can contain other refs and strings in a deep data structure. 




5649




 





 





 





 





 





 



   




5650




 





 





 





 





 





 



 Limitations: 




5651




 





 





 





 





 





 



   




5652




 





 





 





 





 





 



 - Code refs are not handled (just returns C) 




5653




 





 





 





 





 





 



   




5654




 





 





 





 





 





 



 - Regex, class refs and circular recursive structures are also not handled. 




5655




 





 





 





 





 





 



   




5656




 





 





 





 





 





 



 B 




5657




 





 





 





 





 





 



   




5658




 





 





 





 





 





 



   $a = 'test'; 




5659




 





 





 





 





 





 



   @b = (1,2,3); 




5660




 





 





 





 





 





 



   %c = (1=>2, 2=>3, 3=>5, 4=>7, 5=>11); 




5661




 





 





 





 





 





 



   %d = (1=>2, 2=>3, 3=>\5, 4=>7, 5=>11, 6=>[13,17,19,{1,2,3,'asdf\'\\\''}],7=>'x'); 




5662




 





 





 





 





 





 



   print serialize(\$a,'a'); 




5663




 





 





 





 





 





 



   print serialize(\@b,'tab'); 




5664




 





 





 





 





 





 



   print serialize(\%c,'c'); 




5665




 





 





 





 





 





 



   print serialize(\%d,'d'); 




5666




 





 





 





 





 





 



   print serialize(\("test'n roll",'brb "brb"')); 




5667




 





 





 





 





 





 



   print serialize(\%d,'d',undef,1); 




5668




 





 





 





 





 





 



   




5669




 





 





 





 





 





 



 Prints accordingly: 




5670




 





 





 





 





 





 



   




5671




 





 





 





 





 





 



  $a='test'; 




5672




 





 





 





 





 





 



  @tab=('1','2','3'); 




5673




 





 





 





 





 





 



  %c=('1','2','2','3','3','5','4','7','5','11'); 




5674




 





 





 





 





 





 



  %d=('1'=>'2','2'=>'3','3'=>\'5','4'=>'7','5'=>'11','6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}]); 




5675




 





 





 





 





 





 



  ('test\'n roll','brb "brb"'); 




5676




 





 





 





 





 





 



  %d=('1'=>'2', 




5677




 





 





 





 





 





 



  '2'=>'3', 




5678




 





 





 





 





 





 



  '3'=>\'5', 




5679




 





 





 





 





 





 



  '4'=>'7', 




5680




 





 





 





 





 





 



  '5'=>'11', 




5681




 





 





 





 





 





 



  '6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}], 




5682




 





 





 





 





 





 



  '7'=>'x'); 




5683




 





 





 





 





 





 



   




5684




 





 





 





 





 





 



 Areas of use: 




5685




 





 





 





 





 





 



   




5686




 





 





 





 





 





 



 - Debugging (first and foremost) 




5687




 





 





 





 





 





 



   




5688




 





 





 





 





 





 



 - Storing arrays and hashes and data structures of those on file, database or sending them over the net 




5689




 





 





 





 





 





 



   




5690




 





 





 





 





 





 



 - eval earlier stored string to get back the data structure 




5691




 





 





 





 





 





 



   




5692




 





 





 





 





 





 



 Be aware of the security implications of Cing a perl code string 




5693




 





 





 





 





 





 



 stored somewhere that unauthorized users can change them! You are 




5694




 





 





 





 





 





 



 probably better of using L or L without 




5695




 





 





 





 





 





 



 enabling the CODE-options if you have such security issues. 




5696




 





 





 





 





 





 



 More on decompiling Perl-code: L or L. 




5697




 





 





 





 





 





 



   




5698




 





 





 





 





 





 



 =head2 dserialize 




5699




 





 





 





 





 





 



   




5700




 





 





 





 





 





 



 Debug-serialize, dumping data structures for you to look at. 




5701




 





 





 





 





 





 



   




5702




 





 





 





 





 





 



 Same as C but the output is given a newline every 80th character. 




5703




 





 





 





 





 





 



 (Every 80th or whatever C<$Acme::Tools::Dserialize_width> contains) 




5704




 





 





 





 





 





 



   




5705




 





 





 





 





 





 



 =cut 




5706




 





 





 





 





 





 



   




5707




 





 





 





 





 





 



 our $Dserialize_width=80; 




5708



  
0
  




 




  
  0
  



  
0
  




 





0



 sub _kallstack { my $tilbake=shift||0; my @c; my $ret; $ret.=serialize(\@c,"caller$tilbake") while @c=caller(++$tilbake); $ret } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5709



  
0
  




 





 




  
0
  



  
1
  




0



 sub dserialize{join "\n",serialize(@_)=~/(.{1,$Dserialize_width})/gs} 




5710




 





 





 





 





 





 



 sub serialize { 




5711




28





 





 




  
28
  




 





150



   no warnings; 




 




28





 





 





 





 





48



   




 




28





 





 





 





 





127928



   




5712




1127





 





 




  
1127
  



  
1
  




4775



   my($r,$name,$filename,$level)=@_; 




5713




1127





 




  
100
  




 





 





3033



   my @r=(undef,undef,($level||0)-1); 




5714




1127




  
 50
  




 





 





 





2122



   if($filename){ 




5715



  
0
  



  
  0
  




 





 





 





0



     open my $fh, '>', $filename or croak("FEIL: could not open file $filename\n" . _kallstack()); 




5716



  
0
  




 





 





 





 





0



     my $ret=serialize($r,$name,undef,$level); 




5717



  
0
  




 





 





 





 





0



     print $fh "$ret\n1;\n"; 




5718



  
0
  




 





 





 





 





0



     close($fh); 




5719



  
0
  




 





 





 





 





0



     return $ret; 




5720




 





 





 





 





 





 



   } 




5721




1127




  
100
  




 





 





 





2884



   if(ref($r) eq 'SCALAR'){ 




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




5722




903




  
 50
  




 





 





 





1580



     return "\$$name=".serialize($r,@r).";\n" if $name; 




5723




903




  
100
  




 





 





 





1692



     return "undef" unless defined $$r; 




5724




899





 





 





 





 





1128



     my $ret=$$r; 




5725




899





 





 





 





 





1410



     $ret=~s/\\/\\\\/g; 




5726




899





 





 





 





 





1140



     $ret=~s/\'/\\'/g; 




5727




899





 





 





 





 





2785



     return "'$ret'"; 




5728




 





 





 





 





 





 



   } 




5729




 





 





 





 





 





 



   elsif(ref($r) eq 'ARRAY'){ 




5730




72




  
100
  




 





 





 





163



     return "\@$name=".serialize($r,@r).";\n" if $name; 




5731




70





 





 





 





 





99



     my $ret="("; 




5732




70





 





 





 





 





134



     for(@$r){ 




5733




350





 





 





 





 





819



       $ret.=serialize(\$_,@r).","; 




5734




350




  
100
  




 





 





 





1019



       $ret.="\n" if $level>=0; 




5735




 





 





 





 





 





 



     } 




5736




70





 





 





 





 





237



     $ret=~s/,$//; 




5737




70





 





 





 





 





131



     $ret.=")"; 




5738




70




  
 50
  




 





 





 





144



     $ret.=";\n" if $name; 




5739




70





 





 





 





 





235



     return $ret; 




5740




 





 





 





 





 





 



   } 




5741




 





 





 





 





 





 



   elsif(ref($r) eq 'HASH'){ 




5742




31




  
100
  




 





 





 





250



     return "\%$name=".serialize($r,@r).";\n" if $name; 




5743




21





 





 





 





 





37



     my $ret="("; 




5744




21





 





 





 





 





105



     for(sort keys %$r){ 




5745




73





 





 





 





 





193



       $ret.=serialize(\$_,@r)."=>".serialize(\$$r{$_},@r).","; 




5746




73




  
 50
  




 





 





 





234



       $ret.="\n" if $level>=0; 




5747




 





 





 





 





 





 



     } 




5748




21





 





 





 





 





84



     $ret=~s/,$//; 




5749




21





 





 





 





 





33



     $ret.=")"; 




5750




21




  
 50
  




 





 





 





55



     $ret.=";\n" if $name; 




5751




21





 





 





 





 





132



     return $ret; 




5752




 





 





 





 





 





 



   } 




5753




 





 





 





 





 





 



   elsif(ref($$r) eq 'ARRAY'){ 




5754




48




  
 50
  




 





 





 





92



     return "\@$name=".serialize($r,@r).";\n" if $name; 




5755




48





 





 





 





 





63



     my $ret="["; 




5756




48





 





 





 





 





89



     for(@$$r){ 




5757




100





 





 





 





 





555



       $ret.=serialize(\$_,@r).","; 




5758




100




  
 50
  



  
 33
  




 





 





487



       $ret.="\n" if !defined $level or $level>=0; 




5759




 





 





 





 





 





 



     } 




5760




48





 





 





 





 





133



     $ret=~s/,$//; 




5761




48





 





 





 





 





67



     $ret.="]"; 




5762




48




  
 50
  




 





 





 





89



     $ret.=";\n" if $name; 




5763




48





 





 





 





 





132



     return $ret; 




5764




 





 





 





 





 





 



   } 




5765




 





 





 





 





 





 



   elsif(ref($$r) eq 'HASH'){ 




5766




73




  
 50
  




 





 





 





138



     return "\%$name=".serialize($r,@r).";\n" if $name; 




5767




73





 





 





 





 





107



     my $ret="{"; 




5768




73





 





 





 





 





268



     for(sort keys %$$r){ 




5769




214





 





 





 





 





412



       $ret.=serialize(\$_,@r)."=>".serialize(\$$$r{$_},@r).","; 




5770




214




  
 50
  




 





 





 





598



       $ret.="\n" if $level>=0; 




5771




 





 





 





 





 





 



     } 




5772




73





 





 





 





 





211



     $ret=~s/,$//; 




5773




73





 





 





 





 





93



     $ret.="}"; 




5774




73




  
 50
  




 





 





 





133



     $ret.=";\n" if $name; 




5775




73





 





 





 





 





208



     return $ret; 




5776




 





 





 





 





 





 



   } 




5777




 





 





 





 





 





 



   elsif(ref($$r) eq 'SCALAR'){ 




5778



  
0
  




 





 





 





 





0



     return "\\".serialize($$r,@r); 




5779




 





 





 





 





 





 



   } 




5780




 





 





 





 





 





 



   elsif(ref($r) eq 'LVALUE'){ 




5781



  
0
  




 





 





 





 





0



     my $s="$$r"; 




5782



  
0
  




 





 





 





 





0



     return serialize(\$s,@r); 




5783




 





 





 





 





 





 



   } 




5784




 





 





 





 





 





 



   elsif(ref($$r) eq 'CODE'){ 




5785




 





 





 





 





 





 



     #warn "Tried to serialize CODE"; 




5786



  
0
  




 





 





 





 





0



     return 'sub{croak "Can not serialize CODE-references, see perhaps B::Deparse and Storable"}' 




5787




 





 





 





 





 





 



   } 




5788




 





 





 





 





 





 



   elsif(ref($$r) eq 'GLOB'){ 




5789



  
0
  




 





 





 





 





0



     warn "Tried to serialize a GLOB"; 




5790



  
0
  




 





 





 





 





0



     return '\*STDERR' 




5791




 





 





 





 





 





 



   } 




5792




 





 





 





 





 





 



   else{ 




5793



  
0
  




 





 





 





 





0



     my $tilbake; 




5794



  
0
  




 





 





 





 





0



     my($pakke,$fil,$linje,$sub,$hasargs,$wantarray); 




5795



  
0
  




 




  
  0
  




 





 





0



       ($pakke,$fil,$linje,$sub,$hasargs,$wantarray)=caller($tilbake++) until $sub ne 'serialize' || $tilbake>20; 




5796



  
0
  




 





 





 





 





0



     croak("serialize() argument should be reference!\n". 




5797




 





 





 





 





 





 



         "\$r=$r\n". 




5798




 





 





 





 





 





 



         "ref(\$r)   = ".ref($r)."\n". 




5799




 





 





 





 





 





 



         "ref(\$\$r) = ".ref($$r)."\n". 




5800




 





 





 





 





 





 



         "kallstack:\n". _kallstack()); 




5801




 





 





 





 





 





 



   } 




5802




 





 





 





 





 





 



 } 




5803




 





 





 





 





 





 



   




5804




 





 





 





 





 





 



 =head2 srlz 




5805




 





 





 





 





 





 



   




5806




 





 





 





 





 





 



 Synonym to L, but remove unnecessary single quote chars around 




5807




 





 





 





 





 





 



 C<< \w+ >>-keys and number values (except numbers with leading zeros). Example: 




5808




 





 





 





 





 





 



   




5809




 





 





 





 





 





 



 serialize: 




5810




 





 





 





 





 





 



   




5811




 





 





 





 





 





 



  %s=('action'=>{'del'=>'0','ins'=>'0','upd'=>'18'},'post'=>'1348','pre'=>'1348', 




5812




 





 





 





 





 





 



      'updcol'=>{'Laerestednr'=>'18','Studietypenr'=>'18','Undervisningssted'=>'7','Url'=>'11'}, 




5813




 





 





 





 





 





 



      'where'=>'where 1=1'); 




5814




 





 





 





 





 





 



   




5815




 





 





 





 





 





 



 srlz: 




5816




 





 





 





 





 





 



   




5817




 





 





 





 





 





 



  %s=(action=>{del=>0,ins=>0,upd=>18},post=>1348,pre=>1348, 




5818




 





 





 





 





 





 



      updcol=>{Laerestednr=>18,Studietypenr=>18,Undervisningssted=>7,Url=>11}, 




5819




 





 





 





 





 





 



      where=>'where 1=1'); 




5820




 





 





 





 





 





 



   




5821




 





 





 





 





 





 



 Todo: update L to do the same, but in the right way. (For now  




5822




 





 





 





 





 





 



 srlz runs the string from serialize() through two C<< s/// >>, this will break 




5823




 





 





 





 





 





 



 in certain cases). L will be kept as a synonym (or the other way around). 




5824




 





 





 





 





 





 



   




5825




 





 





 





 





 





 



 =cut 




5826




 





 





 





 





 





 



   




5827




 





 





 





 





 





 



 sub srlz { 




5828



  
0
  




 





 




  
0
  



  
1
  




0



   my $s=serialize(@_); 




5829



  
0
  




 





 





 





 





0



   $s=~s,'(\w+)'=>,$1=>,g; 




5830



  
0
  




 





 





 





 





0



   $s=~s,=>'((0|[1-9]\d*)(\.\d+)?(e[-+]?\d+)?)',=>$1,gi;  #ikke ledende null!    hm                                                                                                                                           




5831



  
0
  




 





 





 





 





0



   $s; 




5832




 





 





 





 





 





 



 } 




5833




 





 





 





 





 





 



   




5834




 





 





 





 





 





 



   




5835




 





 





 





 





 





 



 =head2 sys 




5836




 





 





 





 





 





 



   




5837




 





 





 





 





 





 



 Call instead of C if you want C (Carp::croak) when something fails. 




5838




 





 





 





 





 





 



   




5839




 





 





 





 





 





 



  sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" } 




5840




 





 





 





 





 





 



   




5841




 





 





 





 





 





 



   




5842




 





 





 





 





 





 



 =cut 




5843




 





 





 





 





 





 



   




5844



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5845




 





 





 





 





 





 



   




5846




 





 





 





 





 





 



 =head2 recursed 




5847




 





 





 





 





 





 



   




5848




 





 





 





 





 





 



 Returns true or false (actually 1 or 0) depending on whether the 




5849




 





 





 





 





 





 



 current sub has been called by itself or not. 




5850




 





 





 





 





 





 



   




5851




 





 





 





 





 





 



  sub xyz 




5852




 





 





 





 





 





 



  { 




5853




 





 





 





 





 





 



     xyz() if not recursed; 




5854




 





 





 





 





 





 



   




5855




 





 





 





 





 





 



  } 




5856




 





 





 





 





 





 



   




5857




 





 





 





 





 





 



 =cut 




5858




 





 





 





 





 





 



   




5859



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub recursed {(caller(1))[3] eq (caller(2))[3]?1:0} 




5860




 





 





 





 





 





 



   




5861




 





 





 





 





 





 



 =head2 ed 




5862




 





 





 





 





 





 



   




5863




 





 





 





 





 





 



 String editor commands 




5864




 





 





 





 





 





 



   




5865




 





 





 





 





 





 



  literals:               a-z 0-9 space 




5866




 





 





 





 





 





 



  move cursor:            FBAEPN MF MB ME 




5867




 





 





 





 





 





 



  delete:                 D Md 




5868




 





 





 





 





 





 



  up/low/camelcase word   U L C 




5869




 





 





 





 





 





 



  backspace:              - 




5870




 





 





 





 





 





 



  search:                 S 




5871




 





 





 





 





 





 



  return/enter:           R 




5872




 





 





 





 





 





 



  meta/esc/alt:           M 




5873




 





 





 





 





 





 



  shift:                  T 




5874




 





 





 





 





 





 



  cut to eol:             K 




5875




 





 





 





 





 





 



  caps lock:              C 




5876




 





 





 





 





 





 



  yank:                   Y 




5877




 





 





 





 





 





 



  start and end:          < > 




5878




 





 





 





 





 





 



  macro start/end/play:   { } ! 




5879




 





 





 





 





 





 



  times for next cmd:     M  (i.e. M24a inserts 24 a's) 




5880




 





 





 





 





 





 



   




5881




 





 





 





 





 





 



 (TODO: alfa...and more docs needed) 




5882




 





 





 





 





 





 



   




5883




 





 





 





 





 





 



 =cut 




5884




 





 





 





 





 





 



   




5885




 





 





 





 





 





 



 our $Edcursor; 




5886




 





 





 





 





 





 



 sub ed { 




5887




18





 





 




  
18
  



  
1
  




4351



   my($s,$cs,$p,$buf)=@_; #string, commands, point (or cursor) 




5888




18




  
100
  




 





 





 





58



   return $$s=ed($$s,$cs,$p,$buf) if ref($s); 




5889




17





 





 





 





 





33



   my($sh,$cl,$m,$t,@m)=(0,0,0,undef); 




5890




17





 





 





 





 





37



   while(length($cs)){ 




5891




121





 





 





 





 





148



     my $n = 0; 




5892




121




  
 50
  




 





 





 





489



     my $c = $cs=~s,^(M\d+|M.|""|".+?"|S.+?R|\\.|.),,s ? $1 : die; 




5893




121





 




  
100
  




 





 





402



     $p = curb($p||0,0,length($s)); 




5894




121




  
100
  




 





 





 





234



     if(defined$t){$cs="".($c x $t).$cs;$t=undef;next} 




 




1





 





 





 





 





5



   




 




1





 





 





 





 





2



   




 




1





 





 





 





 





3



   




5895




120





 





 




  
81
  




 





375



     my $add=sub{substr($s,$p,0)=$_[0];$p+=length($_[0])}; 




 




81





 





 





 





 





141



   




 




81





 





 





 





 





144



   




5896




120




  
 50
  




 





 





 





821



     if   ($c =~ /^([a-z0-9 ])/){ &$add($sh^$cl?uc($1):$1); $sh=0 } 




 




65




  
100
  




 





 





 





208



   




 




65




  
100
  




 





 





 





80



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




5897




1





 





 





 





 





3



     elsif($c =~ /^"(.+)"$/)    { &$add($1) } 




5898




1





 





 





 





 





4



     elsif($c =~ /^\\(.)/)      { &$add($1) } 




5899




2




  
 50
  




 





 





 





6



     elsif($c =~ /^S(.+)R/)     { my $i=index($s,$1,$p);$p=$i+length($1) if $i>=0 } 




 




2





 





 





 





 





8



   




5900




1





 





 





 





 





3



     elsif($c =~ /^M(\d+)/)     { $t=$1; next } 




 




1





 





 





 





 





6



   




5901




2





 





 





 





 





3



     elsif($c eq 'F') { $p++ } 




5902




1





 





 





 





 





2



     elsif($c eq 'B') { $p-- } 




5903



  
0
  




 




  
  0
  




 





 





0



     elsif($c eq 'A') { $p-- while $p>0 and substr($s,$p-1,2)!~/^\n/ } 




5904




8




  
 50
  




 





 





 





39



     elsif($c eq 'E') { substr($s,$p)=~/(.*)/ and $p+=length($1) } 




5905




4





 





 





 





 





5



     elsif($c eq 'D') { substr($s,$p,1)='' } 




5906




3




  
 50
  




 





 





 





21



     elsif($c eq 'MD'){ substr($s,$p)=~s/^(\W*\w+)// and $buf=$1 } 




5907




3




  
 50
  




 





 





 





17



     elsif($c eq 'MF'){ substr($s,$p)=~/(\W*\w+)/ and $p+=length($1) } 




5908




3




  
 50
  




 





 





 





19



     elsif($c eq 'MB'){ substr($s,0,$p)=~/(\w+\W*)$/ and $p-=length($1) } 




5909



  
0
  



  
  0
  




 





 





 





0



     elsif($c eq '-') { substr($s,--$p,1)='' if $p } 




5910




5




  
 50
  




 





 





 





37



     elsif($c eq 'M-'){ substr($s,0,$p)=~s/(\w+\W*)$// and $p-=length($buf=$1)} 




5911




3




  
 50
  




 





 





 





19



     elsif($c eq 'K') { substr($s,$p)=~s/(\S.+|\s*?\n)// and $buf=$1 } 




5912




12





 





 





 





 





26



     elsif($c eq 'Y') { &$add($buf) } 




5913



  
0
  




 





 





 





 





0



     elsif($c eq 'U') { substr($s,$p)=~s/(\W*)(\w+)/$1\U$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5914



  
0
  




 





 





 





 





0



     elsif($c eq 'L') { substr($s,$p)=~s/(\W*)(\w+)/$1\L$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5915



  
0
  




 





 





 





 





0



     elsif($c eq 'C') { substr($s,$p)=~s/(\W*)(\w+)/$1\u\L$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5916



  
0
  




 





 





 





 





0



     elsif($c eq '<') { $p=0 } 




5917



  
0
  




 





 





 





 





0



     elsif($c eq '>') { $p=length($s) } 




5918



  
0
  




 





 





 





 





0



     elsif($c eq 'T') { $sh=1 } 




5919



  
0
  




 





 





 





 





0



     elsif($c eq 'C') { $cl^=1 } 




5920




1





 





 





 





 





2



     elsif($c eq '{') { $m=1; @m=() } 




 




1





 





 





 





 





2



   




5921




1





 





 





 





 





2



     elsif($c eq '}') { $m=0 } 




5922




2




  
 50
  



  
 33
  




 





 





20



     elsif($c eq '!') { $m||!@m and die"ed: no macro"; $cs=join("",@m).$cs } 




 




2





 





 





 





 





5



   




5923




2





 





 





 





 





5



     elsif($c eq '""'){ &$add('"') } 




5924



  
0
  




 





 





 





 





0



     else             { croak "ed: Unknown cmd '$c'\n" } 




5925




119




  
100
  



  
100
  




 





 





578



     push @m, $c if $m and $c ne '{'; 




5926




 





 





 





 





 





 



     #warn serialize([$c,$m,$cs],'d'); 




5927




 





 





 





 





 





 



   } 




5928




17





 





 





 





 





20



   $Edcursor=$p; 




5929




17





 





 





 





 





50



   $s; 




5930




 





 





 





 





 





 



 } 




5931




 





 





 





 





 





 



   




5932




 





 





 





 





 





 



   




5933




 





 





 





 





 





 



 #todo: sub unbless eller sub damn 




5934




 





 





 





 





 





 



 #todo: ..se også: use Data::Structure::Util qw/unbless/; 




5935




 





 





 





 





 





 



 #todo: ...og: Acme::Damn sin damn() 




5936




 





 





 





 





 





 



 #todo? sub swap($$) http://www.idg.no/computerworld/article242008.ece 




5937




 





 





 





 





 





 



 #todo? catal 




5938




 





 





 





 





 





 



 #todo?  




5939




 





 





 





 





 





 



 #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); 




5940




 





 





 





 





 





 



   




5941




 





 





 





 





 





 



   




5942




 





 





 





 





 





 



 =head1 JUST FOR FUN 




5943




 





 





 





 





 





 



   




5944




 





 





 





 





 





 



 =head2 brainfu 




5945




 





 





 





 





 





 



   




5946




 





 





 





 





 





 



 B one or two arguments 




5947




 





 





 





 





 





 



   




5948




 





 





 





 





 





 



 First argument: a string, source code of the brainfu 




5949




 





 





 





 





 





 



 language. String containing the eight charachters + - < > [ ] . , 




5950




 





 





 





 





 





 



 Every other char is ignored silently. 




5951




 





 





 





 





 





 



   




5952




 





 





 





 





 





 



 Second argument: if the source code contains commas (,) the second 




5953




 





 





 





 





 





 



 argument is the input characters in a string. 




5954




 





 





 





 





 





 



   




5955




 





 





 





 





 





 



 B The resulting output from the program. 




5956




 





 





 





 





 





 



   




5957




 





 





 





 





 





 



 Example: 




5958




 





 





 





 





 





 



   




5959




 





 





 





 





 





 



  print brainfu(<<"");  #prints "Hallo Verden!\n" 




5960




 





 





 





 





 





 



  ++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>---.+++++++++++..+++.>++.<<++++++++++++++ 




5961




 





 





 





 





 





 



  .>----------.+++++++++++++.--------------.+.+++++++++.>+.>. 




5962




 





 





 





 





 





 



   




5963




 





 





 





 





 





 



 See L 




5964




 





 





 





 





 





 



   




5965




 





 





 





 





 





 



 =head2 brainfu2perl 




5966




 





 





 





 





 





 



   




5967




 





 





 





 





 





 



 Just as L but instead it return the perl code to which the 




5968




 





 





 





 





 





 



 brainfu code is translated. Just C<< eval() >> this perl code to run. 




5969




 





 





 





 





 





 



   




5970




 





 





 





 





 





 



 Example: 




5971




 





 





 





 





 





 



   




5972




 





 





 





 





 





 



  print brainfu2perl('>++++++++[<++++++++>-]<++++++++.>++++++[<++++++>-]<---.'); 




5973




 





 





 





 





 





 



   




5974




 





 





 





 





 





 



 Prints this string: 




5975




 





 





 





 





 





 



   




5976




 





 





 





 





 





 



  my($c,$o,@b)=(0); sub out{$o.=chr($b[$c]) for 1..$_[0]||1} 




5977




 





 





 





 





 





 



  ++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5978




 





 





 





 





 





 



  while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5979




 





 





 





 





 





 



  ++$b[$c];++$c;--$b[$c];}--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5980




 





 





 





 





 





 



  ++$b[$c];++$b[$c];out;++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5981




 





 





 





 





 





 



  while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$c;--$b[$c];} 




5982




 





 





 





 





 





 



  --$c;--$b[$c];--$b[$c];--$b[$c];out;$o; 




5983




 





 





 





 





 





 



   




5984




 





 





 





 





 





 



 =head2 brainfu2perl_optimized 




5985




 





 





 





 





 





 



   




5986




 





 





 





 





 





 



 Just as L but optimizes the perl code. The same 




5987




 





 





 





 





 





 



 example as above with brainfu2perl_optimized returns this equivalent 




5988




 





 





 





 





 





 



 but shorter perl code: 




5989




 





 





 





 





 





 



   




5990




 





 





 





 





 





 



  $b[++$c]+=8;while($b[$c]){$b[--$c]+=8;--$b[++$c]}$b[--$c]+=8;out;$b[++$c]+=6; 




5991




 





 





 





 





 





 



  while($b[$c]){$b[--$c]+=6;--$b[++$c]}$b[--$c]-=3;out;$o; 




5992




 





 





 





 





 





 



   




5993




 





 





 





 





 





 



 =cut 




5994




 





 





 





 





 





 



   




5995




3





 





 




  
3
  



  
1
  




691



 sub brainfu { eval(brainfu2perl(@_)) } 




5996




 





 





 





 





 





 



   




5997




 





 





 





 





 





 



 sub brainfu2perl { 




5998




6





 





 




  
6
  



  
1
  




21



   my($bf,$inp)=@_; 




5999




17





 





 





 





 





76



   my $perl='my($c,$inp,$o,@b)=(0,\''.$inp.'\'); no warnings; sub out{$o.=chr($b[$c]) for 1..$_[0]||1}'."\n"; 




6000




3




  
100
  



  
 66
  




 





 





22



   $perl.='sub inp{$inp=~s/(.)//s and $b[$c]=ord($1)}'."\n" if $inp and $bf=~/,/; 




6001




3




  
100
  




 





 





 





918



   $perl.=join("",map/\+/?'++$b[$c];':/\-/?'--$b[$c];':/\[/?'while($b[$c]){':/\]/?'}':/>/?'++$c;':/




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




6002




3





 





 





 





 





309



   $perl; 




6003




 





 





 





 





 





 



 } 




6004




 





 





 





 





 





 



   




6005




 





 





 





 





 





 



 sub brainfu2perl_optimized { 




6006



  
0
  




 





 




  
14
  



  
1
  




0



   my $perl=brainfu2perl(@_); 




6007



  
0
  




 





 





 





 





0



   $perl=~s{(((\+|\-)\3\$b\[\$c\];){2,})}{ '$b[$c]'.$3.'='.(grep/b/,split//,$1).';' }gisex; 




 



  
0
  




 





 





 





 





0



   




6008



  
0
  




 





 





 





 





0



   1 while $perl=~s/\+\+\$c;\-\-\$c;//g + $perl=~s/\-\-\$c;\+\+\$c;//g; 




6009



  
0
  




 





 





 





 





0



   $perl=~s{((([\-\+])\3\$c;){2,})}{"\$c$3=".(grep/c/,split//,$1).';'}gisex; 




 



  
0
  




 





 





 





 





0



   




6010



  
0
  



  
  0
  




 





 





 





0



   $perl=~s{((\+\+|\-\-)\$c;([^;{}]+;))}{my($o,$s)=($2,$3);$s=~s/\$c/$o\$c/?$s:$1}ge; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6011



  
0
  




 





 





 





 





0



   $perl=~s/\$c(\-|\+)=(\d+);(\+\+|\-\-)\$b\[\$c\]/$3.'$b[$c'.$1.'='.$2.'];'/ge; 




 



  
0
  




 





 





 





 





0



   




6012



  
0
  




 





 





 





 





0



   $perl=~s{((out;){2,})}{'out('.(grep/o/,split//,$1).');'}ge; 




 



  
0
  




 





 





 





 





0



   




6013



  
0
  




 





 





 





 





0



   $perl=~s/;}/}/g;$perl=~s/;+/;/g; 




 



  
0
  




 





 





 





 





0



   




6014



  
0
  




 





 





 





 





0



   $perl; 




6015




 





 





 





 





 





 



 } 




6016




 





 





 





 





 





 



   




6017




 





 





 





 





 





 



   




6018




 





 





 





 





 





 



 =head1 BLOOM FILTER SUBROUTINES 




6019




 





 





 





 





 





 



   




6020




 





 





 





 





 





 



 Bloom filters can be used to check whether an element (a string) is a 




6021




 





 





 





 





 





 



 member of a large set using much less memory or disk space than other 




6022




 





 





 





 





 





 



 data structures. Trading speed and accuracy for memory usage. While 




6023




 





 





 





 





 





 



 risking false positives, Bloom filters have a very strong space 




6024




 





 





 





 





 





 



 advantage over other data structures for representing sets. 




6025




 





 





 





 





 





 



   




6026




 





 





 





 





 





 



 In the example below, a set of 100000 phone numbers (or any string of 




6027




 





 





 





 





 





 



 any length) can be "stored" in just 91230 bytes if you accept that you 




6028




 





 





 





 





 





 



 can only check the data structure for existence of a string and accept 




6029




 





 





 





 





 





 



 false positives with an error rate of 0.03 (that is three percent, error 




6030




 





 





 





 





 





 



 rates are given in numbers larger than 0 and smaller than 1). 




6031




 





 





 





 





 





 



   




6032




 





 





 





 





 





 



 You can not retrieve the strings in the set without using "brute 




6033




 





 





 





 





 





 



 force" methods and even then you would get slightly more strings than 




6034




 





 





 





 





 





 



 you put in because of the error rate inaccuracy. 




6035




 





 





 





 





 





 



   




6036




 





 





 





 





 





 



 Bloom Filters have many uses. 




6037




 





 





 





 





 





 



   




6038




 





 





 





 





 





 



 See also: L 




6039




 





 





 





 





 





 



   




6040




 





 





 





 





 





 



 See also: L 




6041




 





 





 





 





 





 



   




6042




 





 





 





 





 





 



 =head2 bfinit 




6043




 





 





 





 





 





 



   




6044




 





 





 





 





 





 



 Initialize a new Bloom Filter: 




6045




 





 





 





 





 





 



   




6046




 





 





 





 





 





 



   my $bf = bfinit( error_rate=>0.01, capacity=>100000 ); 




6047




 





 





 





 





 





 



   




6048




 





 





 





 





 





 



 The same: 




6049




 





 





 





 





 





 



   




6050




 





 





 





 





 





 



   my $bf = bfinit( 0.01, 100000 ); 




6051




 





 





 





 





 





 



   




6052




 





 





 





 





 





 



 since two arguments is interpreted as error_rate and capacity accordingly. 




6053




 





 





 





 





 





 



   




6054




 





 





 





 





 





 



   




6055




 





 





 





 





 





 



 =head2 bfadd 




6056




 





 





 





 





 





 



   




6057




 





 





 





 





 





 



   bfadd($bf, $_) for @phone_numbers;   # Adding strings one at a time 




6058




 





 





 





 





 





 



   




6059




 





 





 





 





 





 



   bfadd($bf, @phone_numbers);          # ...or all at once (faster) 




6060




 





 





 





 





 





 



   




6061




 





 





 





 





 





 



 Returns 1 on success. Dies (croaks) if more strings than capacity is added. 




6062




 





 





 





 





 





 



   




6063




 





 





 





 





 





 



 =head2 bfcheck 




6064




 





 





 





 





 





 



   




6065




 





 





 





 





 





 



   my $phone_number="97713246"; 




6066




 





 





 





 





 





 



   if ( bfcheck($bf, $phone_number) ) { 




6067




 





 





 





 





 





 



     print "Yes, $phone_number was PROBABLY added\n"; 




6068




 





 





 





 





 





 



   } 




6069




 





 





 





 





 





 



   else{ 




6070




 





 





 





 





 





 



     print "No, $phone_number was DEFINITELY NOT added\n"; 




6071




 





 





 





 





 





 



   } 




6072




 





 





 





 





 





 



   




6073




 





 





 





 





 





 



 Returns true if C<$phone_number> exists in C<@phone_numbers>. 




6074




 





 





 





 





 





 



   




6075




 





 





 





 





 





 



 Returns false most of the times, but sometimes true*), if C<$phone_number> doesn't exists in C<@phone_numbers>. 




6076




 





 





 





 





 





 



   




6077




 





 





 





 





 





 



 *) This is called a false positive. 




6078




 





 





 





 





 





 



   




6079




 





 





 





 





 





 



 Checking more than one key: 




6080




 





 





 





 





 





 



   




6081




 





 





 





 





 





 



  @bools = bfcheck($bf, @keys);          # or ... 




6082




 





 





 





 





 





 



  @bools = bfcheck($bf, \@keys);         # better, uses less memory if @keys is large 




6083




 





 





 





 





 





 



   




6084




 





 





 





 





 





 



 Returns an array the same size as @keys where each element is true or false accordingly. 




6085




 





 





 





 





 





 



   




6086




 





 





 





 





 





 



 =head2 bfgrep 




6087




 





 





 





 





 





 



   




6088




 





 





 





 





 





 



 Same as C except it returns the keys that exists in the bloom filter 




6089




 





 





 





 





 





 



   




6090




 





 





 





 





 





 



  @found = bfgrep($bf, @keys);           # or ... 




6091




 





 





 





 





 





 



  @found = bfgrep($bf, \@keys);          # better, uses less memory if @keys is large, or ... 




6092




 





 





 





 





 





 



  @found = grep bfcheck($bf,$_), @keys;  # same but slower 




6093




 





 





 





 





 





 



   




6094




 





 





 





 





 





 



 =head2 bfgrepnot 




6095




 





 





 





 





 





 



   




6096




 





 





 





 





 





 



 Same as C except it returns the keys that do NOT exists in the bloom filter: 




6097




 





 





 





 





 





 



   




6098




 





 





 





 





 





 



  @not_found = bfgrepnot($bf, @keys);          # or ... 




6099




 





 





 





 





 





 



  @not_found = bfgrepnot($bf, \@keys);         # better, uses less memory if @keys is large, or ... 




6100




 





 





 





 





 





 



  @not_found = grep !bfcheck($bf,$_), @keys);  # same but slower 




6101




 





 





 





 





 





 



   




6102




 





 





 





 





 





 



 =head2 bfdelete 




6103




 





 





 





 





 





 



   




6104




 





 





 





 





 





 



 Deletes from a counting bloom filter. 




6105




 





 





 





 





 





 



   




6106




 





 





 





 





 





 



 To enable deleting be sure to initialize the bloom filter with the 




6107




 





 





 





 





 





 



 numeric C argument. The number of bits could be 2 or 3*) 




6108




 





 





 





 





 





 



 for small filters with a small capacity (a small number of keys), but 




6109




 





 





 





 





 





 



 setting the number to 4 ensures that even very large filters with very 




6110




 





 





 





 





 





 



 small error rates would not overflow. 




6111




 





 





 





 





 





 



   




6112




 





 





 





 





 





 



 *) Acme::Tools do not currently support C<< counting_bits => 3 >> so 4 




6113




 





 





 





 





 





 



 and 8 are the only practical alternatives where 8 is almost always overkill. 




6114




 





 





 





 





 





 



   




6115




 





 





 





 





 





 



  my $bf=bfinit( 




6116




 





 





 





 





 





 



    error_rate    => 0.001, 




6117




 





 





 





 





 





 



    capacity      => 10000000, 




6118




 





 





 





 





 





 



    counting_bits => 4              # power of 2, that is 2, 4, 8, 16 or 32 




6119




 





 





 





 





 





 



  ); 




6120




 





 





 





 





 





 



  bfadd(   $bf, @unique_phone_numbers); 




6121




 





 





 





 





 





 



  bfdelete($bf, @unique_phone_numbers); 




6122




 





 





 





 





 





 



   




6123




 





 





 





 





 





 



 Example: examine the frequency of the counters with 4 bit counters and 4 million keys: 




6124




 





 





 





 





 





 



   




6125




 





 





 





 





 





 



  my $bf=bfinit( error_rate=>0.001, capacity=>4e6, counting_bits=>4 ); 




6126




 





 





 





 





 





 



  bfadd($bf,[1e3*$_+1 .. 1e3*($_+1)]) for 0..4000-1;  # adding 4 million keys one thousand at a time 




6127




 





 





 





 





 





 



  my %c; $c{vec($$bf{filter},$_,$$bf{counting_bits})}++ for 0..$$bf{filterlength}-1; 




6128




 





 





 





 





 





 



  printf "%8d counters = %d\n",$c{$_},$_ for sort{$a<=>$b}keys%c; 




6129




 





 





 





 





 





 



   




6130




 





 





 





 





 





 



 The output: 




6131




 





 





 





 





 





 



   




6132




 





 





 





 





 





 



  28689562 counters = 0 




6133




 





 





 





 





 





 



  19947673 counters = 1 




6134




 





 





 





 





 





 



   6941082 counters = 2 




6135




 





 





 





 





 





 



   1608250 counters = 3 




6136




 





 





 





 





 





 



    280107 counters = 4 




6137




 





 





 





 





 





 



     38859 counters = 5 




6138




 





 





 





 





 





 



      4533 counters = 6 




6139




 





 





 





 





 





 



       445 counters = 7 




6140




 





 





 





 





 





 



        46 counters = 8 




6141




 





 





 





 





 





 



         1 counters = 9 




6142




 





 





 





 





 





 



   




6143




 





 





 





 





 





 



 Even after the error_rate is changed from 0.001 to a percent of that, 0.00001, the limit of 16 (4 bits) is still far away: 




6144




 





 





 





 





 





 



   




6145




 





 





 





 





 





 



  47162242 counters = 0 




6146




 





 





 





 





 





 



  33457237 counters = 1 




6147




 





 





 





 





 





 



  11865217 counters = 2 




6148




 





 





 





 





 





 



   2804447 counters = 3 




6149




 





 





 





 





 





 



    497308 counters = 4 




6150




 





 





 





 





 





 



     70608 counters = 5 




6151




 





 





 





 





 





 



      8359 counters = 6 




6152




 





 





 





 





 





 



       858 counters = 7 




6153




 





 





 





 





 





 



        65 counters = 8 




6154




 





 





 





 





 





 



         4 counters = 9 




6155




 





 





 





 





 





 



   




6156




 





 





 





 





 





 



 In algorithmic terms the number of bits needed is C.  Thats why 4 bits (counters up 




6157




 





 





 





 





 





 



 to 15) is "always" good enough except for extremely large capasities or extremely small error rates. 




6158




 





 





 





 





 





 



 (Except when adding the same key many times, which should be avoided, and Acme::Tools::bfadd do not 




6159




 





 





 





 





 





 



 check for that, perhaps in future versions). 




6160




 





 





 





 





 





 



   




6161




 





 





 





 





 





 



 Bloom filters of the counting type are not very space efficient: The tables above shows that 84%-85% 




6162




 





 





 





 





 





 



 of the counters are 0 or 1. This means most bits are zero-bits. This doesn't have to be a problem if 




6163




 





 





 





 





 





 



 a counting bloom filter is used to be sent over slow networks because they are very compressable by 




6164




 





 





 





 





 





 



 common compression tools like I or L and such. 




6165




 





 





 





 





 





 



   




6166




 





 





 





 





 





 



 Deletion of non-existing keys makes C die (croak). 




6167




 





 





 





 





 





 



   




6168




 





 





 





 





 





 



 =head2 bfdelete 




6169




 





 





 





 





 





 



   




6170




 





 





 





 





 





 



 Deletes from a counting bloom filter: 




6171




 





 





 





 





 





 



   




6172




 





 





 





 





 





 



  bfdelete($bf, @keys); 




6173




 





 





 





 





 





 



  bfdelete($bf, \@keys); 




6174




 





 





 





 





 





 



   




6175




 





 





 





 





 





 



 Returns C<$bf> after deletion. 




6176




 





 





 





 





 





 



   




6177




 





 





 





 





 





 



 Croaks (dies) on deleting a non-existing key or deleting from an previouly overflown counter in a counting bloom filter. 




6178




 





 





 





 





 





 



   




6179




 





 





 





 





 





 



 =head2 bfaddbf 




6180




 





 





 





 





 





 



   




6181




 





 





 





 





 





 



 Adds another bloom filter to a bloom filter. 




6182




 





 





 





 





 





 



   




6183




 





 





 





 





 





 



 Bloom filters has the proberty that bit-wise I-ing the bit-filters 




6184




 





 





 





 





 





 



 of two filters with the same capacity and the same number and type of 




6185




 





 





 





 





 





 



 hash functions, adds the filters: 




6186




 





 





 





 





 





 



   




6187




 





 





 





 





 





 



   my $bf1=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[1..500]); 




6188




 





 





 





 





 





 



   my $bf2=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[501..1000]); 




6189




 





 





 





 





 





 



   




6190




 





 





 





 





 





 



   bfaddbf($bf1,$bf2); 




6191




 





 





 





 





 





 



   




6192




 





 





 





 





 





 



   print "Yes!" if bfgrep($bf1, 1..1000) == 1000; 




6193




 





 





 





 





 





 



   




6194




 





 





 





 





 





 



 Prints yes since C now returns an array of all the 1000 elements. 




6195




 





 





 





 





 





 



   




6196




 





 





 





 





 





 



 Croaks if the filters are of different dimensions. 




6197




 





 





 





 





 





 



   




6198




 





 





 





 





 





 



 Works for counting bloom filters as well (C<< counting_bits=>4 >> e.g.) 




6199




 





 





 





 





 





 



   




6200




 





 





 





 





 





 



 =head2 bfsum 




6201




 





 





 





 





 





 



   




6202




 





 





 





 





 





 



 Returns the number of 1's in the filter. 




6203




 





 





 





 





 





 



   




6204




 





 





 





 





 





 



  my $percent=100*bfsum($bf)/$$bf{filterlength}; 




6205




 





 





 





 





 





 



  printf "The filter is %.1f%% filled\n",$percent; #prints 50.0% or so if filled to capacity 




6206




 





 





 





 





 





 



   




6207




 





 





 





 





 





 



 Sums the counters for counting bloom filters (much slower than for non counting). 




6208




 





 





 





 





 





 



   




6209




 





 





 





 





 





 



 =head2 bfdimensions 




6210




 





 





 





 





 





 



   




6211




 





 





 





 





 





 



 Input, two numeric arguments: Capacity and error_rate. 




6212




 





 





 





 





 





 



   




6213




 





 





 





 





 





 



 Outputs an array of two numbers: m and k. 




6214




 





 





 





 





 





 



   




6215




 





 





 





 





 





 



   m = - n * log(p) / log(2)**2   # n = capacity, m = bits in filter (divide by 8 to get bytes) 




6216




 





 





 





 





 





 



   k = log(1/p) / log(2)          # p = error_rate, uses perls internal log() with base e (2.718) 




6217




 





 





 





 





 





 



   




6218




 





 





 





 





 





 



 ...that is: m = the best number of bits in the filter and k = the best 




6219




 





 





 





 





 





 



 number of hash functions optimized for the given capacity (n) and 




6220




 





 





 





 





 





 



 error_rate (p). Note that k is a dependent only of the error_rate.  At 




6221




 





 





 





 





 





 



 about two percent error rate the bloom filter needs just the same 




6222




 





 





 





 





 





 



 number of bytes as the number of keys. 




6223




 





 





 





 





 





 



   




6224




 





 





 





 





 





 



  Storage (bytes): 




6225




 





 





 





 





 





 



  Capacity      Error-rate  Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate 




6226




 





 





 





 





 





 



                0.000000001 0.00000001 0.0000001  0.000001   0.00001    0.0001     0.001      0.01       0.02141585 0.1        0.5        0.99 




6227




 





 





 





 





 





 



  ------------- ----------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- 




6228




 





 





 





 





 





 



             10 54.48       48.49      42.5       36.51      30.52      24.53      18.53      12.54      10.56      6.553      2.366      0.5886 




6229




 





 





 





 





 





 



            100 539.7       479.8      419.9      360        300.1      240.2      180.3      120.4      100.6      60.47      18.6       0.824 




6230




 





 





 





 





 





 



           1000 5392        4793       4194       3595       2996       2397       1798       1199       1001       599.6      180.9      3.177 




6231




 





 





 





 





 





 



          10000 5.392e+04   4.793e+04  4.194e+04  3.594e+04  2.995e+04  2.396e+04  1.797e+04  1.198e+04  1e+04      5991       1804       26.71 




6232




 





 





 





 





 





 



         100000 5.392e+05   4.793e+05  4.193e+05  3.594e+05  2.995e+05  2.396e+05  1.797e+05  1.198e+05  1e+05      5.991e+04  1.803e+04  262 




6233




 





 





 





 





 





 



        1000000 5.392e+06   4.793e+06  4.193e+06  3.594e+06  2.995e+06  2.396e+06  1.797e+06  1.198e+06  1e+06      5.991e+05  1.803e+05  2615 




6234




 





 





 





 





 





 



       10000000 5.392e+07   4.793e+07  4.193e+07  3.594e+07  2.995e+07  2.396e+07  1.797e+07  1.198e+07  1e+07      5.991e+06  1.803e+06  2.615e+04 




6235




 





 





 





 





 





 



      100000000 5.392e+08   4.793e+08  4.193e+08  3.594e+08  2.995e+08  2.396e+08  1.797e+08  1.198e+08  1e+08      5.991e+07  1.803e+07  2.615e+05 




6236




 





 





 





 





 





 



     1000000000 5.392e+09   4.793e+09  4.193e+09  3.594e+09  2.995e+09  2.396e+09  1.797e+09  1.198e+09  1e+09      5.991e+08  1.803e+08  2.615e+06 




6237




 





 





 





 





 





 



    10000000000 5.392e+10   4.793e+10  4.193e+10  3.594e+10  2.995e+10  2.396e+10  1.797e+10  1.198e+10  1e+10      5.991e+09  1.803e+09  2.615e+07 




6238




 





 





 





 





 





 



   100000000000 5.392e+11   4.793e+11  4.193e+11  3.594e+11  2.995e+11  2.396e+11  1.797e+11  1.198e+11  1e+11      5.991e+10  1.803e+10  2.615e+08 




6239




 





 





 





 





 





 



  1000000000000 5.392e+12   4.793e+12  4.193e+12  3.594e+12  2.995e+12  2.396e+12  1.797e+12  1.198e+12  1e+12      5.991e+11  1.803e+11  2.615e+09 




6240




 





 





 





 





 





 



   




6241




 





 





 





 





 





 



  Error rate:               0.99   Hash functions:  1 




6242




 





 





 





 





 





 



  Error rate:                0.5   Hash functions:  1 




6243




 





 





 





 





 





 



  Error rate:                0.1   Hash functions:  3 




6244




 





 





 





 





 





 



  Error rate: 0.0214158522653385   Hash functions:  6 




6245




 





 





 





 





 





 



  Error rate:               0.01   Hash functions:  7 




6246




 





 





 





 





 





 



  Error rate:              0.001   Hash functions: 10 




6247




 





 





 





 





 





 



  Error rate:             0.0001   Hash functions: 13 




6248




 





 





 





 





 





 



  Error rate:            0.00001   Hash functions: 17 




6249




 





 





 





 





 





 



  Error rate:           0.000001   Hash functions: 20 




6250




 





 





 





 





 





 



  Error rate:          0.0000001   Hash functions: 23 




6251




 





 





 





 





 





 



  Error rate:         0.00000001   Hash functions: 27 




6252




 





 





 





 





 





 



  Error rate:        0.000000001   Hash functions: 30 




6253




 





 





 





 





 





 



   




6254




 





 





 





 





 





 



 =head2 bfstore 




6255




 





 





 





 





 





 



   




6256




 





 





 





 





 





 



 Storing and retrieving bloom filters to and from disk uses Ls C and C. This: 




6257




 





 





 





 





 





 



   




6258




 





 





 





 





 





 



  bfstore($bf,'filename.bf'); 




6259




 





 





 





 





 





 



   




6260




 





 





 





 





 





 



 It the same as: 




6261




 





 





 





 





 





 



   




6262




 





 





 





 





 





 



  use Storable qw(store retrieve); 




6263




 





 





 





 





 





 



  ... 




6264




 





 





 





 





 





 



  store($bf,'filename.bf'); 




6265




 





 





 





 





 





 



   




6266




 





 





 





 





 





 



 =head2 bfretrieve 




6267




 





 





 





 





 





 



   




6268




 





 





 





 





 





 



 This: 




6269




 





 





 





 





 





 



   




6270




 





 





 





 





 





 



  my $bf=bfretrieve('filename.bf'); 




6271




 





 





 





 





 





 



   




6272




 





 





 





 





 





 



 Or this: 




6273




 





 





 





 





 





 



   




6274




 





 





 





 





 





 



  my $bf=bfinit('filename.bf'); 




6275




 





 





 





 





 





 



   




6276




 





 





 





 





 





 



 Is the same as: 




6277




 





 





 





 





 





 



   




6278




 





 





 





 





 





 



  use Storable qw(store retrieve); 




6279




 





 





 





 





 





 



  my $bf=retrieve('filename.bf'); 




6280




 





 





 





 





 





 



   




6281




 





 





 





 





 





 



 =head2 bfclone 




6282




 





 





 





 





 





 



   




6283




 





 





 





 





 





 



 Deep copies the bloom filter data structure. (Which btw is not very deep, two levels at most) 




6284




 





 





 





 





 





 



   




6285




 





 





 





 





 





 



 This: 




6286




 





 





 





 





 





 



   




6287




 





 





 





 





 





 



  my $bfc = bfclone($bf); 




6288




 





 





 





 





 





 



   




6289




 





 





 





 





 





 



 Works just as: 




6290




 





 





 





 





 





 



   




6291




 





 





 





 





 





 



  use Storable; 




6292




 





 





 





 





 





 



  my $bfc=Storable::dclone($bf); 




6293




 





 





 





 





 





 



   




6294




 





 





 





 





 





 



 =head2 Object oriented interface to bloom filters 




6295




 





 





 





 





 





 



   




6296




 





 





 





 





 





 



  use Acme::Tools; 




6297




 





 





 





 





 





 



  my $bf=new Acme::Tools::BloomFilter(0.1,1000); # the same as bfinit, see bfinit above 




6298




 





 





 





 





 





 



  print ref($bf),"\n";                           # prints Acme::Tools::BloomFilter 




6299




 





 





 





 





 





 



  $bf->add(@keys); 




6300




 





 





 





 





 





 



  $bf->check($keys[0]) and print "ok\n";         # prints ok 




6301




 





 





 





 





 





 



  $bf->grep(\@keys)==@keys and print "ok\n";     # prints ok 




6302




 





 





 





 





 





 



  $bf->store('filename.bf'); 




6303




 





 





 





 





 





 



  my $bf2=bfretrieve('filename.bf'); 




6304




 





 





 





 





 





 



  $bf2->check($keys[0]) and print "ok\n";        # still ok 




6305




 





 





 





 





 





 



   




6306




 





 





 





 





 





 



  $bf2=$bf->clone(); 




6307




 





 





 





 





 





 



   




6308




 





 





 





 





 





 



 To instantiate a previously stored bloom filter: 




6309




 





 





 





 





 





 



   




6310




 





 





 





 





 





 



  my $bf = Acme::Tools::BloomFilter->new( '/path/to/stored/bloomfilter.bf' ); 




6311




 





 





 





 





 





 



   




6312




 





 





 





 





 





 



 The o.o. interface has the same methods as the C-subs without the 




6313




 





 





 





 





 





 



 C-prefix in the names. The C is not available as a 




6314




 





 





 





 





 





 



 method, although C, C and 




6315




 





 





 





 





 





 



 C are synonyms. 




6316




 





 





 





 





 





 



   




6317




 





 





 





 





 





 



 =head2 Internals and speed 




6318




 





 





 





 





 





 



   




6319




 





 





 





 





 





 



 The internal hash-functions are C<< md5( "$key$salt" ) >> from L. 




6320




 





 





 





 





 





 



   




6321




 





 





 





 





 





 



 Since C returns 128 bits and most medium to large sized bloom 




6322




 





 





 





 





 





 



 filters need only a 32 bit hash function, the result from md5() are 




6323




 





 





 





 





 





 



 split (C-ed) into 4 parts 32 bits each and are treated as if 4 




6324




 





 





 





 





 





 



 hash functions was called at once (speedup). Using different salts to 




6325




 





 





 





 





 





 



 the key on each md5 results in different hash functions. 




6326




 





 





 





 





 





 



   




6327




 





 





 





 





 





 



 Digest::SHA512 would have been even better since it returns more bits, 




6328




 





 





 





 





 





 



 if it werent for the fact that it's much slower than Digest::MD5. 




6329




 





 





 





 





 





 



   




6330




 





 





 





 





 





 



 String::CRC32::crc32 is faster than Digest::MD5, but not 4 times faster: 




6331




 





 





 





 





 





 



   




6332




 





 





 





 





 





 



  time perl -e'use Digest::MD5 qw(md5);md5("asdf$_") for 1..10e6'       #5.56 sec 




6333




 





 





 





 





 





 



  time perl -e'use String::CRC32;crc32("asdf$_") for 1..10e6'           #2.79 sec, faster but not per bit 




6334




 





 





 





 





 





 



  time perl -e'use Digest::SHA qw(sha512);sha512("asdf$_") for 1..10e6' #36.10 sec, too slow (sha1, sha224, sha256 and sha384 too) 




6335




 





 





 





 





 





 



   




6336




 





 





 





 





 





 



 Md5 seems to be an ok choice both for speed and avoiding collitions due to skewed data keys. 




6337




 





 





 





 





 





 



   




6338




 





 





 





 





 





 



 =head2 Theory and math behind bloom filters 




6339




 





 





 





 





 





 



   




6340




 





 





 





 





 





 



 L 




6341




 





 





 





 





 





 



   




6342




 





 





 





 





 





 



 L 




6343




 





 





 





 





 





 



   




6344




 





 





 





 





 





 



 L 




6345




 





 





 





 





 





 



   




6346




 





 





 





 





 





 



 See also Scaleable Bloom Filters: L (not implemented in Acme::Tools) 




6347




 





 





 





 





 





 



   




6348




 





 





 





 





 





 



 ...and perhaps L 




6349




 





 





 





 





 





 



   




6350




 





 





 





 





 





 



 =cut 




6351




 





 





 





 





 





 



   




6352




 





 





 





 





 





 



 sub bfinit { 




6353




24




  
100
  




 




  
24
  



  
1
  




15650



   return bfretrieve(@_)                             if @_==1; 




6354




23




  
 50
  



  
 66
  




 





 





118



   return bfinit(error_rate=>$_[0], capacity=>$_[1]) if @_==2 and 0<$_[0] and $_[0]<1 and $_[1]>1; 




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 33
  




 





 





 



   




6355




21




  
  0
  



  
 33
  




 





 





61



   return bfinit(error_rate=>$_[1], capacity=>$_[0]) if @_==2 and 0<$_[1] and $_[1]<1 and $_[0]>1; 




 




 





 




  
 33
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




6356




21





 





 





 





 





129



   require Digest::MD5; 




6357




21




  
 50
  




 





 





 





54



   @_%2&&croak "Arguments should be a hash of equal number of keys and values"; 




6358




21





 





 





 





 





85



   my %arg=@_; 




6359




21





 





 





 





 





69



   my @ok_param=qw/error_rate capacity min_hashfuncs max_hashfuncs hashfuncs counting_bits adaptive keys/; 




6360




21





 





 





 





 





84



   my @not_ok=sort(grep!in($_,@ok_param),keys%arg); 




6361




21




  
100
  




 





 





 





271



   croak "Not ok param to bfinit: ".join(", ",@not_ok) if @not_ok; 




6362




20




  
 50
  



  
 66
  




 





 





98



   croak "Not an arrayref in keys-param" if exists $arg{keys} and ref($arg{keys}) ne 'ARRAY'; 




6363




20




  
 50
  




 





 





 





77



   croak "Not implemented counting_bits=$arg{counting_bits}, should be 2, 4, 8, 16 or 32" if !in(nvl($arg{counting_bits},1),1,2,4,8,16,32); 




6364




20




  
 50
  



  
 33
  




 





 





73



   croak "An bloom filters here can not be in both adaptive and counting_bits modes" if $arg{adaptive} and $arg{counting_bits}>1; 




6365




20





 





 





 





 





176



   my $bf={error_rate    => 0.001,  #default p 




6366




 





 





 





 





 





 



 	  capacity      => 100000, #default n 




6367




 





 





 





 





 





 



           min_hashfuncs => 1, 




6368




 





 





 





 





 





 



           max_hashfuncs => 100, 




6369




 





 





 





 





 





 



 	  counting_bits => 1,      #default: not counting filter 




6370




 





 





 





 





 





 



 	  adaptive      => 0, 




6371




 





 





 





 





 





 



 	  %arg,                    #arguments 




6372




 





 





 





 





 





 



 	  key_count     => 0, 




6373




 





 





 





 





 





 



 	  overflow      => {}, 




6374




 





 





 





 





 





 



 	  version       => $Acme::Tools::VERSION, 




6375




 





 





 





 





 





 



 	 }; 




6376




20




  
100
  



  
100
  




 





 





384



   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; 




6377




18




  
 50
  




 





 





 





46



   @$bf{'min_hashfuncs','max_hashfuncs'}=(map$arg{hashfuncs},1..2) if $arg{hashfuncs}; 




6378




18





 





 





 





 





53



   @$bf{'filterlength','hashfuncs'}=bfdimensions($bf); #m and k 




6379




18





 





 





 





 





776



   $$bf{filter}=pack("b*", '0' x ($$bf{filterlength}*$$bf{counting_bits}) ); #hm x   new empty filter 




6380




 





 





 





 





 





 



   $$bf{unpack}= $$bf{filterlength}<=2**16/4 ? "n*" # /4 alleviates skewing if m just slightly < 2**x 




6381




18




  
 50
  




 





 





 





57



                :$$bf{filterlength}<=2**32/4 ? "N*" 




 




 




  
100
  




 





 





 





 



   




6382




 





 





 





 





 





 



                :                              "Q*"; 




6383




18




  
100
  




 





 





 





48



   bfadd($bf,@{$arg{keys}}) if $arg{keys}; 




 




8





 





 





 





 





78



   




6384




16





 





 





 





 





95



   return $bf; 




6385




 





 





 





 





 





 



 } 




6386




 





 





 





 





 





 



 sub bfaddbf { 




6387




2





 





 




  
2
  



  
1
  




5



   my($bf,$bf2)=@_; 




6388




 





 





 





 





 





 



   my $differror=join"\n", 




6389




 





 





 





 





 





 



     map "Property $_ differs ($$bf{$_} vs $$bf2{$_})", 




6390




2





 





 





 





 





42



     grep $$bf{$_} ne $$bf2{$_}, 




6391




 





 





 





 





 





 



     qw/capacity counting_bits adaptive hashfuncs filterlength/; #not error_rate 




6392




2




  
 50
  




 





 





 





8



   croak $differror if $differror; 




6393




2




  
 50
  




 





 





 





9



   croak "Can not add adaptive bloom filters" if $$bf{adaptive}; 




6394




2





 





 





 





 





5



   my $count=$$bf{key_count}+$$bf2{key_count}; 




6395




 





 





 





 





 





 



   croak "Exceeded filter capacity $$bf{key_count} + $$bf2{key_count} = $count > $$bf{capacity}" 




6396




2




  
 50
  




 





 





 





10



     if $count > $$bf{capacity}; 




6397




2





 





 





 





 





7



   $$bf{key_count}+=$$bf2{key_count}; 




6398




2




  
100
  




 





 





 





8



   if($$bf{counting_bits}==1){ 




6399




1





 





 





 





 





5



     $$bf{filter} |= $$bf2{filter}; 




6400




 





 





 





 





 





 



     #$$bf{filter} = $$bf{filter} | $$bf2{filter}; #or-ing 




6401




 





 





 





 





 





 



   } 




6402




 





 





 





 





 





 



   else { 




6403




1





 





 





 





 





4



     my $cb=$$bf{counting_bits}; 




6404




1





 





 





 





 





6



     for(0..$$bf{filterlength}-1){ 




6405




 





 





 





 





 





 



       my $sum= 




6406




 





 





 





 





 





 



       vec($$bf{filter}, $_,$cb)+ 




6407




4793





 





 





 





 





8390



       vec($$bf2{filter},$_,$cb); 




6408




4793




  
 50
  




 





 





 





9761



       if( $sum>2**$cb-1 ){ 




6409



  
0
  




 





 





 





 





0



 	$sum=2**$cb-1; 




6410



  
0
  




 





 





 





 





0



 	$$bf{overflow}{$_}++; 




6411




 





 





 





 





 





 



       } 




6412




4793





 





 





 





 





9283



       vec($$bf{filter}, $_,$cb)=$sum; 




6413




28





 





 




  
28
  




 





187



       no warnings; 




 




28





 





 





 





 





49



   




 




28





 





 





 





 





91601



   




6414




 





 





 





 





 





 



       $$bf{overflow}{$_}+=$$bf2{overflow}{$_} 




6415



  
0
  




 





 





 





 





0



 	and keys(%{$$bf{overflow}})>10 #hmm, arbitrary limit 




6416




 





 





 





 





 





 



 	and croak "Too many overflows, concider doubling counting_bits from $cb to ".(2*$cb) 




6417




4793




  
 50
  



  
  0
  




 





 





13225



 	if exists $$bf2{overflow}{$_}; 




 




 





 




  
  0
  




 





 





 



   




6418




 





 





 





 





 





 



     } 




6419




 





 





 





 





 





 



   } 




6420




2





 





 





 





 





7



   return $bf; #for convenience 




6421




 





 





 





 





 





 



 } 




6422




 





 





 





 





 





 



 sub bfsum { 




6423




8





 





 




  
8
  



  
1
  




40



   my($bf)=@_; 




6424




8




  
100
  




 





 





 





89



   return unpack( "%32b*", $$bf{filter}) if $$bf{counting_bits}==1; 




6425




3





 





 





 





 





8



   my($sum,$cb)=(0,$$bf{counting_bits}); 




6426




3





 





 





 





 





5708



   $sum+=vec($$bf{filter},$_,$cb) for 0..$$bf{filterlength}-1; 




6427




3





 





 





 





 





23



   return $sum; 




6428




 





 





 





 





 





 



 } 




6429




 





 





 





 





 





 



 sub bfadd { 




6430




11





 





 




  
11
  



  
1
  




2573



   require Digest::MD5; 




6431




11





 





 





 





 





876



   my($bf,@keys)=@_; 




6432




11




  
 50
  




 





 





 





34



   return if !@keys; 




6433




11




  
100
  



  
 66
  




 





 





45



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6434




11





 





 





 





 





51



   my($m,$k,$up,$n,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','capacity','counting_bits','adaptive'}; 




6435




11





 





 





 





 





37



   for(@$keysref){ 




6436




 





 





 





 





 





 



     #croak "Key should be scalar" if ref($_); 




6437




15084




  
 50
  



  
 66
  




 





 





40952



     $$bf{key_count} >= $n and croak "Exceeded filter capacity $n"  or  $$bf{key_count}++; 




6438




15083





 





 





 





 





18626



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




15083





 





 





 





 





132284



   




6439




15083




  
100
  



  
 66
  




 





 





51645



     if ($cb==1 and !$adaptive) { # normal bloom filter 




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6440




11110





 





 





 





 





102943



       vec($$bf{filter}, $h[$_] % $m, 1) = 1 for 0..$k-1; 




6441




 





 





 





 





 





 



     } 




6442




 





 





 





 





 





 



     elsif ($cb>1) {                 # counting bloom filter 




6443




3973





 





 





 





 





7256



       for(0..$k-1){ 




6444




11919





 





 





 





 





17176



 	my $pos=$h[$_] % $m; 




6445




 





 





 





 





 





 



 	my $c= 




6446




 





 





 





 





 





 



   	vec($$bf{filter}, $pos, $cb) = 




6447




11919





 





 





 





 





29225



 	vec($$bf{filter}, $pos, $cb) + 1; 




6448




11919




  
100
  




 





 





 





35642



 	if($c==0){ 




6449




26





 





 





 





 





51



 	  vec($$bf{filter}, $pos, $cb) = -1; 




6450




 





 





 





 





 





 



 	  $$bf{overflow}{$pos}++ 




6451




26




  
100
  



  
100
  




 





 





134



 	    and keys(%{$$bf{overflow}})>10 #hmm, arbitrary limit 




 




2





 





 





 





 





244



   




6452




 





 





 





 





 





 



 	    and croak "Too many overflows, concider doubling counting_bits from $cb to ".(2*$cb); 




6453




 





 





 





 





 





 



 	} 




6454




 





 





 





 





 





 



       } 




6455




 





 





 





 





 





 



     } 




6456




 





 





 





 





 





 



     elsif ($adaptive) {             # adaptive bloom filter 




6457



  
0
  




 





 





 





 





0



       my($i,$key,$bit)=(0+@h,$_); 




6458



  
0
  




 





 





 





 





0



       for(0..$$bf{filterlength}-1){ 




6459



  
0
  



  
  0
  




 





 





 





0



 	$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h; 




6460



  
0
  




 





 





 





 





0



 	my $pos=shift(@h) % $m; 




6461



  
0
  




 





 





 





 





0



 	$bit=vec($$bf{filter}, $pos, 1); 




6462



  
0
  




 





 





 





 





0



 	vec($$bf{filter}, $pos, 1)=1; 




6463



  
0
  



  
  0
  



  
  0
  




 





 





0



 	last if $_>=$k-1 and $bit==0; 




6464




 





 





 





 





 





 



       } 




6465




 





 





 





 





 





 



     } 




6466



  
0
  




 





 





 





 





0



     else {croak} 




6467




 





 





 





 





 





 



   } 




6468




9





 





 





 





 





733



   return 1; 




6469




 





 





 





 





 





 



 } 




6470




 





 





 





 





 





 



 sub bfcheck { 




6471




5





 





 




  
5
  



  
1
  




83



   require Digest::MD5; 




6472




5





 





 





 





 





1178



   my($bf,@keys)=@_; 




6473




5




  
 50
  




 





 





 





18



   return if !@keys; 




6474




5




  
 50
  



  
 33
  




 





 





26



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6475




5





 





 





 





 





24



   my($m,$k,$up,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','counting_bits','adaptive'}; 




6476




5





 





 





 





 





12



   my $wa=wantarray(); 




6477




5




  
 50
  




 





 





 





15



   if(!$adaptive){    # normal bloom filter  or  counting bloom filter 




6478




 





 





 





 





 





 



     return map { 




6479




5





 





 





 





 





65



       my $match = 1; # match if every bit is on 




 




24001





 





 





 





 





28811



   




6480




24001





 





 





 





 





28750



       my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




24001





 





 





 





 





222331



   




6481




24001





 




  
100
  




 





 





209677



       vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
100
  




 





 





 



   




6482




24001




  
 50
  




 





 





 





44673



       return $match if !$wa; 




6483




24001





 





 





 





 





51962



       $match; 




6484




 





 





 





 





 





 



     } @$keysref; 




6485




 





 





 





 





 





 



   } 




6486




 





 





 





 





 





 



   else {             # adaptive bloom filter 




6487




 





 





 





 





 





 



     return map { 




6488



  
0
  




 





 





 





 





0



       my($match,$i,$key,$bit,@h)=(1,0,$_); 




 



  
0
  




 





 





 





 





0



   




6489



  
0
  




 





 





 





 





0



       for(0..$$bf{filterlength}-1){ 




6490



  
0
  



  
  0
  




 





 





 





0



 	$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h; 




6491



  
0
  




 





 





 





 





0



 	my $pos=shift(@h) % $m; 




6492



  
0
  




 





 





 





 





0



 	$bit=vec($$bf{filter}, $pos, 1); 




6493



  
0
  



  
  0
  



  
  0
  




 





 





0



 	$match++ if $_ >  $k-1 and $bit==1; 




6494



  
0
  



  
  0
  



  
  0
  




 





 





0



 	$match=0 if $_ <= $k-1 and $bit==0; 




6495



  
0
  



  
  0
  




 





 





 





0



 	last     if $bit==0; 




6496




 





 





 





 





 





 



       } 




6497



  
0
  



  
  0
  




 





 





 





0



       return $match if !$wa; 




6498



  
0
  




 





 





 





 





0



       $match; 




6499




 





 





 





 





 





 



     } @$keysref; 




6500




 





 





 





 





 





 



   } 




6501




 





 





 





 





 





 



 } 




6502




 





 





 





 





 





 



 sub bfgrep { # just a copy of bfcheck with map replaced by grep 




6503




8





 





 




  
8
  



  
1
  




870



   require Digest::MD5; 




6504




8





 





 





 





 





24



   my($bf,@keys)=@_; 




6505




8




  
 50
  




 





 





 





27



   return if !@keys; 




6506




8




  
 50
  



  
 33
  




 





 





65



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6507




8





 





 





 





 





34



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6508




 





 





 





 





 





 



   return grep { 




6509




8





 





 





 





 





29



     my $match = 1; # match if every bit is on 




 




6100





 





 





 





 





7316



   




6510




6100





 





 





 





 





6722



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




6100





 





 





 





 





40807



   




6511




6100





 




  
100
  




 





 





42786



     vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
100
  




 





 





 



   




6512




6100





 





 





 





 





11486



     $match; 




6513




 





 





 





 





 





 



   } @$keysref; 




6514




 





 





 





 





 





 



 } 




6515




 





 





 





 





 





 



 sub bfgrepnot { # just a copy of bfgrep with $match replaced by not $match 




6516




1





 





 




  
1
  



  
1
  




9



   require Digest::MD5; 




6517




1





 





 





 





 





3



   my($bf,@keys)=@_; 




6518




1




  
 50
  




 





 





 





5



   return if !@keys; 




6519




1




  
 50
  



  
 33
  




 





 





16



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6520




1





 





 





 





 





5



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6521




 





 





 





 





 





 



   return grep { 




6522




1





 





 





 





 





5



     my $match = 1; # match if every bit is on 




 




1000





 





 





 





 





1246



   




6523




1000





 





 





 





 





1149



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




1000





 





 





 





 





6814



   




6524




1000





 




  
 50
  




 





 





7027



     vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
 50
  




 





 





 



   




6525




1000





 





 





 





 





2346



     !$match; 




6526




 





 





 





 





 





 



   } @$keysref; 




6527




 





 





 





 





 





 



 } 




6528




 





 





 





 





 





 



 sub bfdelete { 




6529




3





 





 




  
3
  



  
1
  




91



   require Digest::MD5; 




6530




3





 





 





 





 





17



   my($bf,@keys)=@_; 




6531




3




  
 50
  




 





 





 





12



   return if !@keys; 




6532




3




  
100
  



  
100
  




 





 





20



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6533




3





 





 





 





 





11



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6534




3




  
 50
  




 





 





 





8



   croak "Cannot delete from non-counting bloom filter (use counting_bits 4 e.g.)" if $cb==1; 




6535




3





 





 





 





 





7



   for my $key (@$keysref){ 




6536




501





 





 





 





 





537



     my @h; push @h, unpack $up, Digest::MD5::md5($key,0+@h) while @h<$k; 




 




501





 





 





 





 





3437



   




6537




501




  
 50
  



  
 33
  




 





 





1432



     $$bf{key_count}==0 and croak "Deleted all and then some"  or  $$bf{key_count}--; 




6538




501





 





 





 





 





782



     my($ones,$croak,@pos)=(0); 




6539




501





 





 





 





 





925



     for(0..$k-1){ 




6540




1503





 





 





 





 





2149



       my $pos=$h[$_] % $m; 




6541




 





 





 





 





 





 



       my $c= 




6542




1503





 





 





 





 





2267



       vec($$bf{filter}, $pos, $cb); 




6543




1503





 





 





 





 





3127



       vec($$bf{filter}, $pos, $cb)=$c-1; 




6544




1503




  
100
  




 





 





 





3244



       $croak="Cannot delete a non-existing key $key" if $c==0; 




6545




 





 





 





 





 





 



       $croak="Cannot delete with previously overflown position. Try doubleing counting_bits" 




6546




1503




  
 50
  



  
 66
  




 





 





6247



 	if $c==1 and ++$ones and $$bf{overflow}{$pos}; 




 




 





 




  
 66
  




 





 





 



   




6547




 





 





 





 





 





 



     } 




6548




501




  
100
  




 





 





 





1241



     if($croak){ #rollback 




6549




 





 





 





 





 





 



       vec($$bf{filter}, $h[$_] % $m, $cb)= 




6550




1





 





 





 





 





11



       vec($$bf{filter}, $h[$_] % $m, $cb)+1 for 0..$k-1; 




6551




1





 





 





 





 





200



       croak $croak; 




6552




 





 





 





 





 





 



     } 




6553




 





 





 





 





 





 



   } 




6554




2





 





 





 





 





20



   return $bf; 




6555




 





 





 





 





 





 



 } 




6556




 





 





 





 





 





 



 sub bfstore { 




6557




1





 





 




  
1
  



  
1
  




22727



   require Storable; 




6558




1





 





 





 





 





8



   Storable::store(@_); 




6559




 





 





 





 





 





 



 } 




6560




 





 





 





 





 





 



 sub bfretrieve { 




6561




2





 





 




  
2
  



  
1
  




527



   require Storable; 




6562




2





 





 





 





 





11



   my $bf=Storable::retrieve(@_); 




6563




2




  
 50
  




 





 





 





545



   carp  "Retrieved bloom filter was stored in version $$bf{version}, this is version $VERSION" if $$bf{version}>$VERSION; 




6564




2





 





 





 





 





7



   return $bf; 




6565




 





 





 





 





 





 



 } 




6566




 





 





 





 





 





 



 sub bfclone { 




6567




1





 





 




  
1
  



  
1
  




30668



   require Storable; 




6568




1





 





 





 





 





8452



   return Storable::dclone(@_); #could be faster 




6569




 





 





 





 





 





 



 } 




6570




 





 





 





 





 





 



 sub bfdimensions_old { 




6571




 





 





 





 





 





 



   my($n,$p,$mink,$maxk, $k,$flen,$m)= 




6572



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



     @_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'},1) 




 



  
0
  



  
  0
  




 





 





 





0



   




6573




 





 





 





 





 





 



    :@_==2 ? (@_,1,100,1) 




6574




 





 





 





 





 





 



           : croak "Wrong number of arguments (".@_."), should be 2"; 




6575



  
0
  



  
  0
  



  
  0
  




 





 





0



   croak "p ($p) should be > 0 and < 1" if not ( 0<$p && $p<1 ); 




6576



  
0
  




 




  
  0
  




 





 





0



   $m=-1*$_*$n/log(1-$p**(1/$_)) and (!defined $flen or $m<$flen) and ($flen,$k)=($m,$_) for $mink..$maxk; 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




6577



  
0
  




 





 





 





 





0



   $flen = int(1+$flen); 




6578



  
0
  




 





 





 





 





0



   return ($flen,$k); 




6579




 





 





 





 





 





 



 } 




6580




 





 





 





 





 





 



 sub bfdimensions { 




6581




 





 





 





 





 





 



   my($n,$p,$mink,$maxk)= 




6582




18




  
  0
  




 




  
18
  



  
1
  




48



     @_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'}) 




 




18




  
 50
  




 





 





 





52



   




6583




 





 





 





 





 





 



    :@_==2 ? (@_,1,100) 




6584




 





 





 





 





 





 



           : croak "Wrong number of arguments (".@_."), should be 2"; 




6585




18





 





 





 





 





66



   my $k=log(1/$p)/log(2);           # k hash funcs 




6586




18





 





 





 





 





47



   my $m=-$n*log($p)/log(2)**2;      # m bits in filter 




6587




18





 





 





 





 





65



   return ($m+0.5,min($maxk,max($mink,int($k+0.5)))); 




6588




 





 





 





 





 





 



 } 




6589




 





 





 





 





 





 



   




6590




 





 





 





 





 





 



 #crontab -e 




6591




 





 





 





 





 





 



 #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 




6592




 





 





 





 





 





 



   




6593




 





 





 





 





 





 



 sub _update_currency_file { #call from cron 




6594



  
0
  




 




  
  0
  



  
0
  




 





0



   my $fn=shift()||'/var/www/html/currency-rates'; 




6595



  
0
  




 




  
  0
  




 





 





0



   my %exe=map+($_=>"/usr/bin/$_"),qw/curl ci/;-x$_ or die for values %exe; 




 



  
0
  




 





 





 





 





0



   




6596



  
0
  



  
  0
  




 





 





 





0



   open my $F, '>', $fn or die"ERROR: Could not write file $fn ($!)\n"; 




6597



  
0
  




 





 





 





 





0



   print $F "#-- Currency rates ".localtime()." (".time().")\n"; 




6598



  
0
  




 





 





 





 





0



   print $F "#   File generated by Acme::Tools version $VERSION\n"; 




6599



  
0
  




 





 





 





 





0



   print $F "#   Updated every 6th hour on http://calthis.com/currency-rates\n"; 




6600



  
0
  




 





 





 





 





0



   print $F "NOK 1.000000000\n"; 




6601



  
0
  




 





 





 





 





0



   my $amount=1000; 




6602



  
0
  




 





 





 





 





0



   my $data=qx($exe{curl} -s "http://www.x-rates.com/table/?from=NOK&amount=$amount"); 




6603



  
0
  




 





 





 





 





0



   $data=~s,to=([A-Z]{3})(.)>,$2>$1,g; 




6604



  
0
  




 





 





 





 





0



   my @data=ht2t($data,"Alphabetical order"); shift @data; 




 



  
0
  




 





 





 





 





0



   




6605



  
0
  



  
  0
  




 





 





 





0



   @data=map "$$_[1] ".($$_[4]>1e-2?$$_[4]:$$_[2]?sprintf("%.8f",$amount/$$_[2]):0)."\n",@data; 




 




 




  
  0
  




 





 





 





 



   




6606



  
0
  




 





 





 





 





0



   my %data=map split,@data; 




6607



  
0
  




 





 





 





 





0



   my@tc=qx($exe{curl} -s https://btc-e.com/api/3/ticker/btc_usd-ltc_usd)=~/avg.?:(\d+\.?\d*)/g; 




6608



  
0
  




 





 





 





 





0



   push @data,"BTC ".($tc[0]*$data{USD})."\n"; 




6609



  
0
  




 





 





 





 





0



   push @data,"LTC ".($tc[1]*$data{USD})."\n"; 




6610



  
0
  




 





 





 





 





0



   print $F sort(@data); 




6611



  
0
  




 





 





 





 





0



   close($F); 




6612



  
0
  



  
  0
  




 





 





 





0



   qx($exe{ci} -l -m. -d $fn) if -w"$fn,v"; 




6613




 





 





 





 





 





 



 } 




6614




 





 





 





 





 





 



   




6615




 





 





 





 





 





 



 sub ftype { 




6616



  
0
  




 





 




  
0
  



  
0
  




0



   my $f=shift; 




6617



  
0
  



  
  0
  



  
  0
  




 





 





0



   -e $f and 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6618




 





 





 





 





 





 



       -f$f ? 'file'         # -f  File is a plain file. 




6619




 





 





 





 





 





 



      :-d$f ? 'dir'          # -d  File is a directory. 




6620




 





 





 





 





 





 



      :-l$f ? 'symlink'      # -l  File is a symbolic link. 




6621




 





 





 





 





 





 



      :-p$f ? 'pipe'         # -p  File is a named pipe (FIFO), or Filehandle is a pipe. 




6622




 





 





 





 





 





 



      :-S$f ? 'socket'       # -S  File is a socket. 




6623




 





 





 





 





 





 



      :-b$f ? 'blockfile'    # -b  File is a block special file. 




6624




 





 





 





 





 





 



      :-c$f ? 'charfile'     # -c  File is a character special file. 




6625




 





 





 





 





 





 



      :-t$f ? 'ttyfile'      # -t  Filehandle is opened to a tty. 




6626




 





 





 





 





 





 



      :       '' 




6627




 





 





 





 





 





 



   or undef; 




6628




 





 





 





 





 





 



 } 




6629




 





 





 





 





 





 



   




6630




 





 





 





 





 





 



 =head1 COMMANDS 




6631




 





 





 





 





 





 



   




6632




 





 





 





 





 





 



 =head2 install_acme_command_tools 




6633




 





 





 





 





 





 



   




6634




 





 





 





 





 





 



  sudo perl -MAcme::Tools -e install_acme_command_tools 




6635




 





 





 





 





 





 



  Wrote executable /usr/local/bin/conv 




6636




 





 





 





 





 





 



  Wrote executable /usr/local/bin/due 




6637




 





 





 





 





 





 



  Wrote executable /usr/local/bin/xcat 




6638




 





 





 





 





 





 



  Wrote executable /usr/local/bin/freq 




6639




 





 





 





 





 





 



  Wrote executable /usr/local/bin/deldup 




6640




 





 





 





 





 





 



  Wrote executable /usr/local/bin/wipe 




6641




 





 





 





 





 





 



   




6642




 





 





 





 





 





 



 Examples of commands then made available: 




6643




 





 





 





 





 





 



   




6644




 





 





 





 





 





 



  conv 1 USD EUR                #might show 0.88029 if thats the current currency rate. Uses conv() 




6645




 





 





 





 





 





 



  conv .5 in cm                 #reveals that 1/2 inch is 1.27 cm, see doc on conv() for all supported units 




6646




 





 





 





 





 





 



  due [-h] /path/1/ /path/2/    #like du, but show statistics on file extentions instead of subdirs 




6647




 





 





 





 





 





 



  xcat file                     #like cat, zcat, bzcat or xzcat in one. Uses file extention to decide. Uses openstr() 




6648




 





 





 





 





 





 



  freq file                     #reads file(s) or stdin and view counts of each byte 0-255 




6649




 





 





 





 





 





 



  deldup [-d] path1/ path2/     #reports (and optionally deletes) duplicate files NOT IMPLEMENTED YET! 




6650




 





 





 





 





 





 



  ccmd grep string /huge/file   #caches stdout+stderr for 15 minutes (default) for much faster results later 




6651




 





 





 





 





 





 



  ccmd "sleep 2;echo hello"     #slow first time. Note the quotes! 




6652




 





 





 





 





 





 



  ccmd "du -s ~/*|sort -n|tail" #ccmd store stdout+stderr in /tmp files (default) 




6653




 





 





 





 





 





 



   




6654




 





 





 





 





 





 



 =head3 due 




6655




 





 





 





 





 





 



   




6656




 





 





 





 





 





 



 Like C command but views space used by file extentions instead of dirs. Options: 




6657




 





 





 





 





 





 



   




6658




 





 





 





 





 





 



  due [-options] [dirs] [files] 




6659




 





 





 





 





 





 



  due -h          View bytes "human readable", i.e. C<8.72 MB> instead of C<9145662 b> (bytes) 




6660




 





 





 





 





 





 



  due -k | -m     View bytes in kilobytes | megabytes (1024 | 1048576) 




6661




 





 





 





 





 





 



  due -K          Like -k but uses 1000 instead of 1024 




6662




 





 





 





 





 





 



  due -z          View two extentions if .z .Z .gz .bz2 .rz or .xz (.tar.gz, not just .gz) 




6663




 





 





 





 





 





 



  due -M          Also show min, medium and max date (mtime) of files, give an idea of their age 




6664




 





 





 





 





 





 



  due -P          Also show 10, 50 (medium) and 90 percentile of file date 




6665




 





 





 





 





 





 



  due -MP         Both -M and -P, shows min, 10p, 50p, 90p and max 




6666




 





 





 





 





 





 



  due -a          Sort output alphabetically by extention (default order is by size) 




6667




 





 





 





 





 





 



  due -c          Sort output by number of files 




6668




 





 





 





 





 





 



  due -i          Ignore case, .GZ and .gz is the same, output in lower case 




6669




 





 





 





 





 





 



  due -t          Adds time of day to -M and -P output 




6670




 





 





 





 





 





 



  due -e 'regex'  Exclude files (full path) matching regex. Ex: due -e '\.git' 




6671




 





 





 





 





 





 



   




6672




 





 





 





 





 





 



 =cut 




6673




 





 





 





 





 





 



   




6674




 





 





 





 





 





 



 sub install_acme_command_tools { 




6675



  
0
  




 





 




  
0
  



  
1
  




0



   my $dir=(grep -d$_, @_, '/usr/local/bin', '/usr/bin')[0]; 




6676



  
0
  




 





 





 





 





0



   for(qw( conv due xcat freq deldup ccmd )){ 




6677



  
0
  




 





 





 





 





0



     unlink("$dir/$_"); 




6678



  
0
  




 





 





 





 





0



     writefile("$dir/$_", "#!$^X\nuse Acme::Tools;\nAcme::Tools::cmd_$_(\@ARGV);\n"); 




6679



  
0
  




 





 





 





 





0



     sys("/bin/chmod +x $dir/$_"); 




6680



  
0
  




 





 





 





 





0



     print "Wrote executable $dir/$_\n"; 




6681




 





 





 





 





 





 



   } 




6682




 





 





 





 





 





 



 } 




6683



  
0
  




 





 




  
0
  



  
0
  




0



 sub cmd_conv { print conv(@ARGV)."\n"  } 




6684




28





 





 




  
28
  




 





51697



   use Data::Dumper; 




 




28





 





 





 





 





294442



   




 




28





 





 





 





 





3305



   




6685




 





 





 





 





 





 



 sub cmd_due { #TODO: output from tar tvf and ls and find -ls 




6686



  
0
  




 





 




  
0
  



  
0
  




0



   require Getopt::Std; my %o; Getopt::Std::getopts("zkKmhciMPate:" => \%o); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6687



  
0
  




 





 





 





 





0



   require File::Find; 




6688




28





 





 




  
28
  




 





189



   no warnings 'uninitialized'; 




 




28





 





 





 





 





55



   




 




28





 





 





 





 





86776



   




6689



  
0
  



  
  0
  




 





 





 





0



   die"$0: -h, -k or -m can not be used together\n" if $o{h}+$o{k}+$o{m}>1; 




6690



  
0
  



  
  0
  




 





 





 





0



   die"$0: -c and -a can not be used together\n"    if $o{a}+$o{c}>1; 




6691



  
0
  



  
  0
  




 





 





 





0



   die"$0: -k and -m can not be used together\n"    if $o{k}+$o{m}>1; 




6692



  
0
  



  
  0
  




 





 





 





0



   my @q=@ARGV; @q=('.') if !@q; 




 



  
0
  




 





 





 





 





0



   




6693



  
0
  




 





 





 





 





0



   my(%c,%b,$cnt,$bts,%mtime); 




6694



  
0
  



  
  0
  




 





 





 





0



   my $r=$o{z} ? qr/(\.[^\.\/]{1,10}(\.(z|Z|gz|bz2|rz|xz))?)$/ 




6695




 





 





 





 





 





 



               : qr/(\.[^\.\/]{1,10})$/; 




6696



  
0
  



  
  0
  




 





 





 





0



   my $rexcl=exists$o{e}?qr/$o{e}/:0; 




6697




 





 





 





 





 





 



   File::Find::find({wanted => 




6698




 





 





 





 





 





 



     sub { 




6699



  
0
  



  
  0
  




 




  
0
  




 





0



       return if !-f$_; 




6700



  
0
  



  
  0
  



  
  0
  




 





 





0



       return if $rexcl and $File::Find::name=~$rexcl; 




6701



  
0
  




 





 





 





 





0



       my($sz,$mtime)=(stat($_))[7,9]; 




6702



  
0
  



  
  0
  




 





 





 





0



       my $ext=m/$r/?$1:""; 




6703



  
0
  



  
  0
  




 





 





 





0



       $ext=lc($ext) if $o{i}; 




6704



  
0
  




 





 





 





 





0



       $cnt++;    $c{$ext}++; 




 



  
0
  




 





 





 





 





0



   




6705



  
0
  




 





 





 





 





0



       $bts+=$sz; $b{$ext}+=$sz; 




 



  
0
  




 





 





 





 





0



   




6706



  
0
  



  
  0
  



  
  0
  




 





 





0



       $mtime{$ext}.=",$mtime" if $o{M} or $o{P}; 




6707



  
0
  




 





 





 





 





0



       1; 




6708



  
0
  




 





 





 





 





0



     } },@q); 




6709



  
0
  




 





 




  
0
  




 





0



   my($f,$s)=$o{k}?("%14.2f kb",sub{$_[0]/1024}) 




6710



  
0
  




 





 




  
0
  




 





0



            :$o{K}?("%14.2f Kb",sub{$_[0]/1000}) 




6711



  
0
  




 





 




  
0
  




 





0



            :$o{m}?("%14.2f mb",sub{$_[0]/1024**2}) 




6712



  
0
  




 





 




  
0
  




 





0



            :$o{h}?("%14s",     sub{bytes_readable($_[0])}) 




6713



  
0
  



  
  0
  




 




  
0
  




 





0



            :      ("%14d b",   sub{$_[0]}); 




 



  
0
  



  
  0
  




 





 





 





0



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6714




 





 





 





 





 





 



   my @e=$o{a}?(sort(keys%c)) 




6715



  
0
  



  
  0
  




 





 





 





0



        :$o{c}?(sort{$c{$a}<=>$c{$b} or $a cmp $b}keys%c) 




6716



  
0
  



  
  0
  




 





 





 





0



        :      (sort{$b{$a}<=>$b{$b} or $a cmp $b}keys%c); 




 



  
0
  



  
  0
  




 





 





 





0



   




 




 




  
  0
  




 





 





 





 



   




6717



  
0
  



  
  0
  




 





 





 





0



   my @p=$o{P}?(10,50,90):(50); 




6718




 





 





 





 





 





 



   my $perc=sub{ 




6719



  
0
  



  
  0
  



  
  0
  



  
0
  




 





0



     $o{M} or $o{P} or return""; 




6720



  
0
  




 





 





 





 





0



     my @m=@_>0 ? do {grep$_, split",", $mtime{$_[0]}} 




6721



  
0
  



  
  0
  




 





 





 





0



                : do {grep$_, map {split","} values %mtime}; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6722



  
0
  




 





 





 





 





0



     my @r=percentile(\@p,@m); 




6723



  
0
  



  
  0
  




 





 





 





0



     @r=(min(@m),@r,max(@m)) if $o{M}; 




6724



  
0
  




 





 





 





 





0



     @r=map int($_), @r; 




6725



  
0
  



  
  0
  




 





 





 





0



     my $fmt='YYYY/MM/DD'; $fmt.="-MM:MI:SS" if $o{t}; 




 



  
0
  




 





 





 





 





0



   




6726



  
0
  




 





 





 





 





0



     @r=map tms($_,$fmt), @r; 




6727



  
0
  




 





 





 





 





0



     "  ".join(" ",@r); 




6728



  
0
  




 





 





 





 





0



   }; 




6729



  
0
  




 





 





 





 





0



   printf("%-11s %8d $f %7.2f%%%s\n",$_,$c{$_},&$s($b{$_}),100*$b{$_}/$bts,&$perc($_)) for @e; 




6730



  
0
  




 





 





 





 





0



   printf("%-11s %8d $f %7.2f%%%s\n","Sum",$cnt,&$s($bts),100,&$perc()); 




6731




 





 





 





 





 





 



 } 




6732




 





 





 





 





 





 



 sub cmd_xcat { 




6733



  
0
  




 





 




  
0
  



  
0
  




0



   for my $fn (@_){ 




6734



  
0
  




 





 





 





 





0



     my $os=openstr($fn); 




6735



  
0
  



  
  0
  



  
  0
  




 





 





0



     open my $FH, $os or warn "xcat: cannot open $os ($!)\n" and next; 




6736



  
0
  




 





 





 





 





0



     print while <$FH>; 




6737



  
0
  




 





 





 





 





0



     close($FH); 




6738




 





 





 





 





 





 



   } 




6739




 





 





 





 





 





 



 } 




6740




 





 





 





 





 





 



 sub cmd_freq { 




6741



  
0
  




 





 




  
0
  



  
0
  




0



   my(@f,$i); 




6742



  
0
  




 





 





 





 





0



   map $f[$_]++, unpack("C*",$_) while <>; 




6743



  
0
  




 





 





 





 





0



   my $s=" " x 12;map{print"$_$s$_$s$_\n"}("BYTE  CHAR   COUNT","---- ----- -------"); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6744



  
0
  




 





 





 





 





0



   my %m=(145,"DOS-æ",155,"DOS-ø",134,"DOS-å",146,"DOS-Æ",157,"DOS-Ø",143,"DOS-Å",map{($_," ")}0..31); 




 



  
0
  




 





 





 





 





0



   




6745



  
0
  



  
  0
  



  
  0
  




 





 





0



   printf("%4d %5s%8d".(++$i%3?$s:"\n"),$_,$m{$_}||chr,$f[$_]) for grep$f[$_],0..255;print "\n"; 




 



  
0
  




 





 





 





 





0



   




6746



  
0
  




 





 





 





 





0



   my @no=grep!$f[$_],0..255; print "No bytes for these ".@no.": ".join(" ",@no)."\n"; 




 



  
0
  




 





 





 





 





0



   




6747




 





 





 





 





 





 



 } 




6748




 





 





 





 





 





 



   




6749




 





 





 





 





 





 



 sub cmd_deldup { 




6750




 





 





 





 





 





 



   # ~/test/deldup.pl #find and optionally delete duplicate files effiencently 




6751




 





 





 





 





 





 



   #http://www.commandlinefu.com/commands/view/3555/find-duplicate-files-based-on-size-first-then-md5-hash 




6752



  
0
  




 





 




  
0
  



  
0
  




0



   die "todo: deldup not ready yet" 




6753




 





 





 





 





 





 



 } 




6754




 





 





 





 





 





 



   




6755




 





 





 





 





 





 



 #http://stackoverflow.com/questions/11900239/can-i-cache-the-output-of-a-command-on-linux-from-cli 




6756




 





 





 





 





 





 



 our $Ccmd_cache_dir='/tmp/acme-tools-ccmd-cache'; 




6757




 





 





 





 





 





 



 our $Ccmd_cache_expire=15*60;  #default 15 minutes 




6758




 





 





 





 





 





 



 sub cmd_ccmd { 




6759



  
0
  




 





 




  
0
  



  
0
  




0



   require Digest::MD5; 




6760



  
0
  




 





 





 





 





0



   my $cmd=join" ",@_; 




6761



  
0
  




 





 





 





 





0



   my $d="$Ccmd_cache_dir/".username(); 




6762



  
0
  




 





 





 





 





0



   makedir($d); 




6763



  
0
  




 





 





 





 





0



   my $md5=Digest::MD5::md5_hex($cmd); 




6764



  
0
  




 





 





 





 





0



   my($fno,$fne)=map"$d/cmd.$md5.std$_","out","err"; 




6765



  
0
  




 





 




  
0
  




 





0



   my $too_old=sub{time()-(stat(shift))[9] >= $Ccmd_cache_expire}; 




 



  
0
  




 





 





 





 





0



   




6766



  
0
  




 





 





 





 





0



   unlink grep &$too_old($_), <$d/*.std???>; 




6767



  
0
  



  
  0
  



  
  0
  




 





 





0



   sys("($cmd) > $fno 2> $fne") if !-e$fno or &$too_old($fno); 




6768



  
0
  




 





 





 





 





0



   print STDOUT "".readfile($fno); 




6769



  
0
  




 





 





 





 





0



   print STDERR "".readfile($fne); 




6770




 





 





 





 





 





 



 } 




6771




 





 





 





 





 





 



   




6772



  
0
  




 





 




  
0
  



  
0
  




0



 sub cmd_trunc { die "todo: trunc not ready yet"} #truncate a file, size 0, keep all other attr 




6773




 





 





 





 





 





 



   




6774




 





 





 





 





 





 



 sub cmd_wipe  { 




6775



  
0
  




 





 




  
0
  



  
0
  




0



   require Getopt::Std; my %o; Getopt::Std::getopts("n:k" => \%o); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6776



  
0
  




 





 





 





 





0



   wipe($_,$o{n},$o{k}) for @_; 




6777




 





 





 





 





 





 



 } 




6778




 





 





 





 





 





 



   




6779




 





 





 





 





 





 



 =head1 DATABASE STUFF - NOT IMPLEMENTED YET 




6780




 





 





 





 





 





 



   




6781




 





 





 





 





 





 



 Uses L. Comming soon... 




6782




 





 





 





 





 





 



   




6783




 





 





 





 





 





 



   $Dbh 




6784




 





 





 





 





 





 



   dlogin 




6785




 





 





 





 





 





 



   dlogout 




6786




 





 





 





 





 





 



   drow 




6787




 





 





 





 





 





 



   drows 




6788




 





 





 





 





 





 



   drowc 




6789




 





 





 





 





 





 



   drowsc 




6790




 





 





 





 





 





 



   dcols 




6791




 





 





 





 





 





 



   dpk 




6792




 





 





 





 





 





 



   dsel 




6793




 





 





 





 





 





 



   ddo 




6794




 





 





 





 





 





 



   dins 




6795




 





 





 





 





 





 



   dupd 




6796




 





 





 





 





 





 



   ddel 




6797




 





 





 





 





 





 



   dcommit 




6798




 





 





 





 





 





 



   drollback 




6799




 





 





 





 





 





 



   




6800




 





 





 





 





 





 



 =cut 




6801




 





 





 





 





 





 



   




6802




 





 





 





 





 





 



 #my$dummy=<<'SOON'; 




6803




 





 





 





 





 





 



 sub dtype { 




6804



  
0
  




 





 




  
0
  



  
0
  




0



   my $connstr=shift; 




6805



  
0
  



  
  0
  




 





 





 





0



   return 'SQLite' if $connstr=~/(\.sqlite|sqlite:.*\.db)$/i; 




6806



  
0
  



  
  0
  




 





 





 





0



   return 'Oracle' if $connstr=~/\@/; 




6807



  
0
  




 





 





 





 





0



   return 'Pg' if 1==2; 




6808



  
0
  




 





 





 





 





0



   die; 




6809




 





 





 





 





 





 



 } 




6810




 





 





 





 





 





 



   




6811




 





 





 





 





 





 



 our($Dbh,@Dbh,%Sth); 




6812




 





 





 





 





 





 



 our %Dbattr=(RaiseError => 1, AutoCommit => 0); #defaults 




6813




 





 





 





 





 





 



 sub dlogin { 




6814



  
0
  




 





 




  
0
  



  
0
  




0



   my $connstr=shift(); 




6815



  
0
  




 





 





 





 





0



   my %attr=(%Dbattr,@_); 




6816



  
0
  




 





 





 





 





0



   my $type=dtype($connstr); 




6817



  
0
  




 





 





 





 





0



   my($dsn,$u,$p)=('','',''); 




6818



  
0
  



  
  0
  




 





 





 





0



   if($type eq 'SQLite'){ 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6819



  
0
  




 





 





 





 





0



     $dsn=$connstr; 




6820




 





 





 





 





 





 



   } 




6821




 





 





 





 





 





 



   elsif($type eq 'Oracle'){ 




6822



  
0
  




 





 





 





 





0



     ($u,$p,$dsn)=($connstr=~m,(.+?)(/.+?)?\@(.+),); 




6823




 





 





 





 





 





 



   } 




6824




 





 





 





 





 





 



   elsif($type eq 'Pg'){ 




6825



  
0
  




 





 





 





 





0



     croak "todo"; 




6826




 





 





 





 





 





 



   } 




6827




 





 





 





 





 





 



   else{ 




6828



  
0
  




 





 





 





 





0



     croak "dblogin: unknown database type for connection string $connstr\n"; 




6829




 





 





 





 





 





 



   } 




6830



  
0
  




 





 





 





 





0



   $dsn="dbi:$type:$dsn"; 




6831



  
0
  



  
  0
  




 





 





 





0



   push @Dbh, $Dbh if $Dbh; #local is better? 




6832



  
0
  




 





 





 





 





0



   require DBI; 




6833



  
0
  




 





 





 





 





0



   $Dbh=DBI->connect($dsn,$u,$p,\%attr); #connect_cached? 




6834




 





 





 





 





 





 



 } 




6835




 





 





 





 





 





 



 sub dlogout { 




6836



  
0
  




 





 




  
0
  



  
0
  




0



   $Dbh->disconnect; 




6837



  
0
  



  
  0
  




 





 





 





0



   $Dbh=pop@Dbh if @Dbh; 




6838




 





 





 





 





 





 



 } 




6839




 





 





 





 





 





 



 sub drow { 




6840



  
0
  




 





 




  
0
  



  
0
  




0



   my($q,@b)=_dattrarg(@_); 




6841




 





 





 





 





 





 



   #my $sth=do{$Sth{$Dbh,$q} ||= $Dbh->prepare_cached($q)}; 




6842



  
0
  




 





 





 





 





0



   my $sth=$Dbh->prepare_cached($q); 




6843



  
0
  




 





 





 





 





0



   $sth->execute(@b); 




6844



  
0
  




 





 





 





 





0



   my @r=$sth->fetchrow_array; 




6845



  
0
  



  
  0
  




 





 





 





0



   $sth->finish if $$Dbh{Driver}{Name} eq 'SQLite'; 




6846




 





 





 





 





 





 



   #$dbh->selectrow_array($statement); 




6847



  
0
  



  
  0
  




 





 





 





0



   return @r==1?$r[0]:@r; 




6848




 





 





 





 





 





 



 } 




6849




 





 





 




  
0
  



  
0
  




 



 sub drows { 




6850




 





 





 





 





 





 



 } 




6851




 





 





 




  
0
  



  
0
  




 



 sub drowc { 




6852




 





 





 





 





 





 



 } 




6853




 





 





 




  
0
  



  
0
  




 



 sub drowsc { 




6854




 





 





 





 





 





 



 } 




6855




 





 





 




  
0
  



  
0
  




 



 sub dcols { 




6856




 





 





 





 





 





 



 } 




6857




 





 





 




  
0
  



  
0
  




 



 sub dpk { 




6858




 





 





 





 





 





 



 } 




6859




 





 





 




  
0
  



  
0
  




 



 sub dsel { 




6860




 





 





 





 





 





 



 } 




6861




 





 





 





 





 





 



 sub ddo { 




6862



  
0
  




 





 




  
0
  



  
0
  




0



   my @arg=_dattrarg(@_); 




6863




 





 





 





 





 





 



   #warn serialize(\@arg,'arg','',1); 




6864



  
0
  




 





 





 





 





0



   $Dbh->do(@arg); #hm cache? 




6865




 





 





 





 





 





 



 } 




6866




 





 





 




  
0
  



  
0
  




 



 sub dins { 




6867




 





 





 





 





 





 



 } 




6868




 





 





 




  
0
  



  
0
  




 



 sub dupd { 




6869




 





 





 





 





 





 



 } 




6870




 





 





 




  
0
  



  
0
  




 



 sub ddel { 




6871




 





 





 





 





 





 



 } 




6872



  
0
  




 





 




  
0
  



  
0
  




0



 sub dcommit { $Dbh->commit } 




6873



  
0
  




 





 




  
0
  



  
0
  




0



 sub drollback { $Dbh->rollback } 




6874




 





 





 





 





 





 



   




6875




 





 





 





 





 





 



 sub _dattrarg { 




6876



  
0
  




 





 




  
0
  




 





0



   my @arg=@_; 




6877



  
0
  



  
  0
  




 





 





 





0



   splice @arg,1,0, ref($arg[-1]) eq 'HASH' ? pop(@arg) : {}; 




6878



  
0
  




 





 





 





 





0



   @arg; 




6879




 





 





 





 





 





 



 } 




6880




 





 





 





 





 





 



   




6881




 





 





 





 





 





 



 =head2 self_update 




6882




 





 





 





 





 





 



   




6883




 





 





 





 





 





 



 Update Acme::Tools to newest version quick and dirty: 




6884




 





 





 





 





 





 



   




6885




 





 





 





 





 





 



  function pmview(){ ls -ld `perl -M$1 -le'$m=shift;$mi=$m;$mi=~s,::,/,g;print $INC{"$mi.pm"};warn"Version ".${$m."::VERSION"}."\n"' $1`;} 




6886




 





 





 





 





 





 



   




6887




 





 





 





 





 





 



  pmview Acme::Tools                                     #view date and version before 




6888




 





 





 





 





 





 



  sudo perl -MAcme::Tools -e Acme::Tools::self_update    #update to newest version 




6889




 





 





 





 





 





 



  pmview Acme::Tools                                     #view date and version after 




6890




 





 





 





 





 





 



   




6891




 





 





 





 





 





 



 Does C to where Acme/Tools.pm are and then wget -N https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm 




6892




 





 





 





 





 





 



   




6893




 





 





 





 





 





 



 =cut 




6894




 





 





 





 





 





 



   




6895




 





 





 





 





 





 



 our $Wget; 




6896




 





 





 





 





 





 



 our $Self_update_url='https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm'; #todo: change site 




6897




 





 





 





 





 





 



 sub self_update { 




6898




 





 





 





 





 





 



   #in($^O,'linux','cygwin') or die"ERROR: self_update works on linux and cygwin only"; 




6899



  
0
  




 




  
  0
  



  
0
  



  
1
  




0



   $Wget||=(grep -x$_,map"$_/wget",'/usr/bin','/bin','/usr/local/bin','.')[0]; #hm --no-check-certificate 




6900



  
0
  



  
  0
  




 





 





 





0



   -x$Wget or die"ERROR: wget ($Wget) executable not found\n"; 




6901



  
0
  




 





 





 





 





0



   my $d=dirname(__FILE__); 




6902



  
0
  




 





 





 





 





0



   sys("cd $d; ls -l Tools.pm; md5sum Tools.pm"); 




6903



  
0
  




 




  
  0
  




 





 





0



   sys("cd $d; $Wget -N ".($ARGV[0]||$Self_update_url)); 




6904



  
0
  




 





 





 





 





0



   sys("cd $d; ls -l Tools.pm; md5sum Tools.pm"); 




6905




 





 





 





 





 





 



 } 




6906




 





 





 





 





 





 



   




6907




 





 





 





 





 





 



 1; 




6908




 





 





 





 





 





 



   




6909




 





 





 





 





 





 



 package Acme::Tools::BloomFilter; 




6910




28





 





 




  
28
  




 





768



 use 5.008; use strict; use warnings; use Carp; 




 




28





 





 




  
28
  




 





101



   




 




28





 





 




  
28
  




 





141



   




 




28





 





 




  
28
  




 





50



   




 




28





 





 





 





 





738



   




 




28





 





 





 





 





132



   




 




28





 





 





 





 





46



   




 




28





 





 





 





 





969



   




 




28





 





 





 





 





143



   




 




28





 





 





 





 





46



   




 




28





 





 





 





 





14374



   




6911




2





 





 




  
2
  




 





307



 sub new      { my($class,@p)=@_; my $self=Acme::Tools::bfinit(@p); bless $self, $class } 




 




2





 





 





 





 





9



   




 




2





 





 





 





 





11



   




6912




2





 





 




  
2
  




 





108



 sub add      { &Acme::Tools::bfadd      } 




6913



  
0
  




 





 




  
0
  




 





0



 sub addbf    { &Acme::Tools::bfaddbf    } 




6914




2





 





 




  
2
  




 





88



 sub check    { &Acme::Tools::bfcheck    } 




6915




1





 





 




  
1
  




 





7



 sub grep     { &Acme::Tools::bfgrep     } 




6916



  
0
  




 





 




  
0
  




 





0



 sub grepnot  { &Acme::Tools::bfgrepnot  } 




6917



  
0
  




 





 




  
0
  




 





0



 sub delete   { &Acme::Tools::bfdelete   } 




6918



  
0
  




 





 




  
0
  




 





0



 sub store    { &Acme::Tools::bfstore    } 




6919



  
0
  




 





 




  
0
  




 





0



 sub retrieve { &Acme::Tools::bfretrieve } 




6920




1





 





 




  
1
  




 





5



 sub clone    { &Acme::Tools::bfclone    } 




6921




0





 





 




  
0
  




 





0



 sub sum      { &Acme::Tools::bfsum      } 




6922




 





 





 





 





 





 



 1; 




6923




 





 





 





 





 





 



   




6924




 





 





 





 





 





 



 # Ny versjon: 




6925




 





 





 





 





 





 



 # + c-s todo 




6926




 





 





 





 





 





 



 # + endre $VERSION 




6927




 





 





 





 





 





 



 # + endre Release history under HISTORY 




6928




 





 





 





 





 





 



 # + endre årstall under COPYRIGHT AND LICENSE 




6929




 





 





 





 





 





 



 # + oppd default valutakurser inkl datoen 




6930




 





 





 





 





 





 



 # + emacs Changes 




6931




 





 





 





 





 





 



 # + emacs README + aarstall 




6932




 





 





 





 





 





 



 # + emacs MANIFEST legg til ev nye t/*.t 




6933




 





 





 





 





 





 



 # + perl            Makefile.PL;make test 




6934




 





 





 





 





 





 



 # + /usr/bin/perl   Makefile.PL;make test 




6935




 





 





 





 





 





 



 # + perlbrew exec "perl ~/Acme-Tools/Makefile.PL ; time make test" 




6936




 





 





 





 





 





 



 # + perlbrew use perl-5.10.1; perl Makefile.PL; make test; perlbrew off 




6937




 





 





 





 





 





 



 # + test evt i cygwin og mingw-perl 




6938




 





 





 





 





 





 



 # + pod2html Tools.pm > Tools.html ; firefox Tools.html  




6939




 





 





 





 





 





 



 # + https://metacpan.org/pod/Acme::Tools 




6940




 





 





 





 





 





 



 # + http://cpants.cpanauthors.org/dist/Acme-Tools  #kvalitee 




6941




 





 





 





 





 





 



 # + perl Makefile.PL ; make test && make dist 




6942




 





 





 





 





 





 



 # + cp -p *tar.gz /htdocs/ 




6943




 





 





 





 





 





 



 # + ci -l -mversjon -d `cat MANIFEST` 




6944




 





 





 





 





 





 



 # + git add `cat MANIFEST` 




6945




 





 





 





 





 





 



 # + git status 




6946




 





 





 





 





 





 



 # + git commit -am versjon 




6947




 





 





 





 





 





 



 # + git push                    #eller: 




6948




 





 





 





 





 





 



 # + git push origin master 




6949




 





 





 





 





 





 



 # + http://pause.perl.org/ 




6950




 





 





 





 





 





 



 # http://en.wikipedia.org/wiki/Birthday_problem#Approximations 




6951




 





 





 





 





 





 



   




6952




 





 





 





 





 





 



 # memoize_expire()           http://perldoc.perl.org/Memoize/Expire.html 




6953




 





 





 





 





 





 



 # memoize_file_expire() 




6954




 





 





 





 





 





 



 # memoize_limit_size() #lru 




6955




 





 





 





 





 





 



 # memoize_file_limit_size() 




6956




 





 





 





 





 





 



 # memoize_memcached         http://search.cpan.org/~dtrischuk/Memoize-Memcached-0.03/lib/Memoize/Memcached.pm 




6957




 





 





 





 





 





 



 # hint on http://perl.jonallen.info/writing/articles/install-perl-modules-without-root 




6958




 





 





 





 





 





 



   




6959




 





 





 





 





 





 



 # sub mycrc32 {  #http://billauer.co.il/blog/2011/05/perl-crc32-crc-xs-module/  eller String::CRC32::crc32 som er 100 x raskere enn Digest::CRC::crc32 




6960




 





 





 





 





 





 



 #  my ($input, $init_value, $polynomial) = @_; 




6961




 





 





 





 





 





 



 #  $init_value = 0 unless (defined $init_value); 




6962




 





 





 





 





 





 



 #  $polynomial = 0xedb88320 unless (defined $polynomial); 




6963




 





 





 





 





 





 



 #  my @lookup_table; 




6964




 





 





 





 





 





 



 #  for (my $i=0; $i<256; $i++) { 




6965




 





 





 





 





 





 



 #    my $x = $i; 




6966




 





 





 





 





 





 



 #    for (my $j=0; $j<8; $j++) { 




6967




 





 





 





 





 





 



 #      if ($x & 1) { 




6968




 





 





 





 





 





 



 #        $x = ($x >> 1) ^ $polynomial; 




6969




 





 





 





 





 





 



 #      } else { 




6970




 





 





 





 





 





 



 #        $x = $x >> 1; 




6971




 





 





 





 





 





 



 #      } 




6972




 





 





 





 





 





 



 #    } 




6973




 





 





 





 





 





 



 #    push @lookup_table, $x; 




6974




 





 





 





 





 





 



 #  } 




6975




 





 





 





 





 





 



 #  my $crc = $init_value ^ 0xffffffff; 




6976




 





 





 





 





 





 



 #  foreach my $x (unpack ('C*', $input)) { 




6977




 





 





 





 





 





 



 #    $crc = (($crc >> 8) & 0xffffff) ^ $lookup_table[ ($crc ^ $x) & 0xff ]; 




6978




 





 





 





 





 





 



 #  } 




6979




 





 





 





 





 





 



 #  $crc = $crc ^ 0xffffffff; 




6980




 





 





 





 





 





 



 #  return $crc; 




6981




 





 





 





 





 





 



 # } 




6982




 





 





 





 





 





 



 # 




6983




 





 





 





 





 





 



   




6984




 





 





 





 





 





 



   




6985




 





 





 





 





 





 



   




6986




 





 





 





 





 





 



 =head1 HISTORY 




6987




 





 





 





 





 





 



   




6988




 





 





 





 





 





 



 Release history 




6989




 





 





 





 





 





 



   




6990




 





 





 





 





 





 



  0.172 Dec 2015   Subs: curb, openstr, pwgen, sleepms, sleepnm, srlz, tms, username, 




6991




 





 





 





 





 





 



                   self_update, install_acme_command_tools 




6992




 





 





 





 





 





 



                   Commands: conv, due, freq, wipe, xcat (see "Commands") 




6993




 





 





 





 





 





 



  0.16  Feb 2015   bigr, curb, cpad, isnum, parta, parth, read_conf, resolve_equation, 




6994




 





 





 





 





 





 



                   roman2int, trim. Improved: conv (numbers, currency), range ("derivatives") 




6995




 





 





 





 





 





 



  0.15  Nov 2014   Improved doc 




6996




 





 





 





 





 





 



  0.14  Nov 2014   New subs, improved tests and doc 




6997




 





 





 





 





 





 



  0.13  Oct 2010   Non-linux test issue, resolve. improved: bloom filter, tests, doc 




6998




 





 





 





 





 





 



  0.12  Oct 2010   Improved tests, doc, bloom filter, random_gauss, bytes_readable 




6999




 





 





 





 





 





 



  0.11  Dec 2008   Improved doc 




7000




 





 





 





 





 





 



  0.10  Dec 2008 




7001




 





 





 





 





 





 



   




7002




 





 





 





 





 





 



 =head1 SEE ALSO 




7003




 





 





 





 





 





 



   




7004




 





 





 





 





 





 



 L 




7005




 





 





 





 





 





 



   




7006




 





 





 





 





 





 



 =head1 AUTHOR 




7007




 





 





 





 





 





 



   




7008




 





 





 





 





 





 



 Kjetil Skotheim, [e-mail] 




7009




 





 





 





 





 





 



   




7010




 





 





 





 





 





 



 =head1 COPYRIGHT 




7011




 





 





 





 





 





 



   




7012




 





 





 





 





 





 



 1995-2015, Kjetil Skotheim 




7013




 





 





 





 





 





 



   




7014




 





 





 





 





 





 



 =head1 LICENSE 




7015




 





 





 





 





 





 



   




7016




 





 





 





 





 





 



 This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 




7017




 





 





 





 





 





 



   




7018




 





 





 





 





 





 



 =cut
and C<<
inside the C<<

 my @table = ht2t($html,'some string occuring before the  you want'); 




3532




 





 





 





 





 





 



   




3533




 





 





 





 





 





 



 Input: One or two arguments. 




3534




 





 





 





 





 





 



   




3535




 





 





 





 





 





 



 First argument: the html where a C<<  >> is to be found and converted. 




3536




 





 





 





 





 





 



   




3537




 





 





 





 





 





 



 Second argument: (optional) If the html contains more than one C<< 




3538




 





 





 





 





 





 



  >>, and you do not want the first one, applying a second 




3539




 





 





 





 





 





 



 argument is a way of telling C which to capture: the one with this word 




3540




 





 





 





 





 





 



 or string occurring before it. 




3541




 





 





 





 





 





 



   




3542




 





 





 





 





 





 



 Output: An array of arrayrefs. 




3543




 





 





 





 





 





 



   




3544




 





 





 





 





 





 



 C is a quick and dirty way of scraping (or harvesting as it is 




3545




 





 





 





 





 





 



 also called) data from a web page. Look too L to do this 




3546




 





 





 





 





 





 



 more accurate. 




3547




 





 





 





 





 





 



   




3548




 





 





 





 





 





 



 Example: 




3549




 





 





 





 





 





 



   




3550




 





 





 





 





 





 



  use Acme::Tools; 




3551




 





 





 





 





 





 



  use LWP::Simple; 




3552




 





 





 





 





 





 



  my $url = "http://en.wikipedia.org/wiki/List_of_countries_by_population"; 




3553




 





 





 





 





 





 



  for( ht2t( get($url), "Countries" ) ) { 




3554




 





 





 





 





 





 



    my($rank, $country, $pop) = @$_; 




3555




 





 





 





 





 





 



    $pop =~ s/,//g; 




3556




 





 





 





 





 





 



    printf "%3d | %-32s | %9d\n", @$_ if $pop>0; 




3557




 





 





 





 





 





 



  } 




3558




 





 





 





 





 





 



   




3559




 





 





 





 





 





 



 Output: 




3560




 





 





 





 





 





 



   




3561




 





 





 





 





 





 



   1 | China                            | 1367740000 




3562




 





 





 





 





 





 



   2 | India                            | 1262090000 




3563




 





 





 





 





 





 



   3 | United States                    | 319043000 




3564




 





 





 





 





 





 



   4 | Indonesia                        | 252164800 




3565




 





 





 





 





 





 



   5 | Brazil                           | 203404000 




3566




 





 





 





 





 





 



   




3567




 





 





 





 





 





 



 ...and so on. 




3568




 





 





 





 





 





 



   




3569




 





 





 





 





 





 



 =cut 




3570




 





 





 





 





 





 



   




3571




 





 





 





 





 





 



 sub ht2t { 




3572




9




  
100
  



  
100
  



  
9
  



  
1
  




451



   my($f,$s,$r)=@_; 1>@_||@_>3 and croak; $s='' if @_==1; 




 




9




  
100
  




 





 





 





314



   




 




7





 





 





 





 





17



   




3573




7





 





 





 





 





121



   $f=~s,.*?($s).*?(




3574




28





 





 




  
28
  




 





835971



   my $e=0;$e++ while index($f,$s=chr($e))>=$[; 




 




28





 





 





 





 





13345



   




 




28





 





 





 





 





104398



   




 




7





 





 





 





 





13



   




 




7





 





 





 





 





36



   




3575




7





 





 





 





 





85



   $f=~s//\l$1$s/gsi; 




3576




7





 





 





 





 





54



   $f=~s/\s*<.*?>\s*/ /gsi; 




3577




7





 





 





 





 





66



   my @t=split("r$s",$f);shift @t; 




 




7





 





 





 





 





12



   




3578




20





 





 




  
20
  




 





32



   $r||=sub{s/&(#160|nbsp);/ /g;s/&/&/g;s/^\s*(.*?)\s*$/$1/s; 




 




20





 





 





 





 





28



   




 




20





 





 





 





 





81



   




3579




7




  
100
  



  
100
  




 





 





38



 	   s/(\d) (\d)/$1$2/g if /^[\d \.\,]+$/}; 




 




20





 





 





 





 





71



   




3580




7





 





 





 





 





16



   for(@t){my @r=split/[dh]$s/;shift@r;$_=[map{&$r;$_}@r]} 




 




9





 





 





 





 





52



   




 




9





 





 





 





 





14



   




 




9





 





 





 





 





16



   




 




20





 





 





 





 





31



   




 




20





 





 





 





 





64



   




3581




7





 





 





 





 





38



   @t; 




3582




 





 





 





 





 





 



 } 




3583




 





 





 





 





 





 



   




3584




 





 





 





 





 





 



 =head1 FILES, DIRECTORIES 




3585




 





 





 





 





 





 



   




3586




 





 





 





 





 





 



 =head2 writefile 




3587




 





 





 





 





 





 



   




3588




 





 





 





 





 





 



 Justification: 




3589




 





 





 





 





 





 



   




3590




 





 





 





 





 





 



 Perl needs three or four operations to make a file out of a string: 




3591




 





 





 





 





 





 



   




3592




 





 





 





 





 





 



  open my $FILE, '>', $filename  or die $!; 




3593




 





 





 





 





 





 



  print $FILE $text; 




3594




 





 





 





 





 





 



  close($FILE); 




3595




 





 





 





 





 





 



   




3596




 





 





 





 





 





 



 This is way simpler: 




3597




 





 





 





 





 





 



   




3598




 





 





 





 





 





 



  writefile($filename,$text); 




3599




 





 





 





 





 





 



   




3600




 





 





 





 





 





 



 Sub writefile opens the file i binary mode (C) and has two usage modes: 




3601




 





 





 





 





 





 



   




3602




 





 





 





 





 





 



 B Two arguments 




3603




 





 





 





 





 





 



   




3604




 





 





 





 





 





 



 B is the filename. If the file exists, its overwritten. 




3605




 





 





 





 





 





 



 If the file can not be opened for writing, a die (a croak really) happens. 




3606




 





 





 





 





 





 



   




3607




 





 





 





 





 





 



 B is one of: 




3608




 





 





 





 





 





 



   




3609




 





 





 





 





 





 



 =over 4 




3610




 





 





 





 





 





 



   




3611




 





 





 





 





 





 



 =item * Either a scaler. That is a normal string to be written to the file. 




3612




 





 





 





 





 





 



   




3613




 





 





 





 





 





 



 =item * Or a reference to a scalar. That referred text is written to the file. 




3614




 





 





 





 





 





 



   




3615




 





 





 





 





 





 



 =item * Or a reference to an array of scalars. This array is the written to the 




3616




 





 





 





 





 





 



  file element by element and C<< \n >> is automatically appended to each element. 




3617




 





 





 





 





 





 



   




3618




 





 





 





 





 





 



 =back 




3619




 





 





 





 





 





 



   




3620




 





 





 





 





 





 



 Alternativelly, you can write several files at once. 




3621




 





 





 





 





 





 



   




3622




 





 





 





 





 





 



 Example, this: 




3623




 





 





 





 





 





 



   




3624




 





 





 





 





 





 



  writefile('file1.txt','The text....tjo'); 




3625




 





 





 





 





 





 



  writefile('file2.txt','The text....hip'); 




3626




 





 





 





 





 





 



  writefile('file3.txt','The text....and hop'); 




3627




 





 





 





 





 





 



   




3628




 





 





 





 





 





 



 ...is the same as this: 




3629




 





 





 





 





 





 



   




3630




 





 





 





 





 





 



  writefile([ 




3631




 





 





 





 





 





 



    ['file1.txt','The text....tjo'], 




3632




 





 





 





 





 





 



    ['file2.txt','The text....hip'], 




3633




 





 





 





 





 





 



    ['file3.txt','The text....and hop'], 




3634




 





 





 





 





 





 



  ]); 




3635




 





 





 





 





 





 



   




3636




 





 





 





 





 





 



 B Nothing (for the time being). Cs (C really) if something goes wrong. 




3637




 





 





 





 





 





 



   




3638




 





 





 





 





 





 



 =cut 




3639




 





 





 





 





 





 



   




3640




 





 





 





 





 





 



 #todo: use openstr() as in readfile(), transparently gzip .gz filenames and so on 




3641




 





 





 





 





 





 



 sub writefile { 




3642




4





 





 




  
4
  



  
1
  




70151



     my($filename,$text)=@_; 




3643




4




  
 50
  




 





 





 





25



     if(ref($filename) eq 'ARRAY'){ 




3644



  
0
  




 





 





 





 





0



 	writefile(@$_) for @$filename; 




3645



  
0
  




 





 





 





 





0



 	return; 




3646




 





 





 





 





 





 



     } 




3647




4




  
 50
  



  
 33
  




 





 





306



     open(WRITEFILE,">",$filename) and binmode(WRITEFILE) or croak($!); 




3648




4




  
 50
  



  
 33
  




 





 





41



     if(!defined $text or !ref($text)){ 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




3649




4





 





 





 





 





733



 	print WRITEFILE $text; 




3650




 





 





 





 





 





 



     } 




3651




 





 





 





 





 





 



     elsif(ref($text) eq 'SCALAR'){ 




3652



  
0
  




 





 





 





 





0



 	print WRITEFILE $$text; 




3653




 





 





 





 





 





 



     } 




3654




 





 





 





 





 





 



     elsif(ref($text) eq 'ARRAY'){ 




3655



  
0
  




 





 





 





 





0



 	print WRITEFILE "$_\n" for @$text; 




3656




 





 





 





 





 





 



     } 




3657




 





 





 





 





 





 



     else { 




3658



  
0
  




 





 





 





 





0



 	croak; 




3659




 





 





 





 





 





 



     } 




3660




4





 





 





 





 





167



     close(WRITEFILE); 




3661




4





 





 





 





 





15



     return; 




3662




 





 





 





 





 





 



 } 




3663




 





 





 





 





 





 



   




3664




 





 





 





 





 





 



 =head2 readfile 




3665




 





 





 





 





 





 



   




3666




 





 





 





 





 





 



 Just as with L you can read in a whole file in one operation with C. Instead of: 




3667




 





 





 





 





 





 



   




3668




 





 





 





 





 





 



  open my $FILE,'<', $filename or die $!; 




3669




 





 





 





 





 





 



  my $data = join"",<$FILE>; 




3670




 





 





 





 





 





 



  close($FILE); 




3671




 





 





 





 





 





 



   




3672




 





 





 





 





 





 



 This is simpler: 




3673




 





 





 





 





 





 



   




3674




 





 





 





 





 





 



  my $data = readfile($filename); 




3675




 





 





 





 





 





 



   




3676




 





 





 





 





 





 



 B 




3677




 





 





 





 





 





 



   




3678




 





 





 





 





 





 



 Reading the content of the file to a scalar variable: (Any content in C<$data> will be overwritten) 




3679




 





 





 





 





 





 



   




3680




 





 





 





 





 





 



  my $data; 




3681




 





 





 





 





 





 



  readfile('filename.txt',\$data); 




3682




 





 





 





 





 





 



   




3683




 





 





 





 





 





 



 Reading the lines of a file into an array: 




3684




 





 





 





 





 





 



   




3685




 





 





 





 





 





 



  my @lines; 




3686




 





 





 





 





 





 



  readfile('filnavn.txt',\@lines); 




3687




 





 





 





 





 





 



  for(@lines){ 




3688




 





 





 





 





 





 



    ... 




3689




 





 





 





 





 





 



  } 




3690




 





 





 





 





 





 



   




3691




 





 





 





 





 





 



 Note: Chomp is done on each line. That is, any newlines (C<< \n >>) will be removed. 




3692




 





 





 





 





 





 



 If C<@lines> is non-empty, this will be lost. 




3693




 





 





 





 





 





 



   




3694




 





 





 





 





 





 



 Sub readfile is context aware. If an array is expected it returns an array of the lines without a trailing C<< \n >>. 




3695




 





 





 





 





 





 



 The last example can be rewritten: 




3696




 





 





 





 





 





 



   




3697




 





 





 





 





 





 



  for(readfile('filnavn.txt')){ 




3698




 





 





 





 





 





 



    ... 




3699




 





 





 





 





 





 



  } 




3700




 





 





 





 





 





 



   




3701




 





 





 





 





 





 



 With two input arguments, nothing (undef) is returned from C. 




3702




 





 





 





 





 





 



   




3703




 





 





 





 





 





 



 =cut 




3704




 





 





 





 





 





 



   




3705




 





 





 





 





 





 



 #http://blogs.perl.org/users/leon_timmermans/2013/05/why-you-dont-need-fileslurp.html 




3706




 





 





 





 





 





 



 #todo: readfile with grep-filter code ref in a third arg (avoid reading all into mem) 




3707




 





 





 





 





 





 



   




3708




 





 





 





 





 





 



 sub readfile { 




3709




12





 





 




  
12
  



  
1
  




11518



   my($filename,$ref)=@_; 




3710




12




  
100
  




 





 





 





59



   if(@_==1){ 




3711




6




  
100
  




 





 





 





22



     if(wantarray){ my @data; readfile($filename,\@data); return @data } 




 




1





 





 





 





 





3



   




 




1





 





 





 





 





5



   




 




1





 





 





 





 





4976



   




3712




5





 





 





 





 





8



     else         { my $data; readfile($filename,\$data); return $data } 




 




5





 





 





 





 





457



   




 




5





 





 





 





 





698



   




3713




 





 





 





 





 





 



   } 




3714




 





 





 





 





 





 



   else { 




3715




6




  
 50
  




 





 





 





46



     open my $fh,openstr($filename) or croak("ERROR: readfile $! $?"); 




3716




6




  
100
  




 





 





 





30



     if   ( ref($ref) eq 'SCALAR') { $$ref=join"",<$fh> } 




 




5




  
 50
  




 





 





 





6899



   




3717




1





 





 





 





 





18



     elsif( ref($ref) eq 'ARRAY' ) { while(my $l=<$fh>){ chomp($l); push @$ref, $l } } 




 




20003





 





 





 





 





20569



   




 




20003





 





 





 





 





54199



   




3718



  
0
  




 





 





 





 





0



     else { croak "ERROR: Second arg to readfile should be a ref to a scalar og array" } 




3719




6





 





 





 





 





1166



     close($fh); 




3720




6





 





 





 





 





38



     return;#? 




3721




 





 





 





 





 





 



   } 




3722




 





 





 





 





 





 



 } 




3723




 





 





 





 





 





 



   




3724




 





 





 





 





 





 



 =head2 readdirectory 




3725




 





 





 





 





 





 



   




3726




 





 





 





 





 





 



 B 




3727




 





 





 





 





 





 



   




3728




 





 





 





 





 





 



 Name of a directory. 




3729




 





 





 





 





 





 



   




3730




 





 





 





 





 





 



 B 




3731




 





 





 





 





 





 



   




3732




 





 





 





 





 





 



 A list of all files in it, except of  C<.> and C<..>  (on linux/unix systems, all directories have a C<.> and C<..> directory). 




3733




 





 





 





 





 





 



   




3734




 





 





 





 





 





 



 The names of all types of files are returned: normal files, directories, symbolic links, 




3735




 





 





 





 





 





 



 pipes, semaphores. That is every thing shown by C except C<.> and C<..> 




3736




 





 





 





 





 





 



   




3737




 





 





 





 





 





 



 C do not recurce down into subdirectories (but see example below). 




3738




 





 





 





 





 





 



   




3739




 





 





 





 





 





 



 B 




3740




 





 





 





 





 





 



   




3741




 





 





 





 





 





 



   my @files = readdirectory("/tmp"); 




3742




 





 





 





 





 





 



   




3743




 





 





 





 





 





 



 B 




3744




 





 





 





 





 





 



   




3745




 





 





 





 





 





 



 Sometimes calling the built ins C, C and C seems a tad tedious, since this: 




3746




 





 





 





 





 





 



   




3747




 





 





 





 





 





 



  my $dir="/usr/bin"; 




3748




 





 





 





 





 





 



  opendir(D,$dir); 




3749




 





 





 





 





 





 



  my @files=map "$dir/$_", grep {!/^\.\.?$/} readdir(D); 




3750




 





 





 





 





 





 



  closedir(D); 




3751




 





 





 





 





 





 



   




3752




 





 





 





 





 





 



 Is the same as this: 




3753




 





 





 





 





 





 



   




3754




 





 





 





 





 





 



  my @files=readdirectory("/usr/bin"); 




3755




 





 





 





 





 





 



   




3756




 





 





 





 





 





 



 See also: L 




3757




 





 





 





 





 





 



   




3758




 





 





 





 





 





 



 B 




3759




 





 





 





 





 





 



   




3760




 





 





 





 





 





 



 On huge directories with perhaps tens or houndreds of thousands of 




3761




 





 





 





 





 





 



 files, readdirectory() will consume more memory than perls 




3762




 





 





 





 





 





 



 opendir/readdir. This isn't usually a concern anymore for modern 




3763




 





 





 





 





 





 



 computers with gigabytes of RAM, but might be the rationale behind 




3764




 





 





 





 





 





 



 Perls more tedious way created in the 80s.  The same argument goes for 




3765




 





 





 





 





 





 



 file slurping. On the other side it's also a good practice to never 




3766




 





 





 





 





 





 



 assume to much on available memory and the number of files if you 




3767




 





 





 





 





 





 



 don't know for certain that enough memory is available whereever your 




3768




 





 





 





 





 





 



 code is run or that the size of the directory is limited. 




3769




 





 





 





 





 





 



   




3770




 





 





 





 





 





 



 B 




3771




 





 





 





 





 





 



   




3772




 





 





 





 





 





 



 How to get all files in the C directory including all subdirectories below of any depth: 




3773




 





 





 





 





 





 



   




3774




 





 





 





 





 





 



  my @files=("/tmp"); 




3775




 





 





 





 





 





 



  map {-d $_ and unshift @files,$_ or push @files,$_} readdirectory(shift(@files)) while -d $files[0]; 




3776




 





 





 





 





 





 



   




3777




 





 





 





 





 





 



 ...or to avoid symlinks and only get real files: 




3778




 





 





 





 





 





 



   




3779




 





 





 





 





 





 



  map {-d and !-l and unshift @files,$_ or -f and !-l and push @files,$_} readdirectory(shift(@files)) while -d $files[0]; 




3780




 





 





 





 





 





 



   




3781




 





 





 





 





 





 



 =cut 




3782




 





 





 





 





 





 



   




3783




 





 





 





 





 





 



 sub readdirectory { 




3784



  
0
  




 





 




  
0
  



  
1
  




0



   my $dir=shift; 




3785



  
0
  




 





 





 





 





0



   opendir(my $D,$dir); 




3786



  
0
  




 





 





 





 





0



   my @filer=map "$dir/$_", grep {!/^\.\.?$/} readdir($D); 




 



  
0
  




 





 





 





 





0



   




3787



  
0
  




 





 





 





 





0



   closedir($D); 




3788



  
0
  




 





 





 





 





0



   return @filer; 




3789




 





 





 





 





 





 



 } 




3790




 





 





 





 





 





 



   




3791




 





 





 





 





 





 



 =head2 basename 




3792




 





 





 





 





 





 



   




3793




 





 





 





 





 





 



 The basename and dirname functions behaves like the *nix shell commands with the same names. 




3794




 





 





 





 





 





 



   




3795




 





 





 





 





 





 



 B One or two arguments: Filename and an optional suffix 




3796




 





 





 





 





 





 



   




3797




 





 





 





 





 





 



 B Returns the filename with any directory and (if given) the suffix removed. 




3798




 





 





 





 





 





 



   




3799




 





 





 





 





 





 



  basename('/usr/bin/perl')                   # returns 'perl' 




3800




 





 





 





 





 





 



  basename('/usr/local/bin/report.pl','.pl')  # returns 'report' since .pl at the end is removed 




3801




 





 





 





 





 





 



  basename('report2.pl','.pl')                # returns 'report2' 




3802




 





 





 





 





 





 



  basename('report2.pl','.\w+')               # returns 'report2.pl', probably not what you meant 




3803




 





 





 





 





 





 



  basename('report2.pl',qr/.\w+/)             # returns 'report2', use qr for regex 




3804




 





 





 





 





 





 



   




3805




 





 





 





 





 





 



 =head2 dirname 




3806




 





 





 





 





 





 



   




3807




 





 





 





 





 





 



 B A filename including path 




3808




 





 





 





 





 





 



   




3809




 





 





 





 





 





 



 B Removes the filename path and returns just the directory path up until but not including 




3810




 





 





 





 





 





 



 the last /. Return just a one char C<< . >> (period string) if there is no directory in the input. 




3811




 





 





 





 





 





 



   




3812




 





 





 





 





 





 



  dirname('/usr/bin/perl')                    # returns '/usr/bin' 




3813




 





 





 





 





 





 



  dirname('perl')                             # returns '.' 




3814




 





 





 





 





 





 



   




3815




 





 





 





 





 





 



 =head2 username 




3816




 





 





 





 





 





 



   




3817




 





 





 





 





 





 



 Returns the current linux/unix username, for example the string root 




3818




 





 





 





 





 





 



   




3819




 





 





 





 





 





 



  print username();                        #just (getpwuid($<))[0] but more readable perhaps 




3820




 





 





 





 





 





 



   




3821




 





 





 





 





 





 



 =cut 




3822




 





 





 





 





 





 



   




3823




8




  
100
  




 




  
8
  



  
1
  




3286



 sub basename { my($f,$s)=(@_,'');$s=quotemeta($s)if!ref($s);$f=~m,^(.*/)?([^/]*?)($s)?$,;$2 } 




 




8





 





 





 





 





25



   




 




8





 





 





 





 





226



   




 




8





 





 





 





 





38



   




3824




2




  
100
  



  
 66
  



  
2
  



  
1
  




438



 sub dirname  { $_[0]=~m,^(.*)/,;defined($1) && length($1) ? $1 : '.' } 




 




2





 





 





 





 





23



   




3825



  
0
  




 





 




  
0
  



  
1
  




0



 sub username { (getpwuid($<))[0] } 




3826




 





 





 





 





 





 



   




3827




 





 





 





 





 





 



 =head2 wipe 




3828




 





 





 





 





 





 



   




3829




 





 





 





 





 





 



 Deletes a file by "wiping" it on the disk. Overwrites the file before deleting. (May not work properly on SSDs) 




3830




 





 





 





 





 





 



   




3831




 





 





 





 





 





 



 B 




3832




 





 





 





 





 





 



 * Arg 1: A filename 




3833




 





 





 





 





 





 



 * Optional arg 2: number of times to overwrite file. Default is 3 if omitted, 0 or undef 




3834




 





 





 





 





 





 



 * Optional arg 3: keep (true/false), wipe() but no delete of file 




3835




 





 





 





 





 





 



   




3836




 





 





 





 





 





 



 B Same as the C (remove file): 1 for success, 0 or false for failure. 




3837




 





 





 





 





 





 



   




3838




 





 





 





 





 





 



 See also: L, L 




3839




 





 





 





 





 





 



   




3840




 





 





 





 





 





 



 =cut 




3841




 





 





 





 





 





 



   




3842




 





 





 





 





 





 



 sub wipe { 




3843




2





 





 




  
2
  



  
1
  




704



   my($file,$times,$keep)=@_; 




3844




2





 




  
100
  




 





 





14



   $times||=3; 




3845




2




  
 50
  



  
 33
  




 





 





82



   croak "ERROR: File $file nonexisting\n" if not -f $file or not -e $file; 




3846




2





 





 





 





 





28



   my $size=-s$file; 




3847




2




  
 50
  




 





 





 





78



   open my $WIFH, '+<', $file or croak "ERROR: Unable to open $file: $!\n"; 




3848




2





 





 





 





 





5



   binmode($WIFH); 




3849




2





 





 





 





 





8



   for(1..$times){ 




3850




4





 





 





 





 





16



     my $block=chr(int(rand(256))) x 1024;#hm 




3851




4





 





 





 





 





10



     for(0..($size/1024)){ 




3852




73





 





 





 





 





521



       seek($WIFH,$_*1024,0); 




3853




73





 





 





 





 





142



       print $WIFH $block; 




3854




 





 





 





 





 





 



     } 




3855




 





 





 





 





 





 



   } 




3856




2





 





 





 





 





30



   close($WIFH); 




3857




2




  
100
  




 





 





 





141



   $keep || unlink($file); 




3858




 





 





 





 





 





 



 } 




3859




 





 





 





 





 





 



   




3860




 





 





 





 





 





 



 =head2 chall 




3861




 





 





 





 





 





 



   




3862




 





 





 





 





 





 



 Does chmod + utime + chown on one or more files. 




3863




 





 





 





 





 





 



   




3864




 





 





 





 





 





 



 Returns the number of files of which those operations was successful. 




3865




 





 





 





 





 





 



   




3866




 





 





 





 





 





 



 Mode, uid, gid, atime and mtime are set from the array ref in the first argument. 




3867




 





 





 





 





 





 



   




3868




 





 





 





 





 





 



 The first argument references an array which is exactly like an array returned from perls internal C -function. 




3869




 





 





 





 





 





 



   




3870




 





 





 





 





 





 



 Example: 




3871




 





 





 





 





 





 



   




3872




 





 





 





 





 





 



  my @stat=stat($filenameA); 




3873




 





 





 





 





 





 



  chall( \@stat,       $filenameB, $filenameC, ... );  # by stat-array 




3874




 





 





 





 





 





 



  chall( $filenameA,   $filenameB, $filenameC, ... );  # by file name 




3875




 





 





 





 





 





 



   




3876




 





 





 





 





 





 



 Copies the chmod, owner, group, access time and modify time from file A to file B and C. 




3877




 





 





 





 





 





 



   




3878




 





 





 





 





 





 



 See C, C, C, C 




3879




 





 





 





 





 





 



   




3880




 





 





 





 





 





 



 =cut 




3881




 





 





 





 





 





 



   




3882




 





 





 





 





 





 



   




3883




 





 





 





 





 





 



 sub chall { 




3884




 





 





 





 





 





 



   my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks ) 




3885




1




  
 50
  




 




  
1
  



  
1
  




28244



     = ref($_[0]) ? @{shift()} : stat(shift()); 




 




1





 





 





 





 





4



   




3886




1





 





 





 





 





2



   my $successful=0; 




3887




1




  
 50
  



  
 33
  




 





 





4



   for(@_){ chmod($mode,$_) && utime($atime,$mtime,$_) && chown($uid,$gid,$_) && $successful++ } 




 




1





 




  
 33
  




 





 





73



   




3888




1





 





 





 





 





3



   return $successful; 




3889




 





 





 





 





 





 



 } 




3890




 





 





 





 





 





 



   




3891




 





 





 





 





 





 



 =head2 makedir 




3892




 





 





 





 





 





 



   




3893




 





 





 





 





 





 



 Input: One or two arguments. 




3894




 





 





 





 





 





 



   




3895




 





 





 





 





 





 



 Works like perls C except that C will create nesessary parent directories if they dont exists. 




3896




 





 





 





 





 





 



   




3897




 





 





 





 





 





 



 First input argument: A directory name (absolute, starting with C< / > or relative). 




3898




 





 





 





 





 





 



   




3899




 





 





 





 





 





 



 Second input argument: (optional) permission bits. Using the normal C<< 0777^umask() >> as the default if no second input argument is provided. 




3900




 





 





 





 





 





 



   




3901




 





 





 





 





 





 



 Example: 




3902




 





 





 





 





 





 



   




3903




 





 





 





 





 





 



  makedir("dirB/dirC") 




3904




 





 





 





 





 





 



   




3905




 





 





 





 





 





 



 ...will create directory C if it does not already exists, to be able to create C inside C. 




3906




 





 





 





 





 





 



   




3907




 





 





 





 





 





 



 Returns true on success, otherwise false. 




3908




 





 





 





 





 





 



   




3909




 





 





 





 





 





 



 C memoizes directories it has checked for existence before (trading memory and for speed). 




3910




 





 





 





 





 





 



 Thus directories removed during running the script is not discovered by makedir. 




3911




 





 





 





 





 





 



   




3912




 





 





 





 





 





 



 See also C<< perldoc -f mkdir >>, C<< man umask >> 




3913




 





 





 





 





 





 



   




3914




 





 





 





 





 





 



 =cut 




3915




 





 





 





 





 





 



   




3916




 





 





 





 





 





 



 our %MAKEDIR; 




3917




 





 





 





 





 





 



   




3918




 





 





 





 





 





 



 sub makedir { 




3919



  
0
  




 





 




  
0
  



  
1
  




0



   my($d,$p,$dd)=@_; 




3920



  
0
  



  
  0
  




 





 





 





0



   $p=0777^umask() if !defined$p; 




3921




 





 





 





 





 





 



   ( 




3922




 





 





 





 





 





 



   $MAKEDIR{$d} or -d$d or mkdir($d,$p) #or croak("mkdir $d, $p") 




3923




 





 





 





 





 





 



   or ($dd)=($d=~m,^(.+)/+([^/]+)$,) and makedir($dd,$p) and mkdir($d,$p) #or die; 




3924



  
0
  



  
  0
  



  
  0
  




 





 





0



   ) and ++$MAKEDIR{$d}; 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




3925




 





 





 





 





 





 



 } 




3926




 





 





 





 





 





 



   




3927




 





 





 





 





 





 



 =head2 md5sum 




3928




 





 





 





 





 





 



   




3929




 





 





 





 





 





 



 B a filename. 




3930




 





 





 





 





 





 



   




3931




 





 





 





 





 





 



 B a string of 32 hexadecimal chars from 0-9 or a-f. 




3932




 





 





 





 





 





 



   




3933




 





 





 





 





 





 



 Example, the md5sum gnu/linux command without options could be implementet like this: 




3934




 





 





 





 





 





 



   




3935




 





 





 





 





 





 



  use Acme::Tools; 




3936




 





 





 





 





 





 



  print eval{ md5sum($_)."  $_\n" } || $@ for @ARGV; 




3937




 





 





 





 





 





 



   




3938




 





 





 





 





 





 



 This sub requires L, which is a core perl-module since 




3939




 





 





 





 





 





 



 version 5.?.?  It does not slurp the files or spawn new processes. 




3940




 





 





 





 





 





 



   




3941




 





 





 





 





 





 



 =cut 




3942




 





 





 





 





 





 



   




3943




 





 





 





 





 





 



 sub md5sum { 




3944




2





 





 




  
2
  



  
1
  




18



   require Digest::MD5; 




3945




2





 





 





 





 





4



   my $fn=shift; 




3946




2




  
100
  




 





 





 





212



   croak "md5sum: $fn is a directory (no md5sum)" if -d $fn; 




3947




1




  
 50
  




 





 





 





34



   open my $FH, '<', $fn or croak "Could not open file $fn for md5sum() $!"; 




3948




1





 





 





 





 





2



   binmode($FH); 




3949




1





 





 





 





 





3



   my $r = eval { Digest::MD5->new->addfile($FH)->hexdigest }; 




 




1





 





 





 





 





19



   




3950




1




  
 50
  




 





 





 





8



   croak "md5sum on $fn failed ($@)\n" if $@; 




3951




1





 





 





 





 





16



   $r; 




3952




 





 





 





 





 





 



 } 




3953




 





 





 





 





 





 



   




3954




 





 





 





 





 





 



 =head2 read_conf 




3955




 





 





 





 





 





 



   




3956




 





 





 





 





 





 



 B A file name or a reference to a string with settings in the format described below. 




3957




 





 





 





 





 





 



   




3958




 





 





 





 





 





 



 B A reference to a hash. This hash will have the settings from the file (or stringref). 




3959




 





 





 





 





 





 



 The hash do not have to be empty beforehand. 




3960




 





 





 





 





 





 



   




3961




 





 





 





 





 





 



 Returns a hash with the settings as in this examples: 




3962




 





 





 





 





 





 



   




3963




 





 





 





 





 





 



  my %conf = read_conf('/etc/your/thing.conf'); 




3964




 





 





 





 





 





 



  print $conf{sectionA}{knobble};  #prints ABC if the file is as shown below 




3965




 





 





 





 





 





 



  print $conf{sectionA}{gobble};   #prints ZZZ, the last gobble 




3966




 





 





 





 





 





 



  print $conf{switch};             #prints OK here as well, unsectioned value 




3967




 





 





 





 





 





 



  print $conf{part2}{password};    #prints oh:no= x 




3968




 





 





 





 





 





 



   




3969




 





 





 





 





 





 



 File use for the above example: 




3970




 





 





 





 





 





 



   




3971




 





 





 





 





 





 



  switch:    OK       #before first section, the '' (empty) section 




3972




 





 





 





 





 





 



  [sectionA] 




3973




 





 





 





 





 





 



  knobble:   ABC 




3974




 





 





 





 





 





 



  gobble:    XYZ      #this gobble is overwritten by the gobble on the next line 




3975




 





 





 





 





 





 



  gobble:    ZZZ 




3976




 





 





 





 





 





 



  [part2] 




3977




 





 





 





 





 





 



  password:  oh:no= x  #should be better 




3978




 





 





 





 





 





 



  text:      { values starting with { continues 




3979




 





 





 





 





 





 



               until reaching a line with } 




3980




 





 





 





 





 





 



   




3981




 





 





 





 





 





 



 Everything from # and behind is regarded comments and ignored. Comments can be on any line. 




3982




 





 





 





 





 





 



 To keep a # char, put a \ in front of it. 




3983




 





 





 





 





 





 



   




3984




 





 





 





 





 





 



 A C< : > or C< = > separates keys and values.  Spaces at the beginning or end of lines are 




3985




 





 





 





 





 





 



 ignored (after removal of #comments), as are any spaces before and after : and = separators. 




3986




 





 





 





 





 





 



   




3987




 





 





 





 





 





 



 Empty lines or lines with no C< : > or C< = > is also ignored. Keys and values can contain 




3988




 





 





 





 





 





 



 internal spaces and tabs, but not at the beginning or end. 




3989




 





 





 





 





 





 



   




3990




 





 





 





 





 





 



 Multi-line values must start and end with { and }. Using { and } keep spaces at the start 




3991




 





 





 





 





 





 



 or end in both one-line and multi-line values. 




3992




 





 





 





 





 





 



   




3993




 





 





 





 





 





 



 Sections are marked with C<< [sectionname] >>.  Section names, keys and values is case 




3994




 





 





 





 





 





 



 sensitive. C above the first section or below and empty C<< [] >> is placed 




3995




 





 





 





 





 





 



 both in the empty section in the returned hash and as top level key/values. 




3996




 





 





 





 





 





 



   




3997




 





 





 





 





 





 



 C can be a simpler alternative to the core module L which has 




3998




 





 





 





 





 





 



 its own hassles. 




3999




 





 





 





 





 





 



   




4000




 





 





 





 





 





 



  $Acme::Tools::Read_conf_empty_section=1;        #default 0 (was 1 in version 0.16) 




4001




 





 





 





 





 





 



  my %conf = read_conf('/etc/your/thing.conf'); 




4002




 





 





 





 





 





 



  print $conf{''}{switch};                        #prints OK with the file above 




4003




 





 





 





 





 





 



  print $conf{switch};                            #prints OK here as well 




4004




 





 





 





 





 





 



   




4005




 





 





 





 





 





 



 =cut 




4006




 





 





 





 





 





 



   




4007




 





 





 





 





 





 



 our $Read_conf_empty_section=0; 




4008




 





 





 





 





 





 



 sub read_conf { 




4009




3





 





 




  
3
  



  
1
  




18



   my($fn,$hr)=(@_,{}); 




4010




3




  
100
  




 





 





 





14



   my $conf=ref($fn)?$$fn:readfile($fn); 




4011




3





 





 





 





 





101



   $conf=~s,\s*(?




4012




3





 





 





 





 





32



   my($section,@l)=('',split"\n",$conf); 




4013




3





 





 





 





 





12



   while(@l) { 




4014




63





 





 





 





 





93



     my $l=shift@l; 




4015




63




  
100
  




 





 





 





330



     if( $l=~/^\s*\[\s*(.*?)\s*\]/ ) { 




 




 




  
100
  




 





 





 





 



   




4016




12





 





 





 





 





22



       $section=$1; 




4017




12





 




  
100
  




 





 





68



       $$hr{$1}||={}; 




4018




 





 





 





 





 





 



     } 




4019




 





 





 





 





 





 



     elsif( $l=~/^\s*([^\:\=]+)[:=]\s*(.*?)\s*$/ ) { 




4020




33





 




  
 66
  



  
33
  




 





108



       my $ml=sub{my$v=shift;$v.="\n".shift@l while $v=~/^\{[^\}]*$/&&@l;$v=~s/^\{(.*)\}\s*$/$1/s;$v=~s,\\#,#,g;$v}; 




 




33





 





 





 





 





71



   




 




33





 





 





 





 





168



   




 




33





 





 





 





 





68



   




 




33





 





 





 





 





52



   




 




33





 





 





 





 





60



   




4021




33





 





 





 





 





71



       my $v=&$ml($2); 




4022




33




  
100
  



  
 66
  




 





 





145



       $$hr{$section}{$1}=$v if length($section) or $Read_conf_empty_section; 




4023




33




  
100
  




 





 





 





175



       $$hr{$1}=$v if !length($section); 




4024




 





 





 





 





 





 



     } 




4025




 





 





 





 





 





 



   } 




4026




3





 





 





 





 





25



   %$hr; 




4027




 





 





 





 





 





 



 } 




4028




 





 





 





 





 





 



 #  my $incfn=sub{return $1 if $_[0]=~m,^(/.+),;my$f=$fn;$f=~s,[^/]+$,$_[0],;$f}; 




4029




 





 





 





 





 





 



 #    s,]+)>,"".readfile(&$incfn($1)),eg; #todo 




4030




 





 





 





 





 





 



   




4031




 





 





 





 





 





 



   




4032




 





 





 





 





 





 



 =head2 openstr 




4033




 





 





 





 





 





 



   




4034




 





 





 





 





 





 



                                             # returned from openstr: 




4035




 





 





 





 





 





 



   open my $FH, openstr("fil.txt")  or die;  # fil.txt 




4036




 





 





 





 





 





 



   open my $FH, openstr("fil.gz")   or die;  # zcat fil.gz | 




4037




 





 





 





 





 





 



   open my $FH, openstr("fil.bz2")  or die;  # bzcat fil.bz2 | 




4038




 





 





 





 





 





 



   open my $FH, openstr("fil.xz")   or die;  # xzcat fil.xz | 




4039




 





 





 





 





 





 



   open my $FH, openstr(">fil.txt") or die;  # > fil.txt 




4040




 





 





 





 





 





 



   open my $FH, openstr(">fil.gz")  or die;  # | gzip > fil.gz 




4041




 





 





 





 





 





 



   open my $FH, openstr(">fil.bz2") or die;  # | bzip2 > fil.bz2 




4042




 





 





 





 





 





 



   open my $FH, openstr(">fil.xz")  or die;  # | xz    > fil.bz2 




4043




 





 





 





 





 





 



   




4044




 





 





 





 





 





 



 Environment variable PATH is used. So in the examples above, /bin/gzip 




4045




 





 





 





 





 





 



 is returned instead of gzip if /bin is the first directory in 




4046




 





 





 





 





 





 



 $ENV{PATH} containing an executable file gzip. Dirs /usr/bin, /bin and 




4047




 





 





 





 





 





 



 /usr/local/bin is added to PATH in openstr(). They are checked even if 




4048




 





 





 





 





 





 



 PATH is empty. 




4049




 





 





 





 





 





 



   




4050




 





 





 





 





 





 



 =cut 




4051




 





 





 





 





 





 



   




4052




 





 





 





 





 





 



 our @Openstrpath=(grep$_,split(":",$ENV{PATH}),qw(/usr/bin /bin /usr/local/bin)); 




4053




 





 





 





 





 





 



 sub openstr { 




4054




14





 





 




  
14
  



  
1
  




4221



   my($fn,$ext)=(shift()=~/^(.*?(?:\.(t?gz|bz2|xz))?)$/i); 




4055




14




  
100
  




 





 





 





389



   return $fn if !$ext; 




4056




6




  
 50
  




 




  
6
  




 





42



   my $prog=sub{@Openstrpath or return $_[0];(grep -x$_, map "$_/$_[0]", @Openstrpath)[0] or die}; 




 




6




  
 50
  




 





 





 





26



   




 




6





 





 





 





 





108929



   




4057




 





 





 





 





 





 



   $fn =~ /^\s*>/ 




4058




 





 





 





 





 





 



       ?  "| ".(&$prog({qw/tgz gzip gz gzip bz2 bzip2 xz xz/   }->{lc($ext)})).$fn 




4059




6




  
100
  




 





 





 





89



       :        &$prog({qw/tgz zcat gz zcat bz2 bzcat xz xzcat/}->{lc($ext)})." $fn |"; 




4060




 





 





 





 





 





 



 } 




4061




 





 





 





 





 





 



   




4062




 





 





 





 





 





 



 =head1 TIME FUNCTIONS 




4063




 





 





 





 





 





 



   




4064




 





 





 





 





 





 



 =head2 tms - timestring, works somewhat like the Gnu/Linux C command and Oracle's C 




4065




 





 





 





 





 





 



   




4066




 





 





 





 





 





 



 Converts timestamps to more readable forms of time strings. 




4067




 





 





 





 





 





 



   




4068




 





 





 





 





 





 



 Converts seconds since I and time strings on the form C to other forms. 




4069




 





 





 





 





 





 



   




4070




 





 





 





 





 





 



 B One, two or three arguments. 




4071




 





 





 





 





 





 



   




4072




 





 





 





 





 





 



 B A format string. 




4073




 





 





 





 





 





 



   




4074




 





 





 





 





 





 



 B An epock C number or a time 




4075




 





 





 





 





 





 



 string of the form YYYYMMDD-HH24:MI:SS or YYYYMMDDTHH:MI:SS or 




4076




 





 





 





 





 





 



 YYYY-MM-DDTHH:MI:SS (in which T is litteral and HH is the 24-hour 




4077




 





 





 





 





 





 



 version of hours) or YYYYMMDD. Uses the current C if the 




4078




 





 





 





 





 





 



 second argument is missing. 




4079




 





 





 





 





 





 



   




4080




 





 





 





 





 





 



 TODO: Formats with % as in C (C<%Y%m%d> and so on) 




4081




 





 





 





 





 





 



   




4082




 





 





 





 





 





 



 B True or false. If true and first argument 




4083




 





 





 





 





 





 



 is eight digits: Its interpreted as a date like YYYYMMDD time string, 




4084




 





 





 





 





 





 



 not an epoch time.  If true and first argument is six digits its 




4085




 





 





 





 





 





 



 interpreted as a date like DDMMYY (not YYMMDD!). 




4086




 





 





 





 





 





 



   




4087




 





 





 





 





 





 



 B a date or clock string on the wanted form. 




4088




 





 





 





 





 





 



   




4089




 





 





 





 





 





 



 B 




4090




 





 





 





 





 





 



   




4091




 





 





 





 





 





 



 Prints C<< 3. july 1997 >> if thats the dato today: 




4092




 





 





 





 





 





 



   




4093




 





 





 





 





 





 



   perl -MAcme::Tools -le 'print timestr("D. month YYYY")' 




4094




 





 





 





 





 





 



   




4095




 





 





 





 





 





 



   print tms("HH24:MI");              # prints 23:55 if thats the time now 




4096




 





 





 





 





 





 



   tms("HH24:MI",time());             # ...same,since time() is the default 




4097




 





 





 





 





 





 



   tms("HH:MI",time()-5*60);          # 23:50 if that was the time 5 minutes ago 




4098




 





 





 





 





 





 



   tms("HH:MI",time()-5*60*60);       # 18:55 if thats the time 5 hours ago 




4099




 





 





 





 





 





 



   tms("Day Month Dth YYYY HH:MI");   # Saturday July 1st 2004 23:55    (big S, big J) 




4100




 





 





 





 





 





 



   tms("Day D. Month YYYY HH:MI");    # Saturday 8. July 2004 23:55     (big S, big J) 




4101




 





 





 





 





 





 



   tms("DAY D. MONTH YYYY HH:MI");    # SATURDAY 8. JULY 2004 23:55     (upper) 




4102




 





 





 





 





 





 



   tms("dy D. month YYYY HH:MI");     # sat 8. july 2004 23:55          (small s, small j) 




4103




 





 





 





 





 





 



   tms("Dy DD. MON YYYY HH12:MI am"); # Sat 08. JUL 2004 11:55 pm       (HH12, am becomes pm if after 12) 




4104




 





 





 





 





 





 



   tms("DD-MON-YYYY");                # 03-MAY-2004                     (mon, english) 




4105




 





 





 





 





 





 



   




4106




 





 





 





 





 





 



 The following list of codes in the first argument will be replaced: 




4107




 





 





 





 





 





 



   




4108




 





 





 





 





 





 



   YYYY    Year, four digits 




4109




 





 





 





 





 





 



   YY      Year, two digits, i.e. 04 instead of 2004 




4110




 





 





 





 





 





 



   yyyy    Year, four digits, but nothing if its the current year 




4111




 





 





 





 





 





 



   YYYY|HH:MI  Year if its another year than the current, a time in hours and minutes elsewise 




4112




 





 





 





 





 





 



   MM      Month, two digits. I.e. 08 for August 




4113




 





 





 





 





 





 



   DD      Day of month, two digits. I.e. 01 (not 1) for the first day in a month 




4114




 





 





 





 





 





 



   D       Day of month, one digit. I.e. 1 (not 01) 




4115




 





 





 





 





 





 



   HH      Hour. From 00 to 23. 




4116




 





 





 





 





 





 



   HH24    Same as HH. 




4117




 





 





 





 





 





 



   HH12    12 becomes 12 (never 00), 13 becomes 01, 14 02 and so on. 




4118




 





 





 





 





 





 



           Note: 00 after midnight becomes 12 (am). Tip: always include the code 




4119




 





 





 





 





 





 



           am in a format string that uses HH12. 




4120




 





 





 





 





 





 



   MI      Minutt. Fra 00 til 59. 




4121




 





 





 





 





 





 



   SS      Sekund. Fra 00 til 59. 




4122




 





 





 





 





 





 



   am      Becomes am or pm 




4123




 





 





 





 





 





 



   pm      Same 




4124




 





 





 





 





 





 



   AM      Becomes AM or PM (upper case) 




4125




 





 





 





 





 





 



   PM      Same 




4126




 





 





 





 





 





 



   




4127




 





 





 





 





 





 



   Month   The full name of the month in English from January to December 




4128




 





 





 





 





 





 



   MONTH   Same in upper case (JANUARY) 




4129




 





 





 





 





 





 



   month   Same in lower case (january) 




4130




 





 





 





 





 





 



   Mont    Jan Feb Mars Apr May June July Aug Sep Oct Nov Dec 




4131




 





 





 





 





 





 



   Mont.   Jan. Feb. Mars Apr. May June July Aug. Sep. Oct. Nov. Dec. (always four chars) 




4132




 





 





 





 





 





 



   Mon     Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec            (always three chars) 




4133




 





 





 





 





 





 



   




4134




 





 





 





 





 





 



   Day     The full name of the weekday. Sunday to Saturday 




4135




 





 





 





 





 





 



   Dy      Three letters: Sun Mon Tue Wed Thu Fri Sat 




4136




 





 





 





 





 





 



   DAY     Upper case 




4137




 





 





 





 





 





 



   DY      Upper case 




4138




 





 





 





 





 





 



   Dth     1st 2nd 3rd 4th 5th ... 11th 12th ... 20th 21st 22nd 23rd 24th ... 30th 31st 




4139




 





 





 





 





 





 



   




4140




 





 





 





 





 





 



   WW      Week number of the year 01-53 according to the ISO8601-definition (which most countries uses) 




4141




 





 





 





 





 





 



   WWUS    Week number of the year 01-53 according to the most used definition in the USA. 




4142




 





 





 





 





 





 



           Other definitions also exists. 




4143




 





 





 





 





 





 



   




4144




 





 





 





 





 





 



   epoch   Converts a time string from YYYYMMDD-HH24:MI:SS, YYYYMMDD-HH24:MI:SS, YYYYMMDDTHH:MI:SS, 




4145




 





 





 





 





 





 



           YYYY-MM-DDTHH:MI:SS or YYYYMMDD to the number of seconds since January 1st 1970. 




4146




 





 





 





 





 





 



           Commonly known as the Unix epoch. 




4147




 





 





 





 





 





 



   




4148




 





 





 





 





 





 



   JDN     Julian day number. Integer. The number of days since the day starting at noon on January 1 4713 BC 




4149




 





 





 





 





 





 



   JD      Same as JDN but a float accounting for the time of day 




4150




 





 





 





 





 





 



   




4151




 





 





 





 





 





 



 TODO:  sub smt() (tms backward... or something better named, converts the other way) 




4152




 





 





 





 





 





 



        As to_date and to_char in Oracle. Se maybe L instead 




4153




 





 





 





 





 





 



   




4154




 





 





 





 





 





 



 B (optional) Is_date. False|true, default false. If true, the second argument is 




4155




 





 





 





 





 





 



 interpreted as a date of the form YYYYMMDD, not as a number of seconds since epoch (January 1st 1970). 




4156




 





 





 





 





 





 



   




4157




 





 





 





 





 





 



 =cut 




4158




 





 





 





 





 





 



   




4159




 





 





 





 





 





 



 #Se også L og L 




4160




 





 





 





 





 





 



   




4161




 





 





 





 





 





 



 our $Tms_pattern; 




4162




 





 





 





 





 





 



 our %Tms_str= 




4163




 





 





 





 





 





 



 	  ('MÅNED' => [4, 'JANUAR','FEBRUAR','MARS','APRIL','MAI','JUNI','JULI', 




4164




 





 





 





 





 





 



 		          'AUGUST','SEPTEMBER','OKTOBER','NOVEMBER','DESEMBER' ], 




4165




 





 





 





 





 





 



 	   'Måned' => [4, 'Januar','Februar','Mars','April','Mai','Juni','Juli', 




4166




 





 





 





 





 





 



 		          'August','September','Oktober','November','Desember'], 




4167




 





 





 





 





 





 



 	   'måned' => [4, 'januar','februar','mars','april','mai','juni','juli', 




4168




 





 





 





 





 





 



 		          'august','september','oktober','november','desember'], 




4169




 





 





 





 





 





 



 	   'MÅNE.' => [4, 'JAN.','FEB.','MARS','APR.','MAI','JUNI','JULI','AUG.','SEP.','OKT.','NOV.','DES.'], 




4170




 





 





 





 





 





 



 	   'Måne.' => [4, 'Jan.','Feb.','Mars','Apr.','Mai','Juni','Juli','Aug.','Sep.','Okt.','Nov.','Des.'], 




4171




 





 





 





 





 





 



 	   'måne.' => [4, 'jan.','feb.','mars','apr.','mai','juni','juli','aug.','sep.','okt.','nov.','des.'], 




4172




 





 





 





 





 





 



 	   'MÅNE'  => [4, 'JAN','FEB','MARS','APR','MAI','JUNI','JULI','AUG','SEP','OKT','NOV','DES'], 




4173




 





 





 





 





 





 



 	   'Måne'  => [4, 'Jan','Feb','Mars','Apr','Mai','Juni','Juli','Aug','Sep','Okt','Nov','Des'], 




4174




 





 





 





 





 





 



 	   'måne'  => [4, 'jan','feb','mars','apr','mai','juni','juli','aug','sep','okt','nov','des'], 




4175




 





 





 





 





 





 



 	   'MÅN'   => [4, 'JAN','FEB','MAR','APR','MAI','JUN','JUL','AUG','SEP','OKT','NOV','DES'], 




4176




 





 





 





 





 





 



 	   'Mån'   => [4, 'Jan','Feb','Mar','Apr','Mai','Jun','Jul','Aug','Sep','Okt','Nov','Des'], 




4177




 





 





 





 





 





 



 	   'mån'   => [4, 'jan','feb','mar','apr','mai','jun','jul','aug','sep','okt','nov','des'], 




4178




 





 





 





 





 





 



 	   'MONTH' => [4, 'JANUARY','FEBRUARY','MARCH','APRIL','MAY','JUNE','JULY', 




4179




 





 





 





 





 





 



 		          'AUGUST','SEPTEMBER','OCTOBER','NOVEMBER','DECEMBER'], 




4180




 





 





 





 





 





 



 	   'Month' => [4, 'January','February','March','April','May','June','July', 




4181




 





 





 





 





 





 



 		          'August','September','October','November','December'], 




4182




 





 





 





 





 





 



 	   'month' => [4, 'january','february','march','april','may','june','july', 




4183




 





 





 





 





 





 



 		          'august','september','october','november','december'], 




4184




 





 





 





 





 





 



 	   'MONT.' => [4, 'JAN.','FEB.','MAR.','APR.','MAY','JUNE','JULY','AUG.','SEP.','OCT.','NOV.','DEC.'], 




4185




 





 





 





 





 





 



 	   'Mont.' => [4, 'Jan.','Feb.','Mar.','Apr.','May','June','July','Aug.','Sep.','Oct.','Nov.','Dec.'], 




4186




 





 





 





 





 





 



 	   'mont.' => [4, 'jan.','feb.','mar.','apr.','may','june','july','aug.','sep.','oct.','nov.','dec.'], 




4187




 





 





 





 





 





 



 	   'MONT'  => [4, 'JAN','FEB','MAR','APR','MAY','JUNE','JULY','AUG','SEP','OCT','NOV','DEC'], 




4188




 





 





 





 





 





 



 	   'Mont'  => [4, 'Jan','Feb','Mar','Apr','May','June','July','Aug','Sep','Oct','Nov','Dec'], 




4189




 





 





 





 





 





 



 	   'mont'  => [4, 'jan','feb','mar','apr','may','june','july','aug','sep','oct','nov','dec'], 




4190




 





 





 





 





 





 



 	   'MON'   => [4, 'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'], 




4191




 





 





 





 





 





 



 	   'Mon'   => [4, 'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'], 




4192




 





 





 





 





 





 



 	   'mon'   => [4, 'jan','feb','mar','apr','may','jun','jul','aug','sep','oct','nov','dec'], 




4193




 





 





 





 





 





 



 	   'DAY'   => [6, 'SUNDAY','MONDAY','TUESDAY','WEDNESDAY','THURSDAY','FRIDAY','SATURDAY'], 




4194




 





 





 





 





 





 



 	   'Day'   => [6, 'Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'], 




4195




 





 





 





 





 





 



 	   'day'   => [6, 'sunday','monday','tuesday','wednesday','thursday','friday','saturday'], 




4196




 





 





 





 





 





 



 	   'DY'    => [6, 'SUN','MON','TUE','WED','THU','FRI','SAT'], 




4197




 





 





 





 





 





 



 	   'Dy'    => [6, 'Sun','Mon','Tue','Wed','Thu','Fri','Sat'], 




4198




 





 





 





 





 





 



 	   'dy'    => [6, 'sun','mon','tue','wed','thu','fri','sat'], 




4199




 





 





 





 





 





 



 	   'DAG'   => [6, 'SØNDAG','MANDAG','TIRSDAG','ONSDAG','TORSDAG','FREDAG','LØRDAG'], 




4200




 





 





 





 





 





 



 	   'Dag'   => [6, 'Søndag','Mandag','Tirsdag','Onsdag','Torsdag','Fredag','Lørdag'], 




4201




 





 





 





 





 





 



 	   'dag'   => [6, 'søndag','mandag','tirsdag','onsdag','torsdag','fredag','lørdag'], 




4202




 





 





 





 





 





 



 	   'DG'    => [6, 'SØN','MAN','TIR','ONS','TOR','FRE','LØR'], 




4203




 





 





 





 





 





 



 	   'Dg'    => [6, 'Søn','Man','Tir','Ons','Tor','Fre','Lør'], 




4204




 





 





 





 





 





 



 	   'dg'    => [6, 'søn','man','tir','ons','tor','fre','lør'], 




4205




 





 





 





 





 





 



 	   ); 




4206




 





 





 





 





 





 



 my $_tms_inited=0; 




4207




 





 





 





 





 





 



 sub tms_init { 




4208




1




  
 50
  




 




  
1
  



  
0
  




7



   return if $_tms_inited++; 




4209




1





 





 





 





 





5



   for(qw(MAANED Maaned maaned MAAN Maan maan),'MAANE.','Maane.','maane.'){ 




4210




9





 





 





 





 





36



     $Tms_str{$_}=$Tms_str{replace($_,"aa","å","AA","Å")}; 




4211




 





 





 





 





 





 



   } 




4212




45





 





 





 





 





121



   $Tms_pattern=join("|",map{quotemeta($_)} 




4213




1





 





 





 





 





23



 			       sort{length($b)<=>length($a)} 




 




197





 





 





 





 





402



   




4214




 





 





 





 





 





 



 			       keys %Tms_str); 




4215




 





 





 





 





 





 



   #uten sort kan "måned" bli "mared", fordi "mån"=>"mar" 




4216




 





 





 





 





 





 



 } 




4217




 





 





 





 





 





 



   




4218




 





 





 




  
0
  



  
0
  




 



 sub totime { 




4219




 





 





 





 





 





 



   




4220




 





 





 





 





 





 



 } 




4221




 





 





 





 





 





 



   




4222




 





 





 





 





 





 



 sub date_ok { 




4223



  
0
  




 





 




  
0
  



  
0
  




0



   my($y,$m,$d)=@_; 




4224



  
0
  



  
  0
  



  
  0
  




 





 





0



   return date_ok($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/; 




4225



  
0
  



  
  0
  




 





 





 





0



   return 0 if $y!~/^\d\d\d\d$/; 




4226



  
0
  



  
  0
  



  
  0
  




 





 





0



   return 0 if $m<1||$m>12||$d<1||$d>(31,$y%4||$y%100==0&&$y%400?28:29,31,30,31,30,31,31,30,31,30,31)[$m-1]; 




 




 




  
  0
  



  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




4227



  
0
  




 





 





 





 





0



   return 1; 




4228




 





 





 





 





 





 



 } 




4229




 





 





 





 





 





 



   




4230




 





 





 





 





 





 



 sub weeknum { 




4231



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



   return weeknum(tms('YYYYMMDD')) if @_<1; 




4232



  
0
  



  
  0
  



  
  0
  




 





 





0



   return weeknum($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/; 




4233



  
0
  




 





 





 





 





0



   my($year,$month,$day)= @_; 




4234



  
0
  




 





 





 





 





0



   eval{ 




4235



  
0
  



  
  0
  




 





 





 





0



     if(@_<2){ 




 




 




  
  0
  




 





 





 





 



   




4236



  
0
  



  
  0
  




 





 





 





0



       if($year=~/^\d{8}$/) { ($year,$month,$day)=unpack("A4A2A2",$year) } 




 



  
0
  



  
  0
  




 





 





 





0



   




4237



  
0
  




 





 





 





 





0



       elsif($year>99999999){ ($year,$month,$day)=(localtime($year))[5,4,3]; $year+=1900; $month++ } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




4238



  
0
  




 





 





 





 





0



       else {die} 




4239




 





 





 





 





 





 



     } 




4240



  
0
  




 





 





 





 





0



     elsif(@_!=3){croak} 




4241



  
0
  



  
  0
  




 





 





 





0



     croak if !date_ok(sprintf("%04d%02d%02d",$year,$month,$day)); 




4242




 





 





 





 





 





 



   }; 




4243



  
0
  



  
  0
  




 





 





 





0



   croak "ERROR: Wrong args Acme::Tools::weeknum(".join(",",@_).")" if $@; 




4244




28





 





 




  
28
  




 





23013



   use integer;#heltallsdivisjon 




 




28





 





 





 





 





303



   




 




28





 





 





 





 





158



   




4245



  
0
  




 





 





 





 





0



   my $y=$year+4800-(14-$month)/12; 




4246



  
0
  




 





 





 





 





0



   my $j=$day+(153*($month+(14-$month)/12*12-3)+2)/5+365*$y+$y/4-$y/100+$y/400-32045; 




4247



  
0
  




 





 





 





 





0



   my $d=($j+31741-$j%7)%146097%36524%1461; 




4248



  
0
  




 





 





 





 





0



   return (($d-$d/1460)%365+$d/1460)/7+1; 




4249




 





 





 





 





 





 



 } 




4250




 





 





 





 





 





 



   




4251




 





 





 





 





 





 



 sub tms { 




4252




40




  
 50
  



  
 66
  



  
40
  



  
1
  




56004



   return undef if @_>1 and not defined $_[1]; #time=undef => undef 




4253




40




  
100
  




 





 





 





107



   if(@_==1){ 




4254




2





 





 





 





 





15



     my @lt=localtime(); 




4255




2




  
 50
  




 





 





 





13



     $_[0] eq 'YYYY'     and return 1900+$lt[5]; 




4256




2




  
 50
  




 





 





 





9



     $_[0] eq 'YYYYMMDD' and return sprintf("%04d%02d%02d",1900+$lt[5],1+$lt[4],$lt[3]);  




4257




2




  
100
  



  
 66
  




 





 





56



     $_[0] =~ $Re_isnum  and @lt=localtime($_[0]) and return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]);  




4258




 





 





 





 





 





 



   } 




4259




39





 





 





 





 





72



   my($format,$time,$is_date)=@_; 




4260




39




  
100
  




 





 





 





96



   $time=time_fp() if !defined$time; 




4261




39




  
100
  



  
100
  




 





 





326



   ($time,$format)=($format,$time) if @_>=2 and $format=~/^[\d+\:\-\.]+$/; #swap /hm/ 




4262




39





 





 





 





 





203



   my @lt=localtime($time); 




4263




 





 





 





 





 





 



   #todo? $is_date=0 if $time=~s/^\@(\-?\d)/$1/; #@n where n is sec since epoch makes it clear that its not a formatted, as in `date` 




4264




 





 





 





 





 





 



   #todo? date --date='TZ="America/Los_Angeles" 09:00 next Fri' #`info date` 




4265




 





 





 





 





 





 



   #      Fri Nov 13 18:00:00 CET 2015 




4266




 





 





 





 





 





 



   #date --date="next Friday"  #--date or -d 




4267




 





 





 





 





 





 



   #date --date="last friday" 




4268




 





 





 





 





 





 



   #date --date="2 days ago" 




4269




 





 





 





 





 





 



   #date --date="yesterday" #or tomorrow 




4270




 





 





 





 





 





 



   #date --date="-1 day"  #date --date='10 week' 




4271




 





 





 





 





 





 



   




4272




39




  
 50
  




 





 





 





102



   if( $is_date ){ 




4273



  
0
  



  
  0
  




 




  
0
  




 





0



     my $yy2c=sub{10+$_[0]>$lt[5]%100?"20":"19"}; #hm 10+ 




 



  
0
  




 





 





 





 





0



   




4274



  
0
  



  
  0
  




 





 





 





0



     $time=totime(&$yy2c($1)."$1$2$3")."000000" if $time=~/^(\d\d)(\d\d)(\d\d)$/; 




4275



  
0
  



  
  0
  




 





 





 





0



     $time=totime("$1$2${3}000000")             if $time=~/^((?:18|19|20)\d\d)(\d\d)(\d\d)$/; #hm 18-20? 




4276




 





 





 





 





 





 



   } 




4277




 





 





 





 





 





 



   else { 




4278




39




  
 50
  




 





 





 





141



     $time = yyyymmddhh24miss_time("$1$2$3$4$5$6") #yyyymmddhh24miss_time ??? 




4279




 





 





 





 





 





 



       if $time=~/^((?:19|20|18)\d\d)          #yyyy 




4280




 





 





 





 





 





 



                   (0[1-9]|1[012])             #mm 




4281




 





 





 





 





 





 



                   (0[1-9]|[12]\d|3[01]) \-?   #dd 




4282




 





 





 





 





 





 



                   ([01]\d|2[0-3])       \:?   #hh24 




4283




 





 





 





 





 





 



                   ([0-5]\d)             \:?   #mi 




4284




 





 





 





 





 





 



                   ([0-5]\d)             $/x;  #ss 




4285




 





 





 





 





 





 



   } 




4286




39




  
100
  




 





 





 





78



   tms_init() if !$_tms_inited; 




4287




39




  
100
  




 





 





 





108



   return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]) if !$format; 




4288




38





 





 





 





 





463



   my %p=('%'=>'%', 




4289




 





 





 





 





 





 



 	 a=>'Dy', 




4290




 





 





 





 





 





 



 	 A=>'Day', 




4291




 





 





 





 





 





 



 	 b=>'Mon', 




4292




 





 





 





 





 





 



 	 b=>'Month', 




4293




 





 





 





 





 





 



 	 c=>'Dy Mon D HH:MI:SS YYYY', 




4294




 





 





 





 





 





 



 	 C=>'CC', 




4295




 





 





 





 





 





 



 	 d=>'DD', 




4296




 





 





 





 





 





 



 	 D=>'MM/DD/YY', 




4297




 





 





 





 





 





 



 	 e=>'D', 




4298




 





 





 





 





 





 



 	 F=>'YYYY-MM-DD', 




4299




 





 





 





 





 





 



         #G=>'',  




4300




 





 





 





 





 





 



 	 h=>'Month', H=>'HH24', I=>'HH12', 




4301




 





 





 





 





 





 



 	 j=>'DoY', #day of year 




4302




 





 





 





 





 





 



 	 k=>'H24', _H=>'H24', 




4303




 





 





 





 





 





 



 	 l=>'H12', _I=>'H12', 




4304




 





 





 





 





 





 



 	 m=>'MM', M=>'MI', 




4305




 





 





 





 





 





 



 	 n=>"\n", 




4306




 





 





 





 





 





 



 	#N=>'NS', #sprintf%09d,1e9*(time_fp()-time()) #000000000..999999999 




4307




 





 





 





 





 





 



 	 p=>'AM', #AM|PM upper (yes, opposite: date +%H%M%S%P%p) 




4308




 





 





 





 





 





 



 	 P=>'am', #am|pm lower 




4309




 





 





 





 





 





 



 	 S=>'SS', 




4310




 





 





 





 





 





 



 	 t=>"\t", 




4311




 





 





 





 





 





 



 	 T=>'HH24:MI:SS', 




4312




 





 





 





 





 





 



 	 u=>'DoW',  #day of week 1..7, 1=mon 7=sun 




4313




 





 





 





 





 





 



 	 w=>'DoW0', #day of week 0..6, 1=mon 0=sun 




4314




 





 





 





 





 





 



 	#U=>'WoYs', #week num of year 00..53, sunday as first day of week 




4315




 





 





 





 





 





 



 	#V=>'UKE',  #ISO week num of year 01..53, monday as first day of week 




4316




 





 





 





 





 





 



 	#W=>'WoYm', #week num of year 00..53, monday as first day of week, not ISO! 




4317




 





 





 





 





 





 



 	#x=>$ENV{locale's date representation}, #e.g. MM/DD/YY 




4318




 





 





 





 





 





 



 	#X=>$ENV{locale's time representation}, #e.g. HH/MI/SS 




4319




 





 





 





 





 





 



 	 y=>'YY', 




4320




 





 





 





 





 





 



 	 Y=>'YYYY', 




4321




 





 





 





 





 





 



 	#z=>'TZHHMI', #time zone hour minute e.g. -0430 




4322




 





 





 





 





 





 



 	#':z'=>'TZHH:MI', 




4323




 





 





 





 





 





 



 	#'::z'=>'TZHH:MI:SS', 




4324




 





 





 





 





 





 



 	#':::z'=>'TZ', #number of :'s necessary precision, e.g. -02 or +03:30 




4325




 





 





 





 





 





 



 	#Z=>'TZN', #e.g. CET, EDT, ... 




4326




 





 





 





 





 





 



       ); 




4327




38





 





 





 





 





260



   my $pkeys=join"|",keys%p; 




4328




38





 





 





 





 





1641



   $format=~s,\%($pkeys),$p{$1},g; 




4329




38





 





 





 





 





459



   $format=~s/($Tms_pattern)/$Tms_str{$1}[1+$lt[$Tms_str{$1}[0]]]/g; 




4330




38





 





 





 





 





92



   $format=~s/YYYY              / 1900+$lt[5]                    /gxe; 




 




13





 





 





 





 





44



   




4331




38




  
  0
  




 





 





 





70



   $format=~s/(\s?)yyyy         / $lt[5]==(localtime)[5]?"":$1.(1900+$lt[5])/gxe; 




 



  
0
  




 





 





 





 





0



   




4332




38





 





 





 





 





65



   $format=~s/YY                / sprintf("%02d",$lt[5]%100)     /gxei; 




 




1





 





 





 





 





5



   




4333




38





 





 





 





 





67



   $format=~s|CC                | sprintf("%02d",(1900+$lt[5])/100) |gxei; 




 




2





 





 





 





 





10



   




4334




38





 





 





 





 





59



   $format=~s/MM                / sprintf("%02d",$lt[4]+1)       /gxe; 




 




5





 





 





 





 





25



   




4335




38





 





 





 





 





56



   $format=~s/mm                / sprintf("%d",$lt[4]+1)         /gxe; 




 



  
0
  




 





 





 





 





0



   




4336




38





 





 





 





 





57



   $format=~s,M/                ,               ($lt[4]+1).'/'   ,gxe; 




 




2





 





 





 





 





7



   




4337




38





 





 





 





 





52



   $format=~s,/M                ,           '/'.($lt[4]+1)       ,gxe; 




 




1





 





 





 





 





4



   




4338




38





 





 





 





 





62



   $format=~s/DD                / sprintf("%02d",$lt[3])         /gxe; 




 




6





 





 





 





 





25



   




4339




38





 





 





 





 





110



   $format=~s/d0w|dow0          / $lt[6]                         /gxei; 




 




4





 





 





 





 





11



   




4340




38




  
100
  




 





 





 





67



   $format=~s/dow               / $lt[6]?$lt[6]:7                /gxei; 




 




2





 





 





 





 





8



   




4341




38





 





 





 





 





81



   $format=~s/d0y|doy0          / $lt[7]                         /gxei; #0-364 (365 leap) 




 




2





 





 





 





 





7



   




4342




38





 





 





 





 





117



   $format=~s/doy               / $lt[7]+1                       /gxei; #1-365 (366 leap) 




 




1





 





 





 





 





4



   




4343




38





 





 





 





 





98



   $format=~s/D(?![AaGgYyEeNn]) / $lt[3]                         /gxe; #EN pga desember og wednesday 




 




5





 





 





 





 





15



   




4344




38





 





 





 





 





55



   $format=~s/dd                / sprintf("%d",$lt[3])           /gxe; 




 



  
0
  




 





 





 





 





0



   




4345




38




  
100
  



  
 50
  




 





 





88



   $format=~s/hh12|HH12         / sprintf("%02d",$lt[2]<13?$lt[2]||12:$lt[2]-12)/gxe; 




 




8





 





 





 





 





51



   




4346




38





 





 





 





 





86



   $format=~s/HH24|HH24|HH|hh   / sprintf("%02d",$lt[2])         /gxe; 




 




4





 





 





 





 





22



   




4347




38





 





 





 





 





77



   $format=~s/MI                / sprintf("%02d",$lt[1])         /gxei; 




 




12





 





 





 





 





42



   




4348




38





 




  
100
  




 





 





68



   $format=~s{SS\.([1-9])      }{ sprintf("%0*.$1f",3+$1,$lt[0]+(repl($time,qr/^[^\.]+/)||0)) }gxei; 




 




3





 





 





 





 





21



   




4349




38





 





 





 





 





64



   $format=~s/SS                / sprintf("%02d",$lt[0])         /gxei; 




 




4





 





 





 





 





16



   




4350




38




  
100
  




 





 





 





77



   $format=~s/am|pm             / $lt[2]<13 ? 'am' : 'pm'        /gxe; 




 




4





 





 





 





 





14



   




4351




38




  
100
  




 





 





 





75



   $format=~s/AM|PM             / $lt[2]<13 ? 'AM' : 'PM'        /gxe; 




 




4





 





 





 





 





13



   




4352




38





 





 





 





 





107



   $format=~s/WWI|WW            / sprintf("%02d",weeknum($time)) /gxei; 




 



  
0
  




 





 





 





 





0



   




4353




38





 





 





 





 





60



   $format=~s/W                 / weeknum($time)                 /gxei; 




 



  
0
  




 





 





 





 





0



   




4354




38





 





 





 





 





323



   $format; 




4355




 





 





 





 





 





 



 } 




4356




 





 





 





 





 





 



   




4357




 





 





 





 





 





 



 =head2 easter 




4358




 





 





 





 





 





 



   




4359




 





 





 





 





 





 



 Input: A year (a four digit number) 




4360




 





 





 





 





 





 



   




4361




 





 





 





 





 





 



 Output: array of two numbers: day and month of Easter Sunday that year. Month 3 means March and 4 means April. 




4362




 





 





 





 





 





 



   




4363




 





 





 





 





 





 



  sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30; 




4364




 





 





 





 





 





 



              (($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) } 




4365




 





 





 





 





 





 



   




4366




 





 





 





 





 





 



 ...is a "golfed" version of Oudins algorithm (1940) L 




4367




 





 





 





 





 





 



 (see also http://www.smart.net/~mmontes/ec-cal.html ) 




4368




 





 





 





 





 





 



   




4369




 





 





 





 





 





 



 Valid for any Gregorian year. Dates repeat themselves after 70499183 




4370




 





 





 





 





 





 



 lunations = 2081882250 days = ca 5699845 years. However, our planet will 




4371




 





 





 





 





 





 



 by then have a different rotation and spin time... 




4372




 





 





 





 





 





 



   




4373




 





 





 





 





 





 



 Example: 




4374




 





 





 





 





 





 



   




4375




 





 





 





 





 





 



  ( $day, $month ) = easter( 2012 ); # $day == 8 and $month == 4 




4376




 





 





 





 





 





 



   




4377




 





 





 





 





 





 



 Example 2: 




4378




 





 





 





 





 





 



   




4379




 





 





 





 





 





 



  my @e=map sprintf("%02d%02d", reverse(easter($_))), 1800..300000; 




4380




 





 





 





 





 





 



  print "First: ".min(@e)." Last: ".max(@e)."\n"; # First: 0322 Last: 0425 




4381




 





 





 





 





 





 



   




4382




 





 





 





 





 





 



 =cut 




4383




 





 





 





 





 





 



   




4384




28





 





 




  
28
  



  
1
  




53963



 sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30; 




 




28





 





 




  
5000
  




 





52



   




 




28





 





 





 





 





124



   




 




5000





 





 





 





 





11620



   




 




5000





 





 





 





 





6188



   




 




5000





 





 





 





 





8536



   




4385




5000




  
100
  



  
 66
  




 





 





24827



              (($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) } 




4386




 





 





 





 





 





 



   




4387




 





 





 





 





 





 



   




4388




 





 





 





 





 





 



 =head2 time_fp 




4389




 





 





 





 





 





 



   




4390




 





 





 





 





 





 



 No input arguments. 




4391




 





 





 





 





 





 



   




4392




 





 





 





 





 





 



 Return the same number as perls C except with decimals (fractions of a second, _fp as in floating point number). 




4393




 





 





 





 





 





 



   




4394




 





 





 





 





 





 



  print time_fp(),"\n"; 




4395




 





 





 





 





 





 



  print time(),"\n"; 




4396




 





 





 





 





 





 



   




4397




 





 





 





 





 





 



 Could write: 




4398




 





 





 





 





 





 



   




4399




 





 





 





 





 





 



  1116776232.38632 




4400




 





 





 





 





 





 



   




4401




 





 





 





 





 





 



 ...if that is the time now. 




4402




 





 





 





 





 





 



   




4403




 





 





 





 





 





 



 Or just: 




4404




 





 





 





 





 





 



   




4405




 





 





 





 





 





 



  1116776232 




4406




 





 





 





 





 





 



   




4407




 





 





 





 





 





 



 ...from perl's internal C if C isn't installed and available. 




4408




 





 





 





 





 





 



   




4409




 





 





 





 





 





 



   




4410




 





 





 





 





 





 



 =cut 




4411




 





 





 





 





 





 



   




4412




 





 





 





 





 





 



 sub time_fp {  # {return 0+gettimeofday} is just as well? 




4413




12416




  
 50
  




 




  
12416
  



  
1
  




19116



     eval{ require Time::HiRes } or return time(); 




 




12416





 





 





 





 





75841



   




4414




12416





 





 





 





 





47644



     my($sec,$mic)=Time::HiRes::gettimeofday(); 




4415




12416





 





 





 





 





53145



     return $sec+$mic/1e6; #1e6 not portable? 




4416




 





 





 





 





 





 



 } 




4417




 





 





 





 





 





 



   




4418




 





 





 





 





 





 



 =head2 sleep_fp 




4419




 





 





 





 





 





 



   




4420




 





 





 





 





 





 



 sleep_fp() work as the built in C<< sleep() >> but also accepts fractional seconds: 




4421




 





 





 





 





 





 



   




4422




 





 





 





 





 





 



  sleep_fp(0.020);  # sleeps for 20 milliseconds 




4423




 





 





 





 





 





 



   




4424




 





 





 





 





 





 



 Sub sleep_fp do a C, thus it might take some 




4425




 





 





 





 





 





 



 extra time the first call. To avoid that, add C<< use Time::HiRes >> 




4426




 





 





 





 





 





 



 to your code. Sleep_fp should not be trusted for accuracy to more than 




4427




 





 





 





 





 





 



 a tenth of a second. Virtual machines tend to be less accurate (sleep 




4428




 





 





 





 





 





 



 longer) than physical ones. This was tested on VMware and RHEL 




4429




 





 





 





 





 





 



 (Linux). See also L. 




4430




 





 





 





 





 





 



   




4431




 





 





 





 





 





 



 =head2 sleeps 




4432




 





 





 





 





 





 



   




4433




 





 





 





 





 





 



 =head2 sleepms 




4434




 





 





 





 





 





 



   




4435




 





 





 





 





 





 



 =head2 sleepus 




4436




 





 





 





 





 





 



   




4437




 





 





 





 





 





 



 =head2 sleepns 




4438




 





 





 





 





 





 



   




4439




 





 





 





 





 





 



  sleep_fp(0.020);   #sleeps for 20 milliseconds 




4440




 





 





 





 





 





 



  sleeps(0.020);     #sleeps for 20 milliseconds, sleeps() is a synonym to sleep_fp() 




4441




 





 





 





 





 





 



  sleepms(20);       #sleeps for 20 milliseconds 




4442




 





 





 





 





 





 



  sleepus(20000);    #sleeps for 20000 microseconds = 20 milliseconds 




4443




 





 





 





 





 





 



  sleepns(20000000); #sleeps for 20 million nanoseconds = 20 milliseconds 




4444




 





 





 





 





 





 



   




4445




 





 





 





 





 





 



 =cut 




4446




 





 





 





 





 





 



   




4447




13




  
 50
  




 




  
13
  



  
1
  




81



 sub sleep_fp { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) } 




 




13





 





 





 





 





156



   




 




13





 





 





 





 





221802



   




4448




1




  
 50
  




 




  
1
  



  
1
  




12



 sub sleeps   { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) } 




 




1





 





 





 





 





14



   




 




1





 





 





 





 





10162



   




4449




1




  
 50
  




 




  
1
  



  
1
  




18



 sub sleepms  { eval{require Time::HiRes} or (sleep(shift()/1e3),return);Time::HiRes::sleep(shift()/1e3) } 




 




1





 





 





 





 





24



   




 




1





 





 





 





 





10168



   




4450




1




  
 50
  




 




  
1
  



  
1
  




14



 sub sleepus  { eval{require Time::HiRes} or (sleep(shift()/1e6),return);Time::HiRes::sleep(shift()/1e6) } 




 




1





 





 





 





 





21



   




 




1





 





 





 





 





10158



   




4451




1




  
 50
  




 




  
1
  



  
1
  




13



 sub sleepns  { eval{require Time::HiRes} or (sleep(shift()/1e9),return);Time::HiRes::sleep(shift()/1e9) } 




 




1





 





 





 





 





19



   




 




1





 





 





 





 





10140



   




4452




 





 





 





 





 





 



   




4453




 





 





 





 





 





 



 =head2 eta 




4454




 





 





 





 





 





 



   




4455




 





 





 





 





 





 



 Estimated time of arrival (ETA). 




4456




 





 





 





 





 





 



   




4457




 





 





 





 





 





 



  for(@files){ 




4458




 





 





 





 





 





 



     ...do work on file... 




4459




 





 





 





 





 





 



     my $eta = eta( ++$i, 0+@files ); # file now, number of files 




4460




 





 





 





 





 





 



     print "" . localtime($eta); 




4461




 





 





 





 





 





 



  } 




4462




 





 





 





 





 





 



   




4463




 





 





 





 





 





 



  ..DOC MISSING.. 




4464




 





 





 





 





 





 



   




4465




 





 





 





 





 





 



 =head2 etahhmm 




4466




 





 





 





 





 





 



   




4467




 





 





 





 





 





 



  ...NOT YET 




4468




 





 





 





 





 





 



   




4469




 





 





 





 





 





 



 =cut 




4470




 





 





 





 





 





 



   




4471




 





 





 





 





 





 



 #http://en.wikipedia.org/wiki/Kalman_filter god idé? 




4472




 





 





 





 





 





 



 our %Eta; 




4473




 





 





 





 





 





 



 our $Eta_forgetfulness=2; 




4474




 





 





 





 





 





 



 sub eta { 




4475




2004




  
100
  




 




  
2004
  



  
1
  




15296



   my($id,$pos,$end,$time_fp)=( @_==2 ? (join(";",caller()),@_) : @_ ); 




4476




2004





 




  
 66
  




 





 





4544



   $time_fp||=time_fp(); 




4477




2004





 




  
100
  




 





 





4853



   my $a=$Eta{$id}||=[]; 




4478




2004





 





 





 





 





4265



   push @$a, [$pos,$time_fp]; 




4479




2004




  
100
  




 





 





 





5365



   @$a=@$a[map$_*2,0..@$a/2] if @$a>40;  #hm 40 




4480




2004




  
100
  



  
100
  




 





 





9090



   splice(@$a,-2,1) if @$a>1 and $$a[-2][0]==$$a[-1][0]; #same pos as last 




4481




2004




  
100
  




 





 





 





4117



   return undef if @$a<2; 




4482




2001





 





 





 





 





2410



   my @eta; 




4483




2001





 





 





 





 





3755



   for(2..@$a){ 




4484




58602





 





 





 





 





158569



     push @eta, $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-$_][1])/($$a[-1][0]-$$a[-$_][0]); 




4485




 





 





 





 





 





 



   } 




4486




2001





 





 





 





 





2940



   my($sum,$sumw,$w)=(0,0,1); 




4487




2001





 





 





 





 





3107



   for(@eta){ 




4488




58602





 





 





 





 





74926



     $sum+=$w*$_; 




4489




58602





 





 





 





 





70451



     $sumw+=$w; 




4490




58602





 





 





 





 





83675



     $w/=$Eta_forgetfulness; 




4491




 





 





 





 





 





 



   } 




4492




2001





 





 





 





 





2729



   my $avg=$sum/$sumw; 




4493




2001





 





 





 





 





6189



   return $avg; 




4494




 





 





 





 





 





 



 #  return avg(@eta); 




4495




 





 





 





 





 





 



  #return $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-2][1])/($$a[-1][0]-$$a[-2][0]); 




4496



  
0
  




 





 





 





 





0



   1; 




4497




 





 





 





 





 





 



 } 




4498




 





 





 





 





 





 



   




4499




 





 





 





 





 





 



 =head2 sleep_until 




4500




 





 





 





 





 





 



   




4501




 





 





 





 





 





 



 sleep_until(0.5) sleeps until half a second has passed since the last 




4502




 





 





 





 





 





 



 call to sleep_until. This example starts the next job excactly ten 




4503




 





 





 





 





 





 



 seconds after the last job started even if the last job lasted for a 




4504




 





 





 





 





 





 



 while (but not more than ten seconds): 




4505




 





 





 





 





 





 



   




4506




 





 





 





 





 





 



  for(@jobs){ 




4507




 





 





 





 





 





 



    sleep_until(10); 




4508




 





 





 





 





 





 



    print localtime()."\n"; 




4509




 





 





 





 





 





 



    ...heavy job.... 




4510




 





 





 





 





 





 



  } 




4511




 





 





 





 





 





 



   




4512




 





 





 





 





 





 



 Might print: 




4513




 





 





 





 





 





 



   




4514




 





 





 





 





 





 



  Thu Jan 12 16:00:00 2012 




4515




 





 





 





 





 





 



  Thu Jan 12 16:00:10 2012 




4516




 





 





 





 





 





 



  Thu Jan 12 16:00:20 2012 




4517




 





 





 





 





 





 



   




4518




 





 





 





 





 





 



 ...and so on even if the C<< ...heavy job... >>-part takes more than a 




4519




 





 





 





 





 





 



 second to complete. Whereas if sleep(10) was used, each job would 




4520




 





 





 





 





 





 



 spend more than ten seconds in average since the work time would be 




4521




 





 





 





 





 





 



 added to sleep(10). 




4522




 





 





 





 





 





 



   




4523




 





 





 





 





 





 



 Note: sleep_until() will remember the time of ANY last call of this sub, 




4524




 





 





 





 





 





 



 not just the one on the same line in the source code (this might change 




4525




 





 





 





 





 





 



 in the future). The first call to sleep_until() will be the same as 




4526




 





 





 





 





 





 



 sleep_fp() or Perl's own sleep() if the argument is an integer. 




4527




 





 





 





 





 





 



   




4528




 





 





 





 





 





 



 =cut 




4529




 





 





 





 





 





 



   




4530




 





 





 





 





 





 



 our $Time_last_sleep_until; 




4531




 





 





 





 





 





 



 sub sleep_until { 




4532



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



   my $s=@_==1?shift():0; 




4533



  
0
  




 





 





 





 





0



   my $time=time_fp(); 




4534



  
0
  




 





 





 





 





0



   my $sleep=$s-($time-nvl($Time_last_sleep_until,0)); 




4535



  
0
  




 





 





 





 





0



   $Time_last_sleep_until=time; 




4536



  
0
  



  
  0
  




 





 





 





0



   sleep_fp($sleep) if $sleep>0; 




4537




 





 





 





 





 





 



 } 




4538




 





 





 





 





 





 



   




4539




 





 





 





 





 





 



 =head2 leapyear 




4540




 





 





 





 





 





 



   




4541




 





 





 





 





 





 



 B A year. A four digit number. 




4542




 





 





 





 





 





 



   




4543




 





 





 





 





 





 



 B True (1) or false (0) of whether the year is a leap year or 




4544




 





 





 





 





 





 



 not. (Uses current calendar even for periods before leapyears was used). 




4545




 





 





 





 





 





 



   




4546




 





 





 





 





 





 



  print join(", ",grep leapyear($_), 1900..2014)."\n"; 




4547




 





 





 





 





 





 



   




4548




 





 





 





 





 





 



  1904, 1908, 1912, 1916, 1920, 1924, 1928, 1932, 1936, 1940, 1944, 1948, 1952, 1956, 




4549




 





 





 





 





 





 



  1960, 1964, 1968, 1972, 1976, 1980, 1984, 1988, 1992, 1996, 2000, 2004, 2008, 2012 




4550




 





 





 





 





 





 



   




4551




 





 





 





 





 





 



 Note: 1900 is not a leap year, but 2000 is. Years divided by 100 is a leap year only 




4552




 





 





 





 





 





 



 if it can be divided by 400. 




4553




 





 





 





 





 





 



   




4554




 





 





 





 





 





 



 =cut 




4555




 





 





 





 





 





 



   




4556



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub leapyear{$_[0]%400?$_[0]%100?$_[0]%4?0:1:0:1} #bool 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




4557




 





 





 





 





 





 



   




4558




 





 





 





 





 





 



 #http://rosettacode.org/wiki/Levenshtein_distance#Perl 




4559




 





 





 





 





 





 



 our %ldist_cache; 




4560




 





 





 





 





 





 



 sub ldist { 




4561



  
0
  




 





 




  
0
  



  
0
  




0



   my($s,$t,$l) = @_; 




4562



  
0
  



  
  0
  




 





 





 





0



   return length($t) if !$s; 




4563



  
0
  



  
  0
  




 





 





 





0



   return length($s) if !$t; 




4564



  
0
  



  
  0
  



  
  0
  




 





 





0



   %ldist_cache=() if !$l and 1000<0+%ldist_cache; 




4565




 





 





 





 





 





 



   $ldist_cache{$s,$t} ||= 




4566



  
0
  




 




  
  0
  




 





 





0



   do { 




4567



  
0
  




 





 





 





 





0



     my($s1,$t1) = ( substr($s,1), substr($t,1) ); 




4568



  
0
  



  
  0
  




 





 





 





0



     substr($s,0,1) eq substr($t,0,1) 




4569




 





 





 





 





 





 



       ? ldist($s1,$t1) 




4570




 





 





 





 





 





 



       : 1 + min( ldist($s1,$t1,1+$l), ldist($s,$t1,1+$l), ldist($s1,$t,1+$l) ); 




4571




 





 





 





 





 





 



   }; 




4572




 





 





 





 





 





 



 } 




4573




 





 





 





 





 





 



   




4574




 





 





 





 





 





 



 =head1 OTHER 




4575




 





 





 





 





 





 



   




4576




 





 





 





 





 





 



 =head2 nvl 




4577




 





 





 





 





 





 



   




4578




 





 





 





 





 





 



 The I function (or I function) 




4579




 





 





 





 





 





 



   




4580




 





 





 





 





 





 



 C takes two or more arguments. (Oracles nvl-function take just two) 




4581




 





 





 





 





 





 



   




4582




 





 





 





 





 





 



 Returns the value of the first input argument with length() > 0. 




4583




 





 





 





 





 





 



   




4584




 





 





 





 





 





 



 Return I if there is no such input argument. 




4585




 





 





 





 





 





 



   




4586




 





 





 





 





 





 



 In perl 5.10 and perl 6 this will most often be easier with the C< // 




4587




 





 





 





 





 





 



 > operator, although C and C<< // >> treats empty strings C<""> 




4588




 





 





 





 





 





 



 differently. Sub nvl here considers empty strings and undef the same. 




4589




 





 





 





 





 





 



   




4590




 





 





 





 





 





 



 =cut 




4591




 





 





 





 





 





 



   




4592




 





 





 





 





 





 



 sub nvl { 




4593




38




  
100
  



  
 66
  



  
38
  



  
1
  




285



   return $_[0] if defined $_[0] and length($_[0]) or @_==1; 




 




 





 




  
100
  




 





 





 



   




4594




22




  
100
  




 





 





 





83



   return $_[1] if @_==2; 




4595




9




  
100
  




 





 





 





36



   return nvl(@_[1..$#_]) if @_>2; 




4596




1





 





 





 





 





4



   return undef; 




4597




 





 





 





 





 





 



 } 




4598




 





 





 





 





 





 



   




4599




 





 





 





 





 





 



 =head2 decode_num 




4600




 





 





 





 





 





 



   




4601




 





 





 





 





 





 



 See L. 




4602




 





 





 





 





 





 



   




4603




 





 





 





 





 





 



 =head2 decode 




4604




 





 





 





 





 





 



   




4605




 





 





 





 





 





 



 C and C works just as Oracles C. 




4606




 





 





 





 





 





 



   




4607




 





 





 





 





 





 



 C and C accordingly uses perl operators C and C<==> for comparison. 




4608




 





 





 





 





 





 



   




4609




 





 





 





 





 





 



 Examples: 




4610




 





 





 





 





 





 



   




4611




 





 





 





 





 





 



  my $a=123; 




4612




 





 





 





 





 





 



  print decode($a, 123,3,  214,4, $a);     # prints 3 




4613




 





 





 





 





 





 



  print decode($a, 123=>3, 214=>4, $a);    # prints 3, same thing since => is synonymous to comma in Perl 




4614




 





 





 





 





 





 



   




4615




 





 





 





 





 





 



 The first argument is tested against the second, fourth, sixth and so on, 




4616




 





 





 





 





 





 



 and then the third, fifth, seventh and so on is 




4617




 





 





 





 





 





 



 returned if decode() finds an equal string or number. 




4618




 





 





 





 





 





 



   




4619




 





 





 





 





 





 



 In the above example: 123 maps to 3, 124 maps to 4 and the last argument $a is returned elsewise. 




4620




 





 





 





 





 





 



   




4621




 





 





 





 





 





 



 More examples: 




4622




 





 





 





 





 





 



   




4623




 





 





 





 





 





 



  my $a=123; 




4624




 





 





 





 





 





 



  print decode($a, 123=>3, 214=>7, $a);              # also 3,  note that => is synonym for , (comma) in perl 




4625




 





 





 





 





 





 



  print decode($a, 122=>3, 214=>7, $a);              # prints 123 




4626




 





 





 





 





 





 



  print decode($a,  123.0 =>3, 214=>7);              # prints 3 




4627




 





 





 





 





 





 



  print decode($a, '123.0'=>3, 214=>7);              # prints nothing (undef), no last argument default value here 




4628




 





 





 





 





 





 



  print decode_num($a, 121=>3, 221=>7, '123.0','b'); # prints b 




4629




 





 





 





 





 





 



   




4630




 





 





 





 





 





 



 Sort of: 




4631




 





 





 





 





 





 



   




4632




 





 





 





 





 





 



  decode($string, %conversion, $default); 




4633




 





 





 





 





 





 



   




4634




 





 





 





 





 





 



 The last argument is returned as a default if none of the keys in the keys/value-pairs matched. 




4635




 





 





 





 





 





 



   




4636




 





 





 





 





 





 



 A more perl-ish and often faster way of doing the same: 




4637




 





 





 





 





 





 



   




4638




 





 





 





 





 





 



  {123=>3, 214=>7}->{$a} || $a                       # (beware of 0) 




4639




 





 





 





 





 





 



   




4640




 





 





 





 





 





 



 =cut 




4641




 





 





 





 





 





 



   




4642




 





 





 





 





 





 



 sub decode { 




4643




4




  
 50
  




 




  
4
  



  
1
  




10



   croak "Must have a mimimum of two arguments" if @_<2; 




4644




4





 





 





 





 





6



   my $uttrykk=shift; 




4645




4




  
 50
  



  
100
  




 





 





11



   if(defined$uttrykk){ shift eq $uttrykk and return shift or shift for 1..@_/2 } 




 




4





 




  
 33
  




 





 





37



   




4646



  
0
  




 




  
  0
  




 





 





0



   else               { !defined shift    and return shift or shift for 1..@_/2 } 




 




 





 




  
  0
  




 





 





 



   




4647




2





 





 





 





 





8



   return shift; 




4648




 





 





 





 





 





 



 } 




4649




 





 





 





 





 





 



   




4650




 





 





 





 





 





 



 sub decode_num { 




4651




1




  
 50
  




 




  
1
  



  
1
  




5



   croak "Must have a mimimum of two arguments" if @_<2; 




4652




1





 





 





 





 





2



   my $uttrykk=shift; 




4653




1




  
 50
  



  
100
  




 





 





3



   if(defined$uttrykk){ shift == $uttrykk and return shift or shift for 1..@_/2 } 




 




1





 




  
 33
  




 





 





15



   




4654



  
0
  




 




  
  0
  




 





 





0



   else               { !defined shift    and return shift or shift for 1..@_/2 } 




 




 





 




  
  0
  




 





 





 



   




4655



  
0
  




 





 





 





 





0



   return shift; 




4656




 





 





 





 





 





 



 } 




4657




 





 





 





 





 





 



   




4658




 





 





 





 





 





 



 =head2 qrlist 




4659




 





 





 





 





 





 



   




4660




 





 





 





 





 





 



 Input: An array of values to be used to test againts for existence. 




4661




 





 





 





 





 





 



   




4662




 





 





 





 





 





 



 Output: A reference to a regular expression. That is a C 




4663




 





 





 





 





 





 



   




4664




 





 





 





 





 





 



 The regex sets $1 if it match. 




4665




 





 





 





 





 





 



   




4666




 





 





 





 





 





 



 Example: 




4667




 





 





 





 





 





 



   




4668




 





 





 





 





 





 



   my @list=qw/ABc XY DEF DEFG XYZ/; 




4669




 





 





 





 





 





 



   my $filter=qrlist("ABC","DEF","XY.");         # makes a regex of it qr/^(\QABC\E|\QDEF\E|\QXY.\E)$/ 




4670




 





 





 





 





 





 



   my @filtered= grep { $_ =~ $filter } @list;   # returns DEF and XYZ, but not XYZ because the . char is taken literally 




4671




 





 





 





 





 





 



   




4672




 





 





 





 





 





 



 Note: Filtering with hash lookups are WAY faster. 




4673




 





 





 





 





 





 



   




4674




 





 





 





 





 





 



 Source: 




4675




 





 





 





 





 





 



   




4676




 





 





 





 





 





 



  sub qrlist (@) { my $str=join"|",map quotemeta, @_; qr/^($str)$/ } 




4677




 





 





 





 





 





 



   




4678




 





 





 





 





 





 



 =cut 




4679




 





 





 





 





 





 



   




4680




 





 





 





 





 





 



 sub qrlist (@) { 




4681



  
0
  




 





 




  
0
  



  
1
  




0



   my $str=join"|",map quotemeta,@_; 




4682



  
0
  




 





 





 





 





0



   return qr/^($str)$/; 




4683




 





 





 





 





 





 



 } 




4684




 





 





 





 





 





 



   




4685




 





 





 





 





 





 



 =head2 ansicolor 




4686




 





 





 





 





 





 



   




4687




 





 





 





 





 





 



 Perhaps easier to use than L ? 




4688




 





 





 





 





 





 



   




4689




 





 





 





 





 





 



 B One argument. A string where the char C<¤> have special 




4690




 





 





 





 





 





 



 meaning and is replaced by color codings depending on the letter 




4691




 





 





 





 





 





 



 following the C<¤>. 




4692




 





 





 





 





 





 



   




4693




 





 





 





 





 





 



 B The same string, but with C<¤letter> replaced by ANSI color 




4694




 





 





 





 





 





 



 codes respected by many types terminal windows. (xterm, telnet, ssh, 




4695




 





 





 





 





 





 



 telnet, rlog, vt100, cygwin, rxvt and such...). 




4696




 





 





 





 





 





 



   




4697




 





 





 





 





 





 



 B 




4698




 





 





 





 





 





 



   




4699




 





 





 





 





 





 



  ¤r red 




4700




 





 





 





 





 





 



  ¤g green 




4701




 





 





 





 





 





 



  ¤b blue 




4702




 





 





 





 





 





 



  ¤y yellow 




4703




 





 





 





 





 





 



  ¤m magenta 




4704




 





 





 





 





 





 



  ¤B bold 




4705




 





 





 





 





 





 



  ¤u underline 




4706




 





 





 





 





 





 



  ¤c clear 




4707




 





 





 





 





 





 



  ¤¤ reset, quits and returns to default text color. 




4708




 





 





 





 





 





 



   




4709




 





 





 





 





 





 



 B 




4710




 





 





 





 





 





 



   




4711




 





 





 





 





 





 



  print ansicolor("This is maybe ¤ggreen¤¤?"); 




4712




 





 





 





 





 





 



   




4713




 





 





 





 





 





 



 Prints I where the word I is shown in green. 




4714




 





 





 





 





 





 



   




4715




 





 





 





 





 





 



 If L is not installed or not found, returns the input 




4716




 





 





 





 





 





 



 string with every C<¤> including the following code letters 




4717




 





 





 





 





 





 



 removed. (That is: ansicolor is safe to use even if Term::ANSIColor is 




4718




 





 





 





 





 





 



 not installed, you just don't get the colors). 




4719




 





 





 





 





 





 



   




4720




 





 





 





 





 





 



 See also L. 




4721




 





 





 





 





 





 



   




4722




 





 





 





 





 





 



 =cut 




4723




 





 





 





 





 





 



   




4724




 





 





 





 





 





 



 sub ansicolor { 




4725



  
0
  




 





 




  
0
  



  
1
  




0



   my $txt=shift; 




4726



  
0
  



  
  0
  




 





 





 





0



   eval{require Term::ANSIColor} or return replace($txt,qr/¤./); 




 



  
0
  




 





 





 





 





0



   




4727



  
0
  




 





 





 





 





0



   my %h=qw/r red  g green  b blue  y yellow  m magenta  B bold  u underline  c clear  ¤ reset/; 




4728



  
0
  




 





 





 





 





0



   my $re=join"|",keys%h; 




4729



  
0
  




 





 





 





 





0



   $txt=~s/¤($re)/Term::ANSIColor::color($h{$1})/ge; 




 



  
0
  




 





 





 





 





0



   




4730



  
0
  




 





 





 





 





0



   return $txt; 




4731




 





 





 





 





 





 



 } 




4732




 





 





 





 





 





 



   




4733




 





 





 





 





 





 



 =head2 ccn_ok 




4734




 





 





 





 





 





 



   




4735




 





 





 





 





 





 



 Checks if a Credit Card number (CCN) has correct control digits according to the LUHN-algorithm from 1960. 




4736




 





 





 





 





 





 



 This method of control digits is used by MasterCard, Visa, American Express, 




4737




 





 





 





 





 





 



 Discover, Diners Club / Carte Blanche, JCB and others. 




4738




 





 





 





 





 





 



   




4739




 





 





 





 





 





 



 B 




4740




 





 





 





 





 





 



   




4741




 





 





 





 





 





 



 A credit card number. Can contain non-digits, but they are removed internally before checking. 




4742




 





 





 





 





 





 



   




4743




 





 





 





 





 





 



 B 




4744




 





 





 





 





 





 



   




4745




 





 





 





 





 





 



 Something true or false. 




4746




 





 





 





 





 





 



   




4747




 





 





 





 





 





 



 Or more accurately: 




4748




 





 





 





 





 





 



   




4749




 





 





 





 





 





 



 Returns C (false) if the input argument is missing digits. 




4750




 





 





 





 





 





 



   




4751




 





 





 





 





 





 



 Returns 0 (zero, which is false) is the digits is not correct according to the LUHN algorithm. 




4752




 





 





 





 





 





 



   




4753




 





 





 





 





 





 



 Returns 1 or the name of a credit card company (true either way) if the last digit is an ok control digit for this ccn. 




4754




 





 





 





 





 





 



   




4755




 





 





 





 





 





 



 The name of the credit card company is returned like this (without the C<'> character) 




4756




 





 





 





 





 





 



   




4757




 





 





 





 





 





 



  Returns (wo '')                Starts on                Number of digits 




4758




 





 





 





 





 





 



  ------------------------------ ------------------------ ---------------- 




4759




 





 





 





 





 





 



  'MasterCard'                   51-55                    16 




4760




 





 





 





 





 





 



  'Visa'                         4                        13 eller 16 




4761




 





 





 





 





 





 



  'American Express'             34 eller 37              15 




4762




 





 





 





 





 





 



  'Discover'                     6011                     16 




4763




 





 





 





 





 





 



  'Diners Club / Carte Blanche'  300-305, 36 eller 38     14 




4764




 





 





 





 





 





 



  'JCB'                          3                        16 




4765




 





 





 





 





 





 



  'JCB'                          2131 eller 1800          15 




4766




 





 





 





 





 





 



   




4767




 





 





 





 





 





 



 And should perhaps have had: 




4768




 





 





 





 





 





 



   




4769




 





 





 





 





 





 



  'enRoute'                      2014 eller 2149          15 




4770




 





 





 





 





 





 



   




4771




 





 





 





 





 





 



 ...but that card uses either another control algorithm or no control 




4772




 





 





 





 





 





 



 digits at all. So C is never returned here. 




4773




 





 





 





 





 





 



   




4774




 





 





 





 





 





 



 If the control digits is valid, but the input does not match anything in the column C, 1 is returned. 




4775




 





 





 





 





 





 



   




4776




 





 





 





 





 





 



 (This is also the same control digit mechanism used in Norwegian KID numbers on payment bills) 




4777




 





 





 





 





 





 



   




4778




 





 





 





 





 





 



 The first digit in a credit card number is supposed to tell what "industry" the card is meant for: 




4779




 





 





 





 





 





 



   




4780




 





 





 





 





 





 



  MII Digit Value             Issuer Category 




4781




 





 





 





 





 





 



  --------------------------- ---------------------------------------------------- 




4782




 





 





 





 





 





 



  0                           ISO/TC 68 and other industry assignments 




4783




 





 





 





 





 





 



  1                           Airlines 




4784




 





 





 





 





 





 



  2                           Airlines and other industry assignments 




4785




 





 





 





 





 





 



  3                           Travel and entertainment 




4786




 





 





 





 





 





 



  4                           Banking and financial 




4787




 





 





 





 





 





 



  5                           Banking and financial 




4788




 





 





 





 





 





 



  6                           Merchandizing and banking 




4789




 





 





 





 





 





 



  7                           Petroleum 




4790




 





 





 





 





 





 



  8                           Telecommunications and other industry assignments 




4791




 





 





 





 





 





 



  9                           National assignment 




4792




 





 





 





 





 





 



   




4793




 





 





 





 





 





 



 ...although this has no meaning to C. 




4794




 





 





 





 





 





 



   




4795




 





 





 





 





 





 



 The first six digits is I, that is the bank 




4796




 





 





 





 





 





 



 (probably). The rest in the "account number", except the last digits, 




4797




 





 





 





 





 





 



 which is the control digit. Max length on credit card numbers are 19 




4798




 





 





 





 





 





 



 digits. 




4799




 





 





 





 





 





 



   




4800




 





 





 





 





 





 



 =cut 




4801




 





 





 





 





 





 



   




4802




 





 





 





 





 





 



 sub ccn_ok { 




4803



  
0
  




 





 




  
0
  



  
1
  




0



     my $ccn=shift(); #credit card number 




4804



  
0
  




 





 





 





 





0



     $ccn=~s/\D+//g; 




4805



  
0
  



  
  0
  




 





 





 





0



     if(KID_ok($ccn)){ 




4806



  
0
  



  
  0
  




 





 





 





0



 	return "MasterCard"                   if $ccn=~/^5[1-5]\d{14}$/; 




4807



  
0
  



  
  0
  




 





 





 





0



 	return "Visa"                         if $ccn=~/^4\d{12}(?:\d{3})?$/; 




4808



  
0
  



  
  0
  




 





 





 





0



 	return "American Express"             if $ccn=~/^3[47]\d{13}$/; 




4809



  
0
  



  
  0
  




 





 





 





0



 	return "Discover"                     if $ccn=~/^6011\d{12}$/; 




4810



  
0
  



  
  0
  




 





 





 





0



 	return "Diners Club / Carte Blanche"  if $ccn=~/^3(?:0[0-5]\d{11}|[68]\d{12})$/; 




4811



  
0
  



  
  0
  




 





 





 





0



 	return "JCB"                          if $ccn=~/^(?:3\d{15}|(?:2131|1800)\d{11})$/; 




4812



  
0
  




 





 





 





 





0



 	return 1; 




4813




 





 





 





 





 





 



     } 




4814




 





 





 





 





 





 



     #return "enRoute"                        if $ccn=~/^(?:2014|2149)\d{11}$/; #ikke LUHN-krav? 




4815



  
0
  




 





 





 





 





0



     return 0; 




4816




 





 





 





 





 





 



 } 




4817




 





 





 





 





 





 



   




4818




 





 





 





 





 





 



 =head2 KID_ok 




4819




 





 





 





 





 





 



   




4820




 





 





 





 





 





 



 Checks if a norwegian KID number has an ok control digit. 




4821




 





 





 





 





 





 



   




4822




 





 





 





 





 





 



 To check if a customer has typed the number correctly. 




4823




 





 





 





 





 





 



   




4824




 





 





 





 





 





 



 This uses the  LUHN algorithm (also known as mod-10) from 1960 which is also used 




4825




 





 





 





 





 





 



 internationally in control digits for credit card numbers, and Canadian social security ID numbers as well. 




4826




 





 





 





 





 





 



   




4827




 





 





 





 





 





 



 The algorithm, as described in Phrack (47-8) (a long time hacker online publication): 




4828




 





 





 





 





 





 



   




4829




 





 





 





 





 





 



  "For a card with an even number of digits, double every odd numbered 




4830




 





 





 





 





 





 



  digit and subtract 9 if the product is greater than 9. Add up all the 




4831




 





 





 





 





 





 



  even digits as well as the doubled-odd digits, and the result must be 




4832




 





 





 





 





 





 



  a multiple of 10 or it's not a valid card. If the card has an odd 




4833




 





 





 





 





 





 



  number of digits, perform the same addition doubling the even numbered 




4834




 





 





 





 





 





 



  digits instead." 




4835




 





 





 





 





 





 



   




4836




 





 





 





 





 





 



 B A KID-nummer. Must consist of digits 0-9 only, otherwise a die (croak) happens. 




4837




 





 





 





 





 





 



   




4838




 





 





 





 





 





 



 B 




4839




 





 





 





 





 





 



   




4840




 





 





 





 





 





 



 - Returns undef if the input argument is missing. 




4841




 





 





 





 





 





 



   




4842




 





 





 





 





 





 



 - Returns 0 if the control digit (the last digit) does not satify the LUHN/mod-10 algorithm. 




4843




 





 





 





 





 





 



   




4844




 





 





 





 





 





 



 - Returns 1 if ok 




4845




 





 





 





 





 





 



   




4846




 





 





 





 





 





 



 B L 




4847




 





 





 





 





 





 



   




4848




 





 





 





 





 





 



 =cut 




4849




 





 





 





 





 





 



   




4850




 





 





 





 





 





 



 sub KID_ok { 




4851



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



   croak "Non-numeric argument" if $_[0]=~/\D/; 




4852



  
0
  



  
  0
  




 





 





 





0



   my @k=split//,shift or return undef; 




4853



  
0
  




 





 





 





 





0



   my $s;$s+=pop(@k)+[qw/0 2 4 6 8 1 3 5 7 9/]->[pop@k] while @k; 




 



  
0
  




 





 





 





 





0



   




4854



  
0
  



  
  0
  




 





 





 





0



   $s%10==0?1:0; 




4855




 





 





 





 





 





 



 } 




4856




 





 





 





 





 





 



   




4857




 





 





 





 





 





 



   




4858




 





 





 





 





 





 



   




4859




 





 





 





 





 





 



 =head2 range 




4860




 





 





 





 





 





 



   




4861




 





 





 





 





 





 



 B 




4862




 





 





 





 





 





 



   




4863




 





 





 





 





 





 



 One or more numeric arguments: 




4864




 





 





 





 





 





 



   




4865




 





 





 





 





 





 



 First: x (first returned element) 




4866




 





 





 





 





 





 



   




4867




 





 





 





 





 





 



 Second: y (last but not including) 




4868




 





 





 





 





 





 



   




4869




 





 





 





 





 





 



 Third: step, default 1. The step between each returned element 




4870




 





 





 





 





 





 



   




4871




 





 





 





 





 





 



 If a fourth, fifth and so on arguments are given, they change the step for each returned element. As first derivative, second derivative. 




4872




 





 





 





 





 





 



   




4873




 





 





 





 





 





 



 B 




4874




 





 





 





 





 





 



   




4875




 





 





 





 





 





 



 If one argument: returns the array C<(0 .. x-1)> 




4876




 





 





 





 





 





 



   




4877




 





 





 





 





 





 



 If two arguments: returns the array C<(x .. y-1)> 




4878




 





 





 





 





 





 



   




4879




 





 





 





 





 





 



 If three arguments: The default step is 1. Use a third argument to use a different step. 




4880




 





 





 





 





 





 



   




4881




 





 





 





 





 





 



 B 




4882




 





 





 





 





 





 



   




4883




 





 





 





 





 





 



  print join ",", range(11);         # prints 0,1,2,3,4,5,6,7,8,9,10      (but not 11) 




4884




 





 





 





 





 





 



  print join ",", range(2,11);       # 2,3,4,5,6,7,8,9,10          (but not 11) 




4885




 





 





 





 





 





 



  print join ",", range(11,2,-1);    # 11,10,9,8,7,6,5,4,3 




4886




 





 





 





 





 





 



  print join ",", range(2,11,3);     # 2,5,8 




4887




 





 





 





 





 





 



  print join ",", range(11,2,-3);    # 11,8,5 




4888




 





 





 





 





 





 



  print join ",", range(11,2,+3);    # prints nothing 




4889




 





 





 





 





 





 



   




4890




 





 





 





 





 





 



  print join ", ",range(2,11,1,0.1);       # 2, 3, 4.1, 5.3, 6.6, 8, 9.5   adds 0.1 to step each time 




4891




 





 





 





 





 





 



  print join ", ",range(2,11,1,0.1,-0.01); # 2, 3, 4.1, 5.29, 6.56, 7.9, 9.3, 10.75 




4892




 





 





 





 





 





 



   




4893




 





 





 





 





 





 



 Note: In the Python language and others, C is a build in iterator (a 




4894




 





 





 





 





 





 



 generator), not an array. This saves memory for large sets and sometimes time. 




4895




 





 





 





 





 





 



 Use C in L to get a similar lazy generator in Perl. 




4896




 





 





 





 





 





 



   




4897




 





 





 





 





 





 



 =cut 




4898




 





 





 





 





 





 



   




4899




 





 





 





 





 





 



 sub range { 




4900




8




  
100
  




 




  
8
  



  
1
  




35



   return _range_accellerated(@_) if @_>3;  #se under 




4901




6





 





 





 





 





13



   my($x,$y,$jump)=@_; 




4902




6




  
100
  




 





 





 





71



   return (  0 .. $x-1 ) if @_==1; 




4903




5




  
100
  




 





 





 





21



   return ( $x .. $y-1 ) if @_==2; 




4904




4




  
 50
  



  
 33
  




 





 





28



   croak "Wrong number of arguments or jump==0" if @_!=3 or $jump==0; 




4905




4





 





 





 





 





6



   my @r; 




4906




4




  
100
  




 





 





 





11



   if($jump>0){  while($x<$y){ push @r, $x; $x+=$jump } } 




 




2





 





 





 





 





8



   




 




772





 





 





 





 





856



   




 




772





 





 





 





 





1292



   




4907




2





 





 





 





 





6



   else       {  while($x>$y){ push @r, $x; $x+=$jump } } 




 




12





 





 





 





 





18



   




 




12





 





 





 





 





21



   




4908




4





 





 





 





 





57



   return @r; 




4909




 





 





 





 





 





 



 } 




4910




 





 





 





 





 





 



   




4911




 





 





 





 





 





 



 #jumps derivative, double der., trippled der usw 




4912




 





 





 





 





 





 



 sub _range_accellerated { 




4913




2





 





 




  
2
  




 





6



   my($x,$y,@jump)=@_; 




4914




2





 





 





 





 





4



   my @r; 




4915




2




  
 50
  




 




  
0
  




 





10



   my $test = $jump[0]>=0 ? sub{$x<$y} : sub{$x>$y}; 




 




17





 





 





 





 





45



   




 



  
0
  




 





 





 





 





0



   




4916




2





 





 





 





 





6



   while(&$test()){ 




4917




15





 





 





 





 





23



     push @r, $x; 




4918




15





 





 





 





 





18



     $x+=$jump[0]; 




4919




15





 





 





 





 





50



     $jump[$_-1]+=$jump[$_] for 1..$#jump; 




4920




 





 





 





 





 





 



   } 




4921




2





 





 





 





 





29



   return @r; 




4922




 





 





 





 





 





 



 } 




4923




 





 





 





 





 





 



   




4924




 





 





 





 





 





 



 =head2 permutations 




4925




 





 





 





 





 





 



   




4926




 





 





 





 





 





 



 How many ways (permutations) can six people be placed around a table: 




4927




 





 





 





 





 





 



   




4928




 





 





 





 





 





 



  If one person:          one 




4929




 





 





 





 





 





 



  If two persons:         two     (they can swap places) 




4930




 





 





 





 





 





 



  If three persons:       six 




4931




 





 





 





 





 





 



  If four persons:         24 




4932




 





 





 





 





 





 



  If five persons:        120 




4933




 





 





 





 





 





 



  If six  persons:        720 




4934




 





 





 





 





 





 



   




4935




 





 





 





 





 





 



 The formula is C where the postfix unary operator C, also known as I is defined like: 




4936




 





 





 





 





 





 



 C. Example: C<5! = 5 * 4 * 3 * 2 * 1 = 120>.Run this to see the 100 first C<< n! >> 




4937




 





 





 





 





 





 



   




4938




 





 





 





 





 





 



  perl -MAcme::Tools -le'$i=big(1);print "$_!=",$i*=$_ for 1..100' 




4939




 





 





 





 





 





 



   




4940




 





 





 





 





 





 



   1!  = 1 




4941




 





 





 





 





 





 



   2!  = 2 




4942




 





 





 





 





 





 



   3!  = 6 




4943




 





 





 





 





 





 



   4!  = 24 




4944




 





 





 





 





 





 



   5!  = 120 




4945




 





 





 





 





 





 



   6!  = 720 




4946




 





 





 





 





 





 



   7!  = 5040 




4947




 





 





 





 





 





 



   8!  = 40320 




4948




 





 





 





 





 





 



   9!  = 362880 




4949




 





 





 





 





 





 



  10!  = 3628800 




4950




 





 





 





 





 





 



  . 




4951




 





 





 





 





 





 



  . 




4952




 





 





 





 





 





 



  . 




4953




 





 





 





 





 





 



  100! = 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000 




4954




 





 





 





 





 





 



   




4955




 





 





 





 





 





 



 C takes a list and return a list of arrayrefs for each 




4956




 





 





 





 





 





 



 of the permutations of the input list: 




4957




 





 





 





 





 





 



   




4958




 





 





 





 





 





 



  permutations('a','b');     #returns (['a','b'],['b','a']) 




4959




 





 





 





 





 





 



   




4960




 





 





 





 





 





 



  permutations('a','b','c'); #returns (['a','b','c'],['a','c','b'], 




4961




 





 





 





 





 





 



                             #         ['b','a','c'],['b','c','a'], 




4962




 





 





 





 





 





 



                             #         ['c','a','b'],['c','b','a']) 




4963




 





 





 





 





 





 



   




4964




 





 





 





 





 





 



 Up to five input arguments C is probably as fast as it 




4965




 





 





 





 





 





 



 can be in this pure perl implementation (see source). For more than 




4966




 





 





 





 





 





 



 five, it could be faster. How fast is it now: Running with different 




4967




 





 





 





 





 





 



 n, this many time took that many seconds: 




4968




 





 





 





 





 





 



   




4969




 





 





 





 





 





 



  n   times    seconds 




4970




 





 





 





 





 





 



  -- ------- --------- 




4971




 





 





 





 





 





 



   2  100000      0.32 




4972




 





 





 





 





 





 



   3  10000       0.09 




4973




 





 





 





 





 





 



   4  10000       0.33 




4974




 





 





 





 





 





 



   5  1000        0.18 




4975




 





 





 





 





 





 



   6  100         0.27 




4976




 





 





 





 





 





 



   7  10          0.21 




4977




 





 





 





 





 





 



   8  1           0.17 




4978




 





 





 





 





 





 



   9  1           1.63 




4979




 





 





 





 





 





 



  10  1          17.00 




4980




 





 





 





 





 





 



   




4981




 





 





 





 





 





 



 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. For example this: 




4982




 





 





 





 





 





 



   




4983




 





 





 





 





 





 



  print for permutations(sub{join"",@_},1..3); 




4984




 





 





 





 





 





 



   




4985




 





 





 





 





 





 



 ...will print the same as: 




4986




 





 





 





 





 





 



   




4987




 





 





 





 





 





 



  print for map join("",@$_), permutations(1..3); 




4988




 





 





 





 





 





 



   




4989




 





 





 





 





 





 



 ...but the first of those two uses less RAM if 3 has been say 9. 




4990




 





 





 





 





 





 



 Changing 3 with 10, and many computers hasn't enough memory 




4991




 





 





 





 





 





 



 for the latter. 




4992




 





 





 





 





 





 



   




4993




 





 





 





 





 





 



 The examples prints: 




4994




 





 





 





 





 





 



   




4995




 





 





 





 





 





 



  123 




4996




 





 





 





 





 





 



  132 




4997




 





 





 





 





 





 



  213 




4998




 





 





 





 





 





 



  231 




4999




 





 





 





 





 





 



  312 




5000




 





 





 





 





 





 



  321 




5001




 





 





 





 





 





 



   




5002




 





 





 





 





 





 



 If you just want to say calculate something on each permutation, 




5003




 





 





 





 





 





 



 but is not interested in the list of them, you just don't 




5004




 





 





 





 





 





 



 take the return. That is: 




5005




 





 





 





 





 





 



   




5006




 





 





 





 





 





 



  my $ant; 




5007




 





 





 





 





 





 



  permutations(sub{$ant++ if $_[-1]>=$_[0]*2},1..9); 




5008




 





 





 





 





 





 



   




5009




 





 





 





 





 





 



 ...is the same as: 




5010




 





 





 





 





 





 



   




5011




 





 





 





 





 





 



  $$_[-1]>=$$_[0]*2 and $ant++ for permutations(1..9); 




5012




 





 





 





 





 





 



   




5013




 





 





 





 





 





 



 ...but the first uses next to nothing of memory compared to the latter. They have about the same speed. 




5014




 





 





 





 





 





 



 (The examples just counts the permutations where the last number is at least twice as large as the first) 




5015




 





 





 





 





 





 



   




5016




 





 





 





 





 





 



 C was created to find all combinations of a persons 




5017




 





 





 





 





 





 



 name. This is useful in "fuzzy" name searches with 




5018




 





 





 





 





 





 



 L if you can not be certain what is first, middle 




5019




 





 





 





 





 





 



 and last names. In foreign or unfamiliar names it can be difficult to 




5020




 





 





 





 





 





 



 know that. 




5021




 





 





 





 





 





 



   




5022




 





 





 





 





 





 



 =cut 




5023




 





 





 





 





 





 



   




5024




 





 





 





 





 





 



 #TODO: se test_perl.pl 




5025




 





 





 





 





 





 



   




5026




 





 





 





 





 





 



 sub permutations { 




5027




2




  
 50
  




 




  
2
  



  
1
  




16



   my $code=ref($_[0]) eq 'CODE' ? shift() : undef; 




5028




2




  
 50
  



  
 33
  




 





 





11



   $code and @_<6 and return map &$code(@$_),permutations(@_); 




5029




 





 





 





 





 





 



   




5030




2




  
 50
  




 





 





 





7



   return [@_] if @_<2; 




5031




 





 





 





 





 





 



   




5032




2




  
100
  




 





 





 





19



   return ([@_[0,1]],[@_[1,0]]) if @_==2; 




5033




 





 





 





 





 





 



   




5034




1




  
 50
  




 





 





 





19



   return ([@_[0,1,2]],[@_[0,2,1]],[@_[1,0,2]], 




5035




 





 





 





 





 





 



 	  [@_[1,2,0]],[@_[2,0,1]],[@_[2,1,0]]) if @_==3; 




5036




 





 





 





 





 





 



   




5037



  
0
  



  
  0
  




 





 





 





0



   return ([@_[0,1,2,3]],[@_[0,1,3,2]],[@_[0,2,1,3]],[@_[0,2,3,1]], 




5038




 





 





 





 





 





 



 	  [@_[0,3,1,2]],[@_[0,3,2,1]],[@_[1,0,2,3]],[@_[1,0,3,2]], 




5039




 





 





 





 





 





 



 	  [@_[1,2,0,3]],[@_[1,2,3,0]],[@_[1,3,0,2]],[@_[1,3,2,0]], 




5040




 





 





 





 





 





 



 	  [@_[2,0,1,3]],[@_[2,0,3,1]],[@_[2,1,0,3]],[@_[2,1,3,0]], 




5041




 





 





 





 





 





 



 	  [@_[2,3,0,1]],[@_[2,3,1,0]],[@_[3,0,1,2]],[@_[3,0,2,1]], 




5042




 





 





 





 





 





 



 	  [@_[3,1,0,2]],[@_[3,1,2,0]],[@_[3,2,0,1]],[@_[3,2,1,0]]) if @_==4; 




5043




 





 





 





 





 





 



   




5044



  
0
  



  
  0
  




 





 





 





0



   return ([@_[0,1,2,3,4]],[@_[0,1,2,4,3]],[@_[0,1,3,2,4]],[@_[0,1,3,4,2]],[@_[0,1,4,2,3]], 




5045




 





 





 





 





 





 



 	  [@_[0,1,4,3,2]],[@_[0,2,1,3,4]],[@_[0,2,1,4,3]],[@_[0,2,3,1,4]],[@_[0,2,3,4,1]], 




5046




 





 





 





 





 





 



 	  [@_[0,2,4,1,3]],[@_[0,2,4,3,1]],[@_[0,3,1,2,4]],[@_[0,3,1,4,2]],[@_[0,3,2,1,4]], 




5047




 





 





 





 





 





 



 	  [@_[0,3,2,4,1]],[@_[0,3,4,1,2]],[@_[0,3,4,2,1]],[@_[0,4,1,2,3]],[@_[0,4,1,3,2]], 




5048




 





 





 





 





 





 



 	  [@_[0,4,2,1,3]],[@_[0,4,2,3,1]],[@_[0,4,3,1,2]],[@_[0,4,3,2,1]],[@_[1,0,2,3,4]], 




5049




 





 





 





 





 





 



 	  [@_[1,0,2,4,3]],[@_[1,0,3,2,4]],[@_[1,0,3,4,2]],[@_[1,0,4,2,3]],[@_[1,0,4,3,2]], 




5050




 





 





 





 





 





 



 	  [@_[1,2,0,3,4]],[@_[1,2,0,4,3]],[@_[1,2,3,0,4]],[@_[1,2,3,4,0]],[@_[1,2,4,0,3]], 




5051




 





 





 





 





 





 



 	  [@_[1,2,4,3,0]],[@_[1,3,0,2,4]],[@_[1,3,0,4,2]],[@_[1,3,2,0,4]],[@_[1,3,2,4,0]], 




5052




 





 





 





 





 





 



 	  [@_[1,3,4,0,2]],[@_[1,3,4,2,0]],[@_[1,4,0,2,3]],[@_[1,4,0,3,2]],[@_[1,4,2,0,3]], 




5053




 





 





 





 





 





 



 	  [@_[1,4,2,3,0]],[@_[1,4,3,0,2]],[@_[1,4,3,2,0]],[@_[2,0,1,3,4]],[@_[2,0,1,4,3]], 




5054




 





 





 





 





 





 



 	  [@_[2,0,3,1,4]],[@_[2,0,3,4,1]],[@_[2,0,4,1,3]],[@_[2,0,4,3,1]],[@_[2,1,0,3,4]], 




5055




 





 





 





 





 





 



 	  [@_[2,1,0,4,3]],[@_[2,1,3,0,4]],[@_[2,1,3,4,0]],[@_[2,1,4,0,3]],[@_[2,1,4,3,0]], 




5056




 





 





 





 





 





 



 	  [@_[2,3,0,1,4]],[@_[2,3,0,4,1]],[@_[2,3,1,0,4]],[@_[2,3,1,4,0]],[@_[2,3,4,0,1]], 




5057




 





 





 





 





 





 



 	  [@_[2,3,4,1,0]],[@_[2,4,0,1,3]],[@_[2,4,0,3,1]],[@_[2,4,1,0,3]],[@_[2,4,1,3,0]], 




5058




 





 





 





 





 





 



 	  [@_[2,4,3,0,1]],[@_[2,4,3,1,0]],[@_[3,0,1,2,4]],[@_[3,0,1,4,2]],[@_[3,0,2,1,4]], 




5059




 





 





 





 





 





 



 	  [@_[3,0,2,4,1]],[@_[3,0,4,1,2]],[@_[3,0,4,2,1]],[@_[3,1,0,2,4]],[@_[3,1,0,4,2]], 




5060




 





 





 





 





 





 



 	  [@_[3,1,2,0,4]],[@_[3,1,2,4,0]],[@_[3,1,4,0,2]],[@_[3,1,4,2,0]],[@_[3,2,0,1,4]], 




5061




 





 





 





 





 





 



 	  [@_[3,2,0,4,1]],[@_[3,2,1,0,4]],[@_[3,2,1,4,0]],[@_[3,2,4,0,1]],[@_[3,2,4,1,0]], 




5062




 





 





 





 





 





 



 	  [@_[3,4,0,1,2]],[@_[3,4,0,2,1]],[@_[3,4,1,0,2]],[@_[3,4,1,2,0]],[@_[3,4,2,0,1]], 




5063




 





 





 





 





 





 



 	  [@_[3,4,2,1,0]],[@_[4,0,1,2,3]],[@_[4,0,1,3,2]],[@_[4,0,2,1,3]],[@_[4,0,2,3,1]], 




5064




 





 





 





 





 





 



 	  [@_[4,0,3,1,2]],[@_[4,0,3,2,1]],[@_[4,1,0,2,3]],[@_[4,1,0,3,2]],[@_[4,1,2,0,3]], 




5065




 





 





 





 





 





 



 	  [@_[4,1,2,3,0]],[@_[4,1,3,0,2]],[@_[4,1,3,2,0]],[@_[4,2,0,1,3]],[@_[4,2,0,3,1]], 




5066




 





 





 





 





 





 



 	  [@_[4,2,1,0,3]],[@_[4,2,1,3,0]],[@_[4,2,3,0,1]],[@_[4,2,3,1,0]],[@_[4,3,0,1,2]], 




5067




 





 





 





 





 





 



 	  [@_[4,3,0,2,1]],[@_[4,3,1,0,2]],[@_[4,3,1,2,0]],[@_[4,3,2,0,1]],[@_[4,3,2,1,0]]) if @_==5; 




5068




 





 





 





 





 





 



   




5069



  
0
  




 





 





 





 





0



   my(@r,@p,@c,@i,@n); @i=(0,@_); @p=@c=1..@_; @n=1..@_-1; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5070




 





 





 





 





 





 



   PERM: 




5071



  
0
  




 





 





 





 





0



   while(1){ 




5072



  
0
  



  
  0
  




 





 





 





0



     if($code){if(defined wantarray){push(@r,&$code(@i[@p]))}else{&$code(@i[@p])}}else{push@r,[@i[@p]]} 




 



  
0
  



  
  0
  




 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5073



  
0
  



  
  0
  




 





 





 





0



     for my$i(@n){splice@p,$i,0,shift@p;next PERM if --$c[$i];$c[$i]=$i+1} 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5074




 





 





 





 





 





 



     return@r 




5075



  
0
  




 





 





 





 





0



   } 




5076




 





 





 





 





 





 



 } 




5077




 





 





 





 





 





 



   




5078




 





 





 





 





 





 



 =head2 cart 




5079




 





 





 





 





 





 



   




5080




 





 





 





 





 





 



 Cartesian product 




5081




 





 





 





 





 





 



   




5082




 





 





 





 





 





 



 B 




5083




 





 





 





 





 





 



   




5084




 





 





 





 





 





 



 Input: two or more arrayrefs with accordingly x, y, z and so on number of elements. 




5085




 





 





 





 





 





 



   




5086




 





 





 





 





 





 



 Output: An array of x * y * z number of arrayrefs. The arrays being the cartesian product of the input arrays. 




5087




 





 





 





 





 





 



   




5088




 





 





 





 





 





 



 It can be useful to think of this as joins in SQL. In C statements with 




5089




 





 





 





 





 





 



 more tables behind C, but without any C condition to join the tables. 




5090




 





 





 





 





 





 



   




5091




 





 





 





 





 





 



 B 




5092




 





 





 





 





 





 



   




5093




 





 





 





 





 





 



 B 




5094




 





 





 





 





 





 



   




5095




 





 





 





 





 





 



 - Either two or more arrayrefs with x, y, z and so on number of elements. 




5096




 





 





 





 





 





 



   




5097




 





 





 





 





 





 



 - Or coderefs to subs containing condition checks. Somewhat like C conditions in SQL. 




5098




 





 





 





 





 





 



   




5099




 





 





 





 





 





 



 B An array of x * y * z number of arrayrefs (the cartesian product) 




5100




 





 





 





 





 





 



 minus the ones that did not fulfill the condition(s). 




5101




 





 





 





 





 





 



   




5102




 





 





 





 





 





 



 This of is as joins with one or more where conditions as coderefs. 




5103




 





 





 





 





 





 



   




5104




 





 





 





 





 





 



 The coderef input arguments can be placed last or among the array refs 




5105




 





 





 





 





 





 



 to save both runtime and memory if the conditions depend on 




5106




 





 





 





 





 





 



 arrays further back. 




5107




 





 





 





 





 





 



   




5108




 





 





 





 





 





 



 B 




5109




 





 





 





 





 





 



   




5110




 





 





 





 





 





 



  for(cart(\@a1,\@a2,\@a3)){ 




5111




 





 





 





 





 





 



    my($a1,$a2,$a3) = @$_; 




5112




 





 





 





 





 





 



    print "$a1,$a2,$a3\n"; 




5113




 





 





 





 





 





 



  } 




5114




 





 





 





 





 





 



   




5115




 





 





 





 





 





 



 Prints the same as this: 




5116




 





 





 





 





 





 



   




5117




 





 





 





 





 





 



  for my $a1 (@a1){ 




5118




 





 





 





 





 





 



    for my $a2 (@a2){ 




5119




 





 





 





 





 





 



      for my $a3 (@a3){ 




5120




 





 





 





 





 





 



        print "$a1,$a2,$a3\n"; 




5121




 





 





 





 





 





 



      } 




5122




 





 





 





 





 





 



    } 




5123




 





 





 





 





 





 



  } 




5124




 





 





 





 





 





 



   




5125




 





 





 





 





 





 



 B (with a condition: the sum of the first two should be dividable with 3) 




5126




 





 





 





 





 





 



   




5127




 





 





 





 





 





 



  for( cart( \@a1, \@a2, sub{sum(@$_)%3==0}, \@a3 ) ) { 




5128




 





 





 





 





 





 



    my($a1,$a2,$a3)=@$_; 




5129




 





 





 





 





 





 



    print "$a1,$a2,$a3\n"; 




5130




 





 





 





 





 





 



  } 




5131




 





 





 





 





 





 



   




5132




 





 





 





 





 





 



 Prints the same as this: 




5133




 





 





 





 





 





 



   




5134




 





 





 





 





 





 



  for my $a1 (@a1){ 




5135




 





 





 





 





 





 



    for my $a2 (@a2){ 




5136




 





 





 





 





 





 



      next if 0==($a1+$a2)%3; 




5137




 





 





 





 





 





 



      for my $a3 (@a3){ 




5138




 





 





 





 





 





 



        print "$a1,$a2,$a3\n"; 




5139




 





 





 





 





 





 



      } 




5140




 





 





 





 





 





 



    } 




5141




 





 





 





 





 





 



  } 




5142




 





 





 





 





 





 



   




5143




 





 





 





 





 





 



 B 




5144




 





 





 





 





 





 



   




5145




 





 





 





 





 





 



  my @a1 = (1,2); 




5146




 





 





 





 





 





 



  my @a2 = (10,20,30); 




5147




 





 





 





 





 





 



  my @a3 = (100,200,300,400); 




5148




 





 





 





 





 





 



   




5149




 





 





 





 





 





 



  my $s = join"", map "*".join(",",@$_), cart(\@a1,\@a2,\@a3); 




5150




 





 





 





 





 





 



  ok( $s eq  "*1,10,100*1,10,200*1,10,300*1,10,400*1,20,100*1,20,200" 




5151




 





 





 





 





 





 



            ."*1,20,300*1,20,400*1,30,100*1,30,200*1,30,300*1,30,400" 




5152




 





 





 





 





 





 



            ."*2,10,100*2,10,200*2,10,300*2,10,400*2,20,100*2,20,200" 




5153




 





 





 





 





 





 



            ."*2,20,300*2,20,400*2,30,100*2,30,200*2,30,300*2,30,400"); 




5154




 





 





 





 





 





 



   




5155




 





 





 





 





 





 



  $s=join"",map "*".join(",",@$_), cart(\@a1,\@a2,\@a3,sub{sum(@$_)%3==0}); 




5156




 





 





 





 





 





 



  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"); 




5157




 





 





 





 





 





 



   




5158




 





 





 





 





 





 



 B 




5159




 





 





 





 





 





 



   




5160




 





 





 





 





 





 



 Returns hashrefs instead of arrayrefs: 




5161




 





 





 





 





 





 



   




5162




 





 





 





 





 





 



  my @cards=cart(             #5200 cards: 100 decks of 52 cards 




5163




 





 





 





 





 





 



    deck  => [1..100], 




5164




 





 





 





 





 





 



    value => [qw/2 3 4 5 6 7 8 9 10 J Q K A/], 




5165




 





 





 





 





 





 



    col   => [qw/heart diamond club star/], 




5166




 





 





 





 





 





 



  ); 




5167




 





 





 





 





 





 



  for my $card ( mix(@cards) ) { 




5168




 





 





 





 





 





 



    print "From deck number $$card{deck} we got $$card{value} $$card{col}\n"; 




5169




 





 





 





 





 





 



  } 




5170




 





 





 





 





 





 



   




5171




 





 





 





 





 





 



 Note: using sub-ref filters do not work (yet) in hash-mode. Use grep on result instead. 




5172




 





 





 





 





 





 



   




5173




 





 





 





 





 





 



 =cut 




5174




 





 





 





 





 





 



   




5175




 





 





 





 





 





 



 sub cart { 




5176




5





 





 




  
5
  



  
1
  




850



   my @ars=@_; 




5177




5




  
100
  




 





 





 





17



   if(!ref($_[0])){ #if hash-mode detected 




5178




1





 




  
 33
  




 





 





2



     my(@k,@v); push@k,shift@ars and push@v,shift@ars while @ars; 




 




1





 





 





 





 





13



   




5179




1





 





 





 





 





7



     return map{my%h;@h{@k}=@$_;\%h}cart(@v); 




 




24





 





 





 





 





26



   




 




24





 





 





 





 





68



   




 




24





 





 





 





 





44



   




5180




 





 





 





 





 





 



   } 




5181




4





 





 





 





 





6



   my @res=map[$_],@{shift@ars}; 




 




4





 





 





 





 





20



   




5182




4





 





 





 





 





9



   for my $ar (@ars){ 




5183




9




  
100
  



  
 50
  




 





 





26



     @res=grep{&$ar(@$_)}@res and next if ref($ar) eq 'CODE'; 




 




24





 





 





 





 





51



   




5184




8





 





 





 





 





13



     @res=map{my$r=$_;map{[@$r,$_]}@$ar}@res; 




 




34





 





 





 





 





38



   




 




34





 





 





 





 





49



   




 




120





 





 





 





 





257



   




5185




 





 





 





 





 





 



   } 




5186




4





 





 





 





 





63



   return @res; 




5187




 





 





 





 





 





 



 } 




5188




 





 





 





 





 





 



   




5189




 





 





 





 





 





 



 sub cart_easy { #not tested/exported http://stackoverflow.com/questions/2457096/in-perl-how-can-i-get-the-cartesian-product-of-multiple-sets 




5190



  
0
  




 





 




  
0
  



  
0
  




0



   my $last = pop @_; 




5191



  
0
  



  
  0
  




 





 





 





0



   @_ ? (map {my$left=$_; map [@$left, $_], @$last } cart_easy(@_) ) 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5192




 





 





 





 





 





 



      : (map [$_], @$last); 




5193




 





 





 





 





 





 



 } 




5194




 





 





 





 





 





 



   




5195




 





 





 





 





 





 



 =head2 reduce 




5196




 





 





 





 





 





 



   




5197




 





 





 





 





 





 



 From: Why Functional Programming Matters: L 




5198




 





 





 





 





 





 



   




5199




 





 





 





 





 





 



 L 




5200




 





 





 





 





 





 



   




5201




 





 





 





 





 





 



 DON'T TRY THIS AT HOME, C PROGRAMMERS. 




5202




 





 





 





 





 





 



   




5203




 





 





 





 





 





 



  sub reduce (&@) { 




5204




 





 





 





 





 





 



    my ($proc, $first, @rest) = @_; 




5205




 





 





 





 





 





 



    return $first if @rest == 0; 




5206




 





 





 





 





 





 



    local ($a, $b) = ($first, reduce($proc, @rest)); 




5207




 





 





 





 





 





 



    return $proc->(); 




5208




 





 





 





 





 





 



  } 




5209




 





 





 





 





 





 



   




5210




 





 





 





 





 





 



 Many functions can then be implemented with very little code. Such as: 




5211




 





 





 





 





 





 



   




5212




 





 





 





 





 





 



  sub mean { (reduce {$a + $b} @_) / @_ } 




5213




 





 





 





 





 





 



   




5214




 





 





 





 





 





 



 =cut 




5215




 





 





 





 





 





 



   




5216




 





 





 





 





 





 



 sub reduce (&@) { 




5217



  
0
  




 





 




  
0
  



  
1
  




0



   my ($proc, $first, @rest) = @_; 




5218



  
0
  



  
  0
  




 





 





 





0



   return $first if @rest == 0; 




5219




28





 





 




  
28
  




 





135865



   no warnings; 




 




28





 





 





 





 





61



   




 




28





 





 





 





 





32373



   




5220



  
0
  




 





 





 





 





0



   local ($a, $b) = ($first, reduce($proc, @rest)); 




5221



  
0
  




 





 





 





 





0



   return $proc->(); 




5222




 





 





 





 





 





 



 } 




5223




 





 





 





 





 





 



   




5224




 





 





 





 





 





 



   




5225




 





 





 





 





 





 



 =head2 pivot 




5226




 





 





 





 





 





 



   




5227




 





 





 





 





 





 



 Resembles the pivot table function in Excel. 




5228




 





 





 





 





 





 



   




5229




 





 





 





 





 





 



 C is used to spread out a slim and long table to a visually improved layout. 




5230




 





 





 





 





 





 



   




5231




 





 





 





 





 





 



 For instance spreading out the results of C-selects from SQL: 




5232




 





 





 





 





 





 



   




5233




 





 





 





 





 





 



  pivot( arrayref, columnname1, columnname2, ...) 




5234




 





 





 





 





 





 



   




5235




 





 





 





 





 





 



  pivot( ref_to_array_of_arrayrefs, @list_of_names_to_down_fields ) 




5236




 





 





 





 





 





 



   




5237




 





 





 





 





 





 



 The first argument is a ref to a two dimensional table. 




5238




 





 





 





 





 





 



   




5239




 





 





 





 





 





 



 The rest of the arguments is a list which also signals the number of 




5240




 





 





 





 





 





 



 columns from left in each row that is ending up to the left of the 




5241




 





 





 





 





 





 



 data table, the rest ends up at the top and the last element of 




5242




 





 





 





 





 





 



 each row ends up as data. 




5243




 





 





 





 





 





 



   




5244




 





 





 





 





 





 



                    top1 top1 top1 top1 




5245




 





 





 





 





 





 



  left1 left2 left3 top2 top2 top2 top2 




5246




 





 





 





 





 





 



  ----- ----- ----- ---- ---- ---- ---- 




5247




 





 





 





 





 





 



                    data data data data 




5248




 





 





 





 





 





 



                    data data data data 




5249




 





 





 





 





 





 



                    data data data data 




5250




 





 





 





 





 





 



   




5251




 





 





 





 





 





 



 Example: 




5252




 





 





 





 





 





 



   




5253




 





 





 





 





 





 



  my @table=( 




5254




 





 





 





 





 





 



                ["1997","Gerd", "Weight", "Summer",66], 




5255




 





 





 





 





 





 



                ["1997","Gerd", "Height", "Summer",170], 




5256




 





 





 





 





 





 



                ["1997","Per",  "Weight", "Summer",75], 




5257




 





 





 





 





 





 



                ["1997","Per",  "Height", "Summer",182], 




5258




 





 





 





 





 





 



                ["1997","Hilde","Weight", "Summer",62], 




5259




 





 





 





 





 





 



                ["1997","Hilde","Height", "Summer",168], 




5260




 





 





 





 





 





 



                ["1997","Tone", "Weight", "Summer",70], 




5261




 





 





 





 





 





 



   




5262




 





 





 





 





 





 



                ["1997","Gerd", "Weight", "Winter",64], 




5263




 





 





 





 





 





 



                ["1997","Gerd", "Height", "Winter",158], 




5264




 





 





 





 





 





 



                ["1997","Per",  "Weight", "Winter",73], 




5265




 





 





 





 





 





 



                ["1997","Per",  "Height", "Winter",180], 




5266




 





 





 





 





 





 



                ["1997","Hilde","Weight", "Winter",61], 




5267




 





 





 





 





 





 



                ["1997","Hilde","Height", "Winter",164], 




5268




 





 





 





 





 





 



                ["1997","Tone", "Weight", "Winter",69], 




5269




 





 





 





 





 





 



   




5270




 





 





 





 





 





 



                ["1998","Gerd", "Weight", "Summer",64], 




5271




 





 





 





 





 





 



                ["1998","Gerd", "Height", "Summer",171], 




5272




 





 





 





 





 





 



                ["1998","Per",  "Weight", "Summer",76], 




5273




 





 





 





 





 





 



                ["1998","Per",  "Height", "Summer",182], 




5274




 





 





 





 





 





 



                ["1998","Hilde","Weight", "Summer",62], 




5275




 





 





 





 





 





 



                ["1998","Hilde","Height", "Summer",168], 




5276




 





 





 





 





 





 



                ["1998","Tone", "Weight", "Summer",70], 




5277




 





 





 





 





 





 



   




5278




 





 





 





 





 





 



                ["1998","Gerd", "Weight", "Winter",64], 




5279




 





 





 





 





 





 



                ["1998","Gerd", "Height", "Winter",171], 




5280




 





 





 





 





 





 



                ["1998","Per",  "Weight", "Winter",74], 




5281




 





 





 





 





 





 



                ["1998","Per",  "Height", "Winter",183], 




5282




 





 





 





 





 





 



                ["1998","Hilde","Weight", "Winter",62], 




5283




 





 





 





 





 





 



                ["1998","Hilde","Height", "Winter",168], 




5284




 





 





 





 





 





 



                ["1998","Tone", "Weight", "Winter",71], 




5285




 





 





 





 





 





 



              ); 




5286




 





 





 





 





 





 



   




5287




 





 





 





 





 





 



 . 




5288




 





 





 





 





 





 



   




5289




 





 





 





 





 





 



  my @reportA=pivot(\@table,"Year","Name"); 




5290




 





 





 





 





 





 



  print "\n\nReport A\n\n".tablestring(\@reportA); 




5291




 





 





 





 





 





 



   




5292




 





 





 





 





 





 



 Will print: 




5293




 





 





 





 





 





 



   




5294




 





 





 





 





 





 



  Report A 




5295




 





 





 





 





 





 



   




5296




 





 





 





 





 





 



  Year Name  Height Height Weight Weight 




5297




 





 





 





 





 





 



             Summer Winter Summer Winter 




5298




 





 





 





 





 





 



  ---- ----- ------ ------ ------ ------ 




5299




 





 





 





 





 





 



  1997 Gerd  170    158    66     64 




5300




 





 





 





 





 





 



  1997 Hilde 168    164    62     61 




5301




 





 





 





 





 





 



  1997 Per   182    180    75     73 




5302




 





 





 





 





 





 



  1997 Tone                70     69 




5303




 





 





 





 





 





 



  1998 Gerd  171    171    64     64 




5304




 





 





 





 





 





 



  1998 Hilde 168    168    62     62 




5305




 





 





 





 





 





 



  1998 Per   182    183    76     74 




5306




 





 





 





 





 





 



  1998 Tone                70     71 




5307




 





 





 





 





 





 



   




5308




 





 





 





 





 





 



 . 




5309




 





 





 





 





 





 



   




5310




 





 





 





 





 





 



  my @reportB=pivot([map{$_=[@$_[0,3,2,1,4]]}(@t=@table)],"Year","Season"); 




5311




 





 





 





 





 





 



  print "\n\nReport B\n\n".tablestring(\@reportB); 




5312




 





 





 





 





 





 



   




5313




 





 





 





 





 





 



 Will print: 




5314




 





 





 





 





 





 



   




5315




 





 





 





 





 





 



  Report B 




5316




 





 





 





 





 





 



   




5317




 





 





 





 





 





 



  Year Season Height Height Height Weight Weight Weight Weight 




5318




 





 





 





 





 





 



              Gerd   Hilde  Per    Gerd   Hilde  Per    Tone 




5319




 





 





 





 





 





 



  ---- ------ ------ ------ -----  -----  ------ ------ ------ 




5320




 





 





 





 





 





 



  1997 Summer 170    168    182    66     62     75     70 




5321




 





 





 





 





 





 



  1997 Winter 158    164    180    64     61     73     69 




5322




 





 





 





 





 





 



  1998 Summer 171    168    182    64     62     76     70 




5323




 





 





 





 





 





 



  1998 Winter 171    168    183    64     62     74     71 




5324




 





 





 





 





 





 



   




5325




 





 





 





 





 





 



 . 




5326




 





 





 





 





 





 



   




5327




 





 





 





 





 





 



  my @reportC=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name","Attributt"); 




5328




 





 





 





 





 





 



  print "\n\nReport C\n\n".tablestring(\@reportC); 




5329




 





 





 





 





 





 



   




5330




 





 





 





 





 





 



 Will print: 




5331




 





 





 





 





 





 



   




5332




 





 





 





 





 





 



  Report C 




5333




 





 





 





 





 





 



   




5334




 





 





 





 





 





 



  Name  Attributt 1997   1997   1998   1998 




5335




 





 





 





 





 





 



                  Summer Winter Summer Winter 




5336




 





 





 





 





 





 



  ----- --------- ------ ------ ------ ------ 




5337




 





 





 





 





 





 



  Gerd  Height     170    158    171    171 




5338




 





 





 





 





 





 



  Gerd  Weight      66     64     64     64 




5339




 





 





 





 





 





 



  Hilde Height     168    164    168    168 




5340




 





 





 





 





 





 



  Hilde Weight      62     61     62     62 




5341




 





 





 





 





 





 



  Per   Height     182    180    182    183 




5342




 





 





 





 





 





 



  Per   Weight      75     73     76     74 




5343




 





 





 





 





 





 



  Tone  Weight      70     69     70     71 




5344




 





 





 





 





 





 



   




5345




 





 





 





 





 





 



 . 




5346




 





 





 





 





 





 



   




5347




 





 





 





 





 





 



  my @reportD=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name"); 




5348




 





 





 





 





 





 



  print "\n\nReport D\n\n".tablestring(\@reportD); 




5349




 





 





 





 





 





 



   




5350




 





 





 





 





 





 



 Will print: 




5351




 





 





 





 





 





 



   




5352




 





 





 





 





 





 



  Report D 




5353




 





 





 





 





 





 



   




5354




 





 





 





 





 





 



  Name  Height Height Height Height Weight Weight Weight Weight 




5355




 





 





 





 





 





 



        1997   1997   1998   1998   1997   1997   1998   1998 




5356




 





 





 





 





 





 



        Summer Winter Summer Winter Summer Winter Summer Winter 




5357




 





 





 





 





 





 



  ----- ------ ------ ------ ------ ------ ------ ------ ------ 




5358




 





 





 





 





 





 



  Gerd  170    158    171    171    66     64     64     64 




5359




 





 





 





 





 





 



  Hilde 168    164    168    168    62     61     62     62 




5360




 





 





 





 





 





 



  Per   182    180    182    183    75     73     76     74 




5361




 





 





 





 





 





 



  Tone                              70     69     70     71 




5362




 





 





 





 





 





 



   




5363




 





 





 





 





 





 



 Options: 




5364




 





 





 





 





 





 



   




5365




 





 





 





 





 





 



 Options to sort differently and show sums and percents are available. (...MORE DOC ON THAT LATER...) 




5366




 





 





 





 





 





 



   




5367




 





 





 





 





 





 



 See also L 




5368




 





 





 





 





 





 



   




5369




 





 





 





 





 





 



 =cut 




5370




 





 





 





 





 





 



   




5371




 





 





 





 





 





 



 sub pivot { 




5372




4





 





 




  
4
  



  
1
  




11



   my($tabref,@vertikalefelt)=@_; 




5373




4




  
 50
  




 





 





 





15



   my %opt=ref($vertikalefelt[-1]) eq 'HASH' ? %{pop(@vertikalefelt)} : (); 




 



  
0
  




 





 





 





 





0



   




5374




4




  
 50
  




 





 





 





16



   my $opt_sum=1 if $opt{sum}; 




5375




4




  
 50
  



  
  0
  




 





 





8



   my $opt_pro=exists $opt{prosent}?$opt{prosent}||0:undef; 




5376




4





 




  
 50
  




 





 





23



   my $sortsub          = $opt{'sortsub'}          || \&_sortsub; 




5377




4





 




  
 33
  




 





 





18



   my $sortsub_bortover = $opt{'sortsub_bortover'} || $sortsub; 




5378




4





 




  
 33
  




 





 





29



   my $sortsub_nedover  = $opt{'sortsub_nedover'}  || $sortsub; 




5379




 





 





 





 





 





 



   #print serialize(\%opt,'opt'); 




5380




 





 





 





 





 





 



   #print serialize(\$opt_pro,'opt_pro'); 




5381




4





 





 





 





 





7



   my $antned=0+@vertikalefelt; 




5382




4





 





 





 





 





7



   my $bakerst=-1+@{$$tabref[0]}; 




 




4





 





 





 





 





10



   




5383




4





 





 





 





 





5



   my(%h,%feltfinnes,%sum); 




5384




 





 





 





 





 





 



   #print "Bakerst<$bakerst>\n"; 




5385




4





 





 





 





 





9



   for(@$tabref){ 




5386




112





 





 





 





 





256



     my $rad=join($;,@$_[0..($antned-1)]); 




5387




112





 





 





 





 





222



     my $felt=join($;,@$_[$antned..($bakerst-1)]); 




5388




112





 





 





 





 





150



     my $verdi=$$_[$bakerst]; 




5389




112




  
 50
  




 





 





 





240



     length($rad) or $rad=' '; 




5390




112




  
 50
  




 





 





 





185



     length($felt) or $felt=' '; 




5391




112





 





 





 





 





227



     $h{$rad}{$felt}=$verdi; 




5392




112





 





 





 





 





239



     $h{$rad}{"%$felt"}=$verdi; 




5393




112




  
 50
  



  
 33
  




 





 





411



     if($opt_sum or defined $opt_pro){ 




5394



  
0
  




 





 





 





 





0



       $h{$rad}{Sum}+=$verdi; 




5395



  
0
  




 





 





 





 





0



       $sum{$felt}+=$verdi; 




5396



  
0
  




 





 





 





 





0



       $sum{Sum}+=$verdi; 




5397




 





 





 





 





 





 



     } 




5398




112





 





 





 





 





164



     $feltfinnes{$felt}++; 




5399




112




  
 50
  




 





 





 





319



     $feltfinnes{"%$felt"}++ if $opt_pro; 




5400




 





 





 





 





 





 



   } 




5401




4





 





 





 





 





26



   my @feltfinnes = sort $sortsub_bortover keys%feltfinnes; 




5402




4




  
 50
  




 





 





 





12



   push @feltfinnes, "Sum" if $opt_sum; 




5403




4





 





 





 





 





8



   my @t=([@vertikalefelt,map{replace($_,$;,"\n")}@feltfinnes]); 




 




23





 





 





 





 





42



   




5404




 





 





 





 





 





 



   #print serialize(\@feltfinnes,'feltfinnes'); 




5405




 





 





 





 





 





 



   #print serialize(\%h,'h'); 




5406




 





 





 





 





 





 



   #print "H = ".join(", ",sort _sortsub keys%h)."\n"; 




5407




4





 





 





 





 





18



   for my $rad (sort $sortsub_nedover keys(%h)){ 




5408




 





 





 





 





 





 



     my @rad=(split($;,$rad), 




5409




 





 





 





 





 





 



 	     map{ 




5410




23




  
 50
  



  
 33
  




 





 





154



 	       if(/^\%/ and defined $opt_pro){ 




 




120





 





 





 





 





309



   




5411



  
0
  




 





 





 





 





0



 		 my $sum=$h{$rad}{Sum}; 




5412



  
0
  




 





 





 





 





0



 		 my $verdi=$h{$rad}{$_}; 




5413



  
0
  



  
  0
  




 





 





 





0



 		 if($sum!=0){ 




5414



  
0
  



  
  0
  




 





 





 





0



 		   defined $verdi 




5415




 





 





 





 





 





 



                    ?sprintf("%*.*f",3+1+$opt_pro,$opt_pro,100*$verdi/$sum) 




5416




 





 





 





 





 





 



 		   :$verdi; 




5417




 





 





 





 





 





 



 		 } 




5418




 





 





 





 





 





 



 		 else{ 




5419



  
0
  



  
  0
  




 





 





 





0



 		   $verdi!=0?"div0":$verdi; 




5420




 





 





 





 





 





 



 		 } 




5421




 





 





 





 





 





 



 	       } 




5422




 





 





 





 





 





 



 	       else{ 




5423




120





 





 





 





 





243



 		 $h{$rad}{$_}; 




5424




 





 





 





 





 





 



 	       } 




5425




 





 





 





 





 





 



 	     } 




5426




 





 





 





 





 





 



 	     @feltfinnes); 




5427




23





 





 





 





 





84



     push(@t,[@rad]); 




5428




 





 





 





 





 





 



   } 




5429




4




  
 50
  




 





 





 





12



   push(@t,"-",["Sum",(map{""}(2..$antned)),map{print "<$_>\n";$sum{$_}}@feltfinnes]) if $opt_sum; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5430




4





 





 





 





 





53



   return @t; 




5431




 





 





 





 





 





 



 } 




5432




 





 





 





 





 





 



   




5433




 





 





 





 





 





 



 # default sortsub for pivot() 




5434




 





 





 





 





 





 



   




5435




 





 





 





 





 





 



 sub _sortsub { 




5436




28





 





 




  
28
  




 





160



   no warnings; 




 




28





 





 





 





 





47



   




 




28





 





 





 





 





13139



   




5437




 





 





 





 





 





 



   #my $c=($a<=>$b)||($a cmp $b); 




5438




 





 





 





 





 





 



   #return $c if $c; 




5439




 





 





 





 





 





 



   #printf "%-30s %-30s  ",replace($a,$;,','),replace($b,$;,','); 




5440




72





 





 




  
72
  




 





489



   my @a=split $;,$a; 




5441




72





 





 





 





 





470



   my @b=split $;,$b; 




5442




72





 





 





 





 





172



   for(0..$#a){ 




5443




110





 





 





 





 





232



     my $c=$a[$_]<=>$b[$_]; 




5444




110




  
100
  



  
 66
  




 





 





398



     return $c if $c and "$a[$_]$b[$_]"!~/[iI][nN][fF]|þ/i; # inf(inity) 




5445




96





 





 





 





 





125



     $c=$a[$_]cmp$b[$_]; 




5446




96




  
100
  




 





 





 





274



     return $c if $c; 




5447




 





 





 





 





 





 



   } 




5448



  
0
  




 





 





 





 





0



   return 0; 




5449




 





 





 





 





 





 



 } 




5450




 





 





 





 





 





 



   




5451




 





 





 





 





 





 



 =head2 tablestring 




5452




 





 





 





 





 





 



   




5453




 





 





 





 





 





 



 B a reference to an array of arrayrefs  -- a two dimensional table of strings and numbers 




5454




 





 





 





 





 





 



   




5455




 





 





 





 





 





 



 B a string containing the textual table -- a string of two or more lines 




5456




 





 





 





 





 





 



   




5457




 





 





 





 





 





 



 The first arrayref in the list refers to a list of either column headings (scalar) 




5458




 





 





 





 





 





 



 or ... (...more later...) 




5459




 





 





 





 





 





 



   




5460




 





 





 





 





 





 



 In this output table: 




5461




 





 





 





 





 





 



   




5462




 





 





 





 





 





 



 - the columns will not be wider than necessary by its widest value (any -tags are removed in every internal width-calculation) 




5463




 





 





 





 





 





 



   




5464




 





 





 





 





 





 



 - multi-lined cell values are handled also 




5465




 





 





 





 





 





 



   




5466




 





 





 





 





 





 



 - and so are html-tags, if the output is to be used inside -tags on a web page. 




5467




 





 





 





 





 





 



   




5468




 





 





 





 





 





 



 - columns with just numeric values are right justified (header row excepted) 




5469




 





 





 





 





 





 



   




5470




 





 





 





 





 





 



 Example: 




5471




 





 





 





 





 





 



   




5472




 





 





 





 





 





 



  print tablestring([ 




5473




 





 





 





 





 





 



    [qw/AA BB CCCC/], 




5474




 





 





 





 





 





 



    [123,23,"d"], 




5475




 





 





 





 





 





 



    [12,23,34], 




5476




 





 





 





 





 





 



    [77,88,99], 




5477




 





 





 





 





 





 



    ["lin\nes",12,"asdff\nfdsa\naa"],[0,22,"adf"] 




5478




 





 





 





 





 





 



  ]); 




5479




 





 





 





 





 





 



   




5480




 





 





 





 





 





 



 Prints this string of 11 lines: 




5481




 





 





 





 





 





 



   




5482




 





 





 





 





 





 



  AA  BB CCCC 




5483




 





 





 





 





 





 



  --- -- ----- 




5484




 





 





 





 





 





 



  123 23 d 




5485




 





 





 





 





 





 



  12  23 34 




5486




 





 





 





 





 





 



  77   8 99 




5487




 





 





 





 





 





 



   




5488




 





 





 





 





 





 



  lin 12 asdff 




5489




 





 





 





 





 





 



  es     fdsa 




5490




 





 





 





 





 





 



         aa 




5491




 





 





 





 





 





 



   




5492




 





 





 





 





 





 



  10  22 adf 




5493




 





 





 





 





 





 



   




5494




 





 





 





 





 





 



 As you can see, rows containing multi-lined cells gets an empty line before and after the row to separate it more clearly. 




5495




 





 





 





 





 





 



   




5496




 





 





 





 





 





 



 =cut 




5497




 





 





 





 





 





 



   




5498




 





 





 





 





 





 



 sub tablestring { 




5499




5





 





 




  
5
  



  
1
  




27



   my $tab=shift; 




5500




5




  
 50
  




 





 





 





14



   my %o=$_[0] ? %{shift()} : (); 




 



  
0
  




 





 





 





 





0



   




5501




5





 





 





 





 





8



   my $fjern_tom=$o{fjern_tomme_kolonner}; 




5502




5





 





 





 





 





8



   my $ikke_space=$o{ikke_space}; 




5503




5





 




  
 50
  




 





 





23



   my $nodup=$o{nodup}||0; 




5504




5





 





 





 





 





7



   my $ikke_hodestrek=$o{ikke_hodestrek}; 




5505




5




  
 50
  




 





 





 





13



   my $pagesize=exists $o{pagesize} ? $o{pagesize}-3 : 9999999; 




5506




5





 





 





 





 





6



   my $venstretvang=$o{venstre}; 




5507




5





 





 





 





 





6



   my(@bredde,@venstre,@hoeyde,@ikketom,@nodup); 




5508




5





 





 





 





 





7



   my $hode=1; 




5509




5





 





 





 





 





8



   my $i=0; 




5510




5





 





 





 





 





8



   my $j; 




5511




5





 





 





 





 





11



   for(@$tab){ 




5512




33





 





 





 





 





34



     $j=0; 




5513




33





 





 





 





 





43



     $hoeyde[$i]=0; 




5514




33





 





 





 





 





37



     my $nodup_rad=$nodup; 




5515




33




  
 50
  




 





 





 





72



     if(ref($_) eq 'ARRAY'){ 




5516




33





 





 





 





 





53



       for(@$_){ 




5517




210





 





 





 





 





272



 	my $celle=$_; 




5518




210





 




  
100
  




 





 





431



 	$bredde[$j]||=0; 




5519




210




  
 50
  



  
 33
  




 





 





582



 	if($nodup_rad and $i>0 and $$tab[$i][$j] eq $$tab[$i-1][$j] || ($nodup_rad=0)){ 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
 33
  




 





 





 



   




5520



  
0
  



  
  0
  




 





 





 





0



 	  $celle=$nodup==1?"":$nodup; 




5521



  
0
  




 





 





 





 





0



 	  $nodup[$i][$j]=1; 




5522




 





 





 





 





 





 



 	} 




5523




 





 





 





 





 





 



 	else{ 




5524




210





 





 





 





 





213



 	  my $hoeyde=0; 




5525




210





 





 





 





 





201



 	  my $bredere; 




5526




28





 





 




  
28
  




 





1335



 	  no warnings; 




 




28





 





 





 





 





1237



   




 




28





 





 





 





 





16611



   




5527




210




  
100
  



  
100
  




 





 





799



 	  $ikketom[$j]=1 if !$hode && length($celle)>0; 




5528




210





 





 





 





 





445



 	  for(split("\n",$celle)){ 




5529




236




  
 50
  




 





 





 





411



 	    $bredere=/




5530




236





 





 





 





 





277



 	    s/<[^>]+>//g; 




5531




236





 





 





 





 





239



 	    $hoeyde++; 




5532




236





 





 





 





 





265



 	    s/>/>/g; 




5533




236





 





 





 





 





258



 	    s/</




5534




236




  
100
  




 





 





 





585



 	    $bredde[$j]=length($_)+1+$bredere if length($_)+1+$bredere>$bredde[$j]; 




5535




236




  
100
  



  
100
  




 





 





1545



 	    $venstre[$j]=1 if $_ && !/^\s*[\-\+]?(\d+|\d*\.\d+)\s*\%?$/ && !$hode; 




 




 





 




  
100
  




 





 





 



   




5536




 





 





 





 





 





 



 	  } 




5537




210




  
100
  



  
 66
  




 





 





614



 	  if( $hoeyde>1 && !$ikke_space){ 




5538




25




  
100
  




 





 





 





53



 	    $hoeyde++ unless $hode; 




5539




25




  
100
  



  
100
  




 





 





69



 	    $hoeyde[$i-1]++ if $i>1 && $hoeyde[$i-1]==1; 




5540




 





 





 





 





 





 



 	  } 




5541




210




  
100
  




 





 





 





477



 	  $hoeyde[$i]=$hoeyde if $hoeyde>$hoeyde[$i]; 




5542




 





 





 





 





 





 



 	} 




5543




210





 





 





 





 





279



 	$j++; 




5544




 





 





 





 





 





 



       } 




5545




 





 





 





 





 





 



     } 




5546




 





 





 





 





 





 



     else{ 




5547



  
0
  




 





 





 





 





0



       $hoeyde[$i]=1; 




5548



  
0
  




 





 





 





 





0



       $ikke_hodestrek=1; 




5549




 





 





 





 





 





 



     } 




5550




33





 





 





 





 





37



     $hode=0; 




5551




33





 





 





 





 





50



     $i++; 




5552




 





 





 





 





 





 



   } 




5553




5





 





 





 





 





9



   $i=$#hoeyde; 




5554




5





 





 





 





 





7



   $j=$#bredde; 




5555




5




  
 50
  



  
 33
  




 





 





24



   if($i==0 or $venstretvang) { @venstre=map{1}(0..$j)                         } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5556




5




  
 50
  




 





 





 





11



   else { for(0..$j){ $venstre[$_]=1 if !$ikketom[$_] }  } 




 




33





 





 





 





 





68



   




5557




5





 





 





 





 





8



   my @tabut; 




5558




5





 





 





 





 





5



   my $rad_startlinje=0; 




5559




5





 





 





 





 





8



   my @overskrift; 




5560




 





 





 





 





 





 



   my $overskrift_forrige; 




5561




5





 





 





 





 





8



   for my $x (0..$i){ 




5562




33




  
 50
  




 





 





 





88



     if($$tab[$x] eq '-'){ 




5563



  
0
  



  
  0
  




 





 





 





0



       my @tegn=map {$$tab[$x-1][$_]=~/\S/?"-":" "} (0..$j); 




 



  
0
  




 





 





 





 





0



   




5564



  
0
  




 





 





 





 





0



       $tabut[$rad_startlinje]=join(" ",map {$tegn[$_] x ($bredde[$_]-1)} (0..$j)); 




 



  
0
  




 





 





 





 





0



   




5565




 





 





 





 





 





 



     } 




5566




 





 





 





 





 





 



     else{ 




5567




33





 





 





 





 





54



       for my $y (0..$j){ 




5568




210




  
 50
  



  
 33
  




 





 





464



 	next if $fjern_tom && !$ikketom[$y]; 




5569




28





 





 




  
28
  




 





1318



 	no warnings; 




 




28





 





 





 





 





49



   




 




28





 





 





 





 





22085



   




5570




 





 





 





 





 





 



 	 




5571




210




  
  0
  



  
 33
  




 





 





1343



 	my @celle= 




 




 




  
 50
  




 





 





 





 



   




5572




 





 





 





 





 





 



             !$overskrift_forrige&&$nodup&&$nodup[$x][$y] 




5573




 





 





 





 





 





 



 	    ?($nodup>0?():((" " x (($bredde[$y]-length($nodup))/2)).$nodup)) 




5574




 





 





 





 





 





 



             :split("\n",$$tab[$x][$y]); 




5575




210





 





 





 





 





434



 	for(0..($hoeyde[$x]-1)){ 




5576




261





 





 





 





 





310



 	  my $linje=$rad_startlinje+$_; 




5577




261





 




  
100
  




 





 





606



 	  my $txt=shift @celle || ''; 




5578




261




  
100
  



  
100
  




 





 





1489



 	  $txt=sprintf("%*s",$bredde[$y]-1,$txt) if length($txt)>0 && !$venstre[$y] && ($x>0 || $ikke_hodestrek); 




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 66
  




 





 





 



   




5579




261





 





 





 





 





374



 	  $tabut[$linje].=$txt; 




5580




261




  
100
  




 





 





 





431



 	  if($y==$j){ 




5581




42





 





 





 





 





185



 	    $tabut[$linje]=~s/\s+$//; 




5582




 





 





 





 





 





 



 	  } 




5583




 





 





 





 





 





 



 	  else{ 




5584




219





 





 





 





 





223



 	    my $bredere; 




5585




219




  
 50
  




 





 





 





399



 	       $bredere = $txt=~/




5586




219





 





 





 





 





275



 	    $txt=~s/<[^>]+>//g; 




5587




219





 





 





 





 





271



 	    $txt=~s/>/>/g; 




5588




219





 





 





 





 





245



 	    $txt=~s/</




5589




219





 





 





 





 





591



 	    $tabut[$linje].= ' ' x ($bredde[$y]-length($txt)-$bredere); 




5590




 





 





 





 





 





 



 	  } 




5591




 





 





 





 





 





 



 	} 




5592




 





 





 





 





 





 



       } 




5593




 





 





 





 





 





 



     } 




5594




33





 





 





 





 





45



     $rad_startlinje+=$hoeyde[$x]; 




5595




 





 





 





 





 





 



   




5596




 





 





 





 





 





 



     #--lage streker? 




5597




33




  
 50
  




 





 





 





63



     if(not $ikke_hodestrek){ 




5598




33




  
100
  



  
 33
  




 





 





155



       if($x==0){ 




 




 




  
 50
  



  
 33
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




5599




5





 





 





 





 





9



 	for my $y (0..$j){ 




5600




33




  
 50
  



  
 33
  




 





 





64



 	  next if $fjern_tom && !$ikketom[$y]; 




5601




33





 





 





 





 





68



 	  $tabut[$rad_startlinje].=('-' x ($bredde[$y]-1))." "; 




5602




 





 





 





 





 





 



 	} 




5603




5





 





 





 





 





8



 	$rad_startlinje++; 




5604




5





 





 





 





 





15



 	@overskrift=("",@tabut); 




5605




 





 





 





 





 





 



       } 




5606




 





 





 





 





 





 



       elsif( 




5607




 





 





 





 





 





 



 	    $x%$pagesize==0 || $nodup>0&&!$nodup[$x+1][$nodup-1] 




5608




 





 





 





 





 





 



 	    and $x+1<@$tab 




5609




 





 





 





 





 





 



 	    and !$ikke_hodestrek 




5610




 





 





 





 





 





 



 	    ) 




5611




 





 





 





 





 





 



       { 




5612



  
0
  




 





 





 





 





0



 	push(@tabut,@overskrift); 




5613



  
0
  




 





 





 





 





0



 	$rad_startlinje+=@overskrift; 




5614



  
0
  




 





 





 





 





0



 	$overskrift_forrige=1; 




5615




 





 





 





 





 





 



       } 




5616




 





 





 





 





 





 



       else{ 




5617




28





 





 





 





 





52



 	$overskrift_forrige=0; 




5618




 





 





 





 





 





 



       } 




5619




 





 





 





 





 





 



     } 




5620




 





 





 





 





 





 



   }#for x 




5621




5





 





 





 





 





56



   return join("\n",@tabut)."\n"; 




5622




 





 





 





 





 





 



 } 




5623




 





 





 





 





 





 



   




5624




 





 





 





 





 





 



 =head2 serialize 




5625




 





 





 





 





 





 



   




5626




 





 





 





 





 





 



 Returns a data structure as a string. See also C 




5627




 





 





 





 





 





 



 (serialize was created long time ago before Data::Dumper appeared on 




5628




 





 





 





 





 





 



 CPAN, before CPAN even...) 




5629




 





 





 





 





 





 



   




5630




 





 





 





 





 





 



 B One to four arguments. 




5631




 





 





 





 





 





 



   




5632




 





 





 





 





 





 



 First argument: A reference to the structure you want. 




5633




 





 





 





 





 





 



   




5634




 





 





 





 





 





 



 Second argument: (optional) The name the structure will get in the output string. 




5635




 





 





 





 





 





 



 If second argument is missing or is undef or '', it will get no name in the output. 




5636




 





 





 





 





 





 



   




5637




 





 





 





 





 





 



 Third argument: (optional) The string that is returned is also put 




5638




 





 





 





 





 





 



 into a created file with the name given in this argument.  Putting a 




5639




 





 





 





 





 





 



 C<< > >> char in from of the filename will append that file 




5640




 





 





 





 





 





 



 instead. Use C<''> or C to not write to a file if you want to 




5641




 





 





 





 





 





 



 use a fourth argument. 




5642




 





 





 





 





 





 



   




5643




 





 





 





 





 





 



 Fourth argument: (optional) A number signalling the depth on which newlines is used in the output. 




5644




 





 





 





 





 





 



 The default is infinite (some big number) so no extra newlines are output. 




5645




 





 





 





 





 





 



   




5646




 





 





 





 





 





 



 B A string containing the perl-code definition that makes that data structure. 




5647




 





 





 





 





 





 



 The input reference (first input argument) can be to an array, hash or a string. 




5648




 





 





 





 





 





 



 Those can contain other refs and strings in a deep data structure. 




5649




 





 





 





 





 





 



   




5650




 





 





 





 





 





 



 Limitations: 




5651




 





 





 





 





 





 



   




5652




 





 





 





 





 





 



 - Code refs are not handled (just returns C) 




5653




 





 





 





 





 





 



   




5654




 





 





 





 





 





 



 - Regex, class refs and circular recursive structures are also not handled. 




5655




 





 





 





 





 





 



   




5656




 





 





 





 





 





 



 B 




5657




 





 





 





 





 





 



   




5658




 





 





 





 





 





 



   $a = 'test'; 




5659




 





 





 





 





 





 



   @b = (1,2,3); 




5660




 





 





 





 





 





 



   %c = (1=>2, 2=>3, 3=>5, 4=>7, 5=>11); 




5661




 





 





 





 





 





 



   %d = (1=>2, 2=>3, 3=>\5, 4=>7, 5=>11, 6=>[13,17,19,{1,2,3,'asdf\'\\\''}],7=>'x'); 




5662




 





 





 





 





 





 



   print serialize(\$a,'a'); 




5663




 





 





 





 





 





 



   print serialize(\@b,'tab'); 




5664




 





 





 





 





 





 



   print serialize(\%c,'c'); 




5665




 





 





 





 





 





 



   print serialize(\%d,'d'); 




5666




 





 





 





 





 





 



   print serialize(\("test'n roll",'brb "brb"')); 




5667




 





 





 





 





 





 



   print serialize(\%d,'d',undef,1); 




5668




 





 





 





 





 





 



   




5669




 





 





 





 





 





 



 Prints accordingly: 




5670




 





 





 





 





 





 



   




5671




 





 





 





 





 





 



  $a='test'; 




5672




 





 





 





 





 





 



  @tab=('1','2','3'); 




5673




 





 





 





 





 





 



  %c=('1','2','2','3','3','5','4','7','5','11'); 




5674




 





 





 





 





 





 



  %d=('1'=>'2','2'=>'3','3'=>\'5','4'=>'7','5'=>'11','6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}]); 




5675




 





 





 





 





 





 



  ('test\'n roll','brb "brb"'); 




5676




 





 





 





 





 





 



  %d=('1'=>'2', 




5677




 





 





 





 





 





 



  '2'=>'3', 




5678




 





 





 





 





 





 



  '3'=>\'5', 




5679




 





 





 





 





 





 



  '4'=>'7', 




5680




 





 





 





 





 





 



  '5'=>'11', 




5681




 





 





 





 





 





 



  '6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}], 




5682




 





 





 





 





 





 



  '7'=>'x'); 




5683




 





 





 





 





 





 



   




5684




 





 





 





 





 





 



 Areas of use: 




5685




 





 





 





 





 





 



   




5686




 





 





 





 





 





 



 - Debugging (first and foremost) 




5687




 





 





 





 





 





 



   




5688




 





 





 





 





 





 



 - Storing arrays and hashes and data structures of those on file, database or sending them over the net 




5689




 





 





 





 





 





 



   




5690




 





 





 





 





 





 



 - eval earlier stored string to get back the data structure 




5691




 





 





 





 





 





 



   




5692




 





 





 





 





 





 



 Be aware of the security implications of Cing a perl code string 




5693




 





 





 





 





 





 



 stored somewhere that unauthorized users can change them! You are 




5694




 





 





 





 





 





 



 probably better of using L or L without 




5695




 





 





 





 





 





 



 enabling the CODE-options if you have such security issues. 




5696




 





 





 





 





 





 



 More on decompiling Perl-code: L or L. 




5697




 





 





 





 





 





 



   




5698




 





 





 





 





 





 



 =head2 dserialize 




5699




 





 





 





 





 





 



   




5700




 





 





 





 





 





 



 Debug-serialize, dumping data structures for you to look at. 




5701




 





 





 





 





 





 



   




5702




 





 





 





 





 





 



 Same as C but the output is given a newline every 80th character. 




5703




 





 





 





 





 





 



 (Every 80th or whatever C<$Acme::Tools::Dserialize_width> contains) 




5704




 





 





 





 





 





 



   




5705




 





 





 





 





 





 



 =cut 




5706




 





 





 





 





 





 



   




5707




 





 





 





 





 





 



 our $Dserialize_width=80; 




5708



  
0
  




 




  
  0
  



  
0
  




 





0



 sub _kallstack { my $tilbake=shift||0; my @c; my $ret; $ret.=serialize(\@c,"caller$tilbake") while @c=caller(++$tilbake); $ret } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5709



  
0
  




 





 




  
0
  



  
1
  




0



 sub dserialize{join "\n",serialize(@_)=~/(.{1,$Dserialize_width})/gs} 




5710




 





 





 





 





 





 



 sub serialize { 




5711




28





 





 




  
28
  




 





150



   no warnings; 




 




28





 





 





 





 





48



   




 




28





 





 





 





 





127928



   




5712




1127





 





 




  
1127
  



  
1
  




4775



   my($r,$name,$filename,$level)=@_; 




5713




1127





 




  
100
  




 





 





3033



   my @r=(undef,undef,($level||0)-1); 




5714




1127




  
 50
  




 





 





 





2122



   if($filename){ 




5715



  
0
  



  
  0
  




 





 





 





0



     open my $fh, '>', $filename or croak("FEIL: could not open file $filename\n" . _kallstack()); 




5716



  
0
  




 





 





 





 





0



     my $ret=serialize($r,$name,undef,$level); 




5717



  
0
  




 





 





 





 





0



     print $fh "$ret\n1;\n"; 




5718



  
0
  




 





 





 





 





0



     close($fh); 




5719



  
0
  




 





 





 





 





0



     return $ret; 




5720




 





 





 





 





 





 



   } 




5721




1127




  
100
  




 





 





 





2884



   if(ref($r) eq 'SCALAR'){ 




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




5722




903




  
 50
  




 





 





 





1580



     return "\$$name=".serialize($r,@r).";\n" if $name; 




5723




903




  
100
  




 





 





 





1692



     return "undef" unless defined $$r; 




5724




899





 





 





 





 





1128



     my $ret=$$r; 




5725




899





 





 





 





 





1410



     $ret=~s/\\/\\\\/g; 




5726




899





 





 





 





 





1140



     $ret=~s/\'/\\'/g; 




5727




899





 





 





 





 





2785



     return "'$ret'"; 




5728




 





 





 





 





 





 



   } 




5729




 





 





 





 





 





 



   elsif(ref($r) eq 'ARRAY'){ 




5730




72




  
100
  




 





 





 





163



     return "\@$name=".serialize($r,@r).";\n" if $name; 




5731




70





 





 





 





 





99



     my $ret="("; 




5732




70





 





 





 





 





134



     for(@$r){ 




5733




350





 





 





 





 





819



       $ret.=serialize(\$_,@r).","; 




5734




350




  
100
  




 





 





 





1019



       $ret.="\n" if $level>=0; 




5735




 





 





 





 





 





 



     } 




5736




70





 





 





 





 





237



     $ret=~s/,$//; 




5737




70





 





 





 





 





131



     $ret.=")"; 




5738




70




  
 50
  




 





 





 





144



     $ret.=";\n" if $name; 




5739




70





 





 





 





 





235



     return $ret; 




5740




 





 





 





 





 





 



   } 




5741




 





 





 





 





 





 



   elsif(ref($r) eq 'HASH'){ 




5742




31




  
100
  




 





 





 





250



     return "\%$name=".serialize($r,@r).";\n" if $name; 




5743




21





 





 





 





 





37



     my $ret="("; 




5744




21





 





 





 





 





105



     for(sort keys %$r){ 




5745




73





 





 





 





 





193



       $ret.=serialize(\$_,@r)."=>".serialize(\$$r{$_},@r).","; 




5746




73




  
 50
  




 





 





 





234



       $ret.="\n" if $level>=0; 




5747




 





 





 





 





 





 



     } 




5748




21





 





 





 





 





84



     $ret=~s/,$//; 




5749




21





 





 





 





 





33



     $ret.=")"; 




5750




21




  
 50
  




 





 





 





55



     $ret.=";\n" if $name; 




5751




21





 





 





 





 





132



     return $ret; 




5752




 





 





 





 





 





 



   } 




5753




 





 





 





 





 





 



   elsif(ref($$r) eq 'ARRAY'){ 




5754




48




  
 50
  




 





 





 





92



     return "\@$name=".serialize($r,@r).";\n" if $name; 




5755




48





 





 





 





 





63



     my $ret="["; 




5756




48





 





 





 





 





89



     for(@$$r){ 




5757




100





 





 





 





 





555



       $ret.=serialize(\$_,@r).","; 




5758




100




  
 50
  



  
 33
  




 





 





487



       $ret.="\n" if !defined $level or $level>=0; 




5759




 





 





 





 





 





 



     } 




5760




48





 





 





 





 





133



     $ret=~s/,$//; 




5761




48





 





 





 





 





67



     $ret.="]"; 




5762




48




  
 50
  




 





 





 





89



     $ret.=";\n" if $name; 




5763




48





 





 





 





 





132



     return $ret; 




5764




 





 





 





 





 





 



   } 




5765




 





 





 





 





 





 



   elsif(ref($$r) eq 'HASH'){ 




5766




73




  
 50
  




 





 





 





138



     return "\%$name=".serialize($r,@r).";\n" if $name; 




5767




73





 





 





 





 





107



     my $ret="{"; 




5768




73





 





 





 





 





268



     for(sort keys %$$r){ 




5769




214





 





 





 





 





412



       $ret.=serialize(\$_,@r)."=>".serialize(\$$$r{$_},@r).","; 




5770




214




  
 50
  




 





 





 





598



       $ret.="\n" if $level>=0; 




5771




 





 





 





 





 





 



     } 




5772




73





 





 





 





 





211



     $ret=~s/,$//; 




5773




73





 





 





 





 





93



     $ret.="}"; 




5774




73




  
 50
  




 





 





 





133



     $ret.=";\n" if $name; 




5775




73





 





 





 





 





208



     return $ret; 




5776




 





 





 





 





 





 



   } 




5777




 





 





 





 





 





 



   elsif(ref($$r) eq 'SCALAR'){ 




5778



  
0
  




 





 





 





 





0



     return "\\".serialize($$r,@r); 




5779




 





 





 





 





 





 



   } 




5780




 





 





 





 





 





 



   elsif(ref($r) eq 'LVALUE'){ 




5781



  
0
  




 





 





 





 





0



     my $s="$$r"; 




5782



  
0
  




 





 





 





 





0



     return serialize(\$s,@r); 




5783




 





 





 





 





 





 



   } 




5784




 





 





 





 





 





 



   elsif(ref($$r) eq 'CODE'){ 




5785




 





 





 





 





 





 



     #warn "Tried to serialize CODE"; 




5786



  
0
  




 





 





 





 





0



     return 'sub{croak "Can not serialize CODE-references, see perhaps B::Deparse and Storable"}' 




5787




 





 





 





 





 





 



   } 




5788




 





 





 





 





 





 



   elsif(ref($$r) eq 'GLOB'){ 




5789



  
0
  




 





 





 





 





0



     warn "Tried to serialize a GLOB"; 




5790



  
0
  




 





 





 





 





0



     return '\*STDERR' 




5791




 





 





 





 





 





 



   } 




5792




 





 





 





 





 





 



   else{ 




5793



  
0
  




 





 





 





 





0



     my $tilbake; 




5794



  
0
  




 





 





 





 





0



     my($pakke,$fil,$linje,$sub,$hasargs,$wantarray); 




5795



  
0
  




 




  
  0
  




 





 





0



       ($pakke,$fil,$linje,$sub,$hasargs,$wantarray)=caller($tilbake++) until $sub ne 'serialize' || $tilbake>20; 




5796



  
0
  




 





 





 





 





0



     croak("serialize() argument should be reference!\n". 




5797




 





 





 





 





 





 



         "\$r=$r\n". 




5798




 





 





 





 





 





 



         "ref(\$r)   = ".ref($r)."\n". 




5799




 





 





 





 





 





 



         "ref(\$\$r) = ".ref($$r)."\n". 




5800




 





 





 





 





 





 



         "kallstack:\n". _kallstack()); 




5801




 





 





 





 





 





 



   } 




5802




 





 





 





 





 





 



 } 




5803




 





 





 





 





 





 



   




5804




 





 





 





 





 





 



 =head2 srlz 




5805




 





 





 





 





 





 



   




5806




 





 





 





 





 





 



 Synonym to L, but remove unnecessary single quote chars around 




5807




 





 





 





 





 





 



 C<< \w+ >>-keys and number values (except numbers with leading zeros). Example: 




5808




 





 





 





 





 





 



   




5809




 





 





 





 





 





 



 serialize: 




5810




 





 





 





 





 





 



   




5811




 





 





 





 





 





 



  %s=('action'=>{'del'=>'0','ins'=>'0','upd'=>'18'},'post'=>'1348','pre'=>'1348', 




5812




 





 





 





 





 





 



      'updcol'=>{'Laerestednr'=>'18','Studietypenr'=>'18','Undervisningssted'=>'7','Url'=>'11'}, 




5813




 





 





 





 





 





 



      'where'=>'where 1=1'); 




5814




 





 





 





 





 





 



   




5815




 





 





 





 





 





 



 srlz: 




5816




 





 





 





 





 





 



   




5817




 





 





 





 





 





 



  %s=(action=>{del=>0,ins=>0,upd=>18},post=>1348,pre=>1348, 




5818




 





 





 





 





 





 



      updcol=>{Laerestednr=>18,Studietypenr=>18,Undervisningssted=>7,Url=>11}, 




5819




 





 





 





 





 





 



      where=>'where 1=1'); 




5820




 





 





 





 





 





 



   




5821




 





 





 





 





 





 



 Todo: update L to do the same, but in the right way. (For now  




5822




 





 





 





 





 





 



 srlz runs the string from serialize() through two C<< s/// >>, this will break 




5823




 





 





 





 





 





 



 in certain cases). L will be kept as a synonym (or the other way around). 




5824




 





 





 





 





 





 



   




5825




 





 





 





 





 





 



 =cut 




5826




 





 





 





 





 





 



   




5827




 





 





 





 





 





 



 sub srlz { 




5828



  
0
  




 





 




  
0
  



  
1
  




0



   my $s=serialize(@_); 




5829



  
0
  




 





 





 





 





0



   $s=~s,'(\w+)'=>,$1=>,g; 




5830



  
0
  




 





 





 





 





0



   $s=~s,=>'((0|[1-9]\d*)(\.\d+)?(e[-+]?\d+)?)',=>$1,gi;  #ikke ledende null!    hm                                                                                                                                           




5831



  
0
  




 





 





 





 





0



   $s; 




5832




 





 





 





 





 





 



 } 




5833




 





 





 





 





 





 



   




5834




 





 





 





 





 





 



   




5835




 





 





 





 





 





 



 =head2 sys 




5836




 





 





 





 





 





 



   




5837




 





 





 





 





 





 



 Call instead of C if you want C (Carp::croak) when something fails. 




5838




 





 





 





 





 





 



   




5839




 





 





 





 





 





 



  sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" } 




5840




 





 





 





 





 





 



   




5841




 





 





 





 





 





 



   




5842




 





 





 





 





 





 



 =cut 




5843




 





 





 





 





 





 



   




5844



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5845




 





 





 





 





 





 



   




5846




 





 





 





 





 





 



 =head2 recursed 




5847




 





 





 





 





 





 



   




5848




 





 





 





 





 





 



 Returns true or false (actually 1 or 0) depending on whether the 




5849




 





 





 





 





 





 



 current sub has been called by itself or not. 




5850




 





 





 





 





 





 



   




5851




 





 





 





 





 





 



  sub xyz 




5852




 





 





 





 





 





 



  { 




5853




 





 





 





 





 





 



     xyz() if not recursed; 




5854




 





 





 





 





 





 



   




5855




 





 





 





 





 





 



  } 




5856




 





 





 





 





 





 



   




5857




 





 





 





 





 





 



 =cut 




5858




 





 





 





 





 





 



   




5859



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub recursed {(caller(1))[3] eq (caller(2))[3]?1:0} 




5860




 





 





 





 





 





 



   




5861




 





 





 





 





 





 



 =head2 ed 




5862




 





 





 





 





 





 



   




5863




 





 





 





 





 





 



 String editor commands 




5864




 





 





 





 





 





 



   




5865




 





 





 





 





 





 



  literals:               a-z 0-9 space 




5866




 





 





 





 





 





 



  move cursor:            FBAEPN MF MB ME 




5867




 





 





 





 





 





 



  delete:                 D Md 




5868




 





 





 





 





 





 



  up/low/camelcase word   U L C 




5869




 





 





 





 





 





 



  backspace:              - 




5870




 





 





 





 





 





 



  search:                 S 




5871




 





 





 





 





 





 



  return/enter:           R 




5872




 





 





 





 





 





 



  meta/esc/alt:           M 




5873




 





 





 





 





 





 



  shift:                  T 




5874




 





 





 





 





 





 



  cut to eol:             K 




5875




 





 





 





 





 





 



  caps lock:              C 




5876




 





 





 





 





 





 



  yank:                   Y 




5877




 





 





 





 





 





 



  start and end:          < > 




5878




 





 





 





 





 





 



  macro start/end/play:   { } ! 




5879




 





 





 





 





 





 



  times for next cmd:     M  (i.e. M24a inserts 24 a's) 




5880




 





 





 





 





 





 



   




5881




 





 





 





 





 





 



 (TODO: alfa...and more docs needed) 




5882




 





 





 





 





 





 



   




5883




 





 





 





 





 





 



 =cut 




5884




 





 





 





 





 





 



   




5885




 





 





 





 





 





 



 our $Edcursor; 




5886




 





 





 





 





 





 



 sub ed { 




5887




18





 





 




  
18
  



  
1
  




4351



   my($s,$cs,$p,$buf)=@_; #string, commands, point (or cursor) 




5888




18




  
100
  




 





 





 





58



   return $$s=ed($$s,$cs,$p,$buf) if ref($s); 




5889




17





 





 





 





 





33



   my($sh,$cl,$m,$t,@m)=(0,0,0,undef); 




5890




17





 





 





 





 





37



   while(length($cs)){ 




5891




121





 





 





 





 





148



     my $n = 0; 




5892




121




  
 50
  




 





 





 





489



     my $c = $cs=~s,^(M\d+|M.|""|".+?"|S.+?R|\\.|.),,s ? $1 : die; 




5893




121





 




  
100
  




 





 





402



     $p = curb($p||0,0,length($s)); 




5894




121




  
100
  




 





 





 





234



     if(defined$t){$cs="".($c x $t).$cs;$t=undef;next} 




 




1





 





 





 





 





5



   




 




1





 





 





 





 





2



   




 




1





 





 





 





 





3



   




5895




120





 





 




  
81
  




 





375



     my $add=sub{substr($s,$p,0)=$_[0];$p+=length($_[0])}; 




 




81





 





 





 





 





141



   




 




81





 





 





 





 





144



   




5896




120




  
 50
  




 





 





 





821



     if   ($c =~ /^([a-z0-9 ])/){ &$add($sh^$cl?uc($1):$1); $sh=0 } 




 




65




  
100
  




 





 





 





208



   




 




65




  
100
  




 





 





 





80



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




5897




1





 





 





 





 





3



     elsif($c =~ /^"(.+)"$/)    { &$add($1) } 




5898




1





 





 





 





 





4



     elsif($c =~ /^\\(.)/)      { &$add($1) } 




5899




2




  
 50
  




 





 





 





6



     elsif($c =~ /^S(.+)R/)     { my $i=index($s,$1,$p);$p=$i+length($1) if $i>=0 } 




 




2





 





 





 





 





8



   




5900




1





 





 





 





 





3



     elsif($c =~ /^M(\d+)/)     { $t=$1; next } 




 




1





 





 





 





 





6



   




5901




2





 





 





 





 





3



     elsif($c eq 'F') { $p++ } 




5902




1





 





 





 





 





2



     elsif($c eq 'B') { $p-- } 




5903



  
0
  




 




  
  0
  




 





 





0



     elsif($c eq 'A') { $p-- while $p>0 and substr($s,$p-1,2)!~/^\n/ } 




5904




8




  
 50
  




 





 





 





39



     elsif($c eq 'E') { substr($s,$p)=~/(.*)/ and $p+=length($1) } 




5905




4





 





 





 





 





5



     elsif($c eq 'D') { substr($s,$p,1)='' } 




5906




3




  
 50
  




 





 





 





21



     elsif($c eq 'MD'){ substr($s,$p)=~s/^(\W*\w+)// and $buf=$1 } 




5907




3




  
 50
  




 





 





 





17



     elsif($c eq 'MF'){ substr($s,$p)=~/(\W*\w+)/ and $p+=length($1) } 




5908




3




  
 50
  




 





 





 





19



     elsif($c eq 'MB'){ substr($s,0,$p)=~/(\w+\W*)$/ and $p-=length($1) } 




5909



  
0
  



  
  0
  




 





 





 





0



     elsif($c eq '-') { substr($s,--$p,1)='' if $p } 




5910




5




  
 50
  




 





 





 





37



     elsif($c eq 'M-'){ substr($s,0,$p)=~s/(\w+\W*)$// and $p-=length($buf=$1)} 




5911




3




  
 50
  




 





 





 





19



     elsif($c eq 'K') { substr($s,$p)=~s/(\S.+|\s*?\n)// and $buf=$1 } 




5912




12





 





 





 





 





26



     elsif($c eq 'Y') { &$add($buf) } 




5913



  
0
  




 





 





 





 





0



     elsif($c eq 'U') { substr($s,$p)=~s/(\W*)(\w+)/$1\U$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5914



  
0
  




 





 





 





 





0



     elsif($c eq 'L') { substr($s,$p)=~s/(\W*)(\w+)/$1\L$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5915



  
0
  




 





 





 





 





0



     elsif($c eq 'C') { substr($s,$p)=~s/(\W*)(\w+)/$1\u\L$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5916



  
0
  




 





 





 





 





0



     elsif($c eq '<') { $p=0 } 




5917



  
0
  




 





 





 





 





0



     elsif($c eq '>') { $p=length($s) } 




5918



  
0
  




 





 





 





 





0



     elsif($c eq 'T') { $sh=1 } 




5919



  
0
  




 





 





 





 





0



     elsif($c eq 'C') { $cl^=1 } 




5920




1





 





 





 





 





2



     elsif($c eq '{') { $m=1; @m=() } 




 




1





 





 





 





 





2



   




5921




1





 





 





 





 





2



     elsif($c eq '}') { $m=0 } 




5922




2




  
 50
  



  
 33
  




 





 





20



     elsif($c eq '!') { $m||!@m and die"ed: no macro"; $cs=join("",@m).$cs } 




 




2





 





 





 





 





5



   




5923




2





 





 





 





 





5



     elsif($c eq '""'){ &$add('"') } 




5924



  
0
  




 





 





 





 





0



     else             { croak "ed: Unknown cmd '$c'\n" } 




5925




119




  
100
  



  
100
  




 





 





578



     push @m, $c if $m and $c ne '{'; 




5926




 





 





 





 





 





 



     #warn serialize([$c,$m,$cs],'d'); 




5927




 





 





 





 





 





 



   } 




5928




17





 





 





 





 





20



   $Edcursor=$p; 




5929




17





 





 





 





 





50



   $s; 




5930




 





 





 





 





 





 



 } 




5931




 





 





 





 





 





 



   




5932




 





 





 





 





 





 



   




5933




 





 





 





 





 





 



 #todo: sub unbless eller sub damn 




5934




 





 





 





 





 





 



 #todo: ..se også: use Data::Structure::Util qw/unbless/; 




5935




 





 





 





 





 





 



 #todo: ...og: Acme::Damn sin damn() 




5936




 





 





 





 





 





 



 #todo? sub swap($$) http://www.idg.no/computerworld/article242008.ece 




5937




 





 





 





 





 





 



 #todo? catal 




5938




 





 





 





 





 





 



 #todo?  




5939




 





 





 





 





 





 



 #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); 




5940




 





 





 





 





 





 



   




5941




 





 





 





 





 





 



   




5942




 





 





 





 





 





 



 =head1 JUST FOR FUN 




5943




 





 





 





 





 





 



   




5944




 





 





 





 





 





 



 =head2 brainfu 




5945




 





 





 





 





 





 



   




5946




 





 





 





 





 





 



 B one or two arguments 




5947




 





 





 





 





 





 



   




5948




 





 





 





 





 





 



 First argument: a string, source code of the brainfu 




5949




 





 





 





 





 





 



 language. String containing the eight charachters + - < > [ ] . , 




5950




 





 





 





 





 





 



 Every other char is ignored silently. 




5951




 





 





 





 





 





 



   




5952




 





 





 





 





 





 



 Second argument: if the source code contains commas (,) the second 




5953




 





 





 





 





 





 



 argument is the input characters in a string. 




5954




 





 





 





 





 





 



   




5955




 





 





 





 





 





 



 B The resulting output from the program. 




5956




 





 





 





 





 





 



   




5957




 





 





 





 





 





 



 Example: 




5958




 





 





 





 





 





 



   




5959




 





 





 





 





 





 



  print brainfu(<<"");  #prints "Hallo Verden!\n" 




5960




 





 





 





 





 





 



  ++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>---.+++++++++++..+++.>++.<<++++++++++++++ 




5961




 





 





 





 





 





 



  .>----------.+++++++++++++.--------------.+.+++++++++.>+.>. 




5962




 





 





 





 





 





 



   




5963




 





 





 





 





 





 



 See L 




5964




 





 





 





 





 





 



   




5965




 





 





 





 





 





 



 =head2 brainfu2perl 




5966




 





 





 





 





 





 



   




5967




 





 





 





 





 





 



 Just as L but instead it return the perl code to which the 




5968




 





 





 





 





 





 



 brainfu code is translated. Just C<< eval() >> this perl code to run. 




5969




 





 





 





 





 





 



   




5970




 





 





 





 





 





 



 Example: 




5971




 





 





 





 





 





 



   




5972




 





 





 





 





 





 



  print brainfu2perl('>++++++++[<++++++++>-]<++++++++.>++++++[<++++++>-]<---.'); 




5973




 





 





 





 





 





 



   




5974




 





 





 





 





 





 



 Prints this string: 




5975




 





 





 





 





 





 



   




5976




 





 





 





 





 





 



  my($c,$o,@b)=(0); sub out{$o.=chr($b[$c]) for 1..$_[0]||1} 




5977




 





 





 





 





 





 



  ++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5978




 





 





 





 





 





 



  while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5979




 





 





 





 





 





 



  ++$b[$c];++$c;--$b[$c];}--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5980




 





 





 





 





 





 



  ++$b[$c];++$b[$c];out;++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5981




 





 





 





 





 





 



  while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$c;--$b[$c];} 




5982




 





 





 





 





 





 



  --$c;--$b[$c];--$b[$c];--$b[$c];out;$o; 




5983




 





 





 





 





 





 



   




5984




 





 





 





 





 





 



 =head2 brainfu2perl_optimized 




5985




 





 





 





 





 





 



   




5986




 





 





 





 





 





 



 Just as L but optimizes the perl code. The same 




5987




 





 





 





 





 





 



 example as above with brainfu2perl_optimized returns this equivalent 




5988




 





 





 





 





 





 



 but shorter perl code: 




5989




 





 





 





 





 





 



   




5990




 





 





 





 





 





 



  $b[++$c]+=8;while($b[$c]){$b[--$c]+=8;--$b[++$c]}$b[--$c]+=8;out;$b[++$c]+=6; 




5991




 





 





 





 





 





 



  while($b[$c]){$b[--$c]+=6;--$b[++$c]}$b[--$c]-=3;out;$o; 




5992




 





 





 





 





 





 



   




5993




 





 





 





 





 





 



 =cut 




5994




 





 





 





 





 





 



   




5995




3





 





 




  
3
  



  
1
  




691



 sub brainfu { eval(brainfu2perl(@_)) } 




5996




 





 





 





 





 





 



   




5997




 





 





 





 





 





 



 sub brainfu2perl { 




5998




6





 





 




  
6
  



  
1
  




21



   my($bf,$inp)=@_; 




5999




17





 





 





 





 





76



   my $perl='my($c,$inp,$o,@b)=(0,\''.$inp.'\'); no warnings; sub out{$o.=chr($b[$c]) for 1..$_[0]||1}'."\n"; 




6000




3




  
100
  



  
 66
  




 





 





22



   $perl.='sub inp{$inp=~s/(.)//s and $b[$c]=ord($1)}'."\n" if $inp and $bf=~/,/; 




6001




3




  
100
  




 





 





 





918



   $perl.=join("",map/\+/?'++$b[$c];':/\-/?'--$b[$c];':/\[/?'while($b[$c]){':/\]/?'}':/>/?'++$c;':/




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




6002




3





 





 





 





 





309



   $perl; 




6003




 





 





 





 





 





 



 } 




6004




 





 





 





 





 





 



   




6005




 





 





 





 





 





 



 sub brainfu2perl_optimized { 




6006



  
0
  




 





 




  
14
  



  
1
  




0



   my $perl=brainfu2perl(@_); 




6007



  
0
  




 





 





 





 





0



   $perl=~s{(((\+|\-)\3\$b\[\$c\];){2,})}{ '$b[$c]'.$3.'='.(grep/b/,split//,$1).';' }gisex; 




 



  
0
  




 





 





 





 





0



   




6008



  
0
  




 





 





 





 





0



   1 while $perl=~s/\+\+\$c;\-\-\$c;//g + $perl=~s/\-\-\$c;\+\+\$c;//g; 




6009



  
0
  




 





 





 





 





0



   $perl=~s{((([\-\+])\3\$c;){2,})}{"\$c$3=".(grep/c/,split//,$1).';'}gisex; 




 



  
0
  




 





 





 





 





0



   




6010



  
0
  



  
  0
  




 





 





 





0



   $perl=~s{((\+\+|\-\-)\$c;([^;{}]+;))}{my($o,$s)=($2,$3);$s=~s/\$c/$o\$c/?$s:$1}ge; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6011



  
0
  




 





 





 





 





0



   $perl=~s/\$c(\-|\+)=(\d+);(\+\+|\-\-)\$b\[\$c\]/$3.'$b[$c'.$1.'='.$2.'];'/ge; 




 



  
0
  




 





 





 





 





0



   




6012



  
0
  




 





 





 





 





0



   $perl=~s{((out;){2,})}{'out('.(grep/o/,split//,$1).');'}ge; 




 



  
0
  




 





 





 





 





0



   




6013



  
0
  




 





 





 





 





0



   $perl=~s/;}/}/g;$perl=~s/;+/;/g; 




 



  
0
  




 





 





 





 





0



   




6014



  
0
  




 





 





 





 





0



   $perl; 




6015




 





 





 





 





 





 



 } 




6016




 





 





 





 





 





 



   




6017




 





 





 





 





 





 



   




6018




 





 





 





 





 





 



 =head1 BLOOM FILTER SUBROUTINES 




6019




 





 





 





 





 





 



   




6020




 





 





 





 





 





 



 Bloom filters can be used to check whether an element (a string) is a 




6021




 





 





 





 





 





 



 member of a large set using much less memory or disk space than other 




6022




 





 





 





 





 





 



 data structures. Trading speed and accuracy for memory usage. While 




6023




 





 





 





 





 





 



 risking false positives, Bloom filters have a very strong space 




6024




 





 





 





 





 





 



 advantage over other data structures for representing sets. 




6025




 





 





 





 





 





 



   




6026




 





 





 





 





 





 



 In the example below, a set of 100000 phone numbers (or any string of 




6027




 





 





 





 





 





 



 any length) can be "stored" in just 91230 bytes if you accept that you 




6028




 





 





 





 





 





 



 can only check the data structure for existence of a string and accept 




6029




 





 





 





 





 





 



 false positives with an error rate of 0.03 (that is three percent, error 




6030




 





 





 





 





 





 



 rates are given in numbers larger than 0 and smaller than 1). 




6031




 





 





 





 





 





 



   




6032




 





 





 





 





 





 



 You can not retrieve the strings in the set without using "brute 




6033




 





 





 





 





 





 



 force" methods and even then you would get slightly more strings than 




6034




 





 





 





 





 





 



 you put in because of the error rate inaccuracy. 




6035




 





 





 





 





 





 



   




6036




 





 





 





 





 





 



 Bloom Filters have many uses. 




6037




 





 





 





 





 





 



   




6038




 





 





 





 





 





 



 See also: L 




6039




 





 





 





 





 





 



   




6040




 





 





 





 





 





 



 See also: L 




6041




 





 





 





 





 





 



   




6042




 





 





 





 





 





 



 =head2 bfinit 




6043




 





 





 





 





 





 



   




6044




 





 





 





 





 





 



 Initialize a new Bloom Filter: 




6045




 





 





 





 





 





 



   




6046




 





 





 





 





 





 



   my $bf = bfinit( error_rate=>0.01, capacity=>100000 ); 




6047




 





 





 





 





 





 



   




6048




 





 





 





 





 





 



 The same: 




6049




 





 





 





 





 





 



   




6050




 





 





 





 





 





 



   my $bf = bfinit( 0.01, 100000 ); 




6051




 





 





 





 





 





 



   




6052




 





 





 





 





 





 



 since two arguments is interpreted as error_rate and capacity accordingly. 




6053




 





 





 





 





 





 



   




6054




 





 





 





 





 





 



   




6055




 





 





 





 





 





 



 =head2 bfadd 




6056




 





 





 





 





 





 



   




6057




 





 





 





 





 





 



   bfadd($bf, $_) for @phone_numbers;   # Adding strings one at a time 




6058




 





 





 





 





 





 



   




6059




 





 





 





 





 





 



   bfadd($bf, @phone_numbers);          # ...or all at once (faster) 




6060




 





 





 





 





 





 



   




6061




 





 





 





 





 





 



 Returns 1 on success. Dies (croaks) if more strings than capacity is added. 




6062




 





 





 





 





 





 



   




6063




 





 





 





 





 





 



 =head2 bfcheck 




6064




 





 





 





 





 





 



   




6065




 





 





 





 





 





 



   my $phone_number="97713246"; 




6066




 





 





 





 





 





 



   if ( bfcheck($bf, $phone_number) ) { 




6067




 





 





 





 





 





 



     print "Yes, $phone_number was PROBABLY added\n"; 




6068




 





 





 





 





 





 



   } 




6069




 





 





 





 





 





 



   else{ 




6070




 





 





 





 





 





 



     print "No, $phone_number was DEFINITELY NOT added\n"; 




6071




 





 





 





 





 





 



   } 




6072




 





 





 





 





 





 



   




6073




 





 





 





 





 





 



 Returns true if C<$phone_number> exists in C<@phone_numbers>. 




6074




 





 





 





 





 





 



   




6075




 





 





 





 





 





 



 Returns false most of the times, but sometimes true*), if C<$phone_number> doesn't exists in C<@phone_numbers>. 




6076




 





 





 





 





 





 



   




6077




 





 





 





 





 





 



 *) This is called a false positive. 




6078




 





 





 





 





 





 



   




6079




 





 





 





 





 





 



 Checking more than one key: 




6080




 





 





 





 





 





 



   




6081




 





 





 





 





 





 



  @bools = bfcheck($bf, @keys);          # or ... 




6082




 





 





 





 





 





 



  @bools = bfcheck($bf, \@keys);         # better, uses less memory if @keys is large 




6083




 





 





 





 





 





 



   




6084




 





 





 





 





 





 



 Returns an array the same size as @keys where each element is true or false accordingly. 




6085




 





 





 





 





 





 



   




6086




 





 





 





 





 





 



 =head2 bfgrep 




6087




 





 





 





 





 





 



   




6088




 





 





 





 





 





 



 Same as C except it returns the keys that exists in the bloom filter 




6089




 





 





 





 





 





 



   




6090




 





 





 





 





 





 



  @found = bfgrep($bf, @keys);           # or ... 




6091




 





 





 





 





 





 



  @found = bfgrep($bf, \@keys);          # better, uses less memory if @keys is large, or ... 




6092




 





 





 





 





 





 



  @found = grep bfcheck($bf,$_), @keys;  # same but slower 




6093




 





 





 





 





 





 



   




6094




 





 





 





 





 





 



 =head2 bfgrepnot 




6095




 





 





 





 





 





 



   




6096




 





 





 





 





 





 



 Same as C except it returns the keys that do NOT exists in the bloom filter: 




6097




 





 





 





 





 





 



   




6098




 





 





 





 





 





 



  @not_found = bfgrepnot($bf, @keys);          # or ... 




6099




 





 





 





 





 





 



  @not_found = bfgrepnot($bf, \@keys);         # better, uses less memory if @keys is large, or ... 




6100




 





 





 





 





 





 



  @not_found = grep !bfcheck($bf,$_), @keys);  # same but slower 




6101




 





 





 





 





 





 



   




6102




 





 





 





 





 





 



 =head2 bfdelete 




6103




 





 





 





 





 





 



   




6104




 





 





 





 





 





 



 Deletes from a counting bloom filter. 




6105




 





 





 





 





 





 



   




6106




 





 





 





 





 





 



 To enable deleting be sure to initialize the bloom filter with the 




6107




 





 





 





 





 





 



 numeric C argument. The number of bits could be 2 or 3*) 




6108




 





 





 





 





 





 



 for small filters with a small capacity (a small number of keys), but 




6109




 





 





 





 





 





 



 setting the number to 4 ensures that even very large filters with very 




6110




 





 





 





 





 





 



 small error rates would not overflow. 




6111




 





 





 





 





 





 



   




6112




 





 





 





 





 





 



 *) Acme::Tools do not currently support C<< counting_bits => 3 >> so 4 




6113




 





 





 





 





 





 



 and 8 are the only practical alternatives where 8 is almost always overkill. 




6114




 





 





 





 





 





 



   




6115




 





 





 





 





 





 



  my $bf=bfinit( 




6116




 





 





 





 





 





 



    error_rate    => 0.001, 




6117




 





 





 





 





 





 



    capacity      => 10000000, 




6118




 





 





 





 





 





 



    counting_bits => 4              # power of 2, that is 2, 4, 8, 16 or 32 




6119




 





 





 





 





 





 



  ); 




6120




 





 





 





 





 





 



  bfadd(   $bf, @unique_phone_numbers); 




6121




 





 





 





 





 





 



  bfdelete($bf, @unique_phone_numbers); 




6122




 





 





 





 





 





 



   




6123




 





 





 





 





 





 



 Example: examine the frequency of the counters with 4 bit counters and 4 million keys: 




6124




 





 





 





 





 





 



   




6125




 





 





 





 





 





 



  my $bf=bfinit( error_rate=>0.001, capacity=>4e6, counting_bits=>4 ); 




6126




 





 





 





 





 





 



  bfadd($bf,[1e3*$_+1 .. 1e3*($_+1)]) for 0..4000-1;  # adding 4 million keys one thousand at a time 




6127




 





 





 





 





 





 



  my %c; $c{vec($$bf{filter},$_,$$bf{counting_bits})}++ for 0..$$bf{filterlength}-1; 




6128




 





 





 





 





 





 



  printf "%8d counters = %d\n",$c{$_},$_ for sort{$a<=>$b}keys%c; 




6129




 





 





 





 





 





 



   




6130




 





 





 





 





 





 



 The output: 




6131




 





 





 





 





 





 



   




6132




 





 





 





 





 





 



  28689562 counters = 0 




6133




 





 





 





 





 





 



  19947673 counters = 1 




6134




 





 





 





 





 





 



   6941082 counters = 2 




6135




 





 





 





 





 





 



   1608250 counters = 3 




6136




 





 





 





 





 





 



    280107 counters = 4 




6137




 





 





 





 





 





 



     38859 counters = 5 




6138




 





 





 





 





 





 



      4533 counters = 6 




6139




 





 





 





 





 





 



       445 counters = 7 




6140




 





 





 





 





 





 



        46 counters = 8 




6141




 





 





 





 





 





 



         1 counters = 9 




6142




 





 





 





 





 





 



   




6143




 





 





 





 





 





 



 Even after the error_rate is changed from 0.001 to a percent of that, 0.00001, the limit of 16 (4 bits) is still far away: 




6144




 





 





 





 





 





 



   




6145




 





 





 





 





 





 



  47162242 counters = 0 




6146




 





 





 





 





 





 



  33457237 counters = 1 




6147




 





 





 





 





 





 



  11865217 counters = 2 




6148




 





 





 





 





 





 



   2804447 counters = 3 




6149




 





 





 





 





 





 



    497308 counters = 4 




6150




 





 





 





 





 





 



     70608 counters = 5 




6151




 





 





 





 





 





 



      8359 counters = 6 




6152




 





 





 





 





 





 



       858 counters = 7 




6153




 





 





 





 





 





 



        65 counters = 8 




6154




 





 





 





 





 





 



         4 counters = 9 




6155




 





 





 





 





 





 



   




6156




 





 





 





 





 





 



 In algorithmic terms the number of bits needed is C.  Thats why 4 bits (counters up 




6157




 





 





 





 





 





 



 to 15) is "always" good enough except for extremely large capasities or extremely small error rates. 




6158




 





 





 





 





 





 



 (Except when adding the same key many times, which should be avoided, and Acme::Tools::bfadd do not 




6159




 





 





 





 





 





 



 check for that, perhaps in future versions). 




6160




 





 





 





 





 





 



   




6161




 





 





 





 





 





 



 Bloom filters of the counting type are not very space efficient: The tables above shows that 84%-85% 




6162




 





 





 





 





 





 



 of the counters are 0 or 1. This means most bits are zero-bits. This doesn't have to be a problem if 




6163




 





 





 





 





 





 



 a counting bloom filter is used to be sent over slow networks because they are very compressable by 




6164




 





 





 





 





 





 



 common compression tools like I or L and such. 




6165




 





 





 





 





 





 



   




6166




 





 





 





 





 





 



 Deletion of non-existing keys makes C die (croak). 




6167




 





 





 





 





 





 



   




6168




 





 





 





 





 





 



 =head2 bfdelete 




6169




 





 





 





 





 





 



   




6170




 





 





 





 





 





 



 Deletes from a counting bloom filter: 




6171




 





 





 





 





 





 



   




6172




 





 





 





 





 





 



  bfdelete($bf, @keys); 




6173




 





 





 





 





 





 



  bfdelete($bf, \@keys); 




6174




 





 





 





 





 





 



   




6175




 





 





 





 





 





 



 Returns C<$bf> after deletion. 




6176




 





 





 





 





 





 



   




6177




 





 





 





 





 





 



 Croaks (dies) on deleting a non-existing key or deleting from an previouly overflown counter in a counting bloom filter. 




6178




 





 





 





 





 





 



   




6179




 





 





 





 





 





 



 =head2 bfaddbf 




6180




 





 





 





 





 





 



   




6181




 





 





 





 





 





 



 Adds another bloom filter to a bloom filter. 




6182




 





 





 





 





 





 



   




6183




 





 





 





 





 





 



 Bloom filters has the proberty that bit-wise I-ing the bit-filters 




6184




 





 





 





 





 





 



 of two filters with the same capacity and the same number and type of 




6185




 





 





 





 





 





 



 hash functions, adds the filters: 




6186




 





 





 





 





 





 



   




6187




 





 





 





 





 





 



   my $bf1=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[1..500]); 




6188




 





 





 





 





 





 



   my $bf2=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[501..1000]); 




6189




 





 





 





 





 





 



   




6190




 





 





 





 





 





 



   bfaddbf($bf1,$bf2); 




6191




 





 





 





 





 





 



   




6192




 





 





 





 





 





 



   print "Yes!" if bfgrep($bf1, 1..1000) == 1000; 




6193




 





 





 





 





 





 



   




6194




 





 





 





 





 





 



 Prints yes since C now returns an array of all the 1000 elements. 




6195




 





 





 





 





 





 



   




6196




 





 





 





 





 





 



 Croaks if the filters are of different dimensions. 




6197




 





 





 





 





 





 



   




6198




 





 





 





 





 





 



 Works for counting bloom filters as well (C<< counting_bits=>4 >> e.g.) 




6199




 





 





 





 





 





 



   




6200




 





 





 





 





 





 



 =head2 bfsum 




6201




 





 





 





 





 





 



   




6202




 





 





 





 





 





 



 Returns the number of 1's in the filter. 




6203




 





 





 





 





 





 



   




6204




 





 





 





 





 





 



  my $percent=100*bfsum($bf)/$$bf{filterlength}; 




6205




 





 





 





 





 





 



  printf "The filter is %.1f%% filled\n",$percent; #prints 50.0% or so if filled to capacity 




6206




 





 





 





 





 





 



   




6207




 





 





 





 





 





 



 Sums the counters for counting bloom filters (much slower than for non counting). 




6208




 





 





 





 





 





 



   




6209




 





 





 





 





 





 



 =head2 bfdimensions 




6210




 





 





 





 





 





 



   




6211




 





 





 





 





 





 



 Input, two numeric arguments: Capacity and error_rate. 




6212




 





 





 





 





 





 



   




6213




 





 





 





 





 





 



 Outputs an array of two numbers: m and k. 




6214




 





 





 





 





 





 



   




6215




 





 





 





 





 





 



   m = - n * log(p) / log(2)**2   # n = capacity, m = bits in filter (divide by 8 to get bytes) 




6216




 





 





 





 





 





 



   k = log(1/p) / log(2)          # p = error_rate, uses perls internal log() with base e (2.718) 




6217




 





 





 





 





 





 



   




6218




 





 





 





 





 





 



 ...that is: m = the best number of bits in the filter and k = the best 




6219




 





 





 





 





 





 



 number of hash functions optimized for the given capacity (n) and 




6220




 





 





 





 





 





 



 error_rate (p). Note that k is a dependent only of the error_rate.  At 




6221




 





 





 





 





 





 



 about two percent error rate the bloom filter needs just the same 




6222




 





 





 





 





 





 



 number of bytes as the number of keys. 




6223




 





 





 





 





 





 



   




6224




 





 





 





 





 





 



  Storage (bytes): 




6225




 





 





 





 





 





 



  Capacity      Error-rate  Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate 




6226




 





 





 





 





 





 



                0.000000001 0.00000001 0.0000001  0.000001   0.00001    0.0001     0.001      0.01       0.02141585 0.1        0.5        0.99 




6227




 





 





 





 





 





 



  ------------- ----------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- 




6228




 





 





 





 





 





 



             10 54.48       48.49      42.5       36.51      30.52      24.53      18.53      12.54      10.56      6.553      2.366      0.5886 




6229




 





 





 





 





 





 



            100 539.7       479.8      419.9      360        300.1      240.2      180.3      120.4      100.6      60.47      18.6       0.824 




6230




 





 





 





 





 





 



           1000 5392        4793       4194       3595       2996       2397       1798       1199       1001       599.6      180.9      3.177 




6231




 





 





 





 





 





 



          10000 5.392e+04   4.793e+04  4.194e+04  3.594e+04  2.995e+04  2.396e+04  1.797e+04  1.198e+04  1e+04      5991       1804       26.71 




6232




 





 





 





 





 





 



         100000 5.392e+05   4.793e+05  4.193e+05  3.594e+05  2.995e+05  2.396e+05  1.797e+05  1.198e+05  1e+05      5.991e+04  1.803e+04  262 




6233




 





 





 





 





 





 



        1000000 5.392e+06   4.793e+06  4.193e+06  3.594e+06  2.995e+06  2.396e+06  1.797e+06  1.198e+06  1e+06      5.991e+05  1.803e+05  2615 




6234




 





 





 





 





 





 



       10000000 5.392e+07   4.793e+07  4.193e+07  3.594e+07  2.995e+07  2.396e+07  1.797e+07  1.198e+07  1e+07      5.991e+06  1.803e+06  2.615e+04 




6235




 





 





 





 





 





 



      100000000 5.392e+08   4.793e+08  4.193e+08  3.594e+08  2.995e+08  2.396e+08  1.797e+08  1.198e+08  1e+08      5.991e+07  1.803e+07  2.615e+05 




6236




 





 





 





 





 





 



     1000000000 5.392e+09   4.793e+09  4.193e+09  3.594e+09  2.995e+09  2.396e+09  1.797e+09  1.198e+09  1e+09      5.991e+08  1.803e+08  2.615e+06 




6237




 





 





 





 





 





 



    10000000000 5.392e+10   4.793e+10  4.193e+10  3.594e+10  2.995e+10  2.396e+10  1.797e+10  1.198e+10  1e+10      5.991e+09  1.803e+09  2.615e+07 




6238




 





 





 





 





 





 



   100000000000 5.392e+11   4.793e+11  4.193e+11  3.594e+11  2.995e+11  2.396e+11  1.797e+11  1.198e+11  1e+11      5.991e+10  1.803e+10  2.615e+08 




6239




 





 





 





 





 





 



  1000000000000 5.392e+12   4.793e+12  4.193e+12  3.594e+12  2.995e+12  2.396e+12  1.797e+12  1.198e+12  1e+12      5.991e+11  1.803e+11  2.615e+09 




6240




 





 





 





 





 





 



   




6241




 





 





 





 





 





 



  Error rate:               0.99   Hash functions:  1 




6242




 





 





 





 





 





 



  Error rate:                0.5   Hash functions:  1 




6243




 





 





 





 





 





 



  Error rate:                0.1   Hash functions:  3 




6244




 





 





 





 





 





 



  Error rate: 0.0214158522653385   Hash functions:  6 




6245




 





 





 





 





 





 



  Error rate:               0.01   Hash functions:  7 




6246




 





 





 





 





 





 



  Error rate:              0.001   Hash functions: 10 




6247




 





 





 





 





 





 



  Error rate:             0.0001   Hash functions: 13 




6248




 





 





 





 





 





 



  Error rate:            0.00001   Hash functions: 17 




6249




 





 





 





 





 





 



  Error rate:           0.000001   Hash functions: 20 




6250




 





 





 





 





 





 



  Error rate:          0.0000001   Hash functions: 23 




6251




 





 





 





 





 





 



  Error rate:         0.00000001   Hash functions: 27 




6252




 





 





 





 





 





 



  Error rate:        0.000000001   Hash functions: 30 




6253




 





 





 





 





 





 



   




6254




 





 





 





 





 





 



 =head2 bfstore 




6255




 





 





 





 





 





 



   




6256




 





 





 





 





 





 



 Storing and retrieving bloom filters to and from disk uses Ls C and C. This: 




6257




 





 





 





 





 





 



   




6258




 





 





 





 





 





 



  bfstore($bf,'filename.bf'); 




6259




 





 





 





 





 





 



   




6260




 





 





 





 





 





 



 It the same as: 




6261




 





 





 





 





 





 



   




6262




 





 





 





 





 





 



  use Storable qw(store retrieve); 




6263




 





 





 





 





 





 



  ... 




6264




 





 





 





 





 





 



  store($bf,'filename.bf'); 




6265




 





 





 





 





 





 



   




6266




 





 





 





 





 





 



 =head2 bfretrieve 




6267




 





 





 





 





 





 



   




6268




 





 





 





 





 





 



 This: 




6269




 





 





 





 





 





 



   




6270




 





 





 





 





 





 



  my $bf=bfretrieve('filename.bf'); 




6271




 





 





 





 





 





 



   




6272




 





 





 





 





 





 



 Or this: 




6273




 





 





 





 





 





 



   




6274




 





 





 





 





 





 



  my $bf=bfinit('filename.bf'); 




6275




 





 





 





 





 





 



   




6276




 





 





 





 





 





 



 Is the same as: 




6277




 





 





 





 





 





 



   




6278




 





 





 





 





 





 



  use Storable qw(store retrieve); 




6279




 





 





 





 





 





 



  my $bf=retrieve('filename.bf'); 




6280




 





 





 





 





 





 



   




6281




 





 





 





 





 





 



 =head2 bfclone 




6282




 





 





 





 





 





 



   




6283




 





 





 





 





 





 



 Deep copies the bloom filter data structure. (Which btw is not very deep, two levels at most) 




6284




 





 





 





 





 





 



   




6285




 





 





 





 





 





 



 This: 




6286




 





 





 





 





 





 



   




6287




 





 





 





 





 





 



  my $bfc = bfclone($bf); 




6288




 





 





 





 





 





 



   




6289




 





 





 





 





 





 



 Works just as: 




6290




 





 





 





 





 





 



   




6291




 





 





 





 





 





 



  use Storable; 




6292




 





 





 





 





 





 



  my $bfc=Storable::dclone($bf); 




6293




 





 





 





 





 





 



   




6294




 





 





 





 





 





 



 =head2 Object oriented interface to bloom filters 




6295




 





 





 





 





 





 



   




6296




 





 





 





 





 





 



  use Acme::Tools; 




6297




 





 





 





 





 





 



  my $bf=new Acme::Tools::BloomFilter(0.1,1000); # the same as bfinit, see bfinit above 




6298




 





 





 





 





 





 



  print ref($bf),"\n";                           # prints Acme::Tools::BloomFilter 




6299




 





 





 





 





 





 



  $bf->add(@keys); 




6300




 





 





 





 





 





 



  $bf->check($keys[0]) and print "ok\n";         # prints ok 




6301




 





 





 





 





 





 



  $bf->grep(\@keys)==@keys and print "ok\n";     # prints ok 




6302




 





 





 





 





 





 



  $bf->store('filename.bf'); 




6303




 





 





 





 





 





 



  my $bf2=bfretrieve('filename.bf'); 




6304




 





 





 





 





 





 



  $bf2->check($keys[0]) and print "ok\n";        # still ok 




6305




 





 





 





 





 





 



   




6306




 





 





 





 





 





 



  $bf2=$bf->clone(); 




6307




 





 





 





 





 





 



   




6308




 





 





 





 





 





 



 To instantiate a previously stored bloom filter: 




6309




 





 





 





 





 





 



   




6310




 





 





 





 





 





 



  my $bf = Acme::Tools::BloomFilter->new( '/path/to/stored/bloomfilter.bf' ); 




6311




 





 





 





 





 





 



   




6312




 





 





 





 





 





 



 The o.o. interface has the same methods as the C-subs without the 




6313




 





 





 





 





 





 



 C-prefix in the names. The C is not available as a 




6314




 





 





 





 





 





 



 method, although C, C and 




6315




 





 





 





 





 





 



 C are synonyms. 




6316




 





 





 





 





 





 



   




6317




 





 





 





 





 





 



 =head2 Internals and speed 




6318




 





 





 





 





 





 



   




6319




 





 





 





 





 





 



 The internal hash-functions are C<< md5( "$key$salt" ) >> from L. 




6320




 





 





 





 





 





 



   




6321




 





 





 





 





 





 



 Since C returns 128 bits and most medium to large sized bloom 




6322




 





 





 





 





 





 



 filters need only a 32 bit hash function, the result from md5() are 




6323




 





 





 





 





 





 



 split (C-ed) into 4 parts 32 bits each and are treated as if 4 




6324




 





 





 





 





 





 



 hash functions was called at once (speedup). Using different salts to 




6325




 





 





 





 





 





 



 the key on each md5 results in different hash functions. 




6326




 





 





 





 





 





 



   




6327




 





 





 





 





 





 



 Digest::SHA512 would have been even better since it returns more bits, 




6328




 





 





 





 





 





 



 if it werent for the fact that it's much slower than Digest::MD5. 




6329




 





 





 





 





 





 



   




6330




 





 





 





 





 





 



 String::CRC32::crc32 is faster than Digest::MD5, but not 4 times faster: 




6331




 





 





 





 





 





 



   




6332




 





 





 





 





 





 



  time perl -e'use Digest::MD5 qw(md5);md5("asdf$_") for 1..10e6'       #5.56 sec 




6333




 





 





 





 





 





 



  time perl -e'use String::CRC32;crc32("asdf$_") for 1..10e6'           #2.79 sec, faster but not per bit 




6334




 





 





 





 





 





 



  time perl -e'use Digest::SHA qw(sha512);sha512("asdf$_") for 1..10e6' #36.10 sec, too slow (sha1, sha224, sha256 and sha384 too) 




6335




 





 





 





 





 





 



   




6336




 





 





 





 





 





 



 Md5 seems to be an ok choice both for speed and avoiding collitions due to skewed data keys. 




6337




 





 





 





 





 





 



   




6338




 





 





 





 





 





 



 =head2 Theory and math behind bloom filters 




6339




 





 





 





 





 





 



   




6340




 





 





 





 





 





 



 L 




6341




 





 





 





 





 





 



   




6342




 





 





 





 





 





 



 L 




6343




 





 





 





 





 





 



   




6344




 





 





 





 





 





 



 L 




6345




 





 





 





 





 





 



   




6346




 





 





 





 





 





 



 See also Scaleable Bloom Filters: L (not implemented in Acme::Tools) 




6347




 





 





 





 





 





 



   




6348




 





 





 





 





 





 



 ...and perhaps L 




6349




 





 





 





 





 





 



   




6350




 





 





 





 





 





 



 =cut 




6351




 





 





 





 





 





 



   




6352




 





 





 





 





 





 



 sub bfinit { 




6353




24




  
100
  




 




  
24
  



  
1
  




15650



   return bfretrieve(@_)                             if @_==1; 




6354




23




  
 50
  



  
 66
  




 





 





118



   return bfinit(error_rate=>$_[0], capacity=>$_[1]) if @_==2 and 0<$_[0] and $_[0]<1 and $_[1]>1; 




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 33
  




 





 





 



   




6355




21




  
  0
  



  
 33
  




 





 





61



   return bfinit(error_rate=>$_[1], capacity=>$_[0]) if @_==2 and 0<$_[1] and $_[1]<1 and $_[0]>1; 




 




 





 




  
 33
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




6356




21





 





 





 





 





129



   require Digest::MD5; 




6357




21




  
 50
  




 





 





 





54



   @_%2&&croak "Arguments should be a hash of equal number of keys and values"; 




6358




21





 





 





 





 





85



   my %arg=@_; 




6359




21





 





 





 





 





69



   my @ok_param=qw/error_rate capacity min_hashfuncs max_hashfuncs hashfuncs counting_bits adaptive keys/; 




6360




21





 





 





 





 





84



   my @not_ok=sort(grep!in($_,@ok_param),keys%arg); 




6361




21




  
100
  




 





 





 





271



   croak "Not ok param to bfinit: ".join(", ",@not_ok) if @not_ok; 




6362




20




  
 50
  



  
 66
  




 





 





98



   croak "Not an arrayref in keys-param" if exists $arg{keys} and ref($arg{keys}) ne 'ARRAY'; 




6363




20




  
 50
  




 





 





 





77



   croak "Not implemented counting_bits=$arg{counting_bits}, should be 2, 4, 8, 16 or 32" if !in(nvl($arg{counting_bits},1),1,2,4,8,16,32); 




6364




20




  
 50
  



  
 33
  




 





 





73



   croak "An bloom filters here can not be in both adaptive and counting_bits modes" if $arg{adaptive} and $arg{counting_bits}>1; 




6365




20





 





 





 





 





176



   my $bf={error_rate    => 0.001,  #default p 




6366




 





 





 





 





 





 



 	  capacity      => 100000, #default n 




6367




 





 





 





 





 





 



           min_hashfuncs => 1, 




6368




 





 





 





 





 





 



           max_hashfuncs => 100, 




6369




 





 





 





 





 





 



 	  counting_bits => 1,      #default: not counting filter 




6370




 





 





 





 





 





 



 	  adaptive      => 0, 




6371




 





 





 





 





 





 



 	  %arg,                    #arguments 




6372




 





 





 





 





 





 



 	  key_count     => 0, 




6373




 





 





 





 





 





 



 	  overflow      => {}, 




6374




 





 





 





 





 





 



 	  version       => $Acme::Tools::VERSION, 




6375




 





 





 





 





 





 



 	 }; 




6376




20




  
100
  



  
100
  




 





 





384



   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; 




6377




18




  
 50
  




 





 





 





46



   @$bf{'min_hashfuncs','max_hashfuncs'}=(map$arg{hashfuncs},1..2) if $arg{hashfuncs}; 




6378




18





 





 





 





 





53



   @$bf{'filterlength','hashfuncs'}=bfdimensions($bf); #m and k 




6379




18





 





 





 





 





776



   $$bf{filter}=pack("b*", '0' x ($$bf{filterlength}*$$bf{counting_bits}) ); #hm x   new empty filter 




6380




 





 





 





 





 





 



   $$bf{unpack}= $$bf{filterlength}<=2**16/4 ? "n*" # /4 alleviates skewing if m just slightly < 2**x 




6381




18




  
 50
  




 





 





 





57



                :$$bf{filterlength}<=2**32/4 ? "N*" 




 




 




  
100
  




 





 





 





 



   




6382




 





 





 





 





 





 



                :                              "Q*"; 




6383




18




  
100
  




 





 





 





48



   bfadd($bf,@{$arg{keys}}) if $arg{keys}; 




 




8





 





 





 





 





78



   




6384




16





 





 





 





 





95



   return $bf; 




6385




 





 





 





 





 





 



 } 




6386




 





 





 





 





 





 



 sub bfaddbf { 




6387




2





 





 




  
2
  



  
1
  




5



   my($bf,$bf2)=@_; 




6388




 





 





 





 





 





 



   my $differror=join"\n", 




6389




 





 





 





 





 





 



     map "Property $_ differs ($$bf{$_} vs $$bf2{$_})", 




6390




2





 





 





 





 





42



     grep $$bf{$_} ne $$bf2{$_}, 




6391




 





 





 





 





 





 



     qw/capacity counting_bits adaptive hashfuncs filterlength/; #not error_rate 




6392




2




  
 50
  




 





 





 





8



   croak $differror if $differror; 




6393




2




  
 50
  




 





 





 





9



   croak "Can not add adaptive bloom filters" if $$bf{adaptive}; 




6394




2





 





 





 





 





5



   my $count=$$bf{key_count}+$$bf2{key_count}; 




6395




 





 





 





 





 





 



   croak "Exceeded filter capacity $$bf{key_count} + $$bf2{key_count} = $count > $$bf{capacity}" 




6396




2




  
 50
  




 





 





 





10



     if $count > $$bf{capacity}; 




6397




2





 





 





 





 





7



   $$bf{key_count}+=$$bf2{key_count}; 




6398




2




  
100
  




 





 





 





8



   if($$bf{counting_bits}==1){ 




6399




1





 





 





 





 





5



     $$bf{filter} |= $$bf2{filter}; 




6400




 





 





 





 





 





 



     #$$bf{filter} = $$bf{filter} | $$bf2{filter}; #or-ing 




6401




 





 





 





 





 





 



   } 




6402




 





 





 





 





 





 



   else { 




6403




1





 





 





 





 





4



     my $cb=$$bf{counting_bits}; 




6404




1





 





 





 





 





6



     for(0..$$bf{filterlength}-1){ 




6405




 





 





 





 





 





 



       my $sum= 




6406




 





 





 





 





 





 



       vec($$bf{filter}, $_,$cb)+ 




6407




4793





 





 





 





 





8390



       vec($$bf2{filter},$_,$cb); 




6408




4793




  
 50
  




 





 





 





9761



       if( $sum>2**$cb-1 ){ 




6409



  
0
  




 





 





 





 





0



 	$sum=2**$cb-1; 




6410



  
0
  




 





 





 





 





0



 	$$bf{overflow}{$_}++; 




6411




 





 





 





 





 





 



       } 




6412




4793





 





 





 





 





9283



       vec($$bf{filter}, $_,$cb)=$sum; 




6413




28





 





 




  
28
  




 





187



       no warnings; 




 




28





 





 





 





 





49



   




 




28





 





 





 





 





91601



   




6414




 





 





 





 





 





 



       $$bf{overflow}{$_}+=$$bf2{overflow}{$_} 




6415



  
0
  




 





 





 





 





0



 	and keys(%{$$bf{overflow}})>10 #hmm, arbitrary limit 




6416




 





 





 





 





 





 



 	and croak "Too many overflows, concider doubling counting_bits from $cb to ".(2*$cb) 




6417




4793




  
 50
  



  
  0
  




 





 





13225



 	if exists $$bf2{overflow}{$_}; 




 




 





 




  
  0
  




 





 





 



   




6418




 





 





 





 





 





 



     } 




6419




 





 





 





 





 





 



   } 




6420




2





 





 





 





 





7



   return $bf; #for convenience 




6421




 





 





 





 





 





 



 } 




6422




 





 





 





 





 





 



 sub bfsum { 




6423




8





 





 




  
8
  



  
1
  




40



   my($bf)=@_; 




6424




8




  
100
  




 





 





 





89



   return unpack( "%32b*", $$bf{filter}) if $$bf{counting_bits}==1; 




6425




3





 





 





 





 





8



   my($sum,$cb)=(0,$$bf{counting_bits}); 




6426




3





 





 





 





 





5708



   $sum+=vec($$bf{filter},$_,$cb) for 0..$$bf{filterlength}-1; 




6427




3





 





 





 





 





23



   return $sum; 




6428




 





 





 





 





 





 



 } 




6429




 





 





 





 





 





 



 sub bfadd { 




6430




11





 





 




  
11
  



  
1
  




2573



   require Digest::MD5; 




6431




11





 





 





 





 





876



   my($bf,@keys)=@_; 




6432




11




  
 50
  




 





 





 





34



   return if !@keys; 




6433




11




  
100
  



  
 66
  




 





 





45



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6434




11





 





 





 





 





51



   my($m,$k,$up,$n,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','capacity','counting_bits','adaptive'}; 




6435




11





 





 





 





 





37



   for(@$keysref){ 




6436




 





 





 





 





 





 



     #croak "Key should be scalar" if ref($_); 




6437




15084




  
 50
  



  
 66
  




 





 





40952



     $$bf{key_count} >= $n and croak "Exceeded filter capacity $n"  or  $$bf{key_count}++; 




6438




15083





 





 





 





 





18626



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




15083





 





 





 





 





132284



   




6439




15083




  
100
  



  
 66
  




 





 





51645



     if ($cb==1 and !$adaptive) { # normal bloom filter 




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6440




11110





 





 





 





 





102943



       vec($$bf{filter}, $h[$_] % $m, 1) = 1 for 0..$k-1; 




6441




 





 





 





 





 





 



     } 




6442




 





 





 





 





 





 



     elsif ($cb>1) {                 # counting bloom filter 




6443




3973





 





 





 





 





7256



       for(0..$k-1){ 




6444




11919





 





 





 





 





17176



 	my $pos=$h[$_] % $m; 




6445




 





 





 





 





 





 



 	my $c= 




6446




 





 





 





 





 





 



   	vec($$bf{filter}, $pos, $cb) = 




6447




11919





 





 





 





 





29225



 	vec($$bf{filter}, $pos, $cb) + 1; 




6448




11919




  
100
  




 





 





 





35642



 	if($c==0){ 




6449




26





 





 





 





 





51



 	  vec($$bf{filter}, $pos, $cb) = -1; 




6450




 





 





 





 





 





 



 	  $$bf{overflow}{$pos}++ 




6451




26




  
100
  



  
100
  




 





 





134



 	    and keys(%{$$bf{overflow}})>10 #hmm, arbitrary limit 




 




2





 





 





 





 





244



   




6452




 





 





 





 





 





 



 	    and croak "Too many overflows, concider doubling counting_bits from $cb to ".(2*$cb); 




6453




 





 





 





 





 





 



 	} 




6454




 





 





 





 





 





 



       } 




6455




 





 





 





 





 





 



     } 




6456




 





 





 





 





 





 



     elsif ($adaptive) {             # adaptive bloom filter 




6457



  
0
  




 





 





 





 





0



       my($i,$key,$bit)=(0+@h,$_); 




6458



  
0
  




 





 





 





 





0



       for(0..$$bf{filterlength}-1){ 




6459



  
0
  



  
  0
  




 





 





 





0



 	$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h; 




6460



  
0
  




 





 





 





 





0



 	my $pos=shift(@h) % $m; 




6461



  
0
  




 





 





 





 





0



 	$bit=vec($$bf{filter}, $pos, 1); 




6462



  
0
  




 





 





 





 





0



 	vec($$bf{filter}, $pos, 1)=1; 




6463



  
0
  



  
  0
  



  
  0
  




 





 





0



 	last if $_>=$k-1 and $bit==0; 




6464




 





 





 





 





 





 



       } 




6465




 





 





 





 





 





 



     } 




6466



  
0
  




 





 





 





 





0



     else {croak} 




6467




 





 





 





 





 





 



   } 




6468




9





 





 





 





 





733



   return 1; 




6469




 





 





 





 





 





 



 } 




6470




 





 





 





 





 





 



 sub bfcheck { 




6471




5





 





 




  
5
  



  
1
  




83



   require Digest::MD5; 




6472




5





 





 





 





 





1178



   my($bf,@keys)=@_; 




6473




5




  
 50
  




 





 





 





18



   return if !@keys; 




6474




5




  
 50
  



  
 33
  




 





 





26



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6475




5





 





 





 





 





24



   my($m,$k,$up,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','counting_bits','adaptive'}; 




6476




5





 





 





 





 





12



   my $wa=wantarray(); 




6477




5




  
 50
  




 





 





 





15



   if(!$adaptive){    # normal bloom filter  or  counting bloom filter 




6478




 





 





 





 





 





 



     return map { 




6479




5





 





 





 





 





65



       my $match = 1; # match if every bit is on 




 




24001





 





 





 





 





28811



   




6480




24001





 





 





 





 





28750



       my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




24001





 





 





 





 





222331



   




6481




24001





 




  
100
  




 





 





209677



       vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
100
  




 





 





 



   




6482




24001




  
 50
  




 





 





 





44673



       return $match if !$wa; 




6483




24001





 





 





 





 





51962



       $match; 




6484




 





 





 





 





 





 



     } @$keysref; 




6485




 





 





 





 





 





 



   } 




6486




 





 





 





 





 





 



   else {             # adaptive bloom filter 




6487




 





 





 





 





 





 



     return map { 




6488



  
0
  




 





 





 





 





0



       my($match,$i,$key,$bit,@h)=(1,0,$_); 




 



  
0
  




 





 





 





 





0



   




6489



  
0
  




 





 





 





 





0



       for(0..$$bf{filterlength}-1){ 




6490



  
0
  



  
  0
  




 





 





 





0



 	$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h; 




6491



  
0
  




 





 





 





 





0



 	my $pos=shift(@h) % $m; 




6492



  
0
  




 





 





 





 





0



 	$bit=vec($$bf{filter}, $pos, 1); 




6493



  
0
  



  
  0
  



  
  0
  




 





 





0



 	$match++ if $_ >  $k-1 and $bit==1; 




6494



  
0
  



  
  0
  



  
  0
  




 





 





0



 	$match=0 if $_ <= $k-1 and $bit==0; 




6495



  
0
  



  
  0
  




 





 





 





0



 	last     if $bit==0; 




6496




 





 





 





 





 





 



       } 




6497



  
0
  



  
  0
  




 





 





 





0



       return $match if !$wa; 




6498



  
0
  




 





 





 





 





0



       $match; 




6499




 





 





 





 





 





 



     } @$keysref; 




6500




 





 





 





 





 





 



   } 




6501




 





 





 





 





 





 



 } 




6502




 





 





 





 





 





 



 sub bfgrep { # just a copy of bfcheck with map replaced by grep 




6503




8





 





 




  
8
  



  
1
  




870



   require Digest::MD5; 




6504




8





 





 





 





 





24



   my($bf,@keys)=@_; 




6505




8




  
 50
  




 





 





 





27



   return if !@keys; 




6506




8




  
 50
  



  
 33
  




 





 





65



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6507




8





 





 





 





 





34



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6508




 





 





 





 





 





 



   return grep { 




6509




8





 





 





 





 





29



     my $match = 1; # match if every bit is on 




 




6100





 





 





 





 





7316



   




6510




6100





 





 





 





 





6722



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




6100





 





 





 





 





40807



   




6511




6100





 




  
100
  




 





 





42786



     vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
100
  




 





 





 



   




6512




6100





 





 





 





 





11486



     $match; 




6513




 





 





 





 





 





 



   } @$keysref; 




6514




 





 





 





 





 





 



 } 




6515




 





 





 





 





 





 



 sub bfgrepnot { # just a copy of bfgrep with $match replaced by not $match 




6516




1





 





 




  
1
  



  
1
  




9



   require Digest::MD5; 




6517




1





 





 





 





 





3



   my($bf,@keys)=@_; 




6518




1




  
 50
  




 





 





 





5



   return if !@keys; 




6519




1




  
 50
  



  
 33
  




 





 





16



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6520




1





 





 





 





 





5



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6521




 





 





 





 





 





 



   return grep { 




6522




1





 





 





 





 





5



     my $match = 1; # match if every bit is on 




 




1000





 





 





 





 





1246



   




6523




1000





 





 





 





 





1149



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




1000





 





 





 





 





6814



   




6524




1000





 




  
 50
  




 





 





7027



     vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
 50
  




 





 





 



   




6525




1000





 





 





 





 





2346



     !$match; 




6526




 





 





 





 





 





 



   } @$keysref; 




6527




 





 





 





 





 





 



 } 




6528




 





 





 





 





 





 



 sub bfdelete { 




6529




3





 





 




  
3
  



  
1
  




91



   require Digest::MD5; 




6530




3





 





 





 





 





17



   my($bf,@keys)=@_; 




6531




3




  
 50
  




 





 





 





12



   return if !@keys; 




6532




3




  
100
  



  
100
  




 





 





20



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6533




3





 





 





 





 





11



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6534




3




  
 50
  




 





 





 





8



   croak "Cannot delete from non-counting bloom filter (use counting_bits 4 e.g.)" if $cb==1; 




6535




3





 





 





 





 





7



   for my $key (@$keysref){ 




6536




501





 





 





 





 





537



     my @h; push @h, unpack $up, Digest::MD5::md5($key,0+@h) while @h<$k; 




 




501





 





 





 





 





3437



   




6537




501




  
 50
  



  
 33
  




 





 





1432



     $$bf{key_count}==0 and croak "Deleted all and then some"  or  $$bf{key_count}--; 




6538




501





 





 





 





 





782



     my($ones,$croak,@pos)=(0); 




6539




501





 





 





 





 





925



     for(0..$k-1){ 




6540




1503





 





 





 





 





2149



       my $pos=$h[$_] % $m; 




6541




 





 





 





 





 





 



       my $c= 




6542




1503





 





 





 





 





2267



       vec($$bf{filter}, $pos, $cb); 




6543




1503





 





 





 





 





3127



       vec($$bf{filter}, $pos, $cb)=$c-1; 




6544




1503




  
100
  




 





 





 





3244



       $croak="Cannot delete a non-existing key $key" if $c==0; 




6545




 





 





 





 





 





 



       $croak="Cannot delete with previously overflown position. Try doubleing counting_bits" 




6546




1503




  
 50
  



  
 66
  




 





 





6247



 	if $c==1 and ++$ones and $$bf{overflow}{$pos}; 




 




 





 




  
 66
  




 





 





 



   




6547




 





 





 





 





 





 



     } 




6548




501




  
100
  




 





 





 





1241



     if($croak){ #rollback 




6549




 





 





 





 





 





 



       vec($$bf{filter}, $h[$_] % $m, $cb)= 




6550




1





 





 





 





 





11



       vec($$bf{filter}, $h[$_] % $m, $cb)+1 for 0..$k-1; 




6551




1





 





 





 





 





200



       croak $croak; 




6552




 





 





 





 





 





 



     } 




6553




 





 





 





 





 





 



   } 




6554




2





 





 





 





 





20



   return $bf; 




6555




 





 





 





 





 





 



 } 




6556




 





 





 





 





 





 



 sub bfstore { 




6557




1





 





 




  
1
  



  
1
  




22727



   require Storable; 




6558




1





 





 





 





 





8



   Storable::store(@_); 




6559




 





 





 





 





 





 



 } 




6560




 





 





 





 





 





 



 sub bfretrieve { 




6561




2





 





 




  
2
  



  
1
  




527



   require Storable; 




6562




2





 





 





 





 





11



   my $bf=Storable::retrieve(@_); 




6563




2




  
 50
  




 





 





 





545



   carp  "Retrieved bloom filter was stored in version $$bf{version}, this is version $VERSION" if $$bf{version}>$VERSION; 




6564




2





 





 





 





 





7



   return $bf; 




6565




 





 





 





 





 





 



 } 




6566




 





 





 





 





 





 



 sub bfclone { 




6567




1





 





 




  
1
  



  
1
  




30668



   require Storable; 




6568




1





 





 





 





 





8452



   return Storable::dclone(@_); #could be faster 




6569




 





 





 





 





 





 



 } 




6570




 





 





 





 





 





 



 sub bfdimensions_old { 




6571




 





 





 





 





 





 



   my($n,$p,$mink,$maxk, $k,$flen,$m)= 




6572



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



     @_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'},1) 




 



  
0
  



  
  0
  




 





 





 





0



   




6573




 





 





 





 





 





 



    :@_==2 ? (@_,1,100,1) 




6574




 





 





 





 





 





 



           : croak "Wrong number of arguments (".@_."), should be 2"; 




6575



  
0
  



  
  0
  



  
  0
  




 





 





0



   croak "p ($p) should be > 0 and < 1" if not ( 0<$p && $p<1 ); 




6576



  
0
  




 




  
  0
  




 





 





0



   $m=-1*$_*$n/log(1-$p**(1/$_)) and (!defined $flen or $m<$flen) and ($flen,$k)=($m,$_) for $mink..$maxk; 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




6577



  
0
  




 





 





 





 





0



   $flen = int(1+$flen); 




6578



  
0
  




 





 





 





 





0



   return ($flen,$k); 




6579




 





 





 





 





 





 



 } 




6580




 





 





 





 





 





 



 sub bfdimensions { 




6581




 





 





 





 





 





 



   my($n,$p,$mink,$maxk)= 




6582




18




  
  0
  




 




  
18
  



  
1
  




48



     @_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'}) 




 




18




  
 50
  




 





 





 





52



   




6583




 





 





 





 





 





 



    :@_==2 ? (@_,1,100) 




6584




 





 





 





 





 





 



           : croak "Wrong number of arguments (".@_."), should be 2"; 




6585




18





 





 





 





 





66



   my $k=log(1/$p)/log(2);           # k hash funcs 




6586




18





 





 





 





 





47



   my $m=-$n*log($p)/log(2)**2;      # m bits in filter 




6587




18





 





 





 





 





65



   return ($m+0.5,min($maxk,max($mink,int($k+0.5)))); 




6588




 





 





 





 





 





 



 } 




6589




 





 





 





 





 





 



   




6590




 





 





 





 





 





 



 #crontab -e 




6591




 





 





 





 





 





 



 #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 




6592




 





 





 





 





 





 



   




6593




 





 





 





 





 





 



 sub _update_currency_file { #call from cron 




6594



  
0
  




 




  
  0
  



  
0
  




 





0



   my $fn=shift()||'/var/www/html/currency-rates'; 




6595



  
0
  




 




  
  0
  




 





 





0



   my %exe=map+($_=>"/usr/bin/$_"),qw/curl ci/;-x$_ or die for values %exe; 




 



  
0
  




 





 





 





 





0



   




6596



  
0
  



  
  0
  




 





 





 





0



   open my $F, '>', $fn or die"ERROR: Could not write file $fn ($!)\n"; 




6597



  
0
  




 





 





 





 





0



   print $F "#-- Currency rates ".localtime()." (".time().")\n"; 




6598



  
0
  




 





 





 





 





0



   print $F "#   File generated by Acme::Tools version $VERSION\n"; 




6599



  
0
  




 





 





 





 





0



   print $F "#   Updated every 6th hour on http://calthis.com/currency-rates\n"; 




6600



  
0
  




 





 





 





 





0



   print $F "NOK 1.000000000\n"; 




6601



  
0
  




 





 





 





 





0



   my $amount=1000; 




6602



  
0
  




 





 





 





 





0



   my $data=qx($exe{curl} -s "http://www.x-rates.com/table/?from=NOK&amount=$amount"); 




6603



  
0
  




 





 





 





 





0



   $data=~s,to=([A-Z]{3})(.)>,$2>$1,g; 




6604



  
0
  




 





 





 





 





0



   my @data=ht2t($data,"Alphabetical order"); shift @data; 




 



  
0
  




 





 





 





 





0



   




6605



  
0
  



  
  0
  




 





 





 





0



   @data=map "$$_[1] ".($$_[4]>1e-2?$$_[4]:$$_[2]?sprintf("%.8f",$amount/$$_[2]):0)."\n",@data; 




 




 




  
  0
  




 





 





 





 



   




6606



  
0
  




 





 





 





 





0



   my %data=map split,@data; 




6607



  
0
  




 





 





 





 





0



   my@tc=qx($exe{curl} -s https://btc-e.com/api/3/ticker/btc_usd-ltc_usd)=~/avg.?:(\d+\.?\d*)/g; 




6608



  
0
  




 





 





 





 





0



   push @data,"BTC ".($tc[0]*$data{USD})."\n"; 




6609



  
0
  




 





 





 





 





0



   push @data,"LTC ".($tc[1]*$data{USD})."\n"; 




6610



  
0
  




 





 





 





 





0



   print $F sort(@data); 




6611



  
0
  




 





 





 





 





0



   close($F); 




6612



  
0
  



  
  0
  




 





 





 





0



   qx($exe{ci} -l -m. -d $fn) if -w"$fn,v"; 




6613




 





 





 





 





 





 



 } 




6614




 





 





 





 





 





 



   




6615




 





 





 





 





 





 



 sub ftype { 




6616



  
0
  




 





 




  
0
  



  
0
  




0



   my $f=shift; 




6617



  
0
  



  
  0
  



  
  0
  




 





 





0



   -e $f and 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6618




 





 





 





 





 





 



       -f$f ? 'file'         # -f  File is a plain file. 




6619




 





 





 





 





 





 



      :-d$f ? 'dir'          # -d  File is a directory. 




6620




 





 





 





 





 





 



      :-l$f ? 'symlink'      # -l  File is a symbolic link. 




6621




 





 





 





 





 





 



      :-p$f ? 'pipe'         # -p  File is a named pipe (FIFO), or Filehandle is a pipe. 




6622




 





 





 





 





 





 



      :-S$f ? 'socket'       # -S  File is a socket. 




6623




 





 





 





 





 





 



      :-b$f ? 'blockfile'    # -b  File is a block special file. 




6624




 





 





 





 





 





 



      :-c$f ? 'charfile'     # -c  File is a character special file. 




6625




 





 





 





 





 





 



      :-t$f ? 'ttyfile'      # -t  Filehandle is opened to a tty. 




6626




 





 





 





 





 





 



      :       '' 




6627




 





 





 





 





 





 



   or undef; 




6628




 





 





 





 





 





 



 } 




6629




 





 





 





 





 





 



   




6630




 





 





 





 





 





 



 =head1 COMMANDS 




6631




 





 





 





 





 





 



   




6632




 





 





 





 





 





 



 =head2 install_acme_command_tools 




6633




 





 





 





 





 





 



   




6634




 





 





 





 





 





 



  sudo perl -MAcme::Tools -e install_acme_command_tools 




6635




 





 





 





 





 





 



  Wrote executable /usr/local/bin/conv 




6636




 





 





 





 





 





 



  Wrote executable /usr/local/bin/due 




6637




 





 





 





 





 





 



  Wrote executable /usr/local/bin/xcat 




6638




 





 





 





 





 





 



  Wrote executable /usr/local/bin/freq 




6639




 





 





 





 





 





 



  Wrote executable /usr/local/bin/deldup 




6640




 





 





 





 





 





 



  Wrote executable /usr/local/bin/wipe 




6641




 





 





 





 





 





 



   




6642




 





 





 





 





 





 



 Examples of commands then made available: 




6643




 





 





 





 





 





 



   




6644




 





 





 





 





 





 



  conv 1 USD EUR                #might show 0.88029 if thats the current currency rate. Uses conv() 




6645




 





 





 





 





 





 



  conv .5 in cm                 #reveals that 1/2 inch is 1.27 cm, see doc on conv() for all supported units 




6646




 





 





 





 





 





 



  due [-h] /path/1/ /path/2/    #like du, but show statistics on file extentions instead of subdirs 




6647




 





 





 





 





 





 



  xcat file                     #like cat, zcat, bzcat or xzcat in one. Uses file extention to decide. Uses openstr() 




6648




 





 





 





 





 





 



  freq file                     #reads file(s) or stdin and view counts of each byte 0-255 




6649




 





 





 





 





 





 



  deldup [-d] path1/ path2/     #reports (and optionally deletes) duplicate files NOT IMPLEMENTED YET! 




6650




 





 





 





 





 





 



  ccmd grep string /huge/file   #caches stdout+stderr for 15 minutes (default) for much faster results later 




6651




 





 





 





 





 





 



  ccmd "sleep 2;echo hello"     #slow first time. Note the quotes! 




6652




 





 





 





 





 





 



  ccmd "du -s ~/*|sort -n|tail" #ccmd store stdout+stderr in /tmp files (default) 




6653




 





 





 





 





 





 



   




6654




 





 





 





 





 





 



 =head3 due 




6655




 





 





 





 





 





 



   




6656




 





 





 





 





 





 



 Like C command but views space used by file extentions instead of dirs. Options: 




6657




 





 





 





 





 





 



   




6658




 





 





 





 





 





 



  due [-options] [dirs] [files] 




6659




 





 





 





 





 





 



  due -h          View bytes "human readable", i.e. C<8.72 MB> instead of C<9145662 b> (bytes) 




6660




 





 





 





 





 





 



  due -k | -m     View bytes in kilobytes | megabytes (1024 | 1048576) 




6661




 





 





 





 





 





 



  due -K          Like -k but uses 1000 instead of 1024 




6662




 





 





 





 





 





 



  due -z          View two extentions if .z .Z .gz .bz2 .rz or .xz (.tar.gz, not just .gz) 




6663




 





 





 





 





 





 



  due -M          Also show min, medium and max date (mtime) of files, give an idea of their age 




6664




 





 





 





 





 





 



  due -P          Also show 10, 50 (medium) and 90 percentile of file date 




6665




 





 





 





 





 





 



  due -MP         Both -M and -P, shows min, 10p, 50p, 90p and max 




6666




 





 





 





 





 





 



  due -a          Sort output alphabetically by extention (default order is by size) 




6667




 





 





 





 





 





 



  due -c          Sort output by number of files 




6668




 





 





 





 





 





 



  due -i          Ignore case, .GZ and .gz is the same, output in lower case 




6669




 





 





 





 





 





 



  due -t          Adds time of day to -M and -P output 




6670




 





 





 





 





 





 



  due -e 'regex'  Exclude files (full path) matching regex. Ex: due -e '\.git' 




6671




 





 





 





 





 





 



   




6672




 





 





 





 





 





 



 =cut 




6673




 





 





 





 





 





 



   




6674




 





 





 





 





 





 



 sub install_acme_command_tools { 




6675



  
0
  




 





 




  
0
  



  
1
  




0



   my $dir=(grep -d$_, @_, '/usr/local/bin', '/usr/bin')[0]; 




6676



  
0
  




 





 





 





 





0



   for(qw( conv due xcat freq deldup ccmd )){ 




6677



  
0
  




 





 





 





 





0



     unlink("$dir/$_"); 




6678



  
0
  




 





 





 





 





0



     writefile("$dir/$_", "#!$^X\nuse Acme::Tools;\nAcme::Tools::cmd_$_(\@ARGV);\n"); 




6679



  
0
  




 





 





 





 





0



     sys("/bin/chmod +x $dir/$_"); 




6680



  
0
  




 





 





 





 





0



     print "Wrote executable $dir/$_\n"; 




6681




 





 





 





 





 





 



   } 




6682




 





 





 





 





 





 



 } 




6683



  
0
  




 





 




  
0
  



  
0
  




0



 sub cmd_conv { print conv(@ARGV)."\n"  } 




6684




28





 





 




  
28
  




 





51697



   use Data::Dumper; 




 




28





 





 





 





 





294442



   




 




28





 





 





 





 





3305



   




6685




 





 





 





 





 





 



 sub cmd_due { #TODO: output from tar tvf and ls and find -ls 




6686



  
0
  




 





 




  
0
  



  
0
  




0



   require Getopt::Std; my %o; Getopt::Std::getopts("zkKmhciMPate:" => \%o); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6687



  
0
  




 





 





 





 





0



   require File::Find; 




6688




28





 





 




  
28
  




 





189



   no warnings 'uninitialized'; 




 




28





 





 





 





 





55



   




 




28





 





 





 





 





86776



   




6689



  
0
  



  
  0
  




 





 





 





0



   die"$0: -h, -k or -m can not be used together\n" if $o{h}+$o{k}+$o{m}>1; 




6690



  
0
  



  
  0
  




 





 





 





0



   die"$0: -c and -a can not be used together\n"    if $o{a}+$o{c}>1; 




6691



  
0
  



  
  0
  




 





 





 





0



   die"$0: -k and -m can not be used together\n"    if $o{k}+$o{m}>1; 




6692



  
0
  



  
  0
  




 





 





 





0



   my @q=@ARGV; @q=('.') if !@q; 




 



  
0
  




 





 





 





 





0



   




6693



  
0
  




 





 





 





 





0



   my(%c,%b,$cnt,$bts,%mtime); 




6694



  
0
  



  
  0
  




 





 





 





0



   my $r=$o{z} ? qr/(\.[^\.\/]{1,10}(\.(z|Z|gz|bz2|rz|xz))?)$/ 




6695




 





 





 





 





 





 



               : qr/(\.[^\.\/]{1,10})$/; 




6696



  
0
  



  
  0
  




 





 





 





0



   my $rexcl=exists$o{e}?qr/$o{e}/:0; 




6697




 





 





 





 





 





 



   File::Find::find({wanted => 




6698




 





 





 





 





 





 



     sub { 




6699



  
0
  



  
  0
  




 




  
0
  




 





0



       return if !-f$_; 




6700



  
0
  



  
  0
  



  
  0
  




 





 





0



       return if $rexcl and $File::Find::name=~$rexcl; 




6701



  
0
  




 





 





 





 





0



       my($sz,$mtime)=(stat($_))[7,9]; 




6702



  
0
  



  
  0
  




 





 





 





0



       my $ext=m/$r/?$1:""; 




6703



  
0
  



  
  0
  




 





 





 





0



       $ext=lc($ext) if $o{i}; 




6704



  
0
  




 





 





 





 





0



       $cnt++;    $c{$ext}++; 




 



  
0
  




 





 





 





 





0



   




6705



  
0
  




 





 





 





 





0



       $bts+=$sz; $b{$ext}+=$sz; 




 



  
0
  




 





 





 





 





0



   




6706



  
0
  



  
  0
  



  
  0
  




 





 





0



       $mtime{$ext}.=",$mtime" if $o{M} or $o{P}; 




6707



  
0
  




 





 





 





 





0



       1; 




6708



  
0
  




 





 





 





 





0



     } },@q); 




6709



  
0
  




 





 




  
0
  




 





0



   my($f,$s)=$o{k}?("%14.2f kb",sub{$_[0]/1024}) 




6710



  
0
  




 





 




  
0
  




 





0



            :$o{K}?("%14.2f Kb",sub{$_[0]/1000}) 




6711



  
0
  




 





 




  
0
  




 





0



            :$o{m}?("%14.2f mb",sub{$_[0]/1024**2}) 




6712



  
0
  




 





 




  
0
  




 





0



            :$o{h}?("%14s",     sub{bytes_readable($_[0])}) 




6713



  
0
  



  
  0
  




 




  
0
  




 





0



            :      ("%14d b",   sub{$_[0]}); 




 



  
0
  



  
  0
  




 





 





 





0



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6714




 





 





 





 





 





 



   my @e=$o{a}?(sort(keys%c)) 




6715



  
0
  



  
  0
  




 





 





 





0



        :$o{c}?(sort{$c{$a}<=>$c{$b} or $a cmp $b}keys%c) 




6716



  
0
  



  
  0
  




 





 





 





0



        :      (sort{$b{$a}<=>$b{$b} or $a cmp $b}keys%c); 




 



  
0
  



  
  0
  




 





 





 





0



   




 




 




  
  0
  




 





 





 





 



   




6717



  
0
  



  
  0
  




 





 





 





0



   my @p=$o{P}?(10,50,90):(50); 




6718




 





 





 





 





 





 



   my $perc=sub{ 




6719



  
0
  



  
  0
  



  
  0
  



  
0
  




 





0



     $o{M} or $o{P} or return""; 




6720



  
0
  




 





 





 





 





0



     my @m=@_>0 ? do {grep$_, split",", $mtime{$_[0]}} 




6721



  
0
  



  
  0
  




 





 





 





0



                : do {grep$_, map {split","} values %mtime}; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6722



  
0
  




 





 





 





 





0



     my @r=percentile(\@p,@m); 




6723



  
0
  



  
  0
  




 





 





 





0



     @r=(min(@m),@r,max(@m)) if $o{M}; 




6724



  
0
  




 





 





 





 





0



     @r=map int($_), @r; 




6725



  
0
  



  
  0
  




 





 





 





0



     my $fmt='YYYY/MM/DD'; $fmt.="-MM:MI:SS" if $o{t}; 




 



  
0
  




 





 





 





 





0



   




6726



  
0
  




 





 





 





 





0



     @r=map tms($_,$fmt), @r; 




6727



  
0
  




 





 





 





 





0



     "  ".join(" ",@r); 




6728



  
0
  




 





 





 





 





0



   }; 




6729



  
0
  




 





 





 





 





0



   printf("%-11s %8d $f %7.2f%%%s\n",$_,$c{$_},&$s($b{$_}),100*$b{$_}/$bts,&$perc($_)) for @e; 




6730



  
0
  




 





 





 





 





0



   printf("%-11s %8d $f %7.2f%%%s\n","Sum",$cnt,&$s($bts),100,&$perc()); 




6731




 





 





 





 





 





 



 } 




6732




 





 





 





 





 





 



 sub cmd_xcat { 




6733



  
0
  




 





 




  
0
  



  
0
  




0



   for my $fn (@_){ 




6734



  
0
  




 





 





 





 





0



     my $os=openstr($fn); 




6735



  
0
  



  
  0
  



  
  0
  




 





 





0



     open my $FH, $os or warn "xcat: cannot open $os ($!)\n" and next; 




6736



  
0
  




 





 





 





 





0



     print while <$FH>; 




6737



  
0
  




 





 





 





 





0



     close($FH); 




6738




 





 





 





 





 





 



   } 




6739




 





 





 





 





 





 



 } 




6740




 





 





 





 





 





 



 sub cmd_freq { 




6741



  
0
  




 





 




  
0
  



  
0
  




0



   my(@f,$i); 




6742



  
0
  




 





 





 





 





0



   map $f[$_]++, unpack("C*",$_) while <>; 




6743



  
0
  




 





 





 





 





0



   my $s=" " x 12;map{print"$_$s$_$s$_\n"}("BYTE  CHAR   COUNT","---- ----- -------"); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6744



  
0
  




 





 





 





 





0



   my %m=(145,"DOS-æ",155,"DOS-ø",134,"DOS-å",146,"DOS-Æ",157,"DOS-Ø",143,"DOS-Å",map{($_," ")}0..31); 




 



  
0
  




 





 





 





 





0



   




6745



  
0
  



  
  0
  



  
  0
  




 





 





0



   printf("%4d %5s%8d".(++$i%3?$s:"\n"),$_,$m{$_}||chr,$f[$_]) for grep$f[$_],0..255;print "\n"; 




 



  
0
  




 





 





 





 





0



   




6746



  
0
  




 





 





 





 





0



   my @no=grep!$f[$_],0..255; print "No bytes for these ".@no.": ".join(" ",@no)."\n"; 




 



  
0
  




 





 





 





 





0



   




6747




 





 





 





 





 





 



 } 




6748




 





 





 





 





 





 



   




6749




 





 





 





 





 





 



 sub cmd_deldup { 




6750




 





 





 





 





 





 



   # ~/test/deldup.pl #find and optionally delete duplicate files effiencently 




6751




 





 





 





 





 





 



   #http://www.commandlinefu.com/commands/view/3555/find-duplicate-files-based-on-size-first-then-md5-hash 




6752



  
0
  




 





 




  
0
  



  
0
  




0



   die "todo: deldup not ready yet" 




6753




 





 





 





 





 





 



 } 




6754




 





 





 





 





 





 



   




6755




 





 





 





 





 





 



 #http://stackoverflow.com/questions/11900239/can-i-cache-the-output-of-a-command-on-linux-from-cli 




6756




 





 





 





 





 





 



 our $Ccmd_cache_dir='/tmp/acme-tools-ccmd-cache'; 




6757




 





 





 





 





 





 



 our $Ccmd_cache_expire=15*60;  #default 15 minutes 




6758




 





 





 





 





 





 



 sub cmd_ccmd { 




6759



  
0
  




 





 




  
0
  



  
0
  




0



   require Digest::MD5; 




6760



  
0
  




 





 





 





 





0



   my $cmd=join" ",@_; 




6761



  
0
  




 





 





 





 





0



   my $d="$Ccmd_cache_dir/".username(); 




6762



  
0
  




 





 





 





 





0



   makedir($d); 




6763



  
0
  




 





 





 





 





0



   my $md5=Digest::MD5::md5_hex($cmd); 




6764



  
0
  




 





 





 





 





0



   my($fno,$fne)=map"$d/cmd.$md5.std$_","out","err"; 




6765



  
0
  




 





 




  
0
  




 





0



   my $too_old=sub{time()-(stat(shift))[9] >= $Ccmd_cache_expire}; 




 



  
0
  




 





 





 





 





0



   




6766



  
0
  




 





 





 





 





0



   unlink grep &$too_old($_), <$d/*.std???>; 




6767



  
0
  



  
  0
  



  
  0
  




 





 





0



   sys("($cmd) > $fno 2> $fne") if !-e$fno or &$too_old($fno); 




6768



  
0
  




 





 





 





 





0



   print STDOUT "".readfile($fno); 




6769



  
0
  




 





 





 





 





0



   print STDERR "".readfile($fne); 




6770




 





 





 





 





 





 



 } 




6771




 





 





 





 





 





 



   




6772



  
0
  




 





 




  
0
  



  
0
  




0



 sub cmd_trunc { die "todo: trunc not ready yet"} #truncate a file, size 0, keep all other attr 




6773




 





 





 





 





 





 



   




6774




 





 





 





 





 





 



 sub cmd_wipe  { 




6775



  
0
  




 





 




  
0
  



  
0
  




0



   require Getopt::Std; my %o; Getopt::Std::getopts("n:k" => \%o); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6776



  
0
  




 





 





 





 





0



   wipe($_,$o{n},$o{k}) for @_; 




6777




 





 





 





 





 





 



 } 




6778




 





 





 





 





 





 



   




6779




 





 





 





 





 





 



 =head1 DATABASE STUFF - NOT IMPLEMENTED YET 




6780




 





 





 





 





 





 



   




6781




 





 





 





 





 





 



 Uses L. Comming soon... 




6782




 





 





 





 





 





 



   




6783




 





 





 





 





 





 



   $Dbh 




6784




 





 





 





 





 





 



   dlogin 




6785




 





 





 





 





 





 



   dlogout 




6786




 





 





 





 





 





 



   drow 




6787




 





 





 





 





 





 



   drows 




6788




 





 





 





 





 





 



   drowc 




6789




 





 





 





 





 





 



   drowsc 




6790




 





 





 





 





 





 



   dcols 




6791




 





 





 





 





 





 



   dpk 




6792




 





 





 





 





 





 



   dsel 




6793




 





 





 





 





 





 



   ddo 




6794




 





 





 





 





 





 



   dins 




6795




 





 





 





 





 





 



   dupd 




6796




 





 





 





 





 





 



   ddel 




6797




 





 





 





 





 





 



   dcommit 




6798




 





 





 





 





 





 



   drollback 




6799




 





 





 





 





 





 



   




6800




 





 





 





 





 





 



 =cut 




6801




 





 





 





 





 





 



   




6802




 





 





 





 





 





 



 #my$dummy=<<'SOON'; 




6803




 





 





 





 





 





 



 sub dtype { 




6804



  
0
  




 





 




  
0
  



  
0
  




0



   my $connstr=shift; 




6805



  
0
  



  
  0
  




 





 





 





0



   return 'SQLite' if $connstr=~/(\.sqlite|sqlite:.*\.db)$/i; 




6806



  
0
  



  
  0
  




 





 





 





0



   return 'Oracle' if $connstr=~/\@/; 




6807



  
0
  




 





 





 





 





0



   return 'Pg' if 1==2; 




6808



  
0
  




 





 





 





 





0



   die; 




6809




 





 





 





 





 





 



 } 




6810




 





 





 





 





 





 



   




6811




 





 





 





 





 





 



 our($Dbh,@Dbh,%Sth); 




6812




 





 





 





 





 





 



 our %Dbattr=(RaiseError => 1, AutoCommit => 0); #defaults 




6813




 





 





 





 





 





 



 sub dlogin { 




6814



  
0
  




 





 




  
0
  



  
0
  




0



   my $connstr=shift(); 




6815



  
0
  




 





 





 





 





0



   my %attr=(%Dbattr,@_); 




6816



  
0
  




 





 





 





 





0



   my $type=dtype($connstr); 




6817



  
0
  




 





 





 





 





0



   my($dsn,$u,$p)=('','',''); 




6818



  
0
  



  
  0
  




 





 





 





0



   if($type eq 'SQLite'){ 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6819



  
0
  




 





 





 





 





0



     $dsn=$connstr; 




6820




 





 





 





 





 





 



   } 




6821




 





 





 





 





 





 



   elsif($type eq 'Oracle'){ 




6822



  
0
  




 





 





 





 





0



     ($u,$p,$dsn)=($connstr=~m,(.+?)(/.+?)?\@(.+),); 




6823




 





 





 





 





 





 



   } 




6824




 





 





 





 





 





 



   elsif($type eq 'Pg'){ 




6825



  
0
  




 





 





 





 





0



     croak "todo"; 




6826




 





 





 





 





 





 



   } 




6827




 





 





 





 





 





 



   else{ 




6828



  
0
  




 





 





 





 





0



     croak "dblogin: unknown database type for connection string $connstr\n"; 




6829




 





 





 





 





 





 



   } 




6830



  
0
  




 





 





 





 





0



   $dsn="dbi:$type:$dsn"; 




6831



  
0
  



  
  0
  




 





 





 





0



   push @Dbh, $Dbh if $Dbh; #local is better? 




6832



  
0
  




 





 





 





 





0



   require DBI; 




6833



  
0
  




 





 





 





 





0



   $Dbh=DBI->connect($dsn,$u,$p,\%attr); #connect_cached? 




6834




 





 





 





 





 





 



 } 




6835




 





 





 





 





 





 



 sub dlogout { 




6836



  
0
  




 





 




  
0
  



  
0
  




0



   $Dbh->disconnect; 




6837



  
0
  



  
  0
  




 





 





 





0



   $Dbh=pop@Dbh if @Dbh; 




6838




 





 





 





 





 





 



 } 




6839




 





 





 





 





 





 



 sub drow { 




6840



  
0
  




 





 




  
0
  



  
0
  




0



   my($q,@b)=_dattrarg(@_); 




6841




 





 





 





 





 





 



   #my $sth=do{$Sth{$Dbh,$q} ||= $Dbh->prepare_cached($q)}; 




6842



  
0
  




 





 





 





 





0



   my $sth=$Dbh->prepare_cached($q); 




6843



  
0
  




 





 





 





 





0



   $sth->execute(@b); 




6844



  
0
  




 





 





 





 





0



   my @r=$sth->fetchrow_array; 




6845



  
0
  



  
  0
  




 





 





 





0



   $sth->finish if $$Dbh{Driver}{Name} eq 'SQLite'; 




6846




 





 





 





 





 





 



   #$dbh->selectrow_array($statement); 




6847



  
0
  



  
  0
  




 





 





 





0



   return @r==1?$r[0]:@r; 




6848




 





 





 





 





 





 



 } 




6849




 





 





 




  
0
  



  
0
  




 



 sub drows { 




6850




 





 





 





 





 





 



 } 




6851




 





 





 




  
0
  



  
0
  




 



 sub drowc { 




6852




 





 





 





 





 





 



 } 




6853




 





 





 




  
0
  



  
0
  




 



 sub drowsc { 




6854




 





 





 





 





 





 



 } 




6855




 





 





 




  
0
  



  
0
  




 



 sub dcols { 




6856




 





 





 





 





 





 



 } 




6857




 





 





 




  
0
  



  
0
  




 



 sub dpk { 




6858




 





 





 





 





 





 



 } 




6859




 





 





 




  
0
  



  
0
  




 



 sub dsel { 




6860




 





 





 





 





 





 



 } 




6861




 





 





 





 





 





 



 sub ddo { 




6862



  
0
  




 





 




  
0
  



  
0
  




0



   my @arg=_dattrarg(@_); 




6863




 





 





 





 





 





 



   #warn serialize(\@arg,'arg','',1); 




6864



  
0
  




 





 





 





 





0



   $Dbh->do(@arg); #hm cache? 




6865




 





 





 





 





 





 



 } 




6866




 





 





 




  
0
  



  
0
  




 



 sub dins { 




6867




 





 





 





 





 





 



 } 




6868




 





 





 




  
0
  



  
0
  




 



 sub dupd { 




6869




 





 





 





 





 





 



 } 




6870




 





 





 




  
0
  



  
0
  




 



 sub ddel { 




6871




 





 





 





 





 





 



 } 




6872



  
0
  




 





 




  
0
  



  
0
  




0



 sub dcommit { $Dbh->commit } 




6873



  
0
  




 





 




  
0
  



  
0
  




0



 sub drollback { $Dbh->rollback } 




6874




 





 





 





 





 





 



   




6875




 





 





 





 





 





 



 sub _dattrarg { 




6876



  
0
  




 





 




  
0
  




 





0



   my @arg=@_; 




6877



  
0
  



  
  0
  




 





 





 





0



   splice @arg,1,0, ref($arg[-1]) eq 'HASH' ? pop(@arg) : {}; 




6878



  
0
  




 





 





 





 





0



   @arg; 




6879




 





 





 





 





 





 



 } 




6880




 





 





 





 





 





 



   




6881




 





 





 





 





 





 



 =head2 self_update 




6882




 





 





 





 





 





 



   




6883




 





 





 





 





 





 



 Update Acme::Tools to newest version quick and dirty: 




6884




 





 





 





 





 





 



   




6885




 





 





 





 





 





 



  function pmview(){ ls -ld `perl -M$1 -le'$m=shift;$mi=$m;$mi=~s,::,/,g;print $INC{"$mi.pm"};warn"Version ".${$m."::VERSION"}."\n"' $1`;} 




6886




 





 





 





 





 





 



   




6887




 





 





 





 





 





 



  pmview Acme::Tools                                     #view date and version before 




6888




 





 





 





 





 





 



  sudo perl -MAcme::Tools -e Acme::Tools::self_update    #update to newest version 




6889




 





 





 





 





 





 



  pmview Acme::Tools                                     #view date and version after 




6890




 





 





 





 





 





 



   




6891




 





 





 





 





 





 



 Does C to where Acme/Tools.pm are and then wget -N https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm 




6892




 





 





 





 





 





 



   




6893




 





 





 





 





 





 



 =cut 




6894




 





 





 





 





 





 



   




6895




 





 





 





 





 





 



 our $Wget; 




6896




 





 





 





 





 





 



 our $Self_update_url='https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm'; #todo: change site 




6897




 





 





 





 





 





 



 sub self_update { 




6898




 





 





 





 





 





 



   #in($^O,'linux','cygwin') or die"ERROR: self_update works on linux and cygwin only"; 




6899



  
0
  




 




  
  0
  



  
0
  



  
1
  




0



   $Wget||=(grep -x$_,map"$_/wget",'/usr/bin','/bin','/usr/local/bin','.')[0]; #hm --no-check-certificate 




6900



  
0
  



  
  0
  




 





 





 





0



   -x$Wget or die"ERROR: wget ($Wget) executable not found\n"; 




6901



  
0
  




 





 





 





 





0



   my $d=dirname(__FILE__); 




6902



  
0
  




 





 





 





 





0



   sys("cd $d; ls -l Tools.pm; md5sum Tools.pm"); 




6903



  
0
  




 




  
  0
  




 





 





0



   sys("cd $d; $Wget -N ".($ARGV[0]||$Self_update_url)); 




6904



  
0
  




 





 





 





 





0



   sys("cd $d; ls -l Tools.pm; md5sum Tools.pm"); 




6905




 





 





 





 





 





 



 } 




6906




 





 





 





 





 





 



   




6907




 





 





 





 





 





 



 1; 




6908




 





 





 





 





 





 



   




6909




 





 





 





 





 





 



 package Acme::Tools::BloomFilter; 




6910




28





 





 




  
28
  




 





768



 use 5.008; use strict; use warnings; use Carp; 




 




28





 





 




  
28
  




 





101



   




 




28





 





 




  
28
  




 





141



   




 




28





 





 




  
28
  




 





50



   




 




28





 





 





 





 





738



   




 




28





 





 





 





 





132



   




 




28





 





 





 





 





46



   




 




28





 





 





 





 





969



   




 




28





 





 





 





 





143



   




 




28





 





 





 





 





46



   




 




28





 





 





 





 





14374



   




6911




2





 





 




  
2
  




 





307



 sub new      { my($class,@p)=@_; my $self=Acme::Tools::bfinit(@p); bless $self, $class } 




 




2





 





 





 





 





9



   




 




2





 





 





 





 





11



   




6912




2





 





 




  
2
  




 





108



 sub add      { &Acme::Tools::bfadd      } 




6913



  
0
  




 





 




  
0
  




 





0



 sub addbf    { &Acme::Tools::bfaddbf    } 




6914




2





 





 




  
2
  




 





88



 sub check    { &Acme::Tools::bfcheck    } 




6915




1





 





 




  
1
  




 





7



 sub grep     { &Acme::Tools::bfgrep     } 




6916



  
0
  




 





 




  
0
  




 





0



 sub grepnot  { &Acme::Tools::bfgrepnot  } 




6917



  
0
  




 





 




  
0
  




 





0



 sub delete   { &Acme::Tools::bfdelete   } 




6918



  
0
  




 





 




  
0
  




 





0



 sub store    { &Acme::Tools::bfstore    } 




6919



  
0
  




 





 




  
0
  




 





0



 sub retrieve { &Acme::Tools::bfretrieve } 




6920




1





 





 




  
1
  




 





5



 sub clone    { &Acme::Tools::bfclone    } 




6921




0





 





 




  
0
  




 





0



 sub sum      { &Acme::Tools::bfsum      } 




6922




 





 





 





 





 





 



 1; 




6923




 





 





 





 





 





 



   




6924




 





 





 





 





 





 



 # Ny versjon: 




6925




 





 





 





 





 





 



 # + c-s todo 




6926




 





 





 





 





 





 



 # + endre $VERSION 




6927




 





 





 





 





 





 



 # + endre Release history under HISTORY 




6928




 





 





 





 





 





 



 # + endre årstall under COPYRIGHT AND LICENSE 




6929




 





 





 





 





 





 



 # + oppd default valutakurser inkl datoen 




6930




 





 





 





 





 





 



 # + emacs Changes 




6931




 





 





 





 





 





 



 # + emacs README + aarstall 




6932




 





 





 





 





 





 



 # + emacs MANIFEST legg til ev nye t/*.t 




6933




 





 





 





 





 





 



 # + perl            Makefile.PL;make test 




6934




 





 





 





 





 





 



 # + /usr/bin/perl   Makefile.PL;make test 




6935




 





 





 





 





 





 



 # + perlbrew exec "perl ~/Acme-Tools/Makefile.PL ; time make test" 




6936




 





 





 





 





 





 



 # + perlbrew use perl-5.10.1; perl Makefile.PL; make test; perlbrew off 




6937




 





 





 





 





 





 



 # + test evt i cygwin og mingw-perl 




6938




 





 





 





 





 





 



 # + pod2html Tools.pm > Tools.html ; firefox Tools.html  




6939




 





 





 





 





 





 



 # + https://metacpan.org/pod/Acme::Tools 




6940




 





 





 





 





 





 



 # + http://cpants.cpanauthors.org/dist/Acme-Tools  #kvalitee 




6941




 





 





 





 





 





 



 # + perl Makefile.PL ; make test && make dist 




6942




 





 





 





 





 





 



 # + cp -p *tar.gz /htdocs/ 




6943




 





 





 





 





 





 



 # + ci -l -mversjon -d `cat MANIFEST` 




6944




 





 





 





 





 





 



 # + git add `cat MANIFEST` 




6945




 





 





 





 





 





 



 # + git status 




6946




 





 





 





 





 





 



 # + git commit -am versjon 




6947




 





 





 





 





 





 



 # + git push                    #eller: 




6948




 





 





 





 





 





 



 # + git push origin master 




6949




 





 





 





 





 





 



 # + http://pause.perl.org/ 




6950




 





 





 





 





 





 



 # http://en.wikipedia.org/wiki/Birthday_problem#Approximations 




6951




 





 





 





 





 





 



   




6952




 





 





 





 





 





 



 # memoize_expire()           http://perldoc.perl.org/Memoize/Expire.html 




6953




 





 





 





 





 





 



 # memoize_file_expire() 




6954




 





 





 





 





 





 



 # memoize_limit_size() #lru 




6955




 





 





 





 





 





 



 # memoize_file_limit_size() 




6956




 





 





 





 





 





 



 # memoize_memcached         http://search.cpan.org/~dtrischuk/Memoize-Memcached-0.03/lib/Memoize/Memcached.pm 




6957




 





 





 





 





 





 



 # hint on http://perl.jonallen.info/writing/articles/install-perl-modules-without-root 




6958




 





 





 





 





 





 



   




6959




 





 





 





 





 





 



 # sub mycrc32 {  #http://billauer.co.il/blog/2011/05/perl-crc32-crc-xs-module/  eller String::CRC32::crc32 som er 100 x raskere enn Digest::CRC::crc32 




6960




 





 





 





 





 





 



 #  my ($input, $init_value, $polynomial) = @_; 




6961




 





 





 





 





 





 



 #  $init_value = 0 unless (defined $init_value); 




6962




 





 





 





 





 





 



 #  $polynomial = 0xedb88320 unless (defined $polynomial); 




6963




 





 





 





 





 





 



 #  my @lookup_table; 




6964




 





 





 





 





 





 



 #  for (my $i=0; $i<256; $i++) { 




6965




 





 





 





 





 





 



 #    my $x = $i; 




6966




 





 





 





 





 





 



 #    for (my $j=0; $j<8; $j++) { 




6967




 





 





 





 





 





 



 #      if ($x & 1) { 




6968




 





 





 





 





 





 



 #        $x = ($x >> 1) ^ $polynomial; 




6969




 





 





 





 





 





 



 #      } else { 




6970




 





 





 





 





 





 



 #        $x = $x >> 1; 




6971




 





 





 





 





 





 



 #      } 




6972




 





 





 





 





 





 



 #    } 




6973




 





 





 





 





 





 



 #    push @lookup_table, $x; 




6974




 





 





 





 





 





 



 #  } 




6975




 





 





 





 





 





 



 #  my $crc = $init_value ^ 0xffffffff; 




6976




 





 





 





 





 





 



 #  foreach my $x (unpack ('C*', $input)) { 




6977




 





 





 





 





 





 



 #    $crc = (($crc >> 8) & 0xffffff) ^ $lookup_table[ ($crc ^ $x) & 0xff ]; 




6978




 





 





 





 





 





 



 #  } 




6979




 





 





 





 





 





 



 #  $crc = $crc ^ 0xffffffff; 




6980




 





 





 





 





 





 



 #  return $crc; 




6981




 





 





 





 





 





 



 # } 




6982




 





 





 





 





 





 



 # 




6983




 





 





 





 





 





 



   




6984




 





 





 





 





 





 



   




6985




 





 





 





 





 





 



   




6986




 





 





 





 





 





 



 =head1 HISTORY 




6987




 





 





 





 





 





 



   




6988




 





 





 





 





 





 



 Release history 




6989




 





 





 





 





 





 



   




6990




 





 





 





 





 





 



  0.172 Dec 2015   Subs: curb, openstr, pwgen, sleepms, sleepnm, srlz, tms, username, 




6991




 





 





 





 





 





 



                   self_update, install_acme_command_tools 




6992




 





 





 





 





 





 



                   Commands: conv, due, freq, wipe, xcat (see "Commands") 




6993




 





 





 





 





 





 



  0.16  Feb 2015   bigr, curb, cpad, isnum, parta, parth, read_conf, resolve_equation, 




6994




 





 





 





 





 





 



                   roman2int, trim. Improved: conv (numbers, currency), range ("derivatives") 




6995




 





 





 





 





 





 



  0.15  Nov 2014   Improved doc 




6996




 





 





 





 





 





 



  0.14  Nov 2014   New subs, improved tests and doc 




6997




 





 





 





 





 





 



  0.13  Oct 2010   Non-linux test issue, resolve. improved: bloom filter, tests, doc 




6998




 





 





 





 





 





 



  0.12  Oct 2010   Improved tests, doc, bloom filter, random_gauss, bytes_readable 




6999




 





 





 





 





 





 



  0.11  Dec 2008   Improved doc 




7000




 





 





 





 





 





 



  0.10  Dec 2008 




7001




 





 





 





 





 





 



   




7002




 





 





 





 





 





 



 =head1 SEE ALSO 




7003




 





 





 





 





 





 



   




7004




 





 





 





 





 





 



 L 




7005




 





 





 





 





 





 



   




7006




 





 





 





 





 





 



 =head1 AUTHOR 




7007




 





 





 





 





 





 



   




7008




 





 





 





 





 





 



 Kjetil Skotheim, [e-mail] 




7009




 





 





 





 





 





 



   




7010




 





 





 





 





 





 



 =head1 COPYRIGHT 




7011




 





 





 





 





 





 



   




7012




 





 





 





 





 





 



 1995-2015, Kjetil Skotheim 




7013




 





 





 





 





 





 



   




7014




 





 





 





 





 





 



 =head1 LICENSE 




7015




 





 





 





 





 





 



   




7016




 





 





 





 





 





 



 This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 




7017




 





 





 





 





 





 



   




7018




 





 





 





 





 





 



 =cut

Input: One or two arguments.

First argument: the html where a C<<  >> is to be found and converted. 




3536




 





 





 





 





 





 



   




3537




 





 





 





 





 





 



 Second argument: (optional) If the html contains more than one C<< 




3538




 





 





 





 





 





 



  >>, and you do not want the first one, applying a second 




3539




 





 





 





 





 





 



 argument is a way of telling C which to capture: the one with this word 




3540




 





 





 





 





 





 



 or string occurring before it. 




3541




 





 





 





 





 





 



   




3542




 





 





 





 





 





 



 Output: An array of arrayrefs. 




3543




 





 





 





 





 





 



   




3544




 





 





 





 





 





 



 C is a quick and dirty way of scraping (or harvesting as it is 




3545




 





 





 





 





 





 



 also called) data from a web page. Look too L to do this 




3546




 





 





 





 





 





 



 more accurate. 




3547




 





 





 





 





 





 



   




3548




 





 





 





 





 





 



 Example: 




3549




 





 





 





 





 





 



   




3550




 





 





 





 





 





 



  use Acme::Tools; 




3551




 





 





 





 





 





 



  use LWP::Simple; 




3552




 





 





 





 





 





 



  my $url = "http://en.wikipedia.org/wiki/List_of_countries_by_population"; 




3553




 





 





 





 





 





 



  for( ht2t( get($url), "Countries" ) ) { 




3554




 





 





 





 





 





 



    my($rank, $country, $pop) = @$_; 




3555




 





 





 





 





 





 



    $pop =~ s/,//g; 




3556




 





 





 





 





 





 



    printf "%3d | %-32s | %9d\n", @$_ if $pop>0; 




3557




 





 





 





 





 





 



  } 




3558




 





 





 





 





 





 



   




3559




 





 





 





 





 





 



 Output: 




3560




 





 





 





 





 





 



   




3561




 





 





 





 





 





 



   1 | China                            | 1367740000 




3562




 





 





 





 





 





 



   2 | India                            | 1262090000 




3563




 





 





 





 





 





 



   3 | United States                    | 319043000 




3564




 





 





 





 





 





 



   4 | Indonesia                        | 252164800 




3565




 





 





 





 





 





 



   5 | Brazil                           | 203404000 




3566




 





 





 





 





 





 



   




3567




 





 





 





 





 





 



 ...and so on. 




3568




 





 





 





 





 





 



   




3569




 





 





 





 





 





 



 =cut 




3570




 





 





 





 





 





 



   




3571




 





 





 





 





 





 



 sub ht2t { 




3572




9




  
100
  



  
100
  



  
9
  



  
1
  




451



   my($f,$s,$r)=@_; 1>@_||@_>3 and croak; $s='' if @_==1; 




 




9




  
100
  




 





 





 





314



   




 




7





 





 





 





 





17



   




3573




7





 





 





 





 





121



   $f=~s,.*?($s).*?(




3574




28





 





 




  
28
  




 





835971



   my $e=0;$e++ while index($f,$s=chr($e))>=$[; 




 




28





 





 





 





 





13345



   




 




28





 





 





 





 





104398



   




 




7





 





 





 





 





13



   




 




7





 





 





 





 





36



   




3575




7





 





 





 





 





85



   $f=~s//\l$1$s/gsi; 




3576




7





 





 





 





 





54



   $f=~s/\s*<.*?>\s*/ /gsi; 




3577




7





 





 





 





 





66



   my @t=split("r$s",$f);shift @t; 




 




7





 





 





 





 





12



   




3578




20





 





 




  
20
  




 





32



   $r||=sub{s/&(#160|nbsp);/ /g;s/&/&/g;s/^\s*(.*?)\s*$/$1/s; 




 




20





 





 





 





 





28



   




 




20





 





 





 





 





81



   




3579




7




  
100
  



  
100
  




 





 





38



 	   s/(\d) (\d)/$1$2/g if /^[\d \.\,]+$/}; 




 




20





 





 





 





 





71



   




3580




7





 





 





 





 





16



   for(@t){my @r=split/[dh]$s/;shift@r;$_=[map{&$r;$_}@r]} 




 




9





 





 





 





 





52



   




 




9





 





 





 





 





14



   




 




9





 





 





 





 





16



   




 




20





 





 





 





 





31



   




 




20





 





 





 





 





64



   




3581




7





 





 





 





 





38



   @t; 




3582




 





 





 





 





 





 



 } 




3583




 





 





 





 





 





 



   




3584




 





 





 





 





 





 



 =head1 FILES, DIRECTORIES 




3585




 





 





 





 





 





 



   




3586




 





 





 





 





 





 



 =head2 writefile 




3587




 





 





 





 





 





 



   




3588




 





 





 





 





 





 



 Justification: 




3589




 





 





 





 





 





 



   




3590




 





 





 





 





 





 



 Perl needs three or four operations to make a file out of a string: 




3591




 





 





 





 





 





 



   




3592




 





 





 





 





 





 



  open my $FILE, '>', $filename  or die $!; 




3593




 





 





 





 





 





 



  print $FILE $text; 




3594




 





 





 





 





 





 



  close($FILE); 




3595




 





 





 





 





 





 



   




3596




 





 





 





 





 





 



 This is way simpler: 




3597




 





 





 





 





 





 



   




3598




 





 





 





 





 





 



  writefile($filename,$text); 




3599




 





 





 





 





 





 



   




3600




 





 





 





 





 





 



 Sub writefile opens the file i binary mode (C) and has two usage modes: 




3601




 





 





 





 





 





 



   




3602




 





 





 





 





 





 



 B Two arguments 




3603




 





 





 





 





 





 



   




3604




 





 





 





 





 





 



 B is the filename. If the file exists, its overwritten. 




3605




 





 





 





 





 





 



 If the file can not be opened for writing, a die (a croak really) happens. 




3606




 





 





 





 





 





 



   




3607




 





 





 





 





 





 



 B is one of: 




3608




 





 





 





 





 





 



   




3609




 





 





 





 





 





 



 =over 4 




3610




 





 





 





 





 





 



   




3611




 





 





 





 





 





 



 =item * Either a scaler. That is a normal string to be written to the file. 




3612




 





 





 





 





 





 



   




3613




 





 





 





 





 





 



 =item * Or a reference to a scalar. That referred text is written to the file. 




3614




 





 





 





 





 





 



   




3615




 





 





 





 





 





 



 =item * Or a reference to an array of scalars. This array is the written to the 




3616




 





 





 





 





 





 



  file element by element and C<< \n >> is automatically appended to each element. 




3617




 





 





 





 





 





 



   




3618




 





 





 





 





 





 



 =back 




3619




 





 





 





 





 





 



   




3620




 





 





 





 





 





 



 Alternativelly, you can write several files at once. 




3621




 





 





 





 





 





 



   




3622




 





 





 





 





 





 



 Example, this: 




3623




 





 





 





 





 





 



   




3624




 





 





 





 





 





 



  writefile('file1.txt','The text....tjo'); 




3625




 





 





 





 





 





 



  writefile('file2.txt','The text....hip'); 




3626




 





 





 





 





 





 



  writefile('file3.txt','The text....and hop'); 




3627




 





 





 





 





 





 



   




3628




 





 





 





 





 





 



 ...is the same as this: 




3629




 





 





 





 





 





 



   




3630




 





 





 





 





 





 



  writefile([ 




3631




 





 





 





 





 





 



    ['file1.txt','The text....tjo'], 




3632




 





 





 





 





 





 



    ['file2.txt','The text....hip'], 




3633




 





 





 





 





 





 



    ['file3.txt','The text....and hop'], 




3634




 





 





 





 





 





 



  ]); 




3635




 





 





 





 





 





 



   




3636




 





 





 





 





 





 



 B Nothing (for the time being). Cs (C really) if something goes wrong. 




3637




 





 





 





 





 





 



   




3638




 





 





 





 





 





 



 =cut 




3639




 





 





 





 





 





 



   




3640




 





 





 





 





 





 



 #todo: use openstr() as in readfile(), transparently gzip .gz filenames and so on 




3641




 





 





 





 





 





 



 sub writefile { 




3642




4





 





 




  
4
  



  
1
  




70151



     my($filename,$text)=@_; 




3643




4




  
 50
  




 





 





 





25



     if(ref($filename) eq 'ARRAY'){ 




3644



  
0
  




 





 





 





 





0



 	writefile(@$_) for @$filename; 




3645



  
0
  




 





 





 





 





0



 	return; 




3646




 





 





 





 





 





 



     } 




3647




4




  
 50
  



  
 33
  




 





 





306



     open(WRITEFILE,">",$filename) and binmode(WRITEFILE) or croak($!); 




3648




4




  
 50
  



  
 33
  




 





 





41



     if(!defined $text or !ref($text)){ 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




3649




4





 





 





 





 





733



 	print WRITEFILE $text; 




3650




 





 





 





 





 





 



     } 




3651




 





 





 





 





 





 



     elsif(ref($text) eq 'SCALAR'){ 




3652



  
0
  




 





 





 





 





0



 	print WRITEFILE $$text; 




3653




 





 





 





 





 





 



     } 




3654




 





 





 





 





 





 



     elsif(ref($text) eq 'ARRAY'){ 




3655



  
0
  




 





 





 





 





0



 	print WRITEFILE "$_\n" for @$text; 




3656




 





 





 





 





 





 



     } 




3657




 





 





 





 





 





 



     else { 




3658



  
0
  




 





 





 





 





0



 	croak; 




3659




 





 





 





 





 





 



     } 




3660




4





 





 





 





 





167



     close(WRITEFILE); 




3661




4





 





 





 





 





15



     return; 




3662




 





 





 





 





 





 



 } 




3663




 





 





 





 





 





 



   




3664




 





 





 





 





 





 



 =head2 readfile 




3665




 





 





 





 





 





 



   




3666




 





 





 





 





 





 



 Just as with L you can read in a whole file in one operation with C. Instead of: 




3667




 





 





 





 





 





 



   




3668




 





 





 





 





 





 



  open my $FILE,'<', $filename or die $!; 




3669




 





 





 





 





 





 



  my $data = join"",<$FILE>; 




3670




 





 





 





 





 





 



  close($FILE); 




3671




 





 





 





 





 





 



   




3672




 





 





 





 





 





 



 This is simpler: 




3673




 





 





 





 





 





 



   




3674




 





 





 





 





 





 



  my $data = readfile($filename); 




3675




 





 





 





 





 





 



   




3676




 





 





 





 





 





 



 B 




3677




 





 





 





 





 





 



   




3678




 





 





 





 





 





 



 Reading the content of the file to a scalar variable: (Any content in C<$data> will be overwritten) 




3679




 





 





 





 





 





 



   




3680




 





 





 





 





 





 



  my $data; 




3681




 





 





 





 





 





 



  readfile('filename.txt',\$data); 




3682




 





 





 





 





 





 



   




3683




 





 





 





 





 





 



 Reading the lines of a file into an array: 




3684




 





 





 





 





 





 



   




3685




 





 





 





 





 





 



  my @lines; 




3686




 





 





 





 





 





 



  readfile('filnavn.txt',\@lines); 




3687




 





 





 





 





 





 



  for(@lines){ 




3688




 





 





 





 





 





 



    ... 




3689




 





 





 





 





 





 



  } 




3690




 





 





 





 





 





 



   




3691




 





 





 





 





 





 



 Note: Chomp is done on each line. That is, any newlines (C<< \n >>) will be removed. 




3692




 





 





 





 





 





 



 If C<@lines> is non-empty, this will be lost. 




3693




 





 





 





 





 





 



   




3694




 





 





 





 





 





 



 Sub readfile is context aware. If an array is expected it returns an array of the lines without a trailing C<< \n >>. 




3695




 





 





 





 





 





 



 The last example can be rewritten: 




3696




 





 





 





 





 





 



   




3697




 





 





 





 





 





 



  for(readfile('filnavn.txt')){ 




3698




 





 





 





 





 





 



    ... 




3699




 





 





 





 





 





 



  } 




3700




 





 





 





 





 





 



   




3701




 





 





 





 





 





 



 With two input arguments, nothing (undef) is returned from C. 




3702




 





 





 





 





 





 



   




3703




 





 





 





 





 





 



 =cut 




3704




 





 





 





 





 





 



   




3705




 





 





 





 





 





 



 #http://blogs.perl.org/users/leon_timmermans/2013/05/why-you-dont-need-fileslurp.html 




3706




 





 





 





 





 





 



 #todo: readfile with grep-filter code ref in a third arg (avoid reading all into mem) 




3707




 





 





 





 





 





 



   




3708




 





 





 





 





 





 



 sub readfile { 




3709




12





 





 




  
12
  



  
1
  




11518



   my($filename,$ref)=@_; 




3710




12




  
100
  




 





 





 





59



   if(@_==1){ 




3711




6




  
100
  




 





 





 





22



     if(wantarray){ my @data; readfile($filename,\@data); return @data } 




 




1





 





 





 





 





3



   




 




1





 





 





 





 





5



   




 




1





 





 





 





 





4976



   




3712




5





 





 





 





 





8



     else         { my $data; readfile($filename,\$data); return $data } 




 




5





 





 





 





 





457



   




 




5





 





 





 





 





698



   




3713




 





 





 





 





 





 



   } 




3714




 





 





 





 





 





 



   else { 




3715




6




  
 50
  




 





 





 





46



     open my $fh,openstr($filename) or croak("ERROR: readfile $! $?"); 




3716




6




  
100
  




 





 





 





30



     if   ( ref($ref) eq 'SCALAR') { $$ref=join"",<$fh> } 




 




5




  
 50
  




 





 





 





6899



   




3717




1





 





 





 





 





18



     elsif( ref($ref) eq 'ARRAY' ) { while(my $l=<$fh>){ chomp($l); push @$ref, $l } } 




 




20003





 





 





 





 





20569



   




 




20003





 





 





 





 





54199



   




3718



  
0
  




 





 





 





 





0



     else { croak "ERROR: Second arg to readfile should be a ref to a scalar og array" } 




3719




6





 





 





 





 





1166



     close($fh); 




3720




6





 





 





 





 





38



     return;#? 




3721




 





 





 





 





 





 



   } 




3722




 





 





 





 





 





 



 } 




3723




 





 





 





 





 





 



   




3724




 





 





 





 





 





 



 =head2 readdirectory 




3725




 





 





 





 





 





 



   




3726




 





 





 





 





 





 



 B 




3727




 





 





 





 





 





 



   




3728




 





 





 





 





 





 



 Name of a directory. 




3729




 





 





 





 





 





 



   




3730




 





 





 





 





 





 



 B 




3731




 





 





 





 





 





 



   




3732




 





 





 





 





 





 



 A list of all files in it, except of  C<.> and C<..>  (on linux/unix systems, all directories have a C<.> and C<..> directory). 




3733




 





 





 





 





 





 



   




3734




 





 





 





 





 





 



 The names of all types of files are returned: normal files, directories, symbolic links, 




3735




 





 





 





 





 





 



 pipes, semaphores. That is every thing shown by C except C<.> and C<..> 




3736




 





 





 





 





 





 



   




3737




 





 





 





 





 





 



 C do not recurce down into subdirectories (but see example below). 




3738




 





 





 





 





 





 



   




3739




 





 





 





 





 





 



 B 




3740




 





 





 





 





 





 



   




3741




 





 





 





 





 





 



   my @files = readdirectory("/tmp"); 




3742




 





 





 





 





 





 



   




3743




 





 





 





 





 





 



 B 




3744




 





 





 





 





 





 



   




3745




 





 





 





 





 





 



 Sometimes calling the built ins C, C and C seems a tad tedious, since this: 




3746




 





 





 





 





 





 



   




3747




 





 





 





 





 





 



  my $dir="/usr/bin"; 




3748




 





 





 





 





 





 



  opendir(D,$dir); 




3749




 





 





 





 





 





 



  my @files=map "$dir/$_", grep {!/^\.\.?$/} readdir(D); 




3750




 





 





 





 





 





 



  closedir(D); 




3751




 





 





 





 





 





 



   




3752




 





 





 





 





 





 



 Is the same as this: 




3753




 





 





 





 





 





 



   




3754




 





 





 





 





 





 



  my @files=readdirectory("/usr/bin"); 




3755




 





 





 





 





 





 



   




3756




 





 





 





 





 





 



 See also: L 




3757




 





 





 





 





 





 



   




3758




 





 





 





 





 





 



 B 




3759




 





 





 





 





 





 



   




3760




 





 





 





 





 





 



 On huge directories with perhaps tens or houndreds of thousands of 




3761




 





 





 





 





 





 



 files, readdirectory() will consume more memory than perls 




3762




 





 





 





 





 





 



 opendir/readdir. This isn't usually a concern anymore for modern 




3763




 





 





 





 





 





 



 computers with gigabytes of RAM, but might be the rationale behind 




3764




 





 





 





 





 





 



 Perls more tedious way created in the 80s.  The same argument goes for 




3765




 





 





 





 





 





 



 file slurping. On the other side it's also a good practice to never 




3766




 





 





 





 





 





 



 assume to much on available memory and the number of files if you 




3767




 





 





 





 





 





 



 don't know for certain that enough memory is available whereever your 




3768




 





 





 





 





 





 



 code is run or that the size of the directory is limited. 




3769




 





 





 





 





 





 



   




3770




 





 





 





 





 





 



 B 




3771




 





 





 





 





 





 



   




3772




 





 





 





 





 





 



 How to get all files in the C directory including all subdirectories below of any depth: 




3773




 





 





 





 





 





 



   




3774




 





 





 





 





 





 



  my @files=("/tmp"); 




3775




 





 





 





 





 





 



  map {-d $_ and unshift @files,$_ or push @files,$_} readdirectory(shift(@files)) while -d $files[0]; 




3776




 





 





 





 





 





 



   




3777




 





 





 





 





 





 



 ...or to avoid symlinks and only get real files: 




3778




 





 





 





 





 





 



   




3779




 





 





 





 





 





 



  map {-d and !-l and unshift @files,$_ or -f and !-l and push @files,$_} readdirectory(shift(@files)) while -d $files[0]; 




3780




 





 





 





 





 





 



   




3781




 





 





 





 





 





 



 =cut 




3782




 





 





 





 





 





 



   




3783




 





 





 





 





 





 



 sub readdirectory { 




3784



  
0
  




 





 




  
0
  



  
1
  




0



   my $dir=shift; 




3785



  
0
  




 





 





 





 





0



   opendir(my $D,$dir); 




3786



  
0
  




 





 





 





 





0



   my @filer=map "$dir/$_", grep {!/^\.\.?$/} readdir($D); 




 



  
0
  




 





 





 





 





0



   




3787



  
0
  




 





 





 





 





0



   closedir($D); 




3788



  
0
  




 





 





 





 





0



   return @filer; 




3789




 





 





 





 





 





 



 } 




3790




 





 





 





 





 





 



   




3791




 





 





 





 





 





 



 =head2 basename 




3792




 





 





 





 





 





 



   




3793




 





 





 





 





 





 



 The basename and dirname functions behaves like the *nix shell commands with the same names. 




3794




 





 





 





 





 





 



   




3795




 





 





 





 





 





 



 B One or two arguments: Filename and an optional suffix 




3796




 





 





 





 





 





 



   




3797




 





 





 





 





 





 



 B Returns the filename with any directory and (if given) the suffix removed. 




3798




 





 





 





 





 





 



   




3799




 





 





 





 





 





 



  basename('/usr/bin/perl')                   # returns 'perl' 




3800




 





 





 





 





 





 



  basename('/usr/local/bin/report.pl','.pl')  # returns 'report' since .pl at the end is removed 




3801




 





 





 





 





 





 



  basename('report2.pl','.pl')                # returns 'report2' 




3802




 





 





 





 





 





 



  basename('report2.pl','.\w+')               # returns 'report2.pl', probably not what you meant 




3803




 





 





 





 





 





 



  basename('report2.pl',qr/.\w+/)             # returns 'report2', use qr for regex 




3804




 





 





 





 





 





 



   




3805




 





 





 





 





 





 



 =head2 dirname 




3806




 





 





 





 





 





 



   




3807




 





 





 





 





 





 



 B A filename including path 




3808




 





 





 





 





 





 



   




3809




 





 





 





 





 





 



 B Removes the filename path and returns just the directory path up until but not including 




3810




 





 





 





 





 





 



 the last /. Return just a one char C<< . >> (period string) if there is no directory in the input. 




3811




 





 





 





 





 





 



   




3812




 





 





 





 





 





 



  dirname('/usr/bin/perl')                    # returns '/usr/bin' 




3813




 





 





 





 





 





 



  dirname('perl')                             # returns '.' 




3814




 





 





 





 





 





 



   




3815




 





 





 





 





 





 



 =head2 username 




3816




 





 





 





 





 





 



   




3817




 





 





 





 





 





 



 Returns the current linux/unix username, for example the string root 




3818




 





 





 





 





 





 



   




3819




 





 





 





 





 





 



  print username();                        #just (getpwuid($<))[0] but more readable perhaps 




3820




 





 





 





 





 





 



   




3821




 





 





 





 





 





 



 =cut 




3822




 





 





 





 





 





 



   




3823




8




  
100
  




 




  
8
  



  
1
  




3286



 sub basename { my($f,$s)=(@_,'');$s=quotemeta($s)if!ref($s);$f=~m,^(.*/)?([^/]*?)($s)?$,;$2 } 




 




8





 





 





 





 





25



   




 




8





 





 





 





 





226



   




 




8





 





 





 





 





38



   




3824




2




  
100
  



  
 66
  



  
2
  



  
1
  




438



 sub dirname  { $_[0]=~m,^(.*)/,;defined($1) && length($1) ? $1 : '.' } 




 




2





 





 





 





 





23



   




3825



  
0
  




 





 




  
0
  



  
1
  




0



 sub username { (getpwuid($<))[0] } 




3826




 





 





 





 





 





 



   




3827




 





 





 





 





 





 



 =head2 wipe 




3828




 





 





 





 





 





 



   




3829




 





 





 





 





 





 



 Deletes a file by "wiping" it on the disk. Overwrites the file before deleting. (May not work properly on SSDs) 




3830




 





 





 





 





 





 



   




3831




 





 





 





 





 





 



 B 




3832




 





 





 





 





 





 



 * Arg 1: A filename 




3833




 





 





 





 





 





 



 * Optional arg 2: number of times to overwrite file. Default is 3 if omitted, 0 or undef 




3834




 





 





 





 





 





 



 * Optional arg 3: keep (true/false), wipe() but no delete of file 




3835




 





 





 





 





 





 



   




3836




 





 





 





 





 





 



 B Same as the C (remove file): 1 for success, 0 or false for failure. 




3837




 





 





 





 





 





 



   




3838




 





 





 





 





 





 



 See also: L, L 




3839




 





 





 





 





 





 



   




3840




 





 





 





 





 





 



 =cut 




3841




 





 





 





 





 





 



   




3842




 





 





 





 





 





 



 sub wipe { 




3843




2





 





 




  
2
  



  
1
  




704



   my($file,$times,$keep)=@_; 




3844




2





 




  
100
  




 





 





14



   $times||=3; 




3845




2




  
 50
  



  
 33
  




 





 





82



   croak "ERROR: File $file nonexisting\n" if not -f $file or not -e $file; 




3846




2





 





 





 





 





28



   my $size=-s$file; 




3847




2




  
 50
  




 





 





 





78



   open my $WIFH, '+<', $file or croak "ERROR: Unable to open $file: $!\n"; 




3848




2





 





 





 





 





5



   binmode($WIFH); 




3849




2





 





 





 





 





8



   for(1..$times){ 




3850




4





 





 





 





 





16



     my $block=chr(int(rand(256))) x 1024;#hm 




3851




4





 





 





 





 





10



     for(0..($size/1024)){ 




3852




73





 





 





 





 





521



       seek($WIFH,$_*1024,0); 




3853




73





 





 





 





 





142



       print $WIFH $block; 




3854




 





 





 





 





 





 



     } 




3855




 





 





 





 





 





 



   } 




3856




2





 





 





 





 





30



   close($WIFH); 




3857




2




  
100
  




 





 





 





141



   $keep || unlink($file); 




3858




 





 





 





 





 





 



 } 




3859




 





 





 





 





 





 



   




3860




 





 





 





 





 





 



 =head2 chall 




3861




 





 





 





 





 





 



   




3862




 





 





 





 





 





 



 Does chmod + utime + chown on one or more files. 




3863




 





 





 





 





 





 



   




3864




 





 





 





 





 





 



 Returns the number of files of which those operations was successful. 




3865




 





 





 





 





 





 



   




3866




 





 





 





 





 





 



 Mode, uid, gid, atime and mtime are set from the array ref in the first argument. 




3867




 





 





 





 





 





 



   




3868




 





 





 





 





 





 



 The first argument references an array which is exactly like an array returned from perls internal C -function. 




3869




 





 





 





 





 





 



   




3870




 





 





 





 





 





 



 Example: 




3871




 





 





 





 





 





 



   




3872




 





 





 





 





 





 



  my @stat=stat($filenameA); 




3873




 





 





 





 





 





 



  chall( \@stat,       $filenameB, $filenameC, ... );  # by stat-array 




3874




 





 





 





 





 





 



  chall( $filenameA,   $filenameB, $filenameC, ... );  # by file name 




3875




 





 





 





 





 





 



   




3876




 





 





 





 





 





 



 Copies the chmod, owner, group, access time and modify time from file A to file B and C. 




3877




 





 





 





 





 





 



   




3878




 





 





 





 





 





 



 See C, C, C, C 




3879




 





 





 





 





 





 



   




3880




 





 





 





 





 





 



 =cut 




3881




 





 





 





 





 





 



   




3882




 





 





 





 





 





 



   




3883




 





 





 





 





 





 



 sub chall { 




3884




 





 





 





 





 





 



   my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks ) 




3885




1




  
 50
  




 




  
1
  



  
1
  




28244



     = ref($_[0]) ? @{shift()} : stat(shift()); 




 




1





 





 





 





 





4



   




3886




1





 





 





 





 





2



   my $successful=0; 




3887




1




  
 50
  



  
 33
  




 





 





4



   for(@_){ chmod($mode,$_) && utime($atime,$mtime,$_) && chown($uid,$gid,$_) && $successful++ } 




 




1





 




  
 33
  




 





 





73



   




3888




1





 





 





 





 





3



   return $successful; 




3889




 





 





 





 





 





 



 } 




3890




 





 





 





 





 





 



   




3891




 





 





 





 





 





 



 =head2 makedir 




3892




 





 





 





 





 





 



   




3893




 





 





 





 





 





 



 Input: One or two arguments. 




3894




 





 





 





 





 





 



   




3895




 





 





 





 





 





 



 Works like perls C except that C will create nesessary parent directories if they dont exists. 




3896




 





 





 





 





 





 



   




3897




 





 





 





 





 





 



 First input argument: A directory name (absolute, starting with C< / > or relative). 




3898




 





 





 





 





 





 



   




3899




 





 





 





 





 





 



 Second input argument: (optional) permission bits. Using the normal C<< 0777^umask() >> as the default if no second input argument is provided. 




3900




 





 





 





 





 





 



   




3901




 





 





 





 





 





 



 Example: 




3902




 





 





 





 





 





 



   




3903




 





 





 





 





 





 



  makedir("dirB/dirC") 




3904




 





 





 





 





 





 



   




3905




 





 





 





 





 





 



 ...will create directory C if it does not already exists, to be able to create C inside C. 




3906




 





 





 





 





 





 



   




3907




 





 





 





 





 





 



 Returns true on success, otherwise false. 




3908




 





 





 





 





 





 



   




3909




 





 





 





 





 





 



 C memoizes directories it has checked for existence before (trading memory and for speed). 




3910




 





 





 





 





 





 



 Thus directories removed during running the script is not discovered by makedir. 




3911




 





 





 





 





 





 



   




3912




 





 





 





 





 





 



 See also C<< perldoc -f mkdir >>, C<< man umask >> 




3913




 





 





 





 





 





 



   




3914




 





 





 





 





 





 



 =cut 




3915




 





 





 





 





 





 



   




3916




 





 





 





 





 





 



 our %MAKEDIR; 




3917




 





 





 





 





 





 



   




3918




 





 





 





 





 





 



 sub makedir { 




3919



  
0
  




 





 




  
0
  



  
1
  




0



   my($d,$p,$dd)=@_; 




3920



  
0
  



  
  0
  




 





 





 





0



   $p=0777^umask() if !defined$p; 




3921




 





 





 





 





 





 



   ( 




3922




 





 





 





 





 





 



   $MAKEDIR{$d} or -d$d or mkdir($d,$p) #or croak("mkdir $d, $p") 




3923




 





 





 





 





 





 



   or ($dd)=($d=~m,^(.+)/+([^/]+)$,) and makedir($dd,$p) and mkdir($d,$p) #or die; 




3924



  
0
  



  
  0
  



  
  0
  




 





 





0



   ) and ++$MAKEDIR{$d}; 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




3925




 





 





 





 





 





 



 } 




3926




 





 





 





 





 





 



   




3927




 





 





 





 





 





 



 =head2 md5sum 




3928




 





 





 





 





 





 



   




3929




 





 





 





 





 





 



 B a filename. 




3930




 





 





 





 





 





 



   




3931




 





 





 





 





 





 



 B a string of 32 hexadecimal chars from 0-9 or a-f. 




3932




 





 





 





 





 





 



   




3933




 





 





 





 





 





 



 Example, the md5sum gnu/linux command without options could be implementet like this: 




3934




 





 





 





 





 





 



   




3935




 





 





 





 





 





 



  use Acme::Tools; 




3936




 





 





 





 





 





 



  print eval{ md5sum($_)."  $_\n" } || $@ for @ARGV; 




3937




 





 





 





 





 





 



   




3938




 





 





 





 





 





 



 This sub requires L, which is a core perl-module since 




3939




 





 





 





 





 





 



 version 5.?.?  It does not slurp the files or spawn new processes. 




3940




 





 





 





 





 





 



   




3941




 





 





 





 





 





 



 =cut 




3942




 





 





 





 





 





 



   




3943




 





 





 





 





 





 



 sub md5sum { 




3944




2





 





 




  
2
  



  
1
  




18



   require Digest::MD5; 




3945




2





 





 





 





 





4



   my $fn=shift; 




3946




2




  
100
  




 





 





 





212



   croak "md5sum: $fn is a directory (no md5sum)" if -d $fn; 




3947




1




  
 50
  




 





 





 





34



   open my $FH, '<', $fn or croak "Could not open file $fn for md5sum() $!"; 




3948




1





 





 





 





 





2



   binmode($FH); 




3949




1





 





 





 





 





3



   my $r = eval { Digest::MD5->new->addfile($FH)->hexdigest }; 




 




1





 





 





 





 





19



   




3950




1




  
 50
  




 





 





 





8



   croak "md5sum on $fn failed ($@)\n" if $@; 




3951




1





 





 





 





 





16



   $r; 




3952




 





 





 





 





 





 



 } 




3953




 





 





 





 





 





 



   




3954




 





 





 





 





 





 



 =head2 read_conf 




3955




 





 





 





 





 





 



   




3956




 





 





 





 





 





 



 B A file name or a reference to a string with settings in the format described below. 




3957




 





 





 





 





 





 



   




3958




 





 





 





 





 





 



 B A reference to a hash. This hash will have the settings from the file (or stringref). 




3959




 





 





 





 





 





 



 The hash do not have to be empty beforehand. 




3960




 





 





 





 





 





 



   




3961




 





 





 





 





 





 



 Returns a hash with the settings as in this examples: 




3962




 





 





 





 





 





 



   




3963




 





 





 





 





 





 



  my %conf = read_conf('/etc/your/thing.conf'); 




3964




 





 





 





 





 





 



  print $conf{sectionA}{knobble};  #prints ABC if the file is as shown below 




3965




 





 





 





 





 





 



  print $conf{sectionA}{gobble};   #prints ZZZ, the last gobble 




3966




 





 





 





 





 





 



  print $conf{switch};             #prints OK here as well, unsectioned value 




3967




 





 





 





 





 





 



  print $conf{part2}{password};    #prints oh:no= x 




3968




 





 





 





 





 





 



   




3969




 





 





 





 





 





 



 File use for the above example: 




3970




 





 





 





 





 





 



   




3971




 





 





 





 





 





 



  switch:    OK       #before first section, the '' (empty) section 




3972




 





 





 





 





 





 



  [sectionA] 




3973




 





 





 





 





 





 



  knobble:   ABC 




3974




 





 





 





 





 





 



  gobble:    XYZ      #this gobble is overwritten by the gobble on the next line 




3975




 





 





 





 





 





 



  gobble:    ZZZ 




3976




 





 





 





 





 





 



  [part2] 




3977




 





 





 





 





 





 



  password:  oh:no= x  #should be better 




3978




 





 





 





 





 





 



  text:      { values starting with { continues 




3979




 





 





 





 





 





 



               until reaching a line with } 




3980




 





 





 





 





 





 



   




3981




 





 





 





 





 





 



 Everything from # and behind is regarded comments and ignored. Comments can be on any line. 




3982




 





 





 





 





 





 



 To keep a # char, put a \ in front of it. 




3983




 





 





 





 





 





 



   




3984




 





 





 





 





 





 



 A C< : > or C< = > separates keys and values.  Spaces at the beginning or end of lines are 




3985




 





 





 





 





 





 



 ignored (after removal of #comments), as are any spaces before and after : and = separators. 




3986




 





 





 





 





 





 



   




3987




 





 





 





 





 





 



 Empty lines or lines with no C< : > or C< = > is also ignored. Keys and values can contain 




3988




 





 





 





 





 





 



 internal spaces and tabs, but not at the beginning or end. 




3989




 





 





 





 





 





 



   




3990




 





 





 





 





 





 



 Multi-line values must start and end with { and }. Using { and } keep spaces at the start 




3991




 





 





 





 





 





 



 or end in both one-line and multi-line values. 




3992




 





 





 





 





 





 



   




3993




 





 





 





 





 





 



 Sections are marked with C<< [sectionname] >>.  Section names, keys and values is case 




3994




 





 





 





 





 





 



 sensitive. C above the first section or below and empty C<< [] >> is placed 




3995




 





 





 





 





 





 



 both in the empty section in the returned hash and as top level key/values. 




3996




 





 





 





 





 





 



   




3997




 





 





 





 





 





 



 C can be a simpler alternative to the core module L which has 




3998




 





 





 





 





 





 



 its own hassles. 




3999




 





 





 





 





 





 



   




4000




 





 





 





 





 





 



  $Acme::Tools::Read_conf_empty_section=1;        #default 0 (was 1 in version 0.16) 




4001




 





 





 





 





 





 



  my %conf = read_conf('/etc/your/thing.conf'); 




4002




 





 





 





 





 





 



  print $conf{''}{switch};                        #prints OK with the file above 




4003




 





 





 





 





 





 



  print $conf{switch};                            #prints OK here as well 




4004




 





 





 





 





 





 



   




4005




 





 





 





 





 





 



 =cut 




4006




 





 





 





 





 





 



   




4007




 





 





 





 





 





 



 our $Read_conf_empty_section=0; 




4008




 





 





 





 





 





 



 sub read_conf { 




4009




3





 





 




  
3
  



  
1
  




18



   my($fn,$hr)=(@_,{}); 




4010




3




  
100
  




 





 





 





14



   my $conf=ref($fn)?$$fn:readfile($fn); 




4011




3





 





 





 





 





101



   $conf=~s,\s*(?




4012




3





 





 





 





 





32



   my($section,@l)=('',split"\n",$conf); 




4013




3





 





 





 





 





12



   while(@l) { 




4014




63





 





 





 





 





93



     my $l=shift@l; 




4015




63




  
100
  




 





 





 





330



     if( $l=~/^\s*\[\s*(.*?)\s*\]/ ) { 




 




 




  
100
  




 





 





 





 



   




4016




12





 





 





 





 





22



       $section=$1; 




4017




12





 




  
100
  




 





 





68



       $$hr{$1}||={}; 




4018




 





 





 





 





 





 



     } 




4019




 





 





 





 





 





 



     elsif( $l=~/^\s*([^\:\=]+)[:=]\s*(.*?)\s*$/ ) { 




4020




33





 




  
 66
  



  
33
  




 





108



       my $ml=sub{my$v=shift;$v.="\n".shift@l while $v=~/^\{[^\}]*$/&&@l;$v=~s/^\{(.*)\}\s*$/$1/s;$v=~s,\\#,#,g;$v}; 




 




33





 





 





 





 





71



   




 




33





 





 





 





 





168



   




 




33





 





 





 





 





68



   




 




33





 





 





 





 





52



   




 




33





 





 





 





 





60



   




4021




33





 





 





 





 





71



       my $v=&$ml($2); 




4022




33




  
100
  



  
 66
  




 





 





145



       $$hr{$section}{$1}=$v if length($section) or $Read_conf_empty_section; 




4023




33




  
100
  




 





 





 





175



       $$hr{$1}=$v if !length($section); 




4024




 





 





 





 





 





 



     } 




4025




 





 





 





 





 





 



   } 




4026




3





 





 





 





 





25



   %$hr; 




4027




 





 





 





 





 





 



 } 




4028




 





 





 





 





 





 



 #  my $incfn=sub{return $1 if $_[0]=~m,^(/.+),;my$f=$fn;$f=~s,[^/]+$,$_[0],;$f}; 




4029




 





 





 





 





 





 



 #    s,]+)>,"".readfile(&$incfn($1)),eg; #todo 




4030




 





 





 





 





 





 



   




4031




 





 





 





 





 





 



   




4032




 





 





 





 





 





 



 =head2 openstr 




4033




 





 





 





 





 





 



   




4034




 





 





 





 





 





 



                                             # returned from openstr: 




4035




 





 





 





 





 





 



   open my $FH, openstr("fil.txt")  or die;  # fil.txt 




4036




 





 





 





 





 





 



   open my $FH, openstr("fil.gz")   or die;  # zcat fil.gz | 




4037




 





 





 





 





 





 



   open my $FH, openstr("fil.bz2")  or die;  # bzcat fil.bz2 | 




4038




 





 





 





 





 





 



   open my $FH, openstr("fil.xz")   or die;  # xzcat fil.xz | 




4039




 





 





 





 





 





 



   open my $FH, openstr(">fil.txt") or die;  # > fil.txt 




4040




 





 





 





 





 





 



   open my $FH, openstr(">fil.gz")  or die;  # | gzip > fil.gz 




4041




 





 





 





 





 





 



   open my $FH, openstr(">fil.bz2") or die;  # | bzip2 > fil.bz2 




4042




 





 





 





 





 





 



   open my $FH, openstr(">fil.xz")  or die;  # | xz    > fil.bz2 




4043




 





 





 





 





 





 



   




4044




 





 





 





 





 





 



 Environment variable PATH is used. So in the examples above, /bin/gzip 




4045




 





 





 





 





 





 



 is returned instead of gzip if /bin is the first directory in 




4046




 





 





 





 





 





 



 $ENV{PATH} containing an executable file gzip. Dirs /usr/bin, /bin and 




4047




 





 





 





 





 





 



 /usr/local/bin is added to PATH in openstr(). They are checked even if 




4048




 





 





 





 





 





 



 PATH is empty. 




4049




 





 





 





 





 





 



   




4050




 





 





 





 





 





 



 =cut 




4051




 





 





 





 





 





 



   




4052




 





 





 





 





 





 



 our @Openstrpath=(grep$_,split(":",$ENV{PATH}),qw(/usr/bin /bin /usr/local/bin)); 




4053




 





 





 





 





 





 



 sub openstr { 




4054




14





 





 




  
14
  



  
1
  




4221



   my($fn,$ext)=(shift()=~/^(.*?(?:\.(t?gz|bz2|xz))?)$/i); 




4055




14




  
100
  




 





 





 





389



   return $fn if !$ext; 




4056




6




  
 50
  




 




  
6
  




 





42



   my $prog=sub{@Openstrpath or return $_[0];(grep -x$_, map "$_/$_[0]", @Openstrpath)[0] or die}; 




 




6




  
 50
  




 





 





 





26



   




 




6





 





 





 





 





108929



   




4057




 





 





 





 





 





 



   $fn =~ /^\s*>/ 




4058




 





 





 





 





 





 



       ?  "| ".(&$prog({qw/tgz gzip gz gzip bz2 bzip2 xz xz/   }->{lc($ext)})).$fn 




4059




6




  
100
  




 





 





 





89



       :        &$prog({qw/tgz zcat gz zcat bz2 bzcat xz xzcat/}->{lc($ext)})." $fn |"; 




4060




 





 





 





 





 





 



 } 




4061




 





 





 





 





 





 



   




4062




 





 





 





 





 





 



 =head1 TIME FUNCTIONS 




4063




 





 





 





 





 





 



   




4064




 





 





 





 





 





 



 =head2 tms - timestring, works somewhat like the Gnu/Linux C command and Oracle's C 




4065




 





 





 





 





 





 



   




4066




 





 





 





 





 





 



 Converts timestamps to more readable forms of time strings. 




4067




 





 





 





 





 





 



   




4068




 





 





 





 





 





 



 Converts seconds since I and time strings on the form C to other forms. 




4069




 





 





 





 





 





 



   




4070




 





 





 





 





 





 



 B One, two or three arguments. 




4071




 





 





 





 





 





 



   




4072




 





 





 





 





 





 



 B A format string. 




4073




 





 





 





 





 





 



   




4074




 





 





 





 





 





 



 B An epock C number or a time 




4075




 





 





 





 





 





 



 string of the form YYYYMMDD-HH24:MI:SS or YYYYMMDDTHH:MI:SS or 




4076




 





 





 





 





 





 



 YYYY-MM-DDTHH:MI:SS (in which T is litteral and HH is the 24-hour 




4077




 





 





 





 





 





 



 version of hours) or YYYYMMDD. Uses the current C if the 




4078




 





 





 





 





 





 



 second argument is missing. 




4079




 





 





 





 





 





 



   




4080




 





 





 





 





 





 



 TODO: Formats with % as in C (C<%Y%m%d> and so on) 




4081




 





 





 





 





 





 



   




4082




 





 





 





 





 





 



 B True or false. If true and first argument 




4083




 





 





 





 





 





 



 is eight digits: Its interpreted as a date like YYYYMMDD time string, 




4084




 





 





 





 





 





 



 not an epoch time.  If true and first argument is six digits its 




4085




 





 





 





 





 





 



 interpreted as a date like DDMMYY (not YYMMDD!). 




4086




 





 





 





 





 





 



   




4087




 





 





 





 





 





 



 B a date or clock string on the wanted form. 




4088




 





 





 





 





 





 



   




4089




 





 





 





 





 





 



 B 




4090




 





 





 





 





 





 



   




4091




 





 





 





 





 





 



 Prints C<< 3. july 1997 >> if thats the dato today: 




4092




 





 





 





 





 





 



   




4093




 





 





 





 





 





 



   perl -MAcme::Tools -le 'print timestr("D. month YYYY")' 




4094




 





 





 





 





 





 



   




4095




 





 





 





 





 





 



   print tms("HH24:MI");              # prints 23:55 if thats the time now 




4096




 





 





 





 





 





 



   tms("HH24:MI",time());             # ...same,since time() is the default 




4097




 





 





 





 





 





 



   tms("HH:MI",time()-5*60);          # 23:50 if that was the time 5 minutes ago 




4098




 





 





 





 





 





 



   tms("HH:MI",time()-5*60*60);       # 18:55 if thats the time 5 hours ago 




4099




 





 





 





 





 





 



   tms("Day Month Dth YYYY HH:MI");   # Saturday July 1st 2004 23:55    (big S, big J) 




4100




 





 





 





 





 





 



   tms("Day D. Month YYYY HH:MI");    # Saturday 8. July 2004 23:55     (big S, big J) 




4101




 





 





 





 





 





 



   tms("DAY D. MONTH YYYY HH:MI");    # SATURDAY 8. JULY 2004 23:55     (upper) 




4102




 





 





 





 





 





 



   tms("dy D. month YYYY HH:MI");     # sat 8. july 2004 23:55          (small s, small j) 




4103




 





 





 





 





 





 



   tms("Dy DD. MON YYYY HH12:MI am"); # Sat 08. JUL 2004 11:55 pm       (HH12, am becomes pm if after 12) 




4104




 





 





 





 





 





 



   tms("DD-MON-YYYY");                # 03-MAY-2004                     (mon, english) 




4105




 





 





 





 





 





 



   




4106




 





 





 





 





 





 



 The following list of codes in the first argument will be replaced: 




4107




 





 





 





 





 





 



   




4108




 





 





 





 





 





 



   YYYY    Year, four digits 




4109




 





 





 





 





 





 



   YY      Year, two digits, i.e. 04 instead of 2004 




4110




 





 





 





 





 





 



   yyyy    Year, four digits, but nothing if its the current year 




4111




 





 





 





 





 





 



   YYYY|HH:MI  Year if its another year than the current, a time in hours and minutes elsewise 




4112




 





 





 





 





 





 



   MM      Month, two digits. I.e. 08 for August 




4113




 





 





 





 





 





 



   DD      Day of month, two digits. I.e. 01 (not 1) for the first day in a month 




4114




 





 





 





 





 





 



   D       Day of month, one digit. I.e. 1 (not 01) 




4115




 





 





 





 





 





 



   HH      Hour. From 00 to 23. 




4116




 





 





 





 





 





 



   HH24    Same as HH. 




4117




 





 





 





 





 





 



   HH12    12 becomes 12 (never 00), 13 becomes 01, 14 02 and so on. 




4118




 





 





 





 





 





 



           Note: 00 after midnight becomes 12 (am). Tip: always include the code 




4119




 





 





 





 





 





 



           am in a format string that uses HH12. 




4120




 





 





 





 





 





 



   MI      Minutt. Fra 00 til 59. 




4121




 





 





 





 





 





 



   SS      Sekund. Fra 00 til 59. 




4122




 





 





 





 





 





 



   am      Becomes am or pm 




4123




 





 





 





 





 





 



   pm      Same 




4124




 





 





 





 





 





 



   AM      Becomes AM or PM (upper case) 




4125




 





 





 





 





 





 



   PM      Same 




4126




 





 





 





 





 





 



   




4127




 





 





 





 





 





 



   Month   The full name of the month in English from January to December 




4128




 





 





 





 





 





 



   MONTH   Same in upper case (JANUARY) 




4129




 





 





 





 





 





 



   month   Same in lower case (january) 




4130




 





 





 





 





 





 



   Mont    Jan Feb Mars Apr May June July Aug Sep Oct Nov Dec 




4131




 





 





 





 





 





 



   Mont.   Jan. Feb. Mars Apr. May June July Aug. Sep. Oct. Nov. Dec. (always four chars) 




4132




 





 





 





 





 





 



   Mon     Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec            (always three chars) 




4133




 





 





 





 





 





 



   




4134




 





 





 





 





 





 



   Day     The full name of the weekday. Sunday to Saturday 




4135




 





 





 





 





 





 



   Dy      Three letters: Sun Mon Tue Wed Thu Fri Sat 




4136




 





 





 





 





 





 



   DAY     Upper case 




4137




 





 





 





 





 





 



   DY      Upper case 




4138




 





 





 





 





 





 



   Dth     1st 2nd 3rd 4th 5th ... 11th 12th ... 20th 21st 22nd 23rd 24th ... 30th 31st 




4139




 





 





 





 





 





 



   




4140




 





 





 





 





 





 



   WW      Week number of the year 01-53 according to the ISO8601-definition (which most countries uses) 




4141




 





 





 





 





 





 



   WWUS    Week number of the year 01-53 according to the most used definition in the USA. 




4142




 





 





 





 





 





 



           Other definitions also exists. 




4143




 





 





 





 





 





 



   




4144




 





 





 





 





 





 



   epoch   Converts a time string from YYYYMMDD-HH24:MI:SS, YYYYMMDD-HH24:MI:SS, YYYYMMDDTHH:MI:SS, 




4145




 





 





 





 





 





 



           YYYY-MM-DDTHH:MI:SS or YYYYMMDD to the number of seconds since January 1st 1970. 




4146




 





 





 





 





 





 



           Commonly known as the Unix epoch. 




4147




 





 





 





 





 





 



   




4148




 





 





 





 





 





 



   JDN     Julian day number. Integer. The number of days since the day starting at noon on January 1 4713 BC 




4149




 





 





 





 





 





 



   JD      Same as JDN but a float accounting for the time of day 




4150




 





 





 





 





 





 



   




4151




 





 





 





 





 





 



 TODO:  sub smt() (tms backward... or something better named, converts the other way) 




4152




 





 





 





 





 





 



        As to_date and to_char in Oracle. Se maybe L instead 




4153




 





 





 





 





 





 



   




4154




 





 





 





 





 





 



 B (optional) Is_date. False|true, default false. If true, the second argument is 




4155




 





 





 





 





 





 



 interpreted as a date of the form YYYYMMDD, not as a number of seconds since epoch (January 1st 1970). 




4156




 





 





 





 





 





 



   




4157




 





 





 





 





 





 



 =cut 




4158




 





 





 





 





 





 



   




4159




 





 





 





 





 





 



 #Se også L og L 




4160




 





 





 





 





 





 



   




4161




 





 





 





 





 





 



 our $Tms_pattern; 




4162




 





 





 





 





 





 



 our %Tms_str= 




4163




 





 





 





 





 





 



 	  ('MÅNED' => [4, 'JANUAR','FEBRUAR','MARS','APRIL','MAI','JUNI','JULI', 




4164




 





 





 





 





 





 



 		          'AUGUST','SEPTEMBER','OKTOBER','NOVEMBER','DESEMBER' ], 




4165




 





 





 





 





 





 



 	   'Måned' => [4, 'Januar','Februar','Mars','April','Mai','Juni','Juli', 




4166




 





 





 





 





 





 



 		          'August','September','Oktober','November','Desember'], 




4167




 





 





 





 





 





 



 	   'måned' => [4, 'januar','februar','mars','april','mai','juni','juli', 




4168




 





 





 





 





 





 



 		          'august','september','oktober','november','desember'], 




4169




 





 





 





 





 





 



 	   'MÅNE.' => [4, 'JAN.','FEB.','MARS','APR.','MAI','JUNI','JULI','AUG.','SEP.','OKT.','NOV.','DES.'], 




4170




 





 





 





 





 





 



 	   'Måne.' => [4, 'Jan.','Feb.','Mars','Apr.','Mai','Juni','Juli','Aug.','Sep.','Okt.','Nov.','Des.'], 




4171




 





 





 





 





 





 



 	   'måne.' => [4, 'jan.','feb.','mars','apr.','mai','juni','juli','aug.','sep.','okt.','nov.','des.'], 




4172




 





 





 





 





 





 



 	   'MÅNE'  => [4, 'JAN','FEB','MARS','APR','MAI','JUNI','JULI','AUG','SEP','OKT','NOV','DES'], 




4173




 





 





 





 





 





 



 	   'Måne'  => [4, 'Jan','Feb','Mars','Apr','Mai','Juni','Juli','Aug','Sep','Okt','Nov','Des'], 




4174




 





 





 





 





 





 



 	   'måne'  => [4, 'jan','feb','mars','apr','mai','juni','juli','aug','sep','okt','nov','des'], 




4175




 





 





 





 





 





 



 	   'MÅN'   => [4, 'JAN','FEB','MAR','APR','MAI','JUN','JUL','AUG','SEP','OKT','NOV','DES'], 




4176




 





 





 





 





 





 



 	   'Mån'   => [4, 'Jan','Feb','Mar','Apr','Mai','Jun','Jul','Aug','Sep','Okt','Nov','Des'], 




4177




 





 





 





 





 





 



 	   'mån'   => [4, 'jan','feb','mar','apr','mai','jun','jul','aug','sep','okt','nov','des'], 




4178




 





 





 





 





 





 



 	   'MONTH' => [4, 'JANUARY','FEBRUARY','MARCH','APRIL','MAY','JUNE','JULY', 




4179




 





 





 





 





 





 



 		          'AUGUST','SEPTEMBER','OCTOBER','NOVEMBER','DECEMBER'], 




4180




 





 





 





 





 





 



 	   'Month' => [4, 'January','February','March','April','May','June','July', 




4181




 





 





 





 





 





 



 		          'August','September','October','November','December'], 




4182




 





 





 





 





 





 



 	   'month' => [4, 'january','february','march','april','may','june','july', 




4183




 





 





 





 





 





 



 		          'august','september','october','november','december'], 




4184




 





 





 





 





 





 



 	   'MONT.' => [4, 'JAN.','FEB.','MAR.','APR.','MAY','JUNE','JULY','AUG.','SEP.','OCT.','NOV.','DEC.'], 




4185




 





 





 





 





 





 



 	   'Mont.' => [4, 'Jan.','Feb.','Mar.','Apr.','May','June','July','Aug.','Sep.','Oct.','Nov.','Dec.'], 




4186




 





 





 





 





 





 



 	   'mont.' => [4, 'jan.','feb.','mar.','apr.','may','june','july','aug.','sep.','oct.','nov.','dec.'], 




4187




 





 





 





 





 





 



 	   'MONT'  => [4, 'JAN','FEB','MAR','APR','MAY','JUNE','JULY','AUG','SEP','OCT','NOV','DEC'], 




4188




 





 





 





 





 





 



 	   'Mont'  => [4, 'Jan','Feb','Mar','Apr','May','June','July','Aug','Sep','Oct','Nov','Dec'], 




4189




 





 





 





 





 





 



 	   'mont'  => [4, 'jan','feb','mar','apr','may','june','july','aug','sep','oct','nov','dec'], 




4190




 





 





 





 





 





 



 	   'MON'   => [4, 'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'], 




4191




 





 





 





 





 





 



 	   'Mon'   => [4, 'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'], 




4192




 





 





 





 





 





 



 	   'mon'   => [4, 'jan','feb','mar','apr','may','jun','jul','aug','sep','oct','nov','dec'], 




4193




 





 





 





 





 





 



 	   'DAY'   => [6, 'SUNDAY','MONDAY','TUESDAY','WEDNESDAY','THURSDAY','FRIDAY','SATURDAY'], 




4194




 





 





 





 





 





 



 	   'Day'   => [6, 'Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'], 




4195




 





 





 





 





 





 



 	   'day'   => [6, 'sunday','monday','tuesday','wednesday','thursday','friday','saturday'], 




4196




 





 





 





 





 





 



 	   'DY'    => [6, 'SUN','MON','TUE','WED','THU','FRI','SAT'], 




4197




 





 





 





 





 





 



 	   'Dy'    => [6, 'Sun','Mon','Tue','Wed','Thu','Fri','Sat'], 




4198




 





 





 





 





 





 



 	   'dy'    => [6, 'sun','mon','tue','wed','thu','fri','sat'], 




4199




 





 





 





 





 





 



 	   'DAG'   => [6, 'SØNDAG','MANDAG','TIRSDAG','ONSDAG','TORSDAG','FREDAG','LØRDAG'], 




4200




 





 





 





 





 





 



 	   'Dag'   => [6, 'Søndag','Mandag','Tirsdag','Onsdag','Torsdag','Fredag','Lørdag'], 




4201




 





 





 





 





 





 



 	   'dag'   => [6, 'søndag','mandag','tirsdag','onsdag','torsdag','fredag','lørdag'], 




4202




 





 





 





 





 





 



 	   'DG'    => [6, 'SØN','MAN','TIR','ONS','TOR','FRE','LØR'], 




4203




 





 





 





 





 





 



 	   'Dg'    => [6, 'Søn','Man','Tir','Ons','Tor','Fre','Lør'], 




4204




 





 





 





 





 





 



 	   'dg'    => [6, 'søn','man','tir','ons','tor','fre','lør'], 




4205




 





 





 





 





 





 



 	   ); 




4206




 





 





 





 





 





 



 my $_tms_inited=0; 




4207




 





 





 





 





 





 



 sub tms_init { 




4208




1




  
 50
  




 




  
1
  



  
0
  




7



   return if $_tms_inited++; 




4209




1





 





 





 





 





5



   for(qw(MAANED Maaned maaned MAAN Maan maan),'MAANE.','Maane.','maane.'){ 




4210




9





 





 





 





 





36



     $Tms_str{$_}=$Tms_str{replace($_,"aa","å","AA","Å")}; 




4211




 





 





 





 





 





 



   } 




4212




45





 





 





 





 





121



   $Tms_pattern=join("|",map{quotemeta($_)} 




4213




1





 





 





 





 





23



 			       sort{length($b)<=>length($a)} 




 




197





 





 





 





 





402



   




4214




 





 





 





 





 





 



 			       keys %Tms_str); 




4215




 





 





 





 





 





 



   #uten sort kan "måned" bli "mared", fordi "mån"=>"mar" 




4216




 





 





 





 





 





 



 } 




4217




 





 





 





 





 





 



   




4218




 





 





 




  
0
  



  
0
  




 



 sub totime { 




4219




 





 





 





 





 





 



   




4220




 





 





 





 





 





 



 } 




4221




 





 





 





 





 





 



   




4222




 





 





 





 





 





 



 sub date_ok { 




4223



  
0
  




 





 




  
0
  



  
0
  




0



   my($y,$m,$d)=@_; 




4224



  
0
  



  
  0
  



  
  0
  




 





 





0



   return date_ok($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/; 




4225



  
0
  



  
  0
  




 





 





 





0



   return 0 if $y!~/^\d\d\d\d$/; 




4226



  
0
  



  
  0
  



  
  0
  




 





 





0



   return 0 if $m<1||$m>12||$d<1||$d>(31,$y%4||$y%100==0&&$y%400?28:29,31,30,31,30,31,31,30,31,30,31)[$m-1]; 




 




 




  
  0
  



  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




4227



  
0
  




 





 





 





 





0



   return 1; 




4228




 





 





 





 





 





 



 } 




4229




 





 





 





 





 





 



   




4230




 





 





 





 





 





 



 sub weeknum { 




4231



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



   return weeknum(tms('YYYYMMDD')) if @_<1; 




4232



  
0
  



  
  0
  



  
  0
  




 





 





0



   return weeknum($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/; 




4233



  
0
  




 





 





 





 





0



   my($year,$month,$day)= @_; 




4234



  
0
  




 





 





 





 





0



   eval{ 




4235



  
0
  



  
  0
  




 





 





 





0



     if(@_<2){ 




 




 




  
  0
  




 





 





 





 



   




4236



  
0
  



  
  0
  




 





 





 





0



       if($year=~/^\d{8}$/) { ($year,$month,$day)=unpack("A4A2A2",$year) } 




 



  
0
  



  
  0
  




 





 





 





0



   




4237



  
0
  




 





 





 





 





0



       elsif($year>99999999){ ($year,$month,$day)=(localtime($year))[5,4,3]; $year+=1900; $month++ } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




4238



  
0
  




 





 





 





 





0



       else {die} 




4239




 





 





 





 





 





 



     } 




4240



  
0
  




 





 





 





 





0



     elsif(@_!=3){croak} 




4241



  
0
  



  
  0
  




 





 





 





0



     croak if !date_ok(sprintf("%04d%02d%02d",$year,$month,$day)); 




4242




 





 





 





 





 





 



   }; 




4243



  
0
  



  
  0
  




 





 





 





0



   croak "ERROR: Wrong args Acme::Tools::weeknum(".join(",",@_).")" if $@; 




4244




28





 





 




  
28
  




 





23013



   use integer;#heltallsdivisjon 




 




28





 





 





 





 





303



   




 




28





 





 





 





 





158



   




4245



  
0
  




 





 





 





 





0



   my $y=$year+4800-(14-$month)/12; 




4246



  
0
  




 





 





 





 





0



   my $j=$day+(153*($month+(14-$month)/12*12-3)+2)/5+365*$y+$y/4-$y/100+$y/400-32045; 




4247



  
0
  




 





 





 





 





0



   my $d=($j+31741-$j%7)%146097%36524%1461; 




4248



  
0
  




 





 





 





 





0



   return (($d-$d/1460)%365+$d/1460)/7+1; 




4249




 





 





 





 





 





 



 } 




4250




 





 





 





 





 





 



   




4251




 





 





 





 





 





 



 sub tms { 




4252




40




  
 50
  



  
 66
  



  
40
  



  
1
  




56004



   return undef if @_>1 and not defined $_[1]; #time=undef => undef 




4253




40




  
100
  




 





 





 





107



   if(@_==1){ 




4254




2





 





 





 





 





15



     my @lt=localtime(); 




4255




2




  
 50
  




 





 





 





13



     $_[0] eq 'YYYY'     and return 1900+$lt[5]; 




4256




2




  
 50
  




 





 





 





9



     $_[0] eq 'YYYYMMDD' and return sprintf("%04d%02d%02d",1900+$lt[5],1+$lt[4],$lt[3]);  




4257




2




  
100
  



  
 66
  




 





 





56



     $_[0] =~ $Re_isnum  and @lt=localtime($_[0]) and return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]);  




4258




 





 





 





 





 





 



   } 




4259




39





 





 





 





 





72



   my($format,$time,$is_date)=@_; 




4260




39




  
100
  




 





 





 





96



   $time=time_fp() if !defined$time; 




4261




39




  
100
  



  
100
  




 





 





326



   ($time,$format)=($format,$time) if @_>=2 and $format=~/^[\d+\:\-\.]+$/; #swap /hm/ 




4262




39





 





 





 





 





203



   my @lt=localtime($time); 




4263




 





 





 





 





 





 



   #todo? $is_date=0 if $time=~s/^\@(\-?\d)/$1/; #@n where n is sec since epoch makes it clear that its not a formatted, as in `date` 




4264




 





 





 





 





 





 



   #todo? date --date='TZ="America/Los_Angeles" 09:00 next Fri' #`info date` 




4265




 





 





 





 





 





 



   #      Fri Nov 13 18:00:00 CET 2015 




4266




 





 





 





 





 





 



   #date --date="next Friday"  #--date or -d 




4267




 





 





 





 





 





 



   #date --date="last friday" 




4268




 





 





 





 





 





 



   #date --date="2 days ago" 




4269




 





 





 





 





 





 



   #date --date="yesterday" #or tomorrow 




4270




 





 





 





 





 





 



   #date --date="-1 day"  #date --date='10 week' 




4271




 





 





 





 





 





 



   




4272




39




  
 50
  




 





 





 





102



   if( $is_date ){ 




4273



  
0
  



  
  0
  




 




  
0
  




 





0



     my $yy2c=sub{10+$_[0]>$lt[5]%100?"20":"19"}; #hm 10+ 




 



  
0
  




 





 





 





 





0



   




4274



  
0
  



  
  0
  




 





 





 





0



     $time=totime(&$yy2c($1)."$1$2$3")."000000" if $time=~/^(\d\d)(\d\d)(\d\d)$/; 




4275



  
0
  



  
  0
  




 





 





 





0



     $time=totime("$1$2${3}000000")             if $time=~/^((?:18|19|20)\d\d)(\d\d)(\d\d)$/; #hm 18-20? 




4276




 





 





 





 





 





 



   } 




4277




 





 





 





 





 





 



   else { 




4278




39




  
 50
  




 





 





 





141



     $time = yyyymmddhh24miss_time("$1$2$3$4$5$6") #yyyymmddhh24miss_time ??? 




4279




 





 





 





 





 





 



       if $time=~/^((?:19|20|18)\d\d)          #yyyy 




4280




 





 





 





 





 





 



                   (0[1-9]|1[012])             #mm 




4281




 





 





 





 





 





 



                   (0[1-9]|[12]\d|3[01]) \-?   #dd 




4282




 





 





 





 





 





 



                   ([01]\d|2[0-3])       \:?   #hh24 




4283




 





 





 





 





 





 



                   ([0-5]\d)             \:?   #mi 




4284




 





 





 





 





 





 



                   ([0-5]\d)             $/x;  #ss 




4285




 





 





 





 





 





 



   } 




4286




39




  
100
  




 





 





 





78



   tms_init() if !$_tms_inited; 




4287




39




  
100
  




 





 





 





108



   return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]) if !$format; 




4288




38





 





 





 





 





463



   my %p=('%'=>'%', 




4289




 





 





 





 





 





 



 	 a=>'Dy', 




4290




 





 





 





 





 





 



 	 A=>'Day', 




4291




 





 





 





 





 





 



 	 b=>'Mon', 




4292




 





 





 





 





 





 



 	 b=>'Month', 




4293




 





 





 





 





 





 



 	 c=>'Dy Mon D HH:MI:SS YYYY', 




4294




 





 





 





 





 





 



 	 C=>'CC', 




4295




 





 





 





 





 





 



 	 d=>'DD', 




4296




 





 





 





 





 





 



 	 D=>'MM/DD/YY', 




4297




 





 





 





 





 





 



 	 e=>'D', 




4298




 





 





 





 





 





 



 	 F=>'YYYY-MM-DD', 




4299




 





 





 





 





 





 



         #G=>'',  




4300




 





 





 





 





 





 



 	 h=>'Month', H=>'HH24', I=>'HH12', 




4301




 





 





 





 





 





 



 	 j=>'DoY', #day of year 




4302




 





 





 





 





 





 



 	 k=>'H24', _H=>'H24', 




4303




 





 





 





 





 





 



 	 l=>'H12', _I=>'H12', 




4304




 





 





 





 





 





 



 	 m=>'MM', M=>'MI', 




4305




 





 





 





 





 





 



 	 n=>"\n", 




4306




 





 





 





 





 





 



 	#N=>'NS', #sprintf%09d,1e9*(time_fp()-time()) #000000000..999999999 




4307




 





 





 





 





 





 



 	 p=>'AM', #AM|PM upper (yes, opposite: date +%H%M%S%P%p) 




4308




 





 





 





 





 





 



 	 P=>'am', #am|pm lower 




4309




 





 





 





 





 





 



 	 S=>'SS', 




4310




 





 





 





 





 





 



 	 t=>"\t", 




4311




 





 





 





 





 





 



 	 T=>'HH24:MI:SS', 




4312




 





 





 





 





 





 



 	 u=>'DoW',  #day of week 1..7, 1=mon 7=sun 




4313




 





 





 





 





 





 



 	 w=>'DoW0', #day of week 0..6, 1=mon 0=sun 




4314




 





 





 





 





 





 



 	#U=>'WoYs', #week num of year 00..53, sunday as first day of week 




4315




 





 





 





 





 





 



 	#V=>'UKE',  #ISO week num of year 01..53, monday as first day of week 




4316




 





 





 





 





 





 



 	#W=>'WoYm', #week num of year 00..53, monday as first day of week, not ISO! 




4317




 





 





 





 





 





 



 	#x=>$ENV{locale's date representation}, #e.g. MM/DD/YY 




4318




 





 





 





 





 





 



 	#X=>$ENV{locale's time representation}, #e.g. HH/MI/SS 




4319




 





 





 





 





 





 



 	 y=>'YY', 




4320




 





 





 





 





 





 



 	 Y=>'YYYY', 




4321




 





 





 





 





 





 



 	#z=>'TZHHMI', #time zone hour minute e.g. -0430 




4322




 





 





 





 





 





 



 	#':z'=>'TZHH:MI', 




4323




 





 





 





 





 





 



 	#'::z'=>'TZHH:MI:SS', 




4324




 





 





 





 





 





 



 	#':::z'=>'TZ', #number of :'s necessary precision, e.g. -02 or +03:30 




4325




 





 





 





 





 





 



 	#Z=>'TZN', #e.g. CET, EDT, ... 




4326




 





 





 





 





 





 



       ); 




4327




38





 





 





 





 





260



   my $pkeys=join"|",keys%p; 




4328




38





 





 





 





 





1641



   $format=~s,\%($pkeys),$p{$1},g; 




4329




38





 





 





 





 





459



   $format=~s/($Tms_pattern)/$Tms_str{$1}[1+$lt[$Tms_str{$1}[0]]]/g; 




4330




38





 





 





 





 





92



   $format=~s/YYYY              / 1900+$lt[5]                    /gxe; 




 




13





 





 





 





 





44



   




4331




38




  
  0
  




 





 





 





70



   $format=~s/(\s?)yyyy         / $lt[5]==(localtime)[5]?"":$1.(1900+$lt[5])/gxe; 




 



  
0
  




 





 





 





 





0



   




4332




38





 





 





 





 





65



   $format=~s/YY                / sprintf("%02d",$lt[5]%100)     /gxei; 




 




1





 





 





 





 





5



   




4333




38





 





 





 





 





67



   $format=~s|CC                | sprintf("%02d",(1900+$lt[5])/100) |gxei; 




 




2





 





 





 





 





10



   




4334




38





 





 





 





 





59



   $format=~s/MM                / sprintf("%02d",$lt[4]+1)       /gxe; 




 




5





 





 





 





 





25



   




4335




38





 





 





 





 





56



   $format=~s/mm                / sprintf("%d",$lt[4]+1)         /gxe; 




 



  
0
  




 





 





 





 





0



   




4336




38





 





 





 





 





57



   $format=~s,M/                ,               ($lt[4]+1).'/'   ,gxe; 




 




2





 





 





 





 





7



   




4337




38





 





 





 





 





52



   $format=~s,/M                ,           '/'.($lt[4]+1)       ,gxe; 




 




1





 





 





 





 





4



   




4338




38





 





 





 





 





62



   $format=~s/DD                / sprintf("%02d",$lt[3])         /gxe; 




 




6





 





 





 





 





25



   




4339




38





 





 





 





 





110



   $format=~s/d0w|dow0          / $lt[6]                         /gxei; 




 




4





 





 





 





 





11



   




4340




38




  
100
  




 





 





 





67



   $format=~s/dow               / $lt[6]?$lt[6]:7                /gxei; 




 




2





 





 





 





 





8



   




4341




38





 





 





 





 





81



   $format=~s/d0y|doy0          / $lt[7]                         /gxei; #0-364 (365 leap) 




 




2





 





 





 





 





7



   




4342




38





 





 





 





 





117



   $format=~s/doy               / $lt[7]+1                       /gxei; #1-365 (366 leap) 




 




1





 





 





 





 





4



   




4343




38





 





 





 





 





98



   $format=~s/D(?![AaGgYyEeNn]) / $lt[3]                         /gxe; #EN pga desember og wednesday 




 




5





 





 





 





 





15



   




4344




38





 





 





 





 





55



   $format=~s/dd                / sprintf("%d",$lt[3])           /gxe; 




 



  
0
  




 





 





 





 





0



   




4345




38




  
100
  



  
 50
  




 





 





88



   $format=~s/hh12|HH12         / sprintf("%02d",$lt[2]<13?$lt[2]||12:$lt[2]-12)/gxe; 




 




8





 





 





 





 





51



   




4346




38





 





 





 





 





86



   $format=~s/HH24|HH24|HH|hh   / sprintf("%02d",$lt[2])         /gxe; 




 




4





 





 





 





 





22



   




4347




38





 





 





 





 





77



   $format=~s/MI                / sprintf("%02d",$lt[1])         /gxei; 




 




12





 





 





 





 





42



   




4348




38





 




  
100
  




 





 





68



   $format=~s{SS\.([1-9])      }{ sprintf("%0*.$1f",3+$1,$lt[0]+(repl($time,qr/^[^\.]+/)||0)) }gxei; 




 




3





 





 





 





 





21



   




4349




38





 





 





 





 





64



   $format=~s/SS                / sprintf("%02d",$lt[0])         /gxei; 




 




4





 





 





 





 





16



   




4350




38




  
100
  




 





 





 





77



   $format=~s/am|pm             / $lt[2]<13 ? 'am' : 'pm'        /gxe; 




 




4





 





 





 





 





14



   




4351




38




  
100
  




 





 





 





75



   $format=~s/AM|PM             / $lt[2]<13 ? 'AM' : 'PM'        /gxe; 




 




4





 





 





 





 





13



   




4352




38





 





 





 





 





107



   $format=~s/WWI|WW            / sprintf("%02d",weeknum($time)) /gxei; 




 



  
0
  




 





 





 





 





0



   




4353




38





 





 





 





 





60



   $format=~s/W                 / weeknum($time)                 /gxei; 




 



  
0
  




 





 





 





 





0



   




4354




38





 





 





 





 





323



   $format; 




4355




 





 





 





 





 





 



 } 




4356




 





 





 





 





 





 



   




4357




 





 





 





 





 





 



 =head2 easter 




4358




 





 





 





 





 





 



   




4359




 





 





 





 





 





 



 Input: A year (a four digit number) 




4360




 





 





 





 





 





 



   




4361




 





 





 





 





 





 



 Output: array of two numbers: day and month of Easter Sunday that year. Month 3 means March and 4 means April. 




4362




 





 





 





 





 





 



   




4363




 





 





 





 





 





 



  sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30; 




4364




 





 





 





 





 





 



              (($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) } 




4365




 





 





 





 





 





 



   




4366




 





 





 





 





 





 



 ...is a "golfed" version of Oudins algorithm (1940) L 




4367




 





 





 





 





 





 



 (see also http://www.smart.net/~mmontes/ec-cal.html ) 




4368




 





 





 





 





 





 



   




4369




 





 





 





 





 





 



 Valid for any Gregorian year. Dates repeat themselves after 70499183 




4370




 





 





 





 





 





 



 lunations = 2081882250 days = ca 5699845 years. However, our planet will 




4371




 





 





 





 





 





 



 by then have a different rotation and spin time... 




4372




 





 





 





 





 





 



   




4373




 





 





 





 





 





 



 Example: 




4374




 





 





 





 





 





 



   




4375




 





 





 





 





 





 



  ( $day, $month ) = easter( 2012 ); # $day == 8 and $month == 4 




4376




 





 





 





 





 





 



   




4377




 





 





 





 





 





 



 Example 2: 




4378




 





 





 





 





 





 



   




4379




 





 





 





 





 





 



  my @e=map sprintf("%02d%02d", reverse(easter($_))), 1800..300000; 




4380




 





 





 





 





 





 



  print "First: ".min(@e)." Last: ".max(@e)."\n"; # First: 0322 Last: 0425 




4381




 





 





 





 





 





 



   




4382




 





 





 





 





 





 



 =cut 




4383




 





 





 





 





 





 



   




4384




28





 





 




  
28
  



  
1
  




53963



 sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30; 




 




28





 





 




  
5000
  




 





52



   




 




28





 





 





 





 





124



   




 




5000





 





 





 





 





11620



   




 




5000





 





 





 





 





6188



   




 




5000





 





 





 





 





8536



   




4385




5000




  
100
  



  
 66
  




 





 





24827



              (($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) } 




4386




 





 





 





 





 





 



   




4387




 





 





 





 





 





 



   




4388




 





 





 





 





 





 



 =head2 time_fp 




4389




 





 





 





 





 





 



   




4390




 





 





 





 





 





 



 No input arguments. 




4391




 





 





 





 





 





 



   




4392




 





 





 





 





 





 



 Return the same number as perls C except with decimals (fractions of a second, _fp as in floating point number). 




4393




 





 





 





 





 





 



   




4394




 





 





 





 





 





 



  print time_fp(),"\n"; 




4395




 





 





 





 





 





 



  print time(),"\n"; 




4396




 





 





 





 





 





 



   




4397




 





 





 





 





 





 



 Could write: 




4398




 





 





 





 





 





 



   




4399




 





 





 





 





 





 



  1116776232.38632 




4400




 





 





 





 





 





 



   




4401




 





 





 





 





 





 



 ...if that is the time now. 




4402




 





 





 





 





 





 



   




4403




 





 





 





 





 





 



 Or just: 




4404




 





 





 





 





 





 



   




4405




 





 





 





 





 





 



  1116776232 




4406




 





 





 





 





 





 



   




4407




 





 





 





 





 





 



 ...from perl's internal C if C isn't installed and available. 




4408




 





 





 





 





 





 



   




4409




 





 





 





 





 





 



   




4410




 





 





 





 





 





 



 =cut 




4411




 





 





 





 





 





 



   




4412




 





 





 





 





 





 



 sub time_fp {  # {return 0+gettimeofday} is just as well? 




4413




12416




  
 50
  




 




  
12416
  



  
1
  




19116



     eval{ require Time::HiRes } or return time(); 




 




12416





 





 





 





 





75841



   




4414




12416





 





 





 





 





47644



     my($sec,$mic)=Time::HiRes::gettimeofday(); 




4415




12416





 





 





 





 





53145



     return $sec+$mic/1e6; #1e6 not portable? 




4416




 





 





 





 





 





 



 } 




4417




 





 





 





 





 





 



   




4418




 





 





 





 





 





 



 =head2 sleep_fp 




4419




 





 





 





 





 





 



   




4420




 





 





 





 





 





 



 sleep_fp() work as the built in C<< sleep() >> but also accepts fractional seconds: 




4421




 





 





 





 





 





 



   




4422




 





 





 





 





 





 



  sleep_fp(0.020);  # sleeps for 20 milliseconds 




4423




 





 





 





 





 





 



   




4424




 





 





 





 





 





 



 Sub sleep_fp do a C, thus it might take some 




4425




 





 





 





 





 





 



 extra time the first call. To avoid that, add C<< use Time::HiRes >> 




4426




 





 





 





 





 





 



 to your code. Sleep_fp should not be trusted for accuracy to more than 




4427




 





 





 





 





 





 



 a tenth of a second. Virtual machines tend to be less accurate (sleep 




4428




 





 





 





 





 





 



 longer) than physical ones. This was tested on VMware and RHEL 




4429




 





 





 





 





 





 



 (Linux). See also L. 




4430




 





 





 





 





 





 



   




4431




 





 





 





 





 





 



 =head2 sleeps 




4432




 





 





 





 





 





 



   




4433




 





 





 





 





 





 



 =head2 sleepms 




4434




 





 





 





 





 





 



   




4435




 





 





 





 





 





 



 =head2 sleepus 




4436




 





 





 





 





 





 



   




4437




 





 





 





 





 





 



 =head2 sleepns 




4438




 





 





 





 





 





 



   




4439




 





 





 





 





 





 



  sleep_fp(0.020);   #sleeps for 20 milliseconds 




4440




 





 





 





 





 





 



  sleeps(0.020);     #sleeps for 20 milliseconds, sleeps() is a synonym to sleep_fp() 




4441




 





 





 





 





 





 



  sleepms(20);       #sleeps for 20 milliseconds 




4442




 





 





 





 





 





 



  sleepus(20000);    #sleeps for 20000 microseconds = 20 milliseconds 




4443




 





 





 





 





 





 



  sleepns(20000000); #sleeps for 20 million nanoseconds = 20 milliseconds 




4444




 





 





 





 





 





 



   




4445




 





 





 





 





 





 



 =cut 




4446




 





 





 





 





 





 



   




4447




13




  
 50
  




 




  
13
  



  
1
  




81



 sub sleep_fp { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) } 




 




13





 





 





 





 





156



   




 




13





 





 





 





 





221802



   




4448




1




  
 50
  




 




  
1
  



  
1
  




12



 sub sleeps   { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) } 




 




1





 





 





 





 





14



   




 




1





 





 





 





 





10162



   




4449




1




  
 50
  




 




  
1
  



  
1
  




18



 sub sleepms  { eval{require Time::HiRes} or (sleep(shift()/1e3),return);Time::HiRes::sleep(shift()/1e3) } 




 




1





 





 





 





 





24



   




 




1





 





 





 





 





10168



   




4450




1




  
 50
  




 




  
1
  



  
1
  




14



 sub sleepus  { eval{require Time::HiRes} or (sleep(shift()/1e6),return);Time::HiRes::sleep(shift()/1e6) } 




 




1





 





 





 





 





21



   




 




1





 





 





 





 





10158



   




4451




1




  
 50
  




 




  
1
  



  
1
  




13



 sub sleepns  { eval{require Time::HiRes} or (sleep(shift()/1e9),return);Time::HiRes::sleep(shift()/1e9) } 




 




1





 





 





 





 





19



   




 




1





 





 





 





 





10140



   




4452




 





 





 





 





 





 



   




4453




 





 





 





 





 





 



 =head2 eta 




4454




 





 





 





 





 





 



   




4455




 





 





 





 





 





 



 Estimated time of arrival (ETA). 




4456




 





 





 





 





 





 



   




4457




 





 





 





 





 





 



  for(@files){ 




4458




 





 





 





 





 





 



     ...do work on file... 




4459




 





 





 





 





 





 



     my $eta = eta( ++$i, 0+@files ); # file now, number of files 




4460




 





 





 





 





 





 



     print "" . localtime($eta); 




4461




 





 





 





 





 





 



  } 




4462




 





 





 





 





 





 



   




4463




 





 





 





 





 





 



  ..DOC MISSING.. 




4464




 





 





 





 





 





 



   




4465




 





 





 





 





 





 



 =head2 etahhmm 




4466




 





 





 





 





 





 



   




4467




 





 





 





 





 





 



  ...NOT YET 




4468




 





 





 





 





 





 



   




4469




 





 





 





 





 





 



 =cut 




4470




 





 





 





 





 





 



   




4471




 





 





 





 





 





 



 #http://en.wikipedia.org/wiki/Kalman_filter god idé? 




4472




 





 





 





 





 





 



 our %Eta; 




4473




 





 





 





 





 





 



 our $Eta_forgetfulness=2; 




4474




 





 





 





 





 





 



 sub eta { 




4475




2004




  
100
  




 




  
2004
  



  
1
  




15296



   my($id,$pos,$end,$time_fp)=( @_==2 ? (join(";",caller()),@_) : @_ ); 




4476




2004





 




  
 66
  




 





 





4544



   $time_fp||=time_fp(); 




4477




2004





 




  
100
  




 





 





4853



   my $a=$Eta{$id}||=[]; 




4478




2004





 





 





 





 





4265



   push @$a, [$pos,$time_fp]; 




4479




2004




  
100
  




 





 





 





5365



   @$a=@$a[map$_*2,0..@$a/2] if @$a>40;  #hm 40 




4480




2004




  
100
  



  
100
  




 





 





9090



   splice(@$a,-2,1) if @$a>1 and $$a[-2][0]==$$a[-1][0]; #same pos as last 




4481




2004




  
100
  




 





 





 





4117



   return undef if @$a<2; 




4482




2001





 





 





 





 





2410



   my @eta; 




4483




2001





 





 





 





 





3755



   for(2..@$a){ 




4484




58602





 





 





 





 





158569



     push @eta, $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-$_][1])/($$a[-1][0]-$$a[-$_][0]); 




4485




 





 





 





 





 





 



   } 




4486




2001





 





 





 





 





2940



   my($sum,$sumw,$w)=(0,0,1); 




4487




2001





 





 





 





 





3107



   for(@eta){ 




4488




58602





 





 





 





 





74926



     $sum+=$w*$_; 




4489




58602





 





 





 





 





70451



     $sumw+=$w; 




4490




58602





 





 





 





 





83675



     $w/=$Eta_forgetfulness; 




4491




 





 





 





 





 





 



   } 




4492




2001





 





 





 





 





2729



   my $avg=$sum/$sumw; 




4493




2001





 





 





 





 





6189



   return $avg; 




4494




 





 





 





 





 





 



 #  return avg(@eta); 




4495




 





 





 





 





 





 



  #return $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-2][1])/($$a[-1][0]-$$a[-2][0]); 




4496



  
0
  




 





 





 





 





0



   1; 




4497




 





 





 





 





 





 



 } 




4498




 





 





 





 





 





 



   




4499




 





 





 





 





 





 



 =head2 sleep_until 




4500




 





 





 





 





 





 



   




4501




 





 





 





 





 





 



 sleep_until(0.5) sleeps until half a second has passed since the last 




4502




 





 





 





 





 





 



 call to sleep_until. This example starts the next job excactly ten 




4503




 





 





 





 





 





 



 seconds after the last job started even if the last job lasted for a 




4504




 





 





 





 





 





 



 while (but not more than ten seconds): 




4505




 





 





 





 





 





 



   




4506




 





 





 





 





 





 



  for(@jobs){ 




4507




 





 





 





 





 





 



    sleep_until(10); 




4508




 





 





 





 





 





 



    print localtime()."\n"; 




4509




 





 





 





 





 





 



    ...heavy job.... 




4510




 





 





 





 





 





 



  } 




4511




 





 





 





 





 





 



   




4512




 





 





 





 





 





 



 Might print: 




4513




 





 





 





 





 





 



   




4514




 





 





 





 





 





 



  Thu Jan 12 16:00:00 2012 




4515




 





 





 





 





 





 



  Thu Jan 12 16:00:10 2012 




4516




 





 





 





 





 





 



  Thu Jan 12 16:00:20 2012 




4517




 





 





 





 





 





 



   




4518




 





 





 





 





 





 



 ...and so on even if the C<< ...heavy job... >>-part takes more than a 




4519




 





 





 





 





 





 



 second to complete. Whereas if sleep(10) was used, each job would 




4520




 





 





 





 





 





 



 spend more than ten seconds in average since the work time would be 




4521




 





 





 





 





 





 



 added to sleep(10). 




4522




 





 





 





 





 





 



   




4523




 





 





 





 





 





 



 Note: sleep_until() will remember the time of ANY last call of this sub, 




4524




 





 





 





 





 





 



 not just the one on the same line in the source code (this might change 




4525




 





 





 





 





 





 



 in the future). The first call to sleep_until() will be the same as 




4526




 





 





 





 





 





 



 sleep_fp() or Perl's own sleep() if the argument is an integer. 




4527




 





 





 





 





 





 



   




4528




 





 





 





 





 





 



 =cut 




4529




 





 





 





 





 





 



   




4530




 





 





 





 





 





 



 our $Time_last_sleep_until; 




4531




 





 





 





 





 





 



 sub sleep_until { 




4532



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



   my $s=@_==1?shift():0; 




4533



  
0
  




 





 





 





 





0



   my $time=time_fp(); 




4534



  
0
  




 





 





 





 





0



   my $sleep=$s-($time-nvl($Time_last_sleep_until,0)); 




4535



  
0
  




 





 





 





 





0



   $Time_last_sleep_until=time; 




4536



  
0
  



  
  0
  




 





 





 





0



   sleep_fp($sleep) if $sleep>0; 




4537




 





 





 





 





 





 



 } 




4538




 





 





 





 





 





 



   




4539




 





 





 





 





 





 



 =head2 leapyear 




4540




 





 





 





 





 





 



   




4541




 





 





 





 





 





 



 B A year. A four digit number. 




4542




 





 





 





 





 





 



   




4543




 





 





 





 





 





 



 B True (1) or false (0) of whether the year is a leap year or 




4544




 





 





 





 





 





 



 not. (Uses current calendar even for periods before leapyears was used). 




4545




 





 





 





 





 





 



   




4546




 





 





 





 





 





 



  print join(", ",grep leapyear($_), 1900..2014)."\n"; 




4547




 





 





 





 





 





 



   




4548




 





 





 





 





 





 



  1904, 1908, 1912, 1916, 1920, 1924, 1928, 1932, 1936, 1940, 1944, 1948, 1952, 1956, 




4549




 





 





 





 





 





 



  1960, 1964, 1968, 1972, 1976, 1980, 1984, 1988, 1992, 1996, 2000, 2004, 2008, 2012 




4550




 





 





 





 





 





 



   




4551




 





 





 





 





 





 



 Note: 1900 is not a leap year, but 2000 is. Years divided by 100 is a leap year only 




4552




 





 





 





 





 





 



 if it can be divided by 400. 




4553




 





 





 





 





 





 



   




4554




 





 





 





 





 





 



 =cut 




4555




 





 





 





 





 





 



   




4556



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub leapyear{$_[0]%400?$_[0]%100?$_[0]%4?0:1:0:1} #bool 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




4557




 





 





 





 





 





 



   




4558




 





 





 





 





 





 



 #http://rosettacode.org/wiki/Levenshtein_distance#Perl 




4559




 





 





 





 





 





 



 our %ldist_cache; 




4560




 





 





 





 





 





 



 sub ldist { 




4561



  
0
  




 





 




  
0
  



  
0
  




0



   my($s,$t,$l) = @_; 




4562



  
0
  



  
  0
  




 





 





 





0



   return length($t) if !$s; 




4563



  
0
  



  
  0
  




 





 





 





0



   return length($s) if !$t; 




4564



  
0
  



  
  0
  



  
  0
  




 





 





0



   %ldist_cache=() if !$l and 1000<0+%ldist_cache; 




4565




 





 





 





 





 





 



   $ldist_cache{$s,$t} ||= 




4566



  
0
  




 




  
  0
  




 





 





0



   do { 




4567



  
0
  




 





 





 





 





0



     my($s1,$t1) = ( substr($s,1), substr($t,1) ); 




4568



  
0
  



  
  0
  




 





 





 





0



     substr($s,0,1) eq substr($t,0,1) 




4569




 





 





 





 





 





 



       ? ldist($s1,$t1) 




4570




 





 





 





 





 





 



       : 1 + min( ldist($s1,$t1,1+$l), ldist($s,$t1,1+$l), ldist($s1,$t,1+$l) ); 




4571




 





 





 





 





 





 



   }; 




4572




 





 





 





 





 





 



 } 




4573




 





 





 





 





 





 



   




4574




 





 





 





 





 





 



 =head1 OTHER 




4575




 





 





 





 





 





 



   




4576




 





 





 





 





 





 



 =head2 nvl 




4577




 





 





 





 





 





 



   




4578




 





 





 





 





 





 



 The I function (or I function) 




4579




 





 





 





 





 





 



   




4580




 





 





 





 





 





 



 C takes two or more arguments. (Oracles nvl-function take just two) 




4581




 





 





 





 





 





 



   




4582




 





 





 





 





 





 



 Returns the value of the first input argument with length() > 0. 




4583




 





 





 





 





 





 



   




4584




 





 





 





 





 





 



 Return I if there is no such input argument. 




4585




 





 





 





 





 





 



   




4586




 





 





 





 





 





 



 In perl 5.10 and perl 6 this will most often be easier with the C< // 




4587




 





 





 





 





 





 



 > operator, although C and C<< // >> treats empty strings C<""> 




4588




 





 





 





 





 





 



 differently. Sub nvl here considers empty strings and undef the same. 




4589




 





 





 





 





 





 



   




4590




 





 





 





 





 





 



 =cut 




4591




 





 





 





 





 





 



   




4592




 





 





 





 





 





 



 sub nvl { 




4593




38




  
100
  



  
 66
  



  
38
  



  
1
  




285



   return $_[0] if defined $_[0] and length($_[0]) or @_==1; 




 




 





 




  
100
  




 





 





 



   




4594




22




  
100
  




 





 





 





83



   return $_[1] if @_==2; 




4595




9




  
100
  




 





 





 





36



   return nvl(@_[1..$#_]) if @_>2; 




4596




1





 





 





 





 





4



   return undef; 




4597




 





 





 





 





 





 



 } 




4598




 





 





 





 





 





 



   




4599




 





 





 





 





 





 



 =head2 decode_num 




4600




 





 





 





 





 





 



   




4601




 





 





 





 





 





 



 See L. 




4602




 





 





 





 





 





 



   




4603




 





 





 





 





 





 



 =head2 decode 




4604




 





 





 





 





 





 



   




4605




 





 





 





 





 





 



 C and C works just as Oracles C. 




4606




 





 





 





 





 





 



   




4607




 





 





 





 





 





 



 C and C accordingly uses perl operators C and C<==> for comparison. 




4608




 





 





 





 





 





 



   




4609




 





 





 





 





 





 



 Examples: 




4610




 





 





 





 





 





 



   




4611




 





 





 





 





 





 



  my $a=123; 




4612




 





 





 





 





 





 



  print decode($a, 123,3,  214,4, $a);     # prints 3 




4613




 





 





 





 





 





 



  print decode($a, 123=>3, 214=>4, $a);    # prints 3, same thing since => is synonymous to comma in Perl 




4614




 





 





 





 





 





 



   




4615




 





 





 





 





 





 



 The first argument is tested against the second, fourth, sixth and so on, 




4616




 





 





 





 





 





 



 and then the third, fifth, seventh and so on is 




4617




 





 





 





 





 





 



 returned if decode() finds an equal string or number. 




4618




 





 





 





 





 





 



   




4619




 





 





 





 





 





 



 In the above example: 123 maps to 3, 124 maps to 4 and the last argument $a is returned elsewise. 




4620




 





 





 





 





 





 



   




4621




 





 





 





 





 





 



 More examples: 




4622




 





 





 





 





 





 



   




4623




 





 





 





 





 





 



  my $a=123; 




4624




 





 





 





 





 





 



  print decode($a, 123=>3, 214=>7, $a);              # also 3,  note that => is synonym for , (comma) in perl 




4625




 





 





 





 





 





 



  print decode($a, 122=>3, 214=>7, $a);              # prints 123 




4626




 





 





 





 





 





 



  print decode($a,  123.0 =>3, 214=>7);              # prints 3 




4627




 





 





 





 





 





 



  print decode($a, '123.0'=>3, 214=>7);              # prints nothing (undef), no last argument default value here 




4628




 





 





 





 





 





 



  print decode_num($a, 121=>3, 221=>7, '123.0','b'); # prints b 




4629




 





 





 





 





 





 



   




4630




 





 





 





 





 





 



 Sort of: 




4631




 





 





 





 





 





 



   




4632




 





 





 





 





 





 



  decode($string, %conversion, $default); 




4633




 





 





 





 





 





 



   




4634




 





 





 





 





 





 



 The last argument is returned as a default if none of the keys in the keys/value-pairs matched. 




4635




 





 





 





 





 





 



   




4636




 





 





 





 





 





 



 A more perl-ish and often faster way of doing the same: 




4637




 





 





 





 





 





 



   




4638




 





 





 





 





 





 



  {123=>3, 214=>7}->{$a} || $a                       # (beware of 0) 




4639




 





 





 





 





 





 



   




4640




 





 





 





 





 





 



 =cut 




4641




 





 





 





 





 





 



   




4642




 





 





 





 





 





 



 sub decode { 




4643




4




  
 50
  




 




  
4
  



  
1
  




10



   croak "Must have a mimimum of two arguments" if @_<2; 




4644




4





 





 





 





 





6



   my $uttrykk=shift; 




4645




4




  
 50
  



  
100
  




 





 





11



   if(defined$uttrykk){ shift eq $uttrykk and return shift or shift for 1..@_/2 } 




 




4





 




  
 33
  




 





 





37



   




4646



  
0
  




 




  
  0
  




 





 





0



   else               { !defined shift    and return shift or shift for 1..@_/2 } 




 




 





 




  
  0
  




 





 





 



   




4647




2





 





 





 





 





8



   return shift; 




4648




 





 





 





 





 





 



 } 




4649




 





 





 





 





 





 



   




4650




 





 





 





 





 





 



 sub decode_num { 




4651




1




  
 50
  




 




  
1
  



  
1
  




5



   croak "Must have a mimimum of two arguments" if @_<2; 




4652




1





 





 





 





 





2



   my $uttrykk=shift; 




4653




1




  
 50
  



  
100
  




 





 





3



   if(defined$uttrykk){ shift == $uttrykk and return shift or shift for 1..@_/2 } 




 




1





 




  
 33
  




 





 





15



   




4654



  
0
  




 




  
  0
  




 





 





0



   else               { !defined shift    and return shift or shift for 1..@_/2 } 




 




 





 




  
  0
  




 





 





 



   




4655



  
0
  




 





 





 





 





0



   return shift; 




4656




 





 





 





 





 





 



 } 




4657




 





 





 





 





 





 



   




4658




 





 





 





 





 





 



 =head2 qrlist 




4659




 





 





 





 





 





 



   




4660




 





 





 





 





 





 



 Input: An array of values to be used to test againts for existence. 




4661




 





 





 





 





 





 



   




4662




 





 





 





 





 





 



 Output: A reference to a regular expression. That is a C 




4663




 





 





 





 





 





 



   




4664




 





 





 





 





 





 



 The regex sets $1 if it match. 




4665




 





 





 





 





 





 



   




4666




 





 





 





 





 





 



 Example: 




4667




 





 





 





 





 





 



   




4668




 





 





 





 





 





 



   my @list=qw/ABc XY DEF DEFG XYZ/; 




4669




 





 





 





 





 





 



   my $filter=qrlist("ABC","DEF","XY.");         # makes a regex of it qr/^(\QABC\E|\QDEF\E|\QXY.\E)$/ 




4670




 





 





 





 





 





 



   my @filtered= grep { $_ =~ $filter } @list;   # returns DEF and XYZ, but not XYZ because the . char is taken literally 




4671




 





 





 





 





 





 



   




4672




 





 





 





 





 





 



 Note: Filtering with hash lookups are WAY faster. 




4673




 





 





 





 





 





 



   




4674




 





 





 





 





 





 



 Source: 




4675




 





 





 





 





 





 



   




4676




 





 





 





 





 





 



  sub qrlist (@) { my $str=join"|",map quotemeta, @_; qr/^($str)$/ } 




4677




 





 





 





 





 





 



   




4678




 





 





 





 





 





 



 =cut 




4679




 





 





 





 





 





 



   




4680




 





 





 





 





 





 



 sub qrlist (@) { 




4681



  
0
  




 





 




  
0
  



  
1
  




0



   my $str=join"|",map quotemeta,@_; 




4682



  
0
  




 





 





 





 





0



   return qr/^($str)$/; 




4683




 





 





 





 





 





 



 } 




4684




 





 





 





 





 





 



   




4685




 





 





 





 





 





 



 =head2 ansicolor 




4686




 





 





 





 





 





 



   




4687




 





 





 





 





 





 



 Perhaps easier to use than L ? 




4688




 





 





 





 





 





 



   




4689




 





 





 





 





 





 



 B One argument. A string where the char C<¤> have special 




4690




 





 





 





 





 





 



 meaning and is replaced by color codings depending on the letter 




4691




 





 





 





 





 





 



 following the C<¤>. 




4692




 





 





 





 





 





 



   




4693




 





 





 





 





 





 



 B The same string, but with C<¤letter> replaced by ANSI color 




4694




 





 





 





 





 





 



 codes respected by many types terminal windows. (xterm, telnet, ssh, 




4695




 





 





 





 





 





 



 telnet, rlog, vt100, cygwin, rxvt and such...). 




4696




 





 





 





 





 





 



   




4697




 





 





 





 





 





 



 B 




4698




 





 





 





 





 





 



   




4699




 





 





 





 





 





 



  ¤r red 




4700




 





 





 





 





 





 



  ¤g green 




4701




 





 





 





 





 





 



  ¤b blue 




4702




 





 





 





 





 





 



  ¤y yellow 




4703




 





 





 





 





 





 



  ¤m magenta 




4704




 





 





 





 





 





 



  ¤B bold 




4705




 





 





 





 





 





 



  ¤u underline 




4706




 





 





 





 





 





 



  ¤c clear 




4707




 





 





 





 





 





 



  ¤¤ reset, quits and returns to default text color. 




4708




 





 





 





 





 





 



   




4709




 





 





 





 





 





 



 B 




4710




 





 





 





 





 





 



   




4711




 





 





 





 





 





 



  print ansicolor("This is maybe ¤ggreen¤¤?"); 




4712




 





 





 





 





 





 



   




4713




 





 





 





 





 





 



 Prints I where the word I is shown in green. 




4714




 





 





 





 





 





 



   




4715




 





 





 





 





 





 



 If L is not installed or not found, returns the input 




4716




 





 





 





 





 





 



 string with every C<¤> including the following code letters 




4717




 





 





 





 





 





 



 removed. (That is: ansicolor is safe to use even if Term::ANSIColor is 




4718




 





 





 





 





 





 



 not installed, you just don't get the colors). 




4719




 





 





 





 





 





 



   




4720




 





 





 





 





 





 



 See also L. 




4721




 





 





 





 





 





 



   




4722




 





 





 





 





 





 



 =cut 




4723




 





 





 





 





 





 



   




4724




 





 





 





 





 





 



 sub ansicolor { 




4725



  
0
  




 





 




  
0
  



  
1
  




0



   my $txt=shift; 




4726



  
0
  



  
  0
  




 





 





 





0



   eval{require Term::ANSIColor} or return replace($txt,qr/¤./); 




 



  
0
  




 





 





 





 





0



   




4727



  
0
  




 





 





 





 





0



   my %h=qw/r red  g green  b blue  y yellow  m magenta  B bold  u underline  c clear  ¤ reset/; 




4728



  
0
  




 





 





 





 





0



   my $re=join"|",keys%h; 




4729



  
0
  




 





 





 





 





0



   $txt=~s/¤($re)/Term::ANSIColor::color($h{$1})/ge; 




 



  
0
  




 





 





 





 





0



   




4730



  
0
  




 





 





 





 





0



   return $txt; 




4731




 





 





 





 





 





 



 } 




4732




 





 





 





 





 





 



   




4733




 





 





 





 





 





 



 =head2 ccn_ok 




4734




 





 





 





 





 





 



   




4735




 





 





 





 





 





 



 Checks if a Credit Card number (CCN) has correct control digits according to the LUHN-algorithm from 1960. 




4736




 





 





 





 





 





 



 This method of control digits is used by MasterCard, Visa, American Express, 




4737




 





 





 





 





 





 



 Discover, Diners Club / Carte Blanche, JCB and others. 




4738




 





 





 





 





 





 



   




4739




 





 





 





 





 





 



 B 




4740




 





 





 





 





 





 



   




4741




 





 





 





 





 





 



 A credit card number. Can contain non-digits, but they are removed internally before checking. 




4742




 





 





 





 





 





 



   




4743




 





 





 





 





 





 



 B 




4744




 





 





 





 





 





 



   




4745




 





 





 





 





 





 



 Something true or false. 




4746




 





 





 





 





 





 



   




4747




 





 





 





 





 





 



 Or more accurately: 




4748




 





 





 





 





 





 



   




4749




 





 





 





 





 





 



 Returns C (false) if the input argument is missing digits. 




4750




 





 





 





 





 





 



   




4751




 





 





 





 





 





 



 Returns 0 (zero, which is false) is the digits is not correct according to the LUHN algorithm. 




4752




 





 





 





 





 





 



   




4753




 





 





 





 





 





 



 Returns 1 or the name of a credit card company (true either way) if the last digit is an ok control digit for this ccn. 




4754




 





 





 





 





 





 



   




4755




 





 





 





 





 





 



 The name of the credit card company is returned like this (without the C<'> character) 




4756




 





 





 





 





 





 



   




4757




 





 





 





 





 





 



  Returns (wo '')                Starts on                Number of digits 




4758




 





 





 





 





 





 



  ------------------------------ ------------------------ ---------------- 




4759




 





 





 





 





 





 



  'MasterCard'                   51-55                    16 




4760




 





 





 





 





 





 



  'Visa'                         4                        13 eller 16 




4761




 





 





 





 





 





 



  'American Express'             34 eller 37              15 




4762




 





 





 





 





 





 



  'Discover'                     6011                     16 




4763




 





 





 





 





 





 



  'Diners Club / Carte Blanche'  300-305, 36 eller 38     14 




4764




 





 





 





 





 





 



  'JCB'                          3                        16 




4765




 





 





 





 





 





 



  'JCB'                          2131 eller 1800          15 




4766




 





 





 





 





 





 



   




4767




 





 





 





 





 





 



 And should perhaps have had: 




4768




 





 





 





 





 





 



   




4769




 





 





 





 





 





 



  'enRoute'                      2014 eller 2149          15 




4770




 





 





 





 





 





 



   




4771




 





 





 





 





 





 



 ...but that card uses either another control algorithm or no control 




4772




 





 





 





 





 





 



 digits at all. So C is never returned here. 




4773




 





 





 





 





 





 



   




4774




 





 





 





 





 





 



 If the control digits is valid, but the input does not match anything in the column C, 1 is returned. 




4775




 





 





 





 





 





 



   




4776




 





 





 





 





 





 



 (This is also the same control digit mechanism used in Norwegian KID numbers on payment bills) 




4777




 





 





 





 





 





 



   




4778




 





 





 





 





 





 



 The first digit in a credit card number is supposed to tell what "industry" the card is meant for: 




4779




 





 





 





 





 





 



   




4780




 





 





 





 





 





 



  MII Digit Value             Issuer Category 




4781




 





 





 





 





 





 



  --------------------------- ---------------------------------------------------- 




4782




 





 





 





 





 





 



  0                           ISO/TC 68 and other industry assignments 




4783




 





 





 





 





 





 



  1                           Airlines 




4784




 





 





 





 





 





 



  2                           Airlines and other industry assignments 




4785




 





 





 





 





 





 



  3                           Travel and entertainment 




4786




 





 





 





 





 





 



  4                           Banking and financial 




4787




 





 





 





 





 





 



  5                           Banking and financial 




4788




 





 





 





 





 





 



  6                           Merchandizing and banking 




4789




 





 





 





 





 





 



  7                           Petroleum 




4790




 





 





 





 





 





 



  8                           Telecommunications and other industry assignments 




4791




 





 





 





 





 





 



  9                           National assignment 




4792




 





 





 





 





 





 



   




4793




 





 





 





 





 





 



 ...although this has no meaning to C. 




4794




 





 





 





 





 





 



   




4795




 





 





 





 





 





 



 The first six digits is I, that is the bank 




4796




 





 





 





 





 





 



 (probably). The rest in the "account number", except the last digits, 




4797




 





 





 





 





 





 



 which is the control digit. Max length on credit card numbers are 19 




4798




 





 





 





 





 





 



 digits. 




4799




 





 





 





 





 





 



   




4800




 





 





 





 





 





 



 =cut 




4801




 





 





 





 





 





 



   




4802




 





 





 





 





 





 



 sub ccn_ok { 




4803



  
0
  




 





 




  
0
  



  
1
  




0



     my $ccn=shift(); #credit card number 




4804



  
0
  




 





 





 





 





0



     $ccn=~s/\D+//g; 




4805



  
0
  



  
  0
  




 





 





 





0



     if(KID_ok($ccn)){ 




4806



  
0
  



  
  0
  




 





 





 





0



 	return "MasterCard"                   if $ccn=~/^5[1-5]\d{14}$/; 




4807



  
0
  



  
  0
  




 





 





 





0



 	return "Visa"                         if $ccn=~/^4\d{12}(?:\d{3})?$/; 




4808



  
0
  



  
  0
  




 





 





 





0



 	return "American Express"             if $ccn=~/^3[47]\d{13}$/; 




4809



  
0
  



  
  0
  




 





 





 





0



 	return "Discover"                     if $ccn=~/^6011\d{12}$/; 




4810



  
0
  



  
  0
  




 





 





 





0



 	return "Diners Club / Carte Blanche"  if $ccn=~/^3(?:0[0-5]\d{11}|[68]\d{12})$/; 




4811



  
0
  



  
  0
  




 





 





 





0



 	return "JCB"                          if $ccn=~/^(?:3\d{15}|(?:2131|1800)\d{11})$/; 




4812



  
0
  




 





 





 





 





0



 	return 1; 




4813




 





 





 





 





 





 



     } 




4814




 





 





 





 





 





 



     #return "enRoute"                        if $ccn=~/^(?:2014|2149)\d{11}$/; #ikke LUHN-krav? 




4815



  
0
  




 





 





 





 





0



     return 0; 




4816




 





 





 





 





 





 



 } 




4817




 





 





 





 





 





 



   




4818




 





 





 





 





 





 



 =head2 KID_ok 




4819




 





 





 





 





 





 



   




4820




 





 





 





 





 





 



 Checks if a norwegian KID number has an ok control digit. 




4821




 





 





 





 





 





 



   




4822




 





 





 





 





 





 



 To check if a customer has typed the number correctly. 




4823




 





 





 





 





 





 



   




4824




 





 





 





 





 





 



 This uses the  LUHN algorithm (also known as mod-10) from 1960 which is also used 




4825




 





 





 





 





 





 



 internationally in control digits for credit card numbers, and Canadian social security ID numbers as well. 




4826




 





 





 





 





 





 



   




4827




 





 





 





 





 





 



 The algorithm, as described in Phrack (47-8) (a long time hacker online publication): 




4828




 





 





 





 





 





 



   




4829




 





 





 





 





 





 



  "For a card with an even number of digits, double every odd numbered 




4830




 





 





 





 





 





 



  digit and subtract 9 if the product is greater than 9. Add up all the 




4831




 





 





 





 





 





 



  even digits as well as the doubled-odd digits, and the result must be 




4832




 





 





 





 





 





 



  a multiple of 10 or it's not a valid card. If the card has an odd 




4833




 





 





 





 





 





 



  number of digits, perform the same addition doubling the even numbered 




4834




 





 





 





 





 





 



  digits instead." 




4835




 





 





 





 





 





 



   




4836




 





 





 





 





 





 



 B A KID-nummer. Must consist of digits 0-9 only, otherwise a die (croak) happens. 




4837




 





 





 





 





 





 



   




4838




 





 





 





 





 





 



 B 




4839




 





 





 





 





 





 



   




4840




 





 





 





 





 





 



 - Returns undef if the input argument is missing. 




4841




 





 





 





 





 





 



   




4842




 





 





 





 





 





 



 - Returns 0 if the control digit (the last digit) does not satify the LUHN/mod-10 algorithm. 




4843




 





 





 





 





 





 



   




4844




 





 





 





 





 





 



 - Returns 1 if ok 




4845




 





 





 





 





 





 



   




4846




 





 





 





 





 





 



 B L 




4847




 





 





 





 





 





 



   




4848




 





 





 





 





 





 



 =cut 




4849




 





 





 





 





 





 



   




4850




 





 





 





 





 





 



 sub KID_ok { 




4851



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



   croak "Non-numeric argument" if $_[0]=~/\D/; 




4852



  
0
  



  
  0
  




 





 





 





0



   my @k=split//,shift or return undef; 




4853



  
0
  




 





 





 





 





0



   my $s;$s+=pop(@k)+[qw/0 2 4 6 8 1 3 5 7 9/]->[pop@k] while @k; 




 



  
0
  




 





 





 





 





0



   




4854



  
0
  



  
  0
  




 





 





 





0



   $s%10==0?1:0; 




4855




 





 





 





 





 





 



 } 




4856




 





 





 





 





 





 



   




4857




 





 





 





 





 





 



   




4858




 





 





 





 





 





 



   




4859




 





 





 





 





 





 



 =head2 range 




4860




 





 





 





 





 





 



   




4861




 





 





 





 





 





 



 B 




4862




 





 





 





 





 





 



   




4863




 





 





 





 





 





 



 One or more numeric arguments: 




4864




 





 





 





 





 





 



   




4865




 





 





 





 





 





 



 First: x (first returned element) 




4866




 





 





 





 





 





 



   




4867




 





 





 





 





 





 



 Second: y (last but not including) 




4868




 





 





 





 





 





 



   




4869




 





 





 





 





 





 



 Third: step, default 1. The step between each returned element 




4870




 





 





 





 





 





 



   




4871




 





 





 





 





 





 



 If a fourth, fifth and so on arguments are given, they change the step for each returned element. As first derivative, second derivative. 




4872




 





 





 





 





 





 



   




4873




 





 





 





 





 





 



 B 




4874




 





 





 





 





 





 



   




4875




 





 





 





 





 





 



 If one argument: returns the array C<(0 .. x-1)> 




4876




 





 





 





 





 





 



   




4877




 





 





 





 





 





 



 If two arguments: returns the array C<(x .. y-1)> 




4878




 





 





 





 





 





 



   




4879




 





 





 





 





 





 



 If three arguments: The default step is 1. Use a third argument to use a different step. 




4880




 





 





 





 





 





 



   




4881




 





 





 





 





 





 



 B 




4882




 





 





 





 





 





 



   




4883




 





 





 





 





 





 



  print join ",", range(11);         # prints 0,1,2,3,4,5,6,7,8,9,10      (but not 11) 




4884




 





 





 





 





 





 



  print join ",", range(2,11);       # 2,3,4,5,6,7,8,9,10          (but not 11) 




4885




 





 





 





 





 





 



  print join ",", range(11,2,-1);    # 11,10,9,8,7,6,5,4,3 




4886




 





 





 





 





 





 



  print join ",", range(2,11,3);     # 2,5,8 




4887




 





 





 





 





 





 



  print join ",", range(11,2,-3);    # 11,8,5 




4888




 





 





 





 





 





 



  print join ",", range(11,2,+3);    # prints nothing 




4889




 





 





 





 





 





 



   




4890




 





 





 





 





 





 



  print join ", ",range(2,11,1,0.1);       # 2, 3, 4.1, 5.3, 6.6, 8, 9.5   adds 0.1 to step each time 




4891




 





 





 





 





 





 



  print join ", ",range(2,11,1,0.1,-0.01); # 2, 3, 4.1, 5.29, 6.56, 7.9, 9.3, 10.75 




4892




 





 





 





 





 





 



   




4893




 





 





 





 





 





 



 Note: In the Python language and others, C is a build in iterator (a 




4894




 





 





 





 





 





 



 generator), not an array. This saves memory for large sets and sometimes time. 




4895




 





 





 





 





 





 



 Use C in L to get a similar lazy generator in Perl. 




4896




 





 





 





 





 





 



   




4897




 





 





 





 





 





 



 =cut 




4898




 





 





 





 





 





 



   




4899




 





 





 





 





 





 



 sub range { 




4900




8




  
100
  




 




  
8
  



  
1
  




35



   return _range_accellerated(@_) if @_>3;  #se under 




4901




6





 





 





 





 





13



   my($x,$y,$jump)=@_; 




4902




6




  
100
  




 





 





 





71



   return (  0 .. $x-1 ) if @_==1; 




4903




5




  
100
  




 





 





 





21



   return ( $x .. $y-1 ) if @_==2; 




4904




4




  
 50
  



  
 33
  




 





 





28



   croak "Wrong number of arguments or jump==0" if @_!=3 or $jump==0; 




4905




4





 





 





 





 





6



   my @r; 




4906




4




  
100
  




 





 





 





11



   if($jump>0){  while($x<$y){ push @r, $x; $x+=$jump } } 




 




2





 





 





 





 





8



   




 




772





 





 





 





 





856



   




 




772





 





 





 





 





1292



   




4907




2





 





 





 





 





6



   else       {  while($x>$y){ push @r, $x; $x+=$jump } } 




 




12





 





 





 





 





18



   




 




12





 





 





 





 





21



   




4908




4





 





 





 





 





57



   return @r; 




4909




 





 





 





 





 





 



 } 




4910




 





 





 





 





 





 



   




4911




 





 





 





 





 





 



 #jumps derivative, double der., trippled der usw 




4912




 





 





 





 





 





 



 sub _range_accellerated { 




4913




2





 





 




  
2
  




 





6



   my($x,$y,@jump)=@_; 




4914




2





 





 





 





 





4



   my @r; 




4915




2




  
 50
  




 




  
0
  




 





10



   my $test = $jump[0]>=0 ? sub{$x<$y} : sub{$x>$y}; 




 




17





 





 





 





 





45



   




 



  
0
  




 





 





 





 





0



   




4916




2





 





 





 





 





6



   while(&$test()){ 




4917




15





 





 





 





 





23



     push @r, $x; 




4918




15





 





 





 





 





18



     $x+=$jump[0]; 




4919




15





 





 





 





 





50



     $jump[$_-1]+=$jump[$_] for 1..$#jump; 




4920




 





 





 





 





 





 



   } 




4921




2





 





 





 





 





29



   return @r; 




4922




 





 





 





 





 





 



 } 




4923




 





 





 





 





 





 



   




4924




 





 





 





 





 





 



 =head2 permutations 




4925




 





 





 





 





 





 



   




4926




 





 





 





 





 





 



 How many ways (permutations) can six people be placed around a table: 




4927




 





 





 





 





 





 



   




4928




 





 





 





 





 





 



  If one person:          one 




4929




 





 





 





 





 





 



  If two persons:         two     (they can swap places) 




4930




 





 





 





 





 





 



  If three persons:       six 




4931




 





 





 





 





 





 



  If four persons:         24 




4932




 





 





 





 





 





 



  If five persons:        120 




4933




 





 





 





 





 





 



  If six  persons:        720 




4934




 





 





 





 





 





 



   




4935




 





 





 





 





 





 



 The formula is C where the postfix unary operator C, also known as I is defined like: 




4936




 





 





 





 





 





 



 C. Example: C<5! = 5 * 4 * 3 * 2 * 1 = 120>.Run this to see the 100 first C<< n! >> 




4937




 





 





 





 





 





 



   




4938




 





 





 





 





 





 



  perl -MAcme::Tools -le'$i=big(1);print "$_!=",$i*=$_ for 1..100' 




4939




 





 





 





 





 





 



   




4940




 





 





 





 





 





 



   1!  = 1 




4941




 





 





 





 





 





 



   2!  = 2 




4942




 





 





 





 





 





 



   3!  = 6 




4943




 





 





 





 





 





 



   4!  = 24 




4944




 





 





 





 





 





 



   5!  = 120 




4945




 





 





 





 





 





 



   6!  = 720 




4946




 





 





 





 





 





 



   7!  = 5040 




4947




 





 





 





 





 





 



   8!  = 40320 




4948




 





 





 





 





 





 



   9!  = 362880 




4949




 





 





 





 





 





 



  10!  = 3628800 




4950




 





 





 





 





 





 



  . 




4951




 





 





 





 





 





 



  . 




4952




 





 





 





 





 





 



  . 




4953




 





 





 





 





 





 



  100! = 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000 




4954




 





 





 





 





 





 



   




4955




 





 





 





 





 





 



 C takes a list and return a list of arrayrefs for each 




4956




 





 





 





 





 





 



 of the permutations of the input list: 




4957




 





 





 





 





 





 



   




4958




 





 





 





 





 





 



  permutations('a','b');     #returns (['a','b'],['b','a']) 




4959




 





 





 





 





 





 



   




4960




 





 





 





 





 





 



  permutations('a','b','c'); #returns (['a','b','c'],['a','c','b'], 




4961




 





 





 





 





 





 



                             #         ['b','a','c'],['b','c','a'], 




4962




 





 





 





 





 





 



                             #         ['c','a','b'],['c','b','a']) 




4963




 





 





 





 





 





 



   




4964




 





 





 





 





 





 



 Up to five input arguments C is probably as fast as it 




4965




 





 





 





 





 





 



 can be in this pure perl implementation (see source). For more than 




4966




 





 





 





 





 





 



 five, it could be faster. How fast is it now: Running with different 




4967




 





 





 





 





 





 



 n, this many time took that many seconds: 




4968




 





 





 





 





 





 



   




4969




 





 





 





 





 





 



  n   times    seconds 




4970




 





 





 





 





 





 



  -- ------- --------- 




4971




 





 





 





 





 





 



   2  100000      0.32 




4972




 





 





 





 





 





 



   3  10000       0.09 




4973




 





 





 





 





 





 



   4  10000       0.33 




4974




 





 





 





 





 





 



   5  1000        0.18 




4975




 





 





 





 





 





 



   6  100         0.27 




4976




 





 





 





 





 





 



   7  10          0.21 




4977




 





 





 





 





 





 



   8  1           0.17 




4978




 





 





 





 





 





 



   9  1           1.63 




4979




 





 





 





 





 





 



  10  1          17.00 




4980




 





 





 





 





 





 



   




4981




 





 





 





 





 





 



 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. For example this: 




4982




 





 





 





 





 





 



   




4983




 





 





 





 





 





 



  print for permutations(sub{join"",@_},1..3); 




4984




 





 





 





 





 





 



   




4985




 





 





 





 





 





 



 ...will print the same as: 




4986




 





 





 





 





 





 



   




4987




 





 





 





 





 





 



  print for map join("",@$_), permutations(1..3); 




4988




 





 





 





 





 





 



   




4989




 





 





 





 





 





 



 ...but the first of those two uses less RAM if 3 has been say 9. 




4990




 





 





 





 





 





 



 Changing 3 with 10, and many computers hasn't enough memory 




4991




 





 





 





 





 





 



 for the latter. 




4992




 





 





 





 





 





 



   




4993




 





 





 





 





 





 



 The examples prints: 




4994




 





 





 





 





 





 



   




4995




 





 





 





 





 





 



  123 




4996




 





 





 





 





 





 



  132 




4997




 





 





 





 





 





 



  213 




4998




 





 





 





 





 





 



  231 




4999




 





 





 





 





 





 



  312 




5000




 





 





 





 





 





 



  321 




5001




 





 





 





 





 





 



   




5002




 





 





 





 





 





 



 If you just want to say calculate something on each permutation, 




5003




 





 





 





 





 





 



 but is not interested in the list of them, you just don't 




5004




 





 





 





 





 





 



 take the return. That is: 




5005




 





 





 





 





 





 



   




5006




 





 





 





 





 





 



  my $ant; 




5007




 





 





 





 





 





 



  permutations(sub{$ant++ if $_[-1]>=$_[0]*2},1..9); 




5008




 





 





 





 





 





 



   




5009




 





 





 





 





 





 



 ...is the same as: 




5010




 





 





 





 





 





 



   




5011




 





 





 





 





 





 



  $$_[-1]>=$$_[0]*2 and $ant++ for permutations(1..9); 




5012




 





 





 





 





 





 



   




5013




 





 





 





 





 





 



 ...but the first uses next to nothing of memory compared to the latter. They have about the same speed. 




5014




 





 





 





 





 





 



 (The examples just counts the permutations where the last number is at least twice as large as the first) 




5015




 





 





 





 





 





 



   




5016




 





 





 





 





 





 



 C was created to find all combinations of a persons 




5017




 





 





 





 





 





 



 name. This is useful in "fuzzy" name searches with 




5018




 





 





 





 





 





 



 L if you can not be certain what is first, middle 




5019




 





 





 





 





 





 



 and last names. In foreign or unfamiliar names it can be difficult to 




5020




 





 





 





 





 





 



 know that. 




5021




 





 





 





 





 





 



   




5022




 





 





 





 





 





 



 =cut 




5023




 





 





 





 





 





 



   




5024




 





 





 





 





 





 



 #TODO: se test_perl.pl 




5025




 





 





 





 





 





 



   




5026




 





 





 





 





 





 



 sub permutations { 




5027




2




  
 50
  




 




  
2
  



  
1
  




16



   my $code=ref($_[0]) eq 'CODE' ? shift() : undef; 




5028




2




  
 50
  



  
 33
  




 





 





11



   $code and @_<6 and return map &$code(@$_),permutations(@_); 




5029




 





 





 





 





 





 



   




5030




2




  
 50
  




 





 





 





7



   return [@_] if @_<2; 




5031




 





 





 





 





 





 



   




5032




2




  
100
  




 





 





 





19



   return ([@_[0,1]],[@_[1,0]]) if @_==2; 




5033




 





 





 





 





 





 



   




5034




1




  
 50
  




 





 





 





19



   return ([@_[0,1,2]],[@_[0,2,1]],[@_[1,0,2]], 




5035




 





 





 





 





 





 



 	  [@_[1,2,0]],[@_[2,0,1]],[@_[2,1,0]]) if @_==3; 




5036




 





 





 





 





 





 



   




5037



  
0
  



  
  0
  




 





 





 





0



   return ([@_[0,1,2,3]],[@_[0,1,3,2]],[@_[0,2,1,3]],[@_[0,2,3,1]], 




5038




 





 





 





 





 





 



 	  [@_[0,3,1,2]],[@_[0,3,2,1]],[@_[1,0,2,3]],[@_[1,0,3,2]], 




5039




 





 





 





 





 





 



 	  [@_[1,2,0,3]],[@_[1,2,3,0]],[@_[1,3,0,2]],[@_[1,3,2,0]], 




5040




 





 





 





 





 





 



 	  [@_[2,0,1,3]],[@_[2,0,3,1]],[@_[2,1,0,3]],[@_[2,1,3,0]], 




5041




 





 





 





 





 





 



 	  [@_[2,3,0,1]],[@_[2,3,1,0]],[@_[3,0,1,2]],[@_[3,0,2,1]], 




5042




 





 





 





 





 





 



 	  [@_[3,1,0,2]],[@_[3,1,2,0]],[@_[3,2,0,1]],[@_[3,2,1,0]]) if @_==4; 




5043




 





 





 





 





 





 



   




5044



  
0
  



  
  0
  




 





 





 





0



   return ([@_[0,1,2,3,4]],[@_[0,1,2,4,3]],[@_[0,1,3,2,4]],[@_[0,1,3,4,2]],[@_[0,1,4,2,3]], 




5045




 





 





 





 





 





 



 	  [@_[0,1,4,3,2]],[@_[0,2,1,3,4]],[@_[0,2,1,4,3]],[@_[0,2,3,1,4]],[@_[0,2,3,4,1]], 




5046




 





 





 





 





 





 



 	  [@_[0,2,4,1,3]],[@_[0,2,4,3,1]],[@_[0,3,1,2,4]],[@_[0,3,1,4,2]],[@_[0,3,2,1,4]], 




5047




 





 





 





 





 





 



 	  [@_[0,3,2,4,1]],[@_[0,3,4,1,2]],[@_[0,3,4,2,1]],[@_[0,4,1,2,3]],[@_[0,4,1,3,2]], 




5048




 





 





 





 





 





 



 	  [@_[0,4,2,1,3]],[@_[0,4,2,3,1]],[@_[0,4,3,1,2]],[@_[0,4,3,2,1]],[@_[1,0,2,3,4]], 




5049




 





 





 





 





 





 



 	  [@_[1,0,2,4,3]],[@_[1,0,3,2,4]],[@_[1,0,3,4,2]],[@_[1,0,4,2,3]],[@_[1,0,4,3,2]], 




5050




 





 





 





 





 





 



 	  [@_[1,2,0,3,4]],[@_[1,2,0,4,3]],[@_[1,2,3,0,4]],[@_[1,2,3,4,0]],[@_[1,2,4,0,3]], 




5051




 





 





 





 





 





 



 	  [@_[1,2,4,3,0]],[@_[1,3,0,2,4]],[@_[1,3,0,4,2]],[@_[1,3,2,0,4]],[@_[1,3,2,4,0]], 




5052




 





 





 





 





 





 



 	  [@_[1,3,4,0,2]],[@_[1,3,4,2,0]],[@_[1,4,0,2,3]],[@_[1,4,0,3,2]],[@_[1,4,2,0,3]], 




5053




 





 





 





 





 





 



 	  [@_[1,4,2,3,0]],[@_[1,4,3,0,2]],[@_[1,4,3,2,0]],[@_[2,0,1,3,4]],[@_[2,0,1,4,3]], 




5054




 





 





 





 





 





 



 	  [@_[2,0,3,1,4]],[@_[2,0,3,4,1]],[@_[2,0,4,1,3]],[@_[2,0,4,3,1]],[@_[2,1,0,3,4]], 




5055




 





 





 





 





 





 



 	  [@_[2,1,0,4,3]],[@_[2,1,3,0,4]],[@_[2,1,3,4,0]],[@_[2,1,4,0,3]],[@_[2,1,4,3,0]], 




5056




 





 





 





 





 





 



 	  [@_[2,3,0,1,4]],[@_[2,3,0,4,1]],[@_[2,3,1,0,4]],[@_[2,3,1,4,0]],[@_[2,3,4,0,1]], 




5057




 





 





 





 





 





 



 	  [@_[2,3,4,1,0]],[@_[2,4,0,1,3]],[@_[2,4,0,3,1]],[@_[2,4,1,0,3]],[@_[2,4,1,3,0]], 




5058




 





 





 





 





 





 



 	  [@_[2,4,3,0,1]],[@_[2,4,3,1,0]],[@_[3,0,1,2,4]],[@_[3,0,1,4,2]],[@_[3,0,2,1,4]], 




5059




 





 





 





 





 





 



 	  [@_[3,0,2,4,1]],[@_[3,0,4,1,2]],[@_[3,0,4,2,1]],[@_[3,1,0,2,4]],[@_[3,1,0,4,2]], 




5060




 





 





 





 





 





 



 	  [@_[3,1,2,0,4]],[@_[3,1,2,4,0]],[@_[3,1,4,0,2]],[@_[3,1,4,2,0]],[@_[3,2,0,1,4]], 




5061




 





 





 





 





 





 



 	  [@_[3,2,0,4,1]],[@_[3,2,1,0,4]],[@_[3,2,1,4,0]],[@_[3,2,4,0,1]],[@_[3,2,4,1,0]], 




5062




 





 





 





 





 





 



 	  [@_[3,4,0,1,2]],[@_[3,4,0,2,1]],[@_[3,4,1,0,2]],[@_[3,4,1,2,0]],[@_[3,4,2,0,1]], 




5063




 





 





 





 





 





 



 	  [@_[3,4,2,1,0]],[@_[4,0,1,2,3]],[@_[4,0,1,3,2]],[@_[4,0,2,1,3]],[@_[4,0,2,3,1]], 




5064




 





 





 





 





 





 



 	  [@_[4,0,3,1,2]],[@_[4,0,3,2,1]],[@_[4,1,0,2,3]],[@_[4,1,0,3,2]],[@_[4,1,2,0,3]], 




5065




 





 





 





 





 





 



 	  [@_[4,1,2,3,0]],[@_[4,1,3,0,2]],[@_[4,1,3,2,0]],[@_[4,2,0,1,3]],[@_[4,2,0,3,1]], 




5066




 





 





 





 





 





 



 	  [@_[4,2,1,0,3]],[@_[4,2,1,3,0]],[@_[4,2,3,0,1]],[@_[4,2,3,1,0]],[@_[4,3,0,1,2]], 




5067




 





 





 





 





 





 



 	  [@_[4,3,0,2,1]],[@_[4,3,1,0,2]],[@_[4,3,1,2,0]],[@_[4,3,2,0,1]],[@_[4,3,2,1,0]]) if @_==5; 




5068




 





 





 





 





 





 



   




5069



  
0
  




 





 





 





 





0



   my(@r,@p,@c,@i,@n); @i=(0,@_); @p=@c=1..@_; @n=1..@_-1; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5070




 





 





 





 





 





 



   PERM: 




5071



  
0
  




 





 





 





 





0



   while(1){ 




5072



  
0
  



  
  0
  




 





 





 





0



     if($code){if(defined wantarray){push(@r,&$code(@i[@p]))}else{&$code(@i[@p])}}else{push@r,[@i[@p]]} 




 



  
0
  



  
  0
  




 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5073



  
0
  



  
  0
  




 





 





 





0



     for my$i(@n){splice@p,$i,0,shift@p;next PERM if --$c[$i];$c[$i]=$i+1} 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5074




 





 





 





 





 





 



     return@r 




5075



  
0
  




 





 





 





 





0



   } 




5076




 





 





 





 





 





 



 } 




5077




 





 





 





 





 





 



   




5078




 





 





 





 





 





 



 =head2 cart 




5079




 





 





 





 





 





 



   




5080




 





 





 





 





 





 



 Cartesian product 




5081




 





 





 





 





 





 



   




5082




 





 





 





 





 





 



 B 




5083




 





 





 





 





 





 



   




5084




 





 





 





 





 





 



 Input: two or more arrayrefs with accordingly x, y, z and so on number of elements. 




5085




 





 





 





 





 





 



   




5086




 





 





 





 





 





 



 Output: An array of x * y * z number of arrayrefs. The arrays being the cartesian product of the input arrays. 




5087




 





 





 





 





 





 



   




5088




 





 





 





 





 





 



 It can be useful to think of this as joins in SQL. In C statements with 




5089




 





 





 





 





 





 



 more tables behind C, but without any C condition to join the tables. 




5090




 





 





 





 





 





 



   




5091




 





 





 





 





 





 



 B 




5092




 





 





 





 





 





 



   




5093




 





 





 





 





 





 



 B 




5094




 





 





 





 





 





 



   




5095




 





 





 





 





 





 



 - Either two or more arrayrefs with x, y, z and so on number of elements. 




5096




 





 





 





 





 





 



   




5097




 





 





 





 





 





 



 - Or coderefs to subs containing condition checks. Somewhat like C conditions in SQL. 




5098




 





 





 





 





 





 



   




5099




 





 





 





 





 





 



 B An array of x * y * z number of arrayrefs (the cartesian product) 




5100




 





 





 





 





 





 



 minus the ones that did not fulfill the condition(s). 




5101




 





 





 





 





 





 



   




5102




 





 





 





 





 





 



 This of is as joins with one or more where conditions as coderefs. 




5103




 





 





 





 





 





 



   




5104




 





 





 





 





 





 



 The coderef input arguments can be placed last or among the array refs 




5105




 





 





 





 





 





 



 to save both runtime and memory if the conditions depend on 




5106




 





 





 





 





 





 



 arrays further back. 




5107




 





 





 





 





 





 



   




5108




 





 





 





 





 





 



 B 




5109




 





 





 





 





 





 



   




5110




 





 





 





 





 





 



  for(cart(\@a1,\@a2,\@a3)){ 




5111




 





 





 





 





 





 



    my($a1,$a2,$a3) = @$_; 




5112




 





 





 





 





 





 



    print "$a1,$a2,$a3\n"; 




5113




 





 





 





 





 





 



  } 




5114




 





 





 





 





 





 



   




5115




 





 





 





 





 





 



 Prints the same as this: 




5116




 





 





 





 





 





 



   




5117




 





 





 





 





 





 



  for my $a1 (@a1){ 




5118




 





 





 





 





 





 



    for my $a2 (@a2){ 




5119




 





 





 





 





 





 



      for my $a3 (@a3){ 




5120




 





 





 





 





 





 



        print "$a1,$a2,$a3\n"; 




5121




 





 





 





 





 





 



      } 




5122




 





 





 





 





 





 



    } 




5123




 





 





 





 





 





 



  } 




5124




 





 





 





 





 





 



   




5125




 





 





 





 





 





 



 B (with a condition: the sum of the first two should be dividable with 3) 




5126




 





 





 





 





 





 



   




5127




 





 





 





 





 





 



  for( cart( \@a1, \@a2, sub{sum(@$_)%3==0}, \@a3 ) ) { 




5128




 





 





 





 





 





 



    my($a1,$a2,$a3)=@$_; 




5129




 





 





 





 





 





 



    print "$a1,$a2,$a3\n"; 




5130




 





 





 





 





 





 



  } 




5131




 





 





 





 





 





 



   




5132




 





 





 





 





 





 



 Prints the same as this: 




5133




 





 





 





 





 





 



   




5134




 





 





 





 





 





 



  for my $a1 (@a1){ 




5135




 





 





 





 





 





 



    for my $a2 (@a2){ 




5136




 





 





 





 





 





 



      next if 0==($a1+$a2)%3; 




5137




 





 





 





 





 





 



      for my $a3 (@a3){ 




5138




 





 





 





 





 





 



        print "$a1,$a2,$a3\n"; 




5139




 





 





 





 





 





 



      } 




5140




 





 





 





 





 





 



    } 




5141




 





 





 





 





 





 



  } 




5142




 





 





 





 





 





 



   




5143




 





 





 





 





 





 



 B 




5144




 





 





 





 





 





 



   




5145




 





 





 





 





 





 



  my @a1 = (1,2); 




5146




 





 





 





 





 





 



  my @a2 = (10,20,30); 




5147




 





 





 





 





 





 



  my @a3 = (100,200,300,400); 




5148




 





 





 





 





 





 



   




5149




 





 





 





 





 





 



  my $s = join"", map "*".join(",",@$_), cart(\@a1,\@a2,\@a3); 




5150




 





 





 





 





 





 



  ok( $s eq  "*1,10,100*1,10,200*1,10,300*1,10,400*1,20,100*1,20,200" 




5151




 





 





 





 





 





 



            ."*1,20,300*1,20,400*1,30,100*1,30,200*1,30,300*1,30,400" 




5152




 





 





 





 





 





 



            ."*2,10,100*2,10,200*2,10,300*2,10,400*2,20,100*2,20,200" 




5153




 





 





 





 





 





 



            ."*2,20,300*2,20,400*2,30,100*2,30,200*2,30,300*2,30,400"); 




5154




 





 





 





 





 





 



   




5155




 





 





 





 





 





 



  $s=join"",map "*".join(",",@$_), cart(\@a1,\@a2,\@a3,sub{sum(@$_)%3==0}); 




5156




 





 





 





 





 





 



  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"); 




5157




 





 





 





 





 





 



   




5158




 





 





 





 





 





 



 B 




5159




 





 





 





 





 





 



   




5160




 





 





 





 





 





 



 Returns hashrefs instead of arrayrefs: 




5161




 





 





 





 





 





 



   




5162




 





 





 





 





 





 



  my @cards=cart(             #5200 cards: 100 decks of 52 cards 




5163




 





 





 





 





 





 



    deck  => [1..100], 




5164




 





 





 





 





 





 



    value => [qw/2 3 4 5 6 7 8 9 10 J Q K A/], 




5165




 





 





 





 





 





 



    col   => [qw/heart diamond club star/], 




5166




 





 





 





 





 





 



  ); 




5167




 





 





 





 





 





 



  for my $card ( mix(@cards) ) { 




5168




 





 





 





 





 





 



    print "From deck number $$card{deck} we got $$card{value} $$card{col}\n"; 




5169




 





 





 





 





 





 



  } 




5170




 





 





 





 





 





 



   




5171




 





 





 





 





 





 



 Note: using sub-ref filters do not work (yet) in hash-mode. Use grep on result instead. 




5172




 





 





 





 





 





 



   




5173




 





 





 





 





 





 



 =cut 




5174




 





 





 





 





 





 



   




5175




 





 





 





 





 





 



 sub cart { 




5176




5





 





 




  
5
  



  
1
  




850



   my @ars=@_; 




5177




5




  
100
  




 





 





 





17



   if(!ref($_[0])){ #if hash-mode detected 




5178




1





 




  
 33
  




 





 





2



     my(@k,@v); push@k,shift@ars and push@v,shift@ars while @ars; 




 




1





 





 





 





 





13



   




5179




1





 





 





 





 





7



     return map{my%h;@h{@k}=@$_;\%h}cart(@v); 




 




24





 





 





 





 





26



   




 




24





 





 





 





 





68



   




 




24





 





 





 





 





44



   




5180




 





 





 





 





 





 



   } 




5181




4





 





 





 





 





6



   my @res=map[$_],@{shift@ars}; 




 




4





 





 





 





 





20



   




5182




4





 





 





 





 





9



   for my $ar (@ars){ 




5183




9




  
100
  



  
 50
  




 





 





26



     @res=grep{&$ar(@$_)}@res and next if ref($ar) eq 'CODE'; 




 




24





 





 





 





 





51



   




5184




8





 





 





 





 





13



     @res=map{my$r=$_;map{[@$r,$_]}@$ar}@res; 




 




34





 





 





 





 





38



   




 




34





 





 





 





 





49



   




 




120





 





 





 





 





257



   




5185




 





 





 





 





 





 



   } 




5186




4





 





 





 





 





63



   return @res; 




5187




 





 





 





 





 





 



 } 




5188




 





 





 





 





 





 



   




5189




 





 





 





 





 





 



 sub cart_easy { #not tested/exported http://stackoverflow.com/questions/2457096/in-perl-how-can-i-get-the-cartesian-product-of-multiple-sets 




5190



  
0
  




 





 




  
0
  



  
0
  




0



   my $last = pop @_; 




5191



  
0
  



  
  0
  




 





 





 





0



   @_ ? (map {my$left=$_; map [@$left, $_], @$last } cart_easy(@_) ) 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5192




 





 





 





 





 





 



      : (map [$_], @$last); 




5193




 





 





 





 





 





 



 } 




5194




 





 





 





 





 





 



   




5195




 





 





 





 





 





 



 =head2 reduce 




5196




 





 





 





 





 





 



   




5197




 





 





 





 





 





 



 From: Why Functional Programming Matters: L 




5198




 





 





 





 





 





 



   




5199




 





 





 





 





 





 



 L 




5200




 





 





 





 





 





 



   




5201




 





 





 





 





 





 



 DON'T TRY THIS AT HOME, C PROGRAMMERS. 




5202




 





 





 





 





 





 



   




5203




 





 





 





 





 





 



  sub reduce (&@) { 




5204




 





 





 





 





 





 



    my ($proc, $first, @rest) = @_; 




5205




 





 





 





 





 





 



    return $first if @rest == 0; 




5206




 





 





 





 





 





 



    local ($a, $b) = ($first, reduce($proc, @rest)); 




5207




 





 





 





 





 





 



    return $proc->(); 




5208




 





 





 





 





 





 



  } 




5209




 





 





 





 





 





 



   




5210




 





 





 





 





 





 



 Many functions can then be implemented with very little code. Such as: 




5211




 





 





 





 





 





 



   




5212




 





 





 





 





 





 



  sub mean { (reduce {$a + $b} @_) / @_ } 




5213




 





 





 





 





 





 



   




5214




 





 





 





 





 





 



 =cut 




5215




 





 





 





 





 





 



   




5216




 





 





 





 





 





 



 sub reduce (&@) { 




5217



  
0
  




 





 




  
0
  



  
1
  




0



   my ($proc, $first, @rest) = @_; 




5218



  
0
  



  
  0
  




 





 





 





0



   return $first if @rest == 0; 




5219




28





 





 




  
28
  




 





135865



   no warnings; 




 




28





 





 





 





 





61



   




 




28





 





 





 





 





32373



   




5220



  
0
  




 





 





 





 





0



   local ($a, $b) = ($first, reduce($proc, @rest)); 




5221



  
0
  




 





 





 





 





0



   return $proc->(); 




5222




 





 





 





 





 





 



 } 




5223




 





 





 





 





 





 



   




5224




 





 





 





 





 





 



   




5225




 





 





 





 





 





 



 =head2 pivot 




5226




 





 





 





 





 





 



   




5227




 





 





 





 





 





 



 Resembles the pivot table function in Excel. 




5228




 





 





 





 





 





 



   




5229




 





 





 





 





 





 



 C is used to spread out a slim and long table to a visually improved layout. 




5230




 





 





 





 





 





 



   




5231




 





 





 





 





 





 



 For instance spreading out the results of C-selects from SQL: 




5232




 





 





 





 





 





 



   




5233




 





 





 





 





 





 



  pivot( arrayref, columnname1, columnname2, ...) 




5234




 





 





 





 





 





 



   




5235




 





 





 





 





 





 



  pivot( ref_to_array_of_arrayrefs, @list_of_names_to_down_fields ) 




5236




 





 





 





 





 





 



   




5237




 





 





 





 





 





 



 The first argument is a ref to a two dimensional table. 




5238




 





 





 





 





 





 



   




5239




 





 





 





 





 





 



 The rest of the arguments is a list which also signals the number of 




5240




 





 





 





 





 





 



 columns from left in each row that is ending up to the left of the 




5241




 





 





 





 





 





 



 data table, the rest ends up at the top and the last element of 




5242




 





 





 





 





 





 



 each row ends up as data. 




5243




 





 





 





 





 





 



   




5244




 





 





 





 





 





 



                    top1 top1 top1 top1 




5245




 





 





 





 





 





 



  left1 left2 left3 top2 top2 top2 top2 




5246




 





 





 





 





 





 



  ----- ----- ----- ---- ---- ---- ---- 




5247




 





 





 





 





 





 



                    data data data data 




5248




 





 





 





 





 





 



                    data data data data 




5249




 





 





 





 





 





 



                    data data data data 




5250




 





 





 





 





 





 



   




5251




 





 





 





 





 





 



 Example: 




5252




 





 





 





 





 





 



   




5253




 





 





 





 





 





 



  my @table=( 




5254




 





 





 





 





 





 



                ["1997","Gerd", "Weight", "Summer",66], 




5255




 





 





 





 





 





 



                ["1997","Gerd", "Height", "Summer",170], 




5256




 





 





 





 





 





 



                ["1997","Per",  "Weight", "Summer",75], 




5257




 





 





 





 





 





 



                ["1997","Per",  "Height", "Summer",182], 




5258




 





 





 





 





 





 



                ["1997","Hilde","Weight", "Summer",62], 




5259




 





 





 





 





 





 



                ["1997","Hilde","Height", "Summer",168], 




5260




 





 





 





 





 





 



                ["1997","Tone", "Weight", "Summer",70], 




5261




 





 





 





 





 





 



   




5262




 





 





 





 





 





 



                ["1997","Gerd", "Weight", "Winter",64], 




5263




 





 





 





 





 





 



                ["1997","Gerd", "Height", "Winter",158], 




5264




 





 





 





 





 





 



                ["1997","Per",  "Weight", "Winter",73], 




5265




 





 





 





 





 





 



                ["1997","Per",  "Height", "Winter",180], 




5266




 





 





 





 





 





 



                ["1997","Hilde","Weight", "Winter",61], 




5267




 





 





 





 





 





 



                ["1997","Hilde","Height", "Winter",164], 




5268




 





 





 





 





 





 



                ["1997","Tone", "Weight", "Winter",69], 




5269




 





 





 





 





 





 



   




5270




 





 





 





 





 





 



                ["1998","Gerd", "Weight", "Summer",64], 




5271




 





 





 





 





 





 



                ["1998","Gerd", "Height", "Summer",171], 




5272




 





 





 





 





 





 



                ["1998","Per",  "Weight", "Summer",76], 




5273




 





 





 





 





 





 



                ["1998","Per",  "Height", "Summer",182], 




5274




 





 





 





 





 





 



                ["1998","Hilde","Weight", "Summer",62], 




5275




 





 





 





 





 





 



                ["1998","Hilde","Height", "Summer",168], 




5276




 





 





 





 





 





 



                ["1998","Tone", "Weight", "Summer",70], 




5277




 





 





 





 





 





 



   




5278




 





 





 





 





 





 



                ["1998","Gerd", "Weight", "Winter",64], 




5279




 





 





 





 





 





 



                ["1998","Gerd", "Height", "Winter",171], 




5280




 





 





 





 





 





 



                ["1998","Per",  "Weight", "Winter",74], 




5281




 





 





 





 





 





 



                ["1998","Per",  "Height", "Winter",183], 




5282




 





 





 





 





 





 



                ["1998","Hilde","Weight", "Winter",62], 




5283




 





 





 





 





 





 



                ["1998","Hilde","Height", "Winter",168], 




5284




 





 





 





 





 





 



                ["1998","Tone", "Weight", "Winter",71], 




5285




 





 





 





 





 





 



              ); 




5286




 





 





 





 





 





 



   




5287




 





 





 





 





 





 



 . 




5288




 





 





 





 





 





 



   




5289




 





 





 





 





 





 



  my @reportA=pivot(\@table,"Year","Name"); 




5290




 





 





 





 





 





 



  print "\n\nReport A\n\n".tablestring(\@reportA); 




5291




 





 





 





 





 





 



   




5292




 





 





 





 





 





 



 Will print: 




5293




 





 





 





 





 





 



   




5294




 





 





 





 





 





 



  Report A 




5295




 





 





 





 





 





 



   




5296




 





 





 





 





 





 



  Year Name  Height Height Weight Weight 




5297




 





 





 





 





 





 



             Summer Winter Summer Winter 




5298




 





 





 





 





 





 



  ---- ----- ------ ------ ------ ------ 




5299




 





 





 





 





 





 



  1997 Gerd  170    158    66     64 




5300




 





 





 





 





 





 



  1997 Hilde 168    164    62     61 




5301




 





 





 





 





 





 



  1997 Per   182    180    75     73 




5302




 





 





 





 





 





 



  1997 Tone                70     69 




5303




 





 





 





 





 





 



  1998 Gerd  171    171    64     64 




5304




 





 





 





 





 





 



  1998 Hilde 168    168    62     62 




5305




 





 





 





 





 





 



  1998 Per   182    183    76     74 




5306




 





 





 





 





 





 



  1998 Tone                70     71 




5307




 





 





 





 





 





 



   




5308




 





 





 





 





 





 



 . 




5309




 





 





 





 





 





 



   




5310




 





 





 





 





 





 



  my @reportB=pivot([map{$_=[@$_[0,3,2,1,4]]}(@t=@table)],"Year","Season"); 




5311




 





 





 





 





 





 



  print "\n\nReport B\n\n".tablestring(\@reportB); 




5312




 





 





 





 





 





 



   




5313




 





 





 





 





 





 



 Will print: 




5314




 





 





 





 





 





 



   




5315




 





 





 





 





 





 



  Report B 




5316




 





 





 





 





 





 



   




5317




 





 





 





 





 





 



  Year Season Height Height Height Weight Weight Weight Weight 




5318




 





 





 





 





 





 



              Gerd   Hilde  Per    Gerd   Hilde  Per    Tone 




5319




 





 





 





 





 





 



  ---- ------ ------ ------ -----  -----  ------ ------ ------ 




5320




 





 





 





 





 





 



  1997 Summer 170    168    182    66     62     75     70 




5321




 





 





 





 





 





 



  1997 Winter 158    164    180    64     61     73     69 




5322




 





 





 





 





 





 



  1998 Summer 171    168    182    64     62     76     70 




5323




 





 





 





 





 





 



  1998 Winter 171    168    183    64     62     74     71 




5324




 





 





 





 





 





 



   




5325




 





 





 





 





 





 



 . 




5326




 





 





 





 





 





 



   




5327




 





 





 





 





 





 



  my @reportC=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name","Attributt"); 




5328




 





 





 





 





 





 



  print "\n\nReport C\n\n".tablestring(\@reportC); 




5329




 





 





 





 





 





 



   




5330




 





 





 





 





 





 



 Will print: 




5331




 





 





 





 





 





 



   




5332




 





 





 





 





 





 



  Report C 




5333




 





 





 





 





 





 



   




5334




 





 





 





 





 





 



  Name  Attributt 1997   1997   1998   1998 




5335




 





 





 





 





 





 



                  Summer Winter Summer Winter 




5336




 





 





 





 





 





 



  ----- --------- ------ ------ ------ ------ 




5337




 





 





 





 





 





 



  Gerd  Height     170    158    171    171 




5338




 





 





 





 





 





 



  Gerd  Weight      66     64     64     64 




5339




 





 





 





 





 





 



  Hilde Height     168    164    168    168 




5340




 





 





 





 





 





 



  Hilde Weight      62     61     62     62 




5341




 





 





 





 





 





 



  Per   Height     182    180    182    183 




5342




 





 





 





 





 





 



  Per   Weight      75     73     76     74 




5343




 





 





 





 





 





 



  Tone  Weight      70     69     70     71 




5344




 





 





 





 





 





 



   




5345




 





 





 





 





 





 



 . 




5346




 





 





 





 





 





 



   




5347




 





 





 





 





 





 



  my @reportD=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name"); 




5348




 





 





 





 





 





 



  print "\n\nReport D\n\n".tablestring(\@reportD); 




5349




 





 





 





 





 





 



   




5350




 





 





 





 





 





 



 Will print: 




5351




 





 





 





 





 





 



   




5352




 





 





 





 





 





 



  Report D 




5353




 





 





 





 





 





 



   




5354




 





 





 





 





 





 



  Name  Height Height Height Height Weight Weight Weight Weight 




5355




 





 





 





 





 





 



        1997   1997   1998   1998   1997   1997   1998   1998 




5356




 





 





 





 





 





 



        Summer Winter Summer Winter Summer Winter Summer Winter 




5357




 





 





 





 





 





 



  ----- ------ ------ ------ ------ ------ ------ ------ ------ 




5358




 





 





 





 





 





 



  Gerd  170    158    171    171    66     64     64     64 




5359




 





 





 





 





 





 



  Hilde 168    164    168    168    62     61     62     62 




5360




 





 





 





 





 





 



  Per   182    180    182    183    75     73     76     74 




5361




 





 





 





 





 





 



  Tone                              70     69     70     71 




5362




 





 





 





 





 





 



   




5363




 





 





 





 





 





 



 Options: 




5364




 





 





 





 





 





 



   




5365




 





 





 





 





 





 



 Options to sort differently and show sums and percents are available. (...MORE DOC ON THAT LATER...) 




5366




 





 





 





 





 





 



   




5367




 





 





 





 





 





 



 See also L 




5368




 





 





 





 





 





 



   




5369




 





 





 





 





 





 



 =cut 




5370




 





 





 





 





 





 



   




5371




 





 





 





 





 





 



 sub pivot { 




5372




4





 





 




  
4
  



  
1
  




11



   my($tabref,@vertikalefelt)=@_; 




5373




4




  
 50
  




 





 





 





15



   my %opt=ref($vertikalefelt[-1]) eq 'HASH' ? %{pop(@vertikalefelt)} : (); 




 



  
0
  




 





 





 





 





0



   




5374




4




  
 50
  




 





 





 





16



   my $opt_sum=1 if $opt{sum}; 




5375




4




  
 50
  



  
  0
  




 





 





8



   my $opt_pro=exists $opt{prosent}?$opt{prosent}||0:undef; 




5376




4





 




  
 50
  




 





 





23



   my $sortsub          = $opt{'sortsub'}          || \&_sortsub; 




5377




4





 




  
 33
  




 





 





18



   my $sortsub_bortover = $opt{'sortsub_bortover'} || $sortsub; 




5378




4





 




  
 33
  




 





 





29



   my $sortsub_nedover  = $opt{'sortsub_nedover'}  || $sortsub; 




5379




 





 





 





 





 





 



   #print serialize(\%opt,'opt'); 




5380




 





 





 





 





 





 



   #print serialize(\$opt_pro,'opt_pro'); 




5381




4





 





 





 





 





7



   my $antned=0+@vertikalefelt; 




5382




4





 





 





 





 





7



   my $bakerst=-1+@{$$tabref[0]}; 




 




4





 





 





 





 





10



   




5383




4





 





 





 





 





5



   my(%h,%feltfinnes,%sum); 




5384




 





 





 





 





 





 



   #print "Bakerst<$bakerst>\n"; 




5385




4





 





 





 





 





9



   for(@$tabref){ 




5386




112





 





 





 





 





256



     my $rad=join($;,@$_[0..($antned-1)]); 




5387




112





 





 





 





 





222



     my $felt=join($;,@$_[$antned..($bakerst-1)]); 




5388




112





 





 





 





 





150



     my $verdi=$$_[$bakerst]; 




5389




112




  
 50
  




 





 





 





240



     length($rad) or $rad=' '; 




5390




112




  
 50
  




 





 





 





185



     length($felt) or $felt=' '; 




5391




112





 





 





 





 





227



     $h{$rad}{$felt}=$verdi; 




5392




112





 





 





 





 





239



     $h{$rad}{"%$felt"}=$verdi; 




5393




112




  
 50
  



  
 33
  




 





 





411



     if($opt_sum or defined $opt_pro){ 




5394



  
0
  




 





 





 





 





0



       $h{$rad}{Sum}+=$verdi; 




5395



  
0
  




 





 





 





 





0



       $sum{$felt}+=$verdi; 




5396



  
0
  




 





 





 





 





0



       $sum{Sum}+=$verdi; 




5397




 





 





 





 





 





 



     } 




5398




112





 





 





 





 





164



     $feltfinnes{$felt}++; 




5399




112




  
 50
  




 





 





 





319



     $feltfinnes{"%$felt"}++ if $opt_pro; 




5400




 





 





 





 





 





 



   } 




5401




4





 





 





 





 





26



   my @feltfinnes = sort $sortsub_bortover keys%feltfinnes; 




5402




4




  
 50
  




 





 





 





12



   push @feltfinnes, "Sum" if $opt_sum; 




5403




4





 





 





 





 





8



   my @t=([@vertikalefelt,map{replace($_,$;,"\n")}@feltfinnes]); 




 




23





 





 





 





 





42



   




5404




 





 





 





 





 





 



   #print serialize(\@feltfinnes,'feltfinnes'); 




5405




 





 





 





 





 





 



   #print serialize(\%h,'h'); 




5406




 





 





 





 





 





 



   #print "H = ".join(", ",sort _sortsub keys%h)."\n"; 




5407




4





 





 





 





 





18



   for my $rad (sort $sortsub_nedover keys(%h)){ 




5408




 





 





 





 





 





 



     my @rad=(split($;,$rad), 




5409




 





 





 





 





 





 



 	     map{ 




5410




23




  
 50
  



  
 33
  




 





 





154



 	       if(/^\%/ and defined $opt_pro){ 




 




120





 





 





 





 





309



   




5411



  
0
  




 





 





 





 





0



 		 my $sum=$h{$rad}{Sum}; 




5412



  
0
  




 





 





 





 





0



 		 my $verdi=$h{$rad}{$_}; 




5413



  
0
  



  
  0
  




 





 





 





0



 		 if($sum!=0){ 




5414



  
0
  



  
  0
  




 





 





 





0



 		   defined $verdi 




5415




 





 





 





 





 





 



                    ?sprintf("%*.*f",3+1+$opt_pro,$opt_pro,100*$verdi/$sum) 




5416




 





 





 





 





 





 



 		   :$verdi; 




5417




 





 





 





 





 





 



 		 } 




5418




 





 





 





 





 





 



 		 else{ 




5419



  
0
  



  
  0
  




 





 





 





0



 		   $verdi!=0?"div0":$verdi; 




5420




 





 





 





 





 





 



 		 } 




5421




 





 





 





 





 





 



 	       } 




5422




 





 





 





 





 





 



 	       else{ 




5423




120





 





 





 





 





243



 		 $h{$rad}{$_}; 




5424




 





 





 





 





 





 



 	       } 




5425




 





 





 





 





 





 



 	     } 




5426




 





 





 





 





 





 



 	     @feltfinnes); 




5427




23





 





 





 





 





84



     push(@t,[@rad]); 




5428




 





 





 





 





 





 



   } 




5429




4




  
 50
  




 





 





 





12



   push(@t,"-",["Sum",(map{""}(2..$antned)),map{print "<$_>\n";$sum{$_}}@feltfinnes]) if $opt_sum; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5430




4





 





 





 





 





53



   return @t; 




5431




 





 





 





 





 





 



 } 




5432




 





 





 





 





 





 



   




5433




 





 





 





 





 





 



 # default sortsub for pivot() 




5434




 





 





 





 





 





 



   




5435




 





 





 





 





 





 



 sub _sortsub { 




5436




28





 





 




  
28
  




 





160



   no warnings; 




 




28





 





 





 





 





47



   




 




28





 





 





 





 





13139



   




5437




 





 





 





 





 





 



   #my $c=($a<=>$b)||($a cmp $b); 




5438




 





 





 





 





 





 



   #return $c if $c; 




5439




 





 





 





 





 





 



   #printf "%-30s %-30s  ",replace($a,$;,','),replace($b,$;,','); 




5440




72





 





 




  
72
  




 





489



   my @a=split $;,$a; 




5441




72





 





 





 





 





470



   my @b=split $;,$b; 




5442




72





 





 





 





 





172



   for(0..$#a){ 




5443




110





 





 





 





 





232



     my $c=$a[$_]<=>$b[$_]; 




5444




110




  
100
  



  
 66
  




 





 





398



     return $c if $c and "$a[$_]$b[$_]"!~/[iI][nN][fF]|þ/i; # inf(inity) 




5445




96





 





 





 





 





125



     $c=$a[$_]cmp$b[$_]; 




5446




96




  
100
  




 





 





 





274



     return $c if $c; 




5447




 





 





 





 





 





 



   } 




5448



  
0
  




 





 





 





 





0



   return 0; 




5449




 





 





 





 





 





 



 } 




5450




 





 





 





 





 





 



   




5451




 





 





 





 





 





 



 =head2 tablestring 




5452




 





 





 





 





 





 



   




5453




 





 





 





 





 





 



 B a reference to an array of arrayrefs  -- a two dimensional table of strings and numbers 




5454




 





 





 





 





 





 



   




5455




 





 





 





 





 





 



 B a string containing the textual table -- a string of two or more lines 




5456




 





 





 





 





 





 



   




5457




 





 





 





 





 





 



 The first arrayref in the list refers to a list of either column headings (scalar) 




5458




 





 





 





 





 





 



 or ... (...more later...) 




5459




 





 





 





 





 





 



   




5460




 





 





 





 





 





 



 In this output table: 




5461




 





 





 





 





 





 



   




5462




 





 





 





 





 





 



 - the columns will not be wider than necessary by its widest value (any -tags are removed in every internal width-calculation) 




5463




 





 





 





 





 





 



   




5464




 





 





 





 





 





 



 - multi-lined cell values are handled also 




5465




 





 





 





 





 





 



   




5466




 





 





 





 





 





 



 - and so are html-tags, if the output is to be used inside -tags on a web page. 




5467




 





 





 





 





 





 



   




5468




 





 





 





 





 





 



 - columns with just numeric values are right justified (header row excepted) 




5469




 





 





 





 





 





 



   




5470




 





 





 





 





 





 



 Example: 




5471




 





 





 





 





 





 



   




5472




 





 





 





 





 





 



  print tablestring([ 




5473




 





 





 





 





 





 



    [qw/AA BB CCCC/], 




5474




 





 





 





 





 





 



    [123,23,"d"], 




5475




 





 





 





 





 





 



    [12,23,34], 




5476




 





 





 





 





 





 



    [77,88,99], 




5477




 





 





 





 





 





 



    ["lin\nes",12,"asdff\nfdsa\naa"],[0,22,"adf"] 




5478




 





 





 





 





 





 



  ]); 




5479




 





 





 





 





 





 



   




5480




 





 





 





 





 





 



 Prints this string of 11 lines: 




5481




 





 





 





 





 





 



   




5482




 





 





 





 





 





 



  AA  BB CCCC 




5483




 





 





 





 





 





 



  --- -- ----- 




5484




 





 





 





 





 





 



  123 23 d 




5485




 





 





 





 





 





 



  12  23 34 




5486




 





 





 





 





 





 



  77   8 99 




5487




 





 





 





 





 





 



   




5488




 





 





 





 





 





 



  lin 12 asdff 




5489




 





 





 





 





 





 



  es     fdsa 




5490




 





 





 





 





 





 



         aa 




5491




 





 





 





 





 





 



   




5492




 





 





 





 





 





 



  10  22 adf 




5493




 





 





 





 





 





 



   




5494




 





 





 





 





 





 



 As you can see, rows containing multi-lined cells gets an empty line before and after the row to separate it more clearly. 




5495




 





 





 





 





 





 



   




5496




 





 





 





 





 





 



 =cut 




5497




 





 





 





 





 





 



   




5498




 





 





 





 





 





 



 sub tablestring { 




5499




5





 





 




  
5
  



  
1
  




27



   my $tab=shift; 




5500




5




  
 50
  




 





 





 





14



   my %o=$_[0] ? %{shift()} : (); 




 



  
0
  




 





 





 





 





0



   




5501




5





 





 





 





 





8



   my $fjern_tom=$o{fjern_tomme_kolonner}; 




5502




5





 





 





 





 





8



   my $ikke_space=$o{ikke_space}; 




5503




5





 




  
 50
  




 





 





23



   my $nodup=$o{nodup}||0; 




5504




5





 





 





 





 





7



   my $ikke_hodestrek=$o{ikke_hodestrek}; 




5505




5




  
 50
  




 





 





 





13



   my $pagesize=exists $o{pagesize} ? $o{pagesize}-3 : 9999999; 




5506




5





 





 





 





 





6



   my $venstretvang=$o{venstre}; 




5507




5





 





 





 





 





6



   my(@bredde,@venstre,@hoeyde,@ikketom,@nodup); 




5508




5





 





 





 





 





7



   my $hode=1; 




5509




5





 





 





 





 





8



   my $i=0; 




5510




5





 





 





 





 





8



   my $j; 




5511




5





 





 





 





 





11



   for(@$tab){ 




5512




33





 





 





 





 





34



     $j=0; 




5513




33





 





 





 





 





43



     $hoeyde[$i]=0; 




5514




33





 





 





 





 





37



     my $nodup_rad=$nodup; 




5515




33




  
 50
  




 





 





 





72



     if(ref($_) eq 'ARRAY'){ 




5516




33





 





 





 





 





53



       for(@$_){ 




5517




210





 





 





 





 





272



 	my $celle=$_; 




5518




210





 




  
100
  




 





 





431



 	$bredde[$j]||=0; 




5519




210




  
 50
  



  
 33
  




 





 





582



 	if($nodup_rad and $i>0 and $$tab[$i][$j] eq $$tab[$i-1][$j] || ($nodup_rad=0)){ 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
 33
  




 





 





 



   




5520



  
0
  



  
  0
  




 





 





 





0



 	  $celle=$nodup==1?"":$nodup; 




5521



  
0
  




 





 





 





 





0



 	  $nodup[$i][$j]=1; 




5522




 





 





 





 





 





 



 	} 




5523




 





 





 





 





 





 



 	else{ 




5524




210





 





 





 





 





213



 	  my $hoeyde=0; 




5525




210





 





 





 





 





201



 	  my $bredere; 




5526




28





 





 




  
28
  




 





1335



 	  no warnings; 




 




28





 





 





 





 





1237



   




 




28





 





 





 





 





16611



   




5527




210




  
100
  



  
100
  




 





 





799



 	  $ikketom[$j]=1 if !$hode && length($celle)>0; 




5528




210





 





 





 





 





445



 	  for(split("\n",$celle)){ 




5529




236




  
 50
  




 





 





 





411



 	    $bredere=/




5530




236





 





 





 





 





277



 	    s/<[^>]+>//g; 




5531




236





 





 





 





 





239



 	    $hoeyde++; 




5532




236





 





 





 





 





265



 	    s/>/>/g; 




5533




236





 





 





 





 





258



 	    s/</




5534




236




  
100
  




 





 





 





585



 	    $bredde[$j]=length($_)+1+$bredere if length($_)+1+$bredere>$bredde[$j]; 




5535




236




  
100
  



  
100
  




 





 





1545



 	    $venstre[$j]=1 if $_ && !/^\s*[\-\+]?(\d+|\d*\.\d+)\s*\%?$/ && !$hode; 




 




 





 




  
100
  




 





 





 



   




5536




 





 





 





 





 





 



 	  } 




5537




210




  
100
  



  
 66
  




 





 





614



 	  if( $hoeyde>1 && !$ikke_space){ 




5538




25




  
100
  




 





 





 





53



 	    $hoeyde++ unless $hode; 




5539




25




  
100
  



  
100
  




 





 





69



 	    $hoeyde[$i-1]++ if $i>1 && $hoeyde[$i-1]==1; 




5540




 





 





 





 





 





 



 	  } 




5541




210




  
100
  




 





 





 





477



 	  $hoeyde[$i]=$hoeyde if $hoeyde>$hoeyde[$i]; 




5542




 





 





 





 





 





 



 	} 




5543




210





 





 





 





 





279



 	$j++; 




5544




 





 





 





 





 





 



       } 




5545




 





 





 





 





 





 



     } 




5546




 





 





 





 





 





 



     else{ 




5547



  
0
  




 





 





 





 





0



       $hoeyde[$i]=1; 




5548



  
0
  




 





 





 





 





0



       $ikke_hodestrek=1; 




5549




 





 





 





 





 





 



     } 




5550




33





 





 





 





 





37



     $hode=0; 




5551




33





 





 





 





 





50



     $i++; 




5552




 





 





 





 





 





 



   } 




5553




5





 





 





 





 





9



   $i=$#hoeyde; 




5554




5





 





 





 





 





7



   $j=$#bredde; 




5555




5




  
 50
  



  
 33
  




 





 





24



   if($i==0 or $venstretvang) { @venstre=map{1}(0..$j)                         } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5556




5




  
 50
  




 





 





 





11



   else { for(0..$j){ $venstre[$_]=1 if !$ikketom[$_] }  } 




 




33





 





 





 





 





68



   




5557




5





 





 





 





 





8



   my @tabut; 




5558




5





 





 





 





 





5



   my $rad_startlinje=0; 




5559




5





 





 





 





 





8



   my @overskrift; 




5560




 





 





 





 





 





 



   my $overskrift_forrige; 




5561




5





 





 





 





 





8



   for my $x (0..$i){ 




5562




33




  
 50
  




 





 





 





88



     if($$tab[$x] eq '-'){ 




5563



  
0
  



  
  0
  




 





 





 





0



       my @tegn=map {$$tab[$x-1][$_]=~/\S/?"-":" "} (0..$j); 




 



  
0
  




 





 





 





 





0



   




5564



  
0
  




 





 





 





 





0



       $tabut[$rad_startlinje]=join(" ",map {$tegn[$_] x ($bredde[$_]-1)} (0..$j)); 




 



  
0
  




 





 





 





 





0



   




5565




 





 





 





 





 





 



     } 




5566




 





 





 





 





 





 



     else{ 




5567




33





 





 





 





 





54



       for my $y (0..$j){ 




5568




210




  
 50
  



  
 33
  




 





 





464



 	next if $fjern_tom && !$ikketom[$y]; 




5569




28





 





 




  
28
  




 





1318



 	no warnings; 




 




28





 





 





 





 





49



   




 




28





 





 





 





 





22085



   




5570




 





 





 





 





 





 



 	 




5571




210




  
  0
  



  
 33
  




 





 





1343



 	my @celle= 




 




 




  
 50
  




 





 





 





 



   




5572




 





 





 





 





 





 



             !$overskrift_forrige&&$nodup&&$nodup[$x][$y] 




5573




 





 





 





 





 





 



 	    ?($nodup>0?():((" " x (($bredde[$y]-length($nodup))/2)).$nodup)) 




5574




 





 





 





 





 





 



             :split("\n",$$tab[$x][$y]); 




5575




210





 





 





 





 





434



 	for(0..($hoeyde[$x]-1)){ 




5576




261





 





 





 





 





310



 	  my $linje=$rad_startlinje+$_; 




5577




261





 




  
100
  




 





 





606



 	  my $txt=shift @celle || ''; 




5578




261




  
100
  



  
100
  




 





 





1489



 	  $txt=sprintf("%*s",$bredde[$y]-1,$txt) if length($txt)>0 && !$venstre[$y] && ($x>0 || $ikke_hodestrek); 




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 66
  




 





 





 



   




5579




261





 





 





 





 





374



 	  $tabut[$linje].=$txt; 




5580




261




  
100
  




 





 





 





431



 	  if($y==$j){ 




5581




42





 





 





 





 





185



 	    $tabut[$linje]=~s/\s+$//; 




5582




 





 





 





 





 





 



 	  } 




5583




 





 





 





 





 





 



 	  else{ 




5584




219





 





 





 





 





223



 	    my $bredere; 




5585




219




  
 50
  




 





 





 





399



 	       $bredere = $txt=~/




5586




219





 





 





 





 





275



 	    $txt=~s/<[^>]+>//g; 




5587




219





 





 





 





 





271



 	    $txt=~s/>/>/g; 




5588




219





 





 





 





 





245



 	    $txt=~s/</




5589




219





 





 





 





 





591



 	    $tabut[$linje].= ' ' x ($bredde[$y]-length($txt)-$bredere); 




5590




 





 





 





 





 





 



 	  } 




5591




 





 





 





 





 





 



 	} 




5592




 





 





 





 





 





 



       } 




5593




 





 





 





 





 





 



     } 




5594




33





 





 





 





 





45



     $rad_startlinje+=$hoeyde[$x]; 




5595




 





 





 





 





 





 



   




5596




 





 





 





 





 





 



     #--lage streker? 




5597




33




  
 50
  




 





 





 





63



     if(not $ikke_hodestrek){ 




5598




33




  
100
  



  
 33
  




 





 





155



       if($x==0){ 




 




 




  
 50
  



  
 33
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




5599




5





 





 





 





 





9



 	for my $y (0..$j){ 




5600




33




  
 50
  



  
 33
  




 





 





64



 	  next if $fjern_tom && !$ikketom[$y]; 




5601




33





 





 





 





 





68



 	  $tabut[$rad_startlinje].=('-' x ($bredde[$y]-1))." "; 




5602




 





 





 





 





 





 



 	} 




5603




5





 





 





 





 





8



 	$rad_startlinje++; 




5604




5





 





 





 





 





15



 	@overskrift=("",@tabut); 




5605




 





 





 





 





 





 



       } 




5606




 





 





 





 





 





 



       elsif( 




5607




 





 





 





 





 





 



 	    $x%$pagesize==0 || $nodup>0&&!$nodup[$x+1][$nodup-1] 




5608




 





 





 





 





 





 



 	    and $x+1<@$tab 




5609




 





 





 





 





 





 



 	    and !$ikke_hodestrek 




5610




 





 





 





 





 





 



 	    ) 




5611




 





 





 





 





 





 



       { 




5612



  
0
  




 





 





 





 





0



 	push(@tabut,@overskrift); 




5613



  
0
  




 





 





 





 





0



 	$rad_startlinje+=@overskrift; 




5614



  
0
  




 





 





 





 





0



 	$overskrift_forrige=1; 




5615




 





 





 





 





 





 



       } 




5616




 





 





 





 





 





 



       else{ 




5617




28





 





 





 





 





52



 	$overskrift_forrige=0; 




5618




 





 





 





 





 





 



       } 




5619




 





 





 





 





 





 



     } 




5620




 





 





 





 





 





 



   }#for x 




5621




5





 





 





 





 





56



   return join("\n",@tabut)."\n"; 




5622




 





 





 





 





 





 



 } 




5623




 





 





 





 





 





 



   




5624




 





 





 





 





 





 



 =head2 serialize 




5625




 





 





 





 





 





 



   




5626




 





 





 





 





 





 



 Returns a data structure as a string. See also C 




5627




 





 





 





 





 





 



 (serialize was created long time ago before Data::Dumper appeared on 




5628




 





 





 





 





 





 



 CPAN, before CPAN even...) 




5629




 





 





 





 





 





 



   




5630




 





 





 





 





 





 



 B One to four arguments. 




5631




 





 





 





 





 





 



   




5632




 





 





 





 





 





 



 First argument: A reference to the structure you want. 




5633




 





 





 





 





 





 



   




5634




 





 





 





 





 





 



 Second argument: (optional) The name the structure will get in the output string. 




5635




 





 





 





 





 





 



 If second argument is missing or is undef or '', it will get no name in the output. 




5636




 





 





 





 





 





 



   




5637




 





 





 





 





 





 



 Third argument: (optional) The string that is returned is also put 




5638




 





 





 





 





 





 



 into a created file with the name given in this argument.  Putting a 




5639




 





 





 





 





 





 



 C<< > >> char in from of the filename will append that file 




5640




 





 





 





 





 





 



 instead. Use C<''> or C to not write to a file if you want to 




5641




 





 





 





 





 





 



 use a fourth argument. 




5642




 





 





 





 





 





 



   




5643




 





 





 





 





 





 



 Fourth argument: (optional) A number signalling the depth on which newlines is used in the output. 




5644




 





 





 





 





 





 



 The default is infinite (some big number) so no extra newlines are output. 




5645




 





 





 





 





 





 



   




5646




 





 





 





 





 





 



 B A string containing the perl-code definition that makes that data structure. 




5647




 





 





 





 





 





 



 The input reference (first input argument) can be to an array, hash or a string. 




5648




 





 





 





 





 





 



 Those can contain other refs and strings in a deep data structure. 




5649




 





 





 





 





 





 



   




5650




 





 





 





 





 





 



 Limitations: 




5651




 





 





 





 





 





 



   




5652




 





 





 





 





 





 



 - Code refs are not handled (just returns C) 




5653




 





 





 





 





 





 



   




5654




 





 





 





 





 





 



 - Regex, class refs and circular recursive structures are also not handled. 




5655




 





 





 





 





 





 



   




5656




 





 





 





 





 





 



 B 




5657




 





 





 





 





 





 



   




5658




 





 





 





 





 





 



   $a = 'test'; 




5659




 





 





 





 





 





 



   @b = (1,2,3); 




5660




 





 





 





 





 





 



   %c = (1=>2, 2=>3, 3=>5, 4=>7, 5=>11); 




5661




 





 





 





 





 





 



   %d = (1=>2, 2=>3, 3=>\5, 4=>7, 5=>11, 6=>[13,17,19,{1,2,3,'asdf\'\\\''}],7=>'x'); 




5662




 





 





 





 





 





 



   print serialize(\$a,'a'); 




5663




 





 





 





 





 





 



   print serialize(\@b,'tab'); 




5664




 





 





 





 





 





 



   print serialize(\%c,'c'); 




5665




 





 





 





 





 





 



   print serialize(\%d,'d'); 




5666




 





 





 





 





 





 



   print serialize(\("test'n roll",'brb "brb"')); 




5667




 





 





 





 





 





 



   print serialize(\%d,'d',undef,1); 




5668




 





 





 





 





 





 



   




5669




 





 





 





 





 





 



 Prints accordingly: 




5670




 





 





 





 





 





 



   




5671




 





 





 





 





 





 



  $a='test'; 




5672




 





 





 





 





 





 



  @tab=('1','2','3'); 




5673




 





 





 





 





 





 



  %c=('1','2','2','3','3','5','4','7','5','11'); 




5674




 





 





 





 





 





 



  %d=('1'=>'2','2'=>'3','3'=>\'5','4'=>'7','5'=>'11','6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}]); 




5675




 





 





 





 





 





 



  ('test\'n roll','brb "brb"'); 




5676




 





 





 





 





 





 



  %d=('1'=>'2', 




5677




 





 





 





 





 





 



  '2'=>'3', 




5678




 





 





 





 





 





 



  '3'=>\'5', 




5679




 





 





 





 





 





 



  '4'=>'7', 




5680




 





 





 





 





 





 



  '5'=>'11', 




5681




 





 





 





 





 





 



  '6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}], 




5682




 





 





 





 





 





 



  '7'=>'x'); 




5683




 





 





 





 





 





 



   




5684




 





 





 





 





 





 



 Areas of use: 




5685




 





 





 





 





 





 



   




5686




 





 





 





 





 





 



 - Debugging (first and foremost) 




5687




 





 





 





 





 





 



   




5688




 





 





 





 





 





 



 - Storing arrays and hashes and data structures of those on file, database or sending them over the net 




5689




 





 





 





 





 





 



   




5690




 





 





 





 





 





 



 - eval earlier stored string to get back the data structure 




5691




 





 





 





 





 





 



   




5692




 





 





 





 





 





 



 Be aware of the security implications of Cing a perl code string 




5693




 





 





 





 





 





 



 stored somewhere that unauthorized users can change them! You are 




5694




 





 





 





 





 





 



 probably better of using L or L without 




5695




 





 





 





 





 





 



 enabling the CODE-options if you have such security issues. 




5696




 





 





 





 





 





 



 More on decompiling Perl-code: L or L. 




5697




 





 





 





 





 





 



   




5698




 





 





 





 





 





 



 =head2 dserialize 




5699




 





 





 





 





 





 



   




5700




 





 





 





 





 





 



 Debug-serialize, dumping data structures for you to look at. 




5701




 





 





 





 





 





 



   




5702




 





 





 





 





 





 



 Same as C but the output is given a newline every 80th character. 




5703




 





 





 





 





 





 



 (Every 80th or whatever C<$Acme::Tools::Dserialize_width> contains) 




5704




 





 





 





 





 





 



   




5705




 





 





 





 





 





 



 =cut 




5706




 





 





 





 





 





 



   




5707




 





 





 





 





 





 



 our $Dserialize_width=80; 




5708



  
0
  




 




  
  0
  



  
0
  




 





0



 sub _kallstack { my $tilbake=shift||0; my @c; my $ret; $ret.=serialize(\@c,"caller$tilbake") while @c=caller(++$tilbake); $ret } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5709



  
0
  




 





 




  
0
  



  
1
  




0



 sub dserialize{join "\n",serialize(@_)=~/(.{1,$Dserialize_width})/gs} 




5710




 





 





 





 





 





 



 sub serialize { 




5711




28





 





 




  
28
  




 





150



   no warnings; 




 




28





 





 





 





 





48



   




 




28





 





 





 





 





127928



   




5712




1127





 





 




  
1127
  



  
1
  




4775



   my($r,$name,$filename,$level)=@_; 




5713




1127





 




  
100
  




 





 





3033



   my @r=(undef,undef,($level||0)-1); 




5714




1127




  
 50
  




 





 





 





2122



   if($filename){ 




5715



  
0
  



  
  0
  




 





 





 





0



     open my $fh, '>', $filename or croak("FEIL: could not open file $filename\n" . _kallstack()); 




5716



  
0
  




 





 





 





 





0



     my $ret=serialize($r,$name,undef,$level); 




5717



  
0
  




 





 





 





 





0



     print $fh "$ret\n1;\n"; 




5718



  
0
  




 





 





 





 





0



     close($fh); 




5719



  
0
  




 





 





 





 





0



     return $ret; 




5720




 





 





 





 





 





 



   } 




5721




1127




  
100
  




 





 





 





2884



   if(ref($r) eq 'SCALAR'){ 




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




5722




903




  
 50
  




 





 





 





1580



     return "\$$name=".serialize($r,@r).";\n" if $name; 




5723




903




  
100
  




 





 





 





1692



     return "undef" unless defined $$r; 




5724




899





 





 





 





 





1128



     my $ret=$$r; 




5725




899





 





 





 





 





1410



     $ret=~s/\\/\\\\/g; 




5726




899





 





 





 





 





1140



     $ret=~s/\'/\\'/g; 




5727




899





 





 





 





 





2785



     return "'$ret'"; 




5728




 





 





 





 





 





 



   } 




5729




 





 





 





 





 





 



   elsif(ref($r) eq 'ARRAY'){ 




5730




72




  
100
  




 





 





 





163



     return "\@$name=".serialize($r,@r).";\n" if $name; 




5731




70





 





 





 





 





99



     my $ret="("; 




5732




70





 





 





 





 





134



     for(@$r){ 




5733




350





 





 





 





 





819



       $ret.=serialize(\$_,@r).","; 




5734




350




  
100
  




 





 





 





1019



       $ret.="\n" if $level>=0; 




5735




 





 





 





 





 





 



     } 




5736




70





 





 





 





 





237



     $ret=~s/,$//; 




5737




70





 





 





 





 





131



     $ret.=")"; 




5738




70




  
 50
  




 





 





 





144



     $ret.=";\n" if $name; 




5739




70





 





 





 





 





235



     return $ret; 




5740




 





 





 





 





 





 



   } 




5741




 





 





 





 





 





 



   elsif(ref($r) eq 'HASH'){ 




5742




31




  
100
  




 





 





 





250



     return "\%$name=".serialize($r,@r).";\n" if $name; 




5743




21





 





 





 





 





37



     my $ret="("; 




5744




21





 





 





 





 





105



     for(sort keys %$r){ 




5745




73





 





 





 





 





193



       $ret.=serialize(\$_,@r)."=>".serialize(\$$r{$_},@r).","; 




5746




73




  
 50
  




 





 





 





234



       $ret.="\n" if $level>=0; 




5747




 





 





 





 





 





 



     } 




5748




21





 





 





 





 





84



     $ret=~s/,$//; 




5749




21





 





 





 





 





33



     $ret.=")"; 




5750




21




  
 50
  




 





 





 





55



     $ret.=";\n" if $name; 




5751




21





 





 





 





 





132



     return $ret; 




5752




 





 





 





 





 





 



   } 




5753




 





 





 





 





 





 



   elsif(ref($$r) eq 'ARRAY'){ 




5754




48




  
 50
  




 





 





 





92



     return "\@$name=".serialize($r,@r).";\n" if $name; 




5755




48





 





 





 





 





63



     my $ret="["; 




5756




48





 





 





 





 





89



     for(@$$r){ 




5757




100





 





 





 





 





555



       $ret.=serialize(\$_,@r).","; 




5758




100




  
 50
  



  
 33
  




 





 





487



       $ret.="\n" if !defined $level or $level>=0; 




5759




 





 





 





 





 





 



     } 




5760




48





 





 





 





 





133



     $ret=~s/,$//; 




5761




48





 





 





 





 





67



     $ret.="]"; 




5762




48




  
 50
  




 





 





 





89



     $ret.=";\n" if $name; 




5763




48





 





 





 





 





132



     return $ret; 




5764




 





 





 





 





 





 



   } 




5765




 





 





 





 





 





 



   elsif(ref($$r) eq 'HASH'){ 




5766




73




  
 50
  




 





 





 





138



     return "\%$name=".serialize($r,@r).";\n" if $name; 




5767




73





 





 





 





 





107



     my $ret="{"; 




5768




73





 





 





 





 





268



     for(sort keys %$$r){ 




5769




214





 





 





 





 





412



       $ret.=serialize(\$_,@r)."=>".serialize(\$$$r{$_},@r).","; 




5770




214




  
 50
  




 





 





 





598



       $ret.="\n" if $level>=0; 




5771




 





 





 





 





 





 



     } 




5772




73





 





 





 





 





211



     $ret=~s/,$//; 




5773




73





 





 





 





 





93



     $ret.="}"; 




5774




73




  
 50
  




 





 





 





133



     $ret.=";\n" if $name; 




5775




73





 





 





 





 





208



     return $ret; 




5776




 





 





 





 





 





 



   } 




5777




 





 





 





 





 





 



   elsif(ref($$r) eq 'SCALAR'){ 




5778



  
0
  




 





 





 





 





0



     return "\\".serialize($$r,@r); 




5779




 





 





 





 





 





 



   } 




5780




 





 





 





 





 





 



   elsif(ref($r) eq 'LVALUE'){ 




5781



  
0
  




 





 





 





 





0



     my $s="$$r"; 




5782



  
0
  




 





 





 





 





0



     return serialize(\$s,@r); 




5783




 





 





 





 





 





 



   } 




5784




 





 





 





 





 





 



   elsif(ref($$r) eq 'CODE'){ 




5785




 





 





 





 





 





 



     #warn "Tried to serialize CODE"; 




5786



  
0
  




 





 





 





 





0



     return 'sub{croak "Can not serialize CODE-references, see perhaps B::Deparse and Storable"}' 




5787




 





 





 





 





 





 



   } 




5788




 





 





 





 





 





 



   elsif(ref($$r) eq 'GLOB'){ 




5789



  
0
  




 





 





 





 





0



     warn "Tried to serialize a GLOB"; 




5790



  
0
  




 





 





 





 





0



     return '\*STDERR' 




5791




 





 





 





 





 





 



   } 




5792




 





 





 





 





 





 



   else{ 




5793



  
0
  




 





 





 





 





0



     my $tilbake; 




5794



  
0
  




 





 





 





 





0



     my($pakke,$fil,$linje,$sub,$hasargs,$wantarray); 




5795



  
0
  




 




  
  0
  




 





 





0



       ($pakke,$fil,$linje,$sub,$hasargs,$wantarray)=caller($tilbake++) until $sub ne 'serialize' || $tilbake>20; 




5796



  
0
  




 





 





 





 





0



     croak("serialize() argument should be reference!\n". 




5797




 





 





 





 





 





 



         "\$r=$r\n". 




5798




 





 





 





 





 





 



         "ref(\$r)   = ".ref($r)."\n". 




5799




 





 





 





 





 





 



         "ref(\$\$r) = ".ref($$r)."\n". 




5800




 





 





 





 





 





 



         "kallstack:\n". _kallstack()); 




5801




 





 





 





 





 





 



   } 




5802




 





 





 





 





 





 



 } 




5803




 





 





 





 





 





 



   




5804




 





 





 





 





 





 



 =head2 srlz 




5805




 





 





 





 





 





 



   




5806




 





 





 





 





 





 



 Synonym to L, but remove unnecessary single quote chars around 




5807




 





 





 





 





 





 



 C<< \w+ >>-keys and number values (except numbers with leading zeros). Example: 




5808




 





 





 





 





 





 



   




5809




 





 





 





 





 





 



 serialize: 




5810




 





 





 





 





 





 



   




5811




 





 





 





 





 





 



  %s=('action'=>{'del'=>'0','ins'=>'0','upd'=>'18'},'post'=>'1348','pre'=>'1348', 




5812




 





 





 





 





 





 



      'updcol'=>{'Laerestednr'=>'18','Studietypenr'=>'18','Undervisningssted'=>'7','Url'=>'11'}, 




5813




 





 





 





 





 





 



      'where'=>'where 1=1'); 




5814




 





 





 





 





 





 



   




5815




 





 





 





 





 





 



 srlz: 




5816




 





 





 





 





 





 



   




5817




 





 





 





 





 





 



  %s=(action=>{del=>0,ins=>0,upd=>18},post=>1348,pre=>1348, 




5818




 





 





 





 





 





 



      updcol=>{Laerestednr=>18,Studietypenr=>18,Undervisningssted=>7,Url=>11}, 




5819




 





 





 





 





 





 



      where=>'where 1=1'); 




5820




 





 





 





 





 





 



   




5821




 





 





 





 





 





 



 Todo: update L to do the same, but in the right way. (For now  




5822




 





 





 





 





 





 



 srlz runs the string from serialize() through two C<< s/// >>, this will break 




5823




 





 





 





 





 





 



 in certain cases). L will be kept as a synonym (or the other way around). 




5824




 





 





 





 





 





 



   




5825




 





 





 





 





 





 



 =cut 




5826




 





 





 





 





 





 



   




5827




 





 





 





 





 





 



 sub srlz { 




5828



  
0
  




 





 




  
0
  



  
1
  




0



   my $s=serialize(@_); 




5829



  
0
  




 





 





 





 





0



   $s=~s,'(\w+)'=>,$1=>,g; 




5830



  
0
  




 





 





 





 





0



   $s=~s,=>'((0|[1-9]\d*)(\.\d+)?(e[-+]?\d+)?)',=>$1,gi;  #ikke ledende null!    hm                                                                                                                                           




5831



  
0
  




 





 





 





 





0



   $s; 




5832




 





 





 





 





 





 



 } 




5833




 





 





 





 





 





 



   




5834




 





 





 





 





 





 



   




5835




 





 





 





 





 





 



 =head2 sys 




5836




 





 





 





 





 





 



   




5837




 





 





 





 





 





 



 Call instead of C if you want C (Carp::croak) when something fails. 




5838




 





 





 





 





 





 



   




5839




 





 





 





 





 





 



  sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" } 




5840




 





 





 





 





 





 



   




5841




 





 





 





 





 





 



   




5842




 





 





 





 





 





 



 =cut 




5843




 





 





 





 





 





 



   




5844



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5845




 





 





 





 





 





 



   




5846




 





 





 





 





 





 



 =head2 recursed 




5847




 





 





 





 





 





 



   




5848




 





 





 





 





 





 



 Returns true or false (actually 1 or 0) depending on whether the 




5849




 





 





 





 





 





 



 current sub has been called by itself or not. 




5850




 





 





 





 





 





 



   




5851




 





 





 





 





 





 



  sub xyz 




5852




 





 





 





 





 





 



  { 




5853




 





 





 





 





 





 



     xyz() if not recursed; 




5854




 





 





 





 





 





 



   




5855




 





 





 





 





 





 



  } 




5856




 





 





 





 





 





 



   




5857




 





 





 





 





 





 



 =cut 




5858




 





 





 





 





 





 



   




5859



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub recursed {(caller(1))[3] eq (caller(2))[3]?1:0} 




5860




 





 





 





 





 





 



   




5861




 





 





 





 





 





 



 =head2 ed 




5862




 





 





 





 





 





 



   




5863




 





 





 





 





 





 



 String editor commands 




5864




 





 





 





 





 





 



   




5865




 





 





 





 





 





 



  literals:               a-z 0-9 space 




5866




 





 





 





 





 





 



  move cursor:            FBAEPN MF MB ME 




5867




 





 





 





 





 





 



  delete:                 D Md 




5868




 





 





 





 





 





 



  up/low/camelcase word   U L C 




5869




 





 





 





 





 





 



  backspace:              - 




5870




 





 





 





 





 





 



  search:                 S 




5871




 





 





 





 





 





 



  return/enter:           R 




5872




 





 





 





 





 





 



  meta/esc/alt:           M 




5873




 





 





 





 





 





 



  shift:                  T 




5874




 





 





 





 





 





 



  cut to eol:             K 




5875




 





 





 





 





 





 



  caps lock:              C 




5876




 





 





 





 





 





 



  yank:                   Y 




5877




 





 





 





 





 





 



  start and end:          < > 




5878




 





 





 





 





 





 



  macro start/end/play:   { } ! 




5879




 





 





 





 





 





 



  times for next cmd:     M  (i.e. M24a inserts 24 a's) 




5880




 





 





 





 





 





 



   




5881




 





 





 





 





 





 



 (TODO: alfa...and more docs needed) 




5882




 





 





 





 





 





 



   




5883




 





 





 





 





 





 



 =cut 




5884




 





 





 





 





 





 



   




5885




 





 





 





 





 





 



 our $Edcursor; 




5886




 





 





 





 





 





 



 sub ed { 




5887




18





 





 




  
18
  



  
1
  




4351



   my($s,$cs,$p,$buf)=@_; #string, commands, point (or cursor) 




5888




18




  
100
  




 





 





 





58



   return $$s=ed($$s,$cs,$p,$buf) if ref($s); 




5889




17





 





 





 





 





33



   my($sh,$cl,$m,$t,@m)=(0,0,0,undef); 




5890




17





 





 





 





 





37



   while(length($cs)){ 




5891




121





 





 





 





 





148



     my $n = 0; 




5892




121




  
 50
  




 





 





 





489



     my $c = $cs=~s,^(M\d+|M.|""|".+?"|S.+?R|\\.|.),,s ? $1 : die; 




5893




121





 




  
100
  




 





 





402



     $p = curb($p||0,0,length($s)); 




5894




121




  
100
  




 





 





 





234



     if(defined$t){$cs="".($c x $t).$cs;$t=undef;next} 




 




1





 





 





 





 





5



   




 




1





 





 





 





 





2



   




 




1





 





 





 





 





3



   




5895




120





 





 




  
81
  




 





375



     my $add=sub{substr($s,$p,0)=$_[0];$p+=length($_[0])}; 




 




81





 





 





 





 





141



   




 




81





 





 





 





 





144



   




5896




120




  
 50
  




 





 





 





821



     if   ($c =~ /^([a-z0-9 ])/){ &$add($sh^$cl?uc($1):$1); $sh=0 } 




 




65




  
100
  




 





 





 





208



   




 




65




  
100
  




 





 





 





80



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




5897




1





 





 





 





 





3



     elsif($c =~ /^"(.+)"$/)    { &$add($1) } 




5898




1





 





 





 





 





4



     elsif($c =~ /^\\(.)/)      { &$add($1) } 




5899




2




  
 50
  




 





 





 





6



     elsif($c =~ /^S(.+)R/)     { my $i=index($s,$1,$p);$p=$i+length($1) if $i>=0 } 




 




2





 





 





 





 





8



   




5900




1





 





 





 





 





3



     elsif($c =~ /^M(\d+)/)     { $t=$1; next } 




 




1





 





 





 





 





6



   




5901




2





 





 





 





 





3



     elsif($c eq 'F') { $p++ } 




5902




1





 





 





 





 





2



     elsif($c eq 'B') { $p-- } 




5903



  
0
  




 




  
  0
  




 





 





0



     elsif($c eq 'A') { $p-- while $p>0 and substr($s,$p-1,2)!~/^\n/ } 




5904




8




  
 50
  




 





 





 





39



     elsif($c eq 'E') { substr($s,$p)=~/(.*)/ and $p+=length($1) } 




5905




4





 





 





 





 





5



     elsif($c eq 'D') { substr($s,$p,1)='' } 




5906




3




  
 50
  




 





 





 





21



     elsif($c eq 'MD'){ substr($s,$p)=~s/^(\W*\w+)// and $buf=$1 } 




5907




3




  
 50
  




 





 





 





17



     elsif($c eq 'MF'){ substr($s,$p)=~/(\W*\w+)/ and $p+=length($1) } 




5908




3




  
 50
  




 





 





 





19



     elsif($c eq 'MB'){ substr($s,0,$p)=~/(\w+\W*)$/ and $p-=length($1) } 




5909



  
0
  



  
  0
  




 





 





 





0



     elsif($c eq '-') { substr($s,--$p,1)='' if $p } 




5910




5




  
 50
  




 





 





 





37



     elsif($c eq 'M-'){ substr($s,0,$p)=~s/(\w+\W*)$// and $p-=length($buf=$1)} 




5911




3




  
 50
  




 





 





 





19



     elsif($c eq 'K') { substr($s,$p)=~s/(\S.+|\s*?\n)// and $buf=$1 } 




5912




12





 





 





 





 





26



     elsif($c eq 'Y') { &$add($buf) } 




5913



  
0
  




 





 





 





 





0



     elsif($c eq 'U') { substr($s,$p)=~s/(\W*)(\w+)/$1\U$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5914



  
0
  




 





 





 





 





0



     elsif($c eq 'L') { substr($s,$p)=~s/(\W*)(\w+)/$1\L$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5915



  
0
  




 





 





 





 





0



     elsif($c eq 'C') { substr($s,$p)=~s/(\W*)(\w+)/$1\u\L$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5916



  
0
  




 





 





 





 





0



     elsif($c eq '<') { $p=0 } 




5917



  
0
  




 





 





 





 





0



     elsif($c eq '>') { $p=length($s) } 




5918



  
0
  




 





 





 





 





0



     elsif($c eq 'T') { $sh=1 } 




5919



  
0
  




 





 





 





 





0



     elsif($c eq 'C') { $cl^=1 } 




5920




1





 





 





 





 





2



     elsif($c eq '{') { $m=1; @m=() } 




 




1





 





 





 





 





2



   




5921




1





 





 





 





 





2



     elsif($c eq '}') { $m=0 } 




5922




2




  
 50
  



  
 33
  




 





 





20



     elsif($c eq '!') { $m||!@m and die"ed: no macro"; $cs=join("",@m).$cs } 




 




2





 





 





 





 





5



   




5923




2





 





 





 





 





5



     elsif($c eq '""'){ &$add('"') } 




5924



  
0
  




 





 





 





 





0



     else             { croak "ed: Unknown cmd '$c'\n" } 




5925




119




  
100
  



  
100
  




 





 





578



     push @m, $c if $m and $c ne '{'; 




5926




 





 





 





 





 





 



     #warn serialize([$c,$m,$cs],'d'); 




5927




 





 





 





 





 





 



   } 




5928




17





 





 





 





 





20



   $Edcursor=$p; 




5929




17





 





 





 





 





50



   $s; 




5930




 





 





 





 





 





 



 } 




5931




 





 





 





 





 





 



   




5932




 





 





 





 





 





 



   




5933




 





 





 





 





 





 



 #todo: sub unbless eller sub damn 




5934




 





 





 





 





 





 



 #todo: ..se også: use Data::Structure::Util qw/unbless/; 




5935




 





 





 





 





 





 



 #todo: ...og: Acme::Damn sin damn() 




5936




 





 





 





 





 





 



 #todo? sub swap($$) http://www.idg.no/computerworld/article242008.ece 




5937




 





 





 





 





 





 



 #todo? catal 




5938




 





 





 





 





 





 



 #todo?  




5939




 





 





 





 





 





 



 #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); 




5940




 





 





 





 





 





 



   




5941




 





 





 





 





 





 



   




5942




 





 





 





 





 





 



 =head1 JUST FOR FUN 




5943




 





 





 





 





 





 



   




5944




 





 





 





 





 





 



 =head2 brainfu 




5945




 





 





 





 





 





 



   




5946




 





 





 





 





 





 



 B one or two arguments 




5947




 





 





 





 





 





 



   




5948




 





 





 





 





 





 



 First argument: a string, source code of the brainfu 




5949




 





 





 





 





 





 



 language. String containing the eight charachters + - < > [ ] . , 




5950




 





 





 





 





 





 



 Every other char is ignored silently. 




5951




 





 





 





 





 





 



   




5952




 





 





 





 





 





 



 Second argument: if the source code contains commas (,) the second 




5953




 





 





 





 





 





 



 argument is the input characters in a string. 




5954




 





 





 





 





 





 



   




5955




 





 





 





 





 





 



 B The resulting output from the program. 




5956




 





 





 





 





 





 



   




5957




 





 





 





 





 





 



 Example: 




5958




 





 





 





 





 





 



   




5959




 





 





 





 





 





 



  print brainfu(<<"");  #prints "Hallo Verden!\n" 




5960




 





 





 





 





 





 



  ++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>---.+++++++++++..+++.>++.<<++++++++++++++ 




5961




 





 





 





 





 





 



  .>----------.+++++++++++++.--------------.+.+++++++++.>+.>. 




5962




 





 





 





 





 





 



   




5963




 





 





 





 





 





 



 See L 




5964




 





 





 





 





 





 



   




5965




 





 





 





 





 





 



 =head2 brainfu2perl 




5966




 





 





 





 





 





 



   




5967




 





 





 





 





 





 



 Just as L but instead it return the perl code to which the 




5968




 





 





 





 





 





 



 brainfu code is translated. Just C<< eval() >> this perl code to run. 




5969




 





 





 





 





 





 



   




5970




 





 





 





 





 





 



 Example: 




5971




 





 





 





 





 





 



   




5972




 





 





 





 





 





 



  print brainfu2perl('>++++++++[<++++++++>-]<++++++++.>++++++[<++++++>-]<---.'); 




5973




 





 





 





 





 





 



   




5974




 





 





 





 





 





 



 Prints this string: 




5975




 





 





 





 





 





 



   




5976




 





 





 





 





 





 



  my($c,$o,@b)=(0); sub out{$o.=chr($b[$c]) for 1..$_[0]||1} 




5977




 





 





 





 





 





 



  ++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5978




 





 





 





 





 





 



  while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5979




 





 





 





 





 





 



  ++$b[$c];++$c;--$b[$c];}--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5980




 





 





 





 





 





 



  ++$b[$c];++$b[$c];out;++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5981




 





 





 





 





 





 



  while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$c;--$b[$c];} 




5982




 





 





 





 





 





 



  --$c;--$b[$c];--$b[$c];--$b[$c];out;$o; 




5983




 





 





 





 





 





 



   




5984




 





 





 





 





 





 



 =head2 brainfu2perl_optimized 




5985




 





 





 





 





 





 



   




5986




 





 





 





 





 





 



 Just as L but optimizes the perl code. The same 




5987




 





 





 





 





 





 



 example as above with brainfu2perl_optimized returns this equivalent 




5988




 





 





 





 





 





 



 but shorter perl code: 




5989




 





 





 





 





 





 



   




5990




 





 





 





 





 





 



  $b[++$c]+=8;while($b[$c]){$b[--$c]+=8;--$b[++$c]}$b[--$c]+=8;out;$b[++$c]+=6; 




5991




 





 





 





 





 





 



  while($b[$c]){$b[--$c]+=6;--$b[++$c]}$b[--$c]-=3;out;$o; 




5992




 





 





 





 





 





 



   




5993




 





 





 





 





 





 



 =cut 




5994




 





 





 





 





 





 



   




5995




3





 





 




  
3
  



  
1
  




691



 sub brainfu { eval(brainfu2perl(@_)) } 




5996




 





 





 





 





 





 



   




5997




 





 





 





 





 





 



 sub brainfu2perl { 




5998




6





 





 




  
6
  



  
1
  




21



   my($bf,$inp)=@_; 




5999




17





 





 





 





 





76



   my $perl='my($c,$inp,$o,@b)=(0,\''.$inp.'\'); no warnings; sub out{$o.=chr($b[$c]) for 1..$_[0]||1}'."\n"; 




6000




3




  
100
  



  
 66
  




 





 





22



   $perl.='sub inp{$inp=~s/(.)//s and $b[$c]=ord($1)}'."\n" if $inp and $bf=~/,/; 




6001




3




  
100
  




 





 





 





918



   $perl.=join("",map/\+/?'++$b[$c];':/\-/?'--$b[$c];':/\[/?'while($b[$c]){':/\]/?'}':/>/?'++$c;':/




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




6002




3





 





 





 





 





309



   $perl; 




6003




 





 





 





 





 





 



 } 




6004




 





 





 





 





 





 



   




6005




 





 





 





 





 





 



 sub brainfu2perl_optimized { 




6006



  
0
  




 





 




  
14
  



  
1
  




0



   my $perl=brainfu2perl(@_); 




6007



  
0
  




 





 





 





 





0



   $perl=~s{(((\+|\-)\3\$b\[\$c\];){2,})}{ '$b[$c]'.$3.'='.(grep/b/,split//,$1).';' }gisex; 




 



  
0
  




 





 





 





 





0



   




6008



  
0
  




 





 





 





 





0



   1 while $perl=~s/\+\+\$c;\-\-\$c;//g + $perl=~s/\-\-\$c;\+\+\$c;//g; 




6009



  
0
  




 





 





 





 





0



   $perl=~s{((([\-\+])\3\$c;){2,})}{"\$c$3=".(grep/c/,split//,$1).';'}gisex; 




 



  
0
  




 





 





 





 





0



   




6010



  
0
  



  
  0
  




 





 





 





0



   $perl=~s{((\+\+|\-\-)\$c;([^;{}]+;))}{my($o,$s)=($2,$3);$s=~s/\$c/$o\$c/?$s:$1}ge; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6011



  
0
  




 





 





 





 





0



   $perl=~s/\$c(\-|\+)=(\d+);(\+\+|\-\-)\$b\[\$c\]/$3.'$b[$c'.$1.'='.$2.'];'/ge; 




 



  
0
  




 





 





 





 





0



   




6012



  
0
  




 





 





 





 





0



   $perl=~s{((out;){2,})}{'out('.(grep/o/,split//,$1).');'}ge; 




 



  
0
  




 





 





 





 





0



   




6013



  
0
  




 





 





 





 





0



   $perl=~s/;}/}/g;$perl=~s/;+/;/g; 




 



  
0
  




 





 





 





 





0



   




6014



  
0
  




 





 





 





 





0



   $perl; 




6015




 





 





 





 





 





 



 } 




6016




 





 





 





 





 





 



   




6017




 





 





 





 





 





 



   




6018




 





 





 





 





 





 



 =head1 BLOOM FILTER SUBROUTINES 




6019




 





 





 





 





 





 



   




6020




 





 





 





 





 





 



 Bloom filters can be used to check whether an element (a string) is a 




6021




 





 





 





 





 





 



 member of a large set using much less memory or disk space than other 




6022




 





 





 





 





 





 



 data structures. Trading speed and accuracy for memory usage. While 




6023




 





 





 





 





 





 



 risking false positives, Bloom filters have a very strong space 




6024




 





 





 





 





 





 



 advantage over other data structures for representing sets. 




6025




 





 





 





 





 





 



   




6026




 





 





 





 





 





 



 In the example below, a set of 100000 phone numbers (or any string of 




6027




 





 





 





 





 





 



 any length) can be "stored" in just 91230 bytes if you accept that you 




6028




 





 





 





 





 





 



 can only check the data structure for existence of a string and accept 




6029




 





 





 





 





 





 



 false positives with an error rate of 0.03 (that is three percent, error 




6030




 





 





 





 





 





 



 rates are given in numbers larger than 0 and smaller than 1). 




6031




 





 





 





 





 





 



   




6032




 





 





 





 





 





 



 You can not retrieve the strings in the set without using "brute 




6033




 





 





 





 





 





 



 force" methods and even then you would get slightly more strings than 




6034




 





 





 





 





 





 



 you put in because of the error rate inaccuracy. 




6035




 





 





 





 





 





 



   




6036




 





 





 





 





 





 



 Bloom Filters have many uses. 




6037




 





 





 





 





 





 



   




6038




 





 





 





 





 





 



 See also: L 




6039




 





 





 





 





 





 



   




6040




 





 





 





 





 





 



 See also: L 




6041




 





 





 





 





 





 



   




6042




 





 





 





 





 





 



 =head2 bfinit 




6043




 





 





 





 





 





 



   




6044




 





 





 





 





 





 



 Initialize a new Bloom Filter: 




6045




 





 





 





 





 





 



   




6046




 





 





 





 





 





 



   my $bf = bfinit( error_rate=>0.01, capacity=>100000 ); 




6047




 





 





 





 





 





 



   




6048




 





 





 





 





 





 



 The same: 




6049




 





 





 





 





 





 



   




6050




 





 





 





 





 





 



   my $bf = bfinit( 0.01, 100000 ); 




6051




 





 





 





 





 





 



   




6052




 





 





 





 





 





 



 since two arguments is interpreted as error_rate and capacity accordingly. 




6053




 





 





 





 





 





 



   




6054




 





 





 





 





 





 



   




6055




 





 





 





 





 





 



 =head2 bfadd 




6056




 





 





 





 





 





 



   




6057




 





 





 





 





 





 



   bfadd($bf, $_) for @phone_numbers;   # Adding strings one at a time 




6058




 





 





 





 





 





 



   




6059




 





 





 





 





 





 



   bfadd($bf, @phone_numbers);          # ...or all at once (faster) 




6060




 





 





 





 





 





 



   




6061




 





 





 





 





 





 



 Returns 1 on success. Dies (croaks) if more strings than capacity is added. 




6062




 





 





 





 





 





 



   




6063




 





 





 





 





 





 



 =head2 bfcheck 




6064




 





 





 





 





 





 



   




6065




 





 





 





 





 





 



   my $phone_number="97713246"; 




6066




 





 





 





 





 





 



   if ( bfcheck($bf, $phone_number) ) { 




6067




 





 





 





 





 





 



     print "Yes, $phone_number was PROBABLY added\n"; 




6068




 





 





 





 





 





 



   } 




6069




 





 





 





 





 





 



   else{ 




6070




 





 





 





 





 





 



     print "No, $phone_number was DEFINITELY NOT added\n"; 




6071




 





 





 





 





 





 



   } 




6072




 





 





 





 





 





 



   




6073




 





 





 





 





 





 



 Returns true if C<$phone_number> exists in C<@phone_numbers>. 




6074




 





 





 





 





 





 



   




6075




 





 





 





 





 





 



 Returns false most of the times, but sometimes true*), if C<$phone_number> doesn't exists in C<@phone_numbers>. 




6076




 





 





 





 





 





 



   




6077




 





 





 





 





 





 



 *) This is called a false positive. 




6078




 





 





 





 





 





 



   




6079




 





 





 





 





 





 



 Checking more than one key: 




6080




 





 





 





 





 





 



   




6081




 





 





 





 





 





 



  @bools = bfcheck($bf, @keys);          # or ... 




6082




 





 





 





 





 





 



  @bools = bfcheck($bf, \@keys);         # better, uses less memory if @keys is large 




6083




 





 





 





 





 





 



   




6084




 





 





 





 





 





 



 Returns an array the same size as @keys where each element is true or false accordingly. 




6085




 





 





 





 





 





 



   




6086




 





 





 





 





 





 



 =head2 bfgrep 




6087




 





 





 





 





 





 



   




6088




 





 





 





 





 





 



 Same as C except it returns the keys that exists in the bloom filter 




6089




 





 





 





 





 





 



   




6090




 





 





 





 





 





 



  @found = bfgrep($bf, @keys);           # or ... 




6091




 





 





 





 





 





 



  @found = bfgrep($bf, \@keys);          # better, uses less memory if @keys is large, or ... 




6092




 





 





 





 





 





 



  @found = grep bfcheck($bf,$_), @keys;  # same but slower 




6093




 





 





 





 





 





 



   




6094




 





 





 





 





 





 



 =head2 bfgrepnot 




6095




 





 





 





 





 





 



   




6096




 





 





 





 





 





 



 Same as C except it returns the keys that do NOT exists in the bloom filter: 




6097




 





 





 





 





 





 



   




6098




 





 





 





 





 





 



  @not_found = bfgrepnot($bf, @keys);          # or ... 




6099




 





 





 





 





 





 



  @not_found = bfgrepnot($bf, \@keys);         # better, uses less memory if @keys is large, or ... 




6100




 





 





 





 





 





 



  @not_found = grep !bfcheck($bf,$_), @keys);  # same but slower 




6101




 





 





 





 





 





 



   




6102




 





 





 





 





 





 



 =head2 bfdelete 




6103




 





 





 





 





 





 



   




6104




 





 





 





 





 





 



 Deletes from a counting bloom filter. 




6105




 





 





 





 





 





 



   




6106




 





 





 





 





 





 



 To enable deleting be sure to initialize the bloom filter with the 




6107




 





 





 





 





 





 



 numeric C argument. The number of bits could be 2 or 3*) 




6108




 





 





 





 





 





 



 for small filters with a small capacity (a small number of keys), but 




6109




 





 





 





 





 





 



 setting the number to 4 ensures that even very large filters with very 




6110




 





 





 





 





 





 



 small error rates would not overflow. 




6111




 





 





 





 





 





 



   




6112




 





 





 





 





 





 



 *) Acme::Tools do not currently support C<< counting_bits => 3 >> so 4 




6113




 





 





 





 





 





 



 and 8 are the only practical alternatives where 8 is almost always overkill. 




6114




 





 





 





 





 





 



   




6115




 





 





 





 





 





 



  my $bf=bfinit( 




6116




 





 





 





 





 





 



    error_rate    => 0.001, 




6117




 





 





 





 





 





 



    capacity      => 10000000, 




6118




 





 





 





 





 





 



    counting_bits => 4              # power of 2, that is 2, 4, 8, 16 or 32 




6119




 





 





 





 





 





 



  ); 




6120




 





 





 





 





 





 



  bfadd(   $bf, @unique_phone_numbers); 




6121




 





 





 





 





 





 



  bfdelete($bf, @unique_phone_numbers); 




6122




 





 





 





 





 





 



   




6123




 





 





 





 





 





 



 Example: examine the frequency of the counters with 4 bit counters and 4 million keys: 




6124




 





 





 





 





 





 



   




6125




 





 





 





 





 





 



  my $bf=bfinit( error_rate=>0.001, capacity=>4e6, counting_bits=>4 ); 




6126




 





 





 





 





 





 



  bfadd($bf,[1e3*$_+1 .. 1e3*($_+1)]) for 0..4000-1;  # adding 4 million keys one thousand at a time 




6127




 





 





 





 





 





 



  my %c; $c{vec($$bf{filter},$_,$$bf{counting_bits})}++ for 0..$$bf{filterlength}-1; 




6128




 





 





 





 





 





 



  printf "%8d counters = %d\n",$c{$_},$_ for sort{$a<=>$b}keys%c; 




6129




 





 





 





 





 





 



   




6130




 





 





 





 





 





 



 The output: 




6131




 





 





 





 





 





 



   




6132




 





 





 





 





 





 



  28689562 counters = 0 




6133




 





 





 





 





 





 



  19947673 counters = 1 




6134




 





 





 





 





 





 



   6941082 counters = 2 




6135




 





 





 





 





 





 



   1608250 counters = 3 




6136




 





 





 





 





 





 



    280107 counters = 4 




6137




 





 





 





 





 





 



     38859 counters = 5 




6138




 





 





 





 





 





 



      4533 counters = 6 




6139




 





 





 





 





 





 



       445 counters = 7 




6140




 





 





 





 





 





 



        46 counters = 8 




6141




 





 





 





 





 





 



         1 counters = 9 




6142




 





 





 





 





 





 



   




6143




 





 





 





 





 





 



 Even after the error_rate is changed from 0.001 to a percent of that, 0.00001, the limit of 16 (4 bits) is still far away: 




6144




 





 





 





 





 





 



   




6145




 





 





 





 





 





 



  47162242 counters = 0 




6146




 





 





 





 





 





 



  33457237 counters = 1 




6147




 





 





 





 





 





 



  11865217 counters = 2 




6148




 





 





 





 





 





 



   2804447 counters = 3 




6149




 





 





 





 





 





 



    497308 counters = 4 




6150




 





 





 





 





 





 



     70608 counters = 5 




6151




 





 





 





 





 





 



      8359 counters = 6 




6152




 





 





 





 





 





 



       858 counters = 7 




6153




 





 





 





 





 





 



        65 counters = 8 




6154




 





 





 





 





 





 



         4 counters = 9 




6155




 





 





 





 





 





 



   




6156




 





 





 





 





 





 



 In algorithmic terms the number of bits needed is C.  Thats why 4 bits (counters up 




6157




 





 





 





 





 





 



 to 15) is "always" good enough except for extremely large capasities or extremely small error rates. 




6158




 





 





 





 





 





 



 (Except when adding the same key many times, which should be avoided, and Acme::Tools::bfadd do not 




6159




 





 





 





 





 





 



 check for that, perhaps in future versions). 




6160




 





 





 





 





 





 



   




6161




 





 





 





 





 





 



 Bloom filters of the counting type are not very space efficient: The tables above shows that 84%-85% 




6162




 





 





 





 





 





 



 of the counters are 0 or 1. This means most bits are zero-bits. This doesn't have to be a problem if 




6163




 





 





 





 





 





 



 a counting bloom filter is used to be sent over slow networks because they are very compressable by 




6164




 





 





 





 





 





 



 common compression tools like I or L and such. 




6165




 





 





 





 





 





 



   




6166




 





 





 





 





 





 



 Deletion of non-existing keys makes C die (croak). 




6167




 





 





 





 





 





 



   




6168




 





 





 





 





 





 



 =head2 bfdelete 




6169




 





 





 





 





 





 



   




6170




 





 





 





 





 





 



 Deletes from a counting bloom filter: 




6171




 





 





 





 





 





 



   




6172




 





 





 





 





 





 



  bfdelete($bf, @keys); 




6173




 





 





 





 





 





 



  bfdelete($bf, \@keys); 




6174




 





 





 





 





 





 



   




6175




 





 





 





 





 





 



 Returns C<$bf> after deletion. 




6176




 





 





 





 





 





 



   




6177




 





 





 





 





 





 



 Croaks (dies) on deleting a non-existing key or deleting from an previouly overflown counter in a counting bloom filter. 




6178




 





 





 





 





 





 



   




6179




 





 





 





 





 





 



 =head2 bfaddbf 




6180




 





 





 





 





 





 



   




6181




 





 





 





 





 





 



 Adds another bloom filter to a bloom filter. 




6182




 





 





 





 





 





 



   




6183




 





 





 





 





 





 



 Bloom filters has the proberty that bit-wise I-ing the bit-filters 




6184




 





 





 





 





 





 



 of two filters with the same capacity and the same number and type of 




6185




 





 





 





 





 





 



 hash functions, adds the filters: 




6186




 





 





 





 





 





 



   




6187




 





 





 





 





 





 



   my $bf1=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[1..500]); 




6188




 





 





 





 





 





 



   my $bf2=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[501..1000]); 




6189




 





 





 





 





 





 



   




6190




 





 





 





 





 





 



   bfaddbf($bf1,$bf2); 




6191




 





 





 





 





 





 



   




6192




 





 





 





 





 





 



   print "Yes!" if bfgrep($bf1, 1..1000) == 1000; 




6193




 





 





 





 





 





 



   




6194




 





 





 





 





 





 



 Prints yes since C now returns an array of all the 1000 elements. 




6195




 





 





 





 





 





 



   




6196




 





 





 





 





 





 



 Croaks if the filters are of different dimensions. 




6197




 





 





 





 





 





 



   




6198




 





 





 





 





 





 



 Works for counting bloom filters as well (C<< counting_bits=>4 >> e.g.) 




6199




 





 





 





 





 





 



   




6200




 





 





 





 





 





 



 =head2 bfsum 




6201




 





 





 





 





 





 



   




6202




 





 





 





 





 





 



 Returns the number of 1's in the filter. 




6203




 





 





 





 





 





 



   




6204




 





 





 





 





 





 



  my $percent=100*bfsum($bf)/$$bf{filterlength}; 




6205




 





 





 





 





 





 



  printf "The filter is %.1f%% filled\n",$percent; #prints 50.0% or so if filled to capacity 




6206




 





 





 





 





 





 



   




6207




 





 





 





 





 





 



 Sums the counters for counting bloom filters (much slower than for non counting). 




6208




 





 





 





 





 





 



   




6209




 





 





 





 





 





 



 =head2 bfdimensions 




6210




 





 





 





 





 





 



   




6211




 





 





 





 





 





 



 Input, two numeric arguments: Capacity and error_rate. 




6212




 





 





 





 





 





 



   




6213




 





 





 





 





 





 



 Outputs an array of two numbers: m and k. 




6214




 





 





 





 





 





 



   




6215




 





 





 





 





 





 



   m = - n * log(p) / log(2)**2   # n = capacity, m = bits in filter (divide by 8 to get bytes) 




6216




 





 





 





 





 





 



   k = log(1/p) / log(2)          # p = error_rate, uses perls internal log() with base e (2.718) 




6217




 





 





 





 





 





 



   




6218




 





 





 





 





 





 



 ...that is: m = the best number of bits in the filter and k = the best 




6219




 





 





 





 





 





 



 number of hash functions optimized for the given capacity (n) and 




6220




 





 





 





 





 





 



 error_rate (p). Note that k is a dependent only of the error_rate.  At 




6221




 





 





 





 





 





 



 about two percent error rate the bloom filter needs just the same 




6222




 





 





 





 





 





 



 number of bytes as the number of keys. 




6223




 





 





 





 





 





 



   




6224




 





 





 





 





 





 



  Storage (bytes): 




6225




 





 





 





 





 





 



  Capacity      Error-rate  Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate 




6226




 





 





 





 





 





 



                0.000000001 0.00000001 0.0000001  0.000001   0.00001    0.0001     0.001      0.01       0.02141585 0.1        0.5        0.99 




6227




 





 





 





 





 





 



  ------------- ----------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- 




6228




 





 





 





 





 





 



             10 54.48       48.49      42.5       36.51      30.52      24.53      18.53      12.54      10.56      6.553      2.366      0.5886 




6229




 





 





 





 





 





 



            100 539.7       479.8      419.9      360        300.1      240.2      180.3      120.4      100.6      60.47      18.6       0.824 




6230




 





 





 





 





 





 



           1000 5392        4793       4194       3595       2996       2397       1798       1199       1001       599.6      180.9      3.177 




6231




 





 





 





 





 





 



          10000 5.392e+04   4.793e+04  4.194e+04  3.594e+04  2.995e+04  2.396e+04  1.797e+04  1.198e+04  1e+04      5991       1804       26.71 




6232




 





 





 





 





 





 



         100000 5.392e+05   4.793e+05  4.193e+05  3.594e+05  2.995e+05  2.396e+05  1.797e+05  1.198e+05  1e+05      5.991e+04  1.803e+04  262 




6233




 





 





 





 





 





 



        1000000 5.392e+06   4.793e+06  4.193e+06  3.594e+06  2.995e+06  2.396e+06  1.797e+06  1.198e+06  1e+06      5.991e+05  1.803e+05  2615 




6234




 





 





 





 





 





 



       10000000 5.392e+07   4.793e+07  4.193e+07  3.594e+07  2.995e+07  2.396e+07  1.797e+07  1.198e+07  1e+07      5.991e+06  1.803e+06  2.615e+04 




6235




 





 





 





 





 





 



      100000000 5.392e+08   4.793e+08  4.193e+08  3.594e+08  2.995e+08  2.396e+08  1.797e+08  1.198e+08  1e+08      5.991e+07  1.803e+07  2.615e+05 




6236




 





 





 





 





 





 



     1000000000 5.392e+09   4.793e+09  4.193e+09  3.594e+09  2.995e+09  2.396e+09  1.797e+09  1.198e+09  1e+09      5.991e+08  1.803e+08  2.615e+06 




6237




 





 





 





 





 





 



    10000000000 5.392e+10   4.793e+10  4.193e+10  3.594e+10  2.995e+10  2.396e+10  1.797e+10  1.198e+10  1e+10      5.991e+09  1.803e+09  2.615e+07 




6238




 





 





 





 





 





 



   100000000000 5.392e+11   4.793e+11  4.193e+11  3.594e+11  2.995e+11  2.396e+11  1.797e+11  1.198e+11  1e+11      5.991e+10  1.803e+10  2.615e+08 




6239




 





 





 





 





 





 



  1000000000000 5.392e+12   4.793e+12  4.193e+12  3.594e+12  2.995e+12  2.396e+12  1.797e+12  1.198e+12  1e+12      5.991e+11  1.803e+11  2.615e+09 




6240




 





 





 





 





 





 



   




6241




 





 





 





 





 





 



  Error rate:               0.99   Hash functions:  1 




6242




 





 





 





 





 





 



  Error rate:                0.5   Hash functions:  1 




6243




 





 





 





 





 





 



  Error rate:                0.1   Hash functions:  3 




6244




 





 





 





 





 





 



  Error rate: 0.0214158522653385   Hash functions:  6 




6245




 





 





 





 





 





 



  Error rate:               0.01   Hash functions:  7 




6246




 





 





 





 





 





 



  Error rate:              0.001   Hash functions: 10 




6247




 





 





 





 





 





 



  Error rate:             0.0001   Hash functions: 13 




6248




 





 





 





 





 





 



  Error rate:            0.00001   Hash functions: 17 




6249




 





 





 





 





 





 



  Error rate:           0.000001   Hash functions: 20 




6250




 





 





 





 





 





 



  Error rate:          0.0000001   Hash functions: 23 




6251




 





 





 





 





 





 



  Error rate:         0.00000001   Hash functions: 27 




6252




 





 





 





 





 





 



  Error rate:        0.000000001   Hash functions: 30 




6253




 





 





 





 





 





 



   




6254




 





 





 





 





 





 



 =head2 bfstore 




6255




 





 





 





 





 





 



   




6256




 





 





 





 





 





 



 Storing and retrieving bloom filters to and from disk uses Ls C and C. This: 




6257




 





 





 





 





 





 



   




6258




 





 





 





 





 





 



  bfstore($bf,'filename.bf'); 




6259




 





 





 





 





 





 



   




6260




 





 





 





 





 





 



 It the same as: 




6261




 





 





 





 





 





 



   




6262




 





 





 





 





 





 



  use Storable qw(store retrieve); 




6263




 





 





 





 





 





 



  ... 




6264




 





 





 





 





 





 



  store($bf,'filename.bf'); 




6265




 





 





 





 





 





 



   




6266




 





 





 





 





 





 



 =head2 bfretrieve 




6267




 





 





 





 





 





 



   




6268




 





 





 





 





 





 



 This: 




6269




 





 





 





 





 





 



   




6270




 





 





 





 





 





 



  my $bf=bfretrieve('filename.bf'); 




6271




 





 





 





 





 





 



   




6272




 





 





 





 





 





 



 Or this: 




6273




 





 





 





 





 





 



   




6274




 





 





 





 





 





 



  my $bf=bfinit('filename.bf'); 




6275




 





 





 





 





 





 



   




6276




 





 





 





 





 





 



 Is the same as: 




6277




 





 





 





 





 





 



   




6278




 





 





 





 





 





 



  use Storable qw(store retrieve); 




6279




 





 





 





 





 





 



  my $bf=retrieve('filename.bf'); 




6280




 





 





 





 





 





 



   




6281




 





 





 





 





 





 



 =head2 bfclone 




6282




 





 





 





 





 





 



   




6283




 





 





 





 





 





 



 Deep copies the bloom filter data structure. (Which btw is not very deep, two levels at most) 




6284




 





 





 





 





 





 



   




6285




 





 





 





 





 





 



 This: 




6286




 





 





 





 





 





 



   




6287




 





 





 





 





 





 



  my $bfc = bfclone($bf); 




6288




 





 





 





 





 





 



   




6289




 





 





 





 





 





 



 Works just as: 




6290




 





 





 





 





 





 



   




6291




 





 





 





 





 





 



  use Storable; 




6292




 





 





 





 





 





 



  my $bfc=Storable::dclone($bf); 




6293




 





 





 





 





 





 



   




6294




 





 





 





 





 





 



 =head2 Object oriented interface to bloom filters 




6295




 





 





 





 





 





 



   




6296




 





 





 





 





 





 



  use Acme::Tools; 




6297




 





 





 





 





 





 



  my $bf=new Acme::Tools::BloomFilter(0.1,1000); # the same as bfinit, see bfinit above 




6298




 





 





 





 





 





 



  print ref($bf),"\n";                           # prints Acme::Tools::BloomFilter 




6299




 





 





 





 





 





 



  $bf->add(@keys); 




6300




 





 





 





 





 





 



  $bf->check($keys[0]) and print "ok\n";         # prints ok 




6301




 





 





 





 





 





 



  $bf->grep(\@keys)==@keys and print "ok\n";     # prints ok 




6302




 





 





 





 





 





 



  $bf->store('filename.bf'); 




6303




 





 





 





 





 





 



  my $bf2=bfretrieve('filename.bf'); 




6304




 





 





 





 





 





 



  $bf2->check($keys[0]) and print "ok\n";        # still ok 




6305




 





 





 





 





 





 



   




6306




 





 





 





 





 





 



  $bf2=$bf->clone(); 




6307




 





 





 





 





 





 



   




6308




 





 





 





 





 





 



 To instantiate a previously stored bloom filter: 




6309




 





 





 





 





 





 



   




6310




 





 





 





 





 





 



  my $bf = Acme::Tools::BloomFilter->new( '/path/to/stored/bloomfilter.bf' ); 




6311




 





 





 





 





 





 



   




6312




 





 





 





 





 





 



 The o.o. interface has the same methods as the C-subs without the 




6313




 





 





 





 





 





 



 C-prefix in the names. The C is not available as a 




6314




 





 





 





 





 





 



 method, although C, C and 




6315




 





 





 





 





 





 



 C are synonyms. 




6316




 





 





 





 





 





 



   




6317




 





 





 





 





 





 



 =head2 Internals and speed 




6318




 





 





 





 





 





 



   




6319




 





 





 





 





 





 



 The internal hash-functions are C<< md5( "$key$salt" ) >> from L. 




6320




 





 





 





 





 





 



   




6321




 





 





 





 





 





 



 Since C returns 128 bits and most medium to large sized bloom 




6322




 





 





 





 





 





 



 filters need only a 32 bit hash function, the result from md5() are 




6323




 





 





 





 





 





 



 split (C-ed) into 4 parts 32 bits each and are treated as if 4 




6324




 





 





 





 





 





 



 hash functions was called at once (speedup). Using different salts to 




6325




 





 





 





 





 





 



 the key on each md5 results in different hash functions. 




6326




 





 





 





 





 





 



   




6327




 





 





 





 





 





 



 Digest::SHA512 would have been even better since it returns more bits, 




6328




 





 





 





 





 





 



 if it werent for the fact that it's much slower than Digest::MD5. 




6329




 





 





 





 





 





 



   




6330




 





 





 





 





 





 



 String::CRC32::crc32 is faster than Digest::MD5, but not 4 times faster: 




6331




 





 





 





 





 





 



   




6332




 





 





 





 





 





 



  time perl -e'use Digest::MD5 qw(md5);md5("asdf$_") for 1..10e6'       #5.56 sec 




6333




 





 





 





 





 





 



  time perl -e'use String::CRC32;crc32("asdf$_") for 1..10e6'           #2.79 sec, faster but not per bit 




6334




 





 





 





 





 





 



  time perl -e'use Digest::SHA qw(sha512);sha512("asdf$_") for 1..10e6' #36.10 sec, too slow (sha1, sha224, sha256 and sha384 too) 




6335




 





 





 





 





 





 



   




6336




 





 





 





 





 





 



 Md5 seems to be an ok choice both for speed and avoiding collitions due to skewed data keys. 




6337




 





 





 





 





 





 



   




6338




 





 





 





 





 





 



 =head2 Theory and math behind bloom filters 




6339




 





 





 





 





 





 



   




6340




 





 





 





 





 





 



 L 




6341




 





 





 





 





 





 



   




6342




 





 





 





 





 





 



 L 




6343




 





 





 





 





 





 



   




6344




 





 





 





 





 





 



 L 




6345




 





 





 





 





 





 



   




6346




 





 





 





 





 





 



 See also Scaleable Bloom Filters: L (not implemented in Acme::Tools) 




6347




 





 





 





 





 





 



   




6348




 





 





 





 





 





 



 ...and perhaps L 




6349




 





 





 





 





 





 



   




6350




 





 





 





 





 





 



 =cut 




6351




 





 





 





 





 





 



   




6352




 





 





 





 





 





 



 sub bfinit { 




6353




24




  
100
  




 




  
24
  



  
1
  




15650



   return bfretrieve(@_)                             if @_==1; 




6354




23




  
 50
  



  
 66
  




 





 





118



   return bfinit(error_rate=>$_[0], capacity=>$_[1]) if @_==2 and 0<$_[0] and $_[0]<1 and $_[1]>1; 




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 33
  




 





 





 



   




6355




21




  
  0
  



  
 33
  




 





 





61



   return bfinit(error_rate=>$_[1], capacity=>$_[0]) if @_==2 and 0<$_[1] and $_[1]<1 and $_[0]>1; 




 




 





 




  
 33
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




6356




21





 





 





 





 





129



   require Digest::MD5; 




6357




21




  
 50
  




 





 





 





54



   @_%2&&croak "Arguments should be a hash of equal number of keys and values"; 




6358




21





 





 





 





 





85



   my %arg=@_; 




6359




21





 





 





 





 





69



   my @ok_param=qw/error_rate capacity min_hashfuncs max_hashfuncs hashfuncs counting_bits adaptive keys/; 




6360




21





 





 





 





 





84



   my @not_ok=sort(grep!in($_,@ok_param),keys%arg); 




6361




21




  
100
  




 





 





 





271



   croak "Not ok param to bfinit: ".join(", ",@not_ok) if @not_ok; 




6362




20




  
 50
  



  
 66
  




 





 





98



   croak "Not an arrayref in keys-param" if exists $arg{keys} and ref($arg{keys}) ne 'ARRAY'; 




6363




20




  
 50
  




 





 





 





77



   croak "Not implemented counting_bits=$arg{counting_bits}, should be 2, 4, 8, 16 or 32" if !in(nvl($arg{counting_bits},1),1,2,4,8,16,32); 




6364




20




  
 50
  



  
 33
  




 





 





73



   croak "An bloom filters here can not be in both adaptive and counting_bits modes" if $arg{adaptive} and $arg{counting_bits}>1; 




6365




20





 





 





 





 





176



   my $bf={error_rate    => 0.001,  #default p 




6366




 





 





 





 





 





 



 	  capacity      => 100000, #default n 




6367




 





 





 





 





 





 



           min_hashfuncs => 1, 




6368




 





 





 





 





 





 



           max_hashfuncs => 100, 




6369




 





 





 





 





 





 



 	  counting_bits => 1,      #default: not counting filter 




6370




 





 





 





 





 





 



 	  adaptive      => 0, 




6371




 





 





 





 





 





 



 	  %arg,                    #arguments 




6372




 





 





 





 





 





 



 	  key_count     => 0, 




6373




 





 





 





 





 





 



 	  overflow      => {}, 




6374




 





 





 





 





 





 



 	  version       => $Acme::Tools::VERSION, 




6375




 





 





 





 





 





 



 	 }; 




6376




20




  
100
  



  
100
  




 





 





384



   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; 




6377




18




  
 50
  




 





 





 





46



   @$bf{'min_hashfuncs','max_hashfuncs'}=(map$arg{hashfuncs},1..2) if $arg{hashfuncs}; 




6378




18





 





 





 





 





53



   @$bf{'filterlength','hashfuncs'}=bfdimensions($bf); #m and k 




6379




18





 





 





 





 





776



   $$bf{filter}=pack("b*", '0' x ($$bf{filterlength}*$$bf{counting_bits}) ); #hm x   new empty filter 




6380




 





 





 





 





 





 



   $$bf{unpack}= $$bf{filterlength}<=2**16/4 ? "n*" # /4 alleviates skewing if m just slightly < 2**x 




6381




18




  
 50
  




 





 





 





57



                :$$bf{filterlength}<=2**32/4 ? "N*" 




 




 




  
100
  




 





 





 





 



   




6382




 





 





 





 





 





 



                :                              "Q*"; 




6383




18




  
100
  




 





 





 





48



   bfadd($bf,@{$arg{keys}}) if $arg{keys}; 




 




8





 





 





 





 





78



   




6384




16





 





 





 





 





95



   return $bf; 




6385




 





 





 





 





 





 



 } 




6386




 





 





 





 





 





 



 sub bfaddbf { 




6387




2





 





 




  
2
  



  
1
  




5



   my($bf,$bf2)=@_; 




6388




 





 





 





 





 





 



   my $differror=join"\n", 




6389




 





 





 





 





 





 



     map "Property $_ differs ($$bf{$_} vs $$bf2{$_})", 




6390




2





 





 





 





 





42



     grep $$bf{$_} ne $$bf2{$_}, 




6391




 





 





 





 





 





 



     qw/capacity counting_bits adaptive hashfuncs filterlength/; #not error_rate 




6392




2




  
 50
  




 





 





 





8



   croak $differror if $differror; 




6393




2




  
 50
  




 





 





 





9



   croak "Can not add adaptive bloom filters" if $$bf{adaptive}; 




6394




2





 





 





 





 





5



   my $count=$$bf{key_count}+$$bf2{key_count}; 




6395




 





 





 





 





 





 



   croak "Exceeded filter capacity $$bf{key_count} + $$bf2{key_count} = $count > $$bf{capacity}" 




6396




2




  
 50
  




 





 





 





10



     if $count > $$bf{capacity}; 




6397




2





 





 





 





 





7



   $$bf{key_count}+=$$bf2{key_count}; 




6398




2




  
100
  




 





 





 





8



   if($$bf{counting_bits}==1){ 




6399




1





 





 





 





 





5



     $$bf{filter} |= $$bf2{filter}; 




6400




 





 





 





 





 





 



     #$$bf{filter} = $$bf{filter} | $$bf2{filter}; #or-ing 




6401




 





 





 





 





 





 



   } 




6402




 





 





 





 





 





 



   else { 




6403




1





 





 





 





 





4



     my $cb=$$bf{counting_bits}; 




6404




1





 





 





 





 





6



     for(0..$$bf{filterlength}-1){ 




6405




 





 





 





 





 





 



       my $sum= 




6406




 





 





 





 





 





 



       vec($$bf{filter}, $_,$cb)+ 




6407




4793





 





 





 





 





8390



       vec($$bf2{filter},$_,$cb); 




6408




4793




  
 50
  




 





 





 





9761



       if( $sum>2**$cb-1 ){ 




6409



  
0
  




 





 





 





 





0



 	$sum=2**$cb-1; 




6410



  
0
  




 





 





 





 





0



 	$$bf{overflow}{$_}++; 




6411




 





 





 





 





 





 



       } 




6412




4793





 





 





 





 





9283



       vec($$bf{filter}, $_,$cb)=$sum; 




6413




28





 





 




  
28
  




 





187



       no warnings; 




 




28





 





 





 





 





49



   




 




28





 





 





 





 





91601



   




6414




 





 





 





 





 





 



       $$bf{overflow}{$_}+=$$bf2{overflow}{$_} 




6415



  
0
  




 





 





 





 





0



 	and keys(%{$$bf{overflow}})>10 #hmm, arbitrary limit 




6416




 





 





 





 





 





 



 	and croak "Too many overflows, concider doubling counting_bits from $cb to ".(2*$cb) 




6417




4793




  
 50
  



  
  0
  




 





 





13225



 	if exists $$bf2{overflow}{$_}; 




 




 





 




  
  0
  




 





 





 



   




6418




 





 





 





 





 





 



     } 




6419




 





 





 





 





 





 



   } 




6420




2





 





 





 





 





7



   return $bf; #for convenience 




6421




 





 





 





 





 





 



 } 




6422




 





 





 





 





 





 



 sub bfsum { 




6423




8





 





 




  
8
  



  
1
  




40



   my($bf)=@_; 




6424




8




  
100
  




 





 





 





89



   return unpack( "%32b*", $$bf{filter}) if $$bf{counting_bits}==1; 




6425




3





 





 





 





 





8



   my($sum,$cb)=(0,$$bf{counting_bits}); 




6426




3





 





 





 





 





5708



   $sum+=vec($$bf{filter},$_,$cb) for 0..$$bf{filterlength}-1; 




6427




3





 





 





 





 





23



   return $sum; 




6428




 





 





 





 





 





 



 } 




6429




 





 





 





 





 





 



 sub bfadd { 




6430




11





 





 




  
11
  



  
1
  




2573



   require Digest::MD5; 




6431




11





 





 





 





 





876



   my($bf,@keys)=@_; 




6432




11




  
 50
  




 





 





 





34



   return if !@keys; 




6433




11




  
100
  



  
 66
  




 





 





45



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6434




11





 





 





 





 





51



   my($m,$k,$up,$n,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','capacity','counting_bits','adaptive'}; 




6435




11





 





 





 





 





37



   for(@$keysref){ 




6436




 





 





 





 





 





 



     #croak "Key should be scalar" if ref($_); 




6437




15084




  
 50
  



  
 66
  




 





 





40952



     $$bf{key_count} >= $n and croak "Exceeded filter capacity $n"  or  $$bf{key_count}++; 




6438




15083





 





 





 





 





18626



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




15083





 





 





 





 





132284



   




6439




15083




  
100
  



  
 66
  




 





 





51645



     if ($cb==1 and !$adaptive) { # normal bloom filter 




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6440




11110





 





 





 





 





102943



       vec($$bf{filter}, $h[$_] % $m, 1) = 1 for 0..$k-1; 




6441




 





 





 





 





 





 



     } 




6442




 





 





 





 





 





 



     elsif ($cb>1) {                 # counting bloom filter 




6443




3973





 





 





 





 





7256



       for(0..$k-1){ 




6444




11919





 





 





 





 





17176



 	my $pos=$h[$_] % $m; 




6445




 





 





 





 





 





 



 	my $c= 




6446




 





 





 





 





 





 



   	vec($$bf{filter}, $pos, $cb) = 




6447




11919





 





 





 





 





29225



 	vec($$bf{filter}, $pos, $cb) + 1; 




6448




11919




  
100
  




 





 





 





35642



 	if($c==0){ 




6449




26





 





 





 





 





51



 	  vec($$bf{filter}, $pos, $cb) = -1; 




6450




 





 





 





 





 





 



 	  $$bf{overflow}{$pos}++ 




6451




26




  
100
  



  
100
  




 





 





134



 	    and keys(%{$$bf{overflow}})>10 #hmm, arbitrary limit 




 




2





 





 





 





 





244



   




6452




 





 





 





 





 





 



 	    and croak "Too many overflows, concider doubling counting_bits from $cb to ".(2*$cb); 




6453




 





 





 





 





 





 



 	} 




6454




 





 





 





 





 





 



       } 




6455




 





 





 





 





 





 



     } 




6456




 





 





 





 





 





 



     elsif ($adaptive) {             # adaptive bloom filter 




6457



  
0
  




 





 





 





 





0



       my($i,$key,$bit)=(0+@h,$_); 




6458



  
0
  




 





 





 





 





0



       for(0..$$bf{filterlength}-1){ 




6459



  
0
  



  
  0
  




 





 





 





0



 	$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h; 




6460



  
0
  




 





 





 





 





0



 	my $pos=shift(@h) % $m; 




6461



  
0
  




 





 





 





 





0



 	$bit=vec($$bf{filter}, $pos, 1); 




6462



  
0
  




 





 





 





 





0



 	vec($$bf{filter}, $pos, 1)=1; 




6463



  
0
  



  
  0
  



  
  0
  




 





 





0



 	last if $_>=$k-1 and $bit==0; 




6464




 





 





 





 





 





 



       } 




6465




 





 





 





 





 





 



     } 




6466



  
0
  




 





 





 





 





0



     else {croak} 




6467




 





 





 





 





 





 



   } 




6468




9





 





 





 





 





733



   return 1; 




6469




 





 





 





 





 





 



 } 




6470




 





 





 





 





 





 



 sub bfcheck { 




6471




5





 





 




  
5
  



  
1
  




83



   require Digest::MD5; 




6472




5





 





 





 





 





1178



   my($bf,@keys)=@_; 




6473




5




  
 50
  




 





 





 





18



   return if !@keys; 




6474




5




  
 50
  



  
 33
  




 





 





26



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6475




5





 





 





 





 





24



   my($m,$k,$up,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','counting_bits','adaptive'}; 




6476




5





 





 





 





 





12



   my $wa=wantarray(); 




6477




5




  
 50
  




 





 





 





15



   if(!$adaptive){    # normal bloom filter  or  counting bloom filter 




6478




 





 





 





 





 





 



     return map { 




6479




5





 





 





 





 





65



       my $match = 1; # match if every bit is on 




 




24001





 





 





 





 





28811



   




6480




24001





 





 





 





 





28750



       my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




24001





 





 





 





 





222331



   




6481




24001





 




  
100
  




 





 





209677



       vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
100
  




 





 





 



   




6482




24001




  
 50
  




 





 





 





44673



       return $match if !$wa; 




6483




24001





 





 





 





 





51962



       $match; 




6484




 





 





 





 





 





 



     } @$keysref; 




6485




 





 





 





 





 





 



   } 




6486




 





 





 





 





 





 



   else {             # adaptive bloom filter 




6487




 





 





 





 





 





 



     return map { 




6488



  
0
  




 





 





 





 





0



       my($match,$i,$key,$bit,@h)=(1,0,$_); 




 



  
0
  




 





 





 





 





0



   




6489



  
0
  




 





 





 





 





0



       for(0..$$bf{filterlength}-1){ 




6490



  
0
  



  
  0
  




 





 





 





0



 	$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h; 




6491



  
0
  




 





 





 





 





0



 	my $pos=shift(@h) % $m; 




6492



  
0
  




 





 





 





 





0



 	$bit=vec($$bf{filter}, $pos, 1); 




6493



  
0
  



  
  0
  



  
  0
  




 





 





0



 	$match++ if $_ >  $k-1 and $bit==1; 




6494



  
0
  



  
  0
  



  
  0
  




 





 





0



 	$match=0 if $_ <= $k-1 and $bit==0; 




6495



  
0
  



  
  0
  




 





 





 





0



 	last     if $bit==0; 




6496




 





 





 





 





 





 



       } 




6497



  
0
  



  
  0
  




 





 





 





0



       return $match if !$wa; 




6498



  
0
  




 





 





 





 





0



       $match; 




6499




 





 





 





 





 





 



     } @$keysref; 




6500




 





 





 





 





 





 



   } 




6501




 





 





 





 





 





 



 } 




6502




 





 





 





 





 





 



 sub bfgrep { # just a copy of bfcheck with map replaced by grep 




6503




8





 





 




  
8
  



  
1
  




870



   require Digest::MD5; 




6504




8





 





 





 





 





24



   my($bf,@keys)=@_; 




6505




8




  
 50
  




 





 





 





27



   return if !@keys; 




6506




8




  
 50
  



  
 33
  




 





 





65



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6507




8





 





 





 





 





34



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6508




 





 





 





 





 





 



   return grep { 




6509




8





 





 





 





 





29



     my $match = 1; # match if every bit is on 




 




6100





 





 





 





 





7316



   




6510




6100





 





 





 





 





6722



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




6100





 





 





 





 





40807



   




6511




6100





 




  
100
  




 





 





42786



     vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
100
  




 





 





 



   




6512




6100





 





 





 





 





11486



     $match; 




6513




 





 





 





 





 





 



   } @$keysref; 




6514




 





 





 





 





 





 



 } 




6515




 





 





 





 





 





 



 sub bfgrepnot { # just a copy of bfgrep with $match replaced by not $match 




6516




1





 





 




  
1
  



  
1
  




9



   require Digest::MD5; 




6517




1





 





 





 





 





3



   my($bf,@keys)=@_; 




6518




1




  
 50
  




 





 





 





5



   return if !@keys; 




6519




1




  
 50
  



  
 33
  




 





 





16



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6520




1





 





 





 





 





5



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6521




 





 





 





 





 





 



   return grep { 




6522




1





 





 





 





 





5



     my $match = 1; # match if every bit is on 




 




1000





 





 





 





 





1246



   




6523




1000





 





 





 





 





1149



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




1000





 





 





 





 





6814



   




6524




1000





 




  
 50
  




 





 





7027



     vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
 50
  




 





 





 



   




6525




1000





 





 





 





 





2346



     !$match; 




6526




 





 





 





 





 





 



   } @$keysref; 




6527




 





 





 





 





 





 



 } 




6528




 





 





 





 





 





 



 sub bfdelete { 




6529




3





 





 




  
3
  



  
1
  




91



   require Digest::MD5; 




6530




3





 





 





 





 





17



   my($bf,@keys)=@_; 




6531




3




  
 50
  




 





 





 





12



   return if !@keys; 




6532




3




  
100
  



  
100
  




 





 





20



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6533




3





 





 





 





 





11



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6534




3




  
 50
  




 





 





 





8



   croak "Cannot delete from non-counting bloom filter (use counting_bits 4 e.g.)" if $cb==1; 




6535




3





 





 





 





 





7



   for my $key (@$keysref){ 




6536




501





 





 





 





 





537



     my @h; push @h, unpack $up, Digest::MD5::md5($key,0+@h) while @h<$k; 




 




501





 





 





 





 





3437



   




6537




501




  
 50
  



  
 33
  




 





 





1432



     $$bf{key_count}==0 and croak "Deleted all and then some"  or  $$bf{key_count}--; 




6538




501





 





 





 





 





782



     my($ones,$croak,@pos)=(0); 




6539




501





 





 





 





 





925



     for(0..$k-1){ 




6540




1503





 





 





 





 





2149



       my $pos=$h[$_] % $m; 




6541




 





 





 





 





 





 



       my $c= 




6542




1503





 





 





 





 





2267



       vec($$bf{filter}, $pos, $cb); 




6543




1503





 





 





 





 





3127



       vec($$bf{filter}, $pos, $cb)=$c-1; 




6544




1503




  
100
  




 





 





 





3244



       $croak="Cannot delete a non-existing key $key" if $c==0; 




6545




 





 





 





 





 





 



       $croak="Cannot delete with previously overflown position. Try doubleing counting_bits" 




6546




1503




  
 50
  



  
 66
  




 





 





6247



 	if $c==1 and ++$ones and $$bf{overflow}{$pos}; 




 




 





 




  
 66
  




 





 





 



   




6547




 





 





 





 





 





 



     } 




6548




501




  
100
  




 





 





 





1241



     if($croak){ #rollback 




6549




 





 





 





 





 





 



       vec($$bf{filter}, $h[$_] % $m, $cb)= 




6550




1





 





 





 





 





11



       vec($$bf{filter}, $h[$_] % $m, $cb)+1 for 0..$k-1; 




6551




1





 





 





 





 





200



       croak $croak; 




6552




 





 





 





 





 





 



     } 




6553




 





 





 





 





 





 



   } 




6554




2





 





 





 





 





20



   return $bf; 




6555




 





 





 





 





 





 



 } 




6556




 





 





 





 





 





 



 sub bfstore { 




6557




1





 





 




  
1
  



  
1
  




22727



   require Storable; 




6558




1





 





 





 





 





8



   Storable::store(@_); 




6559




 





 





 





 





 





 



 } 




6560




 





 





 





 





 





 



 sub bfretrieve { 




6561




2





 





 




  
2
  



  
1
  




527



   require Storable; 




6562




2





 





 





 





 





11



   my $bf=Storable::retrieve(@_); 




6563




2




  
 50
  




 





 





 





545



   carp  "Retrieved bloom filter was stored in version $$bf{version}, this is version $VERSION" if $$bf{version}>$VERSION; 




6564




2





 





 





 





 





7



   return $bf; 




6565




 





 





 





 





 





 



 } 




6566




 





 





 





 





 





 



 sub bfclone { 




6567




1





 





 




  
1
  



  
1
  




30668



   require Storable; 




6568




1





 





 





 





 





8452



   return Storable::dclone(@_); #could be faster 




6569




 





 





 





 





 





 



 } 




6570




 





 





 





 





 





 



 sub bfdimensions_old { 




6571




 





 





 





 





 





 



   my($n,$p,$mink,$maxk, $k,$flen,$m)= 




6572



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



     @_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'},1) 




 



  
0
  



  
  0
  




 





 





 





0



   




6573




 





 





 





 





 





 



    :@_==2 ? (@_,1,100,1) 




6574




 





 





 





 





 





 



           : croak "Wrong number of arguments (".@_."), should be 2"; 




6575



  
0
  



  
  0
  



  
  0
  




 





 





0



   croak "p ($p) should be > 0 and < 1" if not ( 0<$p && $p<1 ); 




6576



  
0
  




 




  
  0
  




 





 





0



   $m=-1*$_*$n/log(1-$p**(1/$_)) and (!defined $flen or $m<$flen) and ($flen,$k)=($m,$_) for $mink..$maxk; 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




6577



  
0
  




 





 





 





 





0



   $flen = int(1+$flen); 




6578



  
0
  




 





 





 





 





0



   return ($flen,$k); 




6579




 





 





 





 





 





 



 } 




6580




 





 





 





 





 





 



 sub bfdimensions { 




6581




 





 





 





 





 





 



   my($n,$p,$mink,$maxk)= 




6582




18




  
  0
  




 




  
18
  



  
1
  




48



     @_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'}) 




 




18




  
 50
  




 





 





 





52



   




6583




 





 





 





 





 





 



    :@_==2 ? (@_,1,100) 




6584




 





 





 





 





 





 



           : croak "Wrong number of arguments (".@_."), should be 2"; 




6585




18





 





 





 





 





66



   my $k=log(1/$p)/log(2);           # k hash funcs 




6586




18





 





 





 





 





47



   my $m=-$n*log($p)/log(2)**2;      # m bits in filter 




6587




18





 





 





 





 





65



   return ($m+0.5,min($maxk,max($mink,int($k+0.5)))); 




6588




 





 





 





 





 





 



 } 




6589




 





 





 





 





 





 



   




6590




 





 





 





 





 





 



 #crontab -e 




6591




 





 





 





 





 





 



 #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 




6592




 





 





 





 





 





 



   




6593




 





 





 





 





 





 



 sub _update_currency_file { #call from cron 




6594



  
0
  




 




  
  0
  



  
0
  




 





0



   my $fn=shift()||'/var/www/html/currency-rates'; 




6595



  
0
  




 




  
  0
  




 





 





0



   my %exe=map+($_=>"/usr/bin/$_"),qw/curl ci/;-x$_ or die for values %exe; 




 



  
0
  




 





 





 





 





0



   




6596



  
0
  



  
  0
  




 





 





 





0



   open my $F, '>', $fn or die"ERROR: Could not write file $fn ($!)\n"; 




6597



  
0
  




 





 





 





 





0



   print $F "#-- Currency rates ".localtime()." (".time().")\n"; 




6598



  
0
  




 





 





 





 





0



   print $F "#   File generated by Acme::Tools version $VERSION\n"; 




6599



  
0
  




 





 





 





 





0



   print $F "#   Updated every 6th hour on http://calthis.com/currency-rates\n"; 




6600



  
0
  




 





 





 





 





0



   print $F "NOK 1.000000000\n"; 




6601



  
0
  




 





 





 





 





0



   my $amount=1000; 




6602



  
0
  




 





 





 





 





0



   my $data=qx($exe{curl} -s "http://www.x-rates.com/table/?from=NOK&amount=$amount"); 




6603



  
0
  




 





 





 





 





0



   $data=~s,to=([A-Z]{3})(.)>,$2>$1,g; 




6604



  
0
  




 





 





 





 





0



   my @data=ht2t($data,"Alphabetical order"); shift @data; 




 



  
0
  




 





 





 





 





0



   




6605



  
0
  



  
  0
  




 





 





 





0



   @data=map "$$_[1] ".($$_[4]>1e-2?$$_[4]:$$_[2]?sprintf("%.8f",$amount/$$_[2]):0)."\n",@data; 




 




 




  
  0
  




 





 





 





 



   




6606



  
0
  




 





 





 





 





0



   my %data=map split,@data; 




6607



  
0
  




 





 





 





 





0



   my@tc=qx($exe{curl} -s https://btc-e.com/api/3/ticker/btc_usd-ltc_usd)=~/avg.?:(\d+\.?\d*)/g; 




6608



  
0
  




 





 





 





 





0



   push @data,"BTC ".($tc[0]*$data{USD})."\n"; 




6609



  
0
  




 





 





 





 





0



   push @data,"LTC ".($tc[1]*$data{USD})."\n"; 




6610



  
0
  




 





 





 





 





0



   print $F sort(@data); 




6611



  
0
  




 





 





 





 





0



   close($F); 




6612



  
0
  



  
  0
  




 





 





 





0



   qx($exe{ci} -l -m. -d $fn) if -w"$fn,v"; 




6613




 





 





 





 





 





 



 } 




6614




 





 





 





 





 





 



   




6615




 





 





 





 





 





 



 sub ftype { 




6616



  
0
  




 





 




  
0
  



  
0
  




0



   my $f=shift; 




6617



  
0
  



  
  0
  



  
  0
  




 





 





0



   -e $f and 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6618




 





 





 





 





 





 



       -f$f ? 'file'         # -f  File is a plain file. 




6619




 





 





 





 





 





 



      :-d$f ? 'dir'          # -d  File is a directory. 




6620




 





 





 





 





 





 



      :-l$f ? 'symlink'      # -l  File is a symbolic link. 




6621




 





 





 





 





 





 



      :-p$f ? 'pipe'         # -p  File is a named pipe (FIFO), or Filehandle is a pipe. 




6622




 





 





 





 





 





 



      :-S$f ? 'socket'       # -S  File is a socket. 




6623




 





 





 





 





 





 



      :-b$f ? 'blockfile'    # -b  File is a block special file. 




6624




 





 





 





 





 





 



      :-c$f ? 'charfile'     # -c  File is a character special file. 




6625




 





 





 





 





 





 



      :-t$f ? 'ttyfile'      # -t  Filehandle is opened to a tty. 




6626




 





 





 





 





 





 



      :       '' 




6627




 





 





 





 





 





 



   or undef; 




6628




 





 





 





 





 





 



 } 




6629




 





 





 





 





 





 



   




6630




 





 





 





 





 





 



 =head1 COMMANDS 




6631




 





 





 





 





 





 



   




6632




 





 





 





 





 





 



 =head2 install_acme_command_tools 




6633




 





 





 





 





 





 



   




6634




 





 





 





 





 





 



  sudo perl -MAcme::Tools -e install_acme_command_tools 




6635




 





 





 





 





 





 



  Wrote executable /usr/local/bin/conv 




6636




 





 





 





 





 





 



  Wrote executable /usr/local/bin/due 




6637




 





 





 





 





 





 



  Wrote executable /usr/local/bin/xcat 




6638




 





 





 





 





 





 



  Wrote executable /usr/local/bin/freq 




6639




 





 





 





 





 





 



  Wrote executable /usr/local/bin/deldup 




6640




 





 





 





 





 





 



  Wrote executable /usr/local/bin/wipe 




6641




 





 





 





 





 





 



   




6642




 





 





 





 





 





 



 Examples of commands then made available: 




6643




 





 





 





 





 





 



   




6644




 





 





 





 





 





 



  conv 1 USD EUR                #might show 0.88029 if thats the current currency rate. Uses conv() 




6645




 





 





 





 





 





 



  conv .5 in cm                 #reveals that 1/2 inch is 1.27 cm, see doc on conv() for all supported units 




6646




 





 





 





 





 





 



  due [-h] /path/1/ /path/2/    #like du, but show statistics on file extentions instead of subdirs 




6647




 





 





 





 





 





 



  xcat file                     #like cat, zcat, bzcat or xzcat in one. Uses file extention to decide. Uses openstr() 




6648




 





 





 





 





 





 



  freq file                     #reads file(s) or stdin and view counts of each byte 0-255 




6649




 





 





 





 





 





 



  deldup [-d] path1/ path2/     #reports (and optionally deletes) duplicate files NOT IMPLEMENTED YET! 




6650




 





 





 





 





 





 



  ccmd grep string /huge/file   #caches stdout+stderr for 15 minutes (default) for much faster results later 




6651




 





 





 





 





 





 



  ccmd "sleep 2;echo hello"     #slow first time. Note the quotes! 




6652




 





 





 





 





 





 



  ccmd "du -s ~/*|sort -n|tail" #ccmd store stdout+stderr in /tmp files (default) 




6653




 





 





 





 





 





 



   




6654




 





 





 





 





 





 



 =head3 due 




6655




 





 





 





 





 





 



   




6656




 





 





 





 





 





 



 Like C command but views space used by file extentions instead of dirs. Options: 




6657




 





 





 





 





 





 



   




6658




 





 





 





 





 





 



  due [-options] [dirs] [files] 




6659




 





 





 





 





 





 



  due -h          View bytes "human readable", i.e. C<8.72 MB> instead of C<9145662 b> (bytes) 




6660




 





 





 





 





 





 



  due -k | -m     View bytes in kilobytes | megabytes (1024 | 1048576) 




6661




 





 





 





 





 





 



  due -K          Like -k but uses 1000 instead of 1024 




6662




 





 





 





 





 





 



  due -z          View two extentions if .z .Z .gz .bz2 .rz or .xz (.tar.gz, not just .gz) 




6663




 





 





 





 





 





 



  due -M          Also show min, medium and max date (mtime) of files, give an idea of their age 




6664




 





 





 





 





 





 



  due -P          Also show 10, 50 (medium) and 90 percentile of file date 




6665




 





 





 





 





 





 



  due -MP         Both -M and -P, shows min, 10p, 50p, 90p and max 




6666




 





 





 





 





 





 



  due -a          Sort output alphabetically by extention (default order is by size) 




6667




 





 





 





 





 





 



  due -c          Sort output by number of files 




6668




 





 





 





 





 





 



  due -i          Ignore case, .GZ and .gz is the same, output in lower case 




6669




 





 





 





 





 





 



  due -t          Adds time of day to -M and -P output 




6670




 





 





 





 





 





 



  due -e 'regex'  Exclude files (full path) matching regex. Ex: due -e '\.git' 




6671




 





 





 





 





 





 



   




6672




 





 





 





 





 





 



 =cut 




6673




 





 





 





 





 





 



   




6674




 





 





 





 





 





 



 sub install_acme_command_tools { 




6675



  
0
  




 





 




  
0
  



  
1
  




0



   my $dir=(grep -d$_, @_, '/usr/local/bin', '/usr/bin')[0]; 




6676



  
0
  




 





 





 





 





0



   for(qw( conv due xcat freq deldup ccmd )){ 




6677



  
0
  




 





 





 





 





0



     unlink("$dir/$_"); 




6678



  
0
  




 





 





 





 





0



     writefile("$dir/$_", "#!$^X\nuse Acme::Tools;\nAcme::Tools::cmd_$_(\@ARGV);\n"); 




6679



  
0
  




 





 





 





 





0



     sys("/bin/chmod +x $dir/$_"); 




6680



  
0
  




 





 





 





 





0



     print "Wrote executable $dir/$_\n"; 




6681




 





 





 





 





 





 



   } 




6682




 





 





 





 





 





 



 } 




6683



  
0
  




 





 




  
0
  



  
0
  




0



 sub cmd_conv { print conv(@ARGV)."\n"  } 




6684




28





 





 




  
28
  




 





51697



   use Data::Dumper; 




 




28





 





 





 





 





294442



   




 




28





 





 





 





 





3305



   




6685




 





 





 





 





 





 



 sub cmd_due { #TODO: output from tar tvf and ls and find -ls 




6686



  
0
  




 





 




  
0
  



  
0
  




0



   require Getopt::Std; my %o; Getopt::Std::getopts("zkKmhciMPate:" => \%o); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6687



  
0
  




 





 





 





 





0



   require File::Find; 




6688




28





 





 




  
28
  




 





189



   no warnings 'uninitialized'; 




 




28





 





 





 





 





55



   




 




28





 





 





 





 





86776



   




6689



  
0
  



  
  0
  




 





 





 





0



   die"$0: -h, -k or -m can not be used together\n" if $o{h}+$o{k}+$o{m}>1; 




6690



  
0
  



  
  0
  




 





 





 





0



   die"$0: -c and -a can not be used together\n"    if $o{a}+$o{c}>1; 




6691



  
0
  



  
  0
  




 





 





 





0



   die"$0: -k and -m can not be used together\n"    if $o{k}+$o{m}>1; 




6692



  
0
  



  
  0
  




 





 





 





0



   my @q=@ARGV; @q=('.') if !@q; 




 



  
0
  




 





 





 





 





0



   




6693



  
0
  




 





 





 





 





0



   my(%c,%b,$cnt,$bts,%mtime); 




6694



  
0
  



  
  0
  




 





 





 





0



   my $r=$o{z} ? qr/(\.[^\.\/]{1,10}(\.(z|Z|gz|bz2|rz|xz))?)$/ 




6695




 





 





 





 





 





 



               : qr/(\.[^\.\/]{1,10})$/; 




6696



  
0
  



  
  0
  




 





 





 





0



   my $rexcl=exists$o{e}?qr/$o{e}/:0; 




6697




 





 





 





 





 





 



   File::Find::find({wanted => 




6698




 





 





 





 





 





 



     sub { 




6699



  
0
  



  
  0
  




 




  
0
  




 





0



       return if !-f$_; 




6700



  
0
  



  
  0
  



  
  0
  




 





 





0



       return if $rexcl and $File::Find::name=~$rexcl; 




6701



  
0
  




 





 





 





 





0



       my($sz,$mtime)=(stat($_))[7,9]; 




6702



  
0
  



  
  0
  




 





 





 





0



       my $ext=m/$r/?$1:""; 




6703



  
0
  



  
  0
  




 





 





 





0



       $ext=lc($ext) if $o{i}; 




6704



  
0
  




 





 





 





 





0



       $cnt++;    $c{$ext}++; 




 



  
0
  




 





 





 





 





0



   




6705



  
0
  




 





 





 





 





0



       $bts+=$sz; $b{$ext}+=$sz; 




 



  
0
  




 





 





 





 





0



   




6706



  
0
  



  
  0
  



  
  0
  




 





 





0



       $mtime{$ext}.=",$mtime" if $o{M} or $o{P}; 




6707



  
0
  




 





 





 





 





0



       1; 




6708



  
0
  




 





 





 





 





0



     } },@q); 




6709



  
0
  




 





 




  
0
  




 





0



   my($f,$s)=$o{k}?("%14.2f kb",sub{$_[0]/1024}) 




6710



  
0
  




 





 




  
0
  




 





0



            :$o{K}?("%14.2f Kb",sub{$_[0]/1000}) 




6711



  
0
  




 





 




  
0
  




 





0



            :$o{m}?("%14.2f mb",sub{$_[0]/1024**2}) 




6712



  
0
  




 





 




  
0
  




 





0



            :$o{h}?("%14s",     sub{bytes_readable($_[0])}) 




6713



  
0
  



  
  0
  




 




  
0
  




 





0



            :      ("%14d b",   sub{$_[0]}); 




 



  
0
  



  
  0
  




 





 





 





0



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6714




 





 





 





 





 





 



   my @e=$o{a}?(sort(keys%c)) 




6715



  
0
  



  
  0
  




 





 





 





0



        :$o{c}?(sort{$c{$a}<=>$c{$b} or $a cmp $b}keys%c) 




6716



  
0
  



  
  0
  




 





 





 





0



        :      (sort{$b{$a}<=>$b{$b} or $a cmp $b}keys%c); 




 



  
0
  



  
  0
  




 





 





 





0



   




 




 




  
  0
  




 





 





 





 



   




6717



  
0
  



  
  0
  




 





 





 





0



   my @p=$o{P}?(10,50,90):(50); 




6718




 





 





 





 





 





 



   my $perc=sub{ 




6719



  
0
  



  
  0
  



  
  0
  



  
0
  




 





0



     $o{M} or $o{P} or return""; 




6720



  
0
  




 





 





 





 





0



     my @m=@_>0 ? do {grep$_, split",", $mtime{$_[0]}} 




6721



  
0
  



  
  0
  




 





 





 





0



                : do {grep$_, map {split","} values %mtime}; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6722



  
0
  




 





 





 





 





0



     my @r=percentile(\@p,@m); 




6723



  
0
  



  
  0
  




 





 





 





0



     @r=(min(@m),@r,max(@m)) if $o{M}; 




6724



  
0
  




 





 





 





 





0



     @r=map int($_), @r; 




6725



  
0
  



  
  0
  




 





 





 





0



     my $fmt='YYYY/MM/DD'; $fmt.="-MM:MI:SS" if $o{t}; 




 



  
0
  




 





 





 





 





0



   




6726



  
0
  




 





 





 





 





0



     @r=map tms($_,$fmt), @r; 




6727



  
0
  




 





 





 





 





0



     "  ".join(" ",@r); 




6728



  
0
  




 





 





 





 





0



   }; 




6729



  
0
  




 





 





 





 





0



   printf("%-11s %8d $f %7.2f%%%s\n",$_,$c{$_},&$s($b{$_}),100*$b{$_}/$bts,&$perc($_)) for @e; 




6730



  
0
  




 





 





 





 





0



   printf("%-11s %8d $f %7.2f%%%s\n","Sum",$cnt,&$s($bts),100,&$perc()); 




6731




 





 





 





 





 





 



 } 




6732




 





 





 





 





 





 



 sub cmd_xcat { 




6733



  
0
  




 





 




  
0
  



  
0
  




0



   for my $fn (@_){ 




6734



  
0
  




 





 





 





 





0



     my $os=openstr($fn); 




6735



  
0
  



  
  0
  



  
  0
  




 





 





0



     open my $FH, $os or warn "xcat: cannot open $os ($!)\n" and next; 




6736



  
0
  




 





 





 





 





0



     print while <$FH>; 




6737



  
0
  




 





 





 





 





0



     close($FH); 




6738




 





 





 





 





 





 



   } 




6739




 





 





 





 





 





 



 } 




6740




 





 





 





 





 





 



 sub cmd_freq { 




6741



  
0
  




 





 




  
0
  



  
0
  




0



   my(@f,$i); 




6742



  
0
  




 





 





 





 





0



   map $f[$_]++, unpack("C*",$_) while <>; 




6743



  
0
  




 





 





 





 





0



   my $s=" " x 12;map{print"$_$s$_$s$_\n"}("BYTE  CHAR   COUNT","---- ----- -------"); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6744



  
0
  




 





 





 





 





0



   my %m=(145,"DOS-æ",155,"DOS-ø",134,"DOS-å",146,"DOS-Æ",157,"DOS-Ø",143,"DOS-Å",map{($_," ")}0..31); 




 



  
0
  




 





 





 





 





0



   




6745



  
0
  



  
  0
  



  
  0
  




 





 





0



   printf("%4d %5s%8d".(++$i%3?$s:"\n"),$_,$m{$_}||chr,$f[$_]) for grep$f[$_],0..255;print "\n"; 




 



  
0
  




 





 





 





 





0



   




6746



  
0
  




 





 





 





 





0



   my @no=grep!$f[$_],0..255; print "No bytes for these ".@no.": ".join(" ",@no)."\n"; 




 



  
0
  




 





 





 





 





0



   




6747




 





 





 





 





 





 



 } 




6748




 





 





 





 





 





 



   




6749




 





 





 





 





 





 



 sub cmd_deldup { 




6750




 





 





 





 





 





 



   # ~/test/deldup.pl #find and optionally delete duplicate files effiencently 




6751




 





 





 





 





 





 



   #http://www.commandlinefu.com/commands/view/3555/find-duplicate-files-based-on-size-first-then-md5-hash 




6752



  
0
  




 





 




  
0
  



  
0
  




0



   die "todo: deldup not ready yet" 




6753




 





 





 





 





 





 



 } 




6754




 





 





 





 





 





 



   




6755




 





 





 





 





 





 



 #http://stackoverflow.com/questions/11900239/can-i-cache-the-output-of-a-command-on-linux-from-cli 




6756




 





 





 





 





 





 



 our $Ccmd_cache_dir='/tmp/acme-tools-ccmd-cache'; 




6757




 





 





 





 





 





 



 our $Ccmd_cache_expire=15*60;  #default 15 minutes 




6758




 





 





 





 





 





 



 sub cmd_ccmd { 




6759



  
0
  




 





 




  
0
  



  
0
  




0



   require Digest::MD5; 




6760



  
0
  




 





 





 





 





0



   my $cmd=join" ",@_; 




6761



  
0
  




 





 





 





 





0



   my $d="$Ccmd_cache_dir/".username(); 




6762



  
0
  




 





 





 





 





0



   makedir($d); 




6763



  
0
  




 





 





 





 





0



   my $md5=Digest::MD5::md5_hex($cmd); 




6764



  
0
  




 





 





 





 





0



   my($fno,$fne)=map"$d/cmd.$md5.std$_","out","err"; 




6765



  
0
  




 





 




  
0
  




 





0



   my $too_old=sub{time()-(stat(shift))[9] >= $Ccmd_cache_expire}; 




 



  
0
  




 





 





 





 





0



   




6766



  
0
  




 





 





 





 





0



   unlink grep &$too_old($_), <$d/*.std???>; 




6767



  
0
  



  
  0
  



  
  0
  




 





 





0



   sys("($cmd) > $fno 2> $fne") if !-e$fno or &$too_old($fno); 




6768



  
0
  




 





 





 





 





0



   print STDOUT "".readfile($fno); 




6769



  
0
  




 





 





 





 





0



   print STDERR "".readfile($fne); 




6770




 





 





 





 





 





 



 } 




6771




 





 





 





 





 





 



   




6772



  
0
  




 





 




  
0
  



  
0
  




0



 sub cmd_trunc { die "todo: trunc not ready yet"} #truncate a file, size 0, keep all other attr 




6773




 





 





 





 





 





 



   




6774




 





 





 





 





 





 



 sub cmd_wipe  { 




6775



  
0
  




 





 




  
0
  



  
0
  




0



   require Getopt::Std; my %o; Getopt::Std::getopts("n:k" => \%o); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6776



  
0
  




 





 





 





 





0



   wipe($_,$o{n},$o{k}) for @_; 




6777




 





 





 





 





 





 



 } 




6778




 





 





 





 





 





 



   




6779




 





 





 





 





 





 



 =head1 DATABASE STUFF - NOT IMPLEMENTED YET 




6780




 





 





 





 





 





 



   




6781




 





 





 





 





 





 



 Uses L. Comming soon... 




6782




 





 





 





 





 





 



   




6783




 





 





 





 





 





 



   $Dbh 




6784




 





 





 





 





 





 



   dlogin 




6785




 





 





 





 





 





 



   dlogout 




6786




 





 





 





 





 





 



   drow 




6787




 





 





 





 





 





 



   drows 




6788




 





 





 





 





 





 



   drowc 




6789




 





 





 





 





 





 



   drowsc 




6790




 





 





 





 





 





 



   dcols 




6791




 





 





 





 





 





 



   dpk 




6792




 





 





 





 





 





 



   dsel 




6793




 





 





 





 





 





 



   ddo 




6794




 





 





 





 





 





 



   dins 




6795




 





 





 





 





 





 



   dupd 




6796




 





 





 





 





 





 



   ddel 




6797




 





 





 





 





 





 



   dcommit 




6798




 





 





 





 





 





 



   drollback 




6799




 





 





 





 





 





 



   




6800




 





 





 





 





 





 



 =cut 




6801




 





 





 





 





 





 



   




6802




 





 





 





 





 





 



 #my$dummy=<<'SOON'; 




6803




 





 





 





 





 





 



 sub dtype { 




6804



  
0
  




 





 




  
0
  



  
0
  




0



   my $connstr=shift; 




6805



  
0
  



  
  0
  




 





 





 





0



   return 'SQLite' if $connstr=~/(\.sqlite|sqlite:.*\.db)$/i; 




6806



  
0
  



  
  0
  




 





 





 





0



   return 'Oracle' if $connstr=~/\@/; 




6807



  
0
  




 





 





 





 





0



   return 'Pg' if 1==2; 




6808



  
0
  




 





 





 





 





0



   die; 




6809




 





 





 





 





 





 



 } 




6810




 





 





 





 





 





 



   




6811




 





 





 





 





 





 



 our($Dbh,@Dbh,%Sth); 




6812




 





 





 





 





 





 



 our %Dbattr=(RaiseError => 1, AutoCommit => 0); #defaults 




6813




 





 





 





 





 





 



 sub dlogin { 




6814



  
0
  




 





 




  
0
  



  
0
  




0



   my $connstr=shift(); 




6815



  
0
  




 





 





 





 





0



   my %attr=(%Dbattr,@_); 




6816



  
0
  




 





 





 





 





0



   my $type=dtype($connstr); 




6817



  
0
  




 





 





 





 





0



   my($dsn,$u,$p)=('','',''); 




6818



  
0
  



  
  0
  




 





 





 





0



   if($type eq 'SQLite'){ 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6819



  
0
  




 





 





 





 





0



     $dsn=$connstr; 




6820




 





 





 





 





 





 



   } 




6821




 





 





 





 





 





 



   elsif($type eq 'Oracle'){ 




6822



  
0
  




 





 





 





 





0



     ($u,$p,$dsn)=($connstr=~m,(.+?)(/.+?)?\@(.+),); 




6823




 





 





 





 





 





 



   } 




6824




 





 





 





 





 





 



   elsif($type eq 'Pg'){ 




6825



  
0
  




 





 





 





 





0



     croak "todo"; 




6826




 





 





 





 





 





 



   } 




6827




 





 





 





 





 





 



   else{ 




6828



  
0
  




 





 





 





 





0



     croak "dblogin: unknown database type for connection string $connstr\n"; 




6829




 





 





 





 





 





 



   } 




6830



  
0
  




 





 





 





 





0



   $dsn="dbi:$type:$dsn"; 




6831



  
0
  



  
  0
  




 





 





 





0



   push @Dbh, $Dbh if $Dbh; #local is better? 




6832



  
0
  




 





 





 





 





0



   require DBI; 




6833



  
0
  




 





 





 





 





0



   $Dbh=DBI->connect($dsn,$u,$p,\%attr); #connect_cached? 




6834




 





 





 





 





 





 



 } 




6835




 





 





 





 





 





 



 sub dlogout { 




6836



  
0
  




 





 




  
0
  



  
0
  




0



   $Dbh->disconnect; 




6837



  
0
  



  
  0
  




 





 





 





0



   $Dbh=pop@Dbh if @Dbh; 




6838




 





 





 





 





 





 



 } 




6839




 





 





 





 





 





 



 sub drow { 




6840



  
0
  




 





 




  
0
  



  
0
  




0



   my($q,@b)=_dattrarg(@_); 




6841




 





 





 





 





 





 



   #my $sth=do{$Sth{$Dbh,$q} ||= $Dbh->prepare_cached($q)}; 




6842



  
0
  




 





 





 





 





0



   my $sth=$Dbh->prepare_cached($q); 




6843



  
0
  




 





 





 





 





0



   $sth->execute(@b); 




6844



  
0
  




 





 





 





 





0



   my @r=$sth->fetchrow_array; 




6845



  
0
  



  
  0
  




 





 





 





0



   $sth->finish if $$Dbh{Driver}{Name} eq 'SQLite'; 




6846




 





 





 





 





 





 



   #$dbh->selectrow_array($statement); 




6847



  
0
  



  
  0
  




 





 





 





0



   return @r==1?$r[0]:@r; 




6848




 





 





 





 





 





 



 } 




6849




 





 





 




  
0
  



  
0
  




 



 sub drows { 




6850




 





 





 





 





 





 



 } 




6851




 





 





 




  
0
  



  
0
  




 



 sub drowc { 




6852




 





 





 





 





 





 



 } 




6853




 





 





 




  
0
  



  
0
  




 



 sub drowsc { 




6854




 





 





 





 





 





 



 } 




6855




 





 





 




  
0
  



  
0
  




 



 sub dcols { 




6856




 





 





 





 





 





 



 } 




6857




 





 





 




  
0
  



  
0
  




 



 sub dpk { 




6858




 





 





 





 





 





 



 } 




6859




 





 





 




  
0
  



  
0
  




 



 sub dsel { 




6860




 





 





 





 





 





 



 } 




6861




 





 





 





 





 





 



 sub ddo { 




6862



  
0
  




 





 




  
0
  



  
0
  




0



   my @arg=_dattrarg(@_); 




6863




 





 





 





 





 





 



   #warn serialize(\@arg,'arg','',1); 




6864



  
0
  




 





 





 





 





0



   $Dbh->do(@arg); #hm cache? 




6865




 





 





 





 





 





 



 } 




6866




 





 





 




  
0
  



  
0
  




 



 sub dins { 




6867




 





 





 





 





 





 



 } 




6868




 





 





 




  
0
  



  
0
  




 



 sub dupd { 




6869




 





 





 





 





 





 



 } 




6870




 





 





 




  
0
  



  
0
  




 



 sub ddel { 




6871




 





 





 





 





 





 



 } 




6872



  
0
  




 





 




  
0
  



  
0
  




0



 sub dcommit { $Dbh->commit } 




6873



  
0
  




 





 




  
0
  



  
0
  




0



 sub drollback { $Dbh->rollback } 




6874




 





 





 





 





 





 



   




6875




 





 





 





 





 





 



 sub _dattrarg { 




6876



  
0
  




 





 




  
0
  




 





0



   my @arg=@_; 




6877



  
0
  



  
  0
  




 





 





 





0



   splice @arg,1,0, ref($arg[-1]) eq 'HASH' ? pop(@arg) : {}; 




6878



  
0
  




 





 





 





 





0



   @arg; 




6879




 





 





 





 





 





 



 } 




6880




 





 





 





 





 





 



   




6881




 





 





 





 





 





 



 =head2 self_update 




6882




 





 





 





 





 





 



   




6883




 





 





 





 





 





 



 Update Acme::Tools to newest version quick and dirty: 




6884




 





 





 





 





 





 



   




6885




 





 





 





 





 





 



  function pmview(){ ls -ld `perl -M$1 -le'$m=shift;$mi=$m;$mi=~s,::,/,g;print $INC{"$mi.pm"};warn"Version ".${$m."::VERSION"}."\n"' $1`;} 




6886




 





 





 





 





 





 



   




6887




 





 





 





 





 





 



  pmview Acme::Tools                                     #view date and version before 




6888




 





 





 





 





 





 



  sudo perl -MAcme::Tools -e Acme::Tools::self_update    #update to newest version 




6889




 





 





 





 





 





 



  pmview Acme::Tools                                     #view date and version after 




6890




 





 





 





 





 





 



   




6891




 





 





 





 





 





 



 Does C to where Acme/Tools.pm are and then wget -N https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm 




6892




 





 





 





 





 





 



   




6893




 





 





 





 





 





 



 =cut 




6894




 





 





 





 





 





 



   




6895




 





 





 





 





 





 



 our $Wget; 




6896




 





 





 





 





 





 



 our $Self_update_url='https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm'; #todo: change site 




6897




 





 





 





 





 





 



 sub self_update { 




6898




 





 





 





 





 





 



   #in($^O,'linux','cygwin') or die"ERROR: self_update works on linux and cygwin only"; 




6899



  
0
  




 




  
  0
  



  
0
  



  
1
  




0



   $Wget||=(grep -x$_,map"$_/wget",'/usr/bin','/bin','/usr/local/bin','.')[0]; #hm --no-check-certificate 




6900



  
0
  



  
  0
  




 





 





 





0



   -x$Wget or die"ERROR: wget ($Wget) executable not found\n"; 




6901



  
0
  




 





 





 





 





0



   my $d=dirname(__FILE__); 




6902



  
0
  




 





 





 





 





0



   sys("cd $d; ls -l Tools.pm; md5sum Tools.pm"); 




6903



  
0
  




 




  
  0
  




 





 





0



   sys("cd $d; $Wget -N ".($ARGV[0]||$Self_update_url)); 




6904



  
0
  




 





 





 





 





0



   sys("cd $d; ls -l Tools.pm; md5sum Tools.pm"); 




6905




 





 





 





 





 





 



 } 




6906




 





 





 





 





 





 



   




6907




 





 





 





 





 





 



 1; 




6908




 





 





 





 





 





 



   




6909




 





 





 





 





 





 



 package Acme::Tools::BloomFilter; 




6910




28





 





 




  
28
  




 





768



 use 5.008; use strict; use warnings; use Carp; 




 




28





 





 




  
28
  




 





101



   




 




28





 





 




  
28
  




 





141



   




 




28





 





 




  
28
  




 





50



   




 




28





 





 





 





 





738



   




 




28





 





 





 





 





132



   




 




28





 





 





 





 





46



   




 




28





 





 





 





 





969



   




 




28





 





 





 





 





143



   




 




28





 





 





 





 





46



   




 




28





 





 





 





 





14374



   




6911




2





 





 




  
2
  




 





307



 sub new      { my($class,@p)=@_; my $self=Acme::Tools::bfinit(@p); bless $self, $class } 




 




2





 





 





 





 





9



   




 




2





 





 





 





 





11



   




6912




2





 





 




  
2
  




 





108



 sub add      { &Acme::Tools::bfadd      } 




6913



  
0
  




 





 




  
0
  




 





0



 sub addbf    { &Acme::Tools::bfaddbf    } 




6914




2





 





 




  
2
  




 





88



 sub check    { &Acme::Tools::bfcheck    } 




6915




1





 





 




  
1
  




 





7



 sub grep     { &Acme::Tools::bfgrep     } 




6916



  
0
  




 





 




  
0
  




 





0



 sub grepnot  { &Acme::Tools::bfgrepnot  } 




6917



  
0
  




 





 




  
0
  




 





0



 sub delete   { &Acme::Tools::bfdelete   } 




6918



  
0
  




 





 




  
0
  




 





0



 sub store    { &Acme::Tools::bfstore    } 




6919



  
0
  




 





 




  
0
  




 





0



 sub retrieve { &Acme::Tools::bfretrieve } 




6920




1





 





 




  
1
  




 





5



 sub clone    { &Acme::Tools::bfclone    } 




6921




0





 





 




  
0
  




 





0



 sub sum      { &Acme::Tools::bfsum      } 




6922




 





 





 





 





 





 



 1; 




6923




 





 





 





 





 





 



   




6924




 





 





 





 





 





 



 # Ny versjon: 




6925




 





 





 





 





 





 



 # + c-s todo 




6926




 





 





 





 





 





 



 # + endre $VERSION 




6927




 





 





 





 





 





 



 # + endre Release history under HISTORY 




6928




 





 





 





 





 





 



 # + endre årstall under COPYRIGHT AND LICENSE 




6929




 





 





 





 





 





 



 # + oppd default valutakurser inkl datoen 




6930




 





 





 





 





 





 



 # + emacs Changes 




6931




 





 





 





 





 





 



 # + emacs README + aarstall 




6932




 





 





 





 





 





 



 # + emacs MANIFEST legg til ev nye t/*.t 




6933




 





 





 





 





 





 



 # + perl            Makefile.PL;make test 




6934




 





 





 





 





 





 



 # + /usr/bin/perl   Makefile.PL;make test 




6935




 





 





 





 





 





 



 # + perlbrew exec "perl ~/Acme-Tools/Makefile.PL ; time make test" 




6936




 





 





 





 





 





 



 # + perlbrew use perl-5.10.1; perl Makefile.PL; make test; perlbrew off 




6937




 





 





 





 





 





 



 # + test evt i cygwin og mingw-perl 




6938




 





 





 





 





 





 



 # + pod2html Tools.pm > Tools.html ; firefox Tools.html  




6939




 





 





 





 





 





 



 # + https://metacpan.org/pod/Acme::Tools 




6940




 





 





 





 





 





 



 # + http://cpants.cpanauthors.org/dist/Acme-Tools  #kvalitee 




6941




 





 





 





 





 





 



 # + perl Makefile.PL ; make test && make dist 




6942




 





 





 





 





 





 



 # + cp -p *tar.gz /htdocs/ 




6943




 





 





 





 





 





 



 # + ci -l -mversjon -d `cat MANIFEST` 




6944




 





 





 





 





 





 



 # + git add `cat MANIFEST` 




6945




 





 





 





 





 





 



 # + git status 




6946




 





 





 





 





 





 



 # + git commit -am versjon 




6947




 





 





 





 





 





 



 # + git push                    #eller: 




6948




 





 





 





 





 





 



 # + git push origin master 




6949




 





 





 





 





 





 



 # + http://pause.perl.org/ 




6950




 





 





 





 





 





 



 # http://en.wikipedia.org/wiki/Birthday_problem#Approximations 




6951




 





 





 





 





 





 



   




6952




 





 





 





 





 





 



 # memoize_expire()           http://perldoc.perl.org/Memoize/Expire.html 




6953




 





 





 





 





 





 



 # memoize_file_expire() 




6954




 





 





 





 





 





 



 # memoize_limit_size() #lru 




6955




 





 





 





 





 





 



 # memoize_file_limit_size() 




6956




 





 





 





 





 





 



 # memoize_memcached         http://search.cpan.org/~dtrischuk/Memoize-Memcached-0.03/lib/Memoize/Memcached.pm 




6957




 





 





 





 





 





 



 # hint on http://perl.jonallen.info/writing/articles/install-perl-modules-without-root 




6958




 





 





 





 





 





 



   




6959




 





 





 





 





 





 



 # sub mycrc32 {  #http://billauer.co.il/blog/2011/05/perl-crc32-crc-xs-module/  eller String::CRC32::crc32 som er 100 x raskere enn Digest::CRC::crc32 




6960




 





 





 





 





 





 



 #  my ($input, $init_value, $polynomial) = @_; 




6961




 





 





 





 





 





 



 #  $init_value = 0 unless (defined $init_value); 




6962




 





 





 





 





 





 



 #  $polynomial = 0xedb88320 unless (defined $polynomial); 




6963




 





 





 





 





 





 



 #  my @lookup_table; 




6964




 





 





 





 





 





 



 #  for (my $i=0; $i<256; $i++) { 




6965




 





 





 





 





 





 



 #    my $x = $i; 




6966




 





 





 





 





 





 



 #    for (my $j=0; $j<8; $j++) { 




6967




 





 





 





 





 





 



 #      if ($x & 1) { 




6968




 





 





 





 





 





 



 #        $x = ($x >> 1) ^ $polynomial; 




6969




 





 





 





 





 





 



 #      } else { 




6970




 





 





 





 





 





 



 #        $x = $x >> 1; 




6971




 





 





 





 





 





 



 #      } 




6972




 





 





 





 





 





 



 #    } 




6973




 





 





 





 





 





 



 #    push @lookup_table, $x; 




6974




 





 





 





 





 





 



 #  } 




6975




 





 





 





 





 





 



 #  my $crc = $init_value ^ 0xffffffff; 




6976




 





 





 





 





 





 



 #  foreach my $x (unpack ('C*', $input)) { 




6977




 





 





 





 





 





 



 #    $crc = (($crc >> 8) & 0xffffff) ^ $lookup_table[ ($crc ^ $x) & 0xff ]; 




6978




 





 





 





 





 





 



 #  } 




6979




 





 





 





 





 





 



 #  $crc = $crc ^ 0xffffffff; 




6980




 





 





 





 





 





 



 #  return $crc; 




6981




 





 





 





 





 





 



 # } 




6982




 





 





 





 





 





 



 # 




6983




 





 





 





 





 





 



   




6984




 





 





 





 





 





 



   




6985




 





 





 





 





 





 



   




6986




 





 





 





 





 





 



 =head1 HISTORY 




6987




 





 





 





 





 





 



   




6988




 





 





 





 





 





 



 Release history 




6989




 





 





 





 





 





 



   




6990




 





 





 





 





 





 



  0.172 Dec 2015   Subs: curb, openstr, pwgen, sleepms, sleepnm, srlz, tms, username, 




6991




 





 





 





 





 





 



                   self_update, install_acme_command_tools 




6992




 





 





 





 





 





 



                   Commands: conv, due, freq, wipe, xcat (see "Commands") 




6993




 





 





 





 





 





 



  0.16  Feb 2015   bigr, curb, cpad, isnum, parta, parth, read_conf, resolve_equation, 




6994




 





 





 





 





 





 



                   roman2int, trim. Improved: conv (numbers, currency), range ("derivatives") 




6995




 





 





 





 





 





 



  0.15  Nov 2014   Improved doc 




6996




 





 





 





 





 





 



  0.14  Nov 2014   New subs, improved tests and doc 




6997




 





 





 





 





 





 



  0.13  Oct 2010   Non-linux test issue, resolve. improved: bloom filter, tests, doc 




6998




 





 





 





 





 





 



  0.12  Oct 2010   Improved tests, doc, bloom filter, random_gauss, bytes_readable 




6999




 





 





 





 





 





 



  0.11  Dec 2008   Improved doc 




7000




 





 





 





 





 





 



  0.10  Dec 2008 




7001




 





 





 





 





 





 



   




7002




 





 





 





 





 





 



 =head1 SEE ALSO 




7003




 





 





 





 





 





 



   




7004




 





 





 





 





 





 



 L 




7005




 





 





 





 





 





 



   




7006




 





 





 





 





 





 



 =head1 AUTHOR 




7007




 





 





 





 





 





 



   




7008




 





 





 





 





 





 



 Kjetil Skotheim, [e-mail] 




7009




 





 





 





 





 





 



   




7010




 





 





 





 





 





 



 =head1 COPYRIGHT 




7011




 





 





 





 





 





 



   




7012




 





 





 





 





 





 



 1995-2015, Kjetil Skotheim 




7013




 





 





 





 





 





 



   




7014




 





 





 





 





 





 



 =head1 LICENSE 




7015




 





 





 





 





 





 



   




7016




 





 





 





 





 





 



 This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 




7017




 





 





 





 





 





 



   




7018




 





 





 





 





 





 



 =cut

Second argument: (optional) If the html contains more than one C<<
 >>, and you do not want the first one, applying a second 




3539




 





 





 





 





 





 



 argument is a way of telling C which to capture: the one with this word 




3540




 





 





 





 





 





 



 or string occurring before it. 




3541




 





 





 





 





 





 



   




3542




 





 





 





 





 





 



 Output: An array of arrayrefs. 




3543




 





 





 





 





 





 



   




3544




 





 





 





 





 





 



 C is a quick and dirty way of scraping (or harvesting as it is 




3545




 





 





 





 





 





 



 also called) data from a web page. Look too L to do this 




3546




 





 





 





 





 





 



 more accurate. 




3547




 





 





 





 





 





 



   




3548




 





 





 





 





 





 



 Example: 




3549




 





 





 





 





 





 



   




3550




 





 





 





 





 





 



  use Acme::Tools; 




3551




 





 





 





 





 





 



  use LWP::Simple; 




3552




 





 





 





 





 





 



  my $url = "http://en.wikipedia.org/wiki/List_of_countries_by_population"; 




3553




 





 





 





 





 





 



  for( ht2t( get($url), "Countries" ) ) { 




3554




 





 





 





 





 





 



    my($rank, $country, $pop) = @$_; 




3555




 





 





 





 





 





 



    $pop =~ s/,//g; 




3556




 





 





 





 





 





 



    printf "%3d | %-32s | %9d\n", @$_ if $pop>0; 




3557




 





 





 





 





 





 



  } 




3558




 





 





 





 





 





 



   




3559




 





 





 





 





 





 



 Output: 




3560




 





 





 





 





 





 



   




3561




 





 





 





 





 





 



   1 | China                            | 1367740000 




3562




 





 





 





 





 





 



   2 | India                            | 1262090000 




3563




 





 





 





 





 





 



   3 | United States                    | 319043000 




3564




 





 





 





 





 





 



   4 | Indonesia                        | 252164800 




3565




 





 





 





 





 





 



   5 | Brazil                           | 203404000 




3566




 





 





 





 





 





 



   




3567




 





 





 





 





 





 



 ...and so on. 




3568




 





 





 





 





 





 



   




3569




 





 





 





 





 





 



 =cut 




3570




 





 





 





 





 





 



   




3571




 





 





 





 





 





 



 sub ht2t { 




3572




9




  
100
  



  
100
  



  
9
  



  
1
  




451



   my($f,$s,$r)=@_; 1>@_||@_>3 and croak; $s='' if @_==1; 




 




9




  
100
  




 





 





 





314



   




 




7





 





 





 





 





17



   




3573




7





 





 





 





 





121



   $f=~s,.*?($s).*?(




3574




28





 





 




  
28
  




 





835971



   my $e=0;$e++ while index($f,$s=chr($e))>=$[; 




 




28





 





 





 





 





13345



   




 




28





 





 





 





 





104398



   




 




7





 





 





 





 





13



   




 




7





 





 





 





 





36



   




3575




7





 





 





 





 





85



   $f=~s//\l$1$s/gsi; 




3576




7





 





 





 





 





54



   $f=~s/\s*<.*?>\s*/ /gsi; 




3577




7





 





 





 





 





66



   my @t=split("r$s",$f);shift @t; 




 




7





 





 





 





 





12



   




3578




20





 





 




  
20
  




 





32



   $r||=sub{s/&(#160|nbsp);/ /g;s/&/&/g;s/^\s*(.*?)\s*$/$1/s; 




 




20





 





 





 





 





28



   




 




20





 





 





 





 





81



   




3579




7




  
100
  



  
100
  




 





 





38



 	   s/(\d) (\d)/$1$2/g if /^[\d \.\,]+$/}; 




 




20





 





 





 





 





71



   




3580




7





 





 





 





 





16



   for(@t){my @r=split/[dh]$s/;shift@r;$_=[map{&$r;$_}@r]} 




 




9





 





 





 





 





52



   




 




9





 





 





 





 





14



   




 




9





 





 





 





 





16



   




 




20





 





 





 





 





31



   




 




20





 





 





 





 





64



   




3581




7





 





 





 





 





38



   @t; 




3582




 





 





 





 





 





 



 } 




3583




 





 





 





 





 





 



   




3584




 





 





 





 





 





 



 =head1 FILES, DIRECTORIES 




3585




 





 





 





 





 





 



   




3586




 





 





 





 





 





 



 =head2 writefile 




3587




 





 





 





 





 





 



   




3588




 





 





 





 





 





 



 Justification: 




3589




 





 





 





 





 





 



   




3590




 





 





 





 





 





 



 Perl needs three or four operations to make a file out of a string: 




3591




 





 





 





 





 





 



   




3592




 





 





 





 





 





 



  open my $FILE, '>', $filename  or die $!; 




3593




 





 





 





 





 





 



  print $FILE $text; 




3594




 





 





 





 





 





 



  close($FILE); 




3595




 





 





 





 





 





 



   




3596




 





 





 





 





 





 



 This is way simpler: 




3597




 





 





 





 





 





 



   




3598




 





 





 





 





 





 



  writefile($filename,$text); 




3599




 





 





 





 





 





 



   




3600




 





 





 





 





 





 



 Sub writefile opens the file i binary mode (C) and has two usage modes: 




3601




 





 





 





 





 





 



   




3602




 





 





 





 





 





 



 B Two arguments 




3603




 





 





 





 





 





 



   




3604




 





 





 





 





 





 



 B is the filename. If the file exists, its overwritten. 




3605




 





 





 





 





 





 



 If the file can not be opened for writing, a die (a croak really) happens. 




3606




 





 





 





 





 





 



   




3607




 





 





 





 





 





 



 B is one of: 




3608




 





 





 





 





 





 



   




3609




 





 





 





 





 





 



 =over 4 




3610




 





 





 





 





 





 



   




3611




 





 





 





 





 





 



 =item * Either a scaler. That is a normal string to be written to the file. 




3612




 





 





 





 





 





 



   




3613




 





 





 





 





 





 



 =item * Or a reference to a scalar. That referred text is written to the file. 




3614




 





 





 





 





 





 



   




3615




 





 





 





 





 





 



 =item * Or a reference to an array of scalars. This array is the written to the 




3616




 





 





 





 





 





 



  file element by element and C<< \n >> is automatically appended to each element. 




3617




 





 





 





 





 





 



   




3618




 





 





 





 





 





 



 =back 




3619




 





 





 





 





 





 



   




3620




 





 





 





 





 





 



 Alternativelly, you can write several files at once. 




3621




 





 





 





 





 





 



   




3622




 





 





 





 





 





 



 Example, this: 




3623




 





 





 





 





 





 



   




3624




 





 





 





 





 





 



  writefile('file1.txt','The text....tjo'); 




3625




 





 





 





 





 





 



  writefile('file2.txt','The text....hip'); 




3626




 





 





 





 





 





 



  writefile('file3.txt','The text....and hop'); 




3627




 





 





 





 





 





 



   




3628




 





 





 





 





 





 



 ...is the same as this: 




3629




 





 





 





 





 





 



   




3630




 





 





 





 





 





 



  writefile([ 




3631




 





 





 





 





 





 



    ['file1.txt','The text....tjo'], 




3632




 





 





 





 





 





 



    ['file2.txt','The text....hip'], 




3633




 





 





 





 





 





 



    ['file3.txt','The text....and hop'], 




3634




 





 





 





 





 





 



  ]); 




3635




 





 





 





 





 





 



   




3636




 





 





 





 





 





 



 B Nothing (for the time being). Cs (C really) if something goes wrong. 




3637




 





 





 





 





 





 



   




3638




 





 





 





 





 





 



 =cut 




3639




 





 





 





 





 





 



   




3640




 





 





 





 





 





 



 #todo: use openstr() as in readfile(), transparently gzip .gz filenames and so on 




3641




 





 





 





 





 





 



 sub writefile { 




3642




4





 





 




  
4
  



  
1
  




70151



     my($filename,$text)=@_; 




3643




4




  
 50
  




 





 





 





25



     if(ref($filename) eq 'ARRAY'){ 




3644



  
0
  




 





 





 





 





0



 	writefile(@$_) for @$filename; 




3645



  
0
  




 





 





 





 





0



 	return; 




3646




 





 





 





 





 





 



     } 




3647




4




  
 50
  



  
 33
  




 





 





306



     open(WRITEFILE,">",$filename) and binmode(WRITEFILE) or croak($!); 




3648




4




  
 50
  



  
 33
  




 





 





41



     if(!defined $text or !ref($text)){ 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




3649




4





 





 





 





 





733



 	print WRITEFILE $text; 




3650




 





 





 





 





 





 



     } 




3651




 





 





 





 





 





 



     elsif(ref($text) eq 'SCALAR'){ 




3652



  
0
  




 





 





 





 





0



 	print WRITEFILE $$text; 




3653




 





 





 





 





 





 



     } 




3654




 





 





 





 





 





 



     elsif(ref($text) eq 'ARRAY'){ 




3655



  
0
  




 





 





 





 





0



 	print WRITEFILE "$_\n" for @$text; 




3656




 





 





 





 





 





 



     } 




3657




 





 





 





 





 





 



     else { 




3658



  
0
  




 





 





 





 





0



 	croak; 




3659




 





 





 





 





 





 



     } 




3660




4





 





 





 





 





167



     close(WRITEFILE); 




3661




4





 





 





 





 





15



     return; 




3662




 





 





 





 





 





 



 } 




3663




 





 





 





 





 





 



   




3664




 





 





 





 





 





 



 =head2 readfile 




3665




 





 





 





 





 





 



   




3666




 





 





 





 





 





 



 Just as with L you can read in a whole file in one operation with C. Instead of: 




3667




 





 





 





 





 





 



   




3668




 





 





 





 





 





 



  open my $FILE,'<', $filename or die $!; 




3669




 





 





 





 





 





 



  my $data = join"",<$FILE>; 




3670




 





 





 





 





 





 



  close($FILE); 




3671




 





 





 





 





 





 



   




3672




 





 





 





 





 





 



 This is simpler: 




3673




 





 





 





 





 





 



   




3674




 





 





 





 





 





 



  my $data = readfile($filename); 




3675




 





 





 





 





 





 



   




3676




 





 





 





 





 





 



 B 




3677




 





 





 





 





 





 



   




3678




 





 





 





 





 





 



 Reading the content of the file to a scalar variable: (Any content in C<$data> will be overwritten) 




3679




 





 





 





 





 





 



   




3680




 





 





 





 





 





 



  my $data; 




3681




 





 





 





 





 





 



  readfile('filename.txt',\$data); 




3682




 





 





 





 





 





 



   




3683




 





 





 





 





 





 



 Reading the lines of a file into an array: 




3684




 





 





 





 





 





 



   




3685




 





 





 





 





 





 



  my @lines; 




3686




 





 





 





 





 





 



  readfile('filnavn.txt',\@lines); 




3687




 





 





 





 





 





 



  for(@lines){ 




3688




 





 





 





 





 





 



    ... 




3689




 





 





 





 





 





 



  } 




3690




 





 





 





 





 





 



   




3691




 





 





 





 





 





 



 Note: Chomp is done on each line. That is, any newlines (C<< \n >>) will be removed. 




3692




 





 





 





 





 





 



 If C<@lines> is non-empty, this will be lost. 




3693




 





 





 





 





 





 



   




3694




 





 





 





 





 





 



 Sub readfile is context aware. If an array is expected it returns an array of the lines without a trailing C<< \n >>. 




3695




 





 





 





 





 





 



 The last example can be rewritten: 




3696




 





 





 





 





 





 



   




3697




 





 





 





 





 





 



  for(readfile('filnavn.txt')){ 




3698




 





 





 





 





 





 



    ... 




3699




 





 





 





 





 





 



  } 




3700




 





 





 





 





 





 



   




3701




 





 





 





 





 





 



 With two input arguments, nothing (undef) is returned from C. 




3702




 





 





 





 





 





 



   




3703




 





 





 





 





 





 



 =cut 




3704




 





 





 





 





 





 



   




3705




 





 





 





 





 





 



 #http://blogs.perl.org/users/leon_timmermans/2013/05/why-you-dont-need-fileslurp.html 




3706




 





 





 





 





 





 



 #todo: readfile with grep-filter code ref in a third arg (avoid reading all into mem) 




3707




 





 





 





 





 





 



   




3708




 





 





 





 





 





 



 sub readfile { 




3709




12





 





 




  
12
  



  
1
  




11518



   my($filename,$ref)=@_; 




3710




12




  
100
  




 





 





 





59



   if(@_==1){ 




3711




6




  
100
  




 





 





 





22



     if(wantarray){ my @data; readfile($filename,\@data); return @data } 




 




1





 





 





 





 





3



   




 




1





 





 





 





 





5



   




 




1





 





 





 





 





4976



   




3712




5





 





 





 





 





8



     else         { my $data; readfile($filename,\$data); return $data } 




 




5





 





 





 





 





457



   




 




5





 





 





 





 





698



   




3713




 





 





 





 





 





 



   } 




3714




 





 





 





 





 





 



   else { 




3715




6




  
 50
  




 





 





 





46



     open my $fh,openstr($filename) or croak("ERROR: readfile $! $?"); 




3716




6




  
100
  




 





 





 





30



     if   ( ref($ref) eq 'SCALAR') { $$ref=join"",<$fh> } 




 




5




  
 50
  




 





 





 





6899



   




3717




1





 





 





 





 





18



     elsif( ref($ref) eq 'ARRAY' ) { while(my $l=<$fh>){ chomp($l); push @$ref, $l } } 




 




20003





 





 





 





 





20569



   




 




20003





 





 





 





 





54199



   




3718



  
0
  




 





 





 





 





0



     else { croak "ERROR: Second arg to readfile should be a ref to a scalar og array" } 




3719




6





 





 





 





 





1166



     close($fh); 




3720




6





 





 





 





 





38



     return;#? 




3721




 





 





 





 





 





 



   } 




3722




 





 





 





 





 





 



 } 




3723




 





 





 





 





 





 



   




3724




 





 





 





 





 





 



 =head2 readdirectory 




3725




 





 





 





 





 





 



   




3726




 





 





 





 





 





 



 B 




3727




 





 





 





 





 





 



   




3728




 





 





 





 





 





 



 Name of a directory. 




3729




 





 





 





 





 





 



   




3730




 





 





 





 





 





 



 B 




3731




 





 





 





 





 





 



   




3732




 





 





 





 





 





 



 A list of all files in it, except of  C<.> and C<..>  (on linux/unix systems, all directories have a C<.> and C<..> directory). 




3733




 





 





 





 





 





 



   




3734




 





 





 





 





 





 



 The names of all types of files are returned: normal files, directories, symbolic links, 




3735




 





 





 





 





 





 



 pipes, semaphores. That is every thing shown by C except C<.> and C<..> 




3736




 





 





 





 





 





 



   




3737




 





 





 





 





 





 



 C do not recurce down into subdirectories (but see example below). 




3738




 





 





 





 





 





 



   




3739




 





 





 





 





 





 



 B 




3740




 





 





 





 





 





 



   




3741




 





 





 





 





 





 



   my @files = readdirectory("/tmp"); 




3742




 





 





 





 





 





 



   




3743




 





 





 





 





 





 



 B 




3744




 





 





 





 





 





 



   




3745




 





 





 





 





 





 



 Sometimes calling the built ins C, C and C seems a tad tedious, since this: 




3746




 





 





 





 





 





 



   




3747




 





 





 





 





 





 



  my $dir="/usr/bin"; 




3748




 





 





 





 





 





 



  opendir(D,$dir); 




3749




 





 





 





 





 





 



  my @files=map "$dir/$_", grep {!/^\.\.?$/} readdir(D); 




3750




 





 





 





 





 





 



  closedir(D); 




3751




 





 





 





 





 





 



   




3752




 





 





 





 





 





 



 Is the same as this: 




3753




 





 





 





 





 





 



   




3754




 





 





 





 





 





 



  my @files=readdirectory("/usr/bin"); 




3755




 





 





 





 





 





 



   




3756




 





 





 





 





 





 



 See also: L 




3757




 





 





 





 





 





 



   




3758




 





 





 





 





 





 



 B 




3759




 





 





 





 





 





 



   




3760




 





 





 





 





 





 



 On huge directories with perhaps tens or houndreds of thousands of 




3761




 





 





 





 





 





 



 files, readdirectory() will consume more memory than perls 




3762




 





 





 





 





 





 



 opendir/readdir. This isn't usually a concern anymore for modern 




3763




 





 





 





 





 





 



 computers with gigabytes of RAM, but might be the rationale behind 




3764




 





 





 





 





 





 



 Perls more tedious way created in the 80s.  The same argument goes for 




3765




 





 





 





 





 





 



 file slurping. On the other side it's also a good practice to never 




3766




 





 





 





 





 





 



 assume to much on available memory and the number of files if you 




3767




 





 





 





 





 





 



 don't know for certain that enough memory is available whereever your 




3768




 





 





 





 





 





 



 code is run or that the size of the directory is limited. 




3769




 





 





 





 





 





 



   




3770




 





 





 





 





 





 



 B 




3771




 





 





 





 





 





 



   




3772




 





 





 





 





 





 



 How to get all files in the C directory including all subdirectories below of any depth: 




3773




 





 





 





 





 





 



   




3774




 





 





 





 





 





 



  my @files=("/tmp"); 




3775




 





 





 





 





 





 



  map {-d $_ and unshift @files,$_ or push @files,$_} readdirectory(shift(@files)) while -d $files[0]; 




3776




 





 





 





 





 





 



   




3777




 





 





 





 





 





 



 ...or to avoid symlinks and only get real files: 




3778




 





 





 





 





 





 



   




3779




 





 





 





 





 





 



  map {-d and !-l and unshift @files,$_ or -f and !-l and push @files,$_} readdirectory(shift(@files)) while -d $files[0]; 




3780




 





 





 





 





 





 



   




3781




 





 





 





 





 





 



 =cut 




3782




 





 





 





 





 





 



   




3783




 





 





 





 





 





 



 sub readdirectory { 




3784



  
0
  




 





 




  
0
  



  
1
  




0



   my $dir=shift; 




3785



  
0
  




 





 





 





 





0



   opendir(my $D,$dir); 




3786



  
0
  




 





 





 





 





0



   my @filer=map "$dir/$_", grep {!/^\.\.?$/} readdir($D); 




 



  
0
  




 





 





 





 





0



   




3787



  
0
  




 





 





 





 





0



   closedir($D); 




3788



  
0
  




 





 





 





 





0



   return @filer; 




3789




 





 





 





 





 





 



 } 




3790




 





 





 





 





 





 



   




3791




 





 





 





 





 





 



 =head2 basename 




3792




 





 





 





 





 





 



   




3793




 





 





 





 





 





 



 The basename and dirname functions behaves like the *nix shell commands with the same names. 




3794




 





 





 





 





 





 



   




3795




 





 





 





 





 





 



 B One or two arguments: Filename and an optional suffix 




3796




 





 





 





 





 





 



   




3797




 





 





 





 





 





 



 B Returns the filename with any directory and (if given) the suffix removed. 




3798




 





 





 





 





 





 



   




3799




 





 





 





 





 





 



  basename('/usr/bin/perl')                   # returns 'perl' 




3800




 





 





 





 





 





 



  basename('/usr/local/bin/report.pl','.pl')  # returns 'report' since .pl at the end is removed 




3801




 





 





 





 





 





 



  basename('report2.pl','.pl')                # returns 'report2' 




3802




 





 





 





 





 





 



  basename('report2.pl','.\w+')               # returns 'report2.pl', probably not what you meant 




3803




 





 





 





 





 





 



  basename('report2.pl',qr/.\w+/)             # returns 'report2', use qr for regex 




3804




 





 





 





 





 





 



   




3805




 





 





 





 





 





 



 =head2 dirname 




3806




 





 





 





 





 





 



   




3807




 





 





 





 





 





 



 B A filename including path 




3808




 





 





 





 





 





 



   




3809




 





 





 





 





 





 



 B Removes the filename path and returns just the directory path up until but not including 




3810




 





 





 





 





 





 



 the last /. Return just a one char C<< . >> (period string) if there is no directory in the input. 




3811




 





 





 





 





 





 



   




3812




 





 





 





 





 





 



  dirname('/usr/bin/perl')                    # returns '/usr/bin' 




3813




 





 





 





 





 





 



  dirname('perl')                             # returns '.' 




3814




 





 





 





 





 





 



   




3815




 





 





 





 





 





 



 =head2 username 




3816




 





 





 





 





 





 



   




3817




 





 





 





 





 





 



 Returns the current linux/unix username, for example the string root 




3818




 





 





 





 





 





 



   




3819




 





 





 





 





 





 



  print username();                        #just (getpwuid($<))[0] but more readable perhaps 




3820




 





 





 





 





 





 



   




3821




 





 





 





 





 





 



 =cut 




3822




 





 





 





 





 





 



   




3823




8




  
100
  




 




  
8
  



  
1
  




3286



 sub basename { my($f,$s)=(@_,'');$s=quotemeta($s)if!ref($s);$f=~m,^(.*/)?([^/]*?)($s)?$,;$2 } 




 




8





 





 





 





 





25



   




 




8





 





 





 





 





226



   




 




8





 





 





 





 





38



   




3824




2




  
100
  



  
 66
  



  
2
  



  
1
  




438



 sub dirname  { $_[0]=~m,^(.*)/,;defined($1) && length($1) ? $1 : '.' } 




 




2





 





 





 





 





23



   




3825



  
0
  




 





 




  
0
  



  
1
  




0



 sub username { (getpwuid($<))[0] } 




3826




 





 





 





 





 





 



   




3827




 





 





 





 





 





 



 =head2 wipe 




3828




 





 





 





 





 





 



   




3829




 





 





 





 





 





 



 Deletes a file by "wiping" it on the disk. Overwrites the file before deleting. (May not work properly on SSDs) 




3830




 





 





 





 





 





 



   




3831




 





 





 





 





 





 



 B 




3832




 





 





 





 





 





 



 * Arg 1: A filename 




3833




 





 





 





 





 





 



 * Optional arg 2: number of times to overwrite file. Default is 3 if omitted, 0 or undef 




3834




 





 





 





 





 





 



 * Optional arg 3: keep (true/false), wipe() but no delete of file 




3835




 





 





 





 





 





 



   




3836




 





 





 





 





 





 



 B Same as the C (remove file): 1 for success, 0 or false for failure. 




3837




 





 





 





 





 





 



   




3838




 





 





 





 





 





 



 See also: L, L 




3839




 





 





 





 





 





 



   




3840




 





 





 





 





 





 



 =cut 




3841




 





 





 





 





 





 



   




3842




 





 





 





 





 





 



 sub wipe { 




3843




2





 





 




  
2
  



  
1
  




704



   my($file,$times,$keep)=@_; 




3844




2





 




  
100
  




 





 





14



   $times||=3; 




3845




2




  
 50
  



  
 33
  




 





 





82



   croak "ERROR: File $file nonexisting\n" if not -f $file or not -e $file; 




3846




2





 





 





 





 





28



   my $size=-s$file; 




3847




2




  
 50
  




 





 





 





78



   open my $WIFH, '+<', $file or croak "ERROR: Unable to open $file: $!\n"; 




3848




2





 





 





 





 





5



   binmode($WIFH); 




3849




2





 





 





 





 





8



   for(1..$times){ 




3850




4





 





 





 





 





16



     my $block=chr(int(rand(256))) x 1024;#hm 




3851




4





 





 





 





 





10



     for(0..($size/1024)){ 




3852




73





 





 





 





 





521



       seek($WIFH,$_*1024,0); 




3853




73





 





 





 





 





142



       print $WIFH $block; 




3854




 





 





 





 





 





 



     } 




3855




 





 





 





 





 





 



   } 




3856




2





 





 





 





 





30



   close($WIFH); 




3857




2




  
100
  




 





 





 





141



   $keep || unlink($file); 




3858




 





 





 





 





 





 



 } 




3859




 





 





 





 





 





 



   




3860




 





 





 





 





 





 



 =head2 chall 




3861




 





 





 





 





 





 



   




3862




 





 





 





 





 





 



 Does chmod + utime + chown on one or more files. 




3863




 





 





 





 





 





 



   




3864




 





 





 





 





 





 



 Returns the number of files of which those operations was successful. 




3865




 





 





 





 





 





 



   




3866




 





 





 





 





 





 



 Mode, uid, gid, atime and mtime are set from the array ref in the first argument. 




3867




 





 





 





 





 





 



   




3868




 





 





 





 





 





 



 The first argument references an array which is exactly like an array returned from perls internal C -function. 




3869




 





 





 





 





 





 



   




3870




 





 





 





 





 





 



 Example: 




3871




 





 





 





 





 





 



   




3872




 





 





 





 





 





 



  my @stat=stat($filenameA); 




3873




 





 





 





 





 





 



  chall( \@stat,       $filenameB, $filenameC, ... );  # by stat-array 




3874




 





 





 





 





 





 



  chall( $filenameA,   $filenameB, $filenameC, ... );  # by file name 




3875




 





 





 





 





 





 



   




3876




 





 





 





 





 





 



 Copies the chmod, owner, group, access time and modify time from file A to file B and C. 




3877




 





 





 





 





 





 



   




3878




 





 





 





 





 





 



 See C, C, C, C 




3879




 





 





 





 





 





 



   




3880




 





 





 





 





 





 



 =cut 




3881




 





 





 





 





 





 



   




3882




 





 





 





 





 





 



   




3883




 





 





 





 





 





 



 sub chall { 




3884




 





 





 





 





 





 



   my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks ) 




3885




1




  
 50
  




 




  
1
  



  
1
  




28244



     = ref($_[0]) ? @{shift()} : stat(shift()); 




 




1





 





 





 





 





4



   




3886




1





 





 





 





 





2



   my $successful=0; 




3887




1




  
 50
  



  
 33
  




 





 





4



   for(@_){ chmod($mode,$_) && utime($atime,$mtime,$_) && chown($uid,$gid,$_) && $successful++ } 




 




1





 




  
 33
  




 





 





73



   




3888




1





 





 





 





 





3



   return $successful; 




3889




 





 





 





 





 





 



 } 




3890




 





 





 





 





 





 



   




3891




 





 





 





 





 





 



 =head2 makedir 




3892




 





 





 





 





 





 



   




3893




 





 





 





 





 





 



 Input: One or two arguments. 




3894




 





 





 





 





 





 



   




3895




 





 





 





 





 





 



 Works like perls C except that C will create nesessary parent directories if they dont exists. 




3896




 





 





 





 





 





 



   




3897




 





 





 





 





 





 



 First input argument: A directory name (absolute, starting with C< / > or relative). 




3898




 





 





 





 





 





 



   




3899




 





 





 





 





 





 



 Second input argument: (optional) permission bits. Using the normal C<< 0777^umask() >> as the default if no second input argument is provided. 




3900




 





 





 





 





 





 



   




3901




 





 





 





 





 





 



 Example: 




3902




 





 





 





 





 





 



   




3903




 





 





 





 





 





 



  makedir("dirB/dirC") 




3904




 





 





 





 





 





 



   




3905




 





 





 





 





 





 



 ...will create directory C if it does not already exists, to be able to create C inside C. 




3906




 





 





 





 





 





 



   




3907




 





 





 





 





 





 



 Returns true on success, otherwise false. 




3908




 





 





 





 





 





 



   




3909




 





 





 





 





 





 



 C memoizes directories it has checked for existence before (trading memory and for speed). 




3910




 





 





 





 





 





 



 Thus directories removed during running the script is not discovered by makedir. 




3911




 





 





 





 





 





 



   




3912




 





 





 





 





 





 



 See also C<< perldoc -f mkdir >>, C<< man umask >> 




3913




 





 





 





 





 





 



   




3914




 





 





 





 





 





 



 =cut 




3915




 





 





 





 





 





 



   




3916




 





 





 





 





 





 



 our %MAKEDIR; 




3917




 





 





 





 





 





 



   




3918




 





 





 





 





 





 



 sub makedir { 




3919



  
0
  




 





 




  
0
  



  
1
  




0



   my($d,$p,$dd)=@_; 




3920



  
0
  



  
  0
  




 





 





 





0



   $p=0777^umask() if !defined$p; 




3921




 





 





 





 





 





 



   ( 




3922




 





 





 





 





 





 



   $MAKEDIR{$d} or -d$d or mkdir($d,$p) #or croak("mkdir $d, $p") 




3923




 





 





 





 





 





 



   or ($dd)=($d=~m,^(.+)/+([^/]+)$,) and makedir($dd,$p) and mkdir($d,$p) #or die; 




3924



  
0
  



  
  0
  



  
  0
  




 





 





0



   ) and ++$MAKEDIR{$d}; 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




3925




 





 





 





 





 





 



 } 




3926




 





 





 





 





 





 



   




3927




 





 





 





 





 





 



 =head2 md5sum 




3928




 





 





 





 





 





 



   




3929




 





 





 





 





 





 



 B a filename. 




3930




 





 





 





 





 





 



   




3931




 





 





 





 





 





 



 B a string of 32 hexadecimal chars from 0-9 or a-f. 




3932




 





 





 





 





 





 



   




3933




 





 





 





 





 





 



 Example, the md5sum gnu/linux command without options could be implementet like this: 




3934




 





 





 





 





 





 



   




3935




 





 





 





 





 





 



  use Acme::Tools; 




3936




 





 





 





 





 





 



  print eval{ md5sum($_)."  $_\n" } || $@ for @ARGV; 




3937




 





 





 





 





 





 



   




3938




 





 





 





 





 





 



 This sub requires L, which is a core perl-module since 




3939




 





 





 





 





 





 



 version 5.?.?  It does not slurp the files or spawn new processes. 




3940




 





 





 





 





 





 



   




3941




 





 





 





 





 





 



 =cut 




3942




 





 





 





 





 





 



   




3943




 





 





 





 





 





 



 sub md5sum { 




3944




2





 





 




  
2
  



  
1
  




18



   require Digest::MD5; 




3945




2





 





 





 





 





4



   my $fn=shift; 




3946




2




  
100
  




 





 





 





212



   croak "md5sum: $fn is a directory (no md5sum)" if -d $fn; 




3947




1




  
 50
  




 





 





 





34



   open my $FH, '<', $fn or croak "Could not open file $fn for md5sum() $!"; 




3948




1





 





 





 





 





2



   binmode($FH); 




3949




1





 





 





 





 





3



   my $r = eval { Digest::MD5->new->addfile($FH)->hexdigest }; 




 




1





 





 





 





 





19



   




3950




1




  
 50
  




 





 





 





8



   croak "md5sum on $fn failed ($@)\n" if $@; 




3951




1





 





 





 





 





16



   $r; 




3952




 





 





 





 





 





 



 } 




3953




 





 





 





 





 





 



   




3954




 





 





 





 





 





 



 =head2 read_conf 




3955




 





 





 





 





 





 



   




3956




 





 





 





 





 





 



 B A file name or a reference to a string with settings in the format described below. 




3957




 





 





 





 





 





 



   




3958




 





 





 





 





 





 



 B A reference to a hash. This hash will have the settings from the file (or stringref). 




3959




 





 





 





 





 





 



 The hash do not have to be empty beforehand. 




3960




 





 





 





 





 





 



   




3961




 





 





 





 





 





 



 Returns a hash with the settings as in this examples: 




3962




 





 





 





 





 





 



   




3963




 





 





 





 





 





 



  my %conf = read_conf('/etc/your/thing.conf'); 




3964




 





 





 





 





 





 



  print $conf{sectionA}{knobble};  #prints ABC if the file is as shown below 




3965




 





 





 





 





 





 



  print $conf{sectionA}{gobble};   #prints ZZZ, the last gobble 




3966




 





 





 





 





 





 



  print $conf{switch};             #prints OK here as well, unsectioned value 




3967




 





 





 





 





 





 



  print $conf{part2}{password};    #prints oh:no= x 




3968




 





 





 





 





 





 



   




3969




 





 





 





 





 





 



 File use for the above example: 




3970




 





 





 





 





 





 



   




3971




 





 





 





 





 





 



  switch:    OK       #before first section, the '' (empty) section 




3972




 





 





 





 





 





 



  [sectionA] 




3973




 





 





 





 





 





 



  knobble:   ABC 




3974




 





 





 





 





 





 



  gobble:    XYZ      #this gobble is overwritten by the gobble on the next line 




3975




 





 





 





 





 





 



  gobble:    ZZZ 




3976




 





 





 





 





 





 



  [part2] 




3977




 





 





 





 





 





 



  password:  oh:no= x  #should be better 




3978




 





 





 





 





 





 



  text:      { values starting with { continues 




3979




 





 





 





 





 





 



               until reaching a line with } 




3980




 





 





 





 





 





 



   




3981




 





 





 





 





 





 



 Everything from # and behind is regarded comments and ignored. Comments can be on any line. 




3982




 





 





 





 





 





 



 To keep a # char, put a \ in front of it. 




3983




 





 





 





 





 





 



   




3984




 





 





 





 





 





 



 A C< : > or C< = > separates keys and values.  Spaces at the beginning or end of lines are 




3985




 





 





 





 





 





 



 ignored (after removal of #comments), as are any spaces before and after : and = separators. 




3986




 





 





 





 





 





 



   




3987




 





 





 





 





 





 



 Empty lines or lines with no C< : > or C< = > is also ignored. Keys and values can contain 




3988




 





 





 





 





 





 



 internal spaces and tabs, but not at the beginning or end. 




3989




 





 





 





 





 





 



   




3990




 





 





 





 





 





 



 Multi-line values must start and end with { and }. Using { and } keep spaces at the start 




3991




 





 





 





 





 





 



 or end in both one-line and multi-line values. 




3992




 





 





 





 





 





 



   




3993




 





 





 





 





 





 



 Sections are marked with C<< [sectionname] >>.  Section names, keys and values is case 




3994




 





 





 





 





 





 



 sensitive. C above the first section or below and empty C<< [] >> is placed 




3995




 





 





 





 





 





 



 both in the empty section in the returned hash and as top level key/values. 




3996




 





 





 





 





 





 



   




3997




 





 





 





 





 





 



 C can be a simpler alternative to the core module L which has 




3998




 





 





 





 





 





 



 its own hassles. 




3999




 





 





 





 





 





 



   




4000




 





 





 





 





 





 



  $Acme::Tools::Read_conf_empty_section=1;        #default 0 (was 1 in version 0.16) 




4001




 





 





 





 





 





 



  my %conf = read_conf('/etc/your/thing.conf'); 




4002




 





 





 





 





 





 



  print $conf{''}{switch};                        #prints OK with the file above 




4003




 





 





 





 





 





 



  print $conf{switch};                            #prints OK here as well 




4004




 





 





 





 





 





 



   




4005




 





 





 





 





 





 



 =cut 




4006




 





 





 





 





 





 



   




4007




 





 





 





 





 





 



 our $Read_conf_empty_section=0; 




4008




 





 





 





 





 





 



 sub read_conf { 




4009




3





 





 




  
3
  



  
1
  




18



   my($fn,$hr)=(@_,{}); 




4010




3




  
100
  




 





 





 





14



   my $conf=ref($fn)?$$fn:readfile($fn); 




4011




3





 





 





 





 





101



   $conf=~s,\s*(?




4012




3





 





 





 





 





32



   my($section,@l)=('',split"\n",$conf); 




4013




3





 





 





 





 





12



   while(@l) { 




4014




63





 





 





 





 





93



     my $l=shift@l; 




4015




63




  
100
  




 





 





 





330



     if( $l=~/^\s*\[\s*(.*?)\s*\]/ ) { 




 




 




  
100
  




 





 





 





 



   




4016




12





 





 





 





 





22



       $section=$1; 




4017




12





 




  
100
  




 





 





68



       $$hr{$1}||={}; 




4018




 





 





 





 





 





 



     } 




4019




 





 





 





 





 





 



     elsif( $l=~/^\s*([^\:\=]+)[:=]\s*(.*?)\s*$/ ) { 




4020




33





 




  
 66
  



  
33
  




 





108



       my $ml=sub{my$v=shift;$v.="\n".shift@l while $v=~/^\{[^\}]*$/&&@l;$v=~s/^\{(.*)\}\s*$/$1/s;$v=~s,\\#,#,g;$v}; 




 




33





 





 





 





 





71



   




 




33





 





 





 





 





168



   




 




33





 





 





 





 





68



   




 




33





 





 





 





 





52



   




 




33





 





 





 





 





60



   




4021




33





 





 





 





 





71



       my $v=&$ml($2); 




4022




33




  
100
  



  
 66
  




 





 





145



       $$hr{$section}{$1}=$v if length($section) or $Read_conf_empty_section; 




4023




33




  
100
  




 





 





 





175



       $$hr{$1}=$v if !length($section); 




4024




 





 





 





 





 





 



     } 




4025




 





 





 





 





 





 



   } 




4026




3





 





 





 





 





25



   %$hr; 




4027




 





 





 





 





 





 



 } 




4028




 





 





 





 





 





 



 #  my $incfn=sub{return $1 if $_[0]=~m,^(/.+),;my$f=$fn;$f=~s,[^/]+$,$_[0],;$f}; 




4029




 





 





 





 





 





 



 #    s,]+)>,"".readfile(&$incfn($1)),eg; #todo 




4030




 





 





 





 





 





 



   




4031




 





 





 





 





 





 



   




4032




 





 





 





 





 





 



 =head2 openstr 




4033




 





 





 





 





 





 



   




4034




 





 





 





 





 





 



                                             # returned from openstr: 




4035




 





 





 





 





 





 



   open my $FH, openstr("fil.txt")  or die;  # fil.txt 




4036




 





 





 





 





 





 



   open my $FH, openstr("fil.gz")   or die;  # zcat fil.gz | 




4037




 





 





 





 





 





 



   open my $FH, openstr("fil.bz2")  or die;  # bzcat fil.bz2 | 




4038




 





 





 





 





 





 



   open my $FH, openstr("fil.xz")   or die;  # xzcat fil.xz | 




4039




 





 





 





 





 





 



   open my $FH, openstr(">fil.txt") or die;  # > fil.txt 




4040




 





 





 





 





 





 



   open my $FH, openstr(">fil.gz")  or die;  # | gzip > fil.gz 




4041




 





 





 





 





 





 



   open my $FH, openstr(">fil.bz2") or die;  # | bzip2 > fil.bz2 




4042




 





 





 





 





 





 



   open my $FH, openstr(">fil.xz")  or die;  # | xz    > fil.bz2 




4043




 





 





 





 





 





 



   




4044




 





 





 





 





 





 



 Environment variable PATH is used. So in the examples above, /bin/gzip 




4045




 





 





 





 





 





 



 is returned instead of gzip if /bin is the first directory in 




4046




 





 





 





 





 





 



 $ENV{PATH} containing an executable file gzip. Dirs /usr/bin, /bin and 




4047




 





 





 





 





 





 



 /usr/local/bin is added to PATH in openstr(). They are checked even if 




4048




 





 





 





 





 





 



 PATH is empty. 




4049




 





 





 





 





 





 



   




4050




 





 





 





 





 





 



 =cut 




4051




 





 





 





 





 





 



   




4052




 





 





 





 





 





 



 our @Openstrpath=(grep$_,split(":",$ENV{PATH}),qw(/usr/bin /bin /usr/local/bin)); 




4053




 





 





 





 





 





 



 sub openstr { 




4054




14





 





 




  
14
  



  
1
  




4221



   my($fn,$ext)=(shift()=~/^(.*?(?:\.(t?gz|bz2|xz))?)$/i); 




4055




14




  
100
  




 





 





 





389



   return $fn if !$ext; 




4056




6




  
 50
  




 




  
6
  




 





42



   my $prog=sub{@Openstrpath or return $_[0];(grep -x$_, map "$_/$_[0]", @Openstrpath)[0] or die}; 




 




6




  
 50
  




 





 





 





26



   




 




6





 





 





 





 





108929



   




4057




 





 





 





 





 





 



   $fn =~ /^\s*>/ 




4058




 





 





 





 





 





 



       ?  "| ".(&$prog({qw/tgz gzip gz gzip bz2 bzip2 xz xz/   }->{lc($ext)})).$fn 




4059




6




  
100
  




 





 





 





89



       :        &$prog({qw/tgz zcat gz zcat bz2 bzcat xz xzcat/}->{lc($ext)})." $fn |"; 




4060




 





 





 





 





 





 



 } 




4061




 





 





 





 





 





 



   




4062




 





 





 





 





 





 



 =head1 TIME FUNCTIONS 




4063




 





 





 





 





 





 



   




4064




 





 





 





 





 





 



 =head2 tms - timestring, works somewhat like the Gnu/Linux C command and Oracle's C 




4065




 





 





 





 





 





 



   




4066




 





 





 





 





 





 



 Converts timestamps to more readable forms of time strings. 




4067




 





 





 





 





 





 



   




4068




 





 





 





 





 





 



 Converts seconds since I and time strings on the form C to other forms. 




4069




 





 





 





 





 





 



   




4070




 





 





 





 





 





 



 B One, two or three arguments. 




4071




 





 





 





 





 





 



   




4072




 





 





 





 





 





 



 B A format string. 




4073




 





 





 





 





 





 



   




4074




 





 





 





 





 





 



 B An epock C number or a time 




4075




 





 





 





 





 





 



 string of the form YYYYMMDD-HH24:MI:SS or YYYYMMDDTHH:MI:SS or 




4076




 





 





 





 





 





 



 YYYY-MM-DDTHH:MI:SS (in which T is litteral and HH is the 24-hour 




4077




 





 





 





 





 





 



 version of hours) or YYYYMMDD. Uses the current C if the 




4078




 





 





 





 





 





 



 second argument is missing. 




4079




 





 





 





 





 





 



   




4080




 





 





 





 





 





 



 TODO: Formats with % as in C (C<%Y%m%d> and so on) 




4081




 





 





 





 





 





 



   




4082




 





 





 





 





 





 



 B True or false. If true and first argument 




4083




 





 





 





 





 





 



 is eight digits: Its interpreted as a date like YYYYMMDD time string, 




4084




 





 





 





 





 





 



 not an epoch time.  If true and first argument is six digits its 




4085




 





 





 





 





 





 



 interpreted as a date like DDMMYY (not YYMMDD!). 




4086




 





 





 





 





 





 



   




4087




 





 





 





 





 





 



 B a date or clock string on the wanted form. 




4088




 





 





 





 





 





 



   




4089




 





 





 





 





 





 



 B 




4090




 





 





 





 





 





 



   




4091




 





 





 





 





 





 



 Prints C<< 3. july 1997 >> if thats the dato today: 




4092




 





 





 





 





 





 



   




4093




 





 





 





 





 





 



   perl -MAcme::Tools -le 'print timestr("D. month YYYY")' 




4094




 





 





 





 





 





 



   




4095




 





 





 





 





 





 



   print tms("HH24:MI");              # prints 23:55 if thats the time now 




4096




 





 





 





 





 





 



   tms("HH24:MI",time());             # ...same,since time() is the default 




4097




 





 





 





 





 





 



   tms("HH:MI",time()-5*60);          # 23:50 if that was the time 5 minutes ago 




4098




 





 





 





 





 





 



   tms("HH:MI",time()-5*60*60);       # 18:55 if thats the time 5 hours ago 




4099




 





 





 





 





 





 



   tms("Day Month Dth YYYY HH:MI");   # Saturday July 1st 2004 23:55    (big S, big J) 




4100




 





 





 





 





 





 



   tms("Day D. Month YYYY HH:MI");    # Saturday 8. July 2004 23:55     (big S, big J) 




4101




 





 





 





 





 





 



   tms("DAY D. MONTH YYYY HH:MI");    # SATURDAY 8. JULY 2004 23:55     (upper) 




4102




 





 





 





 





 





 



   tms("dy D. month YYYY HH:MI");     # sat 8. july 2004 23:55          (small s, small j) 




4103




 





 





 





 





 





 



   tms("Dy DD. MON YYYY HH12:MI am"); # Sat 08. JUL 2004 11:55 pm       (HH12, am becomes pm if after 12) 




4104




 





 





 





 





 





 



   tms("DD-MON-YYYY");                # 03-MAY-2004                     (mon, english) 




4105




 





 





 





 





 





 



   




4106




 





 





 





 





 





 



 The following list of codes in the first argument will be replaced: 




4107




 





 





 





 





 





 



   




4108




 





 





 





 





 





 



   YYYY    Year, four digits 




4109




 





 





 





 





 





 



   YY      Year, two digits, i.e. 04 instead of 2004 




4110




 





 





 





 





 





 



   yyyy    Year, four digits, but nothing if its the current year 




4111




 





 





 





 





 





 



   YYYY|HH:MI  Year if its another year than the current, a time in hours and minutes elsewise 




4112




 





 





 





 





 





 



   MM      Month, two digits. I.e. 08 for August 




4113




 





 





 





 





 





 



   DD      Day of month, two digits. I.e. 01 (not 1) for the first day in a month 




4114




 





 





 





 





 





 



   D       Day of month, one digit. I.e. 1 (not 01) 




4115




 





 





 





 





 





 



   HH      Hour. From 00 to 23. 




4116




 





 





 





 





 





 



   HH24    Same as HH. 




4117




 





 





 





 





 





 



   HH12    12 becomes 12 (never 00), 13 becomes 01, 14 02 and so on. 




4118




 





 





 





 





 





 



           Note: 00 after midnight becomes 12 (am). Tip: always include the code 




4119




 





 





 





 





 





 



           am in a format string that uses HH12. 




4120




 





 





 





 





 





 



   MI      Minutt. Fra 00 til 59. 




4121




 





 





 





 





 





 



   SS      Sekund. Fra 00 til 59. 




4122




 





 





 





 





 





 



   am      Becomes am or pm 




4123




 





 





 





 





 





 



   pm      Same 




4124




 





 





 





 





 





 



   AM      Becomes AM or PM (upper case) 




4125




 





 





 





 





 





 



   PM      Same 




4126




 





 





 





 





 





 



   




4127




 





 





 





 





 





 



   Month   The full name of the month in English from January to December 




4128




 





 





 





 





 





 



   MONTH   Same in upper case (JANUARY) 




4129




 





 





 





 





 





 



   month   Same in lower case (january) 




4130




 





 





 





 





 





 



   Mont    Jan Feb Mars Apr May June July Aug Sep Oct Nov Dec 




4131




 





 





 





 





 





 



   Mont.   Jan. Feb. Mars Apr. May June July Aug. Sep. Oct. Nov. Dec. (always four chars) 




4132




 





 





 





 





 





 



   Mon     Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec            (always three chars) 




4133




 





 





 





 





 





 



   




4134




 





 





 





 





 





 



   Day     The full name of the weekday. Sunday to Saturday 




4135




 





 





 





 





 





 



   Dy      Three letters: Sun Mon Tue Wed Thu Fri Sat 




4136




 





 





 





 





 





 



   DAY     Upper case 




4137




 





 





 





 





 





 



   DY      Upper case 




4138




 





 





 





 





 





 



   Dth     1st 2nd 3rd 4th 5th ... 11th 12th ... 20th 21st 22nd 23rd 24th ... 30th 31st 




4139




 





 





 





 





 





 



   




4140




 





 





 





 





 





 



   WW      Week number of the year 01-53 according to the ISO8601-definition (which most countries uses) 




4141




 





 





 





 





 





 



   WWUS    Week number of the year 01-53 according to the most used definition in the USA. 




4142




 





 





 





 





 





 



           Other definitions also exists. 




4143




 





 





 





 





 





 



   




4144




 





 





 





 





 





 



   epoch   Converts a time string from YYYYMMDD-HH24:MI:SS, YYYYMMDD-HH24:MI:SS, YYYYMMDDTHH:MI:SS, 




4145




 





 





 





 





 





 



           YYYY-MM-DDTHH:MI:SS or YYYYMMDD to the number of seconds since January 1st 1970. 




4146




 





 





 





 





 





 



           Commonly known as the Unix epoch. 




4147




 





 





 





 





 





 



   




4148




 





 





 





 





 





 



   JDN     Julian day number. Integer. The number of days since the day starting at noon on January 1 4713 BC 




4149




 





 





 





 





 





 



   JD      Same as JDN but a float accounting for the time of day 




4150




 





 





 





 





 





 



   




4151




 





 





 





 





 





 



 TODO:  sub smt() (tms backward... or something better named, converts the other way) 




4152




 





 





 





 





 





 



        As to_date and to_char in Oracle. Se maybe L instead 




4153




 





 





 





 





 





 



   




4154




 





 





 





 





 





 



 B (optional) Is_date. False|true, default false. If true, the second argument is 




4155




 





 





 





 





 





 



 interpreted as a date of the form YYYYMMDD, not as a number of seconds since epoch (January 1st 1970). 




4156




 





 





 





 





 





 



   




4157




 





 





 





 





 





 



 =cut 




4158




 





 





 





 





 





 



   




4159




 





 





 





 





 





 



 #Se også L og L 




4160




 





 





 





 





 





 



   




4161




 





 





 





 





 





 



 our $Tms_pattern; 




4162




 





 





 





 





 





 



 our %Tms_str= 




4163




 





 





 





 





 





 



 	  ('MÅNED' => [4, 'JANUAR','FEBRUAR','MARS','APRIL','MAI','JUNI','JULI', 




4164




 





 





 





 





 





 



 		          'AUGUST','SEPTEMBER','OKTOBER','NOVEMBER','DESEMBER' ], 




4165




 





 





 





 





 





 



 	   'Måned' => [4, 'Januar','Februar','Mars','April','Mai','Juni','Juli', 




4166




 





 





 





 





 





 



 		          'August','September','Oktober','November','Desember'], 




4167




 





 





 





 





 





 



 	   'måned' => [4, 'januar','februar','mars','april','mai','juni','juli', 




4168




 





 





 





 





 





 



 		          'august','september','oktober','november','desember'], 




4169




 





 





 





 





 





 



 	   'MÅNE.' => [4, 'JAN.','FEB.','MARS','APR.','MAI','JUNI','JULI','AUG.','SEP.','OKT.','NOV.','DES.'], 




4170




 





 





 





 





 





 



 	   'Måne.' => [4, 'Jan.','Feb.','Mars','Apr.','Mai','Juni','Juli','Aug.','Sep.','Okt.','Nov.','Des.'], 




4171




 





 





 





 





 





 



 	   'måne.' => [4, 'jan.','feb.','mars','apr.','mai','juni','juli','aug.','sep.','okt.','nov.','des.'], 




4172




 





 





 





 





 





 



 	   'MÅNE'  => [4, 'JAN','FEB','MARS','APR','MAI','JUNI','JULI','AUG','SEP','OKT','NOV','DES'], 




4173




 





 





 





 





 





 



 	   'Måne'  => [4, 'Jan','Feb','Mars','Apr','Mai','Juni','Juli','Aug','Sep','Okt','Nov','Des'], 




4174




 





 





 





 





 





 



 	   'måne'  => [4, 'jan','feb','mars','apr','mai','juni','juli','aug','sep','okt','nov','des'], 




4175




 





 





 





 





 





 



 	   'MÅN'   => [4, 'JAN','FEB','MAR','APR','MAI','JUN','JUL','AUG','SEP','OKT','NOV','DES'], 




4176




 





 





 





 





 





 



 	   'Mån'   => [4, 'Jan','Feb','Mar','Apr','Mai','Jun','Jul','Aug','Sep','Okt','Nov','Des'], 




4177




 





 





 





 





 





 



 	   'mån'   => [4, 'jan','feb','mar','apr','mai','jun','jul','aug','sep','okt','nov','des'], 




4178




 





 





 





 





 





 



 	   'MONTH' => [4, 'JANUARY','FEBRUARY','MARCH','APRIL','MAY','JUNE','JULY', 




4179




 





 





 





 





 





 



 		          'AUGUST','SEPTEMBER','OCTOBER','NOVEMBER','DECEMBER'], 




4180




 





 





 





 





 





 



 	   'Month' => [4, 'January','February','March','April','May','June','July', 




4181




 





 





 





 





 





 



 		          'August','September','October','November','December'], 




4182




 





 





 





 





 





 



 	   'month' => [4, 'january','february','march','april','may','june','july', 




4183




 





 





 





 





 





 



 		          'august','september','october','november','december'], 




4184




 





 





 





 





 





 



 	   'MONT.' => [4, 'JAN.','FEB.','MAR.','APR.','MAY','JUNE','JULY','AUG.','SEP.','OCT.','NOV.','DEC.'], 




4185




 





 





 





 





 





 



 	   'Mont.' => [4, 'Jan.','Feb.','Mar.','Apr.','May','June','July','Aug.','Sep.','Oct.','Nov.','Dec.'], 




4186




 





 





 





 





 





 



 	   'mont.' => [4, 'jan.','feb.','mar.','apr.','may','june','july','aug.','sep.','oct.','nov.','dec.'], 




4187




 





 





 





 





 





 



 	   'MONT'  => [4, 'JAN','FEB','MAR','APR','MAY','JUNE','JULY','AUG','SEP','OCT','NOV','DEC'], 




4188




 





 





 





 





 





 



 	   'Mont'  => [4, 'Jan','Feb','Mar','Apr','May','June','July','Aug','Sep','Oct','Nov','Dec'], 




4189




 





 





 





 





 





 



 	   'mont'  => [4, 'jan','feb','mar','apr','may','june','july','aug','sep','oct','nov','dec'], 




4190




 





 





 





 





 





 



 	   'MON'   => [4, 'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'], 




4191




 





 





 





 





 





 



 	   'Mon'   => [4, 'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'], 




4192




 





 





 





 





 





 



 	   'mon'   => [4, 'jan','feb','mar','apr','may','jun','jul','aug','sep','oct','nov','dec'], 




4193




 





 





 





 





 





 



 	   'DAY'   => [6, 'SUNDAY','MONDAY','TUESDAY','WEDNESDAY','THURSDAY','FRIDAY','SATURDAY'], 




4194




 





 





 





 





 





 



 	   'Day'   => [6, 'Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'], 




4195




 





 





 





 





 





 



 	   'day'   => [6, 'sunday','monday','tuesday','wednesday','thursday','friday','saturday'], 




4196




 





 





 





 





 





 



 	   'DY'    => [6, 'SUN','MON','TUE','WED','THU','FRI','SAT'], 




4197




 





 





 





 





 





 



 	   'Dy'    => [6, 'Sun','Mon','Tue','Wed','Thu','Fri','Sat'], 




4198




 





 





 





 





 





 



 	   'dy'    => [6, 'sun','mon','tue','wed','thu','fri','sat'], 




4199




 





 





 





 





 





 



 	   'DAG'   => [6, 'SØNDAG','MANDAG','TIRSDAG','ONSDAG','TORSDAG','FREDAG','LØRDAG'], 




4200




 





 





 





 





 





 



 	   'Dag'   => [6, 'Søndag','Mandag','Tirsdag','Onsdag','Torsdag','Fredag','Lørdag'], 




4201




 





 





 





 





 





 



 	   'dag'   => [6, 'søndag','mandag','tirsdag','onsdag','torsdag','fredag','lørdag'], 




4202




 





 





 





 





 





 



 	   'DG'    => [6, 'SØN','MAN','TIR','ONS','TOR','FRE','LØR'], 




4203




 





 





 





 





 





 



 	   'Dg'    => [6, 'Søn','Man','Tir','Ons','Tor','Fre','Lør'], 




4204




 





 





 





 





 





 



 	   'dg'    => [6, 'søn','man','tir','ons','tor','fre','lør'], 




4205




 





 





 





 





 





 



 	   ); 




4206




 





 





 





 





 





 



 my $_tms_inited=0; 




4207




 





 





 





 





 





 



 sub tms_init { 




4208




1




  
 50
  




 




  
1
  



  
0
  




7



   return if $_tms_inited++; 




4209




1





 





 





 





 





5



   for(qw(MAANED Maaned maaned MAAN Maan maan),'MAANE.','Maane.','maane.'){ 




4210




9





 





 





 





 





36



     $Tms_str{$_}=$Tms_str{replace($_,"aa","å","AA","Å")}; 




4211




 





 





 





 





 





 



   } 




4212




45





 





 





 





 





121



   $Tms_pattern=join("|",map{quotemeta($_)} 




4213




1





 





 





 





 





23



 			       sort{length($b)<=>length($a)} 




 




197





 





 





 





 





402



   




4214




 





 





 





 





 





 



 			       keys %Tms_str); 




4215




 





 





 





 





 





 



   #uten sort kan "måned" bli "mared", fordi "mån"=>"mar" 




4216




 





 





 





 





 





 



 } 




4217




 





 





 





 





 





 



   




4218




 





 





 




  
0
  



  
0
  




 



 sub totime { 




4219




 





 





 





 





 





 



   




4220




 





 





 





 





 





 



 } 




4221




 





 





 





 





 





 



   




4222




 





 





 





 





 





 



 sub date_ok { 




4223



  
0
  




 





 




  
0
  



  
0
  




0



   my($y,$m,$d)=@_; 




4224



  
0
  



  
  0
  



  
  0
  




 





 





0



   return date_ok($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/; 




4225



  
0
  



  
  0
  




 





 





 





0



   return 0 if $y!~/^\d\d\d\d$/; 




4226



  
0
  



  
  0
  



  
  0
  




 





 





0



   return 0 if $m<1||$m>12||$d<1||$d>(31,$y%4||$y%100==0&&$y%400?28:29,31,30,31,30,31,31,30,31,30,31)[$m-1]; 




 




 




  
  0
  



  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




4227



  
0
  




 





 





 





 





0



   return 1; 




4228




 





 





 





 





 





 



 } 




4229




 





 





 





 





 





 



   




4230




 





 





 





 





 





 



 sub weeknum { 




4231



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



   return weeknum(tms('YYYYMMDD')) if @_<1; 




4232



  
0
  



  
  0
  



  
  0
  




 





 





0



   return weeknum($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/; 




4233



  
0
  




 





 





 





 





0



   my($year,$month,$day)= @_; 




4234



  
0
  




 





 





 





 





0



   eval{ 




4235



  
0
  



  
  0
  




 





 





 





0



     if(@_<2){ 




 




 




  
  0
  




 





 





 





 



   




4236



  
0
  



  
  0
  




 





 





 





0



       if($year=~/^\d{8}$/) { ($year,$month,$day)=unpack("A4A2A2",$year) } 




 



  
0
  



  
  0
  




 





 





 





0



   




4237



  
0
  




 





 





 





 





0



       elsif($year>99999999){ ($year,$month,$day)=(localtime($year))[5,4,3]; $year+=1900; $month++ } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




4238



  
0
  




 





 





 





 





0



       else {die} 




4239




 





 





 





 





 





 



     } 




4240



  
0
  




 





 





 





 





0



     elsif(@_!=3){croak} 




4241



  
0
  



  
  0
  




 





 





 





0



     croak if !date_ok(sprintf("%04d%02d%02d",$year,$month,$day)); 




4242




 





 





 





 





 





 



   }; 




4243



  
0
  



  
  0
  




 





 





 





0



   croak "ERROR: Wrong args Acme::Tools::weeknum(".join(",",@_).")" if $@; 




4244




28





 





 




  
28
  




 





23013



   use integer;#heltallsdivisjon 




 




28





 





 





 





 





303



   




 




28





 





 





 





 





158



   




4245



  
0
  




 





 





 





 





0



   my $y=$year+4800-(14-$month)/12; 




4246



  
0
  




 





 





 





 





0



   my $j=$day+(153*($month+(14-$month)/12*12-3)+2)/5+365*$y+$y/4-$y/100+$y/400-32045; 




4247



  
0
  




 





 





 





 





0



   my $d=($j+31741-$j%7)%146097%36524%1461; 




4248



  
0
  




 





 





 





 





0



   return (($d-$d/1460)%365+$d/1460)/7+1; 




4249




 





 





 





 





 





 



 } 




4250




 





 





 





 





 





 



   




4251




 





 





 





 





 





 



 sub tms { 




4252




40




  
 50
  



  
 66
  



  
40
  



  
1
  




56004



   return undef if @_>1 and not defined $_[1]; #time=undef => undef 




4253




40




  
100
  




 





 





 





107



   if(@_==1){ 




4254




2





 





 





 





 





15



     my @lt=localtime(); 




4255




2




  
 50
  




 





 





 





13



     $_[0] eq 'YYYY'     and return 1900+$lt[5]; 




4256




2




  
 50
  




 





 





 





9



     $_[0] eq 'YYYYMMDD' and return sprintf("%04d%02d%02d",1900+$lt[5],1+$lt[4],$lt[3]);  




4257




2




  
100
  



  
 66
  




 





 





56



     $_[0] =~ $Re_isnum  and @lt=localtime($_[0]) and return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]);  




4258




 





 





 





 





 





 



   } 




4259




39





 





 





 





 





72



   my($format,$time,$is_date)=@_; 




4260




39




  
100
  




 





 





 





96



   $time=time_fp() if !defined$time; 




4261




39




  
100
  



  
100
  




 





 





326



   ($time,$format)=($format,$time) if @_>=2 and $format=~/^[\d+\:\-\.]+$/; #swap /hm/ 




4262




39





 





 





 





 





203



   my @lt=localtime($time); 




4263




 





 





 





 





 





 



   #todo? $is_date=0 if $time=~s/^\@(\-?\d)/$1/; #@n where n is sec since epoch makes it clear that its not a formatted, as in `date` 




4264




 





 





 





 





 





 



   #todo? date --date='TZ="America/Los_Angeles" 09:00 next Fri' #`info date` 




4265




 





 





 





 





 





 



   #      Fri Nov 13 18:00:00 CET 2015 




4266




 





 





 





 





 





 



   #date --date="next Friday"  #--date or -d 




4267




 





 





 





 





 





 



   #date --date="last friday" 




4268




 





 





 





 





 





 



   #date --date="2 days ago" 




4269




 





 





 





 





 





 



   #date --date="yesterday" #or tomorrow 




4270




 





 





 





 





 





 



   #date --date="-1 day"  #date --date='10 week' 




4271




 





 





 





 





 





 



   




4272




39




  
 50
  




 





 





 





102



   if( $is_date ){ 




4273



  
0
  



  
  0
  




 




  
0
  




 





0



     my $yy2c=sub{10+$_[0]>$lt[5]%100?"20":"19"}; #hm 10+ 




 



  
0
  




 





 





 





 





0



   




4274



  
0
  



  
  0
  




 





 





 





0



     $time=totime(&$yy2c($1)."$1$2$3")."000000" if $time=~/^(\d\d)(\d\d)(\d\d)$/; 




4275



  
0
  



  
  0
  




 





 





 





0



     $time=totime("$1$2${3}000000")             if $time=~/^((?:18|19|20)\d\d)(\d\d)(\d\d)$/; #hm 18-20? 




4276




 





 





 





 





 





 



   } 




4277




 





 





 





 





 





 



   else { 




4278




39




  
 50
  




 





 





 





141



     $time = yyyymmddhh24miss_time("$1$2$3$4$5$6") #yyyymmddhh24miss_time ??? 




4279




 





 





 





 





 





 



       if $time=~/^((?:19|20|18)\d\d)          #yyyy 




4280




 





 





 





 





 





 



                   (0[1-9]|1[012])             #mm 




4281




 





 





 





 





 





 



                   (0[1-9]|[12]\d|3[01]) \-?   #dd 




4282




 





 





 





 





 





 



                   ([01]\d|2[0-3])       \:?   #hh24 




4283




 





 





 





 





 





 



                   ([0-5]\d)             \:?   #mi 




4284




 





 





 





 





 





 



                   ([0-5]\d)             $/x;  #ss 




4285




 





 





 





 





 





 



   } 




4286




39




  
100
  




 





 





 





78



   tms_init() if !$_tms_inited; 




4287




39




  
100
  




 





 





 





108



   return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]) if !$format; 




4288




38





 





 





 





 





463



   my %p=('%'=>'%', 




4289




 





 





 





 





 





 



 	 a=>'Dy', 




4290




 





 





 





 





 





 



 	 A=>'Day', 




4291




 





 





 





 





 





 



 	 b=>'Mon', 




4292




 





 





 





 





 





 



 	 b=>'Month', 




4293




 





 





 





 





 





 



 	 c=>'Dy Mon D HH:MI:SS YYYY', 




4294




 





 





 





 





 





 



 	 C=>'CC', 




4295




 





 





 





 





 





 



 	 d=>'DD', 




4296




 





 





 





 





 





 



 	 D=>'MM/DD/YY', 




4297




 





 





 





 





 





 



 	 e=>'D', 




4298




 





 





 





 





 





 



 	 F=>'YYYY-MM-DD', 




4299




 





 





 





 





 





 



         #G=>'',  




4300




 





 





 





 





 





 



 	 h=>'Month', H=>'HH24', I=>'HH12', 




4301




 





 





 





 





 





 



 	 j=>'DoY', #day of year 




4302




 





 





 





 





 





 



 	 k=>'H24', _H=>'H24', 




4303




 





 





 





 





 





 



 	 l=>'H12', _I=>'H12', 




4304




 





 





 





 





 





 



 	 m=>'MM', M=>'MI', 




4305




 





 





 





 





 





 



 	 n=>"\n", 




4306




 





 





 





 





 





 



 	#N=>'NS', #sprintf%09d,1e9*(time_fp()-time()) #000000000..999999999 




4307




 





 





 





 





 





 



 	 p=>'AM', #AM|PM upper (yes, opposite: date +%H%M%S%P%p) 




4308




 





 





 





 





 





 



 	 P=>'am', #am|pm lower 




4309




 





 





 





 





 





 



 	 S=>'SS', 




4310




 





 





 





 





 





 



 	 t=>"\t", 




4311




 





 





 





 





 





 



 	 T=>'HH24:MI:SS', 




4312




 





 





 





 





 





 



 	 u=>'DoW',  #day of week 1..7, 1=mon 7=sun 




4313




 





 





 





 





 





 



 	 w=>'DoW0', #day of week 0..6, 1=mon 0=sun 




4314




 





 





 





 





 





 



 	#U=>'WoYs', #week num of year 00..53, sunday as first day of week 




4315




 





 





 





 





 





 



 	#V=>'UKE',  #ISO week num of year 01..53, monday as first day of week 




4316




 





 





 





 





 





 



 	#W=>'WoYm', #week num of year 00..53, monday as first day of week, not ISO! 




4317




 





 





 





 





 





 



 	#x=>$ENV{locale's date representation}, #e.g. MM/DD/YY 




4318




 





 





 





 





 





 



 	#X=>$ENV{locale's time representation}, #e.g. HH/MI/SS 




4319




 





 





 





 





 





 



 	 y=>'YY', 




4320




 





 





 





 





 





 



 	 Y=>'YYYY', 




4321




 





 





 





 





 





 



 	#z=>'TZHHMI', #time zone hour minute e.g. -0430 




4322




 





 





 





 





 





 



 	#':z'=>'TZHH:MI', 




4323




 





 





 





 





 





 



 	#'::z'=>'TZHH:MI:SS', 




4324




 





 





 





 





 





 



 	#':::z'=>'TZ', #number of :'s necessary precision, e.g. -02 or +03:30 




4325




 





 





 





 





 





 



 	#Z=>'TZN', #e.g. CET, EDT, ... 




4326




 





 





 





 





 





 



       ); 




4327




38





 





 





 





 





260



   my $pkeys=join"|",keys%p; 




4328




38





 





 





 





 





1641



   $format=~s,\%($pkeys),$p{$1},g; 




4329




38





 





 





 





 





459



   $format=~s/($Tms_pattern)/$Tms_str{$1}[1+$lt[$Tms_str{$1}[0]]]/g; 




4330




38





 





 





 





 





92



   $format=~s/YYYY              / 1900+$lt[5]                    /gxe; 




 




13





 





 





 





 





44



   




4331




38




  
  0
  




 





 





 





70



   $format=~s/(\s?)yyyy         / $lt[5]==(localtime)[5]?"":$1.(1900+$lt[5])/gxe; 




 



  
0
  




 





 





 





 





0



   




4332




38





 





 





 





 





65



   $format=~s/YY                / sprintf("%02d",$lt[5]%100)     /gxei; 




 




1





 





 





 





 





5



   




4333




38





 





 





 





 





67



   $format=~s|CC                | sprintf("%02d",(1900+$lt[5])/100) |gxei; 




 




2





 





 





 





 





10



   




4334




38





 





 





 





 





59



   $format=~s/MM                / sprintf("%02d",$lt[4]+1)       /gxe; 




 




5





 





 





 





 





25



   




4335




38





 





 





 





 





56



   $format=~s/mm                / sprintf("%d",$lt[4]+1)         /gxe; 




 



  
0
  




 





 





 





 





0



   




4336




38





 





 





 





 





57



   $format=~s,M/                ,               ($lt[4]+1).'/'   ,gxe; 




 




2





 





 





 





 





7



   




4337




38





 





 





 





 





52



   $format=~s,/M                ,           '/'.($lt[4]+1)       ,gxe; 




 




1





 





 





 





 





4



   




4338




38





 





 





 





 





62



   $format=~s/DD                / sprintf("%02d",$lt[3])         /gxe; 




 




6





 





 





 





 





25



   




4339




38





 





 





 





 





110



   $format=~s/d0w|dow0          / $lt[6]                         /gxei; 




 




4





 





 





 





 





11



   




4340




38




  
100
  




 





 





 





67



   $format=~s/dow               / $lt[6]?$lt[6]:7                /gxei; 




 




2





 





 





 





 





8



   




4341




38





 





 





 





 





81



   $format=~s/d0y|doy0          / $lt[7]                         /gxei; #0-364 (365 leap) 




 




2





 





 





 





 





7



   




4342




38





 





 





 





 





117



   $format=~s/doy               / $lt[7]+1                       /gxei; #1-365 (366 leap) 




 




1





 





 





 





 





4



   




4343




38





 





 





 





 





98



   $format=~s/D(?![AaGgYyEeNn]) / $lt[3]                         /gxe; #EN pga desember og wednesday 




 




5





 





 





 





 





15



   




4344




38





 





 





 





 





55



   $format=~s/dd                / sprintf("%d",$lt[3])           /gxe; 




 



  
0
  




 





 





 





 





0



   




4345




38




  
100
  



  
 50
  




 





 





88



   $format=~s/hh12|HH12         / sprintf("%02d",$lt[2]<13?$lt[2]||12:$lt[2]-12)/gxe; 




 




8





 





 





 





 





51



   




4346




38





 





 





 





 





86



   $format=~s/HH24|HH24|HH|hh   / sprintf("%02d",$lt[2])         /gxe; 




 




4





 





 





 





 





22



   




4347




38





 





 





 





 





77



   $format=~s/MI                / sprintf("%02d",$lt[1])         /gxei; 




 




12





 





 





 





 





42



   




4348




38





 




  
100
  




 





 





68



   $format=~s{SS\.([1-9])      }{ sprintf("%0*.$1f",3+$1,$lt[0]+(repl($time,qr/^[^\.]+/)||0)) }gxei; 




 




3





 





 





 





 





21



   




4349




38





 





 





 





 





64



   $format=~s/SS                / sprintf("%02d",$lt[0])         /gxei; 




 




4





 





 





 





 





16



   




4350




38




  
100
  




 





 





 





77



   $format=~s/am|pm             / $lt[2]<13 ? 'am' : 'pm'        /gxe; 




 




4





 





 





 





 





14



   




4351




38




  
100
  




 





 





 





75



   $format=~s/AM|PM             / $lt[2]<13 ? 'AM' : 'PM'        /gxe; 




 




4





 





 





 





 





13



   




4352




38





 





 





 





 





107



   $format=~s/WWI|WW            / sprintf("%02d",weeknum($time)) /gxei; 




 



  
0
  




 





 





 





 





0



   




4353




38





 





 





 





 





60



   $format=~s/W                 / weeknum($time)                 /gxei; 




 



  
0
  




 





 





 





 





0



   




4354




38





 





 





 





 





323



   $format; 




4355




 





 





 





 





 





 



 } 




4356




 





 





 





 





 





 



   




4357




 





 





 





 





 





 



 =head2 easter 




4358




 





 





 





 





 





 



   




4359




 





 





 





 





 





 



 Input: A year (a four digit number) 




4360




 





 





 





 





 





 



   




4361




 





 





 





 





 





 



 Output: array of two numbers: day and month of Easter Sunday that year. Month 3 means March and 4 means April. 




4362




 





 





 





 





 





 



   




4363




 





 





 





 





 





 



  sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30; 




4364




 





 





 





 





 





 



              (($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) } 




4365




 





 





 





 





 





 



   




4366




 





 





 





 





 





 



 ...is a "golfed" version of Oudins algorithm (1940) L 




4367




 





 





 





 





 





 



 (see also http://www.smart.net/~mmontes/ec-cal.html ) 




4368




 





 





 





 





 





 



   




4369




 





 





 





 





 





 



 Valid for any Gregorian year. Dates repeat themselves after 70499183 




4370




 





 





 





 





 





 



 lunations = 2081882250 days = ca 5699845 years. However, our planet will 




4371




 





 





 





 





 





 



 by then have a different rotation and spin time... 




4372




 





 





 





 





 





 



   




4373




 





 





 





 





 





 



 Example: 




4374




 





 





 





 





 





 



   




4375




 





 





 





 





 





 



  ( $day, $month ) = easter( 2012 ); # $day == 8 and $month == 4 




4376




 





 





 





 





 





 



   




4377




 





 





 





 





 





 



 Example 2: 




4378




 





 





 





 





 





 



   




4379




 





 





 





 





 





 



  my @e=map sprintf("%02d%02d", reverse(easter($_))), 1800..300000; 




4380




 





 





 





 





 





 



  print "First: ".min(@e)." Last: ".max(@e)."\n"; # First: 0322 Last: 0425 




4381




 





 





 





 





 





 



   




4382




 





 





 





 





 





 



 =cut 




4383




 





 





 





 





 





 



   




4384




28





 





 




  
28
  



  
1
  




53963



 sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30; 




 




28





 





 




  
5000
  




 





52



   




 




28





 





 





 





 





124



   




 




5000





 





 





 





 





11620



   




 




5000





 





 





 





 





6188



   




 




5000





 





 





 





 





8536



   




4385




5000




  
100
  



  
 66
  




 





 





24827



              (($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) } 




4386




 





 





 





 





 





 



   




4387




 





 





 





 





 





 



   




4388




 





 





 





 





 





 



 =head2 time_fp 




4389




 





 





 





 





 





 



   




4390




 





 





 





 





 





 



 No input arguments. 




4391




 





 





 





 





 





 



   




4392




 





 





 





 





 





 



 Return the same number as perls C except with decimals (fractions of a second, _fp as in floating point number). 




4393




 





 





 





 





 





 



   




4394




 





 





 





 





 





 



  print time_fp(),"\n"; 




4395




 





 





 





 





 





 



  print time(),"\n"; 




4396




 





 





 





 





 





 



   




4397




 





 





 





 





 





 



 Could write: 




4398




 





 





 





 





 





 



   




4399




 





 





 





 





 





 



  1116776232.38632 




4400




 





 





 





 





 





 



   




4401




 





 





 





 





 





 



 ...if that is the time now. 




4402




 





 





 





 





 





 



   




4403




 





 





 





 





 





 



 Or just: 




4404




 





 





 





 





 





 



   




4405




 





 





 





 





 





 



  1116776232 




4406




 





 





 





 





 





 



   




4407




 





 





 





 





 





 



 ...from perl's internal C if C isn't installed and available. 




4408




 





 





 





 





 





 



   




4409




 





 





 





 





 





 



   




4410




 





 





 





 





 





 



 =cut 




4411




 





 





 





 





 





 



   




4412




 





 





 





 





 





 



 sub time_fp {  # {return 0+gettimeofday} is just as well? 




4413




12416




  
 50
  




 




  
12416
  



  
1
  




19116



     eval{ require Time::HiRes } or return time(); 




 




12416





 





 





 





 





75841



   




4414




12416





 





 





 





 





47644



     my($sec,$mic)=Time::HiRes::gettimeofday(); 




4415




12416





 





 





 





 





53145



     return $sec+$mic/1e6; #1e6 not portable? 




4416




 





 





 





 





 





 



 } 




4417




 





 





 





 





 





 



   




4418




 





 





 





 





 





 



 =head2 sleep_fp 




4419




 





 





 





 





 





 



   




4420




 





 





 





 





 





 



 sleep_fp() work as the built in C<< sleep() >> but also accepts fractional seconds: 




4421




 





 





 





 





 





 



   




4422




 





 





 





 





 





 



  sleep_fp(0.020);  # sleeps for 20 milliseconds 




4423




 





 





 





 





 





 



   




4424




 





 





 





 





 





 



 Sub sleep_fp do a C, thus it might take some 




4425




 





 





 





 





 





 



 extra time the first call. To avoid that, add C<< use Time::HiRes >> 




4426




 





 





 





 





 





 



 to your code. Sleep_fp should not be trusted for accuracy to more than 




4427




 





 





 





 





 





 



 a tenth of a second. Virtual machines tend to be less accurate (sleep 




4428




 





 





 





 





 





 



 longer) than physical ones. This was tested on VMware and RHEL 




4429




 





 





 





 





 





 



 (Linux). See also L. 




4430




 





 





 





 





 





 



   




4431




 





 





 





 





 





 



 =head2 sleeps 




4432




 





 





 





 





 





 



   




4433




 





 





 





 





 





 



 =head2 sleepms 




4434




 





 





 





 





 





 



   




4435




 





 





 





 





 





 



 =head2 sleepus 




4436




 





 





 





 





 





 



   




4437




 





 





 





 





 





 



 =head2 sleepns 




4438




 





 





 





 





 





 



   




4439




 





 





 





 





 





 



  sleep_fp(0.020);   #sleeps for 20 milliseconds 




4440




 





 





 





 





 





 



  sleeps(0.020);     #sleeps for 20 milliseconds, sleeps() is a synonym to sleep_fp() 




4441




 





 





 





 





 





 



  sleepms(20);       #sleeps for 20 milliseconds 




4442




 





 





 





 





 





 



  sleepus(20000);    #sleeps for 20000 microseconds = 20 milliseconds 




4443




 





 





 





 





 





 



  sleepns(20000000); #sleeps for 20 million nanoseconds = 20 milliseconds 




4444




 





 





 





 





 





 



   




4445




 





 





 





 





 





 



 =cut 




4446




 





 





 





 





 





 



   




4447




13




  
 50
  




 




  
13
  



  
1
  




81



 sub sleep_fp { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) } 




 




13





 





 





 





 





156



   




 




13





 





 





 





 





221802



   




4448




1




  
 50
  




 




  
1
  



  
1
  




12



 sub sleeps   { eval{require Time::HiRes} or (sleep(shift()),return);Time::HiRes::sleep(shift()) } 




 




1





 





 





 





 





14



   




 




1





 





 





 





 





10162



   




4449




1




  
 50
  




 




  
1
  



  
1
  




18



 sub sleepms  { eval{require Time::HiRes} or (sleep(shift()/1e3),return);Time::HiRes::sleep(shift()/1e3) } 




 




1





 





 





 





 





24



   




 




1





 





 





 





 





10168



   




4450




1




  
 50
  




 




  
1
  



  
1
  




14



 sub sleepus  { eval{require Time::HiRes} or (sleep(shift()/1e6),return);Time::HiRes::sleep(shift()/1e6) } 




 




1





 





 





 





 





21



   




 




1





 





 





 





 





10158



   




4451




1




  
 50
  




 




  
1
  



  
1
  




13



 sub sleepns  { eval{require Time::HiRes} or (sleep(shift()/1e9),return);Time::HiRes::sleep(shift()/1e9) } 




 




1





 





 





 





 





19



   




 




1





 





 





 





 





10140



   




4452




 





 





 





 





 





 



   




4453




 





 





 





 





 





 



 =head2 eta 




4454




 





 





 





 





 





 



   




4455




 





 





 





 





 





 



 Estimated time of arrival (ETA). 




4456




 





 





 





 





 





 



   




4457




 





 





 





 





 





 



  for(@files){ 




4458




 





 





 





 





 





 



     ...do work on file... 




4459




 





 





 





 





 





 



     my $eta = eta( ++$i, 0+@files ); # file now, number of files 




4460




 





 





 





 





 





 



     print "" . localtime($eta); 




4461




 





 





 





 





 





 



  } 




4462




 





 





 





 





 





 



   




4463




 





 





 





 





 





 



  ..DOC MISSING.. 




4464




 





 





 





 





 





 



   




4465




 





 





 





 





 





 



 =head2 etahhmm 




4466




 





 





 





 





 





 



   




4467




 





 





 





 





 





 



  ...NOT YET 




4468




 





 





 





 





 





 



   




4469




 





 





 





 





 





 



 =cut 




4470




 





 





 





 





 





 



   




4471




 





 





 





 





 





 



 #http://en.wikipedia.org/wiki/Kalman_filter god idé? 




4472




 





 





 





 





 





 



 our %Eta; 




4473




 





 





 





 





 





 



 our $Eta_forgetfulness=2; 




4474




 





 





 





 





 





 



 sub eta { 




4475




2004




  
100
  




 




  
2004
  



  
1
  




15296



   my($id,$pos,$end,$time_fp)=( @_==2 ? (join(";",caller()),@_) : @_ ); 




4476




2004





 




  
 66
  




 





 





4544



   $time_fp||=time_fp(); 




4477




2004





 




  
100
  




 





 





4853



   my $a=$Eta{$id}||=[]; 




4478




2004





 





 





 





 





4265



   push @$a, [$pos,$time_fp]; 




4479




2004




  
100
  




 





 





 





5365



   @$a=@$a[map$_*2,0..@$a/2] if @$a>40;  #hm 40 




4480




2004




  
100
  



  
100
  




 





 





9090



   splice(@$a,-2,1) if @$a>1 and $$a[-2][0]==$$a[-1][0]; #same pos as last 




4481




2004




  
100
  




 





 





 





4117



   return undef if @$a<2; 




4482




2001





 





 





 





 





2410



   my @eta; 




4483




2001





 





 





 





 





3755



   for(2..@$a){ 




4484




58602





 





 





 





 





158569



     push @eta, $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-$_][1])/($$a[-1][0]-$$a[-$_][0]); 




4485




 





 





 





 





 





 



   } 




4486




2001





 





 





 





 





2940



   my($sum,$sumw,$w)=(0,0,1); 




4487




2001





 





 





 





 





3107



   for(@eta){ 




4488




58602





 





 





 





 





74926



     $sum+=$w*$_; 




4489




58602





 





 





 





 





70451



     $sumw+=$w; 




4490




58602





 





 





 





 





83675



     $w/=$Eta_forgetfulness; 




4491




 





 





 





 





 





 



   } 




4492




2001





 





 





 





 





2729



   my $avg=$sum/$sumw; 




4493




2001





 





 





 





 





6189



   return $avg; 




4494




 





 





 





 





 





 



 #  return avg(@eta); 




4495




 





 





 





 





 





 



  #return $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-2][1])/($$a[-1][0]-$$a[-2][0]); 




4496



  
0
  




 





 





 





 





0



   1; 




4497




 





 





 





 





 





 



 } 




4498




 





 





 





 





 





 



   




4499




 





 





 





 





 





 



 =head2 sleep_until 




4500




 





 





 





 





 





 



   




4501




 





 





 





 





 





 



 sleep_until(0.5) sleeps until half a second has passed since the last 




4502




 





 





 





 





 





 



 call to sleep_until. This example starts the next job excactly ten 




4503




 





 





 





 





 





 



 seconds after the last job started even if the last job lasted for a 




4504




 





 





 





 





 





 



 while (but not more than ten seconds): 




4505




 





 





 





 





 





 



   




4506




 





 





 





 





 





 



  for(@jobs){ 




4507




 





 





 





 





 





 



    sleep_until(10); 




4508




 





 





 





 





 





 



    print localtime()."\n"; 




4509




 





 





 





 





 





 



    ...heavy job.... 




4510




 





 





 





 





 





 



  } 




4511




 





 





 





 





 





 



   




4512




 





 





 





 





 





 



 Might print: 




4513




 





 





 





 





 





 



   




4514




 





 





 





 





 





 



  Thu Jan 12 16:00:00 2012 




4515




 





 





 





 





 





 



  Thu Jan 12 16:00:10 2012 




4516




 





 





 





 





 





 



  Thu Jan 12 16:00:20 2012 




4517




 





 





 





 





 





 



   




4518




 





 





 





 





 





 



 ...and so on even if the C<< ...heavy job... >>-part takes more than a 




4519




 





 





 





 





 





 



 second to complete. Whereas if sleep(10) was used, each job would 




4520




 





 





 





 





 





 



 spend more than ten seconds in average since the work time would be 




4521




 





 





 





 





 





 



 added to sleep(10). 




4522




 





 





 





 





 





 



   




4523




 





 





 





 





 





 



 Note: sleep_until() will remember the time of ANY last call of this sub, 




4524




 





 





 





 





 





 



 not just the one on the same line in the source code (this might change 




4525




 





 





 





 





 





 



 in the future). The first call to sleep_until() will be the same as 




4526




 





 





 





 





 





 



 sleep_fp() or Perl's own sleep() if the argument is an integer. 




4527




 





 





 





 





 





 



   




4528




 





 





 





 





 





 



 =cut 




4529




 





 





 





 





 





 



   




4530




 





 





 





 





 





 



 our $Time_last_sleep_until; 




4531




 





 





 





 





 





 



 sub sleep_until { 




4532



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



   my $s=@_==1?shift():0; 




4533



  
0
  




 





 





 





 





0



   my $time=time_fp(); 




4534



  
0
  




 





 





 





 





0



   my $sleep=$s-($time-nvl($Time_last_sleep_until,0)); 




4535



  
0
  




 





 





 





 





0



   $Time_last_sleep_until=time; 




4536



  
0
  



  
  0
  




 





 





 





0



   sleep_fp($sleep) if $sleep>0; 




4537




 





 





 





 





 





 



 } 




4538




 





 





 





 





 





 



   




4539




 





 





 





 





 





 



 =head2 leapyear 




4540




 





 





 





 





 





 



   




4541




 





 





 





 





 





 



 B A year. A four digit number. 




4542




 





 





 





 





 





 



   




4543




 





 





 





 





 





 



 B True (1) or false (0) of whether the year is a leap year or 




4544




 





 





 





 





 





 



 not. (Uses current calendar even for periods before leapyears was used). 




4545




 





 





 





 





 





 



   




4546




 





 





 





 





 





 



  print join(", ",grep leapyear($_), 1900..2014)."\n"; 




4547




 





 





 





 





 





 



   




4548




 





 





 





 





 





 



  1904, 1908, 1912, 1916, 1920, 1924, 1928, 1932, 1936, 1940, 1944, 1948, 1952, 1956, 




4549




 





 





 





 





 





 



  1960, 1964, 1968, 1972, 1976, 1980, 1984, 1988, 1992, 1996, 2000, 2004, 2008, 2012 




4550




 





 





 





 





 





 



   




4551




 





 





 





 





 





 



 Note: 1900 is not a leap year, but 2000 is. Years divided by 100 is a leap year only 




4552




 





 





 





 





 





 



 if it can be divided by 400. 




4553




 





 





 





 





 





 



   




4554




 





 





 





 





 





 



 =cut 




4555




 





 





 





 





 





 



   




4556



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub leapyear{$_[0]%400?$_[0]%100?$_[0]%4?0:1:0:1} #bool 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




4557




 





 





 





 





 





 



   




4558




 





 





 





 





 





 



 #http://rosettacode.org/wiki/Levenshtein_distance#Perl 




4559




 





 





 





 





 





 



 our %ldist_cache; 




4560




 





 





 





 





 





 



 sub ldist { 




4561



  
0
  




 





 




  
0
  



  
0
  




0



   my($s,$t,$l) = @_; 




4562



  
0
  



  
  0
  




 





 





 





0



   return length($t) if !$s; 




4563



  
0
  



  
  0
  




 





 





 





0



   return length($s) if !$t; 




4564



  
0
  



  
  0
  



  
  0
  




 





 





0



   %ldist_cache=() if !$l and 1000<0+%ldist_cache; 




4565




 





 





 





 





 





 



   $ldist_cache{$s,$t} ||= 




4566



  
0
  




 




  
  0
  




 





 





0



   do { 




4567



  
0
  




 





 





 





 





0



     my($s1,$t1) = ( substr($s,1), substr($t,1) ); 




4568



  
0
  



  
  0
  




 





 





 





0



     substr($s,0,1) eq substr($t,0,1) 




4569




 





 





 





 





 





 



       ? ldist($s1,$t1) 




4570




 





 





 





 





 





 



       : 1 + min( ldist($s1,$t1,1+$l), ldist($s,$t1,1+$l), ldist($s1,$t,1+$l) ); 




4571




 





 





 





 





 





 



   }; 




4572




 





 





 





 





 





 



 } 




4573




 





 





 





 





 





 



   




4574




 





 





 





 





 





 



 =head1 OTHER 




4575




 





 





 





 





 





 



   




4576




 





 





 





 





 





 



 =head2 nvl 




4577




 





 





 





 





 





 



   




4578




 





 





 





 





 





 



 The I function (or I function) 




4579




 





 





 





 





 





 



   




4580




 





 





 





 





 





 



 C takes two or more arguments. (Oracles nvl-function take just two) 




4581




 





 





 





 





 





 



   




4582




 





 





 





 





 





 



 Returns the value of the first input argument with length() > 0. 




4583




 





 





 





 





 





 



   




4584




 





 





 





 





 





 



 Return I if there is no such input argument. 




4585




 





 





 





 





 





 



   




4586




 





 





 





 





 





 



 In perl 5.10 and perl 6 this will most often be easier with the C< // 




4587




 





 





 





 





 





 



 > operator, although C and C<< // >> treats empty strings C<""> 




4588




 





 





 





 





 





 



 differently. Sub nvl here considers empty strings and undef the same. 




4589




 





 





 





 





 





 



   




4590




 





 





 





 





 





 



 =cut 




4591




 





 





 





 





 





 



   




4592




 





 





 





 





 





 



 sub nvl { 




4593




38




  
100
  



  
 66
  



  
38
  



  
1
  




285



   return $_[0] if defined $_[0] and length($_[0]) or @_==1; 




 




 





 




  
100
  




 





 





 



   




4594




22




  
100
  




 





 





 





83



   return $_[1] if @_==2; 




4595




9




  
100
  




 





 





 





36



   return nvl(@_[1..$#_]) if @_>2; 




4596




1





 





 





 





 





4



   return undef; 




4597




 





 





 





 





 





 



 } 




4598




 





 





 





 





 





 



   




4599




 





 





 





 





 





 



 =head2 decode_num 




4600




 





 





 





 





 





 



   




4601




 





 





 





 





 





 



 See L. 




4602




 





 





 





 





 





 



   




4603




 





 





 





 





 





 



 =head2 decode 




4604




 





 





 





 





 





 



   




4605




 





 





 





 





 





 



 C and C works just as Oracles C. 




4606




 





 





 





 





 





 



   




4607




 





 





 





 





 





 



 C and C accordingly uses perl operators C and C<==> for comparison. 




4608




 





 





 





 





 





 



   




4609




 





 





 





 





 





 



 Examples: 




4610




 





 





 





 





 





 



   




4611




 





 





 





 





 





 



  my $a=123; 




4612




 





 





 





 





 





 



  print decode($a, 123,3,  214,4, $a);     # prints 3 




4613




 





 





 





 





 





 



  print decode($a, 123=>3, 214=>4, $a);    # prints 3, same thing since => is synonymous to comma in Perl 




4614




 





 





 





 





 





 



   




4615




 





 





 





 





 





 



 The first argument is tested against the second, fourth, sixth and so on, 




4616




 





 





 





 





 





 



 and then the third, fifth, seventh and so on is 




4617




 





 





 





 





 





 



 returned if decode() finds an equal string or number. 




4618




 





 





 





 





 





 



   




4619




 





 





 





 





 





 



 In the above example: 123 maps to 3, 124 maps to 4 and the last argument $a is returned elsewise. 




4620




 





 





 





 





 





 



   




4621




 





 





 





 





 





 



 More examples: 




4622




 





 





 





 





 





 



   




4623




 





 





 





 





 





 



  my $a=123; 




4624




 





 





 





 





 





 



  print decode($a, 123=>3, 214=>7, $a);              # also 3,  note that => is synonym for , (comma) in perl 




4625




 





 





 





 





 





 



  print decode($a, 122=>3, 214=>7, $a);              # prints 123 




4626




 





 





 





 





 





 



  print decode($a,  123.0 =>3, 214=>7);              # prints 3 




4627




 





 





 





 





 





 



  print decode($a, '123.0'=>3, 214=>7);              # prints nothing (undef), no last argument default value here 




4628




 





 





 





 





 





 



  print decode_num($a, 121=>3, 221=>7, '123.0','b'); # prints b 




4629




 





 





 





 





 





 



   




4630




 





 





 





 





 





 



 Sort of: 




4631




 





 





 





 





 





 



   




4632




 





 





 





 





 





 



  decode($string, %conversion, $default); 




4633




 





 





 





 





 





 



   




4634




 





 





 





 





 





 



 The last argument is returned as a default if none of the keys in the keys/value-pairs matched. 




4635




 





 





 





 





 





 



   




4636




 





 





 





 





 





 



 A more perl-ish and often faster way of doing the same: 




4637




 





 





 





 





 





 



   




4638




 





 





 





 





 





 



  {123=>3, 214=>7}->{$a} || $a                       # (beware of 0) 




4639




 





 





 





 





 





 



   




4640




 





 





 





 





 





 



 =cut 




4641




 





 





 





 





 





 



   




4642




 





 





 





 





 





 



 sub decode { 




4643




4




  
 50
  




 




  
4
  



  
1
  




10



   croak "Must have a mimimum of two arguments" if @_<2; 




4644




4





 





 





 





 





6



   my $uttrykk=shift; 




4645




4




  
 50
  



  
100
  




 





 





11



   if(defined$uttrykk){ shift eq $uttrykk and return shift or shift for 1..@_/2 } 




 




4





 




  
 33
  




 





 





37



   




4646



  
0
  




 




  
  0
  




 





 





0



   else               { !defined shift    and return shift or shift for 1..@_/2 } 




 




 





 




  
  0
  




 





 





 



   




4647




2





 





 





 





 





8



   return shift; 




4648




 





 





 





 





 





 



 } 




4649




 





 





 





 





 





 



   




4650




 





 





 





 





 





 



 sub decode_num { 




4651




1




  
 50
  




 




  
1
  



  
1
  




5



   croak "Must have a mimimum of two arguments" if @_<2; 




4652




1





 





 





 





 





2



   my $uttrykk=shift; 




4653




1




  
 50
  



  
100
  




 





 





3



   if(defined$uttrykk){ shift == $uttrykk and return shift or shift for 1..@_/2 } 




 




1





 




  
 33
  




 





 





15



   




4654



  
0
  




 




  
  0
  




 





 





0



   else               { !defined shift    and return shift or shift for 1..@_/2 } 




 




 





 




  
  0
  




 





 





 



   




4655



  
0
  




 





 





 





 





0



   return shift; 




4656




 





 





 





 





 





 



 } 




4657




 





 





 





 





 





 



   




4658




 





 





 





 





 





 



 =head2 qrlist 




4659




 





 





 





 





 





 



   




4660




 





 





 





 





 





 



 Input: An array of values to be used to test againts for existence. 




4661




 





 





 





 





 





 



   




4662




 





 





 





 





 





 



 Output: A reference to a regular expression. That is a C 




4663




 





 





 





 





 





 



   




4664




 





 





 





 





 





 



 The regex sets $1 if it match. 




4665




 





 





 





 





 





 



   




4666




 





 





 





 





 





 



 Example: 




4667




 





 





 





 





 





 



   




4668




 





 





 





 





 





 



   my @list=qw/ABc XY DEF DEFG XYZ/; 




4669




 





 





 





 





 





 



   my $filter=qrlist("ABC","DEF","XY.");         # makes a regex of it qr/^(\QABC\E|\QDEF\E|\QXY.\E)$/ 




4670




 





 





 





 





 





 



   my @filtered= grep { $_ =~ $filter } @list;   # returns DEF and XYZ, but not XYZ because the . char is taken literally 




4671




 





 





 





 





 





 



   




4672




 





 





 





 





 





 



 Note: Filtering with hash lookups are WAY faster. 




4673




 





 





 





 





 





 



   




4674




 





 





 





 





 





 



 Source: 




4675




 





 





 





 





 





 



   




4676




 





 





 





 





 





 



  sub qrlist (@) { my $str=join"|",map quotemeta, @_; qr/^($str)$/ } 




4677




 





 





 





 





 





 



   




4678




 





 





 





 





 





 



 =cut 




4679




 





 





 





 





 





 



   




4680




 





 





 





 





 





 



 sub qrlist (@) { 




4681



  
0
  




 





 




  
0
  



  
1
  




0



   my $str=join"|",map quotemeta,@_; 




4682



  
0
  




 





 





 





 





0



   return qr/^($str)$/; 




4683




 





 





 





 





 





 



 } 




4684




 





 





 





 





 





 



   




4685




 





 





 





 





 





 



 =head2 ansicolor 




4686




 





 





 





 





 





 



   




4687




 





 





 





 





 





 



 Perhaps easier to use than L ? 




4688




 





 





 





 





 





 



   




4689




 





 





 





 





 





 



 B One argument. A string where the char C<¤> have special 




4690




 





 





 





 





 





 



 meaning and is replaced by color codings depending on the letter 




4691




 





 





 





 





 





 



 following the C<¤>. 




4692




 





 





 





 





 





 



   




4693




 





 





 





 





 





 



 B The same string, but with C<¤letter> replaced by ANSI color 




4694




 





 





 





 





 





 



 codes respected by many types terminal windows. (xterm, telnet, ssh, 




4695




 





 





 





 





 





 



 telnet, rlog, vt100, cygwin, rxvt and such...). 




4696




 





 





 





 





 





 



   




4697




 





 





 





 





 





 



 B 




4698




 





 





 





 





 





 



   




4699




 





 





 





 





 





 



  ¤r red 




4700




 





 





 





 





 





 



  ¤g green 




4701




 





 





 





 





 





 



  ¤b blue 




4702




 





 





 





 





 





 



  ¤y yellow 




4703




 





 





 





 





 





 



  ¤m magenta 




4704




 





 





 





 





 





 



  ¤B bold 




4705




 





 





 





 





 





 



  ¤u underline 




4706




 





 





 





 





 





 



  ¤c clear 




4707




 





 





 





 





 





 



  ¤¤ reset, quits and returns to default text color. 




4708




 





 





 





 





 





 



   




4709




 





 





 





 





 





 



 B 




4710




 





 





 





 





 





 



   




4711




 





 





 





 





 





 



  print ansicolor("This is maybe ¤ggreen¤¤?"); 




4712




 





 





 





 





 





 



   




4713




 





 





 





 





 





 



 Prints I where the word I is shown in green. 




4714




 





 





 





 





 





 



   




4715




 





 





 





 





 





 



 If L is not installed or not found, returns the input 




4716




 





 





 





 





 





 



 string with every C<¤> including the following code letters 




4717




 





 





 





 





 





 



 removed. (That is: ansicolor is safe to use even if Term::ANSIColor is 




4718




 





 





 





 





 





 



 not installed, you just don't get the colors). 




4719




 





 





 





 





 





 



   




4720




 





 





 





 





 





 



 See also L. 




4721




 





 





 





 





 





 



   




4722




 





 





 





 





 





 



 =cut 




4723




 





 





 





 





 





 



   




4724




 





 





 





 





 





 



 sub ansicolor { 




4725



  
0
  




 





 




  
0
  



  
1
  




0



   my $txt=shift; 




4726



  
0
  



  
  0
  




 





 





 





0



   eval{require Term::ANSIColor} or return replace($txt,qr/¤./); 




 



  
0
  




 





 





 





 





0



   




4727



  
0
  




 





 





 





 





0



   my %h=qw/r red  g green  b blue  y yellow  m magenta  B bold  u underline  c clear  ¤ reset/; 




4728



  
0
  




 





 





 





 





0



   my $re=join"|",keys%h; 




4729



  
0
  




 





 





 





 





0



   $txt=~s/¤($re)/Term::ANSIColor::color($h{$1})/ge; 




 



  
0
  




 





 





 





 





0



   




4730



  
0
  




 





 





 





 





0



   return $txt; 




4731




 





 





 





 





 





 



 } 




4732




 





 





 





 





 





 



   




4733




 





 





 





 





 





 



 =head2 ccn_ok 




4734




 





 





 





 





 





 



   




4735




 





 





 





 





 





 



 Checks if a Credit Card number (CCN) has correct control digits according to the LUHN-algorithm from 1960. 




4736




 





 





 





 





 





 



 This method of control digits is used by MasterCard, Visa, American Express, 




4737




 





 





 





 





 





 



 Discover, Diners Club / Carte Blanche, JCB and others. 




4738




 





 





 





 





 





 



   




4739




 





 





 





 





 





 



 B 




4740




 





 





 





 





 





 



   




4741




 





 





 





 





 





 



 A credit card number. Can contain non-digits, but they are removed internally before checking. 




4742




 





 





 





 





 





 



   




4743




 





 





 





 





 





 



 B 




4744




 





 





 





 





 





 



   




4745




 





 





 





 





 





 



 Something true or false. 




4746




 





 





 





 





 





 



   




4747




 





 





 





 





 





 



 Or more accurately: 




4748




 





 





 





 





 





 



   




4749




 





 





 





 





 





 



 Returns C (false) if the input argument is missing digits. 




4750




 





 





 





 





 





 



   




4751




 





 





 





 





 





 



 Returns 0 (zero, which is false) is the digits is not correct according to the LUHN algorithm. 




4752




 





 





 





 





 





 



   




4753




 





 





 





 





 





 



 Returns 1 or the name of a credit card company (true either way) if the last digit is an ok control digit for this ccn. 




4754




 





 





 





 





 





 



   




4755




 





 





 





 





 





 



 The name of the credit card company is returned like this (without the C<'> character) 




4756




 





 





 





 





 





 



   




4757




 





 





 





 





 





 



  Returns (wo '')                Starts on                Number of digits 




4758




 





 





 





 





 





 



  ------------------------------ ------------------------ ---------------- 




4759




 





 





 





 





 





 



  'MasterCard'                   51-55                    16 




4760




 





 





 





 





 





 



  'Visa'                         4                        13 eller 16 




4761




 





 





 





 





 





 



  'American Express'             34 eller 37              15 




4762




 





 





 





 





 





 



  'Discover'                     6011                     16 




4763




 





 





 





 





 





 



  'Diners Club / Carte Blanche'  300-305, 36 eller 38     14 




4764




 





 





 





 





 





 



  'JCB'                          3                        16 




4765




 





 





 





 





 





 



  'JCB'                          2131 eller 1800          15 




4766




 





 





 





 





 





 



   




4767




 





 





 





 





 





 



 And should perhaps have had: 




4768




 





 





 





 





 





 



   




4769




 





 





 





 





 





 



  'enRoute'                      2014 eller 2149          15 




4770




 





 





 





 





 





 



   




4771




 





 





 





 





 





 



 ...but that card uses either another control algorithm or no control 




4772




 





 





 





 





 





 



 digits at all. So C is never returned here. 




4773




 





 





 





 





 





 



   




4774




 





 





 





 





 





 



 If the control digits is valid, but the input does not match anything in the column C, 1 is returned. 




4775




 





 





 





 





 





 



   




4776




 





 





 





 





 





 



 (This is also the same control digit mechanism used in Norwegian KID numbers on payment bills) 




4777




 





 





 





 





 





 



   




4778




 





 





 





 





 





 



 The first digit in a credit card number is supposed to tell what "industry" the card is meant for: 




4779




 





 





 





 





 





 



   




4780




 





 





 





 





 





 



  MII Digit Value             Issuer Category 




4781




 





 





 





 





 





 



  --------------------------- ---------------------------------------------------- 




4782




 





 





 





 





 





 



  0                           ISO/TC 68 and other industry assignments 




4783




 





 





 





 





 





 



  1                           Airlines 




4784




 





 





 





 





 





 



  2                           Airlines and other industry assignments 




4785




 





 





 





 





 





 



  3                           Travel and entertainment 




4786




 





 





 





 





 





 



  4                           Banking and financial 




4787




 





 





 





 





 





 



  5                           Banking and financial 




4788




 





 





 





 





 





 



  6                           Merchandizing and banking 




4789




 





 





 





 





 





 



  7                           Petroleum 




4790




 





 





 





 





 





 



  8                           Telecommunications and other industry assignments 




4791




 





 





 





 





 





 



  9                           National assignment 




4792




 





 





 





 





 





 



   




4793




 





 





 





 





 





 



 ...although this has no meaning to C. 




4794




 





 





 





 





 





 



   




4795




 





 





 





 





 





 



 The first six digits is I, that is the bank 




4796




 





 





 





 





 





 



 (probably). The rest in the "account number", except the last digits, 




4797




 





 





 





 





 





 



 which is the control digit. Max length on credit card numbers are 19 




4798




 





 





 





 





 





 



 digits. 




4799




 





 





 





 





 





 



   




4800




 





 





 





 





 





 



 =cut 




4801




 





 





 





 





 





 



   




4802




 





 





 





 





 





 



 sub ccn_ok { 




4803



  
0
  




 





 




  
0
  



  
1
  




0



     my $ccn=shift(); #credit card number 




4804



  
0
  




 





 





 





 





0



     $ccn=~s/\D+//g; 




4805



  
0
  



  
  0
  




 





 





 





0



     if(KID_ok($ccn)){ 




4806



  
0
  



  
  0
  




 





 





 





0



 	return "MasterCard"                   if $ccn=~/^5[1-5]\d{14}$/; 




4807



  
0
  



  
  0
  




 





 





 





0



 	return "Visa"                         if $ccn=~/^4\d{12}(?:\d{3})?$/; 




4808



  
0
  



  
  0
  




 





 





 





0



 	return "American Express"             if $ccn=~/^3[47]\d{13}$/; 




4809



  
0
  



  
  0
  




 





 





 





0



 	return "Discover"                     if $ccn=~/^6011\d{12}$/; 




4810



  
0
  



  
  0
  




 





 





 





0



 	return "Diners Club / Carte Blanche"  if $ccn=~/^3(?:0[0-5]\d{11}|[68]\d{12})$/; 




4811



  
0
  



  
  0
  




 





 





 





0



 	return "JCB"                          if $ccn=~/^(?:3\d{15}|(?:2131|1800)\d{11})$/; 




4812



  
0
  




 





 





 





 





0



 	return 1; 




4813




 





 





 





 





 





 



     } 




4814




 





 





 





 





 





 



     #return "enRoute"                        if $ccn=~/^(?:2014|2149)\d{11}$/; #ikke LUHN-krav? 




4815



  
0
  




 





 





 





 





0



     return 0; 




4816




 





 





 





 





 





 



 } 




4817




 





 





 





 





 





 



   




4818




 





 





 





 





 





 



 =head2 KID_ok 




4819




 





 





 





 





 





 



   




4820




 





 





 





 





 





 



 Checks if a norwegian KID number has an ok control digit. 




4821




 





 





 





 





 





 



   




4822




 





 





 





 





 





 



 To check if a customer has typed the number correctly. 




4823




 





 





 





 





 





 



   




4824




 





 





 





 





 





 



 This uses the  LUHN algorithm (also known as mod-10) from 1960 which is also used 




4825




 





 





 





 





 





 



 internationally in control digits for credit card numbers, and Canadian social security ID numbers as well. 




4826




 





 





 





 





 





 



   




4827




 





 





 





 





 





 



 The algorithm, as described in Phrack (47-8) (a long time hacker online publication): 




4828




 





 





 





 





 





 



   




4829




 





 





 





 





 





 



  "For a card with an even number of digits, double every odd numbered 




4830




 





 





 





 





 





 



  digit and subtract 9 if the product is greater than 9. Add up all the 




4831




 





 





 





 





 





 



  even digits as well as the doubled-odd digits, and the result must be 




4832




 





 





 





 





 





 



  a multiple of 10 or it's not a valid card. If the card has an odd 




4833




 





 





 





 





 





 



  number of digits, perform the same addition doubling the even numbered 




4834




 





 





 





 





 





 



  digits instead." 




4835




 





 





 





 





 





 



   




4836




 





 





 





 





 





 



 B A KID-nummer. Must consist of digits 0-9 only, otherwise a die (croak) happens. 




4837




 





 





 





 





 





 



   




4838




 





 





 





 





 





 



 B 




4839




 





 





 





 





 





 



   




4840




 





 





 





 





 





 



 - Returns undef if the input argument is missing. 




4841




 





 





 





 





 





 



   




4842




 





 





 





 





 





 



 - Returns 0 if the control digit (the last digit) does not satify the LUHN/mod-10 algorithm. 




4843




 





 





 





 





 





 



   




4844




 





 





 





 





 





 



 - Returns 1 if ok 




4845




 





 





 





 





 





 



   




4846




 





 





 





 





 





 



 B L 




4847




 





 





 





 





 





 



   




4848




 





 





 





 





 





 



 =cut 




4849




 





 





 





 





 





 



   




4850




 





 





 





 





 





 



 sub KID_ok { 




4851



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



   croak "Non-numeric argument" if $_[0]=~/\D/; 




4852



  
0
  



  
  0
  




 





 





 





0



   my @k=split//,shift or return undef; 




4853



  
0
  




 





 





 





 





0



   my $s;$s+=pop(@k)+[qw/0 2 4 6 8 1 3 5 7 9/]->[pop@k] while @k; 




 



  
0
  




 





 





 





 





0



   




4854



  
0
  



  
  0
  




 





 





 





0



   $s%10==0?1:0; 




4855




 





 





 





 





 





 



 } 




4856




 





 





 





 





 





 



   




4857




 





 





 





 





 





 



   




4858




 





 





 





 





 





 



   




4859




 





 





 





 





 





 



 =head2 range 




4860




 





 





 





 





 





 



   




4861




 





 





 





 





 





 



 B 




4862




 





 





 





 





 





 



   




4863




 





 





 





 





 





 



 One or more numeric arguments: 




4864




 





 





 





 





 





 



   




4865




 





 





 





 





 





 



 First: x (first returned element) 




4866




 





 





 





 





 





 



   




4867




 





 





 





 





 





 



 Second: y (last but not including) 




4868




 





 





 





 





 





 



   




4869




 





 





 





 





 





 



 Third: step, default 1. The step between each returned element 




4870




 





 





 





 





 





 



   




4871




 





 





 





 





 





 



 If a fourth, fifth and so on arguments are given, they change the step for each returned element. As first derivative, second derivative. 




4872




 





 





 





 





 





 



   




4873




 





 





 





 





 





 



 B 




4874




 





 





 





 





 





 



   




4875




 





 





 





 





 





 



 If one argument: returns the array C<(0 .. x-1)> 




4876




 





 





 





 





 





 



   




4877




 





 





 





 





 





 



 If two arguments: returns the array C<(x .. y-1)> 




4878




 





 





 





 





 





 



   




4879




 





 





 





 





 





 



 If three arguments: The default step is 1. Use a third argument to use a different step. 




4880




 





 





 





 





 





 



   




4881




 





 





 





 





 





 



 B 




4882




 





 





 





 





 





 



   




4883




 





 





 





 





 





 



  print join ",", range(11);         # prints 0,1,2,3,4,5,6,7,8,9,10      (but not 11) 




4884




 





 





 





 





 





 



  print join ",", range(2,11);       # 2,3,4,5,6,7,8,9,10          (but not 11) 




4885




 





 





 





 





 





 



  print join ",", range(11,2,-1);    # 11,10,9,8,7,6,5,4,3 




4886




 





 





 





 





 





 



  print join ",", range(2,11,3);     # 2,5,8 




4887




 





 





 





 





 





 



  print join ",", range(11,2,-3);    # 11,8,5 




4888




 





 





 





 





 





 



  print join ",", range(11,2,+3);    # prints nothing 




4889




 





 





 





 





 





 



   




4890




 





 





 





 





 





 



  print join ", ",range(2,11,1,0.1);       # 2, 3, 4.1, 5.3, 6.6, 8, 9.5   adds 0.1 to step each time 




4891




 





 





 





 





 





 



  print join ", ",range(2,11,1,0.1,-0.01); # 2, 3, 4.1, 5.29, 6.56, 7.9, 9.3, 10.75 




4892




 





 





 





 





 





 



   




4893




 





 





 





 





 





 



 Note: In the Python language and others, C is a build in iterator (a 




4894




 





 





 





 





 





 



 generator), not an array. This saves memory for large sets and sometimes time. 




4895




 





 





 





 





 





 



 Use C in L to get a similar lazy generator in Perl. 




4896




 





 





 





 





 





 



   




4897




 





 





 





 





 





 



 =cut 




4898




 





 





 





 





 





 



   




4899




 





 





 





 





 





 



 sub range { 




4900




8




  
100
  




 




  
8
  



  
1
  




35



   return _range_accellerated(@_) if @_>3;  #se under 




4901




6





 





 





 





 





13



   my($x,$y,$jump)=@_; 




4902




6




  
100
  




 





 





 





71



   return (  0 .. $x-1 ) if @_==1; 




4903




5




  
100
  




 





 





 





21



   return ( $x .. $y-1 ) if @_==2; 




4904




4




  
 50
  



  
 33
  




 





 





28



   croak "Wrong number of arguments or jump==0" if @_!=3 or $jump==0; 




4905




4





 





 





 





 





6



   my @r; 




4906




4




  
100
  




 





 





 





11



   if($jump>0){  while($x<$y){ push @r, $x; $x+=$jump } } 




 




2





 





 





 





 





8



   




 




772





 





 





 





 





856



   




 




772





 





 





 





 





1292



   




4907




2





 





 





 





 





6



   else       {  while($x>$y){ push @r, $x; $x+=$jump } } 




 




12





 





 





 





 





18



   




 




12





 





 





 





 





21



   




4908




4





 





 





 





 





57



   return @r; 




4909




 





 





 





 





 





 



 } 




4910




 





 





 





 





 





 



   




4911




 





 





 





 





 





 



 #jumps derivative, double der., trippled der usw 




4912




 





 





 





 





 





 



 sub _range_accellerated { 




4913




2





 





 




  
2
  




 





6



   my($x,$y,@jump)=@_; 




4914




2





 





 





 





 





4



   my @r; 




4915




2




  
 50
  




 




  
0
  




 





10



   my $test = $jump[0]>=0 ? sub{$x<$y} : sub{$x>$y}; 




 




17





 





 





 





 





45



   




 



  
0
  




 





 





 





 





0



   




4916




2





 





 





 





 





6



   while(&$test()){ 




4917




15





 





 





 





 





23



     push @r, $x; 




4918




15





 





 





 





 





18



     $x+=$jump[0]; 




4919




15





 





 





 





 





50



     $jump[$_-1]+=$jump[$_] for 1..$#jump; 




4920




 





 





 





 





 





 



   } 




4921




2





 





 





 





 





29



   return @r; 




4922




 





 





 





 





 





 



 } 




4923




 





 





 





 





 





 



   




4924




 





 





 





 





 





 



 =head2 permutations 




4925




 





 





 





 





 





 



   




4926




 





 





 





 





 





 



 How many ways (permutations) can six people be placed around a table: 




4927




 





 





 





 





 





 



   




4928




 





 





 





 





 





 



  If one person:          one 




4929




 





 





 





 





 





 



  If two persons:         two     (they can swap places) 




4930




 





 





 





 





 





 



  If three persons:       six 




4931




 





 





 





 





 





 



  If four persons:         24 




4932




 





 





 





 





 





 



  If five persons:        120 




4933




 





 





 





 





 





 



  If six  persons:        720 




4934




 





 





 





 





 





 



   




4935




 





 





 





 





 





 



 The formula is C where the postfix unary operator C, also known as I is defined like: 




4936




 





 





 





 





 





 



 C. Example: C<5! = 5 * 4 * 3 * 2 * 1 = 120>.Run this to see the 100 first C<< n! >> 




4937




 





 





 





 





 





 



   




4938




 





 





 





 





 





 



  perl -MAcme::Tools -le'$i=big(1);print "$_!=",$i*=$_ for 1..100' 




4939




 





 





 





 





 





 



   




4940




 





 





 





 





 





 



   1!  = 1 




4941




 





 





 





 





 





 



   2!  = 2 




4942




 





 





 





 





 





 



   3!  = 6 




4943




 





 





 





 





 





 



   4!  = 24 




4944




 





 





 





 





 





 



   5!  = 120 




4945




 





 





 





 





 





 



   6!  = 720 




4946




 





 





 





 





 





 



   7!  = 5040 




4947




 





 





 





 





 





 



   8!  = 40320 




4948




 





 





 





 





 





 



   9!  = 362880 




4949




 





 





 





 





 





 



  10!  = 3628800 




4950




 





 





 





 





 





 



  . 




4951




 





 





 





 





 





 



  . 




4952




 





 





 





 





 





 



  . 




4953




 





 





 





 





 





 



  100! = 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000 




4954




 





 





 





 





 





 



   




4955




 





 





 





 





 





 



 C takes a list and return a list of arrayrefs for each 




4956




 





 





 





 





 





 



 of the permutations of the input list: 




4957




 





 





 





 





 





 



   




4958




 





 





 





 





 





 



  permutations('a','b');     #returns (['a','b'],['b','a']) 




4959




 





 





 





 





 





 



   




4960




 





 





 





 





 





 



  permutations('a','b','c'); #returns (['a','b','c'],['a','c','b'], 




4961




 





 





 





 





 





 



                             #         ['b','a','c'],['b','c','a'], 




4962




 





 





 





 





 





 



                             #         ['c','a','b'],['c','b','a']) 




4963




 





 





 





 





 





 



   




4964




 





 





 





 





 





 



 Up to five input arguments C is probably as fast as it 




4965




 





 





 





 





 





 



 can be in this pure perl implementation (see source). For more than 




4966




 





 





 





 





 





 



 five, it could be faster. How fast is it now: Running with different 




4967




 





 





 





 





 





 



 n, this many time took that many seconds: 




4968




 





 





 





 





 





 



   




4969




 





 





 





 





 





 



  n   times    seconds 




4970




 





 





 





 





 





 



  -- ------- --------- 




4971




 





 





 





 





 





 



   2  100000      0.32 




4972




 





 





 





 





 





 



   3  10000       0.09 




4973




 





 





 





 





 





 



   4  10000       0.33 




4974




 





 





 





 





 





 



   5  1000        0.18 




4975




 





 





 





 





 





 



   6  100         0.27 




4976




 





 





 





 





 





 



   7  10          0.21 




4977




 





 





 





 





 





 



   8  1           0.17 




4978




 





 





 





 





 





 



   9  1           1.63 




4979




 





 





 





 





 





 



  10  1          17.00 




4980




 





 





 





 





 





 



   




4981




 





 





 





 





 





 



 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. For example this: 




4982




 





 





 





 





 





 



   




4983




 





 





 





 





 





 



  print for permutations(sub{join"",@_},1..3); 




4984




 





 





 





 





 





 



   




4985




 





 





 





 





 





 



 ...will print the same as: 




4986




 





 





 





 





 





 



   




4987




 





 





 





 





 





 



  print for map join("",@$_), permutations(1..3); 




4988




 





 





 





 





 





 



   




4989




 





 





 





 





 





 



 ...but the first of those two uses less RAM if 3 has been say 9. 




4990




 





 





 





 





 





 



 Changing 3 with 10, and many computers hasn't enough memory 




4991




 





 





 





 





 





 



 for the latter. 




4992




 





 





 





 





 





 



   




4993




 





 





 





 





 





 



 The examples prints: 




4994




 





 





 





 





 





 



   




4995




 





 





 





 





 





 



  123 




4996




 





 





 





 





 





 



  132 




4997




 





 





 





 





 





 



  213 




4998




 





 





 





 





 





 



  231 




4999




 





 





 





 





 





 



  312 




5000




 





 





 





 





 





 



  321 




5001




 





 





 





 





 





 



   




5002




 





 





 





 





 





 



 If you just want to say calculate something on each permutation, 




5003




 





 





 





 





 





 



 but is not interested in the list of them, you just don't 




5004




 





 





 





 





 





 



 take the return. That is: 




5005




 





 





 





 





 





 



   




5006




 





 





 





 





 





 



  my $ant; 




5007




 





 





 





 





 





 



  permutations(sub{$ant++ if $_[-1]>=$_[0]*2},1..9); 




5008




 





 





 





 





 





 



   




5009




 





 





 





 





 





 



 ...is the same as: 




5010




 





 





 





 





 





 



   




5011




 





 





 





 





 





 



  $$_[-1]>=$$_[0]*2 and $ant++ for permutations(1..9); 




5012




 





 





 





 





 





 



   




5013




 





 





 





 





 





 



 ...but the first uses next to nothing of memory compared to the latter. They have about the same speed. 




5014




 





 





 





 





 





 



 (The examples just counts the permutations where the last number is at least twice as large as the first) 




5015




 





 





 





 





 





 



   




5016




 





 





 





 





 





 



 C was created to find all combinations of a persons 




5017




 





 





 





 





 





 



 name. This is useful in "fuzzy" name searches with 




5018




 





 





 





 





 





 



 L if you can not be certain what is first, middle 




5019




 





 





 





 





 





 



 and last names. In foreign or unfamiliar names it can be difficult to 




5020




 





 





 





 





 





 



 know that. 




5021




 





 





 





 





 





 



   




5022




 





 





 





 





 





 



 =cut 




5023




 





 





 





 





 





 



   




5024




 





 





 





 





 





 



 #TODO: se test_perl.pl 




5025




 





 





 





 





 





 



   




5026




 





 





 





 





 





 



 sub permutations { 




5027




2




  
 50
  




 




  
2
  



  
1
  




16



   my $code=ref($_[0]) eq 'CODE' ? shift() : undef; 




5028




2




  
 50
  



  
 33
  




 





 





11



   $code and @_<6 and return map &$code(@$_),permutations(@_); 




5029




 





 





 





 





 





 



   




5030




2




  
 50
  




 





 





 





7



   return [@_] if @_<2; 




5031




 





 





 





 





 





 



   




5032




2




  
100
  




 





 





 





19



   return ([@_[0,1]],[@_[1,0]]) if @_==2; 




5033




 





 





 





 





 





 



   




5034




1




  
 50
  




 





 





 





19



   return ([@_[0,1,2]],[@_[0,2,1]],[@_[1,0,2]], 




5035




 





 





 





 





 





 



 	  [@_[1,2,0]],[@_[2,0,1]],[@_[2,1,0]]) if @_==3; 




5036




 





 





 





 





 





 



   




5037



  
0
  



  
  0
  




 





 





 





0



   return ([@_[0,1,2,3]],[@_[0,1,3,2]],[@_[0,2,1,3]],[@_[0,2,3,1]], 




5038




 





 





 





 





 





 



 	  [@_[0,3,1,2]],[@_[0,3,2,1]],[@_[1,0,2,3]],[@_[1,0,3,2]], 




5039




 





 





 





 





 





 



 	  [@_[1,2,0,3]],[@_[1,2,3,0]],[@_[1,3,0,2]],[@_[1,3,2,0]], 




5040




 





 





 





 





 





 



 	  [@_[2,0,1,3]],[@_[2,0,3,1]],[@_[2,1,0,3]],[@_[2,1,3,0]], 




5041




 





 





 





 





 





 



 	  [@_[2,3,0,1]],[@_[2,3,1,0]],[@_[3,0,1,2]],[@_[3,0,2,1]], 




5042




 





 





 





 





 





 



 	  [@_[3,1,0,2]],[@_[3,1,2,0]],[@_[3,2,0,1]],[@_[3,2,1,0]]) if @_==4; 




5043




 





 





 





 





 





 



   




5044



  
0
  



  
  0
  




 





 





 





0



   return ([@_[0,1,2,3,4]],[@_[0,1,2,4,3]],[@_[0,1,3,2,4]],[@_[0,1,3,4,2]],[@_[0,1,4,2,3]], 




5045




 





 





 





 





 





 



 	  [@_[0,1,4,3,2]],[@_[0,2,1,3,4]],[@_[0,2,1,4,3]],[@_[0,2,3,1,4]],[@_[0,2,3,4,1]], 




5046




 





 





 





 





 





 



 	  [@_[0,2,4,1,3]],[@_[0,2,4,3,1]],[@_[0,3,1,2,4]],[@_[0,3,1,4,2]],[@_[0,3,2,1,4]], 




5047




 





 





 





 





 





 



 	  [@_[0,3,2,4,1]],[@_[0,3,4,1,2]],[@_[0,3,4,2,1]],[@_[0,4,1,2,3]],[@_[0,4,1,3,2]], 




5048




 





 





 





 





 





 



 	  [@_[0,4,2,1,3]],[@_[0,4,2,3,1]],[@_[0,4,3,1,2]],[@_[0,4,3,2,1]],[@_[1,0,2,3,4]], 




5049




 





 





 





 





 





 



 	  [@_[1,0,2,4,3]],[@_[1,0,3,2,4]],[@_[1,0,3,4,2]],[@_[1,0,4,2,3]],[@_[1,0,4,3,2]], 




5050




 





 





 





 





 





 



 	  [@_[1,2,0,3,4]],[@_[1,2,0,4,3]],[@_[1,2,3,0,4]],[@_[1,2,3,4,0]],[@_[1,2,4,0,3]], 




5051




 





 





 





 





 





 



 	  [@_[1,2,4,3,0]],[@_[1,3,0,2,4]],[@_[1,3,0,4,2]],[@_[1,3,2,0,4]],[@_[1,3,2,4,0]], 




5052




 





 





 





 





 





 



 	  [@_[1,3,4,0,2]],[@_[1,3,4,2,0]],[@_[1,4,0,2,3]],[@_[1,4,0,3,2]],[@_[1,4,2,0,3]], 




5053




 





 





 





 





 





 



 	  [@_[1,4,2,3,0]],[@_[1,4,3,0,2]],[@_[1,4,3,2,0]],[@_[2,0,1,3,4]],[@_[2,0,1,4,3]], 




5054




 





 





 





 





 





 



 	  [@_[2,0,3,1,4]],[@_[2,0,3,4,1]],[@_[2,0,4,1,3]],[@_[2,0,4,3,1]],[@_[2,1,0,3,4]], 




5055




 





 





 





 





 





 



 	  [@_[2,1,0,4,3]],[@_[2,1,3,0,4]],[@_[2,1,3,4,0]],[@_[2,1,4,0,3]],[@_[2,1,4,3,0]], 




5056




 





 





 





 





 





 



 	  [@_[2,3,0,1,4]],[@_[2,3,0,4,1]],[@_[2,3,1,0,4]],[@_[2,3,1,4,0]],[@_[2,3,4,0,1]], 




5057




 





 





 





 





 





 



 	  [@_[2,3,4,1,0]],[@_[2,4,0,1,3]],[@_[2,4,0,3,1]],[@_[2,4,1,0,3]],[@_[2,4,1,3,0]], 




5058




 





 





 





 





 





 



 	  [@_[2,4,3,0,1]],[@_[2,4,3,1,0]],[@_[3,0,1,2,4]],[@_[3,0,1,4,2]],[@_[3,0,2,1,4]], 




5059




 





 





 





 





 





 



 	  [@_[3,0,2,4,1]],[@_[3,0,4,1,2]],[@_[3,0,4,2,1]],[@_[3,1,0,2,4]],[@_[3,1,0,4,2]], 




5060




 





 





 





 





 





 



 	  [@_[3,1,2,0,4]],[@_[3,1,2,4,0]],[@_[3,1,4,0,2]],[@_[3,1,4,2,0]],[@_[3,2,0,1,4]], 




5061




 





 





 





 





 





 



 	  [@_[3,2,0,4,1]],[@_[3,2,1,0,4]],[@_[3,2,1,4,0]],[@_[3,2,4,0,1]],[@_[3,2,4,1,0]], 




5062




 





 





 





 





 





 



 	  [@_[3,4,0,1,2]],[@_[3,4,0,2,1]],[@_[3,4,1,0,2]],[@_[3,4,1,2,0]],[@_[3,4,2,0,1]], 




5063




 





 





 





 





 





 



 	  [@_[3,4,2,1,0]],[@_[4,0,1,2,3]],[@_[4,0,1,3,2]],[@_[4,0,2,1,3]],[@_[4,0,2,3,1]], 




5064




 





 





 





 





 





 



 	  [@_[4,0,3,1,2]],[@_[4,0,3,2,1]],[@_[4,1,0,2,3]],[@_[4,1,0,3,2]],[@_[4,1,2,0,3]], 




5065




 





 





 





 





 





 



 	  [@_[4,1,2,3,0]],[@_[4,1,3,0,2]],[@_[4,1,3,2,0]],[@_[4,2,0,1,3]],[@_[4,2,0,3,1]], 




5066




 





 





 





 





 





 



 	  [@_[4,2,1,0,3]],[@_[4,2,1,3,0]],[@_[4,2,3,0,1]],[@_[4,2,3,1,0]],[@_[4,3,0,1,2]], 




5067




 





 





 





 





 





 



 	  [@_[4,3,0,2,1]],[@_[4,3,1,0,2]],[@_[4,3,1,2,0]],[@_[4,3,2,0,1]],[@_[4,3,2,1,0]]) if @_==5; 




5068




 





 





 





 





 





 



   




5069



  
0
  




 





 





 





 





0



   my(@r,@p,@c,@i,@n); @i=(0,@_); @p=@c=1..@_; @n=1..@_-1; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5070




 





 





 





 





 





 



   PERM: 




5071



  
0
  




 





 





 





 





0



   while(1){ 




5072



  
0
  



  
  0
  




 





 





 





0



     if($code){if(defined wantarray){push(@r,&$code(@i[@p]))}else{&$code(@i[@p])}}else{push@r,[@i[@p]]} 




 



  
0
  



  
  0
  




 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5073



  
0
  



  
  0
  




 





 





 





0



     for my$i(@n){splice@p,$i,0,shift@p;next PERM if --$c[$i];$c[$i]=$i+1} 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5074




 





 





 





 





 





 



     return@r 




5075



  
0
  




 





 





 





 





0



   } 




5076




 





 





 





 





 





 



 } 




5077




 





 





 





 





 





 



   




5078




 





 





 





 





 





 



 =head2 cart 




5079




 





 





 





 





 





 



   




5080




 





 





 





 





 





 



 Cartesian product 




5081




 





 





 





 





 





 



   




5082




 





 





 





 





 





 



 B 




5083




 





 





 





 





 





 



   




5084




 





 





 





 





 





 



 Input: two or more arrayrefs with accordingly x, y, z and so on number of elements. 




5085




 





 





 





 





 





 



   




5086




 





 





 





 





 





 



 Output: An array of x * y * z number of arrayrefs. The arrays being the cartesian product of the input arrays. 




5087




 





 





 





 





 





 



   




5088




 





 





 





 





 





 



 It can be useful to think of this as joins in SQL. In C statements with 




5089




 





 





 





 





 





 



 more tables behind C, but without any C condition to join the tables. 




5090




 





 





 





 





 





 



   




5091




 





 





 





 





 





 



 B 




5092




 





 





 





 





 





 



   




5093




 





 





 





 





 





 



 B 




5094




 





 





 





 





 





 



   




5095




 





 





 





 





 





 



 - Either two or more arrayrefs with x, y, z and so on number of elements. 




5096




 





 





 





 





 





 



   




5097




 





 





 





 





 





 



 - Or coderefs to subs containing condition checks. Somewhat like C conditions in SQL. 




5098




 





 





 





 





 





 



   




5099




 





 





 





 





 





 



 B An array of x * y * z number of arrayrefs (the cartesian product) 




5100




 





 





 





 





 





 



 minus the ones that did not fulfill the condition(s). 




5101




 





 





 





 





 





 



   




5102




 





 





 





 





 





 



 This of is as joins with one or more where conditions as coderefs. 




5103




 





 





 





 





 





 



   




5104




 





 





 





 





 





 



 The coderef input arguments can be placed last or among the array refs 




5105




 





 





 





 





 





 



 to save both runtime and memory if the conditions depend on 




5106




 





 





 





 





 





 



 arrays further back. 




5107




 





 





 





 





 





 



   




5108




 





 





 





 





 





 



 B 




5109




 





 





 





 





 





 



   




5110




 





 





 





 





 





 



  for(cart(\@a1,\@a2,\@a3)){ 




5111




 





 





 





 





 





 



    my($a1,$a2,$a3) = @$_; 




5112




 





 





 





 





 





 



    print "$a1,$a2,$a3\n"; 




5113




 





 





 





 





 





 



  } 




5114




 





 





 





 





 





 



   




5115




 





 





 





 





 





 



 Prints the same as this: 




5116




 





 





 





 





 





 



   




5117




 





 





 





 





 





 



  for my $a1 (@a1){ 




5118




 





 





 





 





 





 



    for my $a2 (@a2){ 




5119




 





 





 





 





 





 



      for my $a3 (@a3){ 




5120




 





 





 





 





 





 



        print "$a1,$a2,$a3\n"; 




5121




 





 





 





 





 





 



      } 




5122




 





 





 





 





 





 



    } 




5123




 





 





 





 





 





 



  } 




5124




 





 





 





 





 





 



   




5125




 





 





 





 





 





 



 B (with a condition: the sum of the first two should be dividable with 3) 




5126




 





 





 





 





 





 



   




5127




 





 





 





 





 





 



  for( cart( \@a1, \@a2, sub{sum(@$_)%3==0}, \@a3 ) ) { 




5128




 





 





 





 





 





 



    my($a1,$a2,$a3)=@$_; 




5129




 





 





 





 





 





 



    print "$a1,$a2,$a3\n"; 




5130




 





 





 





 





 





 



  } 




5131




 





 





 





 





 





 



   




5132




 





 





 





 





 





 



 Prints the same as this: 




5133




 





 





 





 





 





 



   




5134




 





 





 





 





 





 



  for my $a1 (@a1){ 




5135




 





 





 





 





 





 



    for my $a2 (@a2){ 




5136




 





 





 





 





 





 



      next if 0==($a1+$a2)%3; 




5137




 





 





 





 





 





 



      for my $a3 (@a3){ 




5138




 





 





 





 





 





 



        print "$a1,$a2,$a3\n"; 




5139




 





 





 





 





 





 



      } 




5140




 





 





 





 





 





 



    } 




5141




 





 





 





 





 





 



  } 




5142




 





 





 





 





 





 



   




5143




 





 





 





 





 





 



 B 




5144




 





 





 





 





 





 



   




5145




 





 





 





 





 





 



  my @a1 = (1,2); 




5146




 





 





 





 





 





 



  my @a2 = (10,20,30); 




5147




 





 





 





 





 





 



  my @a3 = (100,200,300,400); 




5148




 





 





 





 





 





 



   




5149




 





 





 





 





 





 



  my $s = join"", map "*".join(",",@$_), cart(\@a1,\@a2,\@a3); 




5150




 





 





 





 





 





 



  ok( $s eq  "*1,10,100*1,10,200*1,10,300*1,10,400*1,20,100*1,20,200" 




5151




 





 





 





 





 





 



            ."*1,20,300*1,20,400*1,30,100*1,30,200*1,30,300*1,30,400" 




5152




 





 





 





 





 





 



            ."*2,10,100*2,10,200*2,10,300*2,10,400*2,20,100*2,20,200" 




5153




 





 





 





 





 





 



            ."*2,20,300*2,20,400*2,30,100*2,30,200*2,30,300*2,30,400"); 




5154




 





 





 





 





 





 



   




5155




 





 





 





 





 





 



  $s=join"",map "*".join(",",@$_), cart(\@a1,\@a2,\@a3,sub{sum(@$_)%3==0}); 




5156




 





 





 





 





 





 



  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"); 




5157




 





 





 





 





 





 



   




5158




 





 





 





 





 





 



 B 




5159




 





 





 





 





 





 



   




5160




 





 





 





 





 





 



 Returns hashrefs instead of arrayrefs: 




5161




 





 





 





 





 





 



   




5162




 





 





 





 





 





 



  my @cards=cart(             #5200 cards: 100 decks of 52 cards 




5163




 





 





 





 





 





 



    deck  => [1..100], 




5164




 





 





 





 





 





 



    value => [qw/2 3 4 5 6 7 8 9 10 J Q K A/], 




5165




 





 





 





 





 





 



    col   => [qw/heart diamond club star/], 




5166




 





 





 





 





 





 



  ); 




5167




 





 





 





 





 





 



  for my $card ( mix(@cards) ) { 




5168




 





 





 





 





 





 



    print "From deck number $$card{deck} we got $$card{value} $$card{col}\n"; 




5169




 





 





 





 





 





 



  } 




5170




 





 





 





 





 





 



   




5171




 





 





 





 





 





 



 Note: using sub-ref filters do not work (yet) in hash-mode. Use grep on result instead. 




5172




 





 





 





 





 





 



   




5173




 





 





 





 





 





 



 =cut 




5174




 





 





 





 





 





 



   




5175




 





 





 





 





 





 



 sub cart { 




5176




5





 





 




  
5
  



  
1
  




850



   my @ars=@_; 




5177




5




  
100
  




 





 





 





17



   if(!ref($_[0])){ #if hash-mode detected 




5178




1





 




  
 33
  




 





 





2



     my(@k,@v); push@k,shift@ars and push@v,shift@ars while @ars; 




 




1





 





 





 





 





13



   




5179




1





 





 





 





 





7



     return map{my%h;@h{@k}=@$_;\%h}cart(@v); 




 




24





 





 





 





 





26



   




 




24





 





 





 





 





68



   




 




24





 





 





 





 





44



   




5180




 





 





 





 





 





 



   } 




5181




4





 





 





 





 





6



   my @res=map[$_],@{shift@ars}; 




 




4





 





 





 





 





20



   




5182




4





 





 





 





 





9



   for my $ar (@ars){ 




5183




9




  
100
  



  
 50
  




 





 





26



     @res=grep{&$ar(@$_)}@res and next if ref($ar) eq 'CODE'; 




 




24





 





 





 





 





51



   




5184




8





 





 





 





 





13



     @res=map{my$r=$_;map{[@$r,$_]}@$ar}@res; 




 




34





 





 





 





 





38



   




 




34





 





 





 





 





49



   




 




120





 





 





 





 





257



   




5185




 





 





 





 





 





 



   } 




5186




4





 





 





 





 





63



   return @res; 




5187




 





 





 





 





 





 



 } 




5188




 





 





 





 





 





 



   




5189




 





 





 





 





 





 



 sub cart_easy { #not tested/exported http://stackoverflow.com/questions/2457096/in-perl-how-can-i-get-the-cartesian-product-of-multiple-sets 




5190



  
0
  




 





 




  
0
  



  
0
  




0



   my $last = pop @_; 




5191



  
0
  



  
  0
  




 





 





 





0



   @_ ? (map {my$left=$_; map [@$left, $_], @$last } cart_easy(@_) ) 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5192




 





 





 





 





 





 



      : (map [$_], @$last); 




5193




 





 





 





 





 





 



 } 




5194




 





 





 





 





 





 



   




5195




 





 





 





 





 





 



 =head2 reduce 




5196




 





 





 





 





 





 



   




5197




 





 





 





 





 





 



 From: Why Functional Programming Matters: L 




5198




 





 





 





 





 





 



   




5199




 





 





 





 





 





 



 L 




5200




 





 





 





 





 





 



   




5201




 





 





 





 





 





 



 DON'T TRY THIS AT HOME, C PROGRAMMERS. 




5202




 





 





 





 





 





 



   




5203




 





 





 





 





 





 



  sub reduce (&@) { 




5204




 





 





 





 





 





 



    my ($proc, $first, @rest) = @_; 




5205




 





 





 





 





 





 



    return $first if @rest == 0; 




5206




 





 





 





 





 





 



    local ($a, $b) = ($first, reduce($proc, @rest)); 




5207




 





 





 





 





 





 



    return $proc->(); 




5208




 





 





 





 





 





 



  } 




5209




 





 





 





 





 





 



   




5210




 





 





 





 





 





 



 Many functions can then be implemented with very little code. Such as: 




5211




 





 





 





 





 





 



   




5212




 





 





 





 





 





 



  sub mean { (reduce {$a + $b} @_) / @_ } 




5213




 





 





 





 





 





 



   




5214




 





 





 





 





 





 



 =cut 




5215




 





 





 





 





 





 



   




5216




 





 





 





 





 





 



 sub reduce (&@) { 




5217



  
0
  




 





 




  
0
  



  
1
  




0



   my ($proc, $first, @rest) = @_; 




5218



  
0
  



  
  0
  




 





 





 





0



   return $first if @rest == 0; 




5219




28





 





 




  
28
  




 





135865



   no warnings; 




 




28





 





 





 





 





61



   




 




28





 





 





 





 





32373



   




5220



  
0
  




 





 





 





 





0



   local ($a, $b) = ($first, reduce($proc, @rest)); 




5221



  
0
  




 





 





 





 





0



   return $proc->(); 




5222




 





 





 





 





 





 



 } 




5223




 





 





 





 





 





 



   




5224




 





 





 





 





 





 



   




5225




 





 





 





 





 





 



 =head2 pivot 




5226




 





 





 





 





 





 



   




5227




 





 





 





 





 





 



 Resembles the pivot table function in Excel. 




5228




 





 





 





 





 





 



   




5229




 





 





 





 





 





 



 C is used to spread out a slim and long table to a visually improved layout. 




5230




 





 





 





 





 





 



   




5231




 





 





 





 





 





 



 For instance spreading out the results of C-selects from SQL: 




5232




 





 





 





 





 





 



   




5233




 





 





 





 





 





 



  pivot( arrayref, columnname1, columnname2, ...) 




5234




 





 





 





 





 





 



   




5235




 





 





 





 





 





 



  pivot( ref_to_array_of_arrayrefs, @list_of_names_to_down_fields ) 




5236




 





 





 





 





 





 



   




5237




 





 





 





 





 





 



 The first argument is a ref to a two dimensional table. 




5238




 





 





 





 





 





 



   




5239




 





 





 





 





 





 



 The rest of the arguments is a list which also signals the number of 




5240




 





 





 





 





 





 



 columns from left in each row that is ending up to the left of the 




5241




 





 





 





 





 





 



 data table, the rest ends up at the top and the last element of 




5242




 





 





 





 





 





 



 each row ends up as data. 




5243




 





 





 





 





 





 



   




5244




 





 





 





 





 





 



                    top1 top1 top1 top1 




5245




 





 





 





 





 





 



  left1 left2 left3 top2 top2 top2 top2 




5246




 





 





 





 





 





 



  ----- ----- ----- ---- ---- ---- ---- 




5247




 





 





 





 





 





 



                    data data data data 




5248




 





 





 





 





 





 



                    data data data data 




5249




 





 





 





 





 





 



                    data data data data 




5250




 





 





 





 





 





 



   




5251




 





 





 





 





 





 



 Example: 




5252




 





 





 





 





 





 



   




5253




 





 





 





 





 





 



  my @table=( 




5254




 





 





 





 





 





 



                ["1997","Gerd", "Weight", "Summer",66], 




5255




 





 





 





 





 





 



                ["1997","Gerd", "Height", "Summer",170], 




5256




 





 





 





 





 





 



                ["1997","Per",  "Weight", "Summer",75], 




5257




 





 





 





 





 





 



                ["1997","Per",  "Height", "Summer",182], 




5258




 





 





 





 





 





 



                ["1997","Hilde","Weight", "Summer",62], 




5259




 





 





 





 





 





 



                ["1997","Hilde","Height", "Summer",168], 




5260




 





 





 





 





 





 



                ["1997","Tone", "Weight", "Summer",70], 




5261




 





 





 





 





 





 



   




5262




 





 





 





 





 





 



                ["1997","Gerd", "Weight", "Winter",64], 




5263




 





 





 





 





 





 



                ["1997","Gerd", "Height", "Winter",158], 




5264




 





 





 





 





 





 



                ["1997","Per",  "Weight", "Winter",73], 




5265




 





 





 





 





 





 



                ["1997","Per",  "Height", "Winter",180], 




5266




 





 





 





 





 





 



                ["1997","Hilde","Weight", "Winter",61], 




5267




 





 





 





 





 





 



                ["1997","Hilde","Height", "Winter",164], 




5268




 





 





 





 





 





 



                ["1997","Tone", "Weight", "Winter",69], 




5269




 





 





 





 





 





 



   




5270




 





 





 





 





 





 



                ["1998","Gerd", "Weight", "Summer",64], 




5271




 





 





 





 





 





 



                ["1998","Gerd", "Height", "Summer",171], 




5272




 





 





 





 





 





 



                ["1998","Per",  "Weight", "Summer",76], 




5273




 





 





 





 





 





 



                ["1998","Per",  "Height", "Summer",182], 




5274




 





 





 





 





 





 



                ["1998","Hilde","Weight", "Summer",62], 




5275




 





 





 





 





 





 



                ["1998","Hilde","Height", "Summer",168], 




5276




 





 





 





 





 





 



                ["1998","Tone", "Weight", "Summer",70], 




5277




 





 





 





 





 





 



   




5278




 





 





 





 





 





 



                ["1998","Gerd", "Weight", "Winter",64], 




5279




 





 





 





 





 





 



                ["1998","Gerd", "Height", "Winter",171], 




5280




 





 





 





 





 





 



                ["1998","Per",  "Weight", "Winter",74], 




5281




 





 





 





 





 





 



                ["1998","Per",  "Height", "Winter",183], 




5282




 





 





 





 





 





 



                ["1998","Hilde","Weight", "Winter",62], 




5283




 





 





 





 





 





 



                ["1998","Hilde","Height", "Winter",168], 




5284




 





 





 





 





 





 



                ["1998","Tone", "Weight", "Winter",71], 




5285




 





 





 





 





 





 



              ); 




5286




 





 





 





 





 





 



   




5287




 





 





 





 





 





 



 . 




5288




 





 





 





 





 





 



   




5289




 





 





 





 





 





 



  my @reportA=pivot(\@table,"Year","Name"); 




5290




 





 





 





 





 





 



  print "\n\nReport A\n\n".tablestring(\@reportA); 




5291




 





 





 





 





 





 



   




5292




 





 





 





 





 





 



 Will print: 




5293




 





 





 





 





 





 



   




5294




 





 





 





 





 





 



  Report A 




5295




 





 





 





 





 





 



   




5296




 





 





 





 





 





 



  Year Name  Height Height Weight Weight 




5297




 





 





 





 





 





 



             Summer Winter Summer Winter 




5298




 





 





 





 





 





 



  ---- ----- ------ ------ ------ ------ 




5299




 





 





 





 





 





 



  1997 Gerd  170    158    66     64 




5300




 





 





 





 





 





 



  1997 Hilde 168    164    62     61 




5301




 





 





 





 





 





 



  1997 Per   182    180    75     73 




5302




 





 





 





 





 





 



  1997 Tone                70     69 




5303




 





 





 





 





 





 



  1998 Gerd  171    171    64     64 




5304




 





 





 





 





 





 



  1998 Hilde 168    168    62     62 




5305




 





 





 





 





 





 



  1998 Per   182    183    76     74 




5306




 





 





 





 





 





 



  1998 Tone                70     71 




5307




 





 





 





 





 





 



   




5308




 





 





 





 





 





 



 . 




5309




 





 





 





 





 





 



   




5310




 





 





 





 





 





 



  my @reportB=pivot([map{$_=[@$_[0,3,2,1,4]]}(@t=@table)],"Year","Season"); 




5311




 





 





 





 





 





 



  print "\n\nReport B\n\n".tablestring(\@reportB); 




5312




 





 





 





 





 





 



   




5313




 





 





 





 





 





 



 Will print: 




5314




 





 





 





 





 





 



   




5315




 





 





 





 





 





 



  Report B 




5316




 





 





 





 





 





 



   




5317




 





 





 





 





 





 



  Year Season Height Height Height Weight Weight Weight Weight 




5318




 





 





 





 





 





 



              Gerd   Hilde  Per    Gerd   Hilde  Per    Tone 




5319




 





 





 





 





 





 



  ---- ------ ------ ------ -----  -----  ------ ------ ------ 




5320




 





 





 





 





 





 



  1997 Summer 170    168    182    66     62     75     70 




5321




 





 





 





 





 





 



  1997 Winter 158    164    180    64     61     73     69 




5322




 





 





 





 





 





 



  1998 Summer 171    168    182    64     62     76     70 




5323




 





 





 





 





 





 



  1998 Winter 171    168    183    64     62     74     71 




5324




 





 





 





 





 





 



   




5325




 





 





 





 





 





 



 . 




5326




 





 





 





 





 





 



   




5327




 





 





 





 





 





 



  my @reportC=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name","Attributt"); 




5328




 





 





 





 





 





 



  print "\n\nReport C\n\n".tablestring(\@reportC); 




5329




 





 





 





 





 





 



   




5330




 





 





 





 





 





 



 Will print: 




5331




 





 





 





 





 





 



   




5332




 





 





 





 





 





 



  Report C 




5333




 





 





 





 





 





 



   




5334




 





 





 





 





 





 



  Name  Attributt 1997   1997   1998   1998 




5335




 





 





 





 





 





 



                  Summer Winter Summer Winter 




5336




 





 





 





 





 





 



  ----- --------- ------ ------ ------ ------ 




5337




 





 





 





 





 





 



  Gerd  Height     170    158    171    171 




5338




 





 





 





 





 





 



  Gerd  Weight      66     64     64     64 




5339




 





 





 





 





 





 



  Hilde Height     168    164    168    168 




5340




 





 





 





 





 





 



  Hilde Weight      62     61     62     62 




5341




 





 





 





 





 





 



  Per   Height     182    180    182    183 




5342




 





 





 





 





 





 



  Per   Weight      75     73     76     74 




5343




 





 





 





 





 





 



  Tone  Weight      70     69     70     71 




5344




 





 





 





 





 





 



   




5345




 





 





 





 





 





 



 . 




5346




 





 





 





 





 





 



   




5347




 





 





 





 





 





 



  my @reportD=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name"); 




5348




 





 





 





 





 





 



  print "\n\nReport D\n\n".tablestring(\@reportD); 




5349




 





 





 





 





 





 



   




5350




 





 





 





 





 





 



 Will print: 




5351




 





 





 





 





 





 



   




5352




 





 





 





 





 





 



  Report D 




5353




 





 





 





 





 





 



   




5354




 





 





 





 





 





 



  Name  Height Height Height Height Weight Weight Weight Weight 




5355




 





 





 





 





 





 



        1997   1997   1998   1998   1997   1997   1998   1998 




5356




 





 





 





 





 





 



        Summer Winter Summer Winter Summer Winter Summer Winter 




5357




 





 





 





 





 





 



  ----- ------ ------ ------ ------ ------ ------ ------ ------ 




5358




 





 





 





 





 





 



  Gerd  170    158    171    171    66     64     64     64 




5359




 





 





 





 





 





 



  Hilde 168    164    168    168    62     61     62     62 




5360




 





 





 





 





 





 



  Per   182    180    182    183    75     73     76     74 




5361




 





 





 





 





 





 



  Tone                              70     69     70     71 




5362




 





 





 





 





 





 



   




5363




 





 





 





 





 





 



 Options: 




5364




 





 





 





 





 





 



   




5365




 





 





 





 





 





 



 Options to sort differently and show sums and percents are available. (...MORE DOC ON THAT LATER...) 




5366




 





 





 





 





 





 



   




5367




 





 





 





 





 





 



 See also L 




5368




 





 





 





 





 





 



   




5369




 





 





 





 





 





 



 =cut 




5370




 





 





 





 





 





 



   




5371




 





 





 





 





 





 



 sub pivot { 




5372




4





 





 




  
4
  



  
1
  




11



   my($tabref,@vertikalefelt)=@_; 




5373




4




  
 50
  




 





 





 





15



   my %opt=ref($vertikalefelt[-1]) eq 'HASH' ? %{pop(@vertikalefelt)} : (); 




 



  
0
  




 





 





 





 





0



   




5374




4




  
 50
  




 





 





 





16



   my $opt_sum=1 if $opt{sum}; 




5375




4




  
 50
  



  
  0
  




 





 





8



   my $opt_pro=exists $opt{prosent}?$opt{prosent}||0:undef; 




5376




4





 




  
 50
  




 





 





23



   my $sortsub          = $opt{'sortsub'}          || \&_sortsub; 




5377




4





 




  
 33
  




 





 





18



   my $sortsub_bortover = $opt{'sortsub_bortover'} || $sortsub; 




5378




4





 




  
 33
  




 





 





29



   my $sortsub_nedover  = $opt{'sortsub_nedover'}  || $sortsub; 




5379




 





 





 





 





 





 



   #print serialize(\%opt,'opt'); 




5380




 





 





 





 





 





 



   #print serialize(\$opt_pro,'opt_pro'); 




5381




4





 





 





 





 





7



   my $antned=0+@vertikalefelt; 




5382




4





 





 





 





 





7



   my $bakerst=-1+@{$$tabref[0]}; 




 




4





 





 





 





 





10



   




5383




4





 





 





 





 





5



   my(%h,%feltfinnes,%sum); 




5384




 





 





 





 





 





 



   #print "Bakerst<$bakerst>\n"; 




5385




4





 





 





 





 





9



   for(@$tabref){ 




5386




112





 





 





 





 





256



     my $rad=join($;,@$_[0..($antned-1)]); 




5387




112





 





 





 





 





222



     my $felt=join($;,@$_[$antned..($bakerst-1)]); 




5388




112





 





 





 





 





150



     my $verdi=$$_[$bakerst]; 




5389




112




  
 50
  




 





 





 





240



     length($rad) or $rad=' '; 




5390




112




  
 50
  




 





 





 





185



     length($felt) or $felt=' '; 




5391




112





 





 





 





 





227



     $h{$rad}{$felt}=$verdi; 




5392




112





 





 





 





 





239



     $h{$rad}{"%$felt"}=$verdi; 




5393




112




  
 50
  



  
 33
  




 





 





411



     if($opt_sum or defined $opt_pro){ 




5394



  
0
  




 





 





 





 





0



       $h{$rad}{Sum}+=$verdi; 




5395



  
0
  




 





 





 





 





0



       $sum{$felt}+=$verdi; 




5396



  
0
  




 





 





 





 





0



       $sum{Sum}+=$verdi; 




5397




 





 





 





 





 





 



     } 




5398




112





 





 





 





 





164



     $feltfinnes{$felt}++; 




5399




112




  
 50
  




 





 





 





319



     $feltfinnes{"%$felt"}++ if $opt_pro; 




5400




 





 





 





 





 





 



   } 




5401




4





 





 





 





 





26



   my @feltfinnes = sort $sortsub_bortover keys%feltfinnes; 




5402




4




  
 50
  




 





 





 





12



   push @feltfinnes, "Sum" if $opt_sum; 




5403




4





 





 





 





 





8



   my @t=([@vertikalefelt,map{replace($_,$;,"\n")}@feltfinnes]); 




 




23





 





 





 





 





42



   




5404




 





 





 





 





 





 



   #print serialize(\@feltfinnes,'feltfinnes'); 




5405




 





 





 





 





 





 



   #print serialize(\%h,'h'); 




5406




 





 





 





 





 





 



   #print "H = ".join(", ",sort _sortsub keys%h)."\n"; 




5407




4





 





 





 





 





18



   for my $rad (sort $sortsub_nedover keys(%h)){ 




5408




 





 





 





 





 





 



     my @rad=(split($;,$rad), 




5409




 





 





 





 





 





 



 	     map{ 




5410




23




  
 50
  



  
 33
  




 





 





154



 	       if(/^\%/ and defined $opt_pro){ 




 




120





 





 





 





 





309



   




5411



  
0
  




 





 





 





 





0



 		 my $sum=$h{$rad}{Sum}; 




5412



  
0
  




 





 





 





 





0



 		 my $verdi=$h{$rad}{$_}; 




5413



  
0
  



  
  0
  




 





 





 





0



 		 if($sum!=0){ 




5414



  
0
  



  
  0
  




 





 





 





0



 		   defined $verdi 




5415




 





 





 





 





 





 



                    ?sprintf("%*.*f",3+1+$opt_pro,$opt_pro,100*$verdi/$sum) 




5416




 





 





 





 





 





 



 		   :$verdi; 




5417




 





 





 





 





 





 



 		 } 




5418




 





 





 





 





 





 



 		 else{ 




5419



  
0
  



  
  0
  




 





 





 





0



 		   $verdi!=0?"div0":$verdi; 




5420




 





 





 





 





 





 



 		 } 




5421




 





 





 





 





 





 



 	       } 




5422




 





 





 





 





 





 



 	       else{ 




5423




120





 





 





 





 





243



 		 $h{$rad}{$_}; 




5424




 





 





 





 





 





 



 	       } 




5425




 





 





 





 





 





 



 	     } 




5426




 





 





 





 





 





 



 	     @feltfinnes); 




5427




23





 





 





 





 





84



     push(@t,[@rad]); 




5428




 





 





 





 





 





 



   } 




5429




4




  
 50
  




 





 





 





12



   push(@t,"-",["Sum",(map{""}(2..$antned)),map{print "<$_>\n";$sum{$_}}@feltfinnes]) if $opt_sum; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5430




4





 





 





 





 





53



   return @t; 




5431




 





 





 





 





 





 



 } 




5432




 





 





 





 





 





 



   




5433




 





 





 





 





 





 



 # default sortsub for pivot() 




5434




 





 





 





 





 





 



   




5435




 





 





 





 





 





 



 sub _sortsub { 




5436




28





 





 




  
28
  




 





160



   no warnings; 




 




28





 





 





 





 





47



   




 




28





 





 





 





 





13139



   




5437




 





 





 





 





 





 



   #my $c=($a<=>$b)||($a cmp $b); 




5438




 





 





 





 





 





 



   #return $c if $c; 




5439




 





 





 





 





 





 



   #printf "%-30s %-30s  ",replace($a,$;,','),replace($b,$;,','); 




5440




72





 





 




  
72
  




 





489



   my @a=split $;,$a; 




5441




72





 





 





 





 





470



   my @b=split $;,$b; 




5442




72





 





 





 





 





172



   for(0..$#a){ 




5443




110





 





 





 





 





232



     my $c=$a[$_]<=>$b[$_]; 




5444




110




  
100
  



  
 66
  




 





 





398



     return $c if $c and "$a[$_]$b[$_]"!~/[iI][nN][fF]|þ/i; # inf(inity) 




5445




96





 





 





 





 





125



     $c=$a[$_]cmp$b[$_]; 




5446




96




  
100
  




 





 





 





274



     return $c if $c; 




5447




 





 





 





 





 





 



   } 




5448



  
0
  




 





 





 





 





0



   return 0; 




5449




 





 





 





 





 





 



 } 




5450




 





 





 





 





 





 



   




5451




 





 





 





 





 





 



 =head2 tablestring 




5452




 





 





 





 





 





 



   




5453




 





 





 





 





 





 



 B a reference to an array of arrayrefs  -- a two dimensional table of strings and numbers 




5454




 





 





 





 





 





 



   




5455




 





 





 





 





 





 



 B a string containing the textual table -- a string of two or more lines 




5456




 





 





 





 





 





 



   




5457




 





 





 





 





 





 



 The first arrayref in the list refers to a list of either column headings (scalar) 




5458




 





 





 





 





 





 



 or ... (...more later...) 




5459




 





 





 





 





 





 



   




5460




 





 





 





 





 





 



 In this output table: 




5461




 





 





 





 





 





 



   




5462




 





 





 





 





 





 



 - the columns will not be wider than necessary by its widest value (any -tags are removed in every internal width-calculation) 




5463




 





 





 





 





 





 



   




5464




 





 





 





 





 





 



 - multi-lined cell values are handled also 




5465




 





 





 





 





 





 



   




5466




 





 





 





 





 





 



 - and so are html-tags, if the output is to be used inside -tags on a web page. 




5467




 





 





 





 





 





 



   




5468




 





 





 





 





 





 



 - columns with just numeric values are right justified (header row excepted) 




5469




 





 





 





 





 





 



   




5470




 





 





 





 





 





 



 Example: 




5471




 





 





 





 





 





 



   




5472




 





 





 





 





 





 



  print tablestring([ 




5473




 





 





 





 





 





 



    [qw/AA BB CCCC/], 




5474




 





 





 





 





 





 



    [123,23,"d"], 




5475




 





 





 





 





 





 



    [12,23,34], 




5476




 





 





 





 





 





 



    [77,88,99], 




5477




 





 





 





 





 





 



    ["lin\nes",12,"asdff\nfdsa\naa"],[0,22,"adf"] 




5478




 





 





 





 





 





 



  ]); 




5479




 





 





 





 





 





 



   




5480




 





 





 





 





 





 



 Prints this string of 11 lines: 




5481




 





 





 





 





 





 



   




5482




 





 





 





 





 





 



  AA  BB CCCC 




5483




 





 





 





 





 





 



  --- -- ----- 




5484




 





 





 





 





 





 



  123 23 d 




5485




 





 





 





 





 





 



  12  23 34 




5486




 





 





 





 





 





 



  77   8 99 




5487




 





 





 





 





 





 



   




5488




 





 





 





 





 





 



  lin 12 asdff 




5489




 





 





 





 





 





 



  es     fdsa 




5490




 





 





 





 





 





 



         aa 




5491




 





 





 





 





 





 



   




5492




 





 





 





 





 





 



  10  22 adf 




5493




 





 





 





 





 





 



   




5494




 





 





 





 





 





 



 As you can see, rows containing multi-lined cells gets an empty line before and after the row to separate it more clearly. 




5495




 





 





 





 





 





 



   




5496




 





 





 





 





 





 



 =cut 




5497




 





 





 





 





 





 



   




5498




 





 





 





 





 





 



 sub tablestring { 




5499




5





 





 




  
5
  



  
1
  




27



   my $tab=shift; 




5500




5




  
 50
  




 





 





 





14



   my %o=$_[0] ? %{shift()} : (); 




 



  
0
  




 





 





 





 





0



   




5501




5





 





 





 





 





8



   my $fjern_tom=$o{fjern_tomme_kolonner}; 




5502




5





 





 





 





 





8



   my $ikke_space=$o{ikke_space}; 




5503




5





 




  
 50
  




 





 





23



   my $nodup=$o{nodup}||0; 




5504




5





 





 





 





 





7



   my $ikke_hodestrek=$o{ikke_hodestrek}; 




5505




5




  
 50
  




 





 





 





13



   my $pagesize=exists $o{pagesize} ? $o{pagesize}-3 : 9999999; 




5506




5





 





 





 





 





6



   my $venstretvang=$o{venstre}; 




5507




5





 





 





 





 





6



   my(@bredde,@venstre,@hoeyde,@ikketom,@nodup); 




5508




5





 





 





 





 





7



   my $hode=1; 




5509




5





 





 





 





 





8



   my $i=0; 




5510




5





 





 





 





 





8



   my $j; 




5511




5





 





 





 





 





11



   for(@$tab){ 




5512




33





 





 





 





 





34



     $j=0; 




5513




33





 





 





 





 





43



     $hoeyde[$i]=0; 




5514




33





 





 





 





 





37



     my $nodup_rad=$nodup; 




5515




33




  
 50
  




 





 





 





72



     if(ref($_) eq 'ARRAY'){ 




5516




33





 





 





 





 





53



       for(@$_){ 




5517




210





 





 





 





 





272



 	my $celle=$_; 




5518




210





 




  
100
  




 





 





431



 	$bredde[$j]||=0; 




5519




210




  
 50
  



  
 33
  




 





 





582



 	if($nodup_rad and $i>0 and $$tab[$i][$j] eq $$tab[$i-1][$j] || ($nodup_rad=0)){ 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
 33
  




 





 





 



   




5520



  
0
  



  
  0
  




 





 





 





0



 	  $celle=$nodup==1?"":$nodup; 




5521



  
0
  




 





 





 





 





0



 	  $nodup[$i][$j]=1; 




5522




 





 





 





 





 





 



 	} 




5523




 





 





 





 





 





 



 	else{ 




5524




210





 





 





 





 





213



 	  my $hoeyde=0; 




5525




210





 





 





 





 





201



 	  my $bredere; 




5526




28





 





 




  
28
  




 





1335



 	  no warnings; 




 




28





 





 





 





 





1237



   




 




28





 





 





 





 





16611



   




5527




210




  
100
  



  
100
  




 





 





799



 	  $ikketom[$j]=1 if !$hode && length($celle)>0; 




5528




210





 





 





 





 





445



 	  for(split("\n",$celle)){ 




5529




236




  
 50
  




 





 





 





411



 	    $bredere=/




5530




236





 





 





 





 





277



 	    s/<[^>]+>//g; 




5531




236





 





 





 





 





239



 	    $hoeyde++; 




5532




236





 





 





 





 





265



 	    s/>/>/g; 




5533




236





 





 





 





 





258



 	    s/</




5534




236




  
100
  




 





 





 





585



 	    $bredde[$j]=length($_)+1+$bredere if length($_)+1+$bredere>$bredde[$j]; 




5535




236




  
100
  



  
100
  




 





 





1545



 	    $venstre[$j]=1 if $_ && !/^\s*[\-\+]?(\d+|\d*\.\d+)\s*\%?$/ && !$hode; 




 




 





 




  
100
  




 





 





 



   




5536




 





 





 





 





 





 



 	  } 




5537




210




  
100
  



  
 66
  




 





 





614



 	  if( $hoeyde>1 && !$ikke_space){ 




5538




25




  
100
  




 





 





 





53



 	    $hoeyde++ unless $hode; 




5539




25




  
100
  



  
100
  




 





 





69



 	    $hoeyde[$i-1]++ if $i>1 && $hoeyde[$i-1]==1; 




5540




 





 





 





 





 





 



 	  } 




5541




210




  
100
  




 





 





 





477



 	  $hoeyde[$i]=$hoeyde if $hoeyde>$hoeyde[$i]; 




5542




 





 





 





 





 





 



 	} 




5543




210





 





 





 





 





279



 	$j++; 




5544




 





 





 





 





 





 



       } 




5545




 





 





 





 





 





 



     } 




5546




 





 





 





 





 





 



     else{ 




5547



  
0
  




 





 





 





 





0



       $hoeyde[$i]=1; 




5548



  
0
  




 





 





 





 





0



       $ikke_hodestrek=1; 




5549




 





 





 





 





 





 



     } 




5550




33





 





 





 





 





37



     $hode=0; 




5551




33





 





 





 





 





50



     $i++; 




5552




 





 





 





 





 





 



   } 




5553




5





 





 





 





 





9



   $i=$#hoeyde; 




5554




5





 





 





 





 





7



   $j=$#bredde; 




5555




5




  
 50
  



  
 33
  




 





 





24



   if($i==0 or $venstretvang) { @venstre=map{1}(0..$j)                         } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5556




5




  
 50
  




 





 





 





11



   else { for(0..$j){ $venstre[$_]=1 if !$ikketom[$_] }  } 




 




33





 





 





 





 





68



   




5557




5





 





 





 





 





8



   my @tabut; 




5558




5





 





 





 





 





5



   my $rad_startlinje=0; 




5559




5





 





 





 





 





8



   my @overskrift; 




5560




 





 





 





 





 





 



   my $overskrift_forrige; 




5561




5





 





 





 





 





8



   for my $x (0..$i){ 




5562




33




  
 50
  




 





 





 





88



     if($$tab[$x] eq '-'){ 




5563



  
0
  



  
  0
  




 





 





 





0



       my @tegn=map {$$tab[$x-1][$_]=~/\S/?"-":" "} (0..$j); 




 



  
0
  




 





 





 





 





0



   




5564



  
0
  




 





 





 





 





0



       $tabut[$rad_startlinje]=join(" ",map {$tegn[$_] x ($bredde[$_]-1)} (0..$j)); 




 



  
0
  




 





 





 





 





0



   




5565




 





 





 





 





 





 



     } 




5566




 





 





 





 





 





 



     else{ 




5567




33





 





 





 





 





54



       for my $y (0..$j){ 




5568




210




  
 50
  



  
 33
  




 





 





464



 	next if $fjern_tom && !$ikketom[$y]; 




5569




28





 





 




  
28
  




 





1318



 	no warnings; 




 




28





 





 





 





 





49



   




 




28





 





 





 





 





22085



   




5570




 





 





 





 





 





 



 	 




5571




210




  
  0
  



  
 33
  




 





 





1343



 	my @celle= 




 




 




  
 50
  




 





 





 





 



   




5572




 





 





 





 





 





 



             !$overskrift_forrige&&$nodup&&$nodup[$x][$y] 




5573




 





 





 





 





 





 



 	    ?($nodup>0?():((" " x (($bredde[$y]-length($nodup))/2)).$nodup)) 




5574




 





 





 





 





 





 



             :split("\n",$$tab[$x][$y]); 




5575




210





 





 





 





 





434



 	for(0..($hoeyde[$x]-1)){ 




5576




261





 





 





 





 





310



 	  my $linje=$rad_startlinje+$_; 




5577




261





 




  
100
  




 





 





606



 	  my $txt=shift @celle || ''; 




5578




261




  
100
  



  
100
  




 





 





1489



 	  $txt=sprintf("%*s",$bredde[$y]-1,$txt) if length($txt)>0 && !$venstre[$y] && ($x>0 || $ikke_hodestrek); 




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 66
  




 





 





 



   




5579




261





 





 





 





 





374



 	  $tabut[$linje].=$txt; 




5580




261




  
100
  




 





 





 





431



 	  if($y==$j){ 




5581




42





 





 





 





 





185



 	    $tabut[$linje]=~s/\s+$//; 




5582




 





 





 





 





 





 



 	  } 




5583




 





 





 





 





 





 



 	  else{ 




5584




219





 





 





 





 





223



 	    my $bredere; 




5585




219




  
 50
  




 





 





 





399



 	       $bredere = $txt=~/




5586




219





 





 





 





 





275



 	    $txt=~s/<[^>]+>//g; 




5587




219





 





 





 





 





271



 	    $txt=~s/>/>/g; 




5588




219





 





 





 





 





245



 	    $txt=~s/</




5589




219





 





 





 





 





591



 	    $tabut[$linje].= ' ' x ($bredde[$y]-length($txt)-$bredere); 




5590




 





 





 





 





 





 



 	  } 




5591




 





 





 





 





 





 



 	} 




5592




 





 





 





 





 





 



       } 




5593




 





 





 





 





 





 



     } 




5594




33





 





 





 





 





45



     $rad_startlinje+=$hoeyde[$x]; 




5595




 





 





 





 





 





 



   




5596




 





 





 





 





 





 



     #--lage streker? 




5597




33




  
 50
  




 





 





 





63



     if(not $ikke_hodestrek){ 




5598




33




  
100
  



  
 33
  




 





 





155



       if($x==0){ 




 




 




  
 50
  



  
 33
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




5599




5





 





 





 





 





9



 	for my $y (0..$j){ 




5600




33




  
 50
  



  
 33
  




 





 





64



 	  next if $fjern_tom && !$ikketom[$y]; 




5601




33





 





 





 





 





68



 	  $tabut[$rad_startlinje].=('-' x ($bredde[$y]-1))." "; 




5602




 





 





 





 





 





 



 	} 




5603




5





 





 





 





 





8



 	$rad_startlinje++; 




5604




5





 





 





 





 





15



 	@overskrift=("",@tabut); 




5605




 





 





 





 





 





 



       } 




5606




 





 





 





 





 





 



       elsif( 




5607




 





 





 





 





 





 



 	    $x%$pagesize==0 || $nodup>0&&!$nodup[$x+1][$nodup-1] 




5608




 





 





 





 





 





 



 	    and $x+1<@$tab 




5609




 





 





 





 





 





 



 	    and !$ikke_hodestrek 




5610




 





 





 





 





 





 



 	    ) 




5611




 





 





 





 





 





 



       { 




5612



  
0
  




 





 





 





 





0



 	push(@tabut,@overskrift); 




5613



  
0
  




 





 





 





 





0



 	$rad_startlinje+=@overskrift; 




5614



  
0
  




 





 





 





 





0



 	$overskrift_forrige=1; 




5615




 





 





 





 





 





 



       } 




5616




 





 





 





 





 





 



       else{ 




5617




28





 





 





 





 





52



 	$overskrift_forrige=0; 




5618




 





 





 





 





 





 



       } 




5619




 





 





 





 





 





 



     } 




5620




 





 





 





 





 





 



   }#for x 




5621




5





 





 





 





 





56



   return join("\n",@tabut)."\n"; 




5622




 





 





 





 





 





 



 } 




5623




 





 





 





 





 





 



   




5624




 





 





 





 





 





 



 =head2 serialize 




5625




 





 





 





 





 





 



   




5626




 





 





 





 





 





 



 Returns a data structure as a string. See also C 




5627




 





 





 





 





 





 



 (serialize was created long time ago before Data::Dumper appeared on 




5628




 





 





 





 





 





 



 CPAN, before CPAN even...) 




5629




 





 





 





 





 





 



   




5630




 





 





 





 





 





 



 B One to four arguments. 




5631




 





 





 





 





 





 



   




5632




 





 





 





 





 





 



 First argument: A reference to the structure you want. 




5633




 





 





 





 





 





 



   




5634




 





 





 





 





 





 



 Second argument: (optional) The name the structure will get in the output string. 




5635




 





 





 





 





 





 



 If second argument is missing or is undef or '', it will get no name in the output. 




5636




 





 





 





 





 





 



   




5637




 





 





 





 





 





 



 Third argument: (optional) The string that is returned is also put 




5638




 





 





 





 





 





 



 into a created file with the name given in this argument.  Putting a 




5639




 





 





 





 





 





 



 C<< > >> char in from of the filename will append that file 




5640




 





 





 





 





 





 



 instead. Use C<''> or C to not write to a file if you want to 




5641




 





 





 





 





 





 



 use a fourth argument. 




5642




 





 





 





 





 





 



   




5643




 





 





 





 





 





 



 Fourth argument: (optional) A number signalling the depth on which newlines is used in the output. 




5644




 





 





 





 





 





 



 The default is infinite (some big number) so no extra newlines are output. 




5645




 





 





 





 





 





 



   




5646




 





 





 





 





 





 



 B A string containing the perl-code definition that makes that data structure. 




5647




 





 





 





 





 





 



 The input reference (first input argument) can be to an array, hash or a string. 




5648




 





 





 





 





 





 



 Those can contain other refs and strings in a deep data structure. 




5649




 





 





 





 





 





 



   




5650




 





 





 





 





 





 



 Limitations: 




5651




 





 





 





 





 





 



   




5652




 





 





 





 





 





 



 - Code refs are not handled (just returns C) 




5653




 





 





 





 





 





 



   




5654




 





 





 





 





 





 



 - Regex, class refs and circular recursive structures are also not handled. 




5655




 





 





 





 





 





 



   




5656




 





 





 





 





 





 



 B 




5657




 





 





 





 





 





 



   




5658




 





 





 





 





 





 



   $a = 'test'; 




5659




 





 





 





 





 





 



   @b = (1,2,3); 




5660




 





 





 





 





 





 



   %c = (1=>2, 2=>3, 3=>5, 4=>7, 5=>11); 




5661




 





 





 





 





 





 



   %d = (1=>2, 2=>3, 3=>\5, 4=>7, 5=>11, 6=>[13,17,19,{1,2,3,'asdf\'\\\''}],7=>'x'); 




5662




 





 





 





 





 





 



   print serialize(\$a,'a'); 




5663




 





 





 





 





 





 



   print serialize(\@b,'tab'); 




5664




 





 





 





 





 





 



   print serialize(\%c,'c'); 




5665




 





 





 





 





 





 



   print serialize(\%d,'d'); 




5666




 





 





 





 





 





 



   print serialize(\("test'n roll",'brb "brb"')); 




5667




 





 





 





 





 





 



   print serialize(\%d,'d',undef,1); 




5668




 





 





 





 





 





 



   




5669




 





 





 





 





 





 



 Prints accordingly: 




5670




 





 





 





 





 





 



   




5671




 





 





 





 





 





 



  $a='test'; 




5672




 





 





 





 





 





 



  @tab=('1','2','3'); 




5673




 





 





 





 





 





 



  %c=('1','2','2','3','3','5','4','7','5','11'); 




5674




 





 





 





 





 





 



  %d=('1'=>'2','2'=>'3','3'=>\'5','4'=>'7','5'=>'11','6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}]); 




5675




 





 





 





 





 





 



  ('test\'n roll','brb "brb"'); 




5676




 





 





 





 





 





 



  %d=('1'=>'2', 




5677




 





 





 





 





 





 



  '2'=>'3', 




5678




 





 





 





 





 





 



  '3'=>\'5', 




5679




 





 





 





 





 





 



  '4'=>'7', 




5680




 





 





 





 





 





 



  '5'=>'11', 




5681




 





 





 





 





 





 



  '6'=>['13','17','19',{'1'=>'2','3'=>'asdf\'\\\''}], 




5682




 





 





 





 





 





 



  '7'=>'x'); 




5683




 





 





 





 





 





 



   




5684




 





 





 





 





 





 



 Areas of use: 




5685




 





 





 





 





 





 



   




5686




 





 





 





 





 





 



 - Debugging (first and foremost) 




5687




 





 





 





 





 





 



   




5688




 





 





 





 





 





 



 - Storing arrays and hashes and data structures of those on file, database or sending them over the net 




5689




 





 





 





 





 





 



   




5690




 





 





 





 





 





 



 - eval earlier stored string to get back the data structure 




5691




 





 





 





 





 





 



   




5692




 





 





 





 





 





 



 Be aware of the security implications of Cing a perl code string 




5693




 





 





 





 





 





 



 stored somewhere that unauthorized users can change them! You are 




5694




 





 





 





 





 





 



 probably better of using L or L without 




5695




 





 





 





 





 





 



 enabling the CODE-options if you have such security issues. 




5696




 





 





 





 





 





 



 More on decompiling Perl-code: L or L. 




5697




 





 





 





 





 





 



   




5698




 





 





 





 





 





 



 =head2 dserialize 




5699




 





 





 





 





 





 



   




5700




 





 





 





 





 





 



 Debug-serialize, dumping data structures for you to look at. 




5701




 





 





 





 





 





 



   




5702




 





 





 





 





 





 



 Same as C but the output is given a newline every 80th character. 




5703




 





 





 





 





 





 



 (Every 80th or whatever C<$Acme::Tools::Dserialize_width> contains) 




5704




 





 





 





 





 





 



   




5705




 





 





 





 





 





 



 =cut 




5706




 





 





 





 





 





 



   




5707




 





 





 





 





 





 



 our $Dserialize_width=80; 




5708



  
0
  




 




  
  0
  



  
0
  




 





0



 sub _kallstack { my $tilbake=shift||0; my @c; my $ret; $ret.=serialize(\@c,"caller$tilbake") while @c=caller(++$tilbake); $ret } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5709



  
0
  




 





 




  
0
  



  
1
  




0



 sub dserialize{join "\n",serialize(@_)=~/(.{1,$Dserialize_width})/gs} 




5710




 





 





 





 





 





 



 sub serialize { 




5711




28





 





 




  
28
  




 





150



   no warnings; 




 




28





 





 





 





 





48



   




 




28





 





 





 





 





127928



   




5712




1127





 





 




  
1127
  



  
1
  




4775



   my($r,$name,$filename,$level)=@_; 




5713




1127





 




  
100
  




 





 





3033



   my @r=(undef,undef,($level||0)-1); 




5714




1127




  
 50
  




 





 





 





2122



   if($filename){ 




5715



  
0
  



  
  0
  




 





 





 





0



     open my $fh, '>', $filename or croak("FEIL: could not open file $filename\n" . _kallstack()); 




5716



  
0
  




 





 





 





 





0



     my $ret=serialize($r,$name,undef,$level); 




5717



  
0
  




 





 





 





 





0



     print $fh "$ret\n1;\n"; 




5718



  
0
  




 





 





 





 





0



     close($fh); 




5719



  
0
  




 





 





 





 





0



     return $ret; 




5720




 





 





 





 





 





 



   } 




5721




1127




  
100
  




 





 





 





2884



   if(ref($r) eq 'SCALAR'){ 




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




5722




903




  
 50
  




 





 





 





1580



     return "\$$name=".serialize($r,@r).";\n" if $name; 




5723




903




  
100
  




 





 





 





1692



     return "undef" unless defined $$r; 




5724




899





 





 





 





 





1128



     my $ret=$$r; 




5725




899





 





 





 





 





1410



     $ret=~s/\\/\\\\/g; 




5726




899





 





 





 





 





1140



     $ret=~s/\'/\\'/g; 




5727




899





 





 





 





 





2785



     return "'$ret'"; 




5728




 





 





 





 





 





 



   } 




5729




 





 





 





 





 





 



   elsif(ref($r) eq 'ARRAY'){ 




5730




72




  
100
  




 





 





 





163



     return "\@$name=".serialize($r,@r).";\n" if $name; 




5731




70





 





 





 





 





99



     my $ret="("; 




5732




70





 





 





 





 





134



     for(@$r){ 




5733




350





 





 





 





 





819



       $ret.=serialize(\$_,@r).","; 




5734




350




  
100
  




 





 





 





1019



       $ret.="\n" if $level>=0; 




5735




 





 





 





 





 





 



     } 




5736




70





 





 





 





 





237



     $ret=~s/,$//; 




5737




70





 





 





 





 





131



     $ret.=")"; 




5738




70




  
 50
  




 





 





 





144



     $ret.=";\n" if $name; 




5739




70





 





 





 





 





235



     return $ret; 




5740




 





 





 





 





 





 



   } 




5741




 





 





 





 





 





 



   elsif(ref($r) eq 'HASH'){ 




5742




31




  
100
  




 





 





 





250



     return "\%$name=".serialize($r,@r).";\n" if $name; 




5743




21





 





 





 





 





37



     my $ret="("; 




5744




21





 





 





 





 





105



     for(sort keys %$r){ 




5745




73





 





 





 





 





193



       $ret.=serialize(\$_,@r)."=>".serialize(\$$r{$_},@r).","; 




5746




73




  
 50
  




 





 





 





234



       $ret.="\n" if $level>=0; 




5747




 





 





 





 





 





 



     } 




5748




21





 





 





 





 





84



     $ret=~s/,$//; 




5749




21





 





 





 





 





33



     $ret.=")"; 




5750




21




  
 50
  




 





 





 





55



     $ret.=";\n" if $name; 




5751




21





 





 





 





 





132



     return $ret; 




5752




 





 





 





 





 





 



   } 




5753




 





 





 





 





 





 



   elsif(ref($$r) eq 'ARRAY'){ 




5754




48




  
 50
  




 





 





 





92



     return "\@$name=".serialize($r,@r).";\n" if $name; 




5755




48





 





 





 





 





63



     my $ret="["; 




5756




48





 





 





 





 





89



     for(@$$r){ 




5757




100





 





 





 





 





555



       $ret.=serialize(\$_,@r).","; 




5758




100




  
 50
  



  
 33
  




 





 





487



       $ret.="\n" if !defined $level or $level>=0; 




5759




 





 





 





 





 





 



     } 




5760




48





 





 





 





 





133



     $ret=~s/,$//; 




5761




48





 





 





 





 





67



     $ret.="]"; 




5762




48




  
 50
  




 





 





 





89



     $ret.=";\n" if $name; 




5763




48





 





 





 





 





132



     return $ret; 




5764




 





 





 





 





 





 



   } 




5765




 





 





 





 





 





 



   elsif(ref($$r) eq 'HASH'){ 




5766




73




  
 50
  




 





 





 





138



     return "\%$name=".serialize($r,@r).";\n" if $name; 




5767




73





 





 





 





 





107



     my $ret="{"; 




5768




73





 





 





 





 





268



     for(sort keys %$$r){ 




5769




214





 





 





 





 





412



       $ret.=serialize(\$_,@r)."=>".serialize(\$$$r{$_},@r).","; 




5770




214




  
 50
  




 





 





 





598



       $ret.="\n" if $level>=0; 




5771




 





 





 





 





 





 



     } 




5772




73





 





 





 





 





211



     $ret=~s/,$//; 




5773




73





 





 





 





 





93



     $ret.="}"; 




5774




73




  
 50
  




 





 





 





133



     $ret.=";\n" if $name; 




5775




73





 





 





 





 





208



     return $ret; 




5776




 





 





 





 





 





 



   } 




5777




 





 





 





 





 





 



   elsif(ref($$r) eq 'SCALAR'){ 




5778



  
0
  




 





 





 





 





0



     return "\\".serialize($$r,@r); 




5779




 





 





 





 





 





 



   } 




5780




 





 





 





 





 





 



   elsif(ref($r) eq 'LVALUE'){ 




5781



  
0
  




 





 





 





 





0



     my $s="$$r"; 




5782



  
0
  




 





 





 





 





0



     return serialize(\$s,@r); 




5783




 





 





 





 





 





 



   } 




5784




 





 





 





 





 





 



   elsif(ref($$r) eq 'CODE'){ 




5785




 





 





 





 





 





 



     #warn "Tried to serialize CODE"; 




5786



  
0
  




 





 





 





 





0



     return 'sub{croak "Can not serialize CODE-references, see perhaps B::Deparse and Storable"}' 




5787




 





 





 





 





 





 



   } 




5788




 





 





 





 





 





 



   elsif(ref($$r) eq 'GLOB'){ 




5789



  
0
  




 





 





 





 





0



     warn "Tried to serialize a GLOB"; 




5790



  
0
  




 





 





 





 





0



     return '\*STDERR' 




5791




 





 





 





 





 





 



   } 




5792




 





 





 





 





 





 



   else{ 




5793



  
0
  




 





 





 





 





0



     my $tilbake; 




5794



  
0
  




 





 





 





 





0



     my($pakke,$fil,$linje,$sub,$hasargs,$wantarray); 




5795



  
0
  




 




  
  0
  




 





 





0



       ($pakke,$fil,$linje,$sub,$hasargs,$wantarray)=caller($tilbake++) until $sub ne 'serialize' || $tilbake>20; 




5796



  
0
  




 





 





 





 





0



     croak("serialize() argument should be reference!\n". 




5797




 





 





 





 





 





 



         "\$r=$r\n". 




5798




 





 





 





 





 





 



         "ref(\$r)   = ".ref($r)."\n". 




5799




 





 





 





 





 





 



         "ref(\$\$r) = ".ref($$r)."\n". 




5800




 





 





 





 





 





 



         "kallstack:\n". _kallstack()); 




5801




 





 





 





 





 





 



   } 




5802




 





 





 





 





 





 



 } 




5803




 





 





 





 





 





 



   




5804




 





 





 





 





 





 



 =head2 srlz 




5805




 





 





 





 





 





 



   




5806




 





 





 





 





 





 



 Synonym to L, but remove unnecessary single quote chars around 




5807




 





 





 





 





 





 



 C<< \w+ >>-keys and number values (except numbers with leading zeros). Example: 




5808




 





 





 





 





 





 



   




5809




 





 





 





 





 





 



 serialize: 




5810




 





 





 





 





 





 



   




5811




 





 





 





 





 





 



  %s=('action'=>{'del'=>'0','ins'=>'0','upd'=>'18'},'post'=>'1348','pre'=>'1348', 




5812




 





 





 





 





 





 



      'updcol'=>{'Laerestednr'=>'18','Studietypenr'=>'18','Undervisningssted'=>'7','Url'=>'11'}, 




5813




 





 





 





 





 





 



      'where'=>'where 1=1'); 




5814




 





 





 





 





 





 



   




5815




 





 





 





 





 





 



 srlz: 




5816




 





 





 





 





 





 



   




5817




 





 





 





 





 





 



  %s=(action=>{del=>0,ins=>0,upd=>18},post=>1348,pre=>1348, 




5818




 





 





 





 





 





 



      updcol=>{Laerestednr=>18,Studietypenr=>18,Undervisningssted=>7,Url=>11}, 




5819




 





 





 





 





 





 



      where=>'where 1=1'); 




5820




 





 





 





 





 





 



   




5821




 





 





 





 





 





 



 Todo: update L to do the same, but in the right way. (For now  




5822




 





 





 





 





 





 



 srlz runs the string from serialize() through two C<< s/// >>, this will break 




5823




 





 





 





 





 





 



 in certain cases). L will be kept as a synonym (or the other way around). 




5824




 





 





 





 





 





 



   




5825




 





 





 





 





 





 



 =cut 




5826




 





 





 





 





 





 



   




5827




 





 





 





 





 





 



 sub srlz { 




5828



  
0
  




 





 




  
0
  



  
1
  




0



   my $s=serialize(@_); 




5829



  
0
  




 





 





 





 





0



   $s=~s,'(\w+)'=>,$1=>,g; 




5830



  
0
  




 





 





 





 





0



   $s=~s,=>'((0|[1-9]\d*)(\.\d+)?(e[-+]?\d+)?)',=>$1,gi;  #ikke ledende null!    hm                                                                                                                                           




5831



  
0
  




 





 





 





 





0



   $s; 




5832




 





 





 





 





 





 



 } 




5833




 





 





 





 





 





 



   




5834




 





 





 





 





 





 



   




5835




 





 





 





 





 





 



 =head2 sys 




5836




 





 





 





 





 





 



   




5837




 





 





 





 





 





 



 Call instead of C if you want C (Carp::croak) when something fails. 




5838




 





 





 





 





 





 



   




5839




 





 





 





 





 





 



  sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" } 




5840




 





 





 





 





 





 



   




5841




 





 





 





 





 





 



   




5842




 





 





 





 





 





 



 =cut 




5843




 





 





 





 





 





 



   




5844



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub sys($){ my$s=shift; my$r=system($s); $r==0 or croak"ERROR: system($s)==$r ($!) ($?)" } 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




5845




 





 





 





 





 





 



   




5846




 





 





 





 





 





 



 =head2 recursed 




5847




 





 





 





 





 





 



   




5848




 





 





 





 





 





 



 Returns true or false (actually 1 or 0) depending on whether the 




5849




 





 





 





 





 





 



 current sub has been called by itself or not. 




5850




 





 





 





 





 





 



   




5851




 





 





 





 





 





 



  sub xyz 




5852




 





 





 





 





 





 



  { 




5853




 





 





 





 





 





 



     xyz() if not recursed; 




5854




 





 





 





 





 





 



   




5855




 





 





 





 





 





 



  } 




5856




 





 





 





 





 





 



   




5857




 





 





 





 





 





 



 =cut 




5858




 





 





 





 





 





 



   




5859



  
0
  



  
  0
  




 




  
0
  



  
1
  




0



 sub recursed {(caller(1))[3] eq (caller(2))[3]?1:0} 




5860




 





 





 





 





 





 



   




5861




 





 





 





 





 





 



 =head2 ed 




5862




 





 





 





 





 





 



   




5863




 





 





 





 





 





 



 String editor commands 




5864




 





 





 





 





 





 



   




5865




 





 





 





 





 





 



  literals:               a-z 0-9 space 




5866




 





 





 





 





 





 



  move cursor:            FBAEPN MF MB ME 




5867




 





 





 





 





 





 



  delete:                 D Md 




5868




 





 





 





 





 





 



  up/low/camelcase word   U L C 




5869




 





 





 





 





 





 



  backspace:              - 




5870




 





 





 





 





 





 



  search:                 S 




5871




 





 





 





 





 





 



  return/enter:           R 




5872




 





 





 





 





 





 



  meta/esc/alt:           M 




5873




 





 





 





 





 





 



  shift:                  T 




5874




 





 





 





 





 





 



  cut to eol:             K 




5875




 





 





 





 





 





 



  caps lock:              C 




5876




 





 





 





 





 





 



  yank:                   Y 




5877




 





 





 





 





 





 



  start and end:          < > 




5878




 





 





 





 





 





 



  macro start/end/play:   { } ! 




5879




 





 





 





 





 





 



  times for next cmd:     M  (i.e. M24a inserts 24 a's) 




5880




 





 





 





 





 





 



   




5881




 





 





 





 





 





 



 (TODO: alfa...and more docs needed) 




5882




 





 





 





 





 





 



   




5883




 





 





 





 





 





 



 =cut 




5884




 





 





 





 





 





 



   




5885




 





 





 





 





 





 



 our $Edcursor; 




5886




 





 





 





 





 





 



 sub ed { 




5887




18





 





 




  
18
  



  
1
  




4351



   my($s,$cs,$p,$buf)=@_; #string, commands, point (or cursor) 




5888




18




  
100
  




 





 





 





58



   return $$s=ed($$s,$cs,$p,$buf) if ref($s); 




5889




17





 





 





 





 





33



   my($sh,$cl,$m,$t,@m)=(0,0,0,undef); 




5890




17





 





 





 





 





37



   while(length($cs)){ 




5891




121





 





 





 





 





148



     my $n = 0; 




5892




121




  
 50
  




 





 





 





489



     my $c = $cs=~s,^(M\d+|M.|""|".+?"|S.+?R|\\.|.),,s ? $1 : die; 




5893




121





 




  
100
  




 





 





402



     $p = curb($p||0,0,length($s)); 




5894




121




  
100
  




 





 





 





234



     if(defined$t){$cs="".($c x $t).$cs;$t=undef;next} 




 




1





 





 





 





 





5



   




 




1





 





 





 





 





2



   




 




1





 





 





 





 





3



   




5895




120





 





 




  
81
  




 





375



     my $add=sub{substr($s,$p,0)=$_[0];$p+=length($_[0])}; 




 




81





 





 





 





 





141



   




 




81





 





 





 





 





144



   




5896




120




  
 50
  




 





 





 





821



     if   ($c =~ /^([a-z0-9 ])/){ &$add($sh^$cl?uc($1):$1); $sh=0 } 




 




65




  
100
  




 





 





 





208



   




 




65




  
100
  




 





 





 





80



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
 50
  




 





 





 





 



   




5897




1





 





 





 





 





3



     elsif($c =~ /^"(.+)"$/)    { &$add($1) } 




5898




1





 





 





 





 





4



     elsif($c =~ /^\\(.)/)      { &$add($1) } 




5899




2




  
 50
  




 





 





 





6



     elsif($c =~ /^S(.+)R/)     { my $i=index($s,$1,$p);$p=$i+length($1) if $i>=0 } 




 




2





 





 





 





 





8



   




5900




1





 





 





 





 





3



     elsif($c =~ /^M(\d+)/)     { $t=$1; next } 




 




1





 





 





 





 





6



   




5901




2





 





 





 





 





3



     elsif($c eq 'F') { $p++ } 




5902




1





 





 





 





 





2



     elsif($c eq 'B') { $p-- } 




5903



  
0
  




 




  
  0
  




 





 





0



     elsif($c eq 'A') { $p-- while $p>0 and substr($s,$p-1,2)!~/^\n/ } 




5904




8




  
 50
  




 





 





 





39



     elsif($c eq 'E') { substr($s,$p)=~/(.*)/ and $p+=length($1) } 




5905




4





 





 





 





 





5



     elsif($c eq 'D') { substr($s,$p,1)='' } 




5906




3




  
 50
  




 





 





 





21



     elsif($c eq 'MD'){ substr($s,$p)=~s/^(\W*\w+)// and $buf=$1 } 




5907




3




  
 50
  




 





 





 





17



     elsif($c eq 'MF'){ substr($s,$p)=~/(\W*\w+)/ and $p+=length($1) } 




5908




3




  
 50
  




 





 





 





19



     elsif($c eq 'MB'){ substr($s,0,$p)=~/(\w+\W*)$/ and $p-=length($1) } 




5909



  
0
  



  
  0
  




 





 





 





0



     elsif($c eq '-') { substr($s,--$p,1)='' if $p } 




5910




5




  
 50
  




 





 





 





37



     elsif($c eq 'M-'){ substr($s,0,$p)=~s/(\w+\W*)$// and $p-=length($buf=$1)} 




5911




3




  
 50
  




 





 





 





19



     elsif($c eq 'K') { substr($s,$p)=~s/(\S.+|\s*?\n)// and $buf=$1 } 




5912




12





 





 





 





 





26



     elsif($c eq 'Y') { &$add($buf) } 




5913



  
0
  




 





 





 





 





0



     elsif($c eq 'U') { substr($s,$p)=~s/(\W*)(\w+)/$1\U$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5914



  
0
  




 





 





 





 





0



     elsif($c eq 'L') { substr($s,$p)=~s/(\W*)(\w+)/$1\L$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5915



  
0
  




 





 





 





 





0



     elsif($c eq 'C') { substr($s,$p)=~s/(\W*)(\w+)/$1\u\L$2\E/; $p+=length($1.$2) } 




 



  
0
  




 





 





 





 





0



   




5916



  
0
  




 





 





 





 





0



     elsif($c eq '<') { $p=0 } 




5917



  
0
  




 





 





 





 





0



     elsif($c eq '>') { $p=length($s) } 




5918



  
0
  




 





 





 





 





0



     elsif($c eq 'T') { $sh=1 } 




5919



  
0
  




 





 





 





 





0



     elsif($c eq 'C') { $cl^=1 } 




5920




1





 





 





 





 





2



     elsif($c eq '{') { $m=1; @m=() } 




 




1





 





 





 





 





2



   




5921




1





 





 





 





 





2



     elsif($c eq '}') { $m=0 } 




5922




2




  
 50
  



  
 33
  




 





 





20



     elsif($c eq '!') { $m||!@m and die"ed: no macro"; $cs=join("",@m).$cs } 




 




2





 





 





 





 





5



   




5923




2





 





 





 





 





5



     elsif($c eq '""'){ &$add('"') } 




5924



  
0
  




 





 





 





 





0



     else             { croak "ed: Unknown cmd '$c'\n" } 




5925




119




  
100
  



  
100
  




 





 





578



     push @m, $c if $m and $c ne '{'; 




5926




 





 





 





 





 





 



     #warn serialize([$c,$m,$cs],'d'); 




5927




 





 





 





 





 





 



   } 




5928




17





 





 





 





 





20



   $Edcursor=$p; 




5929




17





 





 





 





 





50



   $s; 




5930




 





 





 





 





 





 



 } 




5931




 





 





 





 





 





 



   




5932




 





 





 





 





 





 



   




5933




 





 





 





 





 





 



 #todo: sub unbless eller sub damn 




5934




 





 





 





 





 





 



 #todo: ..se også: use Data::Structure::Util qw/unbless/; 




5935




 





 





 





 





 





 



 #todo: ...og: Acme::Damn sin damn() 




5936




 





 





 





 





 





 



 #todo? sub swap($$) http://www.idg.no/computerworld/article242008.ece 




5937




 





 





 





 





 





 



 #todo? catal 




5938




 





 





 





 





 





 



 #todo?  




5939




 





 





 





 





 





 



 #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); 




5940




 





 





 





 





 





 



   




5941




 





 





 





 





 





 



   




5942




 





 





 





 





 





 



 =head1 JUST FOR FUN 




5943




 





 





 





 





 





 



   




5944




 





 





 





 





 





 



 =head2 brainfu 




5945




 





 





 





 





 





 



   




5946




 





 





 





 





 





 



 B one or two arguments 




5947




 





 





 





 





 





 



   




5948




 





 





 





 





 





 



 First argument: a string, source code of the brainfu 




5949




 





 





 





 





 





 



 language. String containing the eight charachters + - < > [ ] . , 




5950




 





 





 





 





 





 



 Every other char is ignored silently. 




5951




 





 





 





 





 





 



   




5952




 





 





 





 





 





 



 Second argument: if the source code contains commas (,) the second 




5953




 





 





 





 





 





 



 argument is the input characters in a string. 




5954




 





 





 





 





 





 



   




5955




 





 





 





 





 





 



 B The resulting output from the program. 




5956




 





 





 





 





 





 



   




5957




 





 





 





 





 





 



 Example: 




5958




 





 





 





 





 





 



   




5959




 





 





 





 





 





 



  print brainfu(<<"");  #prints "Hallo Verden!\n" 




5960




 





 





 





 





 





 



  ++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>---.+++++++++++..+++.>++.<<++++++++++++++ 




5961




 





 





 





 





 





 



  .>----------.+++++++++++++.--------------.+.+++++++++.>+.>. 




5962




 





 





 





 





 





 



   




5963




 





 





 





 





 





 



 See L 




5964




 





 





 





 





 





 



   




5965




 





 





 





 





 





 



 =head2 brainfu2perl 




5966




 





 





 





 





 





 



   




5967




 





 





 





 





 





 



 Just as L but instead it return the perl code to which the 




5968




 





 





 





 





 





 



 brainfu code is translated. Just C<< eval() >> this perl code to run. 




5969




 





 





 





 





 





 



   




5970




 





 





 





 





 





 



 Example: 




5971




 





 





 





 





 





 



   




5972




 





 





 





 





 





 



  print brainfu2perl('>++++++++[<++++++++>-]<++++++++.>++++++[<++++++>-]<---.'); 




5973




 





 





 





 





 





 



   




5974




 





 





 





 





 





 



 Prints this string: 




5975




 





 





 





 





 





 



   




5976




 





 





 





 





 





 



  my($c,$o,@b)=(0); sub out{$o.=chr($b[$c]) for 1..$_[0]||1} 




5977




 





 





 





 





 





 



  ++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5978




 





 





 





 





 





 



  while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5979




 





 





 





 





 





 



  ++$b[$c];++$c;--$b[$c];}--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5980




 





 





 





 





 





 



  ++$b[$c];++$b[$c];out;++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c]; 




5981




 





 





 





 





 





 



  while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$c;--$b[$c];} 




5982




 





 





 





 





 





 



  --$c;--$b[$c];--$b[$c];--$b[$c];out;$o; 




5983




 





 





 





 





 





 



   




5984




 





 





 





 





 





 



 =head2 brainfu2perl_optimized 




5985




 





 





 





 





 





 



   




5986




 





 





 





 





 





 



 Just as L but optimizes the perl code. The same 




5987




 





 





 





 





 





 



 example as above with brainfu2perl_optimized returns this equivalent 




5988




 





 





 





 





 





 



 but shorter perl code: 




5989




 





 





 





 





 





 



   




5990




 





 





 





 





 





 



  $b[++$c]+=8;while($b[$c]){$b[--$c]+=8;--$b[++$c]}$b[--$c]+=8;out;$b[++$c]+=6; 




5991




 





 





 





 





 





 



  while($b[$c]){$b[--$c]+=6;--$b[++$c]}$b[--$c]-=3;out;$o; 




5992




 





 





 





 





 





 



   




5993




 





 





 





 





 





 



 =cut 




5994




 





 





 





 





 





 



   




5995




3





 





 




  
3
  



  
1
  




691



 sub brainfu { eval(brainfu2perl(@_)) } 




5996




 





 





 





 





 





 



   




5997




 





 





 





 





 





 



 sub brainfu2perl { 




5998




6





 





 




  
6
  



  
1
  




21



   my($bf,$inp)=@_; 




5999




17





 





 





 





 





76



   my $perl='my($c,$inp,$o,@b)=(0,\''.$inp.'\'); no warnings; sub out{$o.=chr($b[$c]) for 1..$_[0]||1}'."\n"; 




6000




3




  
100
  



  
 66
  




 





 





22



   $perl.='sub inp{$inp=~s/(.)//s and $b[$c]=ord($1)}'."\n" if $inp and $bf=~/,/; 




6001




3




  
100
  




 





 





 





918



   $perl.=join("",map/\+/?'++$b[$c];':/\-/?'--$b[$c];':/\[/?'while($b[$c]){':/\]/?'}':/>/?'++$c;':/




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




 




 




  
100
  




 





 





 





 



   




6002




3





 





 





 





 





309



   $perl; 




6003




 





 





 





 





 





 



 } 




6004




 





 





 





 





 





 



   




6005




 





 





 





 





 





 



 sub brainfu2perl_optimized { 




6006



  
0
  




 





 




  
14
  



  
1
  




0



   my $perl=brainfu2perl(@_); 




6007



  
0
  




 





 





 





 





0



   $perl=~s{(((\+|\-)\3\$b\[\$c\];){2,})}{ '$b[$c]'.$3.'='.(grep/b/,split//,$1).';' }gisex; 




 



  
0
  




 





 





 





 





0



   




6008



  
0
  




 





 





 





 





0



   1 while $perl=~s/\+\+\$c;\-\-\$c;//g + $perl=~s/\-\-\$c;\+\+\$c;//g; 




6009



  
0
  




 





 





 





 





0



   $perl=~s{((([\-\+])\3\$c;){2,})}{"\$c$3=".(grep/c/,split//,$1).';'}gisex; 




 



  
0
  




 





 





 





 





0



   




6010



  
0
  



  
  0
  




 





 





 





0



   $perl=~s{((\+\+|\-\-)\$c;([^;{}]+;))}{my($o,$s)=($2,$3);$s=~s/\$c/$o\$c/?$s:$1}ge; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6011



  
0
  




 





 





 





 





0



   $perl=~s/\$c(\-|\+)=(\d+);(\+\+|\-\-)\$b\[\$c\]/$3.'$b[$c'.$1.'='.$2.'];'/ge; 




 



  
0
  




 





 





 





 





0



   




6012



  
0
  




 





 





 





 





0



   $perl=~s{((out;){2,})}{'out('.(grep/o/,split//,$1).');'}ge; 




 



  
0
  




 





 





 





 





0



   




6013



  
0
  




 





 





 





 





0



   $perl=~s/;}/}/g;$perl=~s/;+/;/g; 




 



  
0
  




 





 





 





 





0



   




6014



  
0
  




 





 





 





 





0



   $perl; 




6015




 





 





 





 





 





 



 } 




6016




 





 





 





 





 





 



   




6017




 





 





 





 





 





 



   




6018




 





 





 





 





 





 



 =head1 BLOOM FILTER SUBROUTINES 




6019




 





 





 





 





 





 



   




6020




 





 





 





 





 





 



 Bloom filters can be used to check whether an element (a string) is a 




6021




 





 





 





 





 





 



 member of a large set using much less memory or disk space than other 




6022




 





 





 





 





 





 



 data structures. Trading speed and accuracy for memory usage. While 




6023




 





 





 





 





 





 



 risking false positives, Bloom filters have a very strong space 




6024




 





 





 





 





 





 



 advantage over other data structures for representing sets. 




6025




 





 





 





 





 





 



   




6026




 





 





 





 





 





 



 In the example below, a set of 100000 phone numbers (or any string of 




6027




 





 





 





 





 





 



 any length) can be "stored" in just 91230 bytes if you accept that you 




6028




 





 





 





 





 





 



 can only check the data structure for existence of a string and accept 




6029




 





 





 





 





 





 



 false positives with an error rate of 0.03 (that is three percent, error 




6030




 





 





 





 





 





 



 rates are given in numbers larger than 0 and smaller than 1). 




6031




 





 





 





 





 





 



   




6032




 





 





 





 





 





 



 You can not retrieve the strings in the set without using "brute 




6033




 





 





 





 





 





 



 force" methods and even then you would get slightly more strings than 




6034




 





 





 





 





 





 



 you put in because of the error rate inaccuracy. 




6035




 





 





 





 





 





 



   




6036




 





 





 





 





 





 



 Bloom Filters have many uses. 




6037




 





 





 





 





 





 



   




6038




 





 





 





 





 





 



 See also: L 




6039




 





 





 





 





 





 



   




6040




 





 





 





 





 





 



 See also: L 




6041




 





 





 





 





 





 



   




6042




 





 





 





 





 





 



 =head2 bfinit 




6043




 





 





 





 





 





 



   




6044




 





 





 





 





 





 



 Initialize a new Bloom Filter: 




6045




 





 





 





 





 





 



   




6046




 





 





 





 





 





 



   my $bf = bfinit( error_rate=>0.01, capacity=>100000 ); 




6047




 





 





 





 





 





 



   




6048




 





 





 





 





 





 



 The same: 




6049




 





 





 





 





 





 



   




6050




 





 





 





 





 





 



   my $bf = bfinit( 0.01, 100000 ); 




6051




 





 





 





 





 





 



   




6052




 





 





 





 





 





 



 since two arguments is interpreted as error_rate and capacity accordingly. 




6053




 





 





 





 





 





 



   




6054




 





 





 





 





 





 



   




6055




 





 





 





 





 





 



 =head2 bfadd 




6056




 





 





 





 





 





 



   




6057




 





 





 





 





 





 



   bfadd($bf, $_) for @phone_numbers;   # Adding strings one at a time 




6058




 





 





 





 





 





 



   




6059




 





 





 





 





 





 



   bfadd($bf, @phone_numbers);          # ...or all at once (faster) 




6060




 





 





 





 





 





 



   




6061




 





 





 





 





 





 



 Returns 1 on success. Dies (croaks) if more strings than capacity is added. 




6062




 





 





 





 





 





 



   




6063




 





 





 





 





 





 



 =head2 bfcheck 




6064




 





 





 





 





 





 



   




6065




 





 





 





 





 





 



   my $phone_number="97713246"; 




6066




 





 





 





 





 





 



   if ( bfcheck($bf, $phone_number) ) { 




6067




 





 





 





 





 





 



     print "Yes, $phone_number was PROBABLY added\n"; 




6068




 





 





 





 





 





 



   } 




6069




 





 





 





 





 





 



   else{ 




6070




 





 





 





 





 





 



     print "No, $phone_number was DEFINITELY NOT added\n"; 




6071




 





 





 





 





 





 



   } 




6072




 





 





 





 





 





 



   




6073




 





 





 





 





 





 



 Returns true if C<$phone_number> exists in C<@phone_numbers>. 




6074




 





 





 





 





 





 



   




6075




 





 





 





 





 





 



 Returns false most of the times, but sometimes true*), if C<$phone_number> doesn't exists in C<@phone_numbers>. 




6076




 





 





 





 





 





 



   




6077




 





 





 





 





 





 



 *) This is called a false positive. 




6078




 





 





 





 





 





 



   




6079




 





 





 





 





 





 



 Checking more than one key: 




6080




 





 





 





 





 





 



   




6081




 





 





 





 





 





 



  @bools = bfcheck($bf, @keys);          # or ... 




6082




 





 





 





 





 





 



  @bools = bfcheck($bf, \@keys);         # better, uses less memory if @keys is large 




6083




 





 





 





 





 





 



   




6084




 





 





 





 





 





 



 Returns an array the same size as @keys where each element is true or false accordingly. 




6085




 





 





 





 





 





 



   




6086




 





 





 





 





 





 



 =head2 bfgrep 




6087




 





 





 





 





 





 



   




6088




 





 





 





 





 





 



 Same as C except it returns the keys that exists in the bloom filter 




6089




 





 





 





 





 





 



   




6090




 





 





 





 





 





 



  @found = bfgrep($bf, @keys);           # or ... 




6091




 





 





 





 





 





 



  @found = bfgrep($bf, \@keys);          # better, uses less memory if @keys is large, or ... 




6092




 





 





 





 





 





 



  @found = grep bfcheck($bf,$_), @keys;  # same but slower 




6093




 





 





 





 





 





 



   




6094




 





 





 





 





 





 



 =head2 bfgrepnot 




6095




 





 





 





 





 





 



   




6096




 





 





 





 





 





 



 Same as C except it returns the keys that do NOT exists in the bloom filter: 




6097




 





 





 





 





 





 



   




6098




 





 





 





 





 





 



  @not_found = bfgrepnot($bf, @keys);          # or ... 




6099




 





 





 





 





 





 



  @not_found = bfgrepnot($bf, \@keys);         # better, uses less memory if @keys is large, or ... 




6100




 





 





 





 





 





 



  @not_found = grep !bfcheck($bf,$_), @keys);  # same but slower 




6101




 





 





 





 





 





 



   




6102




 





 





 





 





 





 



 =head2 bfdelete 




6103




 





 





 





 





 





 



   




6104




 





 





 





 





 





 



 Deletes from a counting bloom filter. 




6105




 





 





 





 





 





 



   




6106




 





 





 





 





 





 



 To enable deleting be sure to initialize the bloom filter with the 




6107




 





 





 





 





 





 



 numeric C argument. The number of bits could be 2 or 3*) 




6108




 





 





 





 





 





 



 for small filters with a small capacity (a small number of keys), but 




6109




 





 





 





 





 





 



 setting the number to 4 ensures that even very large filters with very 




6110




 





 





 





 





 





 



 small error rates would not overflow. 




6111




 





 





 





 





 





 



   




6112




 





 





 





 





 





 



 *) Acme::Tools do not currently support C<< counting_bits => 3 >> so 4 




6113




 





 





 





 





 





 



 and 8 are the only practical alternatives where 8 is almost always overkill. 




6114




 





 





 





 





 





 



   




6115




 





 





 





 





 





 



  my $bf=bfinit( 




6116




 





 





 





 





 





 



    error_rate    => 0.001, 




6117




 





 





 





 





 





 



    capacity      => 10000000, 




6118




 





 





 





 





 





 



    counting_bits => 4              # power of 2, that is 2, 4, 8, 16 or 32 




6119




 





 





 





 





 





 



  ); 




6120




 





 





 





 





 





 



  bfadd(   $bf, @unique_phone_numbers); 




6121




 





 





 





 





 





 



  bfdelete($bf, @unique_phone_numbers); 




6122




 





 





 





 





 





 



   




6123




 





 





 





 





 





 



 Example: examine the frequency of the counters with 4 bit counters and 4 million keys: 




6124




 





 





 





 





 





 



   




6125




 





 





 





 





 





 



  my $bf=bfinit( error_rate=>0.001, capacity=>4e6, counting_bits=>4 ); 




6126




 





 





 





 





 





 



  bfadd($bf,[1e3*$_+1 .. 1e3*($_+1)]) for 0..4000-1;  # adding 4 million keys one thousand at a time 




6127




 





 





 





 





 





 



  my %c; $c{vec($$bf{filter},$_,$$bf{counting_bits})}++ for 0..$$bf{filterlength}-1; 




6128




 





 





 





 





 





 



  printf "%8d counters = %d\n",$c{$_},$_ for sort{$a<=>$b}keys%c; 




6129




 





 





 





 





 





 



   




6130




 





 





 





 





 





 



 The output: 




6131




 





 





 





 





 





 



   




6132




 





 





 





 





 





 



  28689562 counters = 0 




6133




 





 





 





 





 





 



  19947673 counters = 1 




6134




 





 





 





 





 





 



   6941082 counters = 2 




6135




 





 





 





 





 





 



   1608250 counters = 3 




6136




 





 





 





 





 





 



    280107 counters = 4 




6137




 





 





 





 





 





 



     38859 counters = 5 




6138




 





 





 





 





 





 



      4533 counters = 6 




6139




 





 





 





 





 





 



       445 counters = 7 




6140




 





 





 





 





 





 



        46 counters = 8 




6141




 





 





 





 





 





 



         1 counters = 9 




6142




 





 





 





 





 





 



   




6143




 





 





 





 





 





 



 Even after the error_rate is changed from 0.001 to a percent of that, 0.00001, the limit of 16 (4 bits) is still far away: 




6144




 





 





 





 





 





 



   




6145




 





 





 





 





 





 



  47162242 counters = 0 




6146




 





 





 





 





 





 



  33457237 counters = 1 




6147




 





 





 





 





 





 



  11865217 counters = 2 




6148




 





 





 





 





 





 



   2804447 counters = 3 




6149




 





 





 





 





 





 



    497308 counters = 4 




6150




 





 





 





 





 





 



     70608 counters = 5 




6151




 





 





 





 





 





 



      8359 counters = 6 




6152




 





 





 





 





 





 



       858 counters = 7 




6153




 





 





 





 





 





 



        65 counters = 8 




6154




 





 





 





 





 





 



         4 counters = 9 




6155




 





 





 





 





 





 



   




6156




 





 





 





 





 





 



 In algorithmic terms the number of bits needed is C.  Thats why 4 bits (counters up 




6157




 





 





 





 





 





 



 to 15) is "always" good enough except for extremely large capasities or extremely small error rates. 




6158




 





 





 





 





 





 



 (Except when adding the same key many times, which should be avoided, and Acme::Tools::bfadd do not 




6159




 





 





 





 





 





 



 check for that, perhaps in future versions). 




6160




 





 





 





 





 





 



   




6161




 





 





 





 





 





 



 Bloom filters of the counting type are not very space efficient: The tables above shows that 84%-85% 




6162




 





 





 





 





 





 



 of the counters are 0 or 1. This means most bits are zero-bits. This doesn't have to be a problem if 




6163




 





 





 





 





 





 



 a counting bloom filter is used to be sent over slow networks because they are very compressable by 




6164




 





 





 





 





 





 



 common compression tools like I or L and such. 




6165




 





 





 





 





 





 



   




6166




 





 





 





 





 





 



 Deletion of non-existing keys makes C die (croak). 




6167




 





 





 





 





 





 



   




6168




 





 





 





 





 





 



 =head2 bfdelete 




6169




 





 





 





 





 





 



   




6170




 





 





 





 





 





 



 Deletes from a counting bloom filter: 




6171




 





 





 





 





 





 



   




6172




 





 





 





 





 





 



  bfdelete($bf, @keys); 




6173




 





 





 





 





 





 



  bfdelete($bf, \@keys); 




6174




 





 





 





 





 





 



   




6175




 





 





 





 





 





 



 Returns C<$bf> after deletion. 




6176




 





 





 





 





 





 



   




6177




 





 





 





 





 





 



 Croaks (dies) on deleting a non-existing key or deleting from an previouly overflown counter in a counting bloom filter. 




6178




 





 





 





 





 





 



   




6179




 





 





 





 





 





 



 =head2 bfaddbf 




6180




 





 





 





 





 





 



   




6181




 





 





 





 





 





 



 Adds another bloom filter to a bloom filter. 




6182




 





 





 





 





 





 



   




6183




 





 





 





 





 





 



 Bloom filters has the proberty that bit-wise I-ing the bit-filters 




6184




 





 





 





 





 





 



 of two filters with the same capacity and the same number and type of 




6185




 





 





 





 





 





 



 hash functions, adds the filters: 




6186




 





 





 





 





 





 



   




6187




 





 





 





 





 





 



   my $bf1=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[1..500]); 




6188




 





 





 





 





 





 



   my $bf2=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[501..1000]); 




6189




 





 





 





 





 





 



   




6190




 





 





 





 





 





 



   bfaddbf($bf1,$bf2); 




6191




 





 





 





 





 





 



   




6192




 





 





 





 





 





 



   print "Yes!" if bfgrep($bf1, 1..1000) == 1000; 




6193




 





 





 





 





 





 



   




6194




 





 





 





 





 





 



 Prints yes since C now returns an array of all the 1000 elements. 




6195




 





 





 





 





 





 



   




6196




 





 





 





 





 





 



 Croaks if the filters are of different dimensions. 




6197




 





 





 





 





 





 



   




6198




 





 





 





 





 





 



 Works for counting bloom filters as well (C<< counting_bits=>4 >> e.g.) 




6199




 





 





 





 





 





 



   




6200




 





 





 





 





 





 



 =head2 bfsum 




6201




 





 





 





 





 





 



   




6202




 





 





 





 





 





 



 Returns the number of 1's in the filter. 




6203




 





 





 





 





 





 



   




6204




 





 





 





 





 





 



  my $percent=100*bfsum($bf)/$$bf{filterlength}; 




6205




 





 





 





 





 





 



  printf "The filter is %.1f%% filled\n",$percent; #prints 50.0% or so if filled to capacity 




6206




 





 





 





 





 





 



   




6207




 





 





 





 





 





 



 Sums the counters for counting bloom filters (much slower than for non counting). 




6208




 





 





 





 





 





 



   




6209




 





 





 





 





 





 



 =head2 bfdimensions 




6210




 





 





 





 





 





 



   




6211




 





 





 





 





 





 



 Input, two numeric arguments: Capacity and error_rate. 




6212




 





 





 





 





 





 



   




6213




 





 





 





 





 





 



 Outputs an array of two numbers: m and k. 




6214




 





 





 





 





 





 



   




6215




 





 





 





 





 





 



   m = - n * log(p) / log(2)**2   # n = capacity, m = bits in filter (divide by 8 to get bytes) 




6216




 





 





 





 





 





 



   k = log(1/p) / log(2)          # p = error_rate, uses perls internal log() with base e (2.718) 




6217




 





 





 





 





 





 



   




6218




 





 





 





 





 





 



 ...that is: m = the best number of bits in the filter and k = the best 




6219




 





 





 





 





 





 



 number of hash functions optimized for the given capacity (n) and 




6220




 





 





 





 





 





 



 error_rate (p). Note that k is a dependent only of the error_rate.  At 




6221




 





 





 





 





 





 



 about two percent error rate the bloom filter needs just the same 




6222




 





 





 





 





 





 



 number of bytes as the number of keys. 




6223




 





 





 





 





 





 



   




6224




 





 





 





 





 





 



  Storage (bytes): 




6225




 





 





 





 





 





 



  Capacity      Error-rate  Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate 




6226




 





 





 





 





 





 



                0.000000001 0.00000001 0.0000001  0.000001   0.00001    0.0001     0.001      0.01       0.02141585 0.1        0.5        0.99 




6227




 





 





 





 





 





 



  ------------- ----------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- 




6228




 





 





 





 





 





 



             10 54.48       48.49      42.5       36.51      30.52      24.53      18.53      12.54      10.56      6.553      2.366      0.5886 




6229




 





 





 





 





 





 



            100 539.7       479.8      419.9      360        300.1      240.2      180.3      120.4      100.6      60.47      18.6       0.824 




6230




 





 





 





 





 





 



           1000 5392        4793       4194       3595       2996       2397       1798       1199       1001       599.6      180.9      3.177 




6231




 





 





 





 





 





 



          10000 5.392e+04   4.793e+04  4.194e+04  3.594e+04  2.995e+04  2.396e+04  1.797e+04  1.198e+04  1e+04      5991       1804       26.71 




6232




 





 





 





 





 





 



         100000 5.392e+05   4.793e+05  4.193e+05  3.594e+05  2.995e+05  2.396e+05  1.797e+05  1.198e+05  1e+05      5.991e+04  1.803e+04  262 




6233




 





 





 





 





 





 



        1000000 5.392e+06   4.793e+06  4.193e+06  3.594e+06  2.995e+06  2.396e+06  1.797e+06  1.198e+06  1e+06      5.991e+05  1.803e+05  2615 




6234




 





 





 





 





 





 



       10000000 5.392e+07   4.793e+07  4.193e+07  3.594e+07  2.995e+07  2.396e+07  1.797e+07  1.198e+07  1e+07      5.991e+06  1.803e+06  2.615e+04 




6235




 





 





 





 





 





 



      100000000 5.392e+08   4.793e+08  4.193e+08  3.594e+08  2.995e+08  2.396e+08  1.797e+08  1.198e+08  1e+08      5.991e+07  1.803e+07  2.615e+05 




6236




 





 





 





 





 





 



     1000000000 5.392e+09   4.793e+09  4.193e+09  3.594e+09  2.995e+09  2.396e+09  1.797e+09  1.198e+09  1e+09      5.991e+08  1.803e+08  2.615e+06 




6237




 





 





 





 





 





 



    10000000000 5.392e+10   4.793e+10  4.193e+10  3.594e+10  2.995e+10  2.396e+10  1.797e+10  1.198e+10  1e+10      5.991e+09  1.803e+09  2.615e+07 




6238




 





 





 





 





 





 



   100000000000 5.392e+11   4.793e+11  4.193e+11  3.594e+11  2.995e+11  2.396e+11  1.797e+11  1.198e+11  1e+11      5.991e+10  1.803e+10  2.615e+08 




6239




 





 





 





 





 





 



  1000000000000 5.392e+12   4.793e+12  4.193e+12  3.594e+12  2.995e+12  2.396e+12  1.797e+12  1.198e+12  1e+12      5.991e+11  1.803e+11  2.615e+09 




6240




 





 





 





 





 





 



   




6241




 





 





 





 





 





 



  Error rate:               0.99   Hash functions:  1 




6242




 





 





 





 





 





 



  Error rate:                0.5   Hash functions:  1 




6243




 





 





 





 





 





 



  Error rate:                0.1   Hash functions:  3 




6244




 





 





 





 





 





 



  Error rate: 0.0214158522653385   Hash functions:  6 




6245




 





 





 





 





 





 



  Error rate:               0.01   Hash functions:  7 




6246




 





 





 





 





 





 



  Error rate:              0.001   Hash functions: 10 




6247




 





 





 





 





 





 



  Error rate:             0.0001   Hash functions: 13 




6248




 





 





 





 





 





 



  Error rate:            0.00001   Hash functions: 17 




6249




 





 





 





 





 





 



  Error rate:           0.000001   Hash functions: 20 




6250




 





 





 





 





 





 



  Error rate:          0.0000001   Hash functions: 23 




6251




 





 





 





 





 





 



  Error rate:         0.00000001   Hash functions: 27 




6252




 





 





 





 





 





 



  Error rate:        0.000000001   Hash functions: 30 




6253




 





 





 





 





 





 



   




6254




 





 





 





 





 





 



 =head2 bfstore 




6255




 





 





 





 





 





 



   




6256




 





 





 





 





 





 



 Storing and retrieving bloom filters to and from disk uses Ls C and C. This: 




6257




 





 





 





 





 





 



   




6258




 





 





 





 





 





 



  bfstore($bf,'filename.bf'); 




6259




 





 





 





 





 





 



   




6260




 





 





 





 





 





 



 It the same as: 




6261




 





 





 





 





 





 



   




6262




 





 





 





 





 





 



  use Storable qw(store retrieve); 




6263




 





 





 





 





 





 



  ... 




6264




 





 





 





 





 





 



  store($bf,'filename.bf'); 




6265




 





 





 





 





 





 



   




6266




 





 





 





 





 





 



 =head2 bfretrieve 




6267




 





 





 





 





 





 



   




6268




 





 





 





 





 





 



 This: 




6269




 





 





 





 





 





 



   




6270




 





 





 





 





 





 



  my $bf=bfretrieve('filename.bf'); 




6271




 





 





 





 





 





 



   




6272




 





 





 





 





 





 



 Or this: 




6273




 





 





 





 





 





 



   




6274




 





 





 





 





 





 



  my $bf=bfinit('filename.bf'); 




6275




 





 





 





 





 





 



   




6276




 





 





 





 





 





 



 Is the same as: 




6277




 





 





 





 





 





 



   




6278




 





 





 





 





 





 



  use Storable qw(store retrieve); 




6279




 





 





 





 





 





 



  my $bf=retrieve('filename.bf'); 




6280




 





 





 





 





 





 



   




6281




 





 





 





 





 





 



 =head2 bfclone 




6282




 





 





 





 





 





 



   




6283




 





 





 





 





 





 



 Deep copies the bloom filter data structure. (Which btw is not very deep, two levels at most) 




6284




 





 





 





 





 





 



   




6285




 





 





 





 





 





 



 This: 




6286




 





 





 





 





 





 



   




6287




 





 





 





 





 





 



  my $bfc = bfclone($bf); 




6288




 





 





 





 





 





 



   




6289




 





 





 





 





 





 



 Works just as: 




6290




 





 





 





 





 





 



   




6291




 





 





 





 





 





 



  use Storable; 




6292




 





 





 





 





 





 



  my $bfc=Storable::dclone($bf); 




6293




 





 





 





 





 





 



   




6294




 





 





 





 





 





 



 =head2 Object oriented interface to bloom filters 




6295




 





 





 





 





 





 



   




6296




 





 





 





 





 





 



  use Acme::Tools; 




6297




 





 





 





 





 





 



  my $bf=new Acme::Tools::BloomFilter(0.1,1000); # the same as bfinit, see bfinit above 




6298




 





 





 





 





 





 



  print ref($bf),"\n";                           # prints Acme::Tools::BloomFilter 




6299




 





 





 





 





 





 



  $bf->add(@keys); 




6300




 





 





 





 





 





 



  $bf->check($keys[0]) and print "ok\n";         # prints ok 




6301




 





 





 





 





 





 



  $bf->grep(\@keys)==@keys and print "ok\n";     # prints ok 




6302




 





 





 





 





 





 



  $bf->store('filename.bf'); 




6303




 





 





 





 





 





 



  my $bf2=bfretrieve('filename.bf'); 




6304




 





 





 





 





 





 



  $bf2->check($keys[0]) and print "ok\n";        # still ok 




6305




 





 





 





 





 





 



   




6306




 





 





 





 





 





 



  $bf2=$bf->clone(); 




6307




 





 





 





 





 





 



   




6308




 





 





 





 





 





 



 To instantiate a previously stored bloom filter: 




6309




 





 





 





 





 





 



   




6310




 





 





 





 





 





 



  my $bf = Acme::Tools::BloomFilter->new( '/path/to/stored/bloomfilter.bf' ); 




6311




 





 





 





 





 





 



   




6312




 





 





 





 





 





 



 The o.o. interface has the same methods as the C-subs without the 




6313




 





 





 





 





 





 



 C-prefix in the names. The C is not available as a 




6314




 





 





 





 





 





 



 method, although C, C and 




6315




 





 





 





 





 





 



 C are synonyms. 




6316




 





 





 





 





 





 



   




6317




 





 





 





 





 





 



 =head2 Internals and speed 




6318




 





 





 





 





 





 



   




6319




 





 





 





 





 





 



 The internal hash-functions are C<< md5( "$key$salt" ) >> from L. 




6320




 





 





 





 





 





 



   




6321




 





 





 





 





 





 



 Since C returns 128 bits and most medium to large sized bloom 




6322




 





 





 





 





 





 



 filters need only a 32 bit hash function, the result from md5() are 




6323




 





 





 





 





 





 



 split (C-ed) into 4 parts 32 bits each and are treated as if 4 




6324




 





 





 





 





 





 



 hash functions was called at once (speedup). Using different salts to 




6325




 





 





 





 





 





 



 the key on each md5 results in different hash functions. 




6326




 





 





 





 





 





 



   




6327




 





 





 





 





 





 



 Digest::SHA512 would have been even better since it returns more bits, 




6328




 





 





 





 





 





 



 if it werent for the fact that it's much slower than Digest::MD5. 




6329




 





 





 





 





 





 



   




6330




 





 





 





 





 





 



 String::CRC32::crc32 is faster than Digest::MD5, but not 4 times faster: 




6331




 





 





 





 





 





 



   




6332




 





 





 





 





 





 



  time perl -e'use Digest::MD5 qw(md5);md5("asdf$_") for 1..10e6'       #5.56 sec 




6333




 





 





 





 





 





 



  time perl -e'use String::CRC32;crc32("asdf$_") for 1..10e6'           #2.79 sec, faster but not per bit 




6334




 





 





 





 





 





 



  time perl -e'use Digest::SHA qw(sha512);sha512("asdf$_") for 1..10e6' #36.10 sec, too slow (sha1, sha224, sha256 and sha384 too) 




6335




 





 





 





 





 





 



   




6336




 





 





 





 





 





 



 Md5 seems to be an ok choice both for speed and avoiding collitions due to skewed data keys. 




6337




 





 





 





 





 





 



   




6338




 





 





 





 





 





 



 =head2 Theory and math behind bloom filters 




6339




 





 





 





 





 





 



   




6340




 





 





 





 





 





 



 L 




6341




 





 





 





 





 





 



   




6342




 





 





 





 





 





 



 L 




6343




 





 





 





 





 





 



   




6344




 





 





 





 





 





 



 L 




6345




 





 





 





 





 





 



   




6346




 





 





 





 





 





 



 See also Scaleable Bloom Filters: L (not implemented in Acme::Tools) 




6347




 





 





 





 





 





 



   




6348




 





 





 





 





 





 



 ...and perhaps L 




6349




 





 





 





 





 





 



   




6350




 





 





 





 





 





 



 =cut 




6351




 





 





 





 





 





 



   




6352




 





 





 





 





 





 



 sub bfinit { 




6353




24




  
100
  




 




  
24
  



  
1
  




15650



   return bfretrieve(@_)                             if @_==1; 




6354




23




  
 50
  



  
 66
  




 





 





118



   return bfinit(error_rate=>$_[0], capacity=>$_[1]) if @_==2 and 0<$_[0] and $_[0]<1 and $_[1]>1; 




 




 





 




  
 66
  




 





 





 



   




 




 





 




  
 33
  




 





 





 



   




6355




21




  
  0
  



  
 33
  




 





 





61



   return bfinit(error_rate=>$_[1], capacity=>$_[0]) if @_==2 and 0<$_[1] and $_[1]<1 and $_[0]>1; 




 




 





 




  
 33
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




6356




21





 





 





 





 





129



   require Digest::MD5; 




6357




21




  
 50
  




 





 





 





54



   @_%2&&croak "Arguments should be a hash of equal number of keys and values"; 




6358




21





 





 





 





 





85



   my %arg=@_; 




6359




21





 





 





 





 





69



   my @ok_param=qw/error_rate capacity min_hashfuncs max_hashfuncs hashfuncs counting_bits adaptive keys/; 




6360




21





 





 





 





 





84



   my @not_ok=sort(grep!in($_,@ok_param),keys%arg); 




6361




21




  
100
  




 





 





 





271



   croak "Not ok param to bfinit: ".join(", ",@not_ok) if @not_ok; 




6362




20




  
 50
  



  
 66
  




 





 





98



   croak "Not an arrayref in keys-param" if exists $arg{keys} and ref($arg{keys}) ne 'ARRAY'; 




6363




20




  
 50
  




 





 





 





77



   croak "Not implemented counting_bits=$arg{counting_bits}, should be 2, 4, 8, 16 or 32" if !in(nvl($arg{counting_bits},1),1,2,4,8,16,32); 




6364




20




  
 50
  



  
 33
  




 





 





73



   croak "An bloom filters here can not be in both adaptive and counting_bits modes" if $arg{adaptive} and $arg{counting_bits}>1; 




6365




20





 





 





 





 





176



   my $bf={error_rate    => 0.001,  #default p 




6366




 





 





 





 





 





 



 	  capacity      => 100000, #default n 




6367




 





 





 





 





 





 



           min_hashfuncs => 1, 




6368




 





 





 





 





 





 



           max_hashfuncs => 100, 




6369




 





 





 





 





 





 



 	  counting_bits => 1,      #default: not counting filter 




6370




 





 





 





 





 





 



 	  adaptive      => 0, 




6371




 





 





 





 





 





 



 	  %arg,                    #arguments 




6372




 





 





 





 





 





 



 	  key_count     => 0, 




6373




 





 





 





 





 





 



 	  overflow      => {}, 




6374




 





 





 





 





 





 



 	  version       => $Acme::Tools::VERSION, 




6375




 





 





 





 





 





 



 	 }; 




6376




20




  
100
  



  
100
  




 





 





384



   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; 




6377




18




  
 50
  




 





 





 





46



   @$bf{'min_hashfuncs','max_hashfuncs'}=(map$arg{hashfuncs},1..2) if $arg{hashfuncs}; 




6378




18





 





 





 





 





53



   @$bf{'filterlength','hashfuncs'}=bfdimensions($bf); #m and k 




6379




18





 





 





 





 





776



   $$bf{filter}=pack("b*", '0' x ($$bf{filterlength}*$$bf{counting_bits}) ); #hm x   new empty filter 




6380




 





 





 





 





 





 



   $$bf{unpack}= $$bf{filterlength}<=2**16/4 ? "n*" # /4 alleviates skewing if m just slightly < 2**x 




6381




18




  
 50
  




 





 





 





57



                :$$bf{filterlength}<=2**32/4 ? "N*" 




 




 




  
100
  




 





 





 





 



   




6382




 





 





 





 





 





 



                :                              "Q*"; 




6383




18




  
100
  




 





 





 





48



   bfadd($bf,@{$arg{keys}}) if $arg{keys}; 




 




8





 





 





 





 





78



   




6384




16





 





 





 





 





95



   return $bf; 




6385




 





 





 





 





 





 



 } 




6386




 





 





 





 





 





 



 sub bfaddbf { 




6387




2





 





 




  
2
  



  
1
  




5



   my($bf,$bf2)=@_; 




6388




 





 





 





 





 





 



   my $differror=join"\n", 




6389




 





 





 





 





 





 



     map "Property $_ differs ($$bf{$_} vs $$bf2{$_})", 




6390




2





 





 





 





 





42



     grep $$bf{$_} ne $$bf2{$_}, 




6391




 





 





 





 





 





 



     qw/capacity counting_bits adaptive hashfuncs filterlength/; #not error_rate 




6392




2




  
 50
  




 





 





 





8



   croak $differror if $differror; 




6393




2




  
 50
  




 





 





 





9



   croak "Can not add adaptive bloom filters" if $$bf{adaptive}; 




6394




2





 





 





 





 





5



   my $count=$$bf{key_count}+$$bf2{key_count}; 




6395




 





 





 





 





 





 



   croak "Exceeded filter capacity $$bf{key_count} + $$bf2{key_count} = $count > $$bf{capacity}" 




6396




2




  
 50
  




 





 





 





10



     if $count > $$bf{capacity}; 




6397




2





 





 





 





 





7



   $$bf{key_count}+=$$bf2{key_count}; 




6398




2




  
100
  




 





 





 





8



   if($$bf{counting_bits}==1){ 




6399




1





 





 





 





 





5



     $$bf{filter} |= $$bf2{filter}; 




6400




 





 





 





 





 





 



     #$$bf{filter} = $$bf{filter} | $$bf2{filter}; #or-ing 




6401




 





 





 





 





 





 



   } 




6402




 





 





 





 





 





 



   else { 




6403




1





 





 





 





 





4



     my $cb=$$bf{counting_bits}; 




6404




1





 





 





 





 





6



     for(0..$$bf{filterlength}-1){ 




6405




 





 





 





 





 





 



       my $sum= 




6406




 





 





 





 





 





 



       vec($$bf{filter}, $_,$cb)+ 




6407




4793





 





 





 





 





8390



       vec($$bf2{filter},$_,$cb); 




6408




4793




  
 50
  




 





 





 





9761



       if( $sum>2**$cb-1 ){ 




6409



  
0
  




 





 





 





 





0



 	$sum=2**$cb-1; 




6410



  
0
  




 





 





 





 





0



 	$$bf{overflow}{$_}++; 




6411




 





 





 





 





 





 



       } 




6412




4793





 





 





 





 





9283



       vec($$bf{filter}, $_,$cb)=$sum; 




6413




28





 





 




  
28
  




 





187



       no warnings; 




 




28





 





 





 





 





49



   




 




28





 





 





 





 





91601



   




6414




 





 





 





 





 





 



       $$bf{overflow}{$_}+=$$bf2{overflow}{$_} 




6415



  
0
  




 





 





 





 





0



 	and keys(%{$$bf{overflow}})>10 #hmm, arbitrary limit 




6416




 





 





 





 





 





 



 	and croak "Too many overflows, concider doubling counting_bits from $cb to ".(2*$cb) 




6417




4793




  
 50
  



  
  0
  




 





 





13225



 	if exists $$bf2{overflow}{$_}; 




 




 





 




  
  0
  




 





 





 



   




6418




 





 





 





 





 





 



     } 




6419




 





 





 





 





 





 



   } 




6420




2





 





 





 





 





7



   return $bf; #for convenience 




6421




 





 





 





 





 





 



 } 




6422




 





 





 





 





 





 



 sub bfsum { 




6423




8





 





 




  
8
  



  
1
  




40



   my($bf)=@_; 




6424




8




  
100
  




 





 





 





89



   return unpack( "%32b*", $$bf{filter}) if $$bf{counting_bits}==1; 




6425




3





 





 





 





 





8



   my($sum,$cb)=(0,$$bf{counting_bits}); 




6426




3





 





 





 





 





5708



   $sum+=vec($$bf{filter},$_,$cb) for 0..$$bf{filterlength}-1; 




6427




3





 





 





 





 





23



   return $sum; 




6428




 





 





 





 





 





 



 } 




6429




 





 





 





 





 





 



 sub bfadd { 




6430




11





 





 




  
11
  



  
1
  




2573



   require Digest::MD5; 




6431




11





 





 





 





 





876



   my($bf,@keys)=@_; 




6432




11




  
 50
  




 





 





 





34



   return if !@keys; 




6433




11




  
100
  



  
 66
  




 





 





45



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6434




11





 





 





 





 





51



   my($m,$k,$up,$n,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','capacity','counting_bits','adaptive'}; 




6435




11





 





 





 





 





37



   for(@$keysref){ 




6436




 





 





 





 





 





 



     #croak "Key should be scalar" if ref($_); 




6437




15084




  
 50
  



  
 66
  




 





 





40952



     $$bf{key_count} >= $n and croak "Exceeded filter capacity $n"  or  $$bf{key_count}++; 




6438




15083





 





 





 





 





18626



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




15083





 





 





 





 





132284



   




6439




15083




  
100
  



  
 66
  




 





 





51645



     if ($cb==1 and !$adaptive) { # normal bloom filter 




 




 




  
 50
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6440




11110





 





 





 





 





102943



       vec($$bf{filter}, $h[$_] % $m, 1) = 1 for 0..$k-1; 




6441




 





 





 





 





 





 



     } 




6442




 





 





 





 





 





 



     elsif ($cb>1) {                 # counting bloom filter 




6443




3973





 





 





 





 





7256



       for(0..$k-1){ 




6444




11919





 





 





 





 





17176



 	my $pos=$h[$_] % $m; 




6445




 





 





 





 





 





 



 	my $c= 




6446




 





 





 





 





 





 



   	vec($$bf{filter}, $pos, $cb) = 




6447




11919





 





 





 





 





29225



 	vec($$bf{filter}, $pos, $cb) + 1; 




6448




11919




  
100
  




 





 





 





35642



 	if($c==0){ 




6449




26





 





 





 





 





51



 	  vec($$bf{filter}, $pos, $cb) = -1; 




6450




 





 





 





 





 





 



 	  $$bf{overflow}{$pos}++ 




6451




26




  
100
  



  
100
  




 





 





134



 	    and keys(%{$$bf{overflow}})>10 #hmm, arbitrary limit 




 




2





 





 





 





 





244



   




6452




 





 





 





 





 





 



 	    and croak "Too many overflows, concider doubling counting_bits from $cb to ".(2*$cb); 




6453




 





 





 





 





 





 



 	} 




6454




 





 





 





 





 





 



       } 




6455




 





 





 





 





 





 



     } 




6456




 





 





 





 





 





 



     elsif ($adaptive) {             # adaptive bloom filter 




6457



  
0
  




 





 





 





 





0



       my($i,$key,$bit)=(0+@h,$_); 




6458



  
0
  




 





 





 





 





0



       for(0..$$bf{filterlength}-1){ 




6459



  
0
  



  
  0
  




 





 





 





0



 	$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h; 




6460



  
0
  




 





 





 





 





0



 	my $pos=shift(@h) % $m; 




6461



  
0
  




 





 





 





 





0



 	$bit=vec($$bf{filter}, $pos, 1); 




6462



  
0
  




 





 





 





 





0



 	vec($$bf{filter}, $pos, 1)=1; 




6463



  
0
  



  
  0
  



  
  0
  




 





 





0



 	last if $_>=$k-1 and $bit==0; 




6464




 





 





 





 





 





 



       } 




6465




 





 





 





 





 





 



     } 




6466



  
0
  




 





 





 





 





0



     else {croak} 




6467




 





 





 





 





 





 



   } 




6468




9





 





 





 





 





733



   return 1; 




6469




 





 





 





 





 





 



 } 




6470




 





 





 





 





 





 



 sub bfcheck { 




6471




5





 





 




  
5
  



  
1
  




83



   require Digest::MD5; 




6472




5





 





 





 





 





1178



   my($bf,@keys)=@_; 




6473




5




  
 50
  




 





 





 





18



   return if !@keys; 




6474




5




  
 50
  



  
 33
  




 





 





26



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6475




5





 





 





 





 





24



   my($m,$k,$up,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','counting_bits','adaptive'}; 




6476




5





 





 





 





 





12



   my $wa=wantarray(); 




6477




5




  
 50
  




 





 





 





15



   if(!$adaptive){    # normal bloom filter  or  counting bloom filter 




6478




 





 





 





 





 





 



     return map { 




6479




5





 





 





 





 





65



       my $match = 1; # match if every bit is on 




 




24001





 





 





 





 





28811



   




6480




24001





 





 





 





 





28750



       my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




24001





 





 





 





 





222331



   




6481




24001





 




  
100
  




 





 





209677



       vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
100
  




 





 





 



   




6482




24001




  
 50
  




 





 





 





44673



       return $match if !$wa; 




6483




24001





 





 





 





 





51962



       $match; 




6484




 





 





 





 





 





 



     } @$keysref; 




6485




 





 





 





 





 





 



   } 




6486




 





 





 





 





 





 



   else {             # adaptive bloom filter 




6487




 





 





 





 





 





 



     return map { 




6488



  
0
  




 





 





 





 





0



       my($match,$i,$key,$bit,@h)=(1,0,$_); 




 



  
0
  




 





 





 





 





0



   




6489



  
0
  




 





 





 





 





0



       for(0..$$bf{filterlength}-1){ 




6490



  
0
  



  
  0
  




 





 





 





0



 	$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h; 




6491



  
0
  




 





 





 





 





0



 	my $pos=shift(@h) % $m; 




6492



  
0
  




 





 





 





 





0



 	$bit=vec($$bf{filter}, $pos, 1); 




6493



  
0
  



  
  0
  



  
  0
  




 





 





0



 	$match++ if $_ >  $k-1 and $bit==1; 




6494



  
0
  



  
  0
  



  
  0
  




 





 





0



 	$match=0 if $_ <= $k-1 and $bit==0; 




6495



  
0
  



  
  0
  




 





 





 





0



 	last     if $bit==0; 




6496




 





 





 





 





 





 



       } 




6497



  
0
  



  
  0
  




 





 





 





0



       return $match if !$wa; 




6498



  
0
  




 





 





 





 





0



       $match; 




6499




 





 





 





 





 





 



     } @$keysref; 




6500




 





 





 





 





 





 



   } 




6501




 





 





 





 





 





 



 } 




6502




 





 





 





 





 





 



 sub bfgrep { # just a copy of bfcheck with map replaced by grep 




6503




8





 





 




  
8
  



  
1
  




870



   require Digest::MD5; 




6504




8





 





 





 





 





24



   my($bf,@keys)=@_; 




6505




8




  
 50
  




 





 





 





27



   return if !@keys; 




6506




8




  
 50
  



  
 33
  




 





 





65



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6507




8





 





 





 





 





34



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6508




 





 





 





 





 





 



   return grep { 




6509




8





 





 





 





 





29



     my $match = 1; # match if every bit is on 




 




6100





 





 





 





 





7316



   




6510




6100





 





 





 





 





6722



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




6100





 





 





 





 





40807



   




6511




6100





 




  
100
  




 





 





42786



     vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
100
  




 





 





 



   




6512




6100





 





 





 





 





11486



     $match; 




6513




 





 





 





 





 





 



   } @$keysref; 




6514




 





 





 





 





 





 



 } 




6515




 





 





 





 





 





 



 sub bfgrepnot { # just a copy of bfgrep with $match replaced by not $match 




6516




1





 





 




  
1
  



  
1
  




9



   require Digest::MD5; 




6517




1





 





 





 





 





3



   my($bf,@keys)=@_; 




6518




1




  
 50
  




 





 





 





5



   return if !@keys; 




6519




1




  
 50
  



  
 33
  




 





 





16



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6520




1





 





 





 





 





5



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6521




 





 





 





 





 





 



   return grep { 




6522




1





 





 





 





 





5



     my $match = 1; # match if every bit is on 




 




1000





 





 





 





 





1246



   




6523




1000





 





 





 





 





1149



     my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k; 




 




1000





 





 





 





 





6814



   




6524




1000





 




  
 50
  




 





 





7027



     vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1; 




 




 





 




  
 50
  




 





 





 



   




6525




1000





 





 





 





 





2346



     !$match; 




6526




 





 





 





 





 





 



   } @$keysref; 




6527




 





 





 





 





 





 



 } 




6528




 





 





 





 





 





 



 sub bfdelete { 




6529




3





 





 




  
3
  



  
1
  




91



   require Digest::MD5; 




6530




3





 





 





 





 





17



   my($bf,@keys)=@_; 




6531




3




  
 50
  




 





 





 





12



   return if !@keys; 




6532




3




  
100
  



  
100
  




 





 





20



   my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys; 




6533




3





 





 





 





 





11



   my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'}; 




6534




3




  
 50
  




 





 





 





8



   croak "Cannot delete from non-counting bloom filter (use counting_bits 4 e.g.)" if $cb==1; 




6535




3





 





 





 





 





7



   for my $key (@$keysref){ 




6536




501





 





 





 





 





537



     my @h; push @h, unpack $up, Digest::MD5::md5($key,0+@h) while @h<$k; 




 




501





 





 





 





 





3437



   




6537




501




  
 50
  



  
 33
  




 





 





1432



     $$bf{key_count}==0 and croak "Deleted all and then some"  or  $$bf{key_count}--; 




6538




501





 





 





 





 





782



     my($ones,$croak,@pos)=(0); 




6539




501





 





 





 





 





925



     for(0..$k-1){ 




6540




1503





 





 





 





 





2149



       my $pos=$h[$_] % $m; 




6541




 





 





 





 





 





 



       my $c= 




6542




1503





 





 





 





 





2267



       vec($$bf{filter}, $pos, $cb); 




6543




1503





 





 





 





 





3127



       vec($$bf{filter}, $pos, $cb)=$c-1; 




6544




1503




  
100
  




 





 





 





3244



       $croak="Cannot delete a non-existing key $key" if $c==0; 




6545




 





 





 





 





 





 



       $croak="Cannot delete with previously overflown position. Try doubleing counting_bits" 




6546




1503




  
 50
  



  
 66
  




 





 





6247



 	if $c==1 and ++$ones and $$bf{overflow}{$pos}; 




 




 





 




  
 66
  




 





 





 



   




6547




 





 





 





 





 





 



     } 




6548




501




  
100
  




 





 





 





1241



     if($croak){ #rollback 




6549




 





 





 





 





 





 



       vec($$bf{filter}, $h[$_] % $m, $cb)= 




6550




1





 





 





 





 





11



       vec($$bf{filter}, $h[$_] % $m, $cb)+1 for 0..$k-1; 




6551




1





 





 





 





 





200



       croak $croak; 




6552




 





 





 





 





 





 



     } 




6553




 





 





 





 





 





 



   } 




6554




2





 





 





 





 





20



   return $bf; 




6555




 





 





 





 





 





 



 } 




6556




 





 





 





 





 





 



 sub bfstore { 




6557




1





 





 




  
1
  



  
1
  




22727



   require Storable; 




6558




1





 





 





 





 





8



   Storable::store(@_); 




6559




 





 





 





 





 





 



 } 




6560




 





 





 





 





 





 



 sub bfretrieve { 




6561




2





 





 




  
2
  



  
1
  




527



   require Storable; 




6562




2





 





 





 





 





11



   my $bf=Storable::retrieve(@_); 




6563




2




  
 50
  




 





 





 





545



   carp  "Retrieved bloom filter was stored in version $$bf{version}, this is version $VERSION" if $$bf{version}>$VERSION; 




6564




2





 





 





 





 





7



   return $bf; 




6565




 





 





 





 





 





 



 } 




6566




 





 





 





 





 





 



 sub bfclone { 




6567




1





 





 




  
1
  



  
1
  




30668



   require Storable; 




6568




1





 





 





 





 





8452



   return Storable::dclone(@_); #could be faster 




6569




 





 





 





 





 





 



 } 




6570




 





 





 





 





 





 



 sub bfdimensions_old { 




6571




 





 





 





 





 





 



   my($n,$p,$mink,$maxk, $k,$flen,$m)= 




6572



  
0
  



  
  0
  




 




  
0
  



  
0
  




0



     @_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'},1) 




 



  
0
  



  
  0
  




 





 





 





0



   




6573




 





 





 





 





 





 



    :@_==2 ? (@_,1,100,1) 




6574




 





 





 





 





 





 



           : croak "Wrong number of arguments (".@_."), should be 2"; 




6575



  
0
  



  
  0
  



  
  0
  




 





 





0



   croak "p ($p) should be > 0 and < 1" if not ( 0<$p && $p<1 ); 




6576



  
0
  




 




  
  0
  




 





 





0



   $m=-1*$_*$n/log(1-$p**(1/$_)) and (!defined $flen or $m<$flen) and ($flen,$k)=($m,$_) for $mink..$maxk; 




 




 





 




  
  0
  




 





 





 



   




 




 





 




  
  0
  




 





 





 



   




6577



  
0
  




 





 





 





 





0



   $flen = int(1+$flen); 




6578



  
0
  




 





 





 





 





0



   return ($flen,$k); 




6579




 





 





 





 





 





 



 } 




6580




 





 





 





 





 





 



 sub bfdimensions { 




6581




 





 





 





 





 





 



   my($n,$p,$mink,$maxk)= 




6582




18




  
  0
  




 




  
18
  



  
1
  




48



     @_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'}) 




 




18




  
 50
  




 





 





 





52



   




6583




 





 





 





 





 





 



    :@_==2 ? (@_,1,100) 




6584




 





 





 





 





 





 



           : croak "Wrong number of arguments (".@_."), should be 2"; 




6585




18





 





 





 





 





66



   my $k=log(1/$p)/log(2);           # k hash funcs 




6586




18





 





 





 





 





47



   my $m=-$n*log($p)/log(2)**2;      # m bits in filter 




6587




18





 





 





 





 





65



   return ($m+0.5,min($maxk,max($mink,int($k+0.5)))); 




6588




 





 





 





 





 





 



 } 




6589




 





 





 





 





 





 



   




6590




 





 





 





 





 





 



 #crontab -e 




6591




 





 





 





 





 





 



 #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 




6592




 





 





 





 





 





 



   




6593




 





 





 





 





 





 



 sub _update_currency_file { #call from cron 




6594



  
0
  




 




  
  0
  



  
0
  




 





0



   my $fn=shift()||'/var/www/html/currency-rates'; 




6595



  
0
  




 




  
  0
  




 





 





0



   my %exe=map+($_=>"/usr/bin/$_"),qw/curl ci/;-x$_ or die for values %exe; 




 



  
0
  




 





 





 





 





0



   




6596



  
0
  



  
  0
  




 





 





 





0



   open my $F, '>', $fn or die"ERROR: Could not write file $fn ($!)\n"; 




6597



  
0
  




 





 





 





 





0



   print $F "#-- Currency rates ".localtime()." (".time().")\n"; 




6598



  
0
  




 





 





 





 





0



   print $F "#   File generated by Acme::Tools version $VERSION\n"; 




6599



  
0
  




 





 





 





 





0



   print $F "#   Updated every 6th hour on http://calthis.com/currency-rates\n"; 




6600



  
0
  




 





 





 





 





0



   print $F "NOK 1.000000000\n"; 




6601



  
0
  




 





 





 





 





0



   my $amount=1000; 




6602



  
0
  




 





 





 





 





0



   my $data=qx($exe{curl} -s "http://www.x-rates.com/table/?from=NOK&amount=$amount"); 




6603



  
0
  




 





 





 





 





0



   $data=~s,to=([A-Z]{3})(.)>,$2>$1,g; 




6604



  
0
  




 





 





 





 





0



   my @data=ht2t($data,"Alphabetical order"); shift @data; 




 



  
0
  




 





 





 





 





0



   




6605



  
0
  



  
  0
  




 





 





 





0



   @data=map "$$_[1] ".($$_[4]>1e-2?$$_[4]:$$_[2]?sprintf("%.8f",$amount/$$_[2]):0)."\n",@data; 




 




 




  
  0
  




 





 





 





 



   




6606



  
0
  




 





 





 





 





0



   my %data=map split,@data; 




6607



  
0
  




 





 





 





 





0



   my@tc=qx($exe{curl} -s https://btc-e.com/api/3/ticker/btc_usd-ltc_usd)=~/avg.?:(\d+\.?\d*)/g; 




6608



  
0
  




 





 





 





 





0



   push @data,"BTC ".($tc[0]*$data{USD})."\n"; 




6609



  
0
  




 





 





 





 





0



   push @data,"LTC ".($tc[1]*$data{USD})."\n"; 




6610



  
0
  




 





 





 





 





0



   print $F sort(@data); 




6611



  
0
  




 





 





 





 





0



   close($F); 




6612



  
0
  



  
  0
  




 





 





 





0



   qx($exe{ci} -l -m. -d $fn) if -w"$fn,v"; 




6613




 





 





 





 





 





 



 } 




6614




 





 





 





 





 





 



   




6615




 





 





 





 





 





 



 sub ftype { 




6616



  
0
  




 





 




  
0
  



  
0
  




0



   my $f=shift; 




6617



  
0
  



  
  0
  



  
  0
  




 





 





0



   -e $f and 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6618




 





 





 





 





 





 



       -f$f ? 'file'         # -f  File is a plain file. 




6619




 





 





 





 





 





 



      :-d$f ? 'dir'          # -d  File is a directory. 




6620




 





 





 





 





 





 



      :-l$f ? 'symlink'      # -l  File is a symbolic link. 




6621




 





 





 





 





 





 



      :-p$f ? 'pipe'         # -p  File is a named pipe (FIFO), or Filehandle is a pipe. 




6622




 





 





 





 





 





 



      :-S$f ? 'socket'       # -S  File is a socket. 




6623




 





 





 





 





 





 



      :-b$f ? 'blockfile'    # -b  File is a block special file. 




6624




 





 





 





 





 





 



      :-c$f ? 'charfile'     # -c  File is a character special file. 




6625




 





 





 





 





 





 



      :-t$f ? 'ttyfile'      # -t  Filehandle is opened to a tty. 




6626




 





 





 





 





 





 



      :       '' 




6627




 





 





 





 





 





 



   or undef; 




6628




 





 





 





 





 





 



 } 




6629




 





 





 





 





 





 



   




6630




 





 





 





 





 





 



 =head1 COMMANDS 




6631




 





 





 





 





 





 



   




6632




 





 





 





 





 





 



 =head2 install_acme_command_tools 




6633




 





 





 





 





 





 



   




6634




 





 





 





 





 





 



  sudo perl -MAcme::Tools -e install_acme_command_tools 




6635




 





 





 





 





 





 



  Wrote executable /usr/local/bin/conv 




6636




 





 





 





 





 





 



  Wrote executable /usr/local/bin/due 




6637




 





 





 





 





 





 



  Wrote executable /usr/local/bin/xcat 




6638




 





 





 





 





 





 



  Wrote executable /usr/local/bin/freq 




6639




 





 





 





 





 





 



  Wrote executable /usr/local/bin/deldup 




6640




 





 





 





 





 





 



  Wrote executable /usr/local/bin/wipe 




6641




 





 





 





 





 





 



   




6642




 





 





 





 





 





 



 Examples of commands then made available: 




6643




 





 





 





 





 





 



   




6644




 





 





 





 





 





 



  conv 1 USD EUR                #might show 0.88029 if thats the current currency rate. Uses conv() 




6645




 





 





 





 





 





 



  conv .5 in cm                 #reveals that 1/2 inch is 1.27 cm, see doc on conv() for all supported units 




6646




 





 





 





 





 





 



  due [-h] /path/1/ /path/2/    #like du, but show statistics on file extentions instead of subdirs 




6647




 





 





 





 





 





 



  xcat file                     #like cat, zcat, bzcat or xzcat in one. Uses file extention to decide. Uses openstr() 




6648




 





 





 





 





 





 



  freq file                     #reads file(s) or stdin and view counts of each byte 0-255 




6649




 





 





 





 





 





 



  deldup [-d] path1/ path2/     #reports (and optionally deletes) duplicate files NOT IMPLEMENTED YET! 




6650




 





 





 





 





 





 



  ccmd grep string /huge/file   #caches stdout+stderr for 15 minutes (default) for much faster results later 




6651




 





 





 





 





 





 



  ccmd "sleep 2;echo hello"     #slow first time. Note the quotes! 




6652




 





 





 





 





 





 



  ccmd "du -s ~/*|sort -n|tail" #ccmd store stdout+stderr in /tmp files (default) 




6653




 





 





 





 





 





 



   




6654




 





 





 





 





 





 



 =head3 due 




6655




 





 





 





 





 





 



   




6656




 





 





 





 





 





 



 Like C command but views space used by file extentions instead of dirs. Options: 




6657




 





 





 





 





 





 



   




6658




 





 





 





 





 





 



  due [-options] [dirs] [files] 




6659




 





 





 





 





 





 



  due -h          View bytes "human readable", i.e. C<8.72 MB> instead of C<9145662 b> (bytes) 




6660




 





 





 





 





 





 



  due -k | -m     View bytes in kilobytes | megabytes (1024 | 1048576) 




6661




 





 





 





 





 





 



  due -K          Like -k but uses 1000 instead of 1024 




6662




 





 





 





 





 





 



  due -z          View two extentions if .z .Z .gz .bz2 .rz or .xz (.tar.gz, not just .gz) 




6663




 





 





 





 





 





 



  due -M          Also show min, medium and max date (mtime) of files, give an idea of their age 




6664




 





 





 





 





 





 



  due -P          Also show 10, 50 (medium) and 90 percentile of file date 




6665




 





 





 





 





 





 



  due -MP         Both -M and -P, shows min, 10p, 50p, 90p and max 




6666




 





 





 





 





 





 



  due -a          Sort output alphabetically by extention (default order is by size) 




6667




 





 





 





 





 





 



  due -c          Sort output by number of files 




6668




 





 





 





 





 





 



  due -i          Ignore case, .GZ and .gz is the same, output in lower case 




6669




 





 





 





 





 





 



  due -t          Adds time of day to -M and -P output 




6670




 





 





 





 





 





 



  due -e 'regex'  Exclude files (full path) matching regex. Ex: due -e '\.git' 




6671




 





 





 





 





 





 



   




6672




 





 





 





 





 





 



 =cut 




6673




 





 





 





 





 





 



   




6674




 





 





 





 





 





 



 sub install_acme_command_tools { 




6675



  
0
  




 





 




  
0
  



  
1
  




0



   my $dir=(grep -d$_, @_, '/usr/local/bin', '/usr/bin')[0]; 




6676



  
0
  




 





 





 





 





0



   for(qw( conv due xcat freq deldup ccmd )){ 




6677



  
0
  




 





 





 





 





0



     unlink("$dir/$_"); 




6678



  
0
  




 





 





 





 





0



     writefile("$dir/$_", "#!$^X\nuse Acme::Tools;\nAcme::Tools::cmd_$_(\@ARGV);\n"); 




6679



  
0
  




 





 





 





 





0



     sys("/bin/chmod +x $dir/$_"); 




6680



  
0
  




 





 





 





 





0



     print "Wrote executable $dir/$_\n"; 




6681




 





 





 





 





 





 



   } 




6682




 





 





 





 





 





 



 } 




6683



  
0
  




 





 




  
0
  



  
0
  




0



 sub cmd_conv { print conv(@ARGV)."\n"  } 




6684




28





 





 




  
28
  




 





51697



   use Data::Dumper; 




 




28





 





 





 





 





294442



   




 




28





 





 





 





 





3305



   




6685




 





 





 





 





 





 



 sub cmd_due { #TODO: output from tar tvf and ls and find -ls 




6686



  
0
  




 





 




  
0
  



  
0
  




0



   require Getopt::Std; my %o; Getopt::Std::getopts("zkKmhciMPate:" => \%o); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6687



  
0
  




 





 





 





 





0



   require File::Find; 




6688




28





 





 




  
28
  




 





189



   no warnings 'uninitialized'; 




 




28





 





 





 





 





55



   




 




28





 





 





 





 





86776



   




6689



  
0
  



  
  0
  




 





 





 





0



   die"$0: -h, -k or -m can not be used together\n" if $o{h}+$o{k}+$o{m}>1; 




6690



  
0
  



  
  0
  




 





 





 





0



   die"$0: -c and -a can not be used together\n"    if $o{a}+$o{c}>1; 




6691



  
0
  



  
  0
  




 





 





 





0



   die"$0: -k and -m can not be used together\n"    if $o{k}+$o{m}>1; 




6692



  
0
  



  
  0
  




 





 





 





0



   my @q=@ARGV; @q=('.') if !@q; 




 



  
0
  




 





 





 





 





0



   




6693



  
0
  




 





 





 





 





0



   my(%c,%b,$cnt,$bts,%mtime); 




6694



  
0
  



  
  0
  




 





 





 





0



   my $r=$o{z} ? qr/(\.[^\.\/]{1,10}(\.(z|Z|gz|bz2|rz|xz))?)$/ 




6695




 





 





 





 





 





 



               : qr/(\.[^\.\/]{1,10})$/; 




6696



  
0
  



  
  0
  




 





 





 





0



   my $rexcl=exists$o{e}?qr/$o{e}/:0; 




6697




 





 





 





 





 





 



   File::Find::find({wanted => 




6698




 





 





 





 





 





 



     sub { 




6699



  
0
  



  
  0
  




 




  
0
  




 





0



       return if !-f$_; 




6700



  
0
  



  
  0
  



  
  0
  




 





 





0



       return if $rexcl and $File::Find::name=~$rexcl; 




6701



  
0
  




 





 





 





 





0



       my($sz,$mtime)=(stat($_))[7,9]; 




6702



  
0
  



  
  0
  




 





 





 





0



       my $ext=m/$r/?$1:""; 




6703



  
0
  



  
  0
  




 





 





 





0



       $ext=lc($ext) if $o{i}; 




6704



  
0
  




 





 





 





 





0



       $cnt++;    $c{$ext}++; 




 



  
0
  




 





 





 





 





0



   




6705



  
0
  




 





 





 





 





0



       $bts+=$sz; $b{$ext}+=$sz; 




 



  
0
  




 





 





 





 





0



   




6706



  
0
  



  
  0
  



  
  0
  




 





 





0



       $mtime{$ext}.=",$mtime" if $o{M} or $o{P}; 




6707



  
0
  




 





 





 





 





0



       1; 




6708



  
0
  




 





 





 





 





0



     } },@q); 




6709



  
0
  




 





 




  
0
  




 





0



   my($f,$s)=$o{k}?("%14.2f kb",sub{$_[0]/1024}) 




6710



  
0
  




 





 




  
0
  




 





0



            :$o{K}?("%14.2f Kb",sub{$_[0]/1000}) 




6711



  
0
  




 





 




  
0
  




 





0



            :$o{m}?("%14.2f mb",sub{$_[0]/1024**2}) 




6712



  
0
  




 





 




  
0
  




 





0



            :$o{h}?("%14s",     sub{bytes_readable($_[0])}) 




6713



  
0
  



  
  0
  




 




  
0
  




 





0



            :      ("%14d b",   sub{$_[0]}); 




 



  
0
  



  
  0
  




 





 





 





0



   




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6714




 





 





 





 





 





 



   my @e=$o{a}?(sort(keys%c)) 




6715



  
0
  



  
  0
  




 





 





 





0



        :$o{c}?(sort{$c{$a}<=>$c{$b} or $a cmp $b}keys%c) 




6716



  
0
  



  
  0
  




 





 





 





0



        :      (sort{$b{$a}<=>$b{$b} or $a cmp $b}keys%c); 




 



  
0
  



  
  0
  




 





 





 





0



   




 




 




  
  0
  




 





 





 





 



   




6717



  
0
  



  
  0
  




 





 





 





0



   my @p=$o{P}?(10,50,90):(50); 




6718




 





 





 





 





 





 



   my $perc=sub{ 




6719



  
0
  



  
  0
  



  
  0
  



  
0
  




 





0



     $o{M} or $o{P} or return""; 




6720



  
0
  




 





 





 





 





0



     my @m=@_>0 ? do {grep$_, split",", $mtime{$_[0]}} 




6721



  
0
  



  
  0
  




 





 





 





0



                : do {grep$_, map {split","} values %mtime}; 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6722



  
0
  




 





 





 





 





0



     my @r=percentile(\@p,@m); 




6723



  
0
  



  
  0
  




 





 





 





0



     @r=(min(@m),@r,max(@m)) if $o{M}; 




6724



  
0
  




 





 





 





 





0



     @r=map int($_), @r; 




6725



  
0
  



  
  0
  




 





 





 





0



     my $fmt='YYYY/MM/DD'; $fmt.="-MM:MI:SS" if $o{t}; 




 



  
0
  




 





 





 





 





0



   




6726



  
0
  




 





 





 





 





0



     @r=map tms($_,$fmt), @r; 




6727



  
0
  




 





 





 





 





0



     "  ".join(" ",@r); 




6728



  
0
  




 





 





 





 





0



   }; 




6729



  
0
  




 





 





 





 





0



   printf("%-11s %8d $f %7.2f%%%s\n",$_,$c{$_},&$s($b{$_}),100*$b{$_}/$bts,&$perc($_)) for @e; 




6730



  
0
  




 





 





 





 





0



   printf("%-11s %8d $f %7.2f%%%s\n","Sum",$cnt,&$s($bts),100,&$perc()); 




6731




 





 





 





 





 





 



 } 




6732




 





 





 





 





 





 



 sub cmd_xcat { 




6733



  
0
  




 





 




  
0
  



  
0
  




0



   for my $fn (@_){ 




6734



  
0
  




 





 





 





 





0



     my $os=openstr($fn); 




6735



  
0
  



  
  0
  



  
  0
  




 





 





0



     open my $FH, $os or warn "xcat: cannot open $os ($!)\n" and next; 




6736



  
0
  




 





 





 





 





0



     print while <$FH>; 




6737



  
0
  




 





 





 





 





0



     close($FH); 




6738




 





 





 





 





 





 



   } 




6739




 





 





 





 





 





 



 } 




6740




 





 





 





 





 





 



 sub cmd_freq { 




6741



  
0
  




 





 




  
0
  



  
0
  




0



   my(@f,$i); 




6742



  
0
  




 





 





 





 





0



   map $f[$_]++, unpack("C*",$_) while <>; 




6743



  
0
  




 





 





 





 





0



   my $s=" " x 12;map{print"$_$s$_$s$_\n"}("BYTE  CHAR   COUNT","---- ----- -------"); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6744



  
0
  




 





 





 





 





0



   my %m=(145,"DOS-æ",155,"DOS-ø",134,"DOS-å",146,"DOS-Æ",157,"DOS-Ø",143,"DOS-Å",map{($_," ")}0..31); 




 



  
0
  




 





 





 





 





0



   




6745



  
0
  



  
  0
  



  
  0
  




 





 





0



   printf("%4d %5s%8d".(++$i%3?$s:"\n"),$_,$m{$_}||chr,$f[$_]) for grep$f[$_],0..255;print "\n"; 




 



  
0
  




 





 





 





 





0



   




6746



  
0
  




 





 





 





 





0



   my @no=grep!$f[$_],0..255; print "No bytes for these ".@no.": ".join(" ",@no)."\n"; 




 



  
0
  




 





 





 





 





0



   




6747




 





 





 





 





 





 



 } 




6748




 





 





 





 





 





 



   




6749




 





 





 





 





 





 



 sub cmd_deldup { 




6750




 





 





 





 





 





 



   # ~/test/deldup.pl #find and optionally delete duplicate files effiencently 




6751




 





 





 





 





 





 



   #http://www.commandlinefu.com/commands/view/3555/find-duplicate-files-based-on-size-first-then-md5-hash 




6752



  
0
  




 





 




  
0
  



  
0
  




0



   die "todo: deldup not ready yet" 




6753




 





 





 





 





 





 



 } 




6754




 





 





 





 





 





 



   




6755




 





 





 





 





 





 



 #http://stackoverflow.com/questions/11900239/can-i-cache-the-output-of-a-command-on-linux-from-cli 




6756




 





 





 





 





 





 



 our $Ccmd_cache_dir='/tmp/acme-tools-ccmd-cache'; 




6757




 





 





 





 





 





 



 our $Ccmd_cache_expire=15*60;  #default 15 minutes 




6758




 





 





 





 





 





 



 sub cmd_ccmd { 




6759



  
0
  




 





 




  
0
  



  
0
  




0



   require Digest::MD5; 




6760



  
0
  




 





 





 





 





0



   my $cmd=join" ",@_; 




6761



  
0
  




 





 





 





 





0



   my $d="$Ccmd_cache_dir/".username(); 




6762



  
0
  




 





 





 





 





0



   makedir($d); 




6763



  
0
  




 





 





 





 





0



   my $md5=Digest::MD5::md5_hex($cmd); 




6764



  
0
  




 





 





 





 





0



   my($fno,$fne)=map"$d/cmd.$md5.std$_","out","err"; 




6765



  
0
  




 





 




  
0
  




 





0



   my $too_old=sub{time()-(stat(shift))[9] >= $Ccmd_cache_expire}; 




 



  
0
  




 





 





 





 





0



   




6766



  
0
  




 





 





 





 





0



   unlink grep &$too_old($_), <$d/*.std???>; 




6767



  
0
  



  
  0
  



  
  0
  




 





 





0



   sys("($cmd) > $fno 2> $fne") if !-e$fno or &$too_old($fno); 




6768



  
0
  




 





 





 





 





0



   print STDOUT "".readfile($fno); 




6769



  
0
  




 





 





 





 





0



   print STDERR "".readfile($fne); 




6770




 





 





 





 





 





 



 } 




6771




 





 





 





 





 





 



   




6772



  
0
  




 





 




  
0
  



  
0
  




0



 sub cmd_trunc { die "todo: trunc not ready yet"} #truncate a file, size 0, keep all other attr 




6773




 





 





 





 





 





 



   




6774




 





 





 





 





 





 



 sub cmd_wipe  { 




6775



  
0
  




 





 




  
0
  



  
0
  




0



   require Getopt::Std; my %o; Getopt::Std::getopts("n:k" => \%o); 




 



  
0
  




 





 





 





 





0



   




 



  
0
  




 





 





 





 





0



   




6776



  
0
  




 





 





 





 





0



   wipe($_,$o{n},$o{k}) for @_; 




6777




 





 





 





 





 





 



 } 




6778




 





 





 





 





 





 



   




6779




 





 





 





 





 





 



 =head1 DATABASE STUFF - NOT IMPLEMENTED YET 




6780




 





 





 





 





 





 



   




6781




 





 





 





 





 





 



 Uses L. Comming soon... 




6782




 





 





 





 





 





 



   




6783




 





 





 





 





 





 



   $Dbh 




6784




 





 





 





 





 





 



   dlogin 




6785




 





 





 





 





 





 



   dlogout 




6786




 





 





 





 





 





 



   drow 




6787




 





 





 





 





 





 



   drows 




6788




 





 





 





 





 





 



   drowc 




6789




 





 





 





 





 





 



   drowsc 




6790




 





 





 





 





 





 



   dcols 




6791




 





 





 





 





 





 



   dpk 




6792




 





 





 





 





 





 



   dsel 




6793




 





 





 





 





 





 



   ddo 




6794




 





 





 





 





 





 



   dins 




6795




 





 





 





 





 





 



   dupd 




6796




 





 





 





 





 





 



   ddel 




6797




 





 





 





 





 





 



   dcommit 




6798




 





 





 





 





 





 



   drollback 




6799




 





 





 





 





 





 



   




6800




 





 





 





 





 





 



 =cut 




6801




 





 





 





 





 





 



   




6802




 





 





 





 





 





 



 #my$dummy=<<'SOON'; 




6803




 





 





 





 





 





 



 sub dtype { 




6804



  
0
  




 





 




  
0
  



  
0
  




0



   my $connstr=shift; 




6805



  
0
  



  
  0
  




 





 





 





0



   return 'SQLite' if $connstr=~/(\.sqlite|sqlite:.*\.db)$/i; 




6806



  
0
  



  
  0
  




 





 





 





0



   return 'Oracle' if $connstr=~/\@/; 




6807



  
0
  




 





 





 





 





0



   return 'Pg' if 1==2; 




6808



  
0
  




 





 





 





 





0



   die; 




6809




 





 





 





 





 





 



 } 




6810




 





 





 





 





 





 



   




6811




 





 





 





 





 





 



 our($Dbh,@Dbh,%Sth); 




6812




 





 





 





 





 





 



 our %Dbattr=(RaiseError => 1, AutoCommit => 0); #defaults 




6813




 





 





 





 





 





 



 sub dlogin { 




6814



  
0
  




 





 




  
0
  



  
0
  




0



   my $connstr=shift(); 




6815



  
0
  




 





 





 





 





0



   my %attr=(%Dbattr,@_); 




6816



  
0
  




 





 





 





 





0



   my $type=dtype($connstr); 




6817



  
0
  




 





 





 





 





0



   my($dsn,$u,$p)=('','',''); 




6818



  
0
  



  
  0
  




 





 





 





0



   if($type eq 'SQLite'){ 




 




 




  
  0
  




 





 





 





 



   




 




 




  
  0
  




 





 





 





 



   




6819



  
0
  




 





 





 





 





0



     $dsn=$connstr; 




6820




 





 





 





 





 





 



   } 




6821




 





 





 





 





 





 



   elsif($type eq 'Oracle'){ 




6822



  
0
  




 





 





 





 





0



     ($u,$p,$dsn)=($connstr=~m,(.+?)(/.+?)?\@(.+),); 




6823




 





 





 





 





 





 



   } 




6824




 





 





 





 





 





 



   elsif($type eq 'Pg'){ 




6825



  
0
  




 





 





 





 





0



     croak "todo"; 




6826




 





 





 





 





 





 



   } 




6827




 





 





 





 





 





 



   else{ 




6828



  
0
  




 





 





 





 





0



     croak "dblogin: unknown database type for connection string $connstr\n"; 




6829




 





 





 





 





 





 



   } 




6830



  
0
  




 





 





 





 





0



   $dsn="dbi:$type:$dsn"; 




6831



  
0
  



  
  0
  




 





 





 





0



   push @Dbh, $Dbh if $Dbh; #local is better? 




6832



  
0
  




 





 





 





 





0



   require DBI; 




6833



  
0
  




 





 





 





 





0



   $Dbh=DBI->connect($dsn,$u,$p,\%attr); #connect_cached? 




6834




 





 





 





 





 





 



 } 




6835




 





 





 





 





 





 



 sub dlogout { 




6836



  
0
  




 





 




  
0
  



  
0
  




0



   $Dbh->disconnect; 




6837



  
0
  



  
  0
  




 





 





 





0



   $Dbh=pop@Dbh if @Dbh; 




6838




 





 





 





 





 





 



 } 




6839




 





 





 





 





 





 



 sub drow { 




6840



  
0
  




 





 




  
0
  



  
0
  




0



   my($q,@b)=_dattrarg(@_); 




6841




 





 





 





 





 





 



   #my $sth=do{$Sth{$Dbh,$q} ||= $Dbh->prepare_cached($q)}; 




6842



  
0
  




 





 





 





 





0



   my $sth=$Dbh->prepare_cached($q); 




6843



  
0
  




 





 





 





 





0



   $sth->execute(@b); 




6844



  
0
  




 





 





 





 





0



   my @r=$sth->fetchrow_array; 




6845



  
0
  



  
  0
  




 





 





 





0



   $sth->finish if $$Dbh{Driver}{Name} eq 'SQLite'; 




6846




 





 





 





 





 





 



   #$dbh->selectrow_array($statement); 




6847



  
0
  



  
  0
  




 





 





 





0



   return @r==1?$r[0]:@r; 




6848




 





 





 





 





 





 



 } 




6849




 





 





 




  
0
  



  
0
  




 



 sub drows { 




6850




 





 





 





 





 





 



 } 




6851




 





 





 




  
0
  



  
0
  




 



 sub drowc { 




6852




 





 





 





 





 





 



 } 




6853




 





 





 




  
0
  



  
0
  




 



 sub drowsc { 




6854




 





 





 





 





 





 



 } 




6855




 





 





 




  
0
  



  
0
  




 



 sub dcols { 




6856




 





 





 





 





 





 



 } 




6857




 





 





 




  
0
  



  
0
  




 



 sub dpk { 




6858




 





 





 





 





 





 



 } 




6859




 





 





 




  
0
  



  
0
  




 



 sub dsel { 




6860




 





 





 





 





 





 



 } 




6861




 





 





 





 





 





 



 sub ddo { 




6862



  
0
  




 





 




  
0
  



  
0
  




0



   my @arg=_dattrarg(@_); 




6863




 





 





 





 





 





 



   #warn serialize(\@arg,'arg','',1); 




6864



  
0
  




 





 





 





 





0



   $Dbh->do(@arg); #hm cache? 




6865




 





 





 





 





 





 



 } 




6866




 





 





 




  
0
  



  
0
  




 



 sub dins { 




6867




 





 





 





 





 





 



 } 




6868




 





 





 




  
0
  



  
0
  




 



 sub dupd { 




6869




 





 





 





 





 





 



 } 




6870




 





 





 




  
0
  



  
0
  




 



 sub ddel { 




6871




 





 





 





 





 





 



 } 




6872



  
0
  




 





 




  
0
  



  
0
  




0



 sub dcommit { $Dbh->commit } 




6873



  
0
  




 





 




  
0
  



  
0
  




0



 sub drollback { $Dbh->rollback } 




6874




 





 





 





 





 





 



   




6875




 





 





 





 





 





 



 sub _dattrarg { 




6876



  
0
  




 





 




  
0
  




 





0



   my @arg=@_; 




6877



  
0
  



  
  0
  




 





 





 





0



   splice @arg,1,0, ref($arg[-1]) eq 'HASH' ? pop(@arg) : {}; 




6878



  
0
  




 





 





 





 





0



   @arg; 




6879




 





 





 





 





 





 



 } 




6880




 





 





 





 





 





 



   




6881




 





 





 





 





 





 



 =head2 self_update 




6882




 





 





 





 





 





 



   




6883




 





 





 





 





 





 



 Update Acme::Tools to newest version quick and dirty: 




6884




 





 





 





 





 





 



   




6885




 





 





 





 





 





 



  function pmview(){ ls -ld `perl -M$1 -le'$m=shift;$mi=$m;$mi=~s,::,/,g;print $INC{"$mi.pm"};warn"Version ".${$m."::VERSION"}."\n"' $1`;} 




6886




 





 





 





 





 





 



   




6887




 





 





 





 





 





 



  pmview Acme::Tools                                     #view date and version before 




6888




 





 





 





 





 





 



  sudo perl -MAcme::Tools -e Acme::Tools::self_update    #update to newest version 




6889




 





 





 





 





 





 



  pmview Acme::Tools                                     #view date and version after 




6890




 





 





 





 





 





 



   




6891




 





 





 





 





 





 



 Does C to where Acme/Tools.pm are and then wget -N https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm 




6892




 





 





 





 





 





 



   




6893




 





 





 





 





 





 



 =cut 




6894




 





 





 





 





 





 



   




6895




 





 





 





 





 





 



 our $Wget; 




6896




 





 





 





 





 





 



 our $Self_update_url='https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm'; #todo: change site 




6897




 





 





 





 





 





 



 sub self_update { 




6898




 





 





 





 





 





 



   #in($^O,'linux','cygwin') or die"ERROR: self_update works on linux and cygwin only"; 




6899



  
0
  




 




  
  0
  



  
0
  



  
1
  




0



   $Wget||=(grep -x$_,map"$_/wget",'/usr/bin','/bin','/usr/local/bin','.')[0]; #hm --no-check-certificate 




6900



  
0
  



  
  0
  




 





 





 





0



   -x$Wget or die"ERROR: wget ($Wget) executable not found\n"; 




6901



  
0
  




 





 





 





 





0



   my $d=dirname(__FILE__); 




6902



  
0
  




 





 





 





 





0



   sys("cd $d; ls -l Tools.pm; md5sum Tools.pm"); 




6903



  
0
  




 




  
  0
  




 





 





0



   sys("cd $d; $Wget -N ".($ARGV[0]||$Self_update_url)); 




6904



  
0
  




 





 





 





 





0



   sys("cd $d; ls -l Tools.pm; md5sum Tools.pm"); 




6905




 





 





 





 





 





 



 } 




6906




 





 





 





 





 





 



   




6907




 





 





 





 





 





 



 1; 




6908




 





 





 





 





 





 



   




6909




 





 





 





 





 





 



 package Acme::Tools::BloomFilter; 




6910




28





 





 




  
28
  




 





768



 use 5.008; use strict; use warnings; use Carp; 




 




28





 





 




  
28
  




 





101



   




 




28





 





 




  
28
  




 





141



   




 




28





 





 




  
28
  




 





50



   




 




28





 





 





 





 





738



   




 




28





 





 





 





 





132



   




 




28





 





 





 





 





46



   




 




28





 





 





 





 





969



   




 




28





 





 





 





 





143



   




 




28





 





 





 





 





46



   




 




28





 





 





 





 





14374



   




6911




2





 





 




  
2
  




 





307



 sub new      { my($class,@p)=@_; my $self=Acme::Tools::bfinit(@p); bless $self, $class } 




 




2





 





 





 





 





9



   




 




2





 





 





 





 





11



   




6912




2





 





 




  
2
  




 





108



 sub add      { &Acme::Tools::bfadd      } 




6913



  
0
  




 





 




  
0
  




 





0



 sub addbf    { &Acme::Tools::bfaddbf    } 




6914




2





 





 




  
2
  




 





88



 sub check    { &Acme::Tools::bfcheck    } 




6915




1





 





 




  
1
  




 





7



 sub grep     { &Acme::Tools::bfgrep     } 




6916



  
0
  




 





 




  
0
  




 





0



 sub grepnot  { &Acme::Tools::bfgrepnot  } 




6917



  
0
  




 





 




  
0
  




 





0



 sub delete   { &Acme::Tools::bfdelete   } 




6918



  
0
  




 





 




  
0
  




 





0



 sub store    { &Acme::Tools::bfstore    } 




6919



  
0
  




 





 




  
0
  




 





0



 sub retrieve { &Acme::Tools::bfretrieve } 




6920




1





 





 




  
1
  




 





5



 sub clone    { &Acme::Tools::bfclone    } 




6921




0





 





 




  
0
  




 





0



 sub sum      { &Acme::Tools::bfsum      } 




6922




 





 





 





 





 





 



 1; 




6923




 





 





 





 





 





 



   




6924




 





 





 





 





 





 



 # Ny versjon: 




6925




 





 





 





 





 





 



 # + c-s todo 




6926




 





 





 





 





 





 



 # + endre $VERSION 




6927




 





 





 





 





 





 



 # + endre Release history under HISTORY 




6928




 





 





 





 





 





 



 # + endre årstall under COPYRIGHT AND LICENSE 




6929




 





 





 





 





 





 



 # + oppd default valutakurser inkl datoen 




6930




 





 





 





 





 





 



 # + emacs Changes 




6931




 





 





 





 





 





 



 # + emacs README + aarstall 




6932




 





 





 





 





 





 



 # + emacs MANIFEST legg til ev nye t/*.t 




6933




 





 





 





 





 





 



 # + perl            Makefile.PL;make test 




6934




 





 





 





 





 





 



 # + /usr/bin/perl   Makefile.PL;make test 




6935




 





 





 





 





 





 



 # + perlbrew exec "perl ~/Acme-Tools/Makefile.PL ; time make test" 




6936




 





 





 





 





 





 



 # + perlbrew use perl-5.10.1; perl Makefile.PL; make test; perlbrew off 




6937




 





 





 





 





 





 



 # + test evt i cygwin og mingw-perl 




6938




 





 





 





 





 





 



 # + pod2html Tools.pm > Tools.html ; firefox Tools.html  




6939




 





 





 





 





 





 



 # + https://metacpan.org/pod/Acme::Tools 




6940




 





 





 





 





 





 



 # + http://cpants.cpanauthors.org/dist/Acme-Tools  #kvalitee 




6941




 





 





 





 





 





 



 # + perl Makefile.PL ; make test && make dist 




6942




 





 





 





 





 





 



 # + cp -p *tar.gz /htdocs/ 




6943




 





 





 





 





 





 



 # + ci -l -mversjon -d `cat MANIFEST` 




6944




 





 





 





 





 





 



 # + git add `cat MANIFEST` 




6945




 





 





 





 





 





 



 # + git status 




6946




 





 





 





 





 





 



 # + git commit -am versjon 




6947




 





 





 





 





 





 



 # + git push                    #eller: 




6948




 





 





 





 





 





 



 # + git push origin master 




6949




 





 





 





 





 





 



 # + http://pause.perl.org/ 




6950




 





 





 





 





 





 



 # http://en.wikipedia.org/wiki/Birthday_problem#Approximations 




6951




 





 





 





 





 





 



   




6952




 





 





 





 





 





 



 # memoize_expire()           http://perldoc.perl.org/Memoize/Expire.html 




6953




 





 





 





 





 





 



 # memoize_file_expire() 




6954




 





 





 





 





 





 



 # memoize_limit_size() #lru 




6955




 





 





 





 





 





 



 # memoize_file_limit_size() 




6956




 





 





 





 





 





 



 # memoize_memcached         http://search.cpan.org/~dtrischuk/Memoize-Memcached-0.03/lib/Memoize/Memcached.pm 




6957




 





 





 





 





 





 



 # hint on http://perl.jonallen.info/writing/articles/install-perl-modules-without-root 




6958




 





 





 





 





 





 



   




6959




 





 





 





 





 





 



 # sub mycrc32 {  #http://billauer.co.il/blog/2011/05/perl-crc32-crc-xs-module/  eller String::CRC32::crc32 som er 100 x raskere enn Digest::CRC::crc32 




6960




 





 





 





 





 





 



 #  my ($input, $init_value, $polynomial) = @_; 




6961




 





 





 





 





 





 



 #  $init_value = 0 unless (defined $init_value); 




6962




 





 





 





 





 





 



 #  $polynomial = 0xedb88320 unless (defined $polynomial); 




6963




 





 





 





 





 





 



 #  my @lookup_table; 




6964




 





 





 





 





 





 



 #  for (my $i=0; $i<256; $i++) { 




6965




 





 





 





 





 





 



 #    my $x = $i; 




6966




 





 





 





 





 





 



 #    for (my $j=0; $j<8; $j++) { 




6967




 





 





 





 





 





 



 #      if ($x & 1) { 




6968




 





 





 





 





 





 



 #        $x = ($x >> 1) ^ $polynomial; 




6969




 





 





 





 





 





 



 #      } else { 




6970




 





 





 





 





 





 



 #        $x = $x >> 1; 




6971




 





 





 





 





 





 



 #      } 




6972




 





 





 





 





 





 



 #    } 




6973




 





 





 





 





 





 



 #    push @lookup_table, $x; 




6974




 





 





 





 





 





 



 #  } 




6975




 





 





 





 





 





 



 #  my $crc = $init_value ^ 0xffffffff; 




6976




 





 





 





 





 





 



 #  foreach my $x (unpack ('C*', $input)) { 




6977




 





 





 





 





 





 



 #    $crc = (($crc >> 8) & 0xffffff) ^ $lookup_table[ ($crc ^ $x) & 0xff ]; 




6978




 





 





 





 





 





 



 #  } 




6979




 





 





 





 





 





 



 #  $crc = $crc ^ 0xffffffff; 




6980




 





 





 





 





 





 



 #  return $crc; 




6981




 





 





 





 





 





 



 # } 




6982




 





 





 





 





 





 



 # 




6983




 





 





 





 





 





 



   




6984




 





 





 





 





 





 



   




6985




 





 





 





 





 





 



   




6986




 





 





 





 





 





 



 =head1 HISTORY 




6987




 





 





 





 





 





 



   




6988




 





 





 





 





 





 



 Release history 




6989




 





 





 





 





 





 



   




6990




 





 





 





 





 





 



  0.172 Dec 2015   Subs: curb, openstr, pwgen, sleepms, sleepnm, srlz, tms, username, 




6991




 





 





 





 





 





 



                   self_update, install_acme_command_tools 




6992




 





 





 





 





 





 



                   Commands: conv, due, freq, wipe, xcat (see "Commands") 




6993




 





 





 





 





 





 



  0.16  Feb 2015   bigr, curb, cpad, isnum, parta, parth, read_conf, resolve_equation, 




6994




 





 





 





 





 





 



                   roman2int, trim. Improved: conv (numbers, currency), range ("derivatives") 




6995




 





 





 





 





 





 



  0.15  Nov 2014   Improved doc 




6996




 





 





 





 





 





 



  0.14  Nov 2014   New subs, improved tests and doc 




6997




 





 





 





 





 





 



  0.13  Oct 2010   Non-linux test issue, resolve. improved: bloom filter, tests, doc 




6998




 





 





 





 





 





 



  0.12  Oct 2010   Improved tests, doc, bloom filter, random_gauss, bytes_readable 




6999




 





 





 





 





 





 



  0.11  Dec 2008   Improved doc 




7000




 





 





 





 





 





 



  0.10  Dec 2008 




7001




 





 





 





 





 





 



   




7002




 





 





 





 





 





 



 =head1 SEE ALSO 




7003




 





 





 





 





 





 



   




7004




 





 





 





 





 





 



 L 




7005




 





 





 





 





 





 



   




7006




 





 





 





 





 





 



 =head1 AUTHOR 




7007




 





 





 





 





 





 



   




7008




 





 





 





 





 





 



 Kjetil Skotheim, [e-mail] 




7009




 





 





 





 





 





 



   




7010




 





 





 





 





 





 



 =head1 COPYRIGHT 




7011




 





 





 





 





 





 



   




7012




 





 





 





 





 





 



 1995-2015, Kjetil Skotheim 




7013




 





 





 





 





 





 



   




7014




 





 





 





 





 





 



 =head1 LICENSE 




7015




 





 





 





 





 





 



   




7016




 





 





 





 





 





 



 This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 




7017




 





 





 





 





 





 



   




7018




 





 





 





 





 





 



 =cut
argument is a way of telling C which to capture: the one with this word
or string occurring before it.

Output: An array of arrayrefs.

C is a quick and dirty way of scraping (or harvesting as it is
also called) data from a web page. Look too L to do this
more accurate.

Example:

 use Acme::Tools;
 use LWP::Simple;
 my $url = "http://en.wikipedia.org/wiki/List_of_countries_by_population";
 for( ht2t( get($url), "Countries" ) ) {
   my($rank, $country, $pop) = @$_;
   $pop =~ s/,//g;
   printf "%3d | %-32s | %9d\n", @$_ if $pop>0;
 }

Output:

  1 | China                            | 1367740000
  2 | India                            | 1262090000
  3 | United States                    | 319043000
  4 | Indonesia                        | 252164800
  5 | Brazil                           | 203404000

...and so on.

=cut

sub ht2t {
  my($f,$s,$r)=@_; 1>@_||@_>3 and croak; $s='' if @_==1;
  $f=~s,.*?($s).*?(
  my $e=0;$e++ while index($f,$s=chr($e))>=$[;
  $f=~s//\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

=head2 writefile

Justification:

Perl needs three or four operations to make a file out of a string:

 open my $FILE, '>', $filename  or die $!;
 print $FILE $text;
 close($FILE);

This is way simpler:

 writefile($filename,$text);

Sub writefile opens the file i binary mode (C) and has two usage modes:

B Two arguments

B is the filename. If the file exists, its overwritten.
If the file can not be opened for writing, a die (a croak really) happens.

B is one of:

=over 4

=item * Either a scaler. That is a normal string to be written to the file.

=item * Or a reference to a scalar. That referred text is written to the file.

=item * Or a reference to an array of scalars. This array is the written to the
 file element by element and C<< \n >> is automatically appended to each element.

=back

Alternativelly, you can write several files at once.

Example, this:

 writefile('file1.txt','The text....tjo');
 writefile('file2.txt','The text....hip');
 writefile('file3.txt','The text....and hop');

...is the same as this:

 writefile([
   ['file1.txt','The text....tjo'],
   ['file2.txt','The text....hip'],
   ['file3.txt','The text....and hop'],
 ]);

B Nothing (for the time being). Cs (C really) if something goes wrong.

=cut

#todo: use openstr() as in readfile(), transparently gzip .gz filenames and so on
sub writefile {
    my($filename,$text)=@_;
    if(ref($filename) eq 'ARRAY'){
	writefile(@$_) for @$filename;
	return;
    }
    open(WRITEFILE,">",$filename) and binmode(WRITEFILE) or croak($!);
    if(!defined $text or !ref($text)){
	print WRITEFILE $text;
    }
    elsif(ref($text) eq 'SCALAR'){
	print WRITEFILE $$text;
    }
    elsif(ref($text) eq 'ARRAY'){
	print WRITEFILE "$_\n" for @$text;
    }
    else {
	croak;
    }
    close(WRITEFILE);
    return;
}

=head2 readfile

Just as with L you can read in a whole file in one operation with C. Instead of:

 open my $FILE,'<', $filename or die $!;
 my $data = join"",<$FILE>;
 close($FILE);

This is simpler:

 my $data = readfile($filename);

B

Reading the content of the file to a scalar variable: (Any content in C<$data> will be overwritten)

 my $data;
 readfile('filename.txt',\$data);

Reading the lines of a file into an array:

 my @lines;
 readfile('filnavn.txt',\@lines);
 for(@lines){
   ...
 }

Note: Chomp is done on each line. That is, any newlines (C<< \n >>) will be removed.
If C<@lines> is non-empty, this will be lost.

Sub readfile is context aware. If an array is expected it returns an array of the lines without a trailing C<< \n >>.
The last example can be rewritten:

 for(readfile('filnavn.txt')){
   ...
 }

With two input arguments, nothing (undef) is returned from C.

=cut

#http://blogs.perl.org/users/leon_timmermans/2013/05/why-you-dont-need-fileslurp.html
#todo: readfile with grep-filter code ref in a third arg (avoid reading all into mem)

sub readfile {
  my($filename,$ref)=@_;
  if(@_==1){
    if(wantarray){ my @data; readfile($filename,\@data); return @data }
    else         { my $data; readfile($filename,\$data); return $data }
  }
  else {
    open my $fh,openstr($filename) or croak("ERROR: readfile $! $?");
    if   ( ref($ref) eq 'SCALAR') { $$ref=join"",<$fh> }
    elsif( ref($ref) eq 'ARRAY' ) { while(my $l=<$fh>){ chomp($l); push @$ref, $l } }
    else { croak "ERROR: Second arg to readfile should be a ref to a scalar og array" }
    close($fh);
    return;#?
  }
}

=head2 readdirectory

B

Name of a directory.

B

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 except C<.> and C<..>

C do not recurce down into subdirectories (but see example below).

B

  my @files = readdirectory("/tmp");

B

Sometimes calling the built ins C, C and C 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");

See also: L

B

On huge directories with perhaps tens or houndreds of thousands of
files, readdirectory() will consume more memory than perls
opendir/readdir. This isn't usually a concern anymore for modern
computers with gigabytes of RAM, but might be the rationale behind
Perls more tedious way created in the 80s.  The same argument goes for
file slurping. On the other side it's also a good practice to never
assume to much on available memory and the number of files if you
don't know for certain that enough memory is available whereever your
code is run or that the size of the directory is limited.

B

How to get all files in the C 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

The basename and dirname functions behaves like the *nix shell commands with the same names.

B One or two arguments: Filename and an optional suffix

B Returns the filename with any directory and (if given) the suffix removed.

 basename('/usr/bin/perl')                   # returns 'perl'
 basename('/usr/local/bin/report.pl','.pl')  # returns 'report' since .pl at the end is removed
 basename('report2.pl','.pl')                # returns 'report2'
 basename('report2.pl','.\w+')               # returns 'report2.pl', probably not what you meant
 basename('report2.pl',qr/.\w+/)             # returns 'report2', use qr for regex

=head2 dirname

B A filename including path

B Removes the filename path and returns just the directory path up until but not including
the last /. Return just a one char C<< . >> (period string) if there is no directory in the input.

 dirname('/usr/bin/perl')                    # returns '/usr/bin'
 dirname('perl')                             # returns '.'

=head2 username

Returns the current linux/unix username, for example the string root

 print username();                        #just (getpwuid($<))[0] but more readable perhaps

=cut

sub basename { my($f,$s)=(@_,'');$s=quotemeta($s)if!ref($s);$f=~m,^(.*/)?([^/]*?)($s)?$,;$2 }
sub dirname  { $_[0]=~m,^(.*)/,;defined($1) && length($1) ? $1 : '.' }
sub username { (getpwuid($<))[0] }

=head2 wipe

Deletes a file by "wiping" it on the disk. Overwrites the file before deleting. (May not work properly on SSDs)

B
* Arg 1: A filename
* Optional arg 2: number of times to overwrite file. Default is 3 if omitted, 0 or undef
* Optional arg 3: keep (true/false), wipe() but no delete of file

B Same as the C (remove file): 1 for success, 0 or false for failure.

See also: L, L

=cut

sub wipe {
  my($file,$times,$keep)=@_;
  $times||=3;
  croak "ERROR: File $file nonexisting\n" if not -f $file or not -e $file;
  my $size=-s$file;
  open my $WIFH, '+<', $file or croak "ERROR: Unable to open $file: $!\n";
  binmode($WIFH);
  for(1..$times){
    my $block=chr(int(rand(256))) x 1024;#hm
    for(0..($size/1024)){
      seek($WIFH,$_*1024,0);
      print $WIFH $block;
    }
  }
  close($WIFH);
  $keep || unlink($file);
}

=head2 chall

Does chmod + utime + chown on one or more files.

Returns the number of files of which those operations was successful.

Mode, uid, gid, atime and mtime are set from the array ref in the first argument.

The first argument references an array which is exactly like an array returned from perls internal C -function.

Example:

 my @stat=stat($filenameA);
 chall( \@stat,       $filenameB, $filenameC, ... );  # by stat-array
 chall( $filenameA,   $filenameB, $filenameC, ... );  # by file name

Copies the chmod, owner, group, access time and modify time from file A to file B and C.

See C, C, C, C

=cut


sub chall {
  my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks )
    = ref($_[0]) ? @{shift()} : stat(shift());
  my $successful=0;
  for(@_){ chmod($mode,$_) && utime($atime,$mtime,$_) && chown($uid,$gid,$_) && $successful++ }
  return $successful;
}

=head2 makedir

Input: One or two arguments.

Works like perls C except that C will create nesessary parent directories if they dont exists.

First input argument: A directory name (absolute, starting with C< / > or relative).

Second input argument: (optional) permission bits. Using the normal C<< 0777^umask() >> as the default if no second input argument is provided.

Example:

 makedir("dirB/dirC")

...will create directory C if it does not already exists, to be able to create C inside C.

Returns true on success, otherwise false.

C memoizes directories it has checked for existence before (trading memory and for speed).
Thus directories removed during running the script is not discovered by makedir.

See also C<< perldoc -f mkdir >>, C<< man umask >>

=cut

our %MAKEDIR;

sub makedir {
  my($d,$p,$dd)=@_;
  $p=0777^umask() if !defined$p;
  (
  $MAKEDIR{$d} or -d$d or mkdir($d,$p) #or croak("mkdir $d, $p")
  or ($dd)=($d=~m,^(.+)/+([^/]+)$,) and makedir($dd,$p) and mkdir($d,$p) #or die;
  ) and ++$MAKEDIR{$d};
}

=head2 md5sum

B a filename.

B a string of 32 hexadecimal chars from 0-9 or a-f.

Example, the md5sum gnu/linux command without options could be implementet like this:

 use Acme::Tools;
 print eval{ md5sum($_)."  $_\n" } || $@ for @ARGV;

This sub requires L, which is a core perl-module since
version 5.?.?  It does not slurp the files or spawn new processes.

=cut

sub md5sum {
  require Digest::MD5;
  my $fn=shift;
  croak "md5sum: $fn is a directory (no md5sum)" if -d $fn;
  open my $FH, '<', $fn or croak "Could not open file $fn for md5sum() $!";
  binmode($FH);
  my $r = eval { Digest::MD5->new->addfile($FH)->hexdigest };
  croak "md5sum on $fn failed ($@)\n" if $@;
  $r;
}

=head2 read_conf

B A file name or a reference to a string with settings in the format described below.

B A reference to a hash. This hash will have the settings from the file (or stringref).
The hash do not have to be empty beforehand.

Returns a hash with the settings as in this examples:

 my %conf = read_conf('/etc/your/thing.conf');
 print $conf{sectionA}{knobble};  #prints ABC if the file is as shown below
 print $conf{sectionA}{gobble};   #prints ZZZ, the last gobble
 print $conf{switch};             #prints OK here as well, unsectioned value
 print $conf{part2}{password};    #prints oh:no= x

File use for the above example:

 switch:    OK       #before first section, the '' (empty) section
 [sectionA]
 knobble:   ABC
 gobble:    XYZ      #this gobble is overwritten by the gobble on the next line
 gobble:    ZZZ
 [part2]
 password:  oh:no= x  #should be better
 text:      { values starting with { continues
              until reaching a line with }

Everything from # and behind is regarded comments and ignored. Comments can be on any line.
To keep a # char, put a \ in front of it.

A C< : > or C< = > separates keys and values.  Spaces at the beginning or end of lines are
ignored (after removal of #comments), as are any spaces before and after : and = separators.

Empty lines or lines with no C< : > or C< = > is also ignored. Keys and values can contain
internal spaces and tabs, but not at the beginning or end.

Multi-line values must start and end with { and }. Using { and } keep spaces at the start
or end in both one-line and multi-line values.

Sections are marked with C<< [sectionname] >>.  Section names, keys and values is case
sensitive. C above the first section or below and empty C<< [] >> is placed
both in the empty section in the returned hash and as top level key/values.

C can be a simpler alternative to the core module L which has
its own hassles.

 $Acme::Tools::Read_conf_empty_section=1;        #default 0 (was 1 in version 0.16)
 my %conf = read_conf('/etc/your/thing.conf');
 print $conf{''}{switch};                        #prints OK with the file above
 print $conf{switch};                            #prints OK here as well

=cut

our $Read_conf_empty_section=0;
sub read_conf {
  my($fn,$hr)=(@_,{});
  my $conf=ref($fn)?$$fn:readfile($fn);
  $conf=~s,\s*(?
  my($section,@l)=('',split"\n",$conf);
  while(@l) {
    my $l=shift@l;
    if( $l=~/^\s*\[\s*(.*?)\s*\]/ ) {
      $section=$1;
      $$hr{$1}||={};
    }
    elsif( $l=~/^\s*([^\:\=]+)[:=]\s*(.*?)\s*$/ ) {
      my $ml=sub{my$v=shift;$v.="\n".shift@l while $v=~/^\{[^\}]*$/&&@l;$v=~s/^\{(.*)\}\s*$/$1/s;$v=~s,\\#,#,g;$v};
      my $v=&$ml($2);
      $$hr{$section}{$1}=$v if length($section) or $Read_conf_empty_section;
      $$hr{$1}=$v if !length($section);
    }
  }
  %$hr;
}
#  my $incfn=sub{return $1 if $_[0]=~m,^(/.+),;my$f=$fn;$f=~s,[^/]+$,$_[0],;$f};
#    s,]+)>,"".readfile(&$incfn($1)),eg; #todo


=head2 openstr

                                            # returned from openstr:
  open my $FH, openstr("fil.txt")  or die;  # fil.txt
  open my $FH, openstr("fil.gz")   or die;  # zcat fil.gz |
  open my $FH, openstr("fil.bz2")  or die;  # bzcat fil.bz2 |
  open my $FH, openstr("fil.xz")   or die;  # xzcat fil.xz |
  open my $FH, openstr(">fil.txt") or die;  # > fil.txt
  open my $FH, openstr(">fil.gz")  or die;  # | gzip > fil.gz
  open my $FH, openstr(">fil.bz2") or die;  # | bzip2 > fil.bz2
  open my $FH, openstr(">fil.xz")  or die;  # | xz    > fil.bz2

Environment variable PATH is used. So in the examples above, /bin/gzip
is returned instead of gzip if /bin is the first directory in
$ENV{PATH} containing an executable file gzip. Dirs /usr/bin, /bin and
/usr/local/bin is added to PATH in openstr(). They are checked even if
PATH is empty.

=cut

our @Openstrpath=(grep$_,split(":",$ENV{PATH}),qw(/usr/bin /bin /usr/local/bin));
sub openstr {
  my($fn,$ext)=(shift()=~/^(.*?(?:\.(t?gz|bz2|xz))?)$/i);
  return $fn if !$ext;
  my $prog=sub{@Openstrpath or return $_[0];(grep -x$_, map "$_/$_[0]", @Openstrpath)[0] or die};
  $fn =~ /^\s*>/
      ?  "| ".(&$prog({qw/tgz gzip gz gzip bz2 bzip2 xz xz/   }->{lc($ext)})).$fn
      :        &$prog({qw/tgz zcat gz zcat bz2 bzcat xz xzcat/}->{lc($ext)})." $fn |";
}

=head1 TIME FUNCTIONS

=head2 tms - timestring, works somewhat like the Gnu/Linux C command and Oracle's C

Converts timestamps to more readable forms of time strings.

Converts seconds since I and time strings on the form C to other forms.

B One, two or three arguments.

B A format string.

B An epock C number or a time
string of the form YYYYMMDD-HH24:MI:SS or YYYYMMDDTHH:MI:SS or
YYYY-MM-DDTHH:MI:SS (in which T is litteral and HH is the 24-hour
version of hours) or YYYYMMDD. Uses the current C if the
second argument is missing.

TODO: Formats with % as in C (C<%Y%m%d> and so on)

B True or false. If true and first argument
is eight digits: Its interpreted as a date like YYYYMMDD time string,
not an epoch time.  If true and first argument is six digits its
interpreted as a date like DDMMYY (not YYMMDD!).

B a date or clock string on the wanted form.

B

Prints C<< 3. july 1997 >> if thats the dato today:

  perl -MAcme::Tools -le 'print timestr("D. month YYYY")'

  print tms("HH24:MI");              # prints 23:55 if thats the time now
  tms("HH24:MI",time());             # ...same,since time() is the default
  tms("HH:MI",time()-5*60);          # 23:50 if that was the time 5 minutes ago
  tms("HH:MI",time()-5*60*60);       # 18:55 if thats the time 5 hours ago
  tms("Day Month Dth YYYY HH:MI");   # Saturday July 1st 2004 23:55    (big S, big J)
  tms("Day D. Month YYYY HH:MI");    # Saturday 8. July 2004 23:55     (big S, big J)
  tms("DAY D. MONTH YYYY HH:MI");    # SATURDAY 8. JULY 2004 23:55     (upper)
  tms("dy D. month YYYY HH:MI");     # sat 8. july 2004 23:55          (small s, small j)
  tms("Dy DD. MON YYYY HH12:MI am"); # Sat 08. JUL 2004 11:55 pm       (HH12, am becomes pm if after 12)
  tms("DD-MON-YYYY");                # 03-MAY-2004                     (mon, english)

The following list of codes in the first argument will be replaced:

  YYYY    Year, four digits
  YY      Year, two digits, i.e. 04 instead of 2004
  yyyy    Year, four digits, but nothing if its the current year
  YYYY|HH:MI  Year if its another year than the current, a time in hours and minutes elsewise
  MM      Month, two digits. I.e. 08 for August
  DD      Day of month, two digits. I.e. 01 (not 1) for the first day in a month
  D       Day of month, one digit. I.e. 1 (not 01)
  HH      Hour. From 00 to 23.
  HH24    Same as HH.
  HH12    12 becomes 12 (never 00), 13 becomes 01, 14 02 and so on.
          Note: 00 after midnight becomes 12 (am). Tip: always include the code
          am in a format string that uses HH12.
  MI      Minutt. Fra 00 til 59.
  SS      Sekund. Fra 00 til 59.
  am      Becomes am or pm
  pm      Same
  AM      Becomes AM or PM (upper case)
  PM      Same

  Month   The full name of the month in English from January to December
  MONTH   Same in upper case (JANUARY)
  month   Same in lower case (january)
  Mont    Jan Feb Mars Apr May June July Aug Sep Oct Nov Dec
  Mont.   Jan. Feb. Mars Apr. May June July Aug. Sep. Oct. Nov. Dec. (always four chars)
  Mon     Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec            (always three chars)

  Day     The full name of the weekday. Sunday to Saturday
  Dy      Three letters: Sun Mon Tue Wed Thu Fri Sat
  DAY     Upper case
  DY      Upper case
  Dth     1st 2nd 3rd 4th 5th ... 11th 12th ... 20th 21st 22nd 23rd 24th ... 30th 31st

  WW      Week number of the year 01-53 according to the ISO8601-definition (which most countries uses)
  WWUS    Week number of the year 01-53 according to the most used definition in the USA.
          Other definitions also exists.

  epoch   Converts a time string from YYYYMMDD-HH24:MI:SS, YYYYMMDD-HH24:MI:SS, YYYYMMDDTHH:MI:SS,
          YYYY-MM-DDTHH:MI:SS or YYYYMMDD to the number of seconds since January 1st 1970.
          Commonly known as the Unix epoch.

  JDN     Julian day number. Integer. The number of days since the day starting at noon on January 1 4713 BC
  JD      Same as JDN but a float accounting for the time of day

TODO:  sub smt() (tms backward... or something better named, converts the other way)
       As to_date and to_char in Oracle. Se maybe L instead

B (optional) Is_date. False|true, default false. If true, the second argument is
interpreted as a date of the form YYYYMMDD, not as a number of seconds since epoch (January 1st 1970).

=cut

#Se også L og L

our $Tms_pattern;
our %Tms_str=
	  ('MÅNED' => [4, 'JANUAR','FEBRUAR','MARS','APRIL','MAI','JUNI','JULI',
		          'AUGUST','SEPTEMBER','OKTOBER','NOVEMBER','DESEMBER' ],
	   'Måned' => [4, 'Januar','Februar','Mars','April','Mai','Juni','Juli',
		          'August','September','Oktober','November','Desember'],
	   'måned' => [4, 'januar','februar','mars','april','mai','juni','juli',
		          'august','september','oktober','november','desember'],
	   'MÅNE.' => [4, 'JAN.','FEB.','MARS','APR.','MAI','JUNI','JULI','AUG.','SEP.','OKT.','NOV.','DES.'],
	   'Måne.' => [4, 'Jan.','Feb.','Mars','Apr.','Mai','Juni','Juli','Aug.','Sep.','Okt.','Nov.','Des.'],
	   'måne.' => [4, 'jan.','feb.','mars','apr.','mai','juni','juli','aug.','sep.','okt.','nov.','des.'],
	   'MÅNE'  => [4, 'JAN','FEB','MARS','APR','MAI','JUNI','JULI','AUG','SEP','OKT','NOV','DES'],
	   'Måne'  => [4, 'Jan','Feb','Mars','Apr','Mai','Juni','Juli','Aug','Sep','Okt','Nov','Des'],
	   'måne'  => [4, 'jan','feb','mars','apr','mai','juni','juli','aug','sep','okt','nov','des'],
	   'MÅN'   => [4, 'JAN','FEB','MAR','APR','MAI','JUN','JUL','AUG','SEP','OKT','NOV','DES'],
	   'Mån'   => [4, 'Jan','Feb','Mar','Apr','Mai','Jun','Jul','Aug','Sep','Okt','Nov','Des'],
	   'mån'   => [4, 'jan','feb','mar','apr','mai','jun','jul','aug','sep','okt','nov','des'],
	   'MONTH' => [4, 'JANUARY','FEBRUARY','MARCH','APRIL','MAY','JUNE','JULY',
		          'AUGUST','SEPTEMBER','OCTOBER','NOVEMBER','DECEMBER'],
	   'Month' => [4, 'January','February','March','April','May','June','July',
		          'August','September','October','November','December'],
	   'month' => [4, 'january','february','march','april','may','june','july',
		          'august','september','october','november','december'],
	   'MONT.' => [4, 'JAN.','FEB.','MAR.','APR.','MAY','JUNE','JULY','AUG.','SEP.','OCT.','NOV.','DEC.'],
	   'Mont.' => [4, 'Jan.','Feb.','Mar.','Apr.','May','June','July','Aug.','Sep.','Oct.','Nov.','Dec.'],
	   'mont.' => [4, 'jan.','feb.','mar.','apr.','may','june','july','aug.','sep.','oct.','nov.','dec.'],
	   'MONT'  => [4, 'JAN','FEB','MAR','APR','MAY','JUNE','JULY','AUG','SEP','OCT','NOV','DEC'],
	   'Mont'  => [4, 'Jan','Feb','Mar','Apr','May','June','July','Aug','Sep','Oct','Nov','Dec'],
	   'mont'  => [4, 'jan','feb','mar','apr','may','june','july','aug','sep','oct','nov','dec'],
	   'MON'   => [4, 'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'],
	   'Mon'   => [4, 'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'],
	   'mon'   => [4, 'jan','feb','mar','apr','may','jun','jul','aug','sep','oct','nov','dec'],
	   'DAY'   => [6, 'SUNDAY','MONDAY','TUESDAY','WEDNESDAY','THURSDAY','FRIDAY','SATURDAY'],
	   'Day'   => [6, 'Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday'],
	   'day'   => [6, 'sunday','monday','tuesday','wednesday','thursday','friday','saturday'],
	   'DY'    => [6, 'SUN','MON','TUE','WED','THU','FRI','SAT'],
	   'Dy'    => [6, 'Sun','Mon','Tue','Wed','Thu','Fri','Sat'],
	   'dy'    => [6, 'sun','mon','tue','wed','thu','fri','sat'],
	   'DAG'   => [6, 'SØNDAG','MANDAG','TIRSDAG','ONSDAG','TORSDAG','FREDAG','LØRDAG'],
	   'Dag'   => [6, 'Søndag','Mandag','Tirsdag','Onsdag','Torsdag','Fredag','Lørdag'],
	   'dag'   => [6, 'søndag','mandag','tirsdag','onsdag','torsdag','fredag','lørdag'],
	   'DG'    => [6, 'SØN','MAN','TIR','ONS','TOR','FRE','LØR'],
	   'Dg'    => [6, 'Søn','Man','Tir','Ons','Tor','Fre','Lør'],
	   'dg'    => [6, 'søn','man','tir','ons','tor','fre','lør'],
	   );
my $_tms_inited=0;
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);
  #uten sort kan "måned" bli "mared", fordi "mån"=>"mar"
}

sub totime {

}

sub date_ok {
  my($y,$m,$d)=@_;
  return date_ok($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/;
  return 0 if $y!~/^\d\d\d\d$/;
  return 0 if $m<1||$m>12||$d<1||$d>(31,$y%4||$y%100==0&&$y%400?28:29,31,30,31,30,31,31,30,31,30,31)[$m-1];
  return 1;
}

sub weeknum {
  return weeknum(tms('YYYYMMDD')) if @_<1;
  return weeknum($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/;
  my($year,$month,$day)= @_;
  eval{
    if(@_<2){
      if($year=~/^\d{8}$/) { ($year,$month,$day)=unpack("A4A2A2",$year) }
      elsif($year>99999999){ ($year,$month,$day)=(localtime($year))[5,4,3]; $year+=1900; $month++ }
      else {die}
    }
    elsif(@_!=3){croak}
    croak if !date_ok(sprintf("%04d%02d%02d",$year,$month,$day));
  };
  croak "ERROR: Wrong args Acme::Tools::weeknum(".join(",",@_).")" if $@;
  use integer;#heltallsdivisjon
  my $y=$year+4800-(14-$month)/12;
  my $j=$day+(153*($month+(14-$month)/12*12-3)+2)/5+365*$y+$y/4-$y/100+$y/400-32045;
  my $d=($j+31741-$j%7)%146097%36524%1461;
  return (($d-$d/1460)%365+$d/1460)/7+1;
}

sub tms {
  return undef if @_>1 and not defined $_[1]; #time=undef => undef
  if(@_==1){
    my @lt=localtime();
    $_[0] eq 'YYYY'     and return 1900+$lt[5];
    $_[0] eq 'YYYYMMDD' and return sprintf("%04d%02d%02d",1900+$lt[5],1+$lt[4],$lt[3]);
    $_[0] =~ $Re_isnum  and @lt=localtime($_[0]) and return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]);
  }
  my($format,$time,$is_date)=@_;
  $time=time_fp() if !defined$time;
  ($time,$format)=($format,$time) if @_>=2 and $format=~/^[\d+\:\-\.]+$/; #swap /hm/
  my @lt=localtime($time);
  #todo? $is_date=0 if $time=~s/^\@(\-?\d)/$1/; #@n where n is sec since epoch makes it clear that its not a formatted, as in `date`
  #todo? date --date='TZ="America/Los_Angeles" 09:00 next Fri' #`info date`
  #      Fri Nov 13 18:00:00 CET 2015
  #date --date="next Friday"  #--date or -d
  #date --date="last friday"
  #date --date="2 days ago"
  #date --date="yesterday" #or tomorrow
  #date --date="-1 day"  #date --date='10 week'

  if( $is_date ){
    my $yy2c=sub{10+$_[0]>$lt[5]%100?"20":"19"}; #hm 10+
    $time=totime(&$yy2c($1)."$1$2$3")."000000" if $time=~/^(\d\d)(\d\d)(\d\d)$/;
    $time=totime("$1$2${3}000000")             if $time=~/^((?:18|19|20)\d\d)(\d\d)(\d\d)$/; #hm 18-20?
  }
  else {
    $time = yyyymmddhh24miss_time("$1$2$3$4$5$6") #yyyymmddhh24miss_time ???
      if $time=~/^((?:19|20|18)\d\d)          #yyyy
                  (0[1-9]|1[012])             #mm
                  (0[1-9]|[12]\d|3[01]) \-?   #dd
                  ([01]\d|2[0-3])       \:?   #hh24
                  ([0-5]\d)             \:?   #mi
                  ([0-5]\d)             $/x;  #ss
  }
  tms_init() if !$_tms_inited;
  return sprintf("%04d%02d%02d-%02d:%02d:%02d",1900+$lt[5],1+$lt[4],@lt[3,2,1,0]) if !$format;
  my %p=('%'=>'%',
	 a=>'Dy',
	 A=>'Day',
	 b=>'Mon',
	 b=>'Month',
	 c=>'Dy Mon D HH:MI:SS YYYY',
	 C=>'CC',
	 d=>'DD',
	 D=>'MM/DD/YY',
	 e=>'D',
	 F=>'YYYY-MM-DD',
        #G=>'',
	 h=>'Month', H=>'HH24', I=>'HH12',
	 j=>'DoY', #day of year
	 k=>'H24', _H=>'H24',
	 l=>'H12', _I=>'H12',
	 m=>'MM', M=>'MI',
	 n=>"\n",
	#N=>'NS', #sprintf%09d,1e9*(time_fp()-time()) #000000000..999999999
	 p=>'AM', #AM|PM upper (yes, opposite: date +%H%M%S%P%p)
	 P=>'am', #am|pm lower
	 S=>'SS',
	 t=>"\t",
	 T=>'HH24:MI:SS',
	 u=>'DoW',  #day of week 1..7, 1=mon 7=sun
	 w=>'DoW0', #day of week 0..6, 1=mon 0=sun
	#U=>'WoYs', #week num of year 00..53, sunday as first day of week
	#V=>'UKE',  #ISO week num of year 01..53, monday as first day of week
	#W=>'WoYm', #week num of year 00..53, monday as first day of week, not ISO!
	#x=>$ENV{locale's date representation}, #e.g. MM/DD/YY
	#X=>$ENV{locale's time representation}, #e.g. HH/MI/SS
	 y=>'YY',
	 Y=>'YYYY',
	#z=>'TZHHMI', #time zone hour minute e.g. -0430
	#':z'=>'TZHH:MI',
	#'::z'=>'TZHH:MI:SS',
	#':::z'=>'TZ', #number of :'s necessary precision, e.g. -02 or +03:30
	#Z=>'TZN', #e.g. CET, EDT, ...
      );
  my $pkeys=join"|",keys%p;
  $format=~s,\%($pkeys),$p{$1},g;
  $format=~s/($Tms_pattern)/$Tms_str{$1}[1+$lt[$Tms_str{$1}[0]]]/g;
  $format=~s/YYYY              / 1900+$lt[5]                    /gxe;
  $format=~s/(\s?)yyyy         / $lt[5]==(localtime)[5]?"":$1.(1900+$lt[5])/gxe;
  $format=~s/YY                / sprintf("%02d",$lt[5]%100)     /gxei;
  $format=~s|CC                | sprintf("%02d",(1900+$lt[5])/100) |gxei;
  $format=~s/MM                / sprintf("%02d",$lt[4]+1)       /gxe;
  $format=~s/mm                / sprintf("%d",$lt[4]+1)         /gxe;
  $format=~s,M/                ,               ($lt[4]+1).'/'   ,gxe;
  $format=~s,/M                ,           '/'.($lt[4]+1)       ,gxe;
  $format=~s/DD                / sprintf("%02d",$lt[3])         /gxe;
  $format=~s/d0w|dow0          / $lt[6]                         /gxei;
  $format=~s/dow               / $lt[6]?$lt[6]:7                /gxei;
  $format=~s/d0y|doy0          / $lt[7]                         /gxei; #0-364 (365 leap)
  $format=~s/doy               / $lt[7]+1                       /gxei; #1-365 (366 leap)
  $format=~s/D(?![AaGgYyEeNn]) / $lt[3]                         /gxe; #EN pga desember og wednesday
  $format=~s/dd                / sprintf("%d",$lt[3])           /gxe;
  $format=~s/hh12|HH12         / sprintf("%02d",$lt[2]<13?$lt[2]||12:$lt[2]-12)/gxe;
  $format=~s/HH24|HH24|HH|hh   / sprintf("%02d",$lt[2])         /gxe;
  $format=~s/MI                / sprintf("%02d",$lt[1])         /gxei;
  $format=~s{SS\.([1-9])      }{ sprintf("%0*.$1f",3+$1,$lt[0]+(repl($time,qr/^[^\.]+/)||0)) }gxei;
  $format=~s/SS                / sprintf("%02d",$lt[0])         /gxei;
  $format=~s/am|pm             / $lt[2]<13 ? 'am' : 'pm'        /gxe;
  $format=~s/AM|PM             / $lt[2]<13 ? 'AM' : 'PM'        /gxe;
  $format=~s/WWI|WW            / sprintf("%02d",weeknum($time)) /gxei;
  $format=~s/W                 / weeknum($time)                 /gxei;
  $format;
}

=head2 easter

Input: A year (a four digit number)

Output: array of two numbers: day and month of Easter Sunday that year. Month 3 means March and 4 means April.

 sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30;
             (($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) }

...is a "golfed" version of Oudins algorithm (1940) L
(see also http://www.smart.net/~mmontes/ec-cal.html )

Valid for any Gregorian year. Dates repeat themselves after 70499183
lunations = 2081882250 days = ca 5699845 years. However, our planet will
by then have a different rotation and spin time...

Example:

 ( $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

=cut

sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30;
             (($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) }


=head2 time_fp

No input arguments.

Return the same number as perls C except with decimals (fractions of a second, _fp as in floating point number).

 print time_fp(),"\n";
 print time(),"\n";

Could write:

 1116776232.38632

...if that is the time now.

Or just:

 1116776232

...from perl's internal C if C isn't installed and available.


=cut

sub time_fp {  # {return 0+gettimeofday} is just as well?
    eval{ require Time::HiRes } or return time();
    my($sec,$mic)=Time::HiRes::gettimeofday();
    return $sec+$mic/1e6; #1e6 not portable?
}

=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, 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.

=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);
 }

 ..DOC MISSING..

=head2 etahhmm

 ...NOT YET

=cut

#http://en.wikipedia.org/wiki/Kalman_filter god idé?
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;
}

=head2 leapyear

B A year. A four digit number.

B 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 function (or I function)

C takes two or more arguments. (Oracles nvl-function take just two)

Returns the value of the first input argument with length() > 0.

Return I 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 and C<< // >> treats empty strings C<"">
differently. Sub nvl here considers empty strings and undef the same.

=cut

sub nvl {
  return $_[0] if defined $_[0] and length($_[0]) or @_==1;
  return $_[1] if @_==2;
  return nvl(@_[1..$#_]) if @_>2;
  return undef;
}

=head2 decode_num

See L.

=head2 decode

C and C works just as Oracles C.

C and C accordingly uses perl operators C and C<==> for comparison.

Examples:

 my $a=123;
 print decode($a, 123,3,  214,4, $a);     # prints 3
 print decode($a, 123=>3, 214=>4, $a);    # prints 3, same thing since => is synonymous to comma in Perl

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
 print decode($a, 122=>3, 214=>7, $a);              # prints 123
 print decode($a,  123.0 =>3, 214=>7);              # prints 3
 print decode($a, '123.0'=>3, 214=>7);              # prints nothing (undef), no last argument default value here
 print decode_num($a, 121=>3, 221=>7, '123.0','b'); # prints b

Sort of:

 decode($string, %conversion, $default);

The last argument is returned as a default if none of the keys in the keys/value-pairs matched.

A more perl-ish and often faster way of doing the same:

 {123=>3, 214=>7}->{$a} || $a                       # (beware of 0)

=cut

sub decode {
  croak "Must have a mimimum of two arguments" if @_<2;
  my $uttrykk=shift;
  if(defined$uttrykk){ shift eq $uttrykk and return shift or shift for 1..@_/2 }
  else               { !defined shift    and return shift or shift for 1..@_/2 }
  return shift;
}

sub decode_num {
  croak "Must have a mimimum of two arguments" if @_<2;
  my $uttrykk=shift;
  if(defined$uttrykk){ shift == $uttrykk and return shift or shift for 1..@_/2 }
  else               { !defined shift    and return shift or shift for 1..@_/2 }
  return shift;
}

=head2 qrlist

Input: An array of values to be used to test againts for existence.

Output: A reference to a regular expression. That is a C

The regex sets $1 if it match.

Example:

  my @list=qw/ABc XY DEF DEFG XYZ/;
  my $filter=qrlist("ABC","DEF","XY.");         # makes a regex of it qr/^(\QABC\E|\QDEF\E|\QXY.\E)$/
  my @filtered= grep { $_ =~ $filter } @list;   # returns DEF and XYZ, but not XYZ because the . char is taken literally

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

Perhaps easier to use than L ?

B One argument. A string where the char C<¤> have special
meaning and is replaced by color codings depending on the letter
following the C<¤>.

B The same string, but with C<¤letter> replaced by ANSI color
codes respected by many types terminal windows. (xterm, telnet, ssh,
telnet, rlog, vt100, cygwin, rxvt and such...).

B

 ¤r red
 ¤g green
 ¤b blue
 ¤y yellow
 ¤m magenta
 ¤B bold
 ¤u underline
 ¤c clear
 ¤¤ reset, quits and returns to default text color.

B

 print ansicolor("This is maybe ¤ggreen¤¤?");

Prints I where the word I is shown in green.

If L is not installed or not found, returns the input
string with every C<¤> including the following code letters
removed. (That is: ansicolor is safe to use even if Term::ANSIColor is
not installed, you just don't get the colors).

See also L.

=cut

sub ansicolor {
  my $txt=shift;
  eval{require Term::ANSIColor} or return replace($txt,qr/¤./);
  my %h=qw/r red  g green  b blue  y yellow  m magenta  B bold  u underline  c clear  ¤ reset/;
  my $re=join"|",keys%h;
  $txt=~s/¤($re)/Term::ANSIColor::color($h{$1})/ge;
  return $txt;
}

=head2 ccn_ok

Checks if a Credit Card number (CCN) has correct control digits according to the LUHN-algorithm from 1960.
This method of control digits is used by MasterCard, Visa, American Express,
Discover, Diners Club / Carte Blanche, JCB and others.

B

A credit card number. Can contain non-digits, but they are removed internally before checking.

B

Something true or false.

Or more accurately:

Returns C (false) if the input argument is missing digits.

Returns 0 (zero, which is false) is the digits is not correct according to the LUHN algorithm.

Returns 1 or the name of a credit card company (true either way) if the last digit is an ok control digit for this ccn.

The name of the credit card company is returned like this (without the C<'> character)

 Returns (wo '')                Starts on                Number of digits
 ------------------------------ ------------------------ ----------------
 'MasterCard'                   51-55                    16
 'Visa'                         4                        13 eller 16
 'American Express'             34 eller 37              15
 'Discover'                     6011                     16
 'Diners Club / Carte Blanche'  300-305, 36 eller 38     14
 'JCB'                          3                        16
 'JCB'                          2131 eller 1800          15

And should perhaps have had:

 'enRoute'                      2014 eller 2149          15

...but that card uses either another control algorithm or no control
digits at all. So C is never returned here.

If the control digits is valid, but the input does not match anything in the column C, 1 is returned.

(This is also the same control digit mechanism used in Norwegian KID numbers on payment bills)

The first digit in a credit card number is supposed to tell what "industry" the card is meant for:

 MII Digit Value             Issuer Category
 --------------------------- ----------------------------------------------------
 0                           ISO/TC 68 and other industry assignments
 1                           Airlines
 2                           Airlines and other industry assignments
 3                           Travel and entertainment
 4                           Banking and financial
 5                           Banking and financial
 6                           Merchandizing and banking
 7                           Petroleum
 8                           Telecommunications and other industry assignments
 9                           National assignment

...although this has no meaning to C.

The first six digits is I, that is the bank
(probably). The rest in the "account number", except the last digits,
which is the control digit. Max length on credit card numbers are 19
digits.

=cut

sub ccn_ok {
    my $ccn=shift(); #credit card number
    $ccn=~s/\D+//g;
    if(KID_ok($ccn)){
	return "MasterCard"                   if $ccn=~/^5[1-5]\d{14}$/;
	return "Visa"                         if $ccn=~/^4\d{12}(?:\d{3})?$/;
	return "American Express"             if $ccn=~/^3[47]\d{13}$/;
	return "Discover"                     if $ccn=~/^6011\d{12}$/;
	return "Diners Club / Carte Blanche"  if $ccn=~/^3(?:0[0-5]\d{11}|[68]\d{12})$/;
	return "JCB"                          if $ccn=~/^(?:3\d{15}|(?:2131|1800)\d{11})$/;
	return 1;
    }
    #return "enRoute"                        if $ccn=~/^(?:2014|2149)\d{11}$/; #ikke LUHN-krav?
    return 0;
}

=head2 KID_ok

Checks if a norwegian KID number has an ok control digit.

To check if a customer has typed the number correctly.

This uses the  LUHN algorithm (also known as mod-10) from 1960 which is also used
internationally in control digits for credit card numbers, and Canadian social security ID numbers as well.

The algorithm, as described in Phrack (47-8) (a long time hacker online publication):

 "For a card with an even number of digits, double every odd numbered
 digit and subtract 9 if the product is greater than 9. Add up all the
 even digits as well as the doubled-odd digits, and the result must be
 a multiple of 10 or it's not a valid card. If the card has an odd
 number of digits, perform the same addition doubling the even numbered
 digits instead."

B A KID-nummer. Must consist of digits 0-9 only, otherwise a die (croak) happens.

B

- Returns undef if the input argument is missing.

- Returns 0 if the control digit (the last digit) does not satify the LUHN/mod-10 algorithm.

- Returns 1 if ok

B L

=cut

sub KID_ok {
  croak "Non-numeric argument" if $_[0]=~/\D/;
  my @k=split//,shift or return undef;
  my $s;$s+=pop(@k)+[qw/0 2 4 6 8 1 3 5 7 9/]->[pop@k] while @k;
  $s%10==0?1:0;
}



=head2 range

B

One or more numeric arguments:

First: x (first returned element)

Second: y (last but not including)

Third: step, default 1. The step between each returned element

If a fourth, fifth and so on arguments are given, they change the step for each returned element. As first derivative, second derivative.

B

If one argument: returns the array C<(0 .. x-1)>

If two arguments: returns the array C<(x .. y-1)>

If three arguments: The default step is 1. Use a third argument to use a different step.

B

 print join ",", range(11);         # prints 0,1,2,3,4,5,6,7,8,9,10      (but not 11)
 print join ",", range(2,11);       # 2,3,4,5,6,7,8,9,10          (but not 11)
 print join ",", range(11,2,-1);    # 11,10,9,8,7,6,5,4,3
 print join ",", range(2,11,3);     # 2,5,8
 print join ",", range(11,2,-3);    # 11,8,5
 print join ",", range(11,2,+3);    # prints nothing

 print join ", ",range(2,11,1,0.1);       # 2, 3, 4.1, 5.3, 6.6, 8, 9.5   adds 0.1 to step each time
 print join ", ",range(2,11,1,0.1,-0.01); # 2, 3, 4.1, 5.29, 6.56, 7.9, 9.3, 10.75

Note: In the Python language and others, C is a build in iterator (a
generator), not an array. This saves memory for large sets and sometimes time.
Use C in L to get a similar lazy generator in Perl.

=cut

sub range {
  return _range_accellerated(@_) if @_>3;  #se under
  my($x,$y,$jump)=@_;
  return (  0 .. $x-1 ) if @_==1;
  return ( $x .. $y-1 ) if @_==2;
  croak "Wrong number of arguments or jump==0" if @_!=3 or $jump==0;
  my @r;
  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 permutations

How many ways (permutations) can six people be placed around a table:

 If one person:          one
 If two persons:         two     (they can swap places)
 If three persons:       six
 If four persons:         24
 If five persons:        120
 If six  persons:        720

The formula is C where the postfix unary operator C, also known as I is defined like:
C. 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 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 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. 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
 132
 213
 231
 312
 321

If you just want to say calculate something on each permutation,
but is not interested in the list of them, you just don't
take the return. That is:

 my $ant;
 permutations(sub{$ant++ if $_[-1]>=$_[0]*2},1..9);

...is the same as:

 $$_[-1]>=$$_[0]*2 and $ant++ for permutations(1..9);

...but the first uses next to nothing of memory compared to the latter. They have about the same speed.
(The examples just counts the permutations where the last number is at least twice as large as the first)

C was created to find all combinations of a persons
name. This is useful in "fuzzy" name searches with
L if you can not be certain what is first, middle
and last names. In foreign or unfamiliar names it can be difficult to
know that.

=cut

#TODO: se test_perl.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;

  return ([@_[0,1,2]],[@_[0,2,1]],[@_[1,0,2]],
	  [@_[1,2,0]],[@_[2,0,1]],[@_[2,1,0]]) if @_==3;

  return ([@_[0,1,2,3]],[@_[0,1,3,2]],[@_[0,2,1,3]],[@_[0,2,3,1]],
	  [@_[0,3,1,2]],[@_[0,3,2,1]],[@_[1,0,2,3]],[@_[1,0,3,2]],
	  [@_[1,2,0,3]],[@_[1,2,3,0]],[@_[1,3,0,2]],[@_[1,3,2,0]],
	  [@_[2,0,1,3]],[@_[2,0,3,1]],[@_[2,1,0,3]],[@_[2,1,3,0]],
	  [@_[2,3,0,1]],[@_[2,3,1,0]],[@_[3,0,1,2]],[@_[3,0,2,1]],
	  [@_[3,1,0,2]],[@_[3,1,2,0]],[@_[3,2,0,1]],[@_[3,2,1,0]]) if @_==4;

  return ([@_[0,1,2,3,4]],[@_[0,1,2,4,3]],[@_[0,1,3,2,4]],[@_[0,1,3,4,2]],[@_[0,1,4,2,3]],
	  [@_[0,1,4,3,2]],[@_[0,2,1,3,4]],[@_[0,2,1,4,3]],[@_[0,2,3,1,4]],[@_[0,2,3,4,1]],
	  [@_[0,2,4,1,3]],[@_[0,2,4,3,1]],[@_[0,3,1,2,4]],[@_[0,3,1,4,2]],[@_[0,3,2,1,4]],
	  [@_[0,3,2,4,1]],[@_[0,3,4,1,2]],[@_[0,3,4,2,1]],[@_[0,4,1,2,3]],[@_[0,4,1,3,2]],
	  [@_[0,4,2,1,3]],[@_[0,4,2,3,1]],[@_[0,4,3,1,2]],[@_[0,4,3,2,1]],[@_[1,0,2,3,4]],
	  [@_[1,0,2,4,3]],[@_[1,0,3,2,4]],[@_[1,0,3,4,2]],[@_[1,0,4,2,3]],[@_[1,0,4,3,2]],
	  [@_[1,2,0,3,4]],[@_[1,2,0,4,3]],[@_[1,2,3,0,4]],[@_[1,2,3,4,0]],[@_[1,2,4,0,3]],
	  [@_[1,2,4,3,0]],[@_[1,3,0,2,4]],[@_[1,3,0,4,2]],[@_[1,3,2,0,4]],[@_[1,3,2,4,0]],
	  [@_[1,3,4,0,2]],[@_[1,3,4,2,0]],[@_[1,4,0,2,3]],[@_[1,4,0,3,2]],[@_[1,4,2,0,3]],
	  [@_[1,4,2,3,0]],[@_[1,4,3,0,2]],[@_[1,4,3,2,0]],[@_[2,0,1,3,4]],[@_[2,0,1,4,3]],
	  [@_[2,0,3,1,4]],[@_[2,0,3,4,1]],[@_[2,0,4,1,3]],[@_[2,0,4,3,1]],[@_[2,1,0,3,4]],
	  [@_[2,1,0,4,3]],[@_[2,1,3,0,4]],[@_[2,1,3,4,0]],[@_[2,1,4,0,3]],[@_[2,1,4,3,0]],
	  [@_[2,3,0,1,4]],[@_[2,3,0,4,1]],[@_[2,3,1,0,4]],[@_[2,3,1,4,0]],[@_[2,3,4,0,1]],
	  [@_[2,3,4,1,0]],[@_[2,4,0,1,3]],[@_[2,4,0,3,1]],[@_[2,4,1,0,3]],[@_[2,4,1,3,0]],
	  [@_[2,4,3,0,1]],[@_[2,4,3,1,0]],[@_[3,0,1,2,4]],[@_[3,0,1,4,2]],[@_[3,0,2,1,4]],
	  [@_[3,0,2,4,1]],[@_[3,0,4,1,2]],[@_[3,0,4,2,1]],[@_[3,1,0,2,4]],[@_[3,1,0,4,2]],
	  [@_[3,1,2,0,4]],[@_[3,1,2,4,0]],[@_[3,1,4,0,2]],[@_[3,1,4,2,0]],[@_[3,2,0,1,4]],
	  [@_[3,2,0,4,1]],[@_[3,2,1,0,4]],[@_[3,2,1,4,0]],[@_[3,2,4,0,1]],[@_[3,2,4,1,0]],
	  [@_[3,4,0,1,2]],[@_[3,4,0,2,1]],[@_[3,4,1,0,2]],[@_[3,4,1,2,0]],[@_[3,4,2,0,1]],
	  [@_[3,4,2,1,0]],[@_[4,0,1,2,3]],[@_[4,0,1,3,2]],[@_[4,0,2,1,3]],[@_[4,0,2,3,1]],
	  [@_[4,0,3,1,2]],[@_[4,0,3,2,1]],[@_[4,1,0,2,3]],[@_[4,1,0,3,2]],[@_[4,1,2,0,3]],
	  [@_[4,1,2,3,0]],[@_[4,1,3,0,2]],[@_[4,1,3,2,0]],[@_[4,2,0,1,3]],[@_[4,2,0,3,1]],
	  [@_[4,2,1,0,3]],[@_[4,2,1,3,0]],[@_[4,2,3,0,1]],[@_[4,2,3,1,0]],[@_[4,3,0,1,2]],
	  [@_[4,3,0,2,1]],[@_[4,3,1,0,2]],[@_[4,3,1,2,0]],[@_[4,3,2,0,1]],[@_[4,3,2,1,0]]) if @_==5;

  my(@r,@p,@c,@i,@n); @i=(0,@_); @p=@c=1..@_; @n=1..@_-1;
  PERM:
  while(1){
    if($code){if(defined wantarray){push(@r,&$code(@i[@p]))}else{&$code(@i[@p])}}else{push@r,[@i[@p]]}
    for my$i(@n){splice@p,$i,0,shift@p;next PERM if --$c[$i];$c[$i]=$i+1}
    return@r
  }
}

=head2 cart

Cartesian product

B

Input: two or more arrayrefs with accordingly x, y, z and so on number of elements.

Output: An array of x * y * z number of arrayrefs. The arrays being the cartesian product of the input arrays.

It can be useful to think of this as joins in SQL. In C statements with
more tables behind C, but without any C condition to join the tables.

B

B

- Either two or more arrayrefs with x, y, z and so on number of elements.

- Or coderefs to subs containing condition checks. Somewhat like C conditions in SQL.

B An array of x * y * z number of arrayrefs (the cartesian product)
minus the ones that did not fulfill the condition(s).

This of is as joins with one or more where conditions as coderefs.

The coderef input arguments can be placed last or among the array refs
to save both runtime and memory if the conditions depend on
arrays further back.

B

 for(cart(\@a1,\@a2,\@a3)){
   my($a1,$a2,$a3) = @$_;
   print "$a1,$a2,$a3\n";
 }

Prints the same as this:

 for my $a1 (@a1){
   for my $a2 (@a2){
     for my $a3 (@a3){
       print "$a1,$a2,$a3\n";
     }
   }
 }

B (with a condition: the sum of the first two should be dividable with 3)

 for( cart( \@a1, \@a2, sub{sum(@$_)%3==0}, \@a3 ) ) {
   my($a1,$a2,$a3)=@$_;
   print "$a1,$a2,$a3\n";
 }

Prints the same as this:

 for my $a1 (@a1){
   for my $a2 (@a2){
     next if 0==($a1+$a2)%3;
     for my $a3 (@a3){
       print "$a1,$a2,$a3\n";
     }
   }
 }

B

 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

Returns hashrefs instead of arrayrefs:

 my @cards=cart(             #5200 cards: 100 decks of 52 cards
   deck  => [1..100],
   value => [qw/2 3 4 5 6 7 8 9 10 J Q K A/],
   col   => [qw/heart diamond club star/],
 );
 for my $card ( mix(@cards) ) {
   print "From deck number $$card{deck} we got $$card{value} $$card{col}\n";
 }

Note: using sub-ref filters do not work (yet) in hash-mode. Use grep on result instead.

=cut

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/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

L

DON'T TRY THIS AT HOME, C PROGRAMMERS.

 sub reduce (&@) {
   my ($proc, $first, @rest) = @_;
   return $first if @rest == 0;
   local ($a, $b) = ($first, reduce($proc, @rest));
   return $proc->();
 }

Many functions can then be implemented with very little code. Such as:

 sub mean { (reduce {$a + $b} @_) / @_ }

=cut

sub reduce (&@) {
  my ($proc, $first, @rest) = @_;
  return $first if @rest == 0;
  no warnings;
  local ($a, $b) = ($first, reduce($proc, @rest));
  return $proc->();
}


=head2 pivot

Resembles the pivot table function in Excel.

C is used to spread out a slim and long table to a visually improved layout.

For instance spreading out the results of C-selects from SQL:

 pivot( arrayref, columnname1, columnname2, ...)

 pivot( ref_to_array_of_arrayrefs, @list_of_names_to_down_fields )

The first argument is a ref to a two dimensional table.

The rest of the arguments is a list which also signals the number of
columns from left in each row that is ending up to the left of the
data table, the rest ends up at the top and the last element of
each row ends up as data.

                   top1 top1 top1 top1
 left1 left2 left3 top2 top2 top2 top2
 ----- ----- ----- ---- ---- ---- ----
                   data data data data
                   data data data data
                   data data data data

Example:

 my @table=(
               ["1997","Gerd", "Weight", "Summer",66],
               ["1997","Gerd", "Height", "Summer",170],
               ["1997","Per",  "Weight", "Summer",75],
               ["1997","Per",  "Height", "Summer",182],
               ["1997","Hilde","Weight", "Summer",62],
               ["1997","Hilde","Height", "Summer",168],
               ["1997","Tone", "Weight", "Summer",70],

               ["1997","Gerd", "Weight", "Winter",64],
               ["1997","Gerd", "Height", "Winter",158],
               ["1997","Per",  "Weight", "Winter",73],
               ["1997","Per",  "Height", "Winter",180],
               ["1997","Hilde","Weight", "Winter",61],
               ["1997","Hilde","Height", "Winter",164],
               ["1997","Tone", "Weight", "Winter",69],

               ["1998","Gerd", "Weight", "Summer",64],
               ["1998","Gerd", "Height", "Summer",171],
               ["1998","Per",  "Weight", "Summer",76],
               ["1998","Per",  "Height", "Summer",182],
               ["1998","Hilde","Weight", "Summer",62],
               ["1998","Hilde","Height", "Summer",168],
               ["1998","Tone", "Weight", "Summer",70],

               ["1998","Gerd", "Weight", "Winter",64],
               ["1998","Gerd", "Height", "Winter",171],
               ["1998","Per",  "Weight", "Winter",74],
               ["1998","Per",  "Height", "Winter",183],
               ["1998","Hilde","Weight", "Winter",62],
               ["1998","Hilde","Height", "Winter",168],
               ["1998","Tone", "Weight", "Winter",71],
             );

.

 my @reportA=pivot(\@table,"Year","Name");
 print "\n\nReport A\n\n".tablestring(\@reportA);

Will print:

 Report A

 Year Name  Height Height Weight Weight
            Summer Winter Summer Winter
 ---- ----- ------ ------ ------ ------
 1997 Gerd  170    158    66     64
 1997 Hilde 168    164    62     61
 1997 Per   182    180    75     73
 1997 Tone                70     69
 1998 Gerd  171    171    64     64
 1998 Hilde 168    168    62     62
 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

 Year Season Height Height Height Weight Weight Weight Weight
             Gerd   Hilde  Per    Gerd   Hilde  Per    Tone
 ---- ------ ------ ------ -----  -----  ------ ------ ------
 1997 Summer 170    168    182    66     62     75     70
 1997 Winter 158    164    180    64     61     73     69
 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

 Name  Attributt 1997   1997   1998   1998
                 Summer Winter Summer Winter
 ----- --------- ------ ------ ------ ------
 Gerd  Height     170    158    171    171
 Gerd  Weight      66     64     64     64
 Hilde Height     168    164    168    168
 Hilde Weight      62     61     62     62
 Per   Height     182    180    182    183
 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

 Name  Height Height Height Height Weight Weight Weight Weight
       1997   1997   1998   1998   1997   1997   1998   1998
       Summer Winter Summer Winter Summer Winter Summer Winter
 ----- ------ ------ ------ ------ ------ ------ ------ ------
 Gerd  170    158    171    171    66     64     64     64
 Hilde 168    164    168    168    62     61     62     62
 Per   182    180    182    183    75     73     76     74
 Tone                              70     69     70     71

Options:

Options to sort differently and show sums and percents are available. (...MORE DOC ON THAT LATER...)

See also L

=cut

sub pivot {
  my($tabref,@vertikalefelt)=@_;
  my %opt=ref($vertikalefelt[-1]) eq 'HASH' ? %{pop(@vertikalefelt)} : ();
  my $opt_sum=1 if $opt{sum};
  my $opt_pro=exists $opt{prosent}?$opt{prosent}||0:undef;
  my $sortsub          = $opt{'sortsub'}          || \&_sortsub;
  my $sortsub_bortover = $opt{'sortsub_bortover'} || $sortsub;
  my $sortsub_nedover  = $opt{'sortsub_nedover'}  || $sortsub;
  #print serialize(\%opt,'opt');
  #print serialize(\$opt_pro,'opt_pro');
  my $antned=0+@vertikalefelt;
  my $bakerst=-1+@{$$tabref[0]};
  my(%h,%feltfinnes,%sum);
  #print "Bakerst<$bakerst>\n";
  for(@$tabref){
    my $rad=join($;,@$_[0..($antned-1)]);
    my $felt=join($;,@$_[$antned..($bakerst-1)]);
    my $verdi=$$_[$bakerst];
    length($rad) or $rad=' ';
    length($felt) or $felt=' ';
    $h{$rad}{$felt}=$verdi;
    $h{$rad}{"%$felt"}=$verdi;
    if($opt_sum or defined $opt_pro){
      $h{$rad}{Sum}+=$verdi;
      $sum{$felt}+=$verdi;
      $sum{Sum}+=$verdi;
    }
    $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{
	       if(/^\%/ and defined $opt_pro){
		 my $sum=$h{$rad}{Sum};
		 my $verdi=$h{$rad}{$_};
		 if($sum!=0){
		   defined $verdi
                   ?sprintf("%*.*f",3+1+$opt_pro,$opt_pro,100*$verdi/$sum)
		   :$verdi;
		 }
		 else{
		   $verdi!=0?"div0":$verdi;
		 }
	       }
	       else{
		 $h{$rad}{$_};
	       }
	     }
	     @feltfinnes);
    push(@t,[@rad]);
  }
  push(@t,"-",["Sum",(map{""}(2..$antned)),map{print "<$_>\n";$sum{$_}}@feltfinnes]) if $opt_sum;
  return @t;
}

# default sortsub for pivot()

sub _sortsub {
  no warnings;
  #my $c=($a<=>$b)||($a cmp $b);
  #return $c if $c;
  #printf "%-30s %-30s  ",replace($a,$;,','),replace($b,$;,',');
  my @a=split $;,$a;
  my @b=split $;,$b;
  for(0..$#a){
    my $c=$a[$_]<=>$b[$_];
    return $c if $c and "$a[$_]$b[$_]"!~/[iI][nN][fF]|þ/i; # inf(inity)
    $c=$a[$_]cmp$b[$_];
    return $c if $c;
  }
  return 0;
}

=head2 tablestring

B a reference to an array of arrayrefs  -- a two dimensional table of strings and numbers

B a string containing the textual table -- a string of two or more lines

The first arrayref in the list refers to a list of either column headings (scalar)
or ... (...more later...)

In this output table:

- the columns will not be wider than necessary by its widest value (any -tags are removed in every internal width-calculation)

- multi-lined cell values are handled also

- and so are html-tags, if the output is to be used inside -tags on a web page.

- columns with just numeric values are right justified (header row excepted)

Example:

 print tablestring([
   [qw/AA BB CCCC/],
   [123,23,"d"],
   [12,23,34],
   [77,88,99],
   ["lin\nes",12,"asdff\nfdsa\naa"],[0,22,"adf"]
 ]);

Prints this string of 11 lines:

 AA  BB CCCC
 --- -- -----
 123 23 d
 12  23 34
 77   8 99

 lin 12 asdff
 es     fdsa
        aa

 10  22 adf

As you can see, rows containing multi-lined cells gets an empty line before and after the row to separate it more clearly.

=cut

sub tablestring {
  my $tab=shift;
  my %o=$_[0] ? %{shift()} : ();
  my $fjern_tom=$o{fjern_tomme_kolonner};
  my $ikke_space=$o{ikke_space};
  my $nodup=$o{nodup}||0;
  my $ikke_hodestrek=$o{ikke_hodestrek};
  my $pagesize=exists $o{pagesize} ? $o{pagesize}-3 : 9999999;
  my $venstretvang=$o{venstre};
  my(@bredde,@venstre,@hoeyde,@ikketom,@nodup);
  my $hode=1;
  my $i=0;
  my $j;
  for(@$tab){
    $j=0;
    $hoeyde[$i]=0;
    my $nodup_rad=$nodup;
    if(ref($_) eq 'ARRAY'){
      for(@$_){
	my $celle=$_;
	$bredde[$j]||=0;
	if($nodup_rad and $i>0 and $$tab[$i][$j] eq $$tab[$i-1][$j] || ($nodup_rad=0)){
	  $celle=$nodup==1?"":$nodup;
	  $nodup[$i][$j]=1;
	}
	else{
	  my $hoeyde=0;
	  my $bredere;
	  no warnings;
	  $ikketom[$j]=1 if !$hode && length($celle)>0;
	  for(split("\n",$celle)){
	    $bredere=/
	    s/<[^>]+>//g;
	    $hoeyde++;
	    s/>/>/g;
	    s/</
	    $bredde[$j]=length($_)+1+$bredere if length($_)+1+$bredere>$bredde[$j];
	    $venstre[$j]=1 if $_ && !/^\s*[\-\+]?(\d+|\d*\.\d+)\s*\%?$/ && !$hode;
	  }
	  if( $hoeyde>1 && !$ikke_space){
	    $hoeyde++ unless $hode;
	    $hoeyde[$i-1]++ if $i>1 && $hoeyde[$i-1]==1;
	  }
	  $hoeyde[$i]=$hoeyde if $hoeyde>$hoeyde[$i];
	}
	$j++;
      }
    }
    else{
      $hoeyde[$i]=1;
      $ikke_hodestrek=1;
    }
    $hode=0;
    $i++;
  }
  $i=$#hoeyde;
  $j=$#bredde;
  if($i==0 or $venstretvang) { @venstre=map{1}(0..$j)                         }
  else { for(0..$j){ $venstre[$_]=1 if !$ikketom[$_] }  }
  my @tabut;
  my $rad_startlinje=0;
  my @overskrift;
  my $overskrift_forrige;
  for my $x (0..$i){
    if($$tab[$x] eq '-'){
      my @tegn=map {$$tab[$x-1][$_]=~/\S/?"-":" "} (0..$j);
      $tabut[$rad_startlinje]=join(" ",map {$tegn[$_] x ($bredde[$_]-1)} (0..$j));
    }
    else{
      for my $y (0..$j){
	next if $fjern_tom && !$ikketom[$y];
	no warnings;

	my @celle=
            !$overskrift_forrige&&$nodup&&$nodup[$x][$y]
	    ?($nodup>0?():((" " x (($bredde[$y]-length($nodup))/2)).$nodup))
            :split("\n",$$tab[$x][$y]);
	for(0..($hoeyde[$x]-1)){
	  my $linje=$rad_startlinje+$_;
	  my $txt=shift @celle || '';
	  $txt=sprintf("%*s",$bredde[$y]-1,$txt) if length($txt)>0 && !$venstre[$y] && ($x>0 || $ikke_hodestrek);
	  $tabut[$linje].=$txt;
	  if($y==$j){
	    $tabut[$linje]=~s/\s+$//;
	  }
	  else{
	    my $bredere;
	       $bredere = $txt=~/
	    $txt=~s/<[^>]+>//g;
	    $txt=~s/>/>/g;
	    $txt=~s/</
	    $tabut[$linje].= ' ' x ($bredde[$y]-length($txt)-$bredere);
	  }
	}
      }
    }
    $rad_startlinje+=$hoeyde[$x];

    #--lage streker?
    if(not $ikke_hodestrek){
      if($x==0){
	for my $y (0..$j){
	  next if $fjern_tom && !$ikketom[$y];
	  $tabut[$rad_startlinje].=('-' x ($bredde[$y]-1))." ";
	}
	$rad_startlinje++;
	@overskrift=("",@tabut);
      }
      elsif(
	    $x%$pagesize==0 || $nodup>0&&!$nodup[$x+1][$nodup-1]
	    and $x+1<@$tab
	    and !$ikke_hodestrek
	    )
      {
	push(@tabut,@overskrift);
	$rad_startlinje+=@overskrift;
	$overskrift_forrige=1;
      }
      else{
	$overskrift_forrige=0;
      }
    }
  }#for x
  return join("\n",@tabut)."\n";
}

=head2 serialize

Returns a data structure as a string. See also C
(serialize was created long time ago before Data::Dumper appeared on
CPAN, before CPAN even...)

B One to four arguments.

First argument: A reference to the structure you want.

Second argument: (optional) The name the structure will get in the output string.
If second argument is missing or is undef or '', it will get no name in the output.

Third argument: (optional) The string that is returned is also put
into a created file with the name given in this argument.  Putting a
C<< > >> char in from of the filename will append that file
instead. Use C<''> or C to not write to a file if you want to
use a fourth argument.

Fourth argument: (optional) A number signalling the depth on which newlines is used in the output.
The default is infinite (some big number) so no extra newlines are output.

B A string containing the perl-code definition that makes that data structure.
The input reference (first input argument) can be to an array, hash or a string.
Those can contain other refs and strings in a deep data structure.

Limitations:

- Code refs are not handled (just returns C)

- Regex, class refs and circular recursive structures are also not handled.

B

  $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 Cing a perl code string
stored somewhere that unauthorized users can change them! You are
probably better of using L or L without
enabling the CODE-options if you have such security issues.
More on decompiling Perl-code: L or L.

=head2 dserialize

Debug-serialize, dumping data structures for you to look at.

Same as C 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,$linje,$sub,$hasargs,$wantarray);
      ($pakke,$fil,$linje,$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, 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 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 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+)?(e[-+]?\d+)?)',=>$1,gi;  #ikke ledende null!    hm
  $s;
}


=head2 sys

Call instead of C if you want C (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  (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;
}


#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 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 The resulting output from the program.

Example:

 print brainfu(<<"");  #prints "Hallo Verden!\n"
 ++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>---.+++++++++++..+++.>++.<<++++++++++++++
 .>----------.+++++++++++++.--------------.+.+++++++++.>+.>.

See L

=head2 brainfu2perl

Just as L 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;

=head2 brainfu2perl_optimized

Just as L but optimizes the perl code. The same
example as above with brainfu2perl_optimized returns this equivalent
but shorter perl code:

 $b[++$c]+=8;while($b[$c]){$b[--$c]+=8;--$b[++$c]}$b[--$c]+=8;out;$b[++$c]+=6;
 while($b[$c]){$b[--$c]+=6;--$b[++$c]}$b[--$c]-=3;out;$o;

=cut

sub brainfu { eval(brainfu2perl(@_)) }

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;':/
  $perl;
}

sub brainfu2perl_optimized {
  my $perl=brainfu2perl(@_);
  $perl=~s{(((\+|\-)\3\$b\[\$c\];){2,})}{ '$b[$c]'.$3.'='.(grep/b/,split//,$1).';' }gisex;
  1 while $perl=~s/\+\+\$c;\-\-\$c;//g + $perl=~s/\-\-\$c;\+\+\$c;//g;
  $perl=~s{((([\-\+])\3\$c;){2,})}{"\$c$3=".(grep/c/,split//,$1).';'}gisex;
  $perl=~s{((\+\+|\-\-)\$c;([^;{}]+;))}{my($o,$s)=($2,$3);$s=~s/\$c/$o\$c/?$s:$1}ge;
  $perl=~s/\$c(\-|\+)=(\d+);(\+\+|\-\-)\$b\[\$c\]/$3.'$b[$c'.$1.'='.$2.'];'/ge;
  $perl=~s{((out;){2,})}{'out('.(grep/o/,split//,$1).');'}ge;
  $perl=~s/;}/}/g;$perl=~s/;+/;/g;
  $perl;
}


=head1 BLOOM FILTER SUBROUTINES

Bloom filters can be used to check whether an element (a string) is a
member of a large set using much less memory or disk space than other
data structures. Trading speed and accuracy for memory usage. While
risking false positives, Bloom filters have a very strong space
advantage over other data structures for representing sets.

In the example below, a set of 100000 phone numbers (or any string of
any length) can be "stored" in just 91230 bytes if you accept that you
can only check the data structure for existence of a string and accept
false positives with an error rate of 0.03 (that is three percent, error
rates are given in numbers larger than 0 and smaller than 1).

You can not retrieve the strings in the set without using "brute
force" methods and even then you would get slightly more strings than
you put in because of the error rate inaccuracy.

Bloom Filters have many uses.

See also: L

See also: L

=head2 bfinit

Initialize a new Bloom Filter:

  my $bf = bfinit( error_rate=>0.01, capacity=>100000 );

The same:

  my $bf = bfinit( 0.01, 100000 );

since two arguments is interpreted as error_rate and capacity accordingly.


=head2 bfadd

  bfadd($bf, $_) for @phone_numbers;   # Adding strings one at a time

  bfadd($bf, @phone_numbers);          # ...or all at once (faster)

Returns 1 on success. Dies (croaks) if more strings than capacity is added.

=head2 bfcheck

  my $phone_number="97713246";
  if ( bfcheck($bf, $phone_number) ) {
    print "Yes, $phone_number was PROBABLY added\n";
  }
  else{
    print "No, $phone_number was DEFINITELY NOT added\n";
  }

Returns true if C<$phone_number> exists in C<@phone_numbers>.

Returns false most of the times, but sometimes true*), if C<$phone_number> doesn't exists in C<@phone_numbers>.

*) This is called a false positive.

Checking more than one key:

 @bools = bfcheck($bf, @keys);          # or ...
 @bools = bfcheck($bf, \@keys);         # better, uses less memory if @keys is large

Returns an array the same size as @keys where each element is true or false accordingly.

=head2 bfgrep

Same as C except it returns the keys that exists in the bloom filter

 @found = bfgrep($bf, @keys);           # or ...
 @found = bfgrep($bf, \@keys);          # better, uses less memory if @keys is large, or ...
 @found = grep bfcheck($bf,$_), @keys;  # same but slower

=head2 bfgrepnot

Same as C except it returns the keys that do NOT exists in the bloom filter:

 @not_found = bfgrepnot($bf, @keys);          # or ...
 @not_found = bfgrepnot($bf, \@keys);         # better, uses less memory if @keys is large, or ...
 @not_found = grep !bfcheck($bf,$_), @keys);  # same but slower

=head2 bfdelete

Deletes from a counting bloom filter.

To enable deleting be sure to initialize the bloom filter with the
numeric C argument. The number of bits could be 2 or 3*)
for small filters with a small capacity (a small number of keys), but
setting the number to 4 ensures that even very large filters with very
small error rates would not overflow.

*) Acme::Tools do not currently support C<< counting_bits => 3 >> so 4
and 8 are the only practical alternatives where 8 is almost always overkill.

 my $bf=bfinit(
   error_rate    => 0.001,
   capacity      => 10000000,
   counting_bits => 4              # power of 2, that is 2, 4, 8, 16 or 32
 );
 bfadd(   $bf, @unique_phone_numbers);
 bfdelete($bf, @unique_phone_numbers);

Example: examine the frequency of the counters with 4 bit counters and 4 million keys:

 my $bf=bfinit( error_rate=>0.001, capacity=>4e6, counting_bits=>4 );
 bfadd($bf,[1e3*$_+1 .. 1e3*($_+1)]) for 0..4000-1;  # adding 4 million keys one thousand at a time
 my %c; $c{vec($$bf{filter},$_,$$bf{counting_bits})}++ for 0..$$bf{filterlength}-1;
 printf "%8d counters = %d\n",$c{$_},$_ for sort{$a<=>$b}keys%c;

The output:

 28689562 counters = 0
 19947673 counters = 1
  6941082 counters = 2
  1608250 counters = 3
   280107 counters = 4
    38859 counters = 5
     4533 counters = 6
      445 counters = 7
       46 counters = 8
        1 counters = 9

Even after the error_rate is changed from 0.001 to a percent of that, 0.00001, the limit of 16 (4 bits) is still far away:

 47162242 counters = 0
 33457237 counters = 1
 11865217 counters = 2
  2804447 counters = 3
   497308 counters = 4
    70608 counters = 5
     8359 counters = 6
      858 counters = 7
       65 counters = 8
        4 counters = 9

In algorithmic terms the number of bits needed is C.  Thats why 4 bits (counters up
to 15) is "always" good enough except for extremely large capasities or extremely small error rates.
(Except when adding the same key many times, which should be avoided, and Acme::Tools::bfadd do not
check for that, perhaps in future versions).

Bloom filters of the counting type are not very space efficient: The tables above shows that 84%-85%
of the counters are 0 or 1. This means most bits are zero-bits. This doesn't have to be a problem if
a counting bloom filter is used to be sent over slow networks because they are very compressable by
common compression tools like I or L and such.

Deletion of non-existing keys makes C die (croak).

=head2 bfdelete

Deletes from a counting bloom filter:

 bfdelete($bf, @keys);
 bfdelete($bf, \@keys);

Returns C<$bf> after deletion.

Croaks (dies) on deleting a non-existing key or deleting from an previouly overflown counter in a counting bloom filter.

=head2 bfaddbf

Adds another bloom filter to a bloom filter.

Bloom filters has the proberty that bit-wise I-ing the bit-filters
of two filters with the same capacity and the same number and type of
hash functions, adds the filters:

  my $bf1=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[1..500]);
  my $bf2=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[501..1000]);

  bfaddbf($bf1,$bf2);

  print "Yes!" if bfgrep($bf1, 1..1000) == 1000;

Prints yes since C now returns an array of all the 1000 elements.

Croaks if the filters are of different dimensions.

Works for counting bloom filters as well (C<< counting_bits=>4 >> e.g.)

=head2 bfsum

Returns the number of 1's in the filter.

 my $percent=100*bfsum($bf)/$$bf{filterlength};
 printf "The filter is %.1f%% filled\n",$percent; #prints 50.0% or so if filled to capacity

Sums the counters for counting bloom filters (much slower than for non counting).

=head2 bfdimensions

Input, two numeric arguments: Capacity and error_rate.

Outputs an array of two numbers: m and k.

  m = - n * log(p) / log(2)**2   # n = capacity, m = bits in filter (divide by 8 to get bytes)
  k = log(1/p) / log(2)          # p = error_rate, uses perls internal log() with base e (2.718)

...that is: m = the best number of bits in the filter and k = the best
number of hash functions optimized for the given capacity (n) and
error_rate (p). Note that k is a dependent only of the error_rate.  At
about two percent error rate the bloom filter needs just the same
number of bytes as the number of keys.

 Storage (bytes):
 Capacity      Error-rate  Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate Error-rate
               0.000000001 0.00000001 0.0000001  0.000001   0.00001    0.0001     0.001      0.01       0.02141585 0.1        0.5        0.99
 ------------- ----------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ----------
            10 54.48       48.49      42.5       36.51      30.52      24.53      18.53      12.54      10.56      6.553      2.366      0.5886
           100 539.7       479.8      419.9      360        300.1      240.2      180.3      120.4      100.6      60.47      18.6       0.824
          1000 5392        4793       4194       3595       2996       2397       1798       1199       1001       599.6      180.9      3.177
         10000 5.392e+04   4.793e+04  4.194e+04  3.594e+04  2.995e+04  2.396e+04  1.797e+04  1.198e+04  1e+04      5991       1804       26.71
        100000 5.392e+05   4.793e+05  4.193e+05  3.594e+05  2.995e+05  2.396e+05  1.797e+05  1.198e+05  1e+05      5.991e+04  1.803e+04  262
       1000000 5.392e+06   4.793e+06  4.193e+06  3.594e+06  2.995e+06  2.396e+06  1.797e+06  1.198e+06  1e+06      5.991e+05  1.803e+05  2615
      10000000 5.392e+07   4.793e+07  4.193e+07  3.594e+07  2.995e+07  2.396e+07  1.797e+07  1.198e+07  1e+07      5.991e+06  1.803e+06  2.615e+04
     100000000 5.392e+08   4.793e+08  4.193e+08  3.594e+08  2.995e+08  2.396e+08  1.797e+08  1.198e+08  1e+08      5.991e+07  1.803e+07  2.615e+05
    1000000000 5.392e+09   4.793e+09  4.193e+09  3.594e+09  2.995e+09  2.396e+09  1.797e+09  1.198e+09  1e+09      5.991e+08  1.803e+08  2.615e+06
   10000000000 5.392e+10   4.793e+10  4.193e+10  3.594e+10  2.995e+10  2.396e+10  1.797e+10  1.198e+10  1e+10      5.991e+09  1.803e+09  2.615e+07
  100000000000 5.392e+11   4.793e+11  4.193e+11  3.594e+11  2.995e+11  2.396e+11  1.797e+11  1.198e+11  1e+11      5.991e+10  1.803e+10  2.615e+08
 1000000000000 5.392e+12   4.793e+12  4.193e+12  3.594e+12  2.995e+12  2.396e+12  1.797e+12  1.198e+12  1e+12      5.991e+11  1.803e+11  2.615e+09

 Error rate:               0.99   Hash functions:  1
 Error rate:                0.5   Hash functions:  1
 Error rate:                0.1   Hash functions:  3
 Error rate: 0.0214158522653385   Hash functions:  6
 Error rate:               0.01   Hash functions:  7
 Error rate:              0.001   Hash functions: 10
 Error rate:             0.0001   Hash functions: 13
 Error rate:            0.00001   Hash functions: 17
 Error rate:           0.000001   Hash functions: 20
 Error rate:          0.0000001   Hash functions: 23
 Error rate:         0.00000001   Hash functions: 27
 Error rate:        0.000000001   Hash functions: 30

=head2 bfstore

Storing and retrieving bloom filters to and from disk uses Ls C and C. This:

 bfstore($bf,'filename.bf');

It the same as:

 use Storable qw(store retrieve);
 ...
 store($bf,'filename.bf');

=head2 bfretrieve

This:

 my $bf=bfretrieve('filename.bf');

Or this:

 my $bf=bfinit('filename.bf');

Is the same as:

 use Storable qw(store retrieve);
 my $bf=retrieve('filename.bf');

=head2 bfclone

Deep copies the bloom filter data structure. (Which btw is not very deep, two levels at most)

This:

 my $bfc = bfclone($bf);

Works just as:

 use Storable;
 my $bfc=Storable::dclone($bf);

=head2 Object oriented interface to bloom filters

 use Acme::Tools;
 my $bf=new Acme::Tools::BloomFilter(0.1,1000); # the same as bfinit, see bfinit above
 print ref($bf),"\n";                           # prints Acme::Tools::BloomFilter
 $bf->add(@keys);
 $bf->check($keys[0]) and print "ok\n";         # prints ok
 $bf->grep(\@keys)==@keys and print "ok\n";     # prints ok
 $bf->store('filename.bf');
 my $bf2=bfretrieve('filename.bf');
 $bf2->check($keys[0]) and print "ok\n";        # still ok

 $bf2=$bf->clone();

To instantiate a previously stored bloom filter:

 my $bf = Acme::Tools::BloomFilter->new( '/path/to/stored/bloomfilter.bf' );

The o.o. interface has the same methods as the C-subs without the
C-prefix in the names. The C is not available as a
method, although C, C and
C are synonyms.

=head2 Internals and speed

The internal hash-functions are C<< md5( "$key$salt" ) >> from L.

Since C returns 128 bits and most medium to large sized bloom
filters need only a 32 bit hash function, the result from md5() are
split (C-ed) into 4 parts 32 bits each and are treated as if 4
hash functions was called at once (speedup). Using different salts to
the key on each md5 results in different hash functions.

Digest::SHA512 would have been even better since it returns more bits,
if it werent for the fact that it's much slower than Digest::MD5.

String::CRC32::crc32 is faster than Digest::MD5, but not 4 times faster:

 time perl -e'use Digest::MD5 qw(md5);md5("asdf$_") for 1..10e6'       #5.56 sec
 time perl -e'use String::CRC32;crc32("asdf$_") for 1..10e6'           #2.79 sec, faster but not per bit
 time perl -e'use Digest::SHA qw(sha512);sha512("asdf$_") for 1..10e6' #36.10 sec, too slow (sha1, sha224, sha256 and sha384 too)

Md5 seems to be an ok choice both for speed and avoiding collitions due to skewed data keys.

=head2 Theory and math behind bloom filters

L

L

L

See also Scaleable Bloom Filters: L (not implemented in Acme::Tools)

...and perhaps L

=cut

sub bfinit {
  return bfretrieve(@_)                             if @_==1;
  return bfinit(error_rate=>$_[0], capacity=>$_[1]) if @_==2 and 0<$_[0] and $_[0]<1 and $_[1]>1;
  return bfinit(error_rate=>$_[1], capacity=>$_[0]) if @_==2 and 0<$_[1] and $_[1]<1 and $_[0]>1;
  require Digest::MD5;
  @_%2&&croak "Arguments should be a hash of equal number of keys and values";
  my %arg=@_;
  my @ok_param=qw/error_rate capacity min_hashfuncs max_hashfuncs hashfuncs counting_bits adaptive keys/;
  my @not_ok=sort(grep!in($_,@ok_param),keys%arg);
  croak "Not ok param to bfinit: ".join(", ",@not_ok) if @not_ok;
  croak "Not an arrayref in keys-param" if exists $arg{keys} and ref($arg{keys}) ne 'ARRAY';
  croak "Not implemented counting_bits=$arg{counting_bits}, should be 2, 4, 8, 16 or 32" if !in(nvl($arg{counting_bits},1),1,2,4,8,16,32);
  croak "An bloom filters here can not be in both adaptive and counting_bits modes" if $arg{adaptive} and $arg{counting_bits}>1;
  my $bf={error_rate    => 0.001,  #default p
	  capacity      => 100000, #default n
          min_hashfuncs => 1,
          max_hashfuncs => 100,
	  counting_bits => 1,      #default: not counting filter
	  adaptive      => 0,
	  %arg,                    #arguments
	  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*";
  bfadd($bf,@{$arg{keys}}) if $arg{keys};
  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};
  croak "Exceeded filter capacity $$bf{key_count} + $$bf2{key_count} = $count > $$bf{capacity}"
    if $count > $$bf{capacity};
  $$bf{key_count}+=$$bf2{key_count};
  if($$bf{counting_bits}==1){
    $$bf{filter} |= $$bf2{filter};
    #$$bf{filter} = $$bf{filter} | $$bf2{filter}; #or-ing
  }
  else {
    my $cb=$$bf{counting_bits};
    for(0..$$bf{filterlength}-1){
      my $sum=
      vec($$bf{filter}, $_,$cb)+
      vec($$bf2{filter},$_,$cb);
      if( $sum>2**$cb-1 ){
	$sum=2**$cb-1;
	$$bf{overflow}{$_}++;
      }
      vec($$bf{filter}, $_,$cb)=$sum;
      no warnings;
      $$bf{overflow}{$_}+=$$bf2{overflow}{$_}
	and keys(%{$$bf{overflow}})>10 #hmm, arbitrary limit
	and croak "Too many overflows, concider doubling counting_bits from $cb to ".(2*$cb)
	if exists $$bf2{overflow}{$_};
    }
  }
  return $bf; #for convenience
}
sub bfsum {
  my($bf)=@_;
  return unpack( "%32b*", $$bf{filter}) if $$bf{counting_bits}==1;
  my($sum,$cb)=(0,$$bf{counting_bits});
  $sum+=vec($$bf{filter},$_,$cb) for 0..$$bf{filterlength}-1;
  return $sum;
}
sub bfadd {
  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,$n,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','capacity','counting_bits','adaptive'};
  for(@$keysref){
    #croak "Key should be scalar" if ref($_);
    $$bf{key_count} >= $n and croak "Exceeded filter capacity $n"  or  $$bf{key_count}++;
    my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k;
    if ($cb==1 and !$adaptive) { # normal bloom filter
      vec($$bf{filter}, $h[$_] % $m, 1) = 1 for 0..$k-1;
    }
    elsif ($cb>1) {                 # counting bloom filter
      for(0..$k-1){
	my $pos=$h[$_] % $m;
	my $c=
  	vec($$bf{filter}, $pos, $cb) =
	vec($$bf{filter}, $pos, $cb) + 1;
	if($c==0){
	  vec($$bf{filter}, $pos, $cb) = -1;
	  $$bf{overflow}{$pos}++
	    and keys(%{$$bf{overflow}})>10 #hmm, arbitrary limit
	    and croak "Too many overflows, concider doubling counting_bits from $cb to ".(2*$cb);
	}
      }
    }
    elsif ($adaptive) {             # adaptive bloom filter
      my($i,$key,$bit)=(0+@h,$_);
      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);
	vec($$bf{filter}, $pos, 1)=1;
	last if $_>=$k-1 and $bit==0;
      }
    }
    else {croak}
  }
  return 1;
}
sub bfcheck {
  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,$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);
	$match++ if $_ >  $k-1 and $bit==1;
	$match=0 if $_ <= $k-1 and $bit==0;
	last     if $bit==0;
      }
      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'};
  return grep {
    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;
    $match;
  } @$keysref;
}
sub bfgrepnot { # just a copy of bfgrep with $match replaced by not $match
  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'};
  return grep {
    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;
    !$match;
  } @$keysref;
}
sub bfdelete {
  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'};
  croak "Cannot delete from non-counting bloom filter (use counting_bits 4 e.g.)" if $cb==1;
  for my $key (@$keysref){
    my @h; push @h, unpack $up, Digest::MD5::md5($key,0+@h) while @h<$k;
    $$bf{key_count}==0 and croak "Deleted all and then some"  or  $$bf{key_count}--;
    my($ones,$croak,@pos)=(0);
    for(0..$k-1){
      my $pos=$h[$_] % $m;
      my $c=
      vec($$bf{filter}, $pos, $cb);
      vec($$bf{filter}, $pos, $cb)=$c-1;
      $croak="Cannot delete a non-existing key $key" if $c==0;
      $croak="Cannot delete with previously overflown position. Try doubleing counting_bits"
	if $c==1 and ++$ones and $$bf{overflow}{$pos};
    }
    if($croak){ #rollback
      vec($$bf{filter}, $h[$_] % $m, $cb)=
      vec($$bf{filter}, $h[$_] % $m, $cb)+1 for 0..$k-1;
      croak $croak;
    }
  }
  return $bf;
}
sub bfstore {
  require Storable;
  Storable::store(@_);
}
sub bfretrieve {
  require Storable;
  my $bf=Storable::retrieve(@_);
  carp  "Retrieved bloom filter was stored in version $$bf{version}, this is version $VERSION" if $$bf{version}>$VERSION;
  return $bf;
}
sub bfclone {
  require Storable;
  return Storable::dclone(@_); #could be faster
}
sub bfdimensions_old {
  my($n,$p,$mink,$maxk, $k,$flen,$m)=
    @_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'},1)
   :@_==2 ? (@_,1,100,1)
          : croak "Wrong number of arguments (".@_."), should be 2";
  croak "p ($p) should be > 0 and < 1" if not ( 0<$p && $p<1 );
  $m=-1*$_*$n/log(1-$p**(1/$_)) and (!defined $flen or $m<$flen) and ($flen,$k)=($m,$_) for $mink..$maxk;
  $flen = int(1+$flen);
  return ($flen,$k);
}
sub bfdimensions {
  my($n,$p,$mink,$maxk)=
    @_==1 ? (@{$_[0]}{'capacity','error_rate','min_hashfuncs','max_hashfuncs'})
   :@_==2 ? (@_,1,100)
          : croak "Wrong number of arguments (".@_."), should be 2";
  my $k=log(1/$p)/log(2);           # k hash funcs
  my $m=-$n*log($p)/log(2)**2;      # m bits in filter
  return ($m+0.5,min($maxk,max($mink,int($k+0.5))));
}

#crontab -e
#01 4,10,16,22 * * * /usr/bin/perl -MAcme::Tools -e'Acme::Tools::_update_currency_file("/var/www/html/currency-rates")' > /dev/null 2>&1

sub _update_currency_file { #call from cron
  my $fn=shift()||'/var/www/html/currency-rates';
  my %exe=map+($_=>"/usr/bin/$_"),qw/curl ci/;-x$_ or die 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 "http://www.x-rates.com/table/?from=NOK&amount=$amount");
  $data=~s,to=([A-Z]{3})(.)>,$2>$1
  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@tc=qx($exe{curl} -s https://btc-e.com/api/3/ticker/btc_usd-ltc_usd)=~/avg.?:(\d+\.?\d*)/g;
  push @data,"BTC ".($tc[0]*$data{USD})."\n";
  push @data,"LTC ".($tc[1]*$data{USD})."\n";
  print $F sort(@data);
  close($F);
  qx($exe{ci} -l -m. -d $fn) if -w"$fn,v";
}

sub ftype {
  my $f=shift;
  -e $f and
      -f$f ? 'file'         # -f  File is a plain file.
     :-d$f ? 'dir'          # -d  File is a directory.
     :-l$f ? 'symlink'      # -l  File is a symbolic link.
     :-p$f ? 'pipe'         # -p  File is a named pipe (FIFO), or Filehandle is a pipe.
     :-S$f ? 'socket'       # -S  File is a socket.
     :-b$f ? 'blockfile'    # -b  File is a block special file.
     :-c$f ? 'charfile'     # -c  File is a character special file.
     :-t$f ? 'ttyfile'      # -t  Filehandle is opened to a tty.
     :       ''
  or undef;
}

=head1 COMMANDS

=head2 install_acme_command_tools

 sudo perl -MAcme::Tools -e install_acme_command_tools
 Wrote executable /usr/local/bin/conv
 Wrote executable /usr/local/bin/due
 Wrote executable /usr/local/bin/xcat
 Wrote executable /usr/local/bin/freq
 Wrote executable /usr/local/bin/deldup
 Wrote executable /usr/local/bin/wipe

Examples of commands then made available:

 conv 1 USD EUR                #might show 0.88029 if thats the current currency rate. Uses conv()
 conv .5 in cm                 #reveals that 1/2 inch is 1.27 cm, see doc on conv() for all supported units
 due [-h] /path/1/ /path/2/    #like du, but show statistics on file extentions instead of subdirs
 xcat file                     #like cat, zcat, bzcat or xzcat in one. Uses file extention to decide. Uses openstr()
 freq file                     #reads file(s) or stdin and view counts of each byte 0-255
 deldup [-d] path1/ path2/     #reports (and optionally deletes) duplicate files NOT IMPLEMENTED YET!
 ccmd grep string /huge/file   #caches stdout+stderr for 15 minutes (default) for much faster results later
 ccmd "sleep 2;echo hello"     #slow first time. Note the quotes!
 ccmd "du -s ~/*|sort -n|tail" #ccmd store stdout+stderr in /tmp files (default)

=head3 due

Like C command but views space used by file extentions instead of dirs. Options:

 due [-options] [dirs] [files]
 due -h          View bytes "human readable", i.e. C<8.72 MB> instead of C<9145662 b> (bytes)
 due -k | -m     View bytes in kilobytes | megabytes (1024 | 1048576)
 due -K          Like -k but uses 1000 instead of 1024
 due -z          View two extentions if .z .Z .gz .bz2 .rz or .xz (.tar.gz, not just .gz)
 due -M          Also show min, medium and max date (mtime) of files, give an idea of their age
 due -P          Also show 10, 50 (medium) and 90 percentile of file date
 due -MP         Both -M and -P, shows min, 10p, 50p, 90p and max
 due -a          Sort output alphabetically by extention (default order is by size)
 due -c          Sort output by number of files
 due -i          Ignore case, .GZ and .gz is the same, output in lower case
 due -t          Adds time of day to -M and -P output
 due -e 'regex'  Exclude files (full path) matching regex. Ex: due -e '\.git'

=cut

sub install_acme_command_tools {
  my $dir=(grep -d$_, @_, '/usr/local/bin', '/usr/bin')[0];
  for(qw( conv due xcat freq deldup ccmd )){
    unlink("$dir/$_");
    writefile("$dir/$_", "#!$^X\nuse Acme::Tools;\nAcme::Tools::cmd_$_(\@ARGV);\n");
    sys("/bin/chmod +x $dir/$_");
    print "Wrote executable $dir/$_\n";
  }
}
sub cmd_conv { print conv(@ARGV)."\n"  }
  use Data::Dumper;
sub cmd_due { #TODO: output from tar tvf and ls and find -ls
  require Getopt::Std; my %o; Getopt::Std::getopts("zkKmhciMPate:" => \%o);
  require File::Find;
  no warnings 'uninitialized';
  die"$0: -h, -k or -m can not be used together\n" if $o{h}+$o{k}+$o{m}>1;
  die"$0: -c and -a can not be used together\n"    if $o{a}+$o{c}>1;
  die"$0: -k and -m can not be used together\n"    if $o{k}+$o{m}>1;
  my @q=@ARGV; @q=('.') if !@q;
  my(%c,%b,$cnt,$bts,%mtime);
  my $r=$o{z} ? qr/(\.[^\.\/]{1,10}(\.(z|Z|gz|bz2|rz|xz))?)$/
              : qr/(\.[^\.\/]{1,10})$/;
  my $rexcl=exists$o{e}?qr/$o{e}/:0;
  File::Find::find({wanted =>
    sub {
      return if !-f$_;
      return if $rexcl and $File::Find::name=~$rexcl;
      my($sz,$mtime)=(stat($_))[7,9];
      my $ext=m/$r/?$1:"";
      $ext=lc($ext) if $o{i};
      $cnt++;    $c{$ext}++;
      $bts+=$sz; $b{$ext}+=$sz;
      $mtime{$ext}.=",$mtime" if $o{M} or $o{P};
      1;
    } },@q);
  my($f,$s)=$o{k}?("%14.2f kb",sub{$_[0]/1024})
           :$o{K}?("%14.2f Kb",sub{$_[0]/1000})
           :$o{m}?("%14.2f mb",sub{$_[0]/1024**2})
           :$o{h}?("%14s",     sub{bytes_readable($_[0])})
           :      ("%14d b",   sub{$_[0]});
  my @e=$o{a}?(sort(keys%c))
       :$o{c}?(sort{$c{$a}<=>$c{$b} or $a cmp $b}keys%c)
       :      (sort{$b{$a}<=>$b{$b} or $a cmp $b}keys%c);
  my @p=$o{P}?(10,50,90):(50);
  my $perc=sub{
    $o{M} or $o{P} or return"";
    my @m=@_>0 ? do {grep$_, split",", $mtime{$_[0]}}
               : do {grep$_, map {split","} values %mtime};
    my @r=percentile(\@p,@m);
    @r=(min(@m),@r,max(@m)) if $o{M};
    @r=map int($_), @r;
    my $fmt='YYYY/MM/DD'; $fmt.="-MM:MI:SS" if $o{t};
    @r=map tms($_,$fmt), @r;
    "  ".join(" ",@r);
  };
  printf("%-11s %8d $f %7.2f%%%s\n",$_,$c{$_},&$s($b{$_}),100*$b{$_}/$bts,&$perc($_)) for @e;
  printf("%-11s %8d $f %7.2f%%%s\n","Sum",$cnt,&$s($bts),100,&$perc());
}
sub cmd_xcat {
  for my $fn (@_){
    my $os=openstr($fn);
    open my $FH, $os or warn "xcat: cannot open $os ($!)\n" and next;
    print while <$FH>;
    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 {
  # ~/test/deldup.pl #find and optionally delete duplicate files effiencently
  #http://www.commandlinefu.com/commands/view/3555/find-duplicate-files-based-on-size-first-then-md5-hash
  die "todo: deldup not ready yet"
}

#http://stackoverflow.com/questions/11900239/can-i-cache-the-output-of-a-command-on-linux-from-cli
our $Ccmd_cache_dir='/tmp/acme-tools-ccmd-cache';
our $Ccmd_cache_expire=15*60;  #default 15 minutes
sub cmd_ccmd {
  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);
}

sub cmd_trunc { die "todo: trunc not ready yet"} #truncate a file, size 0, keep all other attr

sub cmd_wipe  {
  require Getopt::Std; my %o; Getopt::Std::getopts("n:k" => \%o);
  wipe($_,$o{n},$o{k}) for @_;
}

=head1 DATABASE STUFF - NOT IMPLEMENTED YET

Uses L. Comming soon...

  $Dbh
  dlogin
  dlogout
  drow
  drows
  drowc
  drowsc
  dcols
  dpk
  dsel
  ddo
  dins
  dupd
  ddel
  dcommit
  drollback

=cut

#my$dummy=<<'SOON';
sub dtype {
  my $connstr=shift;
  return 'SQLite' if $connstr=~/(\.sqlite|sqlite:.*\.db)$/i;
  return 'Oracle' if $connstr=~/\@/;
  return 'Pg' if 1==2;
  die;
}

our($Dbh,@Dbh,%Sth);
our %Dbattr=(RaiseError => 1, AutoCommit => 0); #defaults
sub dlogin {
  my $connstr=shift();
  my %attr=(%Dbattr,@_);
  my $type=dtype($connstr);
  my($dsn,$u,$p)=('','','');
  if($type eq 'SQLite'){
    $dsn=$connstr;
  }
  elsif($type eq 'Oracle'){
    ($u,$p,$dsn)=($connstr=~m,(.+?)(/.+?)?\@(.+),);
  }
  elsif($type eq 'Pg'){
    croak "todo";
  }
  else{
    croak "dblogin: unknown database type for connection string $connstr\n";
  }
  $dsn="dbi:$type:$dsn";
  push @Dbh, $Dbh if $Dbh; #local is better?
  require DBI;
  $Dbh=DBI->connect($dsn,$u,$p,\%attr); #connect_cached?
}
sub dlogout {
  $Dbh->disconnect;
  $Dbh=pop@Dbh if @Dbh;
}
sub drow {
  my($q,@b)=_dattrarg(@_);
  #my $sth=do{$Sth{$Dbh,$q} ||= $Dbh->prepare_cached($q)};
  my $sth=$Dbh->prepare_cached($q);
  $sth->execute(@b);
  my @r=$sth->fetchrow_array;
  $sth->finish if $$Dbh{Driver}{Name} eq 'SQLite';
  #$dbh->selectrow_array($statement);
  return @r==1?$r[0]:@r;
}
sub drows {
}
sub drowc {
}
sub drowsc {
}
sub dcols {
}
sub dpk {
}
sub dsel {
}
sub ddo {
  my @arg=_dattrarg(@_);
  #warn serialize(\@arg,'arg','',1);
  $Dbh->do(@arg); #hm cache?
}
sub dins {
}
sub dupd {
}
sub ddel {
}
sub dcommit { $Dbh->commit }
sub drollback { $Dbh->rollback }

sub _dattrarg {
  my @arg=@_;
  splice @arg,1,0, ref($arg[-1]) eq 'HASH' ? pop(@arg) : {};
  @arg;
}

=head2 self_update

Update Acme::Tools to newest version quick and dirty:

 function pmview(){ ls -ld `perl -M$1 -le'$m=shift;$mi=$m;$mi=~s,::,/,g;print $INC{"$mi.pm"};warn"Version ".${$m."::VERSION"}."\n"' $1`;}

 pmview Acme::Tools                                     #view date and version before
 sudo perl -MAcme::Tools -e Acme::Tools::self_update    #update to newest version
 pmview Acme::Tools                                     #view date and version after

Does C to where Acme/Tools.pm are and then wget -N https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm

=cut

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");
}

1;

package Acme::Tools::BloomFilter;
use 5.008; use strict; use warnings; use Carp;
sub new      { my($class,@p)=@_; my $self=Acme::Tools::bfinit(@p); bless $self, $class }
sub add      { &Acme::Tools::bfadd      }
sub addbf    { &Acme::Tools::bfaddbf    }
sub check    { &Acme::Tools::bfcheck    }
sub grep     { &Acme::Tools::bfgrep     }
sub grepnot  { &Acme::Tools::bfgrepnot  }
sub delete   { &Acme::Tools::bfdelete   }
sub store    { &Acme::Tools::bfstore    }
sub retrieve { &Acme::Tools::bfretrieve }
sub clone    { &Acme::Tools::bfclone    }
sub sum      { &Acme::Tools::bfsum      }
1;

# Ny versjon:
# + c-s todo
# + endre $VERSION
# + endre Release history under HISTORY
# + endre årstall under COPYRIGHT AND LICENSE
# + oppd default valutakurser inkl datoen
# + emacs Changes
# + emacs README + aarstall
# + emacs MANIFEST legg til ev nye t/*.t
# + perl            Makefile.PL;make test
# + /usr/bin/perl   Makefile.PL;make test
# + perlbrew exec "perl ~/Acme-Tools/Makefile.PL ; time make test"
# + perlbrew use perl-5.10.1; perl Makefile.PL; make test; perlbrew off
# + test evt i cygwin og mingw-perl
# + pod2html Tools.pm > Tools.html ; firefox Tools.html
# + https://metacpan.org/pod/Acme::Tools
# + http://cpants.cpanauthors.org/dist/Acme-Tools  #kvalitee
# + perl Makefile.PL ; make test && make dist
# + cp -p *tar.gz /htdocs/
# + ci -l -mversjon -d `cat MANIFEST`
# + git add `cat MANIFEST`
# + git status
# + git commit -am versjon
# + git push                    #eller:
# + git push origin master
# + http://pause.perl.org/
# http://en.wikipedia.org/wiki/Birthday_problem#Approximations

# memoize_expire()           http://perldoc.perl.org/Memoize/Expire.html
# memoize_file_expire()
# memoize_limit_size() #lru
# memoize_file_limit_size()
# memoize_memcached         http://search.cpan.org/~dtrischuk/Memoize-Memcached-0.03/lib/Memoize/Memcached.pm
# hint on http://perl.jonallen.info/writing/articles/install-perl-modules-without-root

# sub mycrc32 {  #http://billauer.co.il/blog/2011/05/perl-crc32-crc-xs-module/  eller String::CRC32::crc32 som er 100 x raskere enn Digest::CRC::crc32
#  my ($input, $init_value, $polynomial) = @_;
#  $init_value = 0 unless (defined $init_value);
#  $polynomial = 0xedb88320 unless (defined $polynomial);
#  my @lookup_table;
#  for (my $i=0; $i<256; $i++) {
#    my $x = $i;
#    for (my $j=0; $j<8; $j++) {
#      if ($x & 1) {
#        $x = ($x >> 1) ^ $polynomial;
#      } else {
#        $x = $x >> 1;
#      }
#    }
#    push @lookup_table, $x;
#  }
#  my $crc = $init_value ^ 0xffffffff;
#  foreach my $x (unpack ('C*', $input)) {
#    $crc = (($crc >> 8) & 0xffffff) ^ $lookup_table[ ($crc ^ $x) & 0xff ];
#  }
#  $crc = $crc ^ 0xffffffff;
#  return $crc;
# }
#



=head1 HISTORY

Release history

 0.172 Dec 2015   Subs: curb, openstr, pwgen, sleepms, sleepnm, srlz, tms, username,
                  self_update, install_acme_command_tools
                  Commands: conv, due, freq, wipe, xcat (see "Commands")
 0.16  Feb 2015   bigr, curb, cpad, isnum, parta, parth, read_conf, resolve_equation,
                  roman2int, trim. Improved: conv (numbers, currency), range ("derivatives")
 0.15  Nov 2014   Improved doc
 0.14  Nov 2014   New subs, improved tests and doc
 0.13  Oct 2010   Non-linux test issue, resolve. improved: bloom filter, tests, doc
 0.12  Oct 2010   Improved tests, doc, bloom filter, random_gauss, bytes_readable
 0.11  Dec 2008   Improved doc
 0.10  Dec 2008

=head1 SEE ALSO

L

=head1 AUTHOR

Kjetil Skotheim, [e-mail]

=head1 COPYRIGHT

1995-2015, Kjetil Skotheim

=head1 LICENSE

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut