Acme-Tools
view release on metacpan or search on metacpan
=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</zipb64>.
Input:
First argument: A string made by L</zipb64>
Second argument: (optional) a dictionary string which where used in L</zipb64>.
Output: The original string (be it text or binary).
See L</zipb64>.
=cut
sub unzipb64 {
my($data,$dict)=@_;
require MIME::Base64;
unzipbin(MIME::Base64::decode_base64($data),$dict);
}
=head2 unzipbin
C<unzipbin()> does the same as L</unzip> except that C<unzipbin()>
wants a pure binary compressed string as input, not base64.
See L</unzipb64> 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<Input:> A string or reference to a string you want to compress. Text or binary.
B<Output:> The binary compressed representation of that input string.
C<gzip()> is really just a wrapper for C< Compress:Zlib::memGzip() > and uses the same
compression algorithm as the well known GNU program gzip found in most unix/linux/cygwin
distros. Except C<gzip()> does this in-memory. (Both using the C-library C<zlib>).
writefile( "file.gz", gzip("some string") );
=head2 gunzip
B<Input:> A binary compressed string or a reference to such a string. I.e. something returned from
C<gzip()> earlier or read from a C<< .gz >> file.
B<Output:> The original larger non-compressed string. Text or binary.
C<gunzip()> is a wrapper for Compress::Zlib::memGunzip()
print gunzip( gzip("some string") ); #some string
=head2 bzip2
Same as L</gzip> and L</gunzip> except with a different compression algorithm (compresses more but is slower). Wrapper for Compress::Bzip2::memBzip.
Compared to gzip/gunzip, bzip2 compression is much slower, bunzip2 decompression not so much.
See also L<Compress::Bzip2>, C<man Compress::Bzip2>, C<man bzip2>, C<man bunzip2>.
writefile( "file.bz2", bzip2("some string") );
print bunzip2( bzip2("some string") ); #some string
=head2 bunzip2
Decompressed something compressed by bzip2() or data from a C<.bz2> file. See L</bzip2>.
=cut
sub gzip { my $s=shift; eval"require Compress::Zlib" if !$INC{'Compress/Zlib.pm'}; croak "Compress::Zlib not found" if $@; Compress::Zlib::memGzip( ref($s)?$s:\$s ) }
sub gunzip { my $s=shift; eval"require Compress::Zlib" if !$INC{'Compress/Zlib.pm'}; croak "Compress::Zlib not found" if $@; Compress::Zlib::memGunzip( ref($s)?$s:\$s ) }
sub bzip2 { my $s=shift; eval"require Compress::Bzip2" if !$INC{'Compress/Bzip2.pm'}; croak "Compress::Bzip2 not found" if $@; Compress::Bzip2::memBzip( ref($s)?$s:\$s ) }
sub bunzip2 { my $s=shift; eval"require Compress::Bzip2" if !$INC{'Compress/Bzip2.pm'}; croak "Compress::Bzip2 not found" if $@; Compress::Bzip2::memBunzip( ref($s)?$s:\$s ) }
=head1 NET, WEB, CGI-STUFF
=head2 ipaddr
B<Input:> an IP-number
B<Output:> either an IP-address I<machine.sld.tld> 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<gethostbyaddr> internally.
C<ipaddr()> 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<HostnameLookups Off> in Apache C<httpd.conf> and then use I<ipaddr> afterwards if necessary.
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<readfile()>.
Automatic decompression:
my $txt = readfile('file.txt.gz'); #uses /bin/gunzip to decompress content
Extentions C<.gz>, C<.bz2> and C<.xz> are recognized for decompression. See also C<writefile()> and C<openstr()>.
=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<Input:>
Name of a directory.
B<Output:>
A list of all files in it, except of C<.> and C<..> (on linux/unix systems, all directories have a C<.> and C<..> directory).
The names of all types of files are returned: normal files, directories, symbolic links,
pipes, semaphores. That is every thing shown by C<ls -la> except C<.> and C<..>
C<readdirectory> do not recurce down into subdirectories (but see example below).
B<Example:>
my @files = readdirectory("/tmp");
B<Why readdirectory?>
Sometimes calling the built ins C<opendir>, C<readdir> and C<closedir> seems a tad tedious, since this:
my $dir="/usr/bin";
opendir(D,$dir);
my @files=map "$dir/$_", grep {!/^\.\.?$/} readdir(D);
closedir(D);
Is the same as this:
my @files=readdirectory("/usr/bin");
See also: L<File::Find>
B<Why not readdirectory?>
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<Example:>
How to get all files in the C</tmp> directory including all subdirectories below of any depth:
my @files=("/tmp");
map {-d $_ and unshift @files,$_ or push @files,$_} readdirectory(shift(@files)) while -d $files[0];
...or to avoid symlinks and only get real files:
map {-d and !-l and unshift @files,$_ or -f and !-l and push @files,$_} readdirectory(shift(@files)) while -d $files[0];
=cut
sub readdirectory {
my $dir=shift;
opendir(my $D,$dir);
my @filer=map "$dir/$_", grep {!/^\.\.?$/} readdir($D);
closedir($D);
return @filer;
}
=head2 basename
The basename and dirname functions behaves like the *nix shell commands with the same names.
B<Input:> One or two arguments: Filename and an optional suffix
B<Output:> 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<Input:> A filename including path
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.
B<Output:> a date or clock string on the wanted form.
B<Examples:>
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
B<Third argument:> (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</tidstrk> og L</tidstr>
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.'){
( run in 1.626 second using v1.01-cache-2.11-cpan-df04353d9ac )