#!/usr/bin/perl -w
=pod
AUTHOR
-Tommy Butler, professional contractor, open source proponent, nerd.
Atrixnet™, for Internet Business Software®
http://atrixnet.com
6711 Forest Park Dr
Arlington, TX
76001
NOTES
ALL embedded class packages are seriously hacked versions of the
real libraries by the same names.
COPYRIGHT
Copyright Tommy Butler. All rights reserved
LISCENCE
Futils.pm 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.
=cut
package Futils;
use strict;
use Exporter;
$Futils::VERSION = 3.09; # 8/28/2002, 12:06:56 PM
@Futils::ISA = qw( Exporter Handy::Dandy );
@Futils::EXPORT_OK = qw
(
can_flock newline SL n eb
can_read can_write
shave_opts
coerce_array OOorNO
myargs
);
%Futils::EXPORT_TAGS = ( 'all' => [ @Futils::EXPORT_OK ] );
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;$Futils::empty_writes= 0;
@Futils::onflockfail = ();
@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 Exception::Handler;
# --------------------------------------------------------
# Constructor
# --------------------------------------------------------
sub new {
my($this) = {};
# bless object ref into the class' namespace
bless($this, shift(@_));
# 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'} = __PACKAGE__;
$this->{'n'} = $Futils::n;
$this->{'SL'} = $Futils::SL;
$this->{'opts'} = $opts;
$this->{'expt'} = Exception::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() isbin() fexists() eb()
# set() get() can_read() can_write()
# --------------------------------------------------------
sub can_flock { $Futils::hasflock } # EXPORT_OK
sub newline { $Futils::n } # EXPORT_OK
sub SL { $Futils::SL } # EXPORT_OK
sub n { $Futils::n } # EXPORT_OK
sub eb { my($q) = &myargs; $ebl . $q . $ebr } # EXPORT_OK
sub can_read { my($f) = &myargs; -r $f } # EXPORT_OK
sub can_write { my($f) = &myargs; -w $f } # EXPORT_OK
# --------------------------------------------------------
# Futils::list_dir()
# --------------------------------------------------------
sub list_dir {
&$main::ldh();
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
return($this->
throw
(
'no input',
{
'meth' => 'list_dir',
'missing' => 'a directory name',
'opts' => $opts,
}
))
unless (length($dir) > 0);
# if the call to this method included a non-existant directory then
# complain about it
return($this->
throw
(
'no such file',
{
'filename' => $dir,
'opts' => $opts,
}
))
unless (-e $dir);
if ($opts->{'--recursing'}) { ++$Futils::recursed }
else { $Futils::recursed = 0 }
if ($Futils::recursed >= $Futils::maxdepth) {
return($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
return($this->
throw
(
'called opendir on a file',
{
'filename' => $dir,
'opts' => $opts,
}
))
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
return($this->
throw
(
'bad opendir',
{
'dir' => $dir,
'exception' => $!,
'opts' => $opts,
}
));
# 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
return($this->
throw
(
'close dir',
{
'dir' => $dir,
'exception' => $!,
'opts' => $opts,
}
));
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::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::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 = '.';
}
return($this->
throw
(
'no input',
{
'meth' => 'load_file',
'missing' => 'a file name or file handle reference',
'opts' => $opts,
}
))
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 {
return($this->
throw
(
'no input',
{
'meth' => 'load_file',
'missing' => 'a file name or file handle reference',
'opts' => $opts,
}
));
}
}
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 {
return($this->
throw
(
'readlimit exceeded',
{
'filename' => '<FH>',
'size' => qq[[truncated at $bytes_read]],
'opts' => $opts,
}
));
}
}
# 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
return($this->
throw
(
'no such file',
{
'filename' => $path . $Futils::SL . $filename,
'opts' => $opts,
}
))
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
return($this->
throw
(
'cant dread',
{
'filename' => $path . $Futils::SL.$filename,
'dirname' => $path . $Futils::SL,
'opts' => $opts,
}
))
unless ($this->can_read($path . $Futils::SL));
# --> now check the readability of the file itself
return($this->
throw
(
'cant fread',
{
'filename' => $path . $Futils::SL.$filename,
'dirname' => $path . $Futils::SL,
'opts' => $opts,
}
))
unless ($this->can_read($path . $Futils::SL . $filename));
# if the file is a directory it will not be opened
return($this->
throw
(
'called open on a dir',
{
'filename' => $path . $Futils::SL . $filename,
'opts' => $opts,
}
))
if
(-d $path . $Futils::SL . $filename);
return($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);
return($this->
throw
(
'readlimit exceeded',
{
'filename' => $path . $Futils::SL . $filename,
'size' => $fsize,
'opts' => $opts,
}
))
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
return($this->
throw
(
'bad open',
{
'filename' => $path . $Futils::SL . $filename,
'mode' => $mode,
'exception' => $!,
'cmd' => $cmd,
'opts' => $opts,
}
));
# }
# else {
# open(LOAD_FILE, $cmd)
# or
# return($this->
# throw
# (
# 'bad open',
# {
# 'filename' => $path . $Futils::SL . $filename,
# 'mode' => $mode,
# 'exception' => $!,
# 'cmd' => $cmd,
# 'opts' => $opts,
# }
# ));
# $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
return($this->
throw
(
'bad close',
{
'filename' => $path . $Futils::SL . $filename,
'mode' => $mode,
'exception' => $!,
'opts' => $opts,
}
));
# }
# else {
# release shadow-ed locks on the file
# $this->release(*LOAD_FILE);
# close(LOAD_FILE)
# or
# return($this->
# throw
# (
# 'bad close',
# {
# 'filename' => $path . $Futils::SL . $filename,
# 'mode' => $mode,
# 'exception' => $!,
# 'opts' => $opts,
# }
# ));
# }
# 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::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::throw()
# --------------------------------------------------------
sub throw {
my($this) = shift(@_);
my($error) = shift(@_) || '[empty error]';
my($opts) = $this->shave_opts(\@_);
my($in) = shift(@_) || {};
$Futils::errors = eval($Futils::errors);
return(0)
if
(
$this->{'opts'}{'--fatals-as-status'}
||
$this->{'fatals-as-status'}
);
$this->{'expt'}||={};
unless (UNIVERSAL::isa($this->{'expt'},'expt_handler')) {
$this->{'expt'} = expt_handler->new();
}
foreach (keys(%{$in})) { $_ = (defined($_)) ? $_ : '[undefined value]' }
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]';
next if ($_ eq 'opts');
$bad_news .= qq[ARG $_ = $in->{$_}] . $n;
}
if ($in->{'opts'}) {
foreach (keys(%{$$in{'opts'}})) {
$_ = (defined($_)) ? $_ : '[empty value]';
$bad_news .= qq[OPT $_] . $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 = <<'____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->{'dirname'}$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__
}
____FUTILS_ERRORS____
# --------------------------------------------------------
# Futils::DESTROY()
# --------------------------------------------------------
sub DESTROY {}
1;
package Handy::Dandy;
use strict;
use Exporter;
$Handy::Dandy::VERSION = 1.18; # 8/24/2002, 2:17:45 PM
@Handy::Dandy::ISA = qw( Exporter );
@Handy::Dandy::EXPORT_OK = qw
(
shave_opts
coerce_array OOorNO
myargs
);
%Handy::Dandy::EXPORT_TAGS = ( 'all' => [ @Handy::Dandy::EXPORT_OK ] );
# --------------------------------------------------------
# Constructor
# --------------------------------------------------------
sub new { bless({}, shift(@_)) }
# --------------------------------------------------------
# Futils::OOorNO()
# --------------------------------------------------------
sub OOorNO { return($_[0]) if UNIVERSAL::can($_[0],'can'); undef }
# --------------------------------------------------------
# Futils::myargs()
# --------------------------------------------------------
sub myargs { if (&OOorNO) { shift(@_) } @_ }
# --------------------------------------------------------
# Handy::Dandy::shave_opts()
# --------------------------------------------------------
sub shave_opts {
my($mamma) = &myargs;
return(undef) unless ($mamma && ref($mamma) eq 'ARRAY');
my(@maid) = @$mamma; @$mamma = ();
my($opts) = {};
while (@maid) {
my($o) = shift(@maid)||'';
if ($o =~ /^\Q--\E\w/o) { $opts->{$o} = $o } else { push(@$mamma, $o) }
}
return($opts);
}
# --------------------------------------------------------
# Handy::Dandy::coerce_array()
# --------------------------------------------------------
sub coerce_array {
my($hashref) = {};
my($i) = 0;
my(@shadow) = &myargs;
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);
}
# --------------------------------------------------------
# Handy::Dandy::use_once
# --------------------------------------------------------
sub use_once { @_ }
# --------------------------------------------------------
# Handy::Dandy::DESTROY()
# --------------------------------------------------------
sub DESTROY {}
# --------------------------------------------------------
# end Handy::Dandy Class, return true on import
# --------------------------------------------------------
1;
package Handy::Dandy::CGItools;
use strict;
use Exporter;
$Handy::Dandy::CGItools::VERSION = 1.00; # 8/23/2002, 12:49:15 PM
@Handy::Dandy::CGItools::ISA = qw( Exporter );
@Handy::Dandy::CGItools::EXPORT_OK = qw
(
cgi_error
time_spent
);
%Handy::Dandy::CGItools::EXPORT_TAGS =
(
'all' => [ @Handy::Dandy::CGItools::EXPORT_OK ]
);
# --------------------------------------------------------
# sub Handy::Dandy::CGItools::timespent
# --------------------------------------------------------
sub time_spent { sprintf('%0.2f', (time - $^T)) }
# --------------------------------------------------------
# Handy::Dandy::CGItools::DESTROY()
# --------------------------------------------------------
sub DESTROY {}
# --------------------------------------------------------
# end Handy::Dandy::CGItools Class, return true on import
# --------------------------------------------------------
1;
package Exception::Handler;
use strict;
$Exception::Handler::VERSION = 1.00; # 8/12/2002, 10:14:13 PM
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);
}
# --------------------------------------------------------
# Exception::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;
}
# --------------------------------------------------------
# Exception::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 );
return($trace);
}
# --------------------------------------------------------
# Exception::Handler::DESTROY()
# --------------------------------------------------------
sub DESTROY {}
1;
package main;
use strict;
INIT { print(<<__OUT__) if $ENV{'REQUEST_METHOD'} }
Content-Type: text/html; charset=ISO-8859-1
<?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" />
<style
type="text/css"
xml:space="preserve">
<!--
HTML {
color: #000000;
background-color: #FFFFFF;
font-family: Verdana, sans-serif;
}
BODY {
margin: 0px;
padding: 0px 0px 40px 20px;
color: #000000;
background-color: #FFFFFF;
font-family: Verdana, sans-serif;
font-size: 13px;
}
PRE {
margin: 0px;
padding: 0px;
font-family: Lucida Console, Courier New, Courier, monospace;
font-size: 11px;
}
-->
</style>
</head>
<body>
<p> </p>
<div
style="
font-size: 18px;
font-weight: bold;
padding: 0 0 15px 0;">
Gathering data... *(this could take several seconds)*
</div>
<div
style="
font-size: 32px;
font-weight: bold;
padding: 15px 0 15px 0;">
perl binary details
</div>
<div>
<pre>
__OUT__
$main::ldh = sub {
print(q[<!-- no timeout -->])
if $ENV{'REQUEST_METHOD'};
undef;
};
my($m) = qr/\.pm$/; my($V) = qr/VERSION(?:\s){0,}\=(?:\s){0,}(['"._\d]+?)\;/;
my($f) = {}; $f = Futils->new(); my(@o) = (); @o = `perl -v`; my($o) = '';
push(@o,$Futils::n x 2,`perl -V`, $Futils::n x 2); $o = join('',@o); undef(@o);
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]'; $o .= qq[$_ => $con{$_}] . $Futils::n;
}
else { $o .= qq[$_ => $con{$_}] . $Futils::n; }
}
else { $o .= qq[$_ => [undefined]] . $Futils::n; }
}
}
else {
$o .= $Futils::n
. q[%Config::Config not defined or unavailable.]
. $Futils::n;
}
$Futils::maxdepth = 1000;
$o .= $Futils::n x 2
. q[@INC is ]
. join($Futils::n, @INC)
. $Futils::n x 2
. q[@INC CONTAINS...];
print($o) and undef($o);
my(@opts) = qw
(
--no-fancy
--follow
--no-fsdots
--with-paths
--sl-after-dirs
--as-list
);
my($nick) = '';
my($mods) = 0;
my($mver) = 0;
my($cut) = join('|',reverse(sort(@INC)));
my($cvr) = qr/[^ .0-9]/;
my($cvr2) = qr/(?: ){2,}/;
$cut = qr/^(?:$cut)$Futils::SL/;
foreach (@INC) {
next if ($_ eq '.');
next if ($f->strip_path($_) eq 'auto');
print
(
$Futils::n x 2
. q[ALL MODULES INSTALLED in ]
. $_
. $Futils::n
. '=' x 80
. $Futils::n
. q[NAME]
. ' ' x 56
. q[VERSION]
. $Futils::n
. '-' x 80
);
foreach ($f->list_dir($_,@opts),print($Futils::n)) {
if ($_ =~ /$m/) {
++$mods;
$nick = $_; $nick =~ s/$cut//; $nick =~ s/$Futils::dirsplit/\:\:/g;
print(sprintf('% -60s %s',$nick,get_ver($_)). $Futils::n);
}
}
print($Futils::n x 2);
}
print(join('',@o), <<__DONE__);
counted $mods installed modules.
@{[$mods - $mver]} modules did not have a parsable version number.
this page generated in approximately @{[
Handy::Dandy::CGItools::time_spent]} seconds
__DONE__
print(<<'__ENDHTML__') if $ENV{'REQUEST_METHOD'};
</pre>
</div>
<p> </p>
</body>
</html>
__ENDHTML__
exit;
sub get_ver {
my($file) = @_; my($buffer) = '';
my($v) = ''; my($lines) = 0;
$file ||= '';
warn(q[No file argument passed to get_ver()]) and return(undef)
unless ($file);
local(*VER);
sysopen(VER, $file, Fcntl::O_RDONLY())
or
Handy::Dandy::CGItools::cgi_error(<<__FOPEN__);
Problem gathering Perl module version data from \@INC.
<pre>
\$! = ($!)
\$@ = ($@)
\$? = ($?)
\$? >> 8 = (@{[$? >> 8]})
\$^E = ($^E)
<pre>
__FOPEN__
while (sysread(VER, $buffer, 512)) {
$lines += ($buffer =~ tr/$Futils::n//);
if ($buffer =~ m/$V/) {
$v = $1||'[bad match!]'; $v =~ s/$cvr//g; $v =~ s/$cvr2/ /g;
++$mver; close(VER) and return($v);
}
$buffer = ''; last if ($lines > 50);
}
close(VER) and return(q[ ?]);
}
# This software was written by Tommy Butler, 8/28/2002
# Copyright Tommy Butler, all rights reserved.