Acme-Tools
view release on metacpan or search on metacpan
MUR => 0.239306, #mauritius
MXN => 0.418798, #mexico peso
MYR => 1.998096, #malaysian ringgit
NPR => 0.075316, #nepal rupee
NZD => 5.745187, #new zealand dollar
OMR => 20.234592, #oman rial
PHP => 0.148869, #philippines peso
PKR => 0.070338, #pakistan rupee
PLN => 2.319848, #poland zloty
QAR => 2.137418, #qatar rial
RON => 2.070137, #romaina new nei
RUB => 0.137791, #russia rouble / rubel
SAR => 2.074720, #saudi arabia riyal
SEK => 0.976704, #swedish kroner
SGD => 5.931982, #singapore dollar
THB => 0.248282, #thailand baht
TRY => 2.076265, #turkish new lira
TTD => 1.150931, #trinidad/tobago dollar
TWD => 0.267321, #taiwan dollar
USD => 7.780201, #us dollar
'$' => 7.780201, #us doller, symbol
VEF => 0.778994, #venezuelan bolivares fuertes
XBT => 84864.0984477, #synonym for BTC
XRP => 8.96808208868, #ripple
ZAR => 0.667117, #south africa rand
},
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 dimension (unit type).\n" if @type<1;
croak join"\n",map"conv: $_",@err if @err;
my $type=$type[0];
conv_prepare_money() if $type eq 'money' and time() >= $conv_prepare_money_time + $Currency_rates_expire;
return conv_temperature(@_) if $type eq 'temperature';
return conv_numbers(@_) if $type eq 'numbers';
my $c=$conv{$type};
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)
B<Output:> 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<Input:>
* 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<Output:> Same as the C<unlink()> (remove file): 1 for success, 0 or false for failure.
See also: L<https://www.google.com/search?q=wipe+file>, L<http://www.dban.org/>
=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<stat($filename)> -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<perldoc -f stat>, C<perldoc -f chmod>, C<perldoc -f chown>, C<perldoc -f utime>
=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<mkdir()> except that C<makedir()> 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<dirB> if it does not already exists, to be able to create C<dirC> inside C<dirB>.
Returns true on success, otherwise false.
C<makedir()> 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<Input:> a filename (or a scalar ref to a string, see below)
B<Output:> 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<Digest::MD5>, which is a core perl-module since
version 5.?.? It does not slurp the files or spawn new processes.
If the input argument is a scalar ref then the MD5 of the string referenced is returned in hex.
=cut
sub md5sum {
Default ordering of files without C<-k n> or C<-k o> is the order they
are mentioned on the command line. For directory args the order might be
random: use C<< dir/* >> to avoid that (but then dot files are not included).
=cut
sub install_acme_command_tools {
my $dir=(grep -d$_, @_, '/usr/local/bin', '/usr/bin')[0];
for( qw( conv due xcat freq finddup ccmd trunc wipe rttop z2z 2gz 2gzip 2bz2 2bzip2 2xz resubst zsize) ){
unlink("$dir/$_");
writefile("$dir/$_", "#!$^X\nuse Acme::Tools;\nAcme::Tools::cmd_$_(\@ARGV);\n");
sys("/bin/chmod +x $dir/$_"); #hm umask
print "Wrote executable $dir/$_\n";
}
}
sub cmd_conv { print conv(@ARGV)."\n" }
our @Due_fake_stdin;
#TODO: output from tar tvf and ls and find -ls
sub cmd_due {
my %o;
my @argv=opts("zkKmhciMCAPate:lE:t",\%o,@_);
require File::Find;
no warnings 'uninitialized';
die"$0: -l not implemented yet\n" if $o{l}; #man du: default is not to count hardlinks more than once, with -l it does
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;
die"$0: -M, -C, -A can not be used together\n" if $o{M}+$o{C}+$o{A}>1;
my(%c,%b,$cnt,$bts,%xtime);
my $zext=$o{z}?'(\.(z|Z|gz|bz2|xz|rz|kr|lrz|rz))?':'';
$o{E}||=11;
my $r=qr/(\.[^\.\/]{1,$o{E}}$zext)$/i;
my $qrexcl=exists$o{e}?qr/$o{e}/:0;
#TODO: ought to work: tar cf - .|tar tvf -|due
my $x=$o{M}?9:$o{C}?10:$o{A}?8:9;
if(-p STDIN or @Due_fake_stdin){
die "due: can not combine STDIN and args\n" if @argv;
my $stdin=join"",map"$_\n",@Due_fake_stdin; #test
open(local *STDIN, '<', \$stdin) or die "ERR: $! $?\n" if $stdin;
my $rl=qr/(^| )\-[rwx\-sS]{9}\s+(?:\d )?(?:[\w\-]+(?:\/|\s+)[\w\-]+)\s+(\d+)\s+.*?([^\/]*\.[\w,\-]+)?$/;
my $MorP=$o{M}||$o{C}||$o{A}||$o{P}?"due: -M, -C, -A and -P not yet implemented for STDIN unless list of filenames only\n":0;
while(<STDIN>){
chomp;
next if /\/$/;
my($f,$sz,$xtime)=(/$rl/?($3,$2):-f$_?($_,(stat)[7,$x]):next);
# 1576142 240 -rw-r--r-- 1 root root 242153 april 4 2016 /opt/wine-staging/share/wine/wine.inf
my $ext=$f=~$r?$1:'';
$ext=lc($ext) if $o{i};
$cnt++; $c{$ext}++;
$bts+=$sz; $b{$ext}+=$sz;
defined $xtime and $xtime{$ext}.=",$xtime" or die $MorP if $MorP;
}
}
else { #hm DRY
@argv=('.') if !@argv;
File::Find::find({follow=>0, wanted =>
sub {
return if !-f$_;
return if $qrexcl and defined $File::Find::name and $File::Find::name=~$qrexcl;
my($sz,$xtime)=(stat($_))[7,$x];
my $ext=m/$r/?$1:'';
$ext=lc($ext) if $o{i};
$cnt++; $c{$ext}++;
$bts+=$sz; $b{$ext}+=$sz;
$xtime{$ext}.=",$xtime" if $o{M} || $o{C} || $o{A} || $o{P};
1;
} },@argv);
}
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 $perc=!$o{M}&&!$o{C}&&!$o{A}&&!$o{P}?sub{""}:
sub{
my @p=$o{P}?(10,50,90):(50);
my @m=@_>0 ? do {grep$_, split",", $xtime{$_[0]}}
: do {grep$_, map {split","} values %xtime};
my @r=percentile(\@p,@m);
@r=(min(@m),@r,max(@m)) if $o{M}||$o{C}||$o{A};
@r=map int($_), @r;
my $fmt=$o{t}?'YYYY/MM/DD-MM:MI:SS':'YYYY/MM/DD';
@r=map tms($_,$fmt), @r;
" ".join(" ",@r);
};
my $width=max( 10, grep $_, map length($_), @e );
@e=@e[-10..-1] if $o{t} and @e>10; #-t tail
printf("%-*s %8d $f %7.2f%%%s\n",$width,$_,$c{$_},&$s($b{$_}),100*$b{$_}/$bts,&$perc($_)) for @e;
printf("%-*s %8d $f %7.2f%%%s\n",$width,"Sum",$cnt,&$s($bts),100,&$perc());
}
sub cmd_resubst {
my %o;
my $zo="123456789e";
my @argv=opts("f:t:vno:gi$zo",\%o,@_);
if(exists$o{t}){ $o{t}=~s,\\,\$, } else { $o{t}='' }
my($i,$tc,$tbfr,$tbto)=(0,0,0,0);
for my $file (@argv){
my $zopt=join" ",map"-$_",grep$o{$_},split//,$zo;
my $oext=$o{o}?$o{o}:$file=~/\.(gz|bz2|xz)$/i?$1:'';
my $open_out_pre=$oext?"|".openstr_prog({qw/gz gzip bz2 bzip2 xz xz/}->{lc($oext)})." $zopt":'';
my $open_out="$open_out_pre > $file.tmp$$";
my $open_in=openstr($file);
# die srlz(\%o,'o','',1);
open my $I, $open_in or croak"ERR: open $open_in failed. $! $?\n";
open my $O, $open_out or croak"ERR: open $open_out failed. $! $?\n";
my $c=0;
my $mod=join"",grep$o{$_},qw(g i);
eval"while(<\$I>){ \$c+=s/\$o{f}/$o{t}/$mod;print \$O \$_ }";
$tc+=$c;
close($I);close($O);
chall($file,"$file.tmp$$") or croak"ERR: chall $file\n" if !$o{n};
my($bfr,$bto)=(-s$file,-s"$file.tmp$$");
unlink $file or croak"ERR: cant rm $file\n";
my $newfile=$o{o}?repl($file,qr/\.(gz|bz2|xz)$/i,".$oext"):$file;
rename("$file.tmp$$",$newfile) or croak"ERR: rename $file.tmp$$ -> $newfile failed\n";
if($o{v}){
my $pr=$bfr?100*$bto/$bfr:0;
printf "%*d/%d %*s %7d =>%8d b (%2d%%) %s\n",
length(0+@argv), ++$i, 0+@argv, -15, "$tc/$c", $bfr, $bto, $pr, $file;
$tbfr+=$bfr;
$tbto+=$bto;
}
}
if($o{v} and @argv>1){
printf "Replaces: %d Bytes before: %d After: %d Change: %.1f%%\n",
$tc, $tbfr, $tbto, $tbfr?100*($tbto-$tbfr)/$tbfr:0
}
$tc;
}
sub cmd_xcat {
for my $fn (@_){
my $os=openstr($fn);
open my $FH, $os or warn "xcat: cannot open $os ($!)\n" and next;
#binmode($FH);#hm?
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 {
cmd_finddup('-d',@_);
}
sub cmd_finddup {
# http://www.commandlinefu.com/commands/view/3555/find-duplicate-files-based-on-size-first-then-md5-hash
# die "todo: finddup not ready yet"
my %o;
my @argv=opts("ak:dhsnqv0P:FMRp",\%o,@_); $o{P}=1024*8 if!defined$o{P}; $o{k}='' if!defined$o{k};
croak"ERR: cannot combine -a with -d, -s or -h" if $o{a} and $o{d}||$o{s}||$o{h};
require File::Find;
@argv=map{
my @f;
if(-d$_){ File::Find::find({follow=>0,wanted=>sub{return if !-f$_;push@f,$File::Find::name;1}},$_) }
else { @f=($_) }
@f;
}@argv;
my %md5sum;
my $md5sum=sub{$md5sum{$_[0]}=md5sum($_[0]) if!defined$md5sum{$_[0]}}; #memoize
my $md5sum_1st_part=sub{
open my $fh, "<", $_[0] or die "ERR: Could not read $_[0]";
binmode($fh);
my $buf; read($fh,$buf,$o{P});
close($fh);
md5sum(\$buf);
};
my @checks=( #todo: stat()[0,1] (or[0,1,7]?) and diff filename => no need for md5, is hardlink! just linux?
sub{-s$_[0]},
sub{-s$_[0]<=$o{P}?md5sum($_[0]):&$md5sum_1st_part($_[0])},
sub{md5sum($_[0])}
);
pop @checks if $o{M}; #4tst
my $i=0;
my %s=map{($_=>++$i)}@argv; #sort
my %f=map{($_=>[$_])}@argv; #also weeds out dupl params
for my $c (@checks){
my @f=map @{$f{$_}}, sort keys %f;
if($o{p} and $c eq $checks[-1]){ #view progress for last check, todo: eta() is wacky here! everywhere?
my $sum=@f?sum(map -s$_,@f):0;
my($corg,$cnt,$cntmb,$mb)=($c,0,0,$sum/1e6);
$c=sub{
$cntmb+=(-s$_[0])/1e6;
my $eol=++$cnt==@f?"\n":"\r";
print STDERR sprintf("%d/%d files checked (%d%%), %d/%d MB (%d%%), ETA in %d sec $eol",
$cnt, 0+@f, 100*$cnt/@f, $cntmb, $mb, 100*$cntmb/$mb,
curb(nvl(eta($cnt,0+@f),time)-time(),0,1e7));
&$corg(@_)
};
}
my %n; push @{$n{&$c($_)}}, $_ for @f;
delete @n{grep@{$n{$_}}<2,keys%n};
%f=%n;
}
return %f if $o{F};
my@r=sort{$s{$$a[0]}<=>$s{$$b[0]}}values%f;
my $si={qw(o 9 n 9 O 8 N 8)}->{$o{k}}; #stat index: 9=mtime, 8=atime
my $sort=lc$o{k} eq 'o' ? sub{sprintf"%011d%9d", (stat($_[0]))[$si],$s{$_[0]}}
:lc$o{k} eq 'n' ? sub{sprintf"%011d%9d",1e11-(stat($_[0]))[$si],$s{$_[0]}}
: sub{sprintf "%9d", $s{$_[0]}};
@$_=map$$_[1],sort{$$a[0]cmp$$b[0]}map[&$sort($_),$_],@$_ for @r;
my %of; #dup of
for my $r (@r){
$of{$_}=$$r[0] for @$r[1..$#$r];
}
my $nl=$o{0}?"\x00":"\n";
my $print=sub{$o{q} or print $_[0]};
my $do=sub{ $o{v} && &$print("$_[0]$nl"); qx($_[0]) };
my $go=sub{ $o{n} ? &$print("$_[0]$nl") : &$do($_[0]) };
&$print(join$nl,map join("",map"$_$nl",@$_),@r) and return if $o{a};
@r=map@$_[1..$#$_],@r;
return @r if $o{R}; #hm
unlink@r if $o{d}||$o{s}||$o{h} and !$o{n}; #delete duplicates
map &$go(qq(rm "$_") ),@r if $o{d}&& $o{n}; #delete duplicates, dryrun
map &$go(qq(ln "$of{$_}" "$_")),@r if $o{h}; #replace duplicates with hardlink
map &$go(qq(ln -s "$of{$_}" "$_")),@r if $o{s}; #replace duplicates with symlink,
#todo: BUG! abc/def/file -> ghi/file should be abc/def/file -> ../../ghi/file
return if $o{q} or $o{n}; #quiet or dryrun
&$print("$_$nl") for @r;
}
#http://stackoverflow.com/questions/11900239/can-i-cache-the-output-of-a-command-on-linux-from-cli
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
#todo: wipe -n 4 filer* #virker ikke! tror det er args() eller opts() som ikke virker
sub cmd_wipe {
my %o;
my @argv=opts("n:k0123456789",\%o,@_);
die if 1<grep exists$o{$_},'n',0..9;
$o{$_} and $o{n}=$_ for 0..9;
wipe($_,$o{n},$o{k}) for @argv;
}
sub which { my $prog=shift; -x "$_/$prog" and return "$_/$prog" for split /:/, $ENV{PATH} }
sub cmd_2gz {cmd_z2z("-t","gz", @_)}
sub cmd_2gzip {cmd_z2z("-t","gz", @_)}
sub cmd_2bz2 {cmd_z2z("-t","bz2",@_)}
sub cmd_2bzip2 {cmd_z2z("-t","bz2",@_)}
sub cmd_2xz {cmd_z2z("-t","xz", @_)}
#todo: sub cmd_7z
#todo: .tgz same as .tar.gz (but not .tbz2/.txz)
sub cmd_z2z {
my %o;
my $pvopts="L:D:i:lIq";
my @argv=opts("pt:kvhon123456789es:$pvopts",\%o,@_);
my $t=repl(lc$o{t},qw/gzip gz bzip2 bz2/);
die "due: unknown compression type $o{t}, known are gz, bz2 and xz" if $t!~/^(gz|bz2|xz)$/;
$o{p}=1 if!defined$o{p} and grep$pvopts=~/$_/,keys%o;
delete $o{e} if $o{e} and $o{t} ne 'xz' and warn "-e available only for type xz\n";
my $sum=sum(map -s$_,@argv);
print "Converting ".@argv." files, total ".bytes_readable($sum)."\n" if $o{v} and @argv>1;
my $cat='cat';
if($o{p}){ if(which('pv')){ $cat='pv' } else { warn repl(<<"",qr/^\s+/) } }
due: pv for -p not found, install with sudo yum install pv, sudo apt-get install pv or similar
$o{$_} and $o{$_}=" " for qw(l q); #still true, but no cmd arg for:
$o{I} and $o{I}="-pterb";
exists$o{$_} and $cat=~s,pv,pv -$_ $o{$_}, for $pvopts=~/(\w)/g; #warn "cat: $cat\n";
my $sumnew=0;
my $start=time_fp();
my($i,$bsf)=(0,0);#bytes so far
$Eta{'z2z'}=[];eta('z2z',0,$sum);
#@argv=map$$_[1],sort{$$a[0]cmp$$b[0]}map{[$opt{
for(@argv){
my $new=$_; $new=~s/(\.(gz|bz2|xz))?$/.$t/i or die;
my $ext=defined($2)?lc($2):'';
my $same=/^$new$/; $new.=".tmp" if $same; die if $o{k} and $same;
next if !-e$_ and warn"$_ do not exists\n";
next if !-r$_ and warn"$_ is not readable\n";
next if -e$new and !$o{o} and warn"$new already exists, skipping (use -o to overwrite)\n";
my $unz={qw/gz gunzip bz2 bunzip2 xz unxz/}->{$ext}||'';
#todo: my $cntfile="/tmp/acme-tools-z2z-wc-c.$$";
#todo: my $cnt="tee >(wc -c>$cntfile)" if $ENV{SHELL}=~/bash/ and $o{v}; #hm dash vs bash
my $z= {qw/gz gzip bz2 bzip2 xz xz/}->{$t};
$z.=" -$_" for grep$o{$_},1..9,'e';
$z.=" -$_ $o{$_}" for grep exists$o{$_},'L';
my $cmd=qq($cat "$_"|$unz|$z>"$new");
#todo: "$cat $_|$unz|$cnt|$z>$new";
#cat /tmp/kontroll-linux.xz|unxz|tee >(wc -c>/tmp/p)|gzip|wc -c;cat /tmp/p
$cmd=~s,\|+,|,g; #print "cmd: $cmd\n";
sys($cmd);
chall($_,$new) or croak("$0 cannot chmod|chown|touch $new") if !$o{n};
my($szold,$sznew)=map{-s$_}($_,$new);
$bsf+=-s$_;
unlink $_ if !$o{k};
rename($new, replace($new,qr/.tmp$/)) or die if $same;
if($o{v}){
$sumnew+=$sznew;
my $pr=sprintf"%0.1f%%",$szold?100*$sznew/$szold:0;
#todo: my $szuncmp=-s$cntfile&&time()-(stat($cntfile))[9]<10 ? qx(cat $cntfile) : '';
#todo: $o{h} ? printf("%6.1f%% %9s => %9s => %9s %s\n", $pr,(map bytes_readable($_),$szold,$szuncmp,$sznew),$_)
#todo: : printf("%6.1f%% %11d b => %11d b => %11 b %s\n",$pr,$szold,$szuncmp,$sznew,$_)
my $str= $o{h}
? sprintf("%-7s %9s => %9s", $pr,(map bytes_readable($_),$szold,$sznew))
: sprintf("%-7s %11d b => %11d b", $pr,$szold,$sznew);
if(@argv>1){
$i++;
$str=$i<@argv
? " ETA:".sprintf("%-8s",sec_readable(eta('z2z',$bsf,$sum)-time_fp()))." $str"
: " TA: 0s $str"
if $sum>1e6;
$str="$i/".@argv." $str";
}
print "$str $new\n";
}
}
if($o{v} and @argv>1){
my $bytes=$o{h}?'':'bytes ';
my $str=
sprintf "%d files compressed in %.3f seconds from %s to %s $bytes (%s bytes) %.1f%% of original\n",
0+@argv,
time_fp()-$start,
(map{$o{h}?bytes_readable($_):$_}($sum,$sumnew,$sumnew-$sum)),
100*$sumnew/$sum;
$str=~s,\((\d),(+$1,;
print $str;
}
}
=head2 args
Parses command line options and arguments:
my %opt;
my @argv=Acme::Tools::args('i:nJ123',\%opt,@ARGV); #returns remaining command line elements after C<-o ptions> are parsed into C<%opt>.
Uses C<Getopt::Std::getopts()>. First arg names the different one char
options and an optional C<:> behind the letter or digit marks that the
switch takes an argument.
=cut
sub args {
my $switches=shift;
my $hashref=shift;
my $re_sw='^([a-z0-9]:?)+$';
croak "ERR: args: first arg $switches dont match $re_sw\n" if $switches !~ /$re_sw/i;
croak "ERR: second arg to args() not hashref\n" if ref($hashref) ne 'HASH';
local @ARGV=@_;
require Getopt::Std;
Getopt::Std::getopts($switches => $hashref);
(@ARGV);
}
sub opts {
my($def, $hashref, @a)=@_;
@a=@ARGV if @_<=2;
my %def=map{/(\w)(:?)/;($1=>$2?2:1)}$def=~/(\w:?)/g;
my $o1=join"",grep$def{$_}==1,sort keys%def;
my $o= join"", sort keys%def;
( run in 1.872 second using v1.01-cache-2.11-cpan-39bf76dae61 )