#!/usr/bin/perl -w
use strict;
package Futils;
# use Handy::Dandy;
@Futils::ISA = qw( Handy::Dandy Exporter );
@Futils::EXPORT_OK= qw( can_flock newline SL n );
$Futils::VERSION = 2.06; # 8/6/2002, 5:40:21 PM
$Futils::NAME = __PACKAGE__;
$Futils::started = time();
=pod
AUTHOR
-Tommy Butler, professional contractor and open source proponent
Atrixnet™, for Internet Business Software®
http://atrixnet.com
6711 Forest Park Dr
Dallas, TX
76001
COPYRIGHT
Copyright Tommy Butler. All rights reserved
LISCENCE
This software is free, and you may use and distribute it under the
GNU GPL liscence. If you modify the code for your own purposes
please acknowledge its original author.
BUGS
Please report any of the following to me
- bugs
- interface inconsistencies
- suggestions
- comments
- complaints
- smart remarks
=cut
BEGIN {
require Config;
# start by figuring out the os we're running under. Some systems support
# the $^O variable. If not available then require() the Config library
unless ($Futils::OS = $^O) {
# I am so sick of the freakin 'used once' warning! Hence...
$Futils::OS = eval(q[$Config::Config{'osname'}]);
}
if ($Futils::OS=~/darwin/i) {
$Futils::OS = 'UNIX';
}
elsif ($Futils::OS=~/cygwin/i) {
$Futils::OS = 'CYGWIN';
}
elsif ($Futils::OS=~/Win/i) {
$Futils::OS = 'WINDOWS';
}
elsif ($Futils::OS=~/vms/i) {
$Futils::OS = 'VMS';
}
elsif ($Futils::OS=~/bsdos/i) {
$Futils::OS = 'UNIX';
}
elsif ($Futils::OS=~/dos/i) {
$Futils::OS = 'DOS';
}
elsif ($Futils::OS=~/^MacOS$/i) {
$Futils::OS = 'MACINTOSH';
}
elsif ($Futils::OS=~/epoc/) {
$Futils::OS = 'EPOC';
}
elsif ($Futils::OS=~/os2/i) {
$Futils::OS = 'OS2';
}
else {
$Futils::OS = 'UNIX';
}
# Some OS logic. Binary mode enabled on DOS, NT and VMS
$Futils::needs_binmode = 0;
$Futils::needs_binmode = $Futils::OS=~/^(WINDOWS|DOS|OS2|MSWin)/o;
$Futils::EBCDIC = qq[\t] ne qq[\011];
if ($Futils::OS eq 'VMS') { $Futils::n = eval(q[chr(10)]) }
elsif ($Futils::EBCDIC) { $Futils::n = eval(q[chr(13).chr(10)]) }
else { $Futils::n = qq[\015\012] }
# The path separator is a slash, backslash or semicolon, depending
# on the paltform.
$Futils::SL = {};
$Futils::SL =
{
'DOS' => '\\',
'EPOC' => '/',
'MACINTOSH' => ':',
'OS2' => '\\',
'UNIX' => '/',
'CYGWIN' => '/',
'VMS' => '/',
'WINDOWS' => '\\',
}->{$Futils::OS};
# When all else fails...
$Futils::SL ||= '/';
# set readlimit to a default of 10 megabytes
$Futils::readlimit = 10000000;
# maximum allowed directory depth for a recursive call to list_dir
$Futils::maxdepth = 500;
# a global recursion iterator
$Futils::recursed = 0;
# trail-ing directory separator
$Futils::trailer = qr/(?:$Futils::SL$)|(?:\/$)|(?:\\$)|(?:\:$)/;
# directory split
$Futils::dirsplit = quotemeta($Futils::SL);
$Futils::dirsplit = qr/$Futils::dirsplit|\\|\/|\:/;
# allow empty writes
$Futils::empty_writes= 0;
=pod
OPTIONS ON I/O RACE CONDITION POLICY
set $Futils::onflockfail to any of the following strings:
ex- @Futils::onflockfail = qw( wait fail );
--fatal fails with stack trace
--fail same as above
--warn warns() about the error with a stack trace
--ignore ignores the failure to get an exclusive lock
--undef returns undef
--0 returns 0
* --wait waits to try getting an exclusive lock
* --block same as above
* used in tandem with another option.
you must specify another option to
fall back on if blocking should fail.
otherwise Futils will throw a fatal
error and dump a stack trace before
exiting the process with a 0 status
=cut
@Futils::onflockfail = qw( --block --fail );
# use file locking
$Futils::use_flock = 1;
# characters not allowed in filenames (sorry, no spaces)
$Futils::illegal_filename_chrs =
qr/
(?sx)
$Futils::SL|
\\|
\/|
\:|
\ |
\||
\*|
\?|
\"|
\<|
\>|
\t|
\n|
\r
/;
$Futils::canhackit = 0;
$Futils::canhackit = 1 unless ($] < 5.006001);
{
# can your perl flock()
$Futils::defineflock =
$Config::Config{'d_flock'}
||
$Config::Config{'d_lockf'}
||
$Config::Config{'d_fcntl_can_lock'}
||0;
$Futils::hasflock = 1 if (eval(<<__canflock__));
flock(STDOUT, Fcntl::LOCK_EX() | Fcntl::LOCK_NB());
flock(STDOUT, Fcntl::LOCK_UN());
__canflock__
$Futils::hasflock = 1 if (!$@);
$Futils::hasflock||=0; $Futils::defineflock||=0;
}
use Fcntl qw( ); # keep your dad-blasted crap in your own namespace!
use vars qw( $ebl $ebr $n ); $ebl = '»'; $ebr = '«'; $n = $Futils::n;
($ebl,$ebr) = ('~~>','<~~') if ($Futils::OS eq 'WINDOWS')
} # end BEGIN-time loaded constants
$Futils::modes->{'popen'} =
{
'write' => '>',
'trunc' => '>',
'append' => '>>',
'read' => '<',
};
$Futils::modes->{'sysopen'} =
{
'read' => 'Fcntl::O_RDONLY()',
'write' => 'Fcntl::O_WRONLY() | Fcntl::O_CREAT()',
'append' => 'Fcntl::O_WRONLY() | Fcntl::O_APPEND() | Fcntl::O_CREAT()',
'trunc' => 'Fcntl::O_WRONLY() | Fcntl::O_CREAT() | Fcntl::O_TRUNC()',
};
# use exception handler library
# use expt_handler;
# --------------------------------------------------------
# Constructor
# --------------------------------------------------------
sub new {
my($class) = shift(@_); $class = __PACKAGE__; # yeah, yeah --no hacking ;O)
my($this) = {};
# bless object ref into the class' namespace
bless($this, $class);
# get input in hash context, no warnings
my($opts) = $this->shave_opts(\@_);
my($in) = $this->coerce_array(@_);
$Futils::use_flock = 0 if ($opts->{'--no-flock'});
# set up class attributes
$this->{'name'} = $Futils::NAME;
$this->{'n'} = $Futils::n;
$this->{'SL'} = $Futils::SL;
$this->{'opts'} = $opts;
$this->{'expt'} = expt_handler->new();
$Futils::readlimit = $in->{'readlimit'} if (defined($in->{'readlimit'}));
$this->{'hasflock'} = $Futils::hasflock;
$this->{'object'} = $this;
# return object reference
return($this);
}
# Futils::------------------------------------------------
# newline() can_flock() n() SL()
# --------------------------------------------------------
sub can_flock { $Futils::hasflock }
sub newline { $Futils::n }
sub SL { $Futils::SL }
sub n { $Futils::n }
# --------------------------------------------------------
# Futils::list_dir()
# --------------------------------------------------------
sub list_dir {
my($this) = shift(@_);
my($opts) = $this->shave_opts(\@_);
my($dir) = shift(@_)||'.';
my($path) = $dir;
my(@files) = ();
my(@dirs) = ();
my(@items) = ();
my($r) = 0;
# if the call to this method didn't include a directory name to open,
# then complain about it
$this->
throw
(
'meth' => 'list_dir',
'missing' => 'a directory name',
'error' => 'no input',
)
unless (length($dir) > 0);
# if the call to this method included a non-existant directory then
# complain about it
$this->
throw
(
'filename' => $dir,
'error' => 'no such file',
)
unless (-e $dir);
if ($opts->{'--recursing'}) { ++$Futils::recursed }
else { $Futils::recursed = 0 }
if ($Futils::recursed >= $Futils::maxdepth) {
$this->{'expt'}->fail(<<__rbail__);
recursion limit reached. Maximum recursive directory listings is set to
$Futils::maxdepth. Try setting \$Futils::maxdepth to a higher number
before calling list_dir() with option '--follow' or '--recurse'
This operation aborted.
__rbail__
}
$r = 1
if
(
$opts->{'--follow'}
||
$opts->{'--recurse'}
);
# whack off any trailing directory separator
unless (length($dir) == 1)
{ $dir =~ s/$Futils::trailer//o; $path =~ s/$Futils::trailer//o; }
# can't open a directory if the argument isn't a diretory file type
$this->
throw
(
'filename' => $dir,
'error' => 'called opendir on a file',
)
unless (-d $dir);
# localize filehandle that we're going to be using in this method
local(*DIR);
# open the directory for reading or fail with a diagnostic error message
# if our attempt to open the directory was unsuccessful
opendir(DIR, $dir)
or
$this->
throw
(
'dir' => $dir,
'error' => 'bad opendir',
'exception' => $!,
);
# read from beginning of the directory (doesn't seem necessary on any
# platforms I've run code on, but just in case...)
rewinddir(DIR);
# assign the contents of the directory to this lexically scoped array
# variable(memory for *that* variable will be freed when execution
# leaves this method / sub
if ($opts->{'--count-only'}) {
my($i) = 0; my($o) = '';
while ($o = readdir(DIR)) { ++$i unless (($o eq '.')||($o eq '..')) }
return($i);
}
@files = readdir(DIR);
# close the directory or send out a system warning with any diagnostics
# about the error. if all else fails, Perl will close the directory
# for us when the top-level process has finished execution
closedir(DIR)
or
$this->
throw
(
'dir' => $dir,
'error' => 'close dir',
'exception' => $!,
);
if ($opts->{'--no-fsdots'}) {
my(@shadow) = @files;
@files = ();
while (@shadow) {
my($f) = shift(@shadow);
push(@files,$f)
unless
(
$this->strip_path($f) eq '.'
or
$this->strip_path($f) eq '..'
);
}
}
foreach (@files) {
my($i) = 0;
my($listing) =
($opts->{'--with-paths'} or ($r==1))
? $path.$Futils::SL.$_
: $_;
if (-d $path.$Futils::SL.$_) {
push(@dirs, $listing);
}
else {
push(@items, $listing);
}
}
if (($r) and (not $opts->{'--override-follow'})) {
my(@shadow) = @dirs;
@dirs = ();
while (@shadow) {
my($f) = shift(@shadow);
push(@dirs,$f)
unless
(
$this->strip_path($f) eq '.'
or
$this->strip_path($f) eq '..'
);
}
foreach (@dirs) {
my(@lsts) =
$this->
list_dir
(
$_,
'--with-paths',
'--dirs-as-ref',
'--files-as-ref',
'--recursing',
'--no-fsdots',
);
push(@dirs,@{$lsts[0]});
push(@items,@{$lsts[1]});
}
}
if ($opts->{'--sl-after-dirs'}) {
@dirs = $this->dropdots(@dirs,'--save-dots');
my($dots) = shift(@dirs);
@dirs = map ( ($_.=$Futils::SL), @dirs );
@dirs = (@{$dots},@dirs);
}
my($reta) = [sort(@dirs)];
my($retb) = [sort(@items)];
$reta=[$reta]
if
(
$opts->{'--dirs-as-ref'}
||
$opts->{'--as-ref'}
);
$retb=[$retb]
if
(
$opts->{'--files-as-ref'}
||
$opts->{'--as-ref'}
);
return(@$reta) if ($opts->{'--dirs-only'});
return(@$retb) if ($opts->{'--files-only'});
return(@$reta,@$retb);
}
# --------------------------------------------------------
# Futils::list_dir_a()
# --------------------------------------------------------
sub list_dir_a {
my($this) = shift(@_);
my($path) = $_[0];
my(@files) = $this->list_dir(@_);
my($SL) = $Futils::SL;
foreach (@files) {
my($file) = {};
$file->{'name'} = $_;
if (-d $path.$SL.$_) {
unless
(
$file->{'name'} eq '..'
or
$file->{'name'} eq '.'
) {
$file->{'name'} = $file->{'name'}.$SL;
}
}
$file->{'absname'} = $path.$SL.$_;
$file->{'size'} = $this->fsize( $path.$SL.$_ );
$file->{'created'} = $this->created( $path.$SL.$_ );
$file->{'last_mod'} = $this->last_mod( $path.$SL.$_ );
$file->{'last_access'} = $this->last_access( $path.$SL.$_ );
$_ = $file;
}
return(@files);
}
# --------------------------------------------------------
# Futils::dropdots()
# --------------------------------------------------------
sub dropdots {
my($this) = shift(@_);
my(@out) = ();
my($opts) = $this->shave_opts(\@_);
my(@shadow) = @_;
my(@dots) = ();
my($gottadot) = 0;
while (@shadow) {
if ($gottadot == 2){ push(@out,@shadow) and last }
my($thing) = shift(@shadow);
if ($thing eq '.') {++$gottadot;push(@dots,$thing);next}
if ($thing eq '..') {++$gottadot;push(@dots,$thing);next}
push(@out,$thing);
}
return([@dots],@out) if ($opts->{'--save-dots'});
return(@out);
}
# --------------------------------------------------------
# Futils::list_dir_wpaths()
# --------------------------------------------------------
sub list_dir_wpaths {
my($this) = shift(@_);
my($path) = $_[0]||'';
my(@files) = $this->list_dir(@_);
foreach (@files) {
$_ = $path.$Futils::SL.$_;
}
return(@files);
}
# --------------------------------------------------------
# Futils::print_dir()
# --------------------------------------------------------
sub print_dir {
my($this) = shift(@_);
my($dir) = shift(@_)||'';
my($opts) = $this->shave_opts(\@_);
my($cls) = 75;
my($cap) = q[+] . (q[-] x $cls) . q[+];
my($toe) = $cap;
my(@f) = ();
my($msg) = '';
my($fdir) = '';
$msg = qq[Directory listing for $dir];
$msg .= '...' if (length($msg) > 70);
$msg = sprintf(' % 0.70s%s', $msg);
# get list of files from Futils::list_dir()
@f = $this->list_dir($dir,@{[values(%$opts)]});
{
# handle 'no-fancy' option
if ($opts->{'--no-fancy'} or $opts->{'--raw'}) {
# make a plain list of the directory
foreach (@f) {$fdir .= $_ . $n}
if (scalar(@f) == 0) {$fdir = 'This directory contains no items.'}
return
(
($n x 2)
. $fdir
. ($n x 2)
)
if ($opts->{'--raw'});
return
(
($n x 2)
. ('-' x 75)
. $n . $msg . $n
. ('-' x 75)
. ($n x 2)
. $fdir
. ($n x 2)
);
}
}
# make a pretty, formatted table of the directory listings
foreach (@f) {
$fdir .= sprintf('| %s',$_) . (' 'x(int(($cls-1)-length($_)))) . $n
}
$cap .=
sprintf(qq[$n| %s], $msg)
. ' ' x (int(($cls - 1) - length($msg)))
. $n
. $cap;
$fdir = join($n, $cap, $fdir) . $toe;
return(qq[$n$fdir$n$n]);
}
# --------------------------------------------------------
# Futils::load_dir()
# --------------------------------------------------------
sub load_dir {
my($this) = shift(@_);
my($dir) = shift(@_)||'';
my($opts) = $this->shave_opts(\@_);
my(@files) = ();
my($dir_hash) = {};
my($dir_list) = [];
# if the call to this method didn't include a directory name to open,
# then complain about it
$this->
throw
(
'meth' => 'load_dir',
'missing' => 'a directory name',
'error' => 'no input',
)
unless (length($dir) > 0);
# get list of files from Futils::list_dir()
@files = $this->list_dir($dir,'--files-only');
# map the content of each file into a hash key-value element where the
# key name for each file is the name of the file
if (!$opts->{'--as-list'} and !$opts->{'--as-listref'}) {
foreach (@files) {
$dir_hash->{ $_ } = $this->load_file( $dir.$Futils::SL.$_ );
}
return($dir_hash);
}
else {
foreach (@files) {
push
(
@{$dir_list},
$this->load_file( $dir.$Futils::SL.$_ )
);
}
return($dir_list) if ($opts->{'--as-listref'});
return(@{$dir_list});
}
# return a reference to the hash containing all the filenames and contents
return($dir_hash);
}
# --------------------------------------------------------
# Futils::file_type()
# --------------------------------------------------------
sub file_type {
my($this) = shift(@_);
my($filename) = shift(@_)||'';
my($ret) = '';
return(q[$filename does not exist. No such file or directory])
if
(not $this->fexists($filename));
$ret .= 'plain' if (-f $filename);
$ret .= 'text' if (-T $filename);
$ret .= 'binary' if (-B $filename);
$ret .= 'directory' if (-d $filename);
$ret .= 'symlink' if (-l $filename);
$ret .= 'pipe' if (-p $filename);
$ret .= 'socket' if (-S $filename);
$ret .= 'block' if (-b $filename);
$ret .= 'character' if (-c $filename);
$ret .= 'tty' if (-t $filename);
return($ret || 'file type cannot be determined');
}
# --------------------------------------------------------
# Futils::make_dir()
# --------------------------------------------------------
sub make_dir {
my($this,$dir,$bitmask) = @_;
# if the call to this method didn't include a directory name to create,
# then complain about it
$this->
throw
(
'meth' => 'make_dir',
'missing' => 'a directory name',
'error' => 'no input',
)
unless (length($dir) > 0);
# if prospective directory name contains 2+ dir separators in sequence then
# this is a syntax error we need to whine about
$this->
throw
(
'error' => 'bad chars',
'string' => $dir,
'purpose' => 'the name of a directory',
)
if ($dir =~ /(?o)$Futils::dirsplit{2,}/);
$bitmask ||= 0777;
if (length($bitmask) == 3) {$bitmask = '0'.$bitmask}
$dir =~ s/\\$|\/$//o;
my($split) = quotemeta($Futils::SL);
my(@dirs_in_path) = split(/$split/o,$dir);
my(@substitute) = @dirs_in_path;
foreach (@dirs_in_path) {
# if prospective directory name contains illegal chars then complain
$this->
throw
(
'error' => 'bad chars',
'string' => $_,
'purpose' => 'the name of a directory',
)
if ($this->isbad($_))
}
my($depth) = 0;
foreach (@substitute) {
++$depth;
last if ($depth == scalar(@dirs_in_path));
$dirs_in_path[$depth] ||= '.';
$dirs_in_path[$depth] =
join
(
$Futils::SL,
@dirs_in_path[($depth-1)..$depth]
);
}
my($i) = 0;
foreach (@dirs_in_path) {
my($dir) = $_;
my($up) = $dirs_in_path[$i-1] if ($i > 0);
++$i;
unless ($this->fexists($dir) or -f ($dir)) {
# it's good to know beforehand whether or not we have permission to
# create dirs here, which allows us to handle such an exception
# before it handles us.
$this->
throw
(
'filename' => $dir,
'dirname' => $up.$Futils::SL,
'error' => 'cant dcreate',
)
unless ($this->can_write($up));
mkdir($dir, $bitmask)
or
$this->
throw
(
'error' => 'bad make_dir',
'exception' => $!,
'dir' => $dir,
'bitmask' => $bitmask,
);
}
}
return($dir);
}
# --------------------------------------------------------
# Futils::fexists()
# --------------------------------------------------------
sub fexists {
my($this) = shift(@_);
my($filename) = shift(@_)||'';
# if the file doesn't exist, send back a zero value
return(-e $filename);
}
# --------------------------------------------------------
# Futils::fsize()
# --------------------------------------------------------
sub fsize {
my($this) = shift(@_);
my($filename) = shift(@_)||'';
# if the file doesn't exist, send back an error
$this->
throw
(
'filename' => $filename,
'error' => 'no such file',
)
if (not (-e $filename));
# return the size of $filename
return(-s $filename);
}
# --------------------------------------------------------
# Futils::created()
# --------------------------------------------------------
sub created {
my($this,$filename,$format) = @_;
# if the file doesn't exist, send back an error
$this->
throw
(
'filename' => $filename,
'error' => 'no such file',
)
if (not (-e $filename));
# return the last modified time of $filename
my($r) = $Futils::started - ((-M $filename) * 60 * 60 * 24);
return($this->stamp($r,$format)) if (defined($format));
return($r);
}
# --------------------------------------------------------
# Futils::last_mod()
# --------------------------------------------------------
sub last_mod {
my($this,$filename,$format) = @_;
# if the file doesn't exist, send back an error
$this->
throw
(
'filename' => $filename,
'error' => 'no such file',
)
if (not (-e $filename));
# return the last modified time of $filename
my($r) = $Futils::started - ((-C $filename) * 60 * 60 * 24);
return($this->stamp($r,$format)) if (defined($format));
return($r);
}
# --------------------------------------------------------
# Futils::last_access()
# --------------------------------------------------------
sub last_access {
my($this,$filename,$format) = @_;
# if the file doesn't exist, send back an error
$this->
throw
(
'filename' => $filename,
'error' => 'no such file',
)
if (not (-e $filename));
# return the last accessed time of $filename
my($r) = $Futils::started - ((-A $filename) * 60 * 60 * 24);
return($this->stamp($r,$format)) if (defined($format));
return($r);
}
# --------------------------------------------------------
# Futils::can_read() Futils::can_write()
# --------------------------------------------------------
sub can_read { -r $_[1] }
sub can_write { -w $_[1] }
# --------------------------------------------------------
# Futils::line_count()
# --------------------------------------------------------
sub line_count {
my($this,$filename) = @_;
my($buffer) = '';
my($lines) = 0;
my($cmd) = '<'.$filename;
local(*LINES);
open(LINES, $filename)
or
$this->
throw
(
'error' => 'bad open',
'filename' => $filename,
'mode' => 'read',
'exception' => $!,
'cmd' => $cmd,
);
while (sysread(LINES, $buffer, 4096)) {
$lines += ($buffer =~ tr/\n//);
$buffer = '';
}
close(LINES);
return($lines);
}
# --------------------------------------------------------
# Futils::load_file()
# --------------------------------------------------------
sub load_file {
my($this) = shift(@_);
my($opts) = $this->shave_opts(\@_);
my($in) = $this->coerce_array(@_);
my(@dirs) = ();
my($blocksize) = 1024; # 1.24 kb
my($FH_passed) = 0;
my($FH) = undef;
my($filename) = '';
my($path) = '';
my($content) = '';
my($FHstatus) = '';
my($mode) = 'read';
if (scalar(@_) == 1) {
$filename = shift(@_)||'';
# determine existance of the file path, make directory(ies) for the
# path if the full directory path doesn't exist
@dirs = split(/$Futils::dirsplit/, $filename);
if (scalar(@dirs) > 0) {
$filename = pop(@dirs);
$path = join($Futils::SL, @dirs);
}
if (length($path) > 0) {
$path = '.'.$Futils::SL.$path
if
($path !~ /(?:^\/)|(?:^\w\:)/o);
}
else {
$path = '.';
}
$this->
throw
(
'meth' => 'load_file',
'missing' => 'a file name or file handle reference',
'error' => 'no input',
)
if (length($path . $Futils::SL . $filename) == 0);
}
else {
$FH = $in->{'FH'} || '';
$FHstatus = $in->{'FH_status'} || '';
# did we get a filehandle?
if (length($FH) > 0) {
$FH_passed = 1;
}
else {
$this->
throw
(
'meth' => 'load_file',
'missing' => 'a file name or file handle reference',
'error' => 'no input',
);
}
}
if ($FH_passed) {
my($buffer) = 0;
my($bytes_read) = 0;
while (<$FH>) {
if ($buffer < $Futils::readlimit) {
$bytes_read = read( $FH, $content, $blocksize, );
$buffer += $bytes_read;
}
else {
$this->
throw
(
'filename' => '<FH>',
'size' => qq[[truncated at $bytes_read]],
'error' => 'readlimit exceeded',
);
}
}
# return an array of all lines in the file if the call to this method/
# subroutine asked for an array eg- my(@file) = load_file('file');
# otherwise, return a scalar value containing all of the file's content
return(split(/$this->{'n'}|\r|\n/o,$content)) if $opts->{'--as-list'};
return($content);
}
# if the file doesn't exist, send back an error
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'error' => 'no such file',
)
if (not (-e $path . $Futils::SL . $filename));
# it's good to know beforehand whether or not we have permission to open
# and read from this file allowing us to handle such an exception before
# it handles us.
# --> first check the readability of the file's housing dir
$this->
throw
(
'filename' => $path . $Futils::SL.$filename,
'dirname' => $path . $Futils::SL,
'error' => 'cant dread',
)
unless ($this->can_read($path . $Futils::SL));
# --> now check the readability of the file itself
$this->
throw
(
'filename' => $path . $Futils::SL.$filename,
'dirname' => $path . $Futils::SL,
'error' => 'cant fread',
)
unless ($this->can_read($path . $Futils::SL . $filename));
# if the file is a directory it will not be opened
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'error' => 'called open on a dir',
)
if
(-d $path . $Futils::SL . $filename);
$this->{'expt'}->fail( qq[
$this->{'name'} can't open " $filename " for reading because
it is a a block special file.] )
if (-b $path . $Futils::SL . $filename);
my($fsize) = $this->fsize($path . $Futils::SL . $filename);
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'size' => $fsize,
'error' => 'readlimit exceeded',
)
if
($fsize > $Futils::readlimit);
# we need a unique filehandle
$FH = int(rand(time)) . $$;
$FH = eval('*' . 'LOAD_FILE' . $FH);
# localize the global output record separator so we can slurp it all
# in one quick read. We fail if the filesize exceeds our limit.
local($/,*LOAD_FILE);
# open the file for reading (note the '<' syntax there) or fail with a
# error message if our attempt to open the file was unsuccessful
my($cmd) = '<' . $path . $Futils::SL . $filename;
# lock file before I/O when possible
if ($$opts{'--no-lock'} || $$this{'opts'}{'--no-lock'}) {
# if you use the '--no-lock' option you are probably stupid
open(LOAD_FILE, $cmd)
or
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'mode' => $mode,
'error' => 'bad open',
'exception' => $!,
'cmd' => $cmd,
);
}
else {
open(LOAD_FILE, $cmd)
or
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'mode' => $mode,
'error' => 'bad open',
'exception' => $!,
'cmd' => $cmd,
);
$this->seize($path . $Futils::SL . $filename, *LOAD_FILE);
}
# call binmode on binary files for portability accross platforms such
# as MS flavor OS family
CORE::binmode(LOAD_FILE) if (-B $path . $Futils::SL . $filename);
# assign the content of the file to this lexically scoped scalar variable
# (memory for *that* variable will be freed when execution leaves this
# method / sub
$content = <LOAD_FILE>;
if ($$opts{'--no-lock'} || $$this{'opts'}{'--no-lock'}) {
# if execution gets here, you used the '--no-lock' option, and you
# are probably stupid
close(LOAD_FILE)
or
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'mode' => $mode,
'error' => 'bad close',
'exception' => $!,
);
}
else {
# release shadow-ed locks on the file
$this->release(*LOAD_FILE);
close(LOAD_FILE)
or
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'mode' => $mode,
'error' => 'bad close',
'exception' => $!,
);
}
# return an array of all lines in the file if the call to this method/
# subroutine asked for an array eg- my(@file) = load_file('file');
# otherwise, return a scalar value containing all of the file's content
return(split(/$this->{'n'}|\r|\n/o,$content)) if $opts->{'--as-list'};
return($content);
}
# --------------------------------------------------------
# Futils::open_to_FH()
# --------------------------------------------------------
sub open_to_FH {
my($this) = shift(@_);
my($opts) = $this->shave_opts(\@_);
my($in) = $this->coerce_array(@_);
my($filename) = $in->{'file'};
my($mode) = $in->{'mode'} || 'write';
my(@dirs) = ();
my($path) = '';
my($cmd) = '';
$filename ||= $$in{'filename'};
$filename ||= '';
$path = $filename;
# if the call to this method didn't include a filename to which the caller
# wants us to write, then complain about it
$this->
throw
(
'meth' => 'open_to_FH',
'missing' => 'a file name to create, read, write, or append',
'error' => 'no input',
)
unless (length($filename) > 0);
# if prospective directory name contains 2+ dir separators in sequence then
# this is a syntax error we need to whine about
$this->
throw
(
'error' => 'bad chars',
'string' => $filename,
'purpose' => 'the name of a file or directory',
)
if ($filename =~ /(?o)$Futils::dirsplit{2,}/);
# determine existance of the file path, make directory(ies) for the
# path if the full directory path doesn't exist
@dirs = split(/$Futils::dirsplit/, $filename);
# if file name has illegal chars then complain
foreach (@dirs) {
$this->
throw
(
'error' => 'bad chars',
'string' => $_,
'purpose' => 'the name of a file or directory',
)
if ($this->isbad($_));
}
if (scalar(@dirs) > 0) {
$filename = pop(@dirs);
$path = join($Futils::SL, @dirs);
}
if (length($path) > 0) {
$path = '.' . $Futils::SL . $path
if
($path !~ /(?:^\/)|(?:^\w\:)/o);
}
else {
$path = '.';
}
if (not $this->fexists($path)) {
$this->make_dir($path,0644);
}
# determine whether the caller wants to over-write old data in the file
# if it already exists, create a fresh new file from the content provided,
# or just append the content onto the end of an existing file
if ($mode eq 'write') {
$cmd = '>' . $path . $Futils::SL . $filename;
# While we're here...
# it's good to know beforehand whether or not we have permission to
# write/append to this file allowing us to handle such an exception
# before it handles us.
if (-e $path . $Futils::SL . $filename) {
# --> now check the writability of the file itself
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'dirname' => $path . $Futils::SL,
'error' => 'cant fwrite',
)
unless ($this->can_write($path.$Futils::SL.$filename));
}
else {
# --> if file doesn't exist, the error is one of creation
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'dirname' => $path . $Futils::SL,
'error' => 'cant fcreate',
)
unless ($this->can_write($path . $Futils::SL));
}
}
elsif ($mode eq 'append') {
$cmd = '>>' . $path . $Futils::SL . $filename;
}
elsif ($mode eq 'read') {
# it's good to know beforehand whether or not we have permission to open
# and read from this file allowing us to handle such an exception before
# it handles us.
# --> first check the readability of the file's housing dir
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'dirname' => $path . $Futils::SL,
'error' => 'cant dread',
)
unless ($this->can_read($path.$Futils::SL));
# --> now check the readability of the file itself
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'dirname' => $path . $Futils::SL,
'error' => 'cant fread',
)
unless ($this->can_read($path.$Futils::SL.$filename));
$cmd = '<' . $path . $Futils::SL . $filename;
}
# we need a unique filehandle
my($FH) = int(rand(time())).$$;
$FH = eval('*'.'OPEN_TO_FH'.$FH);
# lock file before I/O when possible
if ($$opts{'--no-lock'} || $$this{'opts'}{'--no-lock'}) {
# if you use the '--no-lock' option you are probably stupid
open($FH, $cmd)
or
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'mode' => $mode,
'error' => 'bad open',
'exception' => $!,
'cmd' => $cmd,
);
# return file handle reference to the caller
return($FH);
}
else {
open($FH, $cmd)
or
$this->
throw
(
'filename' => $path . $Futils::SL . $filename,
'mode' => $mode,
'error' => 'bad open',
'exception' => $!,
'cmd' => $cmd,
);
$this->seize($path . $Futils::SL . $filename, $FH);
}
# return file handle reference to the caller
return($FH);
}
# --------------------------------------------------------
# Futils::write_file()
# --------------------------------------------------------
sub write_file {
my($this) = shift(@_);
my($opts) = $this->shave_opts(\@_);
my($in) = $this->coerce_array(@_);
my($filename) = $in->{'file'} || '';
my($content) = $in->{'content'} || '';
my($mode) = $in->{'mode'} || 'write';
my($shadow_FH) = undef;
my($path) = '';
my($cmd) = '';
my(@dirs) = ();
my($have_lock) = 0;
my($FH_passed) = 0;
$filename ||= $$in{'filename'};
$filename ||= '';
$path = $filename;
local(*WRITE_FILE);
$mode = 'trunc' if ($mode eq 'truncate');
# if the call to this method didn't include a filename to which the caller
# wants us to write, then complain about it
$this->
throw
(
'error' => 'no input',
'meth' => 'write_file',
'missing' => 'a file name to create, write, or append',
)
if (length($filename) == 0);
# if prospective filename contains 2+ dir separators in sequence then
# this is a syntax error we need to whine about
$this->
throw
(
'error' => 'bad chars',
'string' => $filename,
'purpose' => 'the name of a file or directory',
)
if ($filename =~ /$Futils::dirsplit{2,}/);
# if the call to this method didn't include any data which the caller
# wants us to write or append to the file, then complain about it
$this->
throw
(
'meth' => 'write_file',
'missing' => 'the content you want to write or append',
'error' => 'no input',
)
if
(
(length($content) == 0)
and
($mode ne 'trunc')
and
(!$Futils::empty_writes)
);
# take care of idiots
$filename =~ s/$Futils::trailer//;
# determine existance of the file path, make directory(ies) for the
# path if the full directory path doesn't exist
@dirs = split(/$Futils::dirsplit/, $filename);
# if prospective file name has illegal chars then complain
foreach (@dirs) {
$this->
throw
(
'error' => 'bad chars',
'string' => $_,
'purpose' => 'the name of a file or directory',
)
if ($this->isbad($_));
}
if (scalar(@dirs) > 0) {
$filename = pop(@dirs);
$path = join($Futils::SL, @dirs);
}
if (length($path) > 0) {
$path = '.'.$Futils::SL.$path
if
($path !~ /(?:^\/)|(?:^\w\:)/o);
}
else {
$path = '.';
}
if (not $this->fexists($path)) {
$this->make_dir($path,0644);
}
my($openarg) = qq[$path$Futils::SL$filename];
# it's good to know beforehand whether or not we have permission to
# write/append to this file allowing us to handle such an exception
# before it handles us.
if (-e $openarg) {
# --> now check the writability of the file itself
$this->
throw
(
'filename' => $openarg,
'dirname' => $path . $Futils::SL,
'error' => 'cant fwrite',
)
unless ($this->can_write($openarg));
}
else {
# --> if file doesn't exist, the error is one of creation
$this->
throw
(
'filename' => $openarg,
'dirname' => $path.$Futils::SL,
'error' => 'cant fcreate',
)
unless ($this->can_write($path . $Futils::SL));
}
# determine whether the caller wants to over-write old data in the file
# if it already exists, create a fresh new file from the content provided,
# or just append the content onto the end of an existing file
if ($$opts{'--no-lock'} || $$this{'opts'}{'--no-lock'}) {
# get open mode
$mode = $$Futils::modes{'popen'}{ $mode };
# if you use the '--no-lock' option you are probably stupid
open(WRITE_FILE, $mode . $openarg)
or
$this->
throw
(
'filename' => $openarg,
'mode' => $mode,
'error' => 'bad open',
'exception' => $!,
'cmd' => $cmd,
);
}
else {
sysopen
(
*WRITE_FILE,
$openarg,
eval($$Futils::modes{'sysopen'}{ $mode })
)
or
$this->
throw
(
'filename' => $openarg,
'mode' => $mode,
'error' => 'bad open',
'exception' => $!,
'cmd' => qq[$openarg, $mode],
);
{ my($current_FH) = select(WRITE_FILE); ++$|; select($current_FH) }
# lock file before I/O when possible
$this->seize($openarg, *WRITE_FILE);
# now truncate
if ($mode ne 'append') {
truncate(WRITE_FILE,0)
or
$this->
throw
(
'filename' => $openarg,
'error' => 'bad systrunc',
'exception' => $!,
);
}
}
# write the caller's data to the newly opened file, syswrite covers our
# rear if the content is a binary stream and we're running on an OS that
# needs binmode. otherwise it isn't going to matter, except that it might
# be faster, since it bypasses stdio
$in->{'content'}||='';
syswrite(WRITE_FILE, $in->{'content'});
# release locks on the file
if ($$opts{'--no-lock'} || $$this{'opts'}{'--no-lock'}) {
# if execution gets here and you didn't pass in a locked filehandle
# to this method, you used the '--no-lock' option and you
# are probably stupid
close(WRITE_FILE)
or
$this->
throw
(
'filename' => $openarg,
'mode' => $mode,
'error' => 'bad close',
'exception' => $!,
);
}
else {
$this->release(*WRITE_FILE);
close(WRITE_FILE)
or
$this->
throw
(
'filename' => $openarg,
'mode' => $mode,
'error' => 'bad close',
'exception' => $!,
);
}
# return a quick success code to the caller in order to pass any checks
# being made that the operation was successful
return(1);
}
# --------------------------------------------------------
# Futils::seize()
# --------------------------------------------------------
sub seize {
# flock() helper for same-process race conditions
# which aren't safely handled when left up to the native filesystem
# locking mechanisms. Here, flock(2) lockf(3) and fcntl(2) can't
# save your bacon. You have to help out a little yourself.
=pod
OPTIONS ON I/O RACE CONDITION POLICY
set $Futils::onflockfail to any of the following strings:
ex- @Futils::onflockfail = qw( wait fail );
--fatal fails with stack trace
--fail same as above
--warn warns() about the error with a stack trace
--ignore ignores the failure to get an exclusive lock
--undef returns undef
--0 returns 0
* --wait waits to try getting an exclusive lock
* --block same as above
* used in tandem with another option.
you must specify another option to
fall back on if blocking should fail.
otherwise Futils will throw a fatal
error and dump a stack trace before
exiting the process with a 0 status
=cut
my($this) = shift(@_);
my($file) = shift(@_)||'';
my($FH) = shift(@_)||'';
my(@policy) = @Futils::onflockfail;
my($policy) = $this->shave_opts(\@policy);
$this->{'expt'}->fail(q[no file name passed to seize.])
unless
($file);
$this->{'expt'}->fail(q[no handle passed to seize.])
unless
($FH);
if ($Futils::hasflock) {
if (flock($FH, Fcntl::LOCK_EX() | Fcntl::LOCK_NB())) {
# at this point we know we have a non-blocking lock on $FH
return($FH);
}
else {
if
(
$policy->{'--block'}
or
$policy->{'--wait'}
)
{
if (flock($FH, Fcntl::LOCK_EX())) { return($FH) }
else {
if ($policy->{'--0'}) { return(0) }
elsif ($policy->{'--undef'}) { return(undef) }
elsif ($policy->{'--warn'}) {
return
(
$this->
throw
(
'--as-warning',
'filename' => $file,
'error' => 'bad lock',
'exception' => $!,
)
)
}
$this->
throw
(
'filename' => $file,
'error' => 'bad lock',
'exception' => $!,
)
}
}
else {
if ($policy->{'--0'}) { return(0) }
elsif ($policy->{'--undef'}) { return(undef) }
elsif ($policy->{'--warn'}) {
$this->
throw
(
'--as-warning',
'filename' => $file,
'error' => 'bad nblock',
'exception' => $!,
);
return(undef);
}
$this->
throw
(
'filename' => $file,
'error' => 'bad nblock',
'exception' => $!,
)
}
return(undef)
}
}
return($FH)
}
# --------------------------------------------------------
# Futils::release()
# --------------------------------------------------------
sub release {
my($this,$FH) = @_;
$this->{'expt'}->fail(qq[can't unlock $ebl$FH$ebr: not a valid handle])
unless (ref(\$FH||'') eq 'GLOB');
if ($Futils::hasflock) { flock($FH, Fcntl::LOCK_UN()) }
return(1);
}
# --------------------------------------------------------
# Futils::ftruncate()
# --------------------------------------------------------
sub ftruncate { $_[0]->write_file('mode'=>'trunc','file'=>$_[1]) }
# --------------------------------------------------------
# Futils::isbad()
# --------------------------------------------------------
sub isbad { $_[1] =~ /$Futils::illegal_filename_chrs/ }
# --------------------------------------------------------
# Futils::strip_path()
# --------------------------------------------------------
sub strip_path {
my($this) = shift(@_);
my($filename) = shift(@_)||'';
my(@dirs) = ();
# determine existance of the file path, make directory(ies) for the
# path if the full directory path doesn't exist
@dirs = split(/$Futils::dirsplit/, $filename);
return((pop(@dirs))||'');
}
# --------------------------------------------------------
# Futils::escape_filename()
# --------------------------------------------------------
sub escape_filename {
my($this) = shift(@_);
my($filename) = shift(@_)||'';
my($opts) = $this->shave_opts(\@_);
my($escape) = $opts->{'--use-chr'};
my($also) = $opts->{'--also'};
my(@dirs) = ();
my($path) = '';
my($mskpath) = '';
$escape = '_' if (not defined($escape));
$also ||= '';
$also = (length($also) > 0) ? '|'.$also : '';
# take care of idiots
$filename =~ s/$Futils::trailer//;
# determine existance of the file path, make directory(ies) for the
# path if the full directory path doesn't exist
@dirs = split(/$Futils::dirsplit/, $filename);
if (scalar(@dirs) > 0) {
$filename = pop(@dirs);
$path = join($Futils::SL, @dirs);
$mskpath = join($escape , @dirs);
}
if (length($path) > 0) {
$path = '.' . $Futils::SL . $path
if
($path !~ /(?:^\/)|(?:^\w\:)/o);
}
else {
$path = '.';
}
$filename =~ s/$Futils::illegal_filename_chrs$also/$escape/g;
$filename =~ s/^(?:\.)+?\w//o;
if ($opts->{'--strip-path'}) {
# take care of relative path prefixes still present
$filename =~ s/^\.+?//o;
return($filename);
}
return($mskpath . $escape . $filename);
}
# --------------------------------------------------------
# Futils::throw()
# --------------------------------------------------------
sub throw {
my($this) = shift(@_);
my($opts) = $this->shave_opts(\@_);
my($in) = $this->coerce_array(@_);
return(0) if ($this->{'opts'}{'--fatals-as-status'});
$this->{'expt'}||={};
unless (UNIVERSAL::isa($this->{'expt'},'expt_handler')) {
$this->{'expt'} = expt_handler->new();
}
foreach (keys(%{$in})) {
$_ = (defined($_)) ? $_ : '[undefined value]';
}
my($error) = (defined($in->{'error'})) ? $in->{'error'} : '[empty error]';
unless (defined( $Futils::errors->{$error} )) {
$Futils::errors->{$error} = $Futils::errors->{'unknown error message'}
}
my($bad_news) = CORE::eval($Futils::errors->{$error});
if ($opts->{'--as-warning'}) {
warn($this->{'expt'}->trace($@ || $bad_news)) and return()
}
elsif
(
$this->{'opts'}{'--fatals-as-errmsg'}
||
$opts->{'--return'}
)
{
return($this->{'expt'}->trace($@ || $bad_news))
}
foreach (keys(%{$in})) {
$_ = (defined($_)) ? $_ : '[empty value]';
$bad_news .= qq[ $_ => $in->{$_}] . $n;
}
foreach (keys(%{$opts})) {
$_ = (defined($_)) ? $_ : '[empty value]';
$bad_news .= qq[ $_ => $in->{$_}] . $n;
}
warn($this->{'expt'}->trace($@ || $bad_news)) if ($opts->{'--warn-also'});
return($this->{'expt'}->fail(($@ || $bad_news)))
}
# --------------------------------------------------------
# $Futils::errors [ref to anonymous hash of error msgs]
# --------------------------------------------------------
BEGIN {
$Futils::errors = {};
$Futils::errors =
{
# BAD CHARS
'bad chars' => <<'__bad_chars__',
qq[
Futils v$Futils::VERSION
Futils can't use this string for $ebl$in->{'purpose'}$ebr.
$ebl$in->{'string'}$ebr
It contains illegal characters.
Illegal characters are:
$ebl$Futils::SL$ebr
$ebl\\$ebr (backslash)
$ebl/$ebr (forward slash)
$ebl:$ebr (colon)
$ebl $ebr (space)
$ebl|$ebr (pipe)
$ebl*$ebr (asterisk)
$ebl?$ebr (question mark)
$ebl"$ebr (double quote)
$ebl<$ebr (less than)
$ebl>$ebr (greater than)
$ebl\\t$ebr (tab)
$ebl\\r$ebr (newline CR)
$ebl\\n$ebr (newline LF)
Origin: This is a human error.
Solution: A human must remove the illegal characters from this string.
Raw input as passed to this method:
]
__bad_chars__
# NO SUCH FILE
'no such file' => <<'__bad_open__',
qq[
Futils v$Futils::VERSION
Futils can't open
$ebl$in->{'filename'}$ebr
because no such file or directory exists.
Origin: This is *most likely* due to human error.
Solution: Cannot diagnose. A human must investigate the problem.
Raw input as passed to this method:
]
__bad_open__
# INVALID ERROR TYPE
'unknown error message' => <<'__foobar_input__',
qq[
Futils v$Futils::VERSION
Futils failed with an invalid error-type designation.
Origin: This is a human error.
Solution: A human must fix the programming flaw.
Raw input as passed to this method:
]
__foobar_input__
# EMPTY ERROR TYPE
'empty error' => <<'__no_input__',
qq[
Futils v$Futils::VERSION
Futils failed with an empty error-type designation.
Origin: This is a human error.
Solution: A human must fix the programming flaw.
Raw input as passed to this method:
]
__no_input__
# BAD CALL TO METHOD x
'no input' => <<'__no_input__',
qq[
Futils v$Futils::VERSION
Futils can't honor your call to ${\$ebl}Futils::$in->{'meth'}()$ebr
because you didn't provide $ebl@{[$in->{'missing'}||'the required input']}$ebr
Origin: This is a human error.
Solution: A human must fix the programming flaw.
Raw input as passed to this method:
]
__no_input__
# CAN'T READ FILE
'cant fread' => <<'__cant_read__',
qq[
Futils v$Futils::VERSION
Permissions conflict. Futils can't read the contents of this file:
$ebl$in->{'filename'}$ebr
Due to insufficient permissions, the system has denied Perl the right to
view the contents of this file. It has a bitmask of: (octal number)
$ebl@{[ sprintf('%04o',(stat($in->{'filename'}))[2] & 0777 ]}$ebr
The directory housing it has a bitmask of: (octal number)
$ebl@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$ebr
Origin: This is *most likely* due to human error. External system errors
can occur however, but this doesn't have to do with Futils.
Solution: A human must fix the conflict by adjusting the file permissions
of directories where a program asks Futils to perform I/O.
Try using Perl's chmod command, or the native system chmod()
command from a shell.
Raw input as passed to this method:
]
__cant_read__
# CAN'T CREATE FILE
'cant fcreate' => <<'__cant_write__',
qq[
Futils v$Futils::VERSION
Permissions conflict. Futils can't create this file:
$ebl$in->{'filename'}$ebr
Futils can't create this file because the system has denied Perl
the right to create files in the parent directory.
The -e test returns $ebl@{[-e $in->{'dirname'} ]}$ebr for the directory.
The -r test returns $ebl@{[-r $in->{'dirname'} ]}$ebr for the directory.
The -R test returns $ebl@{[-R $in->{'dirname'} ]}$ebr for the directory.
The -w test returns $ebl@{[-w $in->{'dirname'} ]}$ebr for the directory
The -W test returns $ebl@{[-w $in->{'dirname'} ]}$ebr for the directory
Parent directory: (path may be relative or redundant)
$ebl$in->{'dirname'}$ebr
Parent directory has a bitmask of: (octal number)
$ebl@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$ebr
Origin: This is *most likely* due to human error. External system errors
can occur however, but this doesn't have to do with Futils.
Solution: A human must fix the conflict by adjusting the file permissions
of directories where a program asks Futils to perform I/O.
Try using Perl's chmod command, or the native system chmod()
command from a shell.
Raw input as passed to this method:
]
__cant_write__
# CAN'T WRITE TO FILE
'cant fwrite' => <<'__cant_write__',
qq[
Futils v$Futils::VERSION
Permissions conflict. Futils can't write to this file:
$ebl$in->{'filename'}$ebr
Due to insufficient permissions, the system has denied Perl the right
to modify the contents of this file. It has a bitmask of: (octal number)
$ebl@{[ sprintf('%04o',(stat($in->{'filename'}))[2] & 0777) ]}$ebr
Parent directory has a bitmask of: (octal number)
$ebl@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$ebr
Origin: This is *most likely* due to human error. External system errors
can occur however, but this doesn't have to do with Futils.
Solution: A human must fix the conflict by adjusting the file permissions
of directories where a program asks Futils to perform I/O.
Try using Perl's chmod command, or the native system chmod()
command from a shell.
Raw input as passed to this method:
]
__cant_write__
# CAN'T LIST DIRECTORY
'cant dread' => <<'__cant_read__',
qq[
Futils v$Futils::VERSION
Permissions conflict. Futils can't list the contents of this directory:
$ebl$in->{'filename'}$ebr
Due to insufficient permissions, the system has denied Perl the right to
view the contents of this directory. It has a bitmask of: (octal number)
$ebl@{[ sprintf('%04o',(stat($in->{'filename'}))[2] & 0777) ]}$ebr
Origin: This is *most likely* due to human error. External system errors
can occur however, but this doesn't have to do with Futils.
Solution: A human must fix the conflict by adjusting the file permissions
of directories where a program asks Futils to perform I/O.
Try using Perl's chmod command, or the native system chmod()
command from a shell.
Raw input as passed to this method:
]
__cant_read__
# CAN'T CREATE DIRECTORY
'cant dcreate' => <<'__cant_write__',
qq[
Futils v$Futils::VERSION
Permissions conflict. Futils can't create:
$ebl$in->{'filename'}$ebr
Futils can't create this directory because the system has denied
Perl the right to create files in the parent directory.
Parent directory: (path may be relative or redundant)
$ebl$in->{'dirname'}$ebr
Parent directory has a bitmask of: (octal number)
$ebl@{[ sprintf('%04o',(stat($in->{'dirname'}))[2] & 0777) ]}$ebr
Origin: This is *most likely* due to human error. External system errors
can occur however, but this doesn't have to do with Futils.
Solution: A human must fix the conflict by adjusting the file permissions
of directories where a program asks Futils to perform I/O.
Try using Perl's chmod command, or the native system chmod()
command from a shell.
Raw input as passed to this method:
]
__cant_write__
# CAN'T OPEN
'bad open' => <<'__bad_open__',
qq[
Futils v$Futils::VERSION
Futils can't open this file for $ebl$in->{'mode'}$ebr:
$ebl$in->{'filename'}$ebr
The system returned this error:
$ebl$in->{'exception'}$ebr
Futils used this directive in its attempt to open the file
$ebl$in->{'cmd'}$ebr
Origin: This is *most likely* due to human error.
Solution: Cannot diagnose. A Human must investigate the problem.
Raw input as passed to this method:
]
__bad_open__
# ALREADY OPEN
'already open' => <<'__already_open__',
qq[
Futils v$Futils::VERSION
Futils can't open this file
$ebl$in->{'filename'}$ebr
This file is already in use somewhere else in your code.
It is opened to descriptor number $ebl@{[
fileno($this->{'lockbox'}{'file names'}{ $in->{'filename'} }{'handle'})
||
'[descriptor irretrievable]'
]}$ebr
Origin: This is a human error.
Solution: Turn off file locking in Futils or don't open the same file more
than one time simultaneously. You risk data corruption.
Raw input as passed to this method:
]
__already_open__
# CAN'T GET FLOCK AFTER BLOCKING
'bad nblock' => <<'__bad_lock__',
qq[
Futils v$Futils::VERSION
Futils can't get a non-blocking exclusive lock on the file
$ebl$in->{'filename'}$ebr
The system returned this error:
$ebl$in->{'exception'}$ebr
Origin: Could be either human _or_ system error.
Solution: Fall back to an attempt at getting a lock on the file by blocking.
Investigate the reason why you can't get a lock on the file,
it is usually because of improper programming which causes
race conditions on one or more files.
Raw input as passed to this method:
]
__bad_lock__
# CAN'T GET NON-BLOCKING FLOCK
'bad lock' => <<'__bad_lock__',
qq[
Futils v$Futils::VERSION
Futils can't get a blocking exclusive lock on the file.
$ebl$in->{'filename'}$ebr
The system returned this error:
$ebl$in->{'exception'}$ebr
Origin: Could be either human _or_ system error.
Solution: Investigate the reason why you can't get a lock on the file,
it is usually because of improper programming which causes
race conditions on one or more files.
Raw input as passed to this method:
]
__bad_lock__
# CAN'T OPEN ON A DIRECTORY
'called open on a dir' => <<'__bad_open__',
qq[
Futils v$Futils::VERSION
Futils can't call open() on this file because it is a directory
$ebl$in->{'filename'}$ebr
Origin: This is a human error.
Solution: Use Futils::load_file() to load the contents of a file
Use Futils::list_dir() to list the contents of a directory
Raw input as passed to this method:
]
__bad_open__
# CAN'T OPENDIR ON A FILE
'called opendir on a file' => <<'__bad_open__',
qq[
Futils v$Futils::VERSION
Futils can't opendir() on this file because it is not a directory.
$ebl$in->{'filename'}$ebr
Use Futils::load_file() to load the contents of a file
Use Futils::list_dir() to list the contents of a directory
Origin: This is a human error.
Solution: Use Futils::load_file() to load the contents of a file
Use Futils::list_dir() to list the contents of a directory
Raw input as passed to this method:
]
__bad_open__
# PASSED READLIMIT
'readlimit exceeded' => <<'__readlimit__',
qq[
Futils v$Futils::VERSION
Futils can't load file: $ebl$in->{'filename'}$ebr
into memory because its size exceeds the maximum file size allowed
for a read.
The size of this file is $ebl$in->{'size'}$ebr bytes.
Currently the read limit is set at $ebl$Futils::readlimit$ebr bytes.
Origin: This is a human error.
Solution: Consider setting the limit to a higher number of bytes.
Raw input as passed to this method:
]
__readlimit__
# BAD OPENDIR
'bad opendir' => <<'__bad_opendir__',
qq[
Futils v$Futils::VERSION
Futils can't opendir this on $ebl$dir$ebr
The system returned this error:
$ebl$in->{'exception'}$ebr
Origin: Could be either human _or_ system error.
Solution: Cannot diagnose. A Human must investigate the problem.
Raw input as passed to this method:
]
__bad_opendir__
# BAD MAKEDIR
'bad make_dir' => <<'__bad_make_dir__',
qq[
Futils v$Futils::VERSION
Futils had a problem with the system while attempting to create the directory
you specified with a bitmask of $ebl$in->{'bitmask'}$ebr
directory: $ebl$in->{'dir'}$ebr
The system returned this error:
$ebl$in->{'exception'}$ebr
Origin: Could be either human _or_ system error.
Solution: Cannot diagnose. A Human must investigate the problem.
Raw input as passed to this method:
]
__bad_make_dir__
# BAD CLOSE
'bad close' => <<'__bad_close__',
qq[
Futils v$Futils::VERSION
Futils couldn't close this file after $ebl$in->{'mode'}$ebr
$ebl$in->{'filename'}$ebr
The system returned this error:
$ebl$in->{'exception'}$ebr
Origin: Could be either human _or_ system error.
Solution: Cannot diagnose. A Human must investigate the problem.
Raw input as passed to this method:
]
__bad_close__
# CAN'T TRUNCATE
'bad systrunc' => <<'__bad_systrunc__',
qq[
Futils v$Futils::VERSION
Futils couldn't truncate() on $ebl$in->{'filename'}$ebr after having
successfully opened the file in write mode.
The system returned this error:
$ebl$in->{'exception'}$ebr
This is most likely _not_ a human error, but has to do with your system's
support for the C truncate() function.
Raw input as passed to this method:
]
__bad_systrunc__
}
} # close surrounding BEGIN block for Futils::errors
# --------------------------------------------------------
# Futils::DESTROY(), end Futils class package
# --------------------------------------------------------
sub DESTROY {}
1;
=pod
PERL FILE CHECKS REFERENCE
-r File is readable by effective uid/gid.
-w File is writable by effective uid/gid.
-x File is executable by effective uid/gid.
-o File is owned by effective uid.
-R File is readable by real uid/gid.
-W File is writable by real uid/gid.
-X File is executable by real uid/gid.
-O File is owned by real uid.
-e File exists.
-z File has zero size.
-s File has non-zero size (returns size).
-f File is a plain file.
-d File is a directory.
-l File is a symbolic link.
-p File is a named pipe (FIFO).
-S File is a socket.
-b File is a block special file.
-c File is a character special file.
-t Filehandle is opened to a tty.
-u File has setuid bit set.
-g File has setgid bit set.
-k File has sticky bit set.
-T File is a text file.
-B File is a binary file (opposite of -T).
-M Age of file in days when script started.
-A Same for access time.
-C Same for inode change time.
SYSTEM FLOCK SUPPORT DEFINES
d_fcntl_can_lock
From d_fcntl_can_lock.U:
This variable conditionally defines the FCNTL_CAN_LOCK symbol
and indicates whether file locking with fcntl() works.
d_flock
From d_flock.U:
This variable conditionally defines HAS_FLOCK if flock() is
available to do file locking.
d_lockf
From d_lockf.U:
This variable conditionally defines HAS_LOCKF if lockf() is
available to do file locking.
/FLOCKING CONSTANTS/
classic values for these constants are as listed,
but this can vary from system to system
LOCK_EX 2
LOCK_UN 8
LOCK_NB 4
LOCK_SH 1
=cut
package expt_handler;
use strict;
$expt_handler::VERSION = 1.01; # 8/6/2002, 1:42:23 PM
=pod
AUTHOR
-Tommy Butler, professional contractor and open source proponent
Atrixnet™, for Internet Business Software®
http://atrixnet.com
6711 Forest Park Dr
Dallas, TX
76001
COPYRIGHT
Copyright Tommy Butler. All rights reserved
LISCENCE
This software is free, and you may use and distribute it under the
GNU GPL liscence. If you modify the code for your own purposes
please acknowledge its original author.
BUGS
Please report any of the following to me
- bugs
- interface inconsistencies
- suggestions
- comments
- complaints
- smart remarks
=cut
use vars qw( $n ); $n = qq[\n];
# --------------------------------------------------------
# Constructor
# --------------------------------------------------------
sub new {
my($class) = shift;
my($this) = {};
my($name) = __PACKAGE__;
# -------------------------------------------
# bless object ref into the class' namespace
# -------------------------------------------
bless($this, $name);
# this is always a handy help
$this->{'name'} = $name;
# return object reference
return($this);
}
# --------------------------------------------------------
# expt_handler::quit()
# --------------------------------------------------------
sub quit {
my($this) = shift;
print( qq[Content-Type: text/html] . $n x 2 )
if ( $ENV{'REQUEST_METHOD'} =~ /^HEAD|^GET|^POST/io );
print( qq[PROCESS TERMINATED DUE TO ERRORS, see log...] );
warn($this->trace(@_));
exit;
}
# --------------------------------------------------------
# expt_handler::fail(), error(), belch()
# --------------------------------------------------------
sub fail {
my($this) = shift;
my($throw_count) = $this->{'tflag'} || 0;
{
# I refuse to manually initialize a standard environment
# variable. This is an example where the warnings pragma
# is going too far. It's something we live with.
local($^W) = undef;
# if we're running in a CGI gateway iface, we need
# to output the necessary HTTP headers
if ( $ENV{'REQUEST_METHOD'} =~ /^HEAD|^GET|^POST/io ) {
print(<<__crash__) and exit;
Content-Type: text/html; charset=ISO-8859-1
<pre>
PROCESS TERMINATED DUE TO ERRORS
@{[ $this->trace(@_) ]}
</pre>
__crash__
}
else {
print(<<__crash__) and exit;
PROCESS TERMINATED DUE TO ERRORS
@{[ $this->trace(@_) ]}
__crash__
}
}
exit;
}
sub error { my($this) = shift; return( $this->fail(@_) ) }
sub belch { my($this) = shift; return( $this->fail(@_) ) }
# --------------------------------------------------------
# expt_handler::trace()
# --------------------------------------------------------
sub trace {
my($this) = shift;
my(@errors) = @_;
my($errfile) = '';
my($caught) = 0;
my(
$pak, $filename, $linenum, $subroutine,
$hasargs, $wantarray, $evaltext, $req_OR_use,
@stack, $trace, $i, $ialias,
);
$ialias = 0;
while (
(
$pak, $filename, $linenum, $subroutine,
$hasargs, $wantarray, $evaltext, $req_OR_use
)
= caller( $i++ )
)
{
$ialias = $i - 2;
my(@tree) = split ( /\:\:/, $subroutine );
if ( $tree[0] ne $this->{'name'} ) {
push (
@stack, qq[
$ialias. $subroutine
-called at line ($linenum) of $filename
@{[
($hasargs)
? '-was called with args'
: '-was called without args'
]}
@{[
($evaltext)
? '-was called to evalate text'
: '-was not called to evaluate anything'
]}]
);
}
else {
$caught =
$n
. uc(qq[exception was raised at])
. qq[ line ($linenum) of $filename];
}
}
$i = 0;
if ( scalar(@errors) == 0 ) {
push ( @errors, qq[[unreported error. stack frame no. $ialias...]] );
}
foreach (@errors) {
$_ = ( defined($_) ) ? $_ : '';
if ( length($_) == 0 ) {
$_ = qq[Something is wrong. stack frame no. $ialias...];
}
else { $_ =~ s/^(?:\r|\n)//o; $_ =~ s/(?:\r|\n)$//o; $_ = qq[$n$_$n]; }
++$i;
}
$trace = join ( $n x 2, @errors, ) . $caught . $n x 2;
$trace .= join ( $n x 2, @stack, $n x 4 );
return($trace);
}
# --------------------------------------------------------
# expt_handler::DESTROY()
# --------------------------------------------------------
sub DESTROY {}
1;
package Handy::Dandy;
use strict;
$Handy::Dandy::VERSION = 1.08; # 8/4/2002, 6:28:46 PM
=pod
AUTHOR
-Tommy Butler, professional contractor and open source proponent
Atrixnet™, for Internet Business Software®
http://atrixnet.com
6711 Forest Park Dr
Dallas, TX
76001
COPYRIGHT
Copyright Tommy Butler. All rights reserved
LISCENCE
This software is free, and you may use and distribute it under the
GNU GPL liscence. If you modify the code for your own purposes
please acknowledge its original author.
BUGS
Please report any of the following to me
- bugs
- interface inconsistencies
- suggestions
- comments
- complaints
- smart remarks
=cut
# --------------------------------------------------------
# Constructor
# --------------------------------------------------------
sub new {
my($class) = shift;
my($this) = {};
my($name) = __PACKAGE__;
# -------------------------------------------
# bless object ref into the class' namespace
# -------------------------------------------
bless($this, $class);
my($in) = $this->coerce_array(@_);
# -------------------------------------------
# begin setting up class attributes
# -------------------------------------------
$this->{'name'} = $name;
# return object reference
return($this);
}
# --------------------------------------------------------
# Handy::Dandy::utf8()
# --------------------------------------------------------
sub utf8 {
my($this) = shift;
my($toencode) = join('',@_);
my($no_encode) = 'a-zA-Z 0-9_\\-@.=';
$toencode =~ s/([^&;$no_encode])/sprintf("%%%02X",ord($1))/ego;
$toencode =~ s/ /+/gmo;
return($toencode);
}
# --------------------------------------------------------
# Handy::Dandy::html_escape()
# --------------------------------------------------------
sub html_escape {
my($this) = shift;
my(@chars) = split(//,shift(@_));
foreach (@chars) {
$_ = '&#' .ord($_) .';';
}
return(join('',@chars));
}
# --------------------------------------------------------
# Handy::Dandy::convert()
# --------------------------------------------------------
sub convert_size {
my($this) = shift;
my($amt) = shift;
my($cmd) = shift;
my(@specs) = split(/ /,$cmd);
my($from) = $specs[0];
my($to) = $specs[-1];
my($b) = 1;
my($k) = 1000;
my($m) = 1000000;
# FROM conversions
if ($from =~ /^ki/io) {
$amt *= $k;
}
elsif ($from =~ /^meg/io) {
$amt *= $m;
}
elsif ($from =~ /^by/io) {
$amt *= $b;
}
# TO conversions
if ($to =~ /^ki/io) {
$amt /= $k;
}
elsif ($to =~ /^meg/io) {
$amt /= $m;
}
elsif ($to =~ /^by/io) {
$amt /= $b;
}
return($amt);
}
# --------------------------------------------------------
# Handy::Dandy::to_seconds()
# --------------------------------------------------------
sub time_units {
my($this) = shift(@_);
my($unit) = shift(@_) || '10 minutes';
my($amt) = 0;
$unit =~ s/(?go)^(?: )+|(?: )+$//;
($unit,$amt) = split(/ /,$unit);
if ($unit =~ /(?o)sec/) {
return($amt);
}
elsif ($unit =~ /(?o)min/) {
# 1 minute = 60 seconds
return($amt * 60);
}
elsif ($unit =~ /(?o)hour/) {
# 1 hour = 60 minutes
# 60 minutes = 3600 seconds
return($amt * 3600);
}
elsif ($unit =~ /(?o)day/) {
# 1 day = 24 hours
# 24 hours = 1440 minutes
# 1440 minutes = 86400 seconds
return($amt * 86400);
}
elsif ($unit =~ /(?o)week/) {
# 1 week = 7.0347222 days
# 7.0347222 days = 168.8333333 hours
# 168.8333333 hours = 10130 minutes
# 10130 minutes = 607800 seconds
return($amt * 607800);
}
elsif ($unit =~ /(?o)year/) {
# 1 year = 365.2425116 days
# 365.2425116 days = 8765.8202778 hours
# 8765.8202778 hours = 525949.2166667 minutes
# 525949.2166667 minutes = 31556953 seconds
return($amt * 31556953);
}
elsif ($unit =~ /(?o)never/) {
return(-2)
}
else { return(-1) }
}
# --------------------------------------------------------
# Handy::Dandy::shave_opts()
# --------------------------------------------------------
sub shave_opts {
my($this) = shift;
my($mamma) = shift;
my($maid) = [@{$mamma}];
my($opts) = {};
my($i) = 0;
while (@{$maid}) {
my($e) = shift(@{$maid})||'';
if ($e =~ /^\Q--\E\w/o) {
splice(@{$mamma},$i,1);
$opts->{$e} = $e if (length($e));
}
++$i;
}
return($opts);
}
# --------------------------------------------------------
# Handy::Dandy::coerce_array()
# --------------------------------------------------------
sub coerce_array {
my($this) = shift;
my($hashref) = {};
my($i) = 0;
my(@shadow) = @_;
while (@shadow) {
my($name,$val) = splice(@shadow,0,2);
if (defined($name)) {
$hashref->{$name} = (defined($val)) ? $val : '';
}
else {
++$i;
$hashref->{qq[un-named key no. $i]} = (defined($val)) ? $val : '';
}
}
return($hashref);
}
# --------------------------------------------------------
# sub Handy::Dandy::touch
# --------------------------------------------------------
sub touch {
my($this) = shift;
my(@items) = @_;
foreach(@items) {
if (ref($_) eq 'SCALAR') {
$$_ = '' if (not defined($$_));
}
elsif (ref($_) eq 'HASH') {
%$_ = {} if (not defined(%$_));
}
elsif (ref($_) eq 'ARRAY') {
@$_ = [] if (not defined(@$_));
}
}
return(@items);
}
# --------------------------------------------------------
# sub Handy::Dandy::soft_touch
# --------------------------------------------------------
sub soft_touch {@_}
# ----------------------------------
# sub Handy::Dandy::isnum
# ----------------------------------
sub isnum { $_[0] !~ /\D/o }
# --------------------------------------------------------
# Handy::Dandy::trim()
# --------------------------------------------------------
sub trim {
my($this) = shift;
return('') if (scalar(@_) < 2);
my($str) = shift; $str = (defined($str)) ? $str : '';
my($len) = shift; $len = (defined($len)) ? $len : 0;
my($lst) = shift; $lst = (defined($lst)) ? $lst : 0;
if ((length($str)==0) or (length($len)==0)) {
return($str);
}
$len = int($len);
if (length($str) <= $len) {
return($str);
}
my($frag) = '';
$frag =
join
(
'',
splice
(
@{[split(//,$str)]},
$len
),
);
$str =
sprintf
(
'%'.$len.'.'.$len.'s',
$str
);
return (wantarray or $lst) ? ($str,$frag) : $str;
}
# --------------------------------------------------------
# Handy::Dandy::stamp()
# --------------------------------------------------------
sub stamp {
my($this) = shift;
my($opts) = $this->shave_opts(\@_);
my($argtime) = shift;
my($months) = [
'January', 'February', 'March', 'April',
'May', 'June', 'July', 'August',
'September', 'October', 'November', 'December',
];
my($days) = [
'Sunday', 'Monday', 'Tuesday', 'Wednesday',
'Thursday', 'Friday', 'Saturday'
];
$argtime ||= time();
my( $sec, $min, $hour, $date, $mon, $year, $wday, $yday, $isdst ) =
localtime($argtime);
my($AMPM) = ( $hour >= 12 ) ? 'PM' : 'AM';
$hour -= 12 if ( $hour > 12 );
$hour = 12 if ( $hour == 0 );
# 5/15/2002, 4.22.43 PM
return
(
sprintf(
q[%s/%u/%u, %s:%02u:%02u %s],
$mon + 1, $date, $year + 1900,
$hour, $min, $sec, $AMPM
)
) if ($opts->{'--short'});
# -June-15-2002-4.22.43-PM
return
(
sprintf(
q[-%s-%u-%u-%u.%02u.%02u-%s],
$months->[$mon], $date, $year + 1900,
$hour, $min, $sec, $AMPM
)
) if ($opts->{'--filename'} or $opts->{'--file'});
# Saturday, June 15, 2002, 4.22.43 PM
return
(
sprintf(
q[%s, %s %u, %u, %s:%02u:%02u %s],
$days->[$wday], $months->[$mon], $date, $year + 1900,
$hour, $min, $sec, $AMPM
)
);
}
# --------------------------------------------------------
# Handy::Dandy::DESTROY()
# --------------------------------------------------------
sub DESTROY {}
# --------------------------------------------------------
# end Handy::Dandy Class, return true on import
# --------------------------------------------------------
1;
package main;
use strict;
use Config;
use Time::HiRes qw( time );
my($futils) = Futils->new();
print(qq[Content-Type: text/html; charset=ISO-8859-1\n\n]);
my(@out) = `perl -v`;
push(@out, qq[\n\n], `perl -V`, qq[\n\n]);
if (defined(%Config::Config)) {
my(%con) = (%Config::Config);
$con{'osname'}||=$^O||'[osname variable not available]';
foreach (sort(keys(%con))) {
if (defined($con{$_})) {
if (length($con{$_}) == 0) {
$con{$_} = '[defined empty]';
push(@out,qq[$_ => $con{$_}\n]);
}
else {
push(@out,qq[$_ => $con{$_}\n]);
}
}
else {
push(@out,qq[$_ => [undefined]\n]);
}
}
}
else {
push(@out,qq[\n\%Config::Config not defined or unavailable.\n\n]);
}
$Futils::maxdepth = 1000;
push
(
@out,
$Futils::n x 2
. q[@INC is ]
. join($Futils::n, @INC)
. $Futils::n x 2
. q[@INC CONTAINS...]
);
foreach (@INC) {
next if ($_ eq '.');
push
(
@out,
$futils->print_dir
(
$_,
'--dirs-only',
'--with-paths',
'--follow',
'--no-fsdots',
)
)
}
print(<<__endtemplate__);
<?xml version="1.0" encoding='ISO-8859-1'?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html
xmlns="http://www.w3.org/1999/xhtml"
xml:lang="en"
lang="en">
<head>
<title>perl binary details</title>
<meta
http-equiv="Content-Type"
content="text/html; charset=iso-8859-1" />
<link
rel="stylesheet"
type="text/css"
href="http://www.atrixnet.com/css/style.css" />
</head>
<body>
<h1>perl binary details</h1>
<p> </p>
<div class="px700">
<pre>
@{[ join('',@out) ]}
this page generated in @{[sprintf('%.2f',((time-$^T)))]} seconds
</pre>
</div>
<p> </p>
</body>
</html>
__endtemplate__
exit;