dslinux/user/perl/lib AnyDBM_File.pm AnyDBM_File.t AutoLoader.pm AutoLoader.t AutoSplit.pm AutoSplit.t Benchmark.pm Benchmark.t CGI.pm CPAN.pm Carp.pm Carp.t Config.t Cwd.pm DB.pm DB.t DBM_Filter.pm Digest.pm DirHandle.pm DirHandle.t Dumpvalue.pm Dumpvalue.t English.pm English.t Env.pm Exporter.pm Exporter.t Fatal.pm Fatal.t FileCache.pm FileHandle.pm FileHandle.t FindBin.pm FindBin.t Internals.t Memoize.pm NEXT.pm PerlIO.pm SelectSaver.pm SelectSaver.t SelfLoader.pm SelfLoader.t Shell.pm Shell.t Switch.pm Symbol.pm Symbol.t Test.pm Thread.pm UNIVERSAL.pm abbrev.pl assert.pl attributes.pm autouse.pm autouse.t base.pm bigfloat.pl bigfloatpl.t bigint.pl bigint.pm bigintpl.t bignum.pm bigrat.pl bigrat.pm blib.pm blib.t bytes.pm bytes.t bytes_heavy.pl cacheout.pl charnames.pm charnames.t complete.pl constant.pm constant.t ctime.pl dbm_filter_util.pl diagnostics.pm diagnostics.t dotsh.pl dumpvar.pl dumpvar.t exceptions.pl fastcwd.pl fields.pm filetest.pm filetest.t find.! pl finddepth.pl flush.pl getcwd.pl getopt.pl getopts.pl h2ph.t h2xs.t hostname.pl if.pm if.t importenv.pl integer.pm integer.t less.pm less.t lib.t lib_pm.PL locale.pm locale.t look.pl newgetopt.pl open.pm open.t open2.pl open3.pl overload.pm overload.t perl5db.pl ph.t pwd.pl shellwords.pl sigtrap.pm sigtrap.t sort.pm sort.t stat.pl strict.pm strict.t subs.pm subs.t syslog.pl tainted.pl termcap.pl timelocal.pl utf8.pm utf8.t utf8_heavy.pl validate.pl vars.pm vars.t vmsish.pm vmsish.t warnings.pm warnings.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:23 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/lib
In directory antilope:/tmp/cvs-serv17422/lib
Added Files:
AnyDBM_File.pm AnyDBM_File.t AutoLoader.pm AutoLoader.t
AutoSplit.pm AutoSplit.t Benchmark.pm Benchmark.t CGI.pm
CPAN.pm Carp.pm Carp.t Config.t Cwd.pm DB.pm DB.t
DBM_Filter.pm Digest.pm DirHandle.pm DirHandle.t Dumpvalue.pm
Dumpvalue.t English.pm English.t Env.pm Exporter.pm Exporter.t
Fatal.pm Fatal.t FileCache.pm FileHandle.pm FileHandle.t
FindBin.pm FindBin.t Internals.t Memoize.pm NEXT.pm PerlIO.pm
SelectSaver.pm SelectSaver.t SelfLoader.pm SelfLoader.t
Shell.pm Shell.t Switch.pm Symbol.pm Symbol.t Test.pm
Thread.pm UNIVERSAL.pm abbrev.pl assert.pl attributes.pm
autouse.pm autouse.t base.pm bigfloat.pl bigfloatpl.t
bigint.pl bigint.pm bigintpl.t bignum.pm bigrat.pl bigrat.pm
blib.pm blib.t bytes.pm bytes.t bytes_heavy.pl cacheout.pl
charnames.pm charnames.t complete.pl constant.pm constant.t
ctime.pl dbm_filter_util.pl diagnostics.pm diagnostics.t
dotsh.pl dumpvar.pl dumpvar.t exceptions.pl fastcwd.pl
fields.pm filetest.pm filetest.t find.pl finddepth.pl flush.pl
getcwd.pl getopt.pl getopts.pl h2ph.t h2xs.t hostname.pl if.pm
if.t importenv.pl integer.pm integer.t less.pm less.t lib.t
lib_pm.PL locale.pm locale.t look.pl newgetopt.pl open.pm
open.t open2.pl open3.pl overload.pm overload.t perl5db.pl
ph.t pwd.pl shellwords.pl sigtrap.pm sigtrap.t sort.pm sort.t
stat.pl strict.pm strict.t subs.pm subs.t syslog.pl tainted.pl
termcap.pl timelocal.pl utf8.pm utf8.t utf8_heavy.pl
validate.pl vars.pm vars.t vmsish.pm vmsish.t warnings.pm
warnings.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: Symbol.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use Test::More tests => 19;
BEGIN { $_ = 'foo'; } # because Symbol used to clobber $_
use Symbol;
ok( $_ eq 'foo', 'check $_ clobbering' );
# First test gensym()
$sym1 = gensym;
ok( ref($sym1) eq 'GLOB', 'gensym() returns a GLOB' );
$sym2 = gensym;
ok( $sym1 ne $sym2, 'gensym() returns a different GLOB' );
ungensym $sym1;
$sym1 = $sym2 = undef;
# Test geniosym()
use Symbol qw(geniosym);
$sym1 = geniosym;
like( $sym1, qr/=IO\(/, 'got an IO ref' );
$FOO = 'Eymascalar';
*FOO = $sym1;
is( $sym1, *FOO{IO}, 'assigns into glob OK' );
is( $FOO, 'Eymascalar', 'leaves scalar alone' );
{
local $^W=1; # 5.005 compat.
my $warn;
local $SIG{__WARN__} = sub { $warn .= "@_" };
readline FOO;
like( $warn, qr/unopened filehandle/, 'warns like an unopened filehandle' );
}
# Test qualify()
package foo;
use Symbol qw(qualify); # must import into this package too
::ok( qualify("x") eq "foo::x", 'qualify() with a simple identifier' );
::ok( qualify("x", "FOO") eq "FOO::x", 'qualify() with a package' );
::ok( qualify("BAR::x") eq "BAR::x",
'qualify() with a qualified identifier' );
::ok( qualify("STDOUT") eq "main::STDOUT",
'qualify() with a reserved identifier' );
::ok( qualify("ARGV", "FOO") eq "main::ARGV",
'qualify() with a reserved identifier and a package' );
::ok( qualify("_foo") eq "foo::_foo",
'qualify() with an identifier starting with a _' );
::ok( qualify("^FOO") eq "main::\cFOO",
'qualify() with an identifier starting with a ^' );
# tests for delete_package
package main;
$Transient::variable = 42;
ok( exists $::{'Transient::'}, 'transient stash exists' );
ok( defined $Transient::{variable}, 'transient variable in stash' );
Symbol::delete_package('Transient');
ok( !exists $Transient::{variable}, 'transient variable no longer in stash' );
is( scalar(keys %Transient::), 0, 'transient stash is empty' );
ok( !exists $::{'Transient::'}, 'no transient stash' );
--- NEW FILE: DirHandle.pm ---
package DirHandle;
our $VERSION = '1.00';
=head1 NAME
DirHandle - supply object methods for directory handles
=head1 SYNOPSIS
use DirHandle;
$d = new DirHandle ".";
if (defined $d) {
while (defined($_ = $d->read)) { something($_); }
$d->rewind;
while (defined($_ = $d->read)) { something_else($_); }
undef $d;
}
=head1 DESCRIPTION
The C<DirHandle> method provide an alternative interface to the
opendir(), closedir(), readdir(), and rewinddir() functions.
The only objective benefit to using C<DirHandle> is that it avoids
namespace pollution by creating globs to hold directory handles.
=head1 NOTES
=over 4
=item *
On Mac OS (Classic), the path separator is ':', not '/', and the
current directory is denoted as ':', not '.'. You should be careful
about specifying relative pathnames. While a full path always begins
with a volume name, a relative pathname should always begin with a
':'. If specifying a volume name only, a trailing ':' is required.
=back
=cut
require 5.000;
use Carp;
use Symbol;
sub new {
@_ >= 1 && @_ <= 2 or croak 'usage: new DirHandle [DIRNAME]';
my $class = shift;
my $dh = gensym;
if (@_) {
DirHandle::open($dh, $_[0])
or return undef;
}
bless $dh, $class;
}
sub DESTROY {
my ($dh) = @_;
closedir($dh);
}
sub open {
@_ == 2 or croak 'usage: $dh->open(DIRNAME)';
my ($dh, $dirname) = @_;
opendir($dh, $dirname);
}
sub close {
@_ == 1 or croak 'usage: $dh->close()';
my ($dh) = @_;
closedir($dh);
}
sub read {
@_ == 1 or croak 'usage: $dh->read()';
my ($dh) = @_;
readdir($dh);
}
sub rewind {
@_ == 1 or croak 'usage: $dh->rewind()';
my ($dh) = @_;
rewinddir($dh);
}
1;
--- NEW FILE: less.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
push @INC, '../lib';
}
use Test::More tests => 1;
use_ok( 'less' );
--- NEW FILE: open.pm ---
package open;
use warnings;
use Carp;
$open::hint_bits = 0x20000; # HINT_LOCALIZE_HH
our $VERSION = '1.05';
require 5.008001; # for PerlIO::get_layers()
my $locale_encoding;
sub _get_encname {
return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/;
return;
}
sub _drop_oldenc {
# If by the time we arrive here there already is at the top of the
# perlio layer stack an encoding identical to what we would like
# to push via this open pragma, we will pop away the old encoding
# (+utf8) so that we can push ourselves in place (this is easier
# than ignoring pushing ourselves because of the way how ${^OPEN}
# works). So we are looking for something like
#
# stdio encoding(xxx) utf8
#
# in the existing layer stack, and in the new stack chunk for
#
# :encoding(xxx)
#
# If we find a match, we pop the old stack (once, since
# the utf8 is just a flag on the encoding layer)
my ($h, @new) = @_;
return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/;
my @old = PerlIO::get_layers($h);
return unless @old >= 3 &&
$old[-1] eq 'utf8' &&
$old[-2] =~ /^encoding\(.+\)$/;
require Encode;
my ($loname, $lcname) = _get_encname($old[-2]);
unless (defined $lcname) { # Should we trust get_layers()?
require Carp;
Carp::croak("open: Unknown encoding '$loname'");
}
my ($voname, $vcname) = _get_encname($new[-1]);
unless (defined $vcname) {
require Carp;
Carp::croak("open: Unknown encoding '$voname'");
}
if ($lcname eq $vcname) {
binmode($h, ":pop"); # utf8 is part of the encoding layer
}
}
sub import {
my ($class, at args) = @_;
croak("open: needs explicit list of PerlIO layers") unless @args;
my $std;
$^H |= $open::hint_bits;
my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
while (@args) {
my $type = shift(@args);
my $dscp;
if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
$type = 'IO';
$dscp = ":$1";
} elsif ($type eq ':std') {
$std = 1;
next;
} else {
$dscp = shift(@args) || '';
}
my @val;
foreach my $layer (split(/\s+/,$dscp)) {
$layer =~ s/^://;
if ($layer eq 'locale') {
require Encode;
require encoding;
$locale_encoding = encoding::_get_locale_encoding()
unless defined $locale_encoding;
(warnings::warnif("layer", "Cannot figure out an encoding to use"), last)
unless defined $locale_encoding;
if ($locale_encoding =~ /^utf-?8$/i) {
$layer = "utf8";
} else {
$layer = "encoding($locale_encoding)";
}
$std = 1;
} else {
my $target = $layer; # the layer name itself
$target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters
unless(PerlIO::Layer::->find($target,1)) {
warnings::warnif("layer", "Unknown PerlIO layer '$target'");
}
}
push(@val,":$layer");
if ($layer =~ /^(crlf|raw)$/) {
$^H{"open_$type"} = $layer;
}
}
if ($type eq 'IN') {
_drop_oldenc(*STDIN, @val);
$in = join(' ', @val);
}
elsif ($type eq 'OUT') {
_drop_oldenc(*STDOUT, @val);
$out = join(' ', @val);
}
elsif ($type eq 'IO') {
_drop_oldenc(*STDIN, @val);
_drop_oldenc(*STDOUT, @val);
$in = $out = join(' ', @val);
}
else {
croak "Unknown PerlIO layer class '$type'";
}
}
${^OPEN} = join("\0", $in, $out);
if ($std) {
if ($in) {
if ($in =~ /:utf8\b/) {
binmode(STDIN, ":utf8");
} elsif ($in =~ /(\w+\(.+\))/) {
binmode(STDIN, ":$1");
}
}
if ($out) {
if ($out =~ /:utf8\b/) {
binmode(STDOUT, ":utf8");
binmode(STDERR, ":utf8");
} elsif ($out =~ /(\w+\(.+\))/) {
binmode(STDOUT, ":$1");
binmode(STDERR, ":$1");
}
}
}
}
1;
__END__
=head1 NAME
open - perl pragma to set default PerlIO layers for input and output
=head1 SYNOPSIS
use open IN => ":crlf", OUT => ":bytes";
use open OUT => ':utf8';
use open IO => ":encoding(iso-8859-7)";
use open IO => ':locale';
use open ':utf8';
use open ':locale';
use open ':encoding(iso-8859-7)';
use open ':std';
=head1 DESCRIPTION
Full-fledged support for I/O layers is now implemented provided
Perl is configured to use PerlIO as its IO system (which is now the
default).
The C<open> pragma serves as one of the interfaces to declare default
"layers" (also known as "disciplines") for all I/O. Any two-argument
open(), readpipe() (aka qx//) and similar operators found within the
lexical scope of this pragma will use the declared defaults.
Even three-argument opens may be affected by this pragma
when they don't specify IO layers in MODE.
With the C<IN> subpragma you can declare the default layers
of input streams, and with the C<OUT> subpragma you can declare
the default layers of output streams. With the C<IO> subpragma
you can control both input and output streams simultaneously.
If you have a legacy encoding, you can use the C<:encoding(...)> tag.
If you want to set your encoding layers based on your
locale environment variables, you can use the C<:locale> tag.
For example:
$ENV{LANG} = 'ru_RU.KOI8-R';
# the :locale will probe the locale environment variables like LANG
use open OUT => ':locale';
open(O, ">koi8");
print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
close O;
open(I, "<koi8");
printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
close I;
These are equivalent
use open ':utf8';
use open IO => ':utf8';
as are these
use open ':locale';
use open IO => ':locale';
and these
use open ':encoding(iso-8859-7)';
use open IO => ':encoding(iso-8859-7)';
The matching of encoding names is loose: case does not matter, and
many encodings have several aliases. See L<Encode::Supported> for
details and the list of supported locales.
Note that C<:utf8> PerlIO layer must always be specified exactly like
that, it is not subject to the loose matching of encoding names.
When open() is given an explicit list of layers (with the three-arg
syntax), they override the list declared using this pragma.
The C<:std> subpragma on its own has no effect, but if combined with
the C<:utf8> or C<:encoding> subpragmas, it converts the standard
filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
for input/output handles. For example, if both input and out are
chosen to be C<:utf8>, a C<:std> will mean that STDIN, STDOUT, and
STDERR are also in C<:utf8>. On the other hand, if only output is
chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the
STDOUT and STDERR to be in C<koi8r>. The C<:locale> subpragma
implicitly turns on C<:std>.
The logic of C<:locale> is described in full in L<encoding>,
but in short it is first trying nl_langinfo(CODESET) and then
guessing from the LC_ALL and LANG locale environment variables.
Directory handles may also support PerlIO layers in the future.
=head1 NONPERLIO FUNCTIONALITY
If Perl is not built to use PerlIO as its IO system then only the two
pseudo-layers C<:bytes> and C<:crlf> are available.
The C<:bytes> layer corresponds to "binary mode" and the C<:crlf>
layer corresponds to "text mode" on platforms that distinguish
between the two modes when opening files (which is many DOS-like
platforms, including Windows). These two layers are no-ops on
platforms where binmode() is a no-op, but perform their functions
everywhere if PerlIO is enabled.
=head1 IMPLEMENTATION DETAILS
There is a class method in C<PerlIO::Layer> C<find> which is
implemented as XS code. It is called by C<import> to validate the
layers:
PerlIO::Layer::->find("perlio")
The return value (if defined) is a Perl object, of class
C<PerlIO::Layer> which is created by the C code in F<perlio.c>. As
yet there is nothing useful you can do with the object at the perl
level.
=head1 SEE ALSO
L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
L<encoding>
=cut
--- NEW FILE: autouse.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config;
if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
print "1..0 # Skip -- Perl configured without List::Util module\n";
exit 0;
}
}
use Test;
BEGIN { plan tests => 10; }
BEGIN {
require autouse;
eval {
"autouse"->import('List::Util' => 'List::Util::first(&@)');
};
ok( !$@ );
eval {
"autouse"->import('List::Util' => 'Foo::min');
};
ok( $@, qr/^autouse into different package attempted/ );
"autouse"->import('List::Util' => qw(max first(&@)));
}
my @a = (1,2,3,4,5.5);
ok( max(@a), 5.5);
# first() has a prototype of &@. Make sure that's preserved.
ok( (first { $_ > 3 } @a), 4);
# Example from the docs.
use autouse 'Carp' => qw(carp croak);
{
my @warning;
local $SIG{__WARN__} = sub { push @warning, @_ };
carp "this carp was predeclared and autoused\n";
ok( scalar @warning, 1 );
ok( $warning[0], qr/^this carp was predeclared and autoused\n/ );
eval { croak "It is but a scratch!" };
ok( $@, qr/^It is but a scratch!/);
}
# Test that autouse's lazy module loading works. We assume that nothing
# involved in this test uses Text::Soundex, which is pretty safe.
use autouse 'Text::Soundex' => qw(soundex);
my $mod_file = 'Text/Soundex.pm'; # just fine and portable for %INC
ok( !exists $INC{$mod_file} );
ok( soundex('Basset'), 'B230' );
ok( exists $INC{$mod_file} );
--- NEW FILE: UNIVERSAL.pm ---
package UNIVERSAL;
our $VERSION = '1.01';
# UNIVERSAL should not contain any extra subs/methods beyond those
# that it exists to define. The use of Exporter below is a historical
# accident that can't be fixed without breaking code. Note that we
# *don't* set @ISA here, don't want all classes/objects inheriting from
# Exporter. It's bad enough that all classes have a import() method
# whenever UNIVERSAL.pm is loaded.
require Exporter;
*import = \&Exporter::import;
@EXPORT_OK = qw(isa can VERSION);
1;
__END__
=head1 NAME
UNIVERSAL - base class for ALL classes (blessed references)
=head1 SYNOPSIS
$is_io = $fd->isa("IO::Handle");
$is_io = Class->isa("IO::Handle");
$sub = $obj->can("print");
$sub = Class->can("print");
use UNIVERSAL qw( isa can VERSION );
$yes = isa $ref, "HASH" ;
$sub = can $ref, "fandango" ;
$ver = VERSION $obj ;
=head1 DESCRIPTION
C<UNIVERSAL> is the base class which all bless references will inherit from,
see L<perlobj>.
C<UNIVERSAL> provides the following methods and functions:
=over 4
=item C<< $obj->isa( TYPE ) >>
=item C<< CLASS->isa( TYPE ) >>
=item C<isa( VAL, TYPE )>
Where
=over 4
=item C<TYPE>
is a package name
=item C<$obj>
is a blessed reference or a string containing a package name
=item C<CLASS>
is a package name
=item C<VAL>
is any of the above or an unblessed reference
=back
When used as an instance or class method (C<< $obj->isa( TYPE ) >>),
C<isa> returns I<true> if $obj is blessed into package C<TYPE> or
inherits from package C<TYPE>.
When used as a class method (C<< CLASS->isa( TYPE ) >>: sometimes
referred to as a static method), C<isa> returns I<true> if C<CLASS>
inherits from (or is itself) the name of the package C<TYPE> or
inherits from package C<TYPE>.
When used as a function, like
use UNIVERSAL qw( isa ) ;
$yes = isa $h, "HASH";
$yes = isa "Foo", "Bar";
or
require UNIVERSAL ;
$yes = UNIVERSAL::isa $a, "ARRAY";
C<isa> returns I<true> in the same cases as above and also if C<VAL> is an
unblessed reference to a perl variable of type C<TYPE>, such as "HASH",
"ARRAY", or "Regexp".
=item C<< $obj->can( METHOD ) >>
=item C<< CLASS->can( METHOD ) >>
=item C<can( VAL, METHOD )>
C<can> checks if the object or class has a method called C<METHOD>. If it does
then a reference to the sub is returned. If it does not then I<undef> is
returned. This includes methods inherited or imported by C<$obj>, C<CLASS>, or
C<VAL>.
C<can> cannot know whether an object will be able to provide a method
through AUTOLOAD, so a return value of I<undef> does not necessarily mean
the object will not be able to handle the method call. To get around
this some module authors use a forward declaration (see L<perlsub>)
for methods they will handle via AUTOLOAD. For such 'dummy' subs, C<can>
will still return a code reference, which, when called, will fall through
to the AUTOLOAD. If no suitable AUTOLOAD is provided, calling the coderef
will cause an error.
C<can> can be called as a class (static) method, an object method, or a
function.
When used as a function, if C<VAL> is a blessed reference or package name which
has a method called C<METHOD>, C<can> returns a reference to the subroutine.
If C<VAL> is not a blessed reference, or if it does not have a method
C<METHOD>, I<undef> is returned.
=item C<VERSION ( [ REQUIRE ] )>
C<VERSION> will return the value of the variable C<$VERSION> in the
package the object is blessed into. If C<REQUIRE> is given then
it will do a comparison and die if the package version is not
greater than or equal to C<REQUIRE>.
C<VERSION> can be called as either a class (static) method, an object
method or a function.
=back
=head1 EXPORTS
None by default.
You may request the import of all three functions (C<isa>, C<can>, and
C<VERSION>), however it isn't usually necessary to do so. Perl magically
makes these functions act as methods on all objects. The one exception is
C<isa>, which is useful as a function when operating on non-blessed
references.
=cut
--- NEW FILE: locale.pm ---
package locale;
our $VERSION = '1.00';
=head1 NAME
locale - Perl pragma to use and avoid POSIX locales for built-in operations
=head1 SYNOPSIS
@x = sort @y; # ASCII sorting order
{
use locale;
@x = sort @y; # Locale-defined sorting order
}
@x = sort @y; # ASCII sorting order again
=head1 DESCRIPTION
This pragma tells the compiler to enable (or disable) the use of POSIX
locales for built-in operations (LC_CTYPE for regular expressions, and
LC_COLLATE for string comparison). Each "use locale" or "no locale"
affects statements to the end of the enclosing BLOCK.
See L<perllocale> for more detailed information on how Perl supports
locales.
=cut
$locale::hint_bits = 0x4;
sub import {
$^H |= $locale::hint_bits;
}
sub unimport {
$^H &= ~$locale::hint_bits;
}
1;
--- NEW FILE: getopts.pl ---
;# getopts.pl - a better getopt.pl
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternatives: Getopt::Long or Getopt::Std
#
;# Usage:
;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
;# # side effect.
sub Getopts {
local($argumentative) = @_;
local(@args,$_,$first,$rest);
local($errs) = 0;
local($[) = 0;
@args = split( / */, $argumentative );
while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
($first,$rest) = ($1,$2);
$pos = index($argumentative,$first);
if($pos >= $[) {
if($args[$pos+1] eq ':') {
shift(@ARGV);
if($rest eq '') {
++$errs unless(@ARGV);
$rest = shift(@ARGV);
}
eval "
push(\@opt_$first, \$rest);
if (!defined \$opt_$first or \$opt_$first eq '') {
\$opt_$first = \$rest;
}
else {
\$opt_$first .= ' ' . \$rest;
}
";
}
else {
eval "\$opt_$first = 1";
if($rest eq '') {
shift(@ARGV);
}
else {
$ARGV[0] = "-$rest";
}
}
}
else {
print STDERR "Unknown option: $first\n";
++$errs;
if($rest ne '') {
$ARGV[0] = "-$rest";
}
else {
shift(@ARGV);
}
}
}
$errs == 0;
}
1;
--- NEW FILE: bytes_heavy.pl ---
package bytes;
sub length ($) {
BEGIN { bytes::import() }
return CORE::length($_[0]);
}
sub substr ($$;$$) {
BEGIN { bytes::import() }
return
@_ == 2 ? CORE::substr($_[0], $_[1]) :
@_ == 3 ? CORE::substr($_[0], $_[1], $_[2]) :
CORE::substr($_[0], $_[1], $_[2], $_[3]) ;
}
sub ord ($) {
BEGIN { bytes::import() }
return CORE::ord($_[0]);
}
sub chr ($) {
BEGIN { bytes::import() }
return CORE::chr($_[0]);
}
sub index ($$;$) {
BEGIN { bytes::import() }
return
@_ == 2 ? CORE::index($_[0], $_[1]) :
CORE::index($_[0], $_[1], $_[2]) ;
}
sub rindex ($$;$) {
BEGIN { bytes::import() }
return
@_ == 2 ? CORE::rindex($_[0], $_[1]) :
CORE::rindex($_[0], $_[1], $_[2]) ;
}
1;
--- NEW FILE: dumpvar.t ---
#!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*-
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config;
if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
print "1..0 # Skip -- Perl configured without List::Util module\n";
exit 0;
}
}
use strict;
$|=1;
my @prgs;
{
local $/;
@prgs = split "########\n", <DATA>;
close DATA;
}
use Test::More;
plan tests => scalar @prgs;
require "dumpvar.pl";
sub unctrl { print dumpvar::unctrl($_[0]), "\n" }
sub uniescape { print dumpvar::uniescape($_[0]), "\n" }
sub stringify { print dumpvar::stringify($_[0]), "\n" }
sub dumpvalue {
# Call main::dumpValue exactly as the perl5db.pl calls it.
local $\ = '';
local $, = '';
local $" = ' ';
my @params = @_;
&main::dumpValue(\@params,-1);
}
package Foo;
sub new { my $class = shift; bless [ @_ ], $class }
package Bar;
sub new { my $class = shift; bless [ @_ ], $class }
use overload '""' => sub { "Bar<@{$_[0]}>" };
package main;
my $foo = Foo->new(1..5);
my $bar = Bar->new(1..5);
for (@prgs) {
my($prog, $expected) = split(/\nEXPECT\n?/, $_);
# TODO: dumpvar::stringify() is controlled by a pile of package
# dumpvar variables: $printUndef, $unctrl, $quoteHighBit, $bareStringify,
# and so forth. We need to test with various settings of those.
my $out = tie *STDOUT, 'TieOut';
eval $prog;
my $ERR = $@;
untie $out;
if ($ERR) {
ok(0, "$prog - $ERR");
} else {
if ($expected =~ m:^/:) {
like($$out, $expected, $prog);
} else {
is($$out, $expected, $prog);
}
}
}
package TieOut;
sub TIEHANDLE {
bless( \(my $self), $_[0] );
}
sub PRINT {
my $self = shift;
$$self .= join('', @_);
}
sub read {
my $self = shift;
substr( $$self, 0, length($$self), '' );
}
__END__
unctrl("A");
EXPECT
A
########
unctrl("\cA");
EXPECT
^A
########
uniescape("A");
EXPECT
A
########
uniescape("\x{100}");
EXPECT
\x{0100}
########
stringify(undef);
EXPECT
undef
########
stringify("foo");
EXPECT
'foo'
########
stringify("\cA");
EXPECT
"\cA"
########
stringify(*a);
EXPECT
*main::a
########
stringify(\undef);
EXPECT
/^'SCALAR\(0x[0-9a-f]+\)'$/i
########
stringify([]);
EXPECT
/^'ARRAY\(0x[0-9a-f]+\)'$/i
########
stringify({});
EXPECT
/^'HASH\(0x[0-9a-f]+\)'$/i
########
stringify(sub{});
EXPECT
/^'CODE\(0x[0-9a-f]+\)'$/i
########
stringify(\*a);
EXPECT
/^'GLOB\(0x[0-9a-f]+\)'$/i
########
stringify($foo);
EXPECT
/^'Foo=ARRAY\(0x[0-9a-f]+\)'$/i
########
stringify($bar);
EXPECT
/^'Bar=ARRAY\(0x[0-9a-f]+\)'$/i
########
dumpValue(undef);
EXPECT
undef
########
dumpValue(1);
EXPECT
1
########
dumpValue("\cA");
EXPECT
"\cA"
########
dumpValue("\x{100}");
EXPECT
'\x{0100}'
########
dumpValue("1\n2\n3");
EXPECT
'1
2
3'
########
dumpValue([1..3],1);
EXPECT
0 1
1 2
2 3
########
dumpValue([1..3]);
EXPECT
0 1
1 2
2 3
########
dumpValue({1..4},1);
EXPECT
1 => 2
3 => 4
########
dumpValue({1..4});
EXPECT
1 => 2
3 => 4
########
dumpValue($foo,1);
EXPECT
0 1
1 2
2 3
3 4
4 5
########
dumpValue($foo);
EXPECT
0 1
1 2
2 3
3 4
4 5
########
dumpValue($bar,1);
EXPECT
0 1
1 2
2 3
3 4
4 5
########
dumpValue($bar);
EXPECT
0 1
1 2
2 3
3 4
4 5
########
dumpvalue("a");
EXPECT
0 'a'
########
dumpvalue("\cA");
EXPECT
0 "\cA"
########
dumpvalue("\x{100}");
EXPECT
0 '\x{0100}'
########
dumpvalue(undef);
EXPECT
0 undef
########
dumpvalue("foo");
EXPECT
0 'foo'
########
dumpvalue(\undef);
EXPECT
/0 SCALAR\(0x[0-9a-f]+\)\n -> undef\n/i
########
dumpvalue(\\undef);
EXPECT
/0 REF\(0x[0-9a-f]+\)\n -> SCALAR\(0x[0-9a-f]+\)\n -> undef\n/i
########
dumpvalue([]);
EXPECT
/0 ARRAY\(0x[0-9a-f]+\)\n empty array/i
########
dumpvalue({});
EXPECT
/0 HASH\(0x[0-9a-f]+\)\n\s+empty hash/i
########
dumpvalue(sub{});
EXPECT
/0 CODE\(0x[0-9a-f]+\)\n -> &CODE\(0x[0-9a-f]+\) in /i
########
dumpvalue(\*a);
EXPECT
/0 GLOB\(0x[0-9a-f]+\)\n -> \*main::a\n/i
########
dumpvalue($foo);
EXPECT
/0 Foo=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n 4 5\n/i
########
dumpvalue($bar);
EXPECT
/0 Bar=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n 4 5\n/i
########
dumpvalue("1\n2\n3")
EXPECT
/0 '1\n2\n3'\n/i
########
dumpvalue([1..4]);
EXPECT
/0 ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n/i
########
dumpvalue({1..4});
EXPECT
/0 HASH\(0x[0-9a-f]+\)\n 1 => 2\n 3 => 4\n/i
########
dumpvalue({1=>2,3=>4});
EXPECT
/0 HASH\(0x[0-9a-f]+\)\n 1 => 2\n 3 => 4\n/i
########
dumpvalue({a=>1,b=>2});
EXPECT
/0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i
########
dumpvalue([{a=>[1,2,3],b=>{c=>1,d=>2}},{e=>{f=>1,g=>2},h=>[qw(i j k)]}]);
EXPECT
/0 ARRAY\(0x[0-9a-f]+\)\n 0 HASH\(0x[0-9a-f]+\)\n 'a' => ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 'b' => HASH\(0x[0-9a-f]+\)\n 'c' => 1\n 'd' => 2\n 1 HASH\(0x[0-9a-f]+\)\n 'e' => HASH\(0x[0-9a-f]+\)\n 'f' => 1\n 'g' => 2\n 'h' => ARRAY\(0x[0-9a-f]+\)\n 0 'i'\n 1 'j'\n 2 'k'/i
########
dumpvalue({reverse map {$_=>1} sort qw(the quick brown fox)})
EXPECT
/0 HASH\(0x[0-9a-f]+\)\n 1 => 'brown'\n/i
########
my @x=qw(a b c); dumpvalue(\@x);
EXPECT
/0 ARRAY\(0x[0-9a-f]+\)\n 0 'a'\n 1 'b'\n 2 'c'\n/i
########
my %x=(a=>1, b=>2); dumpvalue(\%x);
EXPECT
/0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i
--- NEW FILE: AnyDBM_File.pm ---
package AnyDBM_File;
use 5.006_001;
our $VERSION = '1.00';
our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA;
my $mod;
for $mod (@ISA) {
if (eval "require $mod") {
@ISA = ($mod); # if we leave @ISA alone, warnings abound
return 1;
}
}
die "No DBM package was successfully found or installed";
#return 0;
=head1 NAME
AnyDBM_File - provide framework for multiple DBMs
NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations
=head1 SYNOPSIS
use AnyDBM_File;
=head1 DESCRIPTION
This module is a "pure virtual base class"--it has nothing of its own.
It's just there to inherit from one of the various DBM packages. It
prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See
L<DB_File>), GDBM, SDBM (which is always there--it comes with Perl), and
finally ODBM. This way old programs that used to use NDBM via dbmopen()
can still do so, but new ones can reorder @ISA:
BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
use AnyDBM_File;
Having multiple DBM implementations makes it trivial to copy database formats:
use POSIX; use NDBM_File; use DB_File;
tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR;
tie %oldhash, 'NDBM_File', $old_filename, 1, 0;
%newhash = %oldhash;
=head2 DBM Comparisons
Here's a partial table of features the different packages offer:
odbm ndbm sdbm gdbm bsd-db
---- ---- ---- ---- ------
Linkage comes w/ perl yes yes yes yes yes
Src comes w/ perl no no yes no no
Comes w/ many unix os yes yes[0] no no no
Builds ok on !unix ? ? yes yes ?
Code Size ? ? small big big
Database Size ? ? small big? ok[1]
Speed ? ? slow ok fast
FTPable no no yes yes yes
Easy to build N/A N/A yes yes ok[2]
Size limits 1k 4k 1k[3] none none
Byte-order independent no no no no yes
Licensing restrictions ? ? no yes no
=over 4
=item [0]
on mixed universe machines, may be in the bsd compat library,
which is often shunned.
=item [1]
Can be trimmed if you compile for one access method.
=item [2]
See L<DB_File>.
Requires symbolic links.
=item [3]
By default, but can be redefined.
=back
=head1 SEE ALSO
dbm(3), ndbm(3), DB_File(3), L<perldbmfilter>
=cut
--- NEW FILE: Carp.t ---
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
my $Is_VMS = $^O eq 'VMS';
use Carp qw(carp cluck croak confess);
plan tests => 21;
ok 1;
{ local $SIG{__WARN__} = sub {
like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n' };
carp "ok 2\n";
}
{ local $SIG{__WARN__} = sub {
like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3' };
carp 3;
}
sub sub_4 {
local $SIG{__WARN__} = sub {
like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/, 'cluck 4' };
cluck 4;
}
sub_4;
{ local $SIG{__DIE__} = sub {
like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/, 'croak 5' };
eval { croak 5 };
}
sub sub_6 {
local $SIG{__DIE__} = sub {
like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at.+\b(?i:carp\.t) line \d+$/, 'confess 6' };
eval { confess 6 };
}
sub_6;
ok(1);
# test for caller_info API
my $eval = "use Carp::Heavy; return Carp::caller_info(0);";
my %info = eval($eval);
is($info{sub_name}, "eval '$eval'", 'caller_info API');
# test for '...::CARP_NOT used only once' warning from Carp::Heavy
my $warning;
eval {
BEGIN {
$^W = 1;
local $SIG{__WARN__} =
sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } }
}
package Z;
BEGIN { eval { Carp::croak() } }
};
ok !$warning, q/'...::CARP_NOT used only once' warning from Carp::Heavy/;
# tests for global variables
sub x { carp @_ }
sub w { cluck @_ }
# $Carp::Verbose;
{ my $aref = [
qr/t at \S*(?i:carp.t) line \d+/,
qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/
];
my $i = 0;
for my $re (@$aref) {
local $Carp::Verbose = $i++;
local $SIG{__WARN__} = sub {
like $_[0], $re, 'Verbose';
};
package Z;
main::x('t');
}
}
# $Carp::MaxEvalLen
{ my $test_num = 1;
for(0,4) {
my $txt = "Carp::cluck($test_num)";
local $Carp::MaxEvalLen = $_;
local $SIG{__WARN__} = sub {
"@_"=~/'(.+?)(?:\n|')/s;
is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen';
};
eval "$txt"; $test_num++;
}
}
# $Carp::MaxArgLen
{
for(0,4) {
my $arg = 'testtest';
local $Carp::MaxArgLen = $_;
local $SIG{__WARN__} = sub {
"@_"=~/'(.+?)'/;
is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen';
};
package Z;
main::w($arg);
}
}
# $Carp::MaxArgNums
{ my $i = 0;
my $aref = [
qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, 3, 4\) called at \S*(?i:carp.t) line \d+/,
qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/,
];
for(@$aref) {
local $Carp::MaxArgNums = $i++;
local $SIG{__WARN__} = sub {
like "@_", $_, 'MaxArgNums';
};
package Z;
main::w(1..4);
}
}
# $Carp::CarpLevel
{ my $i = 0;
my $aref = [
qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/,
qr/1 at \S*(?i:carp.t) line \d+$/,
];
for (@$aref) {
local $Carp::CarpLevel = $i++;
local $SIG{__WARN__} = sub {
like "@_", $_, 'CarpLevel';
};
package Z;
main::w(1);
}
}
{
local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
# Check that croak() and confess() don't clobber $!
runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
stderr => 1);
is($?>>8, 42, 'croak() doesn\'t clobber $!');
runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
stderr => 1);
is($?>>8, 42, 'confess() doesn\'t clobber $!');
}
--- NEW FILE: AnyDBM_File.t ---
#!./perl
# $RCSfile: AnyDBM_File.t,v $$Revision: 1.1 $$Date: 2006-12-04 17:00:05 $
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
require Test::More; import Test::More;
plan(tests, 12);
}
require AnyDBM_File;
use Fcntl;
$Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' ||
$^O eq 'NetWare' || $^O eq 'dos' ||
$^O eq 'os2' || $^O eq 'mint' ||
$^O eq 'cygwin');
unlink <Op_dbmx*>;
umask(0);
ok( tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640), "Tie");
$Dfile = "Op_dbmx.pag";
if (! -e $Dfile) {
($Dfile) = <Op_dbmx*>;
}
SKIP:
{
skip( "different file permission semantics",1)
if ($Is_Dosish || $^O eq 'MacOS') ;
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($Dfile);
ok(($mode & 0777) == ($^O eq 'vos' ? 0750 : 0640) , "File permissions");
}
while (($key,$value) = each(%h)) {
$i++;
}
ok(!$i,"Hash created empty");
$h{'goner1'} = 'snork';
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
$h{'jkl','mno'} = "JKL\034MNO";
$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
$h{'a'} = 'A';
$h{'b'} = 'B';
$h{'c'} = 'C';
$h{'d'} = 'D';
$h{'e'} = 'E';
$h{'f'} = 'F';
$h{'g'} = 'G';
$h{'h'} = 'H';
$h{'i'} = 'I';
$h{'goner2'} = 'snork';
delete $h{'goner2'};
untie(%h);
ok(tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR, 0640),"Re-tie hash");
$h{'j'} = 'J';
$h{'k'} = 'K';
$h{'l'} = 'L';
$h{'m'} = 'M';
$h{'n'} = 'N';
$h{'o'} = 'O';
$h{'p'} = 'P';
$h{'q'} = 'Q';
$h{'r'} = 'R';
$h{'s'} = 'S';
$h{'t'} = 'T';
$h{'u'} = 'U';
$h{'v'} = 'V';
$h{'w'} = 'W';
$h{'x'} = 'X';
$h{'y'} = 'Y';
$h{'z'} = 'Z';
$h{'goner3'} = 'snork';
delete $h{'goner1'};
delete $h{'goner3'};
@keys = keys(%h);
@values = values(%h);
ok( ($#keys == 29 && $#values == 29),'$#keys == $#values');
while (($key,$value) = each(%h)) {
if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
}
}
ok($i == 30,"keys and values match");
@keys = ('blurfl', keys(%h), 'dyick');
ok($#keys == 31,"Correct number of keys");
$h{'foo'} = '';
$h{''} = 'bar';
# check cache overflow and numeric keys and contents
$ok = 1;
for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
ok($ok, "cache overflow and numeric keys and contents");
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($Dfile);
ok($size > 0, "check file size");
@h{0..200} = 200..400;
@foo = @h{0..200};
ok( join(':',200..400) eq join(':', at foo), "hash slice");
ok($h{'foo'} eq '', "empty value");
my $compact = '';
if ($AnyDBM_File::ISA[0] eq 'DB_File' && ($DB_File::db_ver >= 2.004010 && $DB_File::db_ver < 3.001)) {
($major, $minor, $patch) = ($DB_File::db_ver =~ /^(\d+)\.(\d\d\d)(\d\d\d)/) ;
$major =~ s/^0+// ;
$minor =~ s/^0+// ;
$patch =~ s/^0+// ;
$compact = "$major.$minor.$patch" ;
#
# anydbm.t test 12 will fail when AnyDBM_File uses the combination of
# DB_File and Berkeley DB 2.4.10 (or greater).
# You are using DB_File $DB_File::VERSION and Berkeley DB $compact
#
# Berkeley DB 2 from version 2.4.10 onwards does not allow null keys.
# This feature returned with version 3.1
#
}
SKIP:
{
skip( "db v$compact, no null key support", 1) if $compact;
ok($h{''} eq 'bar','null key');
}
untie %h;
if ($^O eq 'VMS') {
unlink 'Op_dbmx.sdbm_dir', $Dfile;
} else {
unlink 'Op_dbmx.dir', $Dfile;
}
--- NEW FILE: complete.pl ---
;#
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Term::Complete
#
;# @(#)complete.pl,v1.1 (me at anywhere.EBay.Sun.COM) 09/23/91
;#
;# Author: Wayne Thompson
;#
;# Description:
;# This routine provides word completion.
;# (TAB) attempts word completion.
;# (^D) prints completion list.
;# (These may be changed by setting $Complete'complete, etc.)
;#
;# Diagnostics:
;# Bell when word completion fails.
;#
;# Dependencies:
;# The tty driver is put into raw mode.
;#
;# Bugs:
;#
;# Usage:
;# $input = &Complete('prompt_string', *completion_list);
;# or
;# $input = &Complete('prompt_string', @completion_list);
;#
CONFIG: {
package Complete;
$complete = "\004";
$kill = "\025";
$erase1 = "\177";
$erase2 = "\010";
}
sub Complete {
package Complete;
local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
if ($_[1] =~ /^StB\0/) {
($prompt, *_) = @_;
}
else {
$prompt = shift(@_);
}
@cmp_lst = sort(@_);
system('stty raw -echo');
LOOP: {
print($prompt, $return);
while (($_ = getc(STDIN)) ne "\r") {
CASE: {
# (TAB) attempt completion
$_ eq "\t" && do {
@match = grep(/^$return/, @cmp_lst);
$l = length($test = shift(@match));
unless ($#match < 0) {
foreach $cmp (@match) {
until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
$l--;
}
}
print("\a");
}
print($test = substr($test, $r, $l - $r));
$r = length($return .= $test);
last CASE;
};
# (^D) completion list
$_ eq $complete && do {
print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
redo LOOP;
};
# (^U) kill
$_ eq $kill && do {
if ($r) {
undef $r;
undef $return;
print("\r\n");
redo LOOP;
}
last CASE;
};
# (DEL) || (BS) erase
($_ eq $erase1 || $_ eq $erase2) && do {
if($r) {
print("\b \b");
chop($return);
$r--;
}
last CASE;
};
# printable char
ord >= 32 && do {
$return .= $_;
$r++;
print;
last CASE;
};
}
}
}
system('stty -raw echo');
print("\n");
$return;
}
1;
--- NEW FILE: AutoSplit.t ---
#!./perl -w
# AutoLoader.t runs before this test, so it seems safe to assume that it will
# work.
my($incdir, $lib);
BEGIN {
chdir 't' if -d 't';
if ($^O eq 'dos') {
print "1..0 # This test is not 8.3-aware.\n";
exit 0;
}
if ($^O eq 'MacOS') {
$incdir = ":auto-$$";
$lib = '-I::lib:';
} else {
$incdir = "auto-$$";
$lib = '"-I../lib"'; # ok on unix, nt, The extra \" are for VMS
}
@INC = $incdir;
push @INC, '../lib';
}
my $runperl = "$^X $lib";
use warnings;
use strict;
use Test::More tests => 58;
use File::Spec;
use File::Find;
require AutoSplit; # Run time. Check it compiles.
ok (1, "AutoSplit loaded");
END {
use File::Path;
print "# $incdir being removed...\n";
rmtree($incdir);
}
mkdir $incdir,0755;
my @tests;
{
# local this else it buggers up the chomp() below.
# Hmm. Would be nice to have this as a regexp.
local $/
= "################################################################\n";
@tests = <DATA>;
close DATA;
}
my $pathsep = $^O eq 'MSWin32' ? '\\' : $^O eq 'MacOS' ? ':' : '/';
my $endpathsep = $^O eq 'MacOS' ? ':' : '';
sub split_a_file {
my $contents = shift;
my $file = $_[0];
if (defined $contents) {
open FILE, ">$file" or die "Can't open $file: $!";
print FILE $contents;
close FILE or die "Can't close $file: $!";
}
# Assumption: no characters in arguments need escaping from the shell or perl
my $com = qq($runperl -e "use AutoSplit; autosplit (qw(@_))");
print "# command: $com\n";
# There may be a way to capture STDOUT without spawning a child process, but
# it's probably worthwhile spawning, as it ensures that nothing in AutoSplit
# can load functions from split modules into this perl.
my $output = `$com`;
warn "Exit status $? from running: >>$com<<" if $?;
return $output;
}
my $i = 0;
my $dir = File::Spec->catdir($incdir, 'auto');
if ($^O eq 'VMS') {
$dir = VMS::Filespec::unixify($dir);
$dir =~ s/\/$//;
} elsif ($^O eq 'MacOS') {
$dir =~ s/:$//;
}
foreach (@tests) {
my $module = 'A' . $i . '_' . $$ . 'splittest';
my $file = File::Spec->catfile($incdir,"$module.pm");
s/\*INC\*/$incdir/gm;
s/\*DIR\*/$dir/gm;
s/\*MOD\*/$module/gm;
s/\*PATHSEP\*/$pathsep/gm;
s/\*ENDPATHSEP\*/$endpathsep/gm;
s#//#/#gm;
# Build a hash for this test.
my %args = /^\#\#\ ([^\n]*)\n # Key is on a line starting ##
((?:[^\#]+ # Any number of characters not #
| \#(?!\#) # or a # character not followed by #
| (?<!\n)\# # or a # character not preceded by \n
)*)/sgmx;
foreach ($args{Name}, $args{Require}, $args{Extra}) {
chomp $_ if defined $_;
}
$args{Get} ||= '';
my @extra_args = !defined $args{Extra} ? () : split /,/, $args{Extra};
my ($output, $body);
if ($args{File}) {
$body ="package $module;\n" . $args{File};
$output = split_a_file ($body, $file, $dir, @extra_args);
} else {
# Repeat tests
$output = split_a_file (undef, $file, $dir, @extra_args);
}
if ($^O eq 'VMS') {
my ($filespec, $replacement);
while ($output =~ m/(\[.+\])/) {
$filespec = $1;
$replacement = VMS::Filespec::unixify($filespec);
$replacement =~ s/\/$//;
$output =~ s/\Q$filespec\E/$replacement/;
}
}
# test n+1
is($output, $args{Get}, "Output from autosplit()ing $args{Name}");
if ($args{Files}) {
$args{Files} =~ s!/!:!gs if $^O eq 'MacOS';
my (%missing, %got);
find (sub {$got{$File::Find::name}++ unless -d $_}, $dir);
foreach (split /\n/, $args{Files}) {
next if /^#/;
$_ = lc($_) if $^O eq 'VMS';
unless (delete $got{$_}) {
$missing{$_}++;
}
}
my @missing = keys %missing;
# test n+2
unless (ok (!@missing, "Are any expected files missing?")) {
print "# These files are missing\n";
print "# $_\n" foreach sort @missing;
}
my @extra = keys %got;
# test n+3
unless (ok (!@extra, "Are any extra files present?")) {
print "# These files are unexpectedly present:\n";
print "# $_\n" foreach sort @extra;
}
}
if ($args{Require}) {
$args{Require} =~ s|/|:|gm if $^O eq 'MacOS';
my $com = 'require "' . File::Spec->catfile ('auto', $args{Require}) . '"';
$com =~ s{\\}{/}gm if ($^O eq 'MSWin32');
eval $com;
# test n+3
ok ($@ eq '', $com) or print "# \$\@ = '$@'\n";
if (defined $body) {
eval $body or die $@;
}
}
# match tests to check for prototypes
if ($args{Match}) {
local $/;
my $file = File::Spec->catfile($dir, $args{Require});
open IX, $file or die "Can't open '$file': $!";
my $ix = <IX>;
close IX or die "Can't close '$file': $!";
foreach my $pat (split /\n/, $args{Match}) {
next if $pat =~ /^\#/;
like ($ix, qr/^\s*$pat\s*$/m, "match $pat");
}
}
# code tests contain eval{}ed ok()s etc
if ($args{Tests}) {
foreach my $code (split /\n/, $args{Tests}) {
next if $code =~ /^\#/;
defined eval $code or fail(), print "# Code: $code\n# Error: $@";
}
}
if (my $sleepfor = $args{Sleep}) {
# We need to sleep for a while
# Need the sleep hack else the next test is so fast that the timestamp
# compare routine in AutoSplit thinks that it shouldn't split the files.
my $time = time;
my $until = $time + $sleepfor;
my $attempts = 3;
do {
sleep ($sleepfor)
} while (time < $until && --$attempts > 0);
if ($attempts == 0) {
printf << "EOM", time;
# Attempted to sleep for $sleepfor second(s), started at $time, now %d.
# sleep attempt ppears to have failed; some tests may fail as a result.
EOM
}
}
unless ($args{SameAgain}) {
$i++;
rmtree($dir);
mkdir $dir, 0775;
}
}
__DATA__
## Name
tests from the end of the AutoSplit module.
## File
use AutoLoader 'AUTOLOAD';
{package Just::Another;
use AutoLoader 'AUTOLOAD';
}
@Yet::Another::AutoSplit::ISA = 'AutoLoader';
1;
__END__
sub test1 ($) { "test 1"; }
sub test2 ($$) { "test 2"; }
sub test3 ($$$) { "test 3"; }
sub testtesttesttest4_1 { "test 4"; }
sub testtesttesttest4_2 { "duplicate test 4"; }
sub Just::Another::test5 { "another test 5"; }
sub test6 { return join ":", __FILE__,__LINE__; }
package Yet::Another::AutoSplit;
sub testtesttesttest4_1 ($) { "another test 4"; }
sub testtesttesttest4_2 ($$) { "another duplicate test 4"; }
package Yet::More::Attributes;
sub test_a1 ($) : locked :locked { 1; }
sub test_a2 : locked { 1; }
# And that was all it has. You were expected to manually inspect the output
## Get
Warning: AutoSplit had to create top-level *DIR* unexpectedly.
AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
*INC**PATHSEP**MOD*.pm: some names are not unique when truncated to 8 characters:
directory *DIR**PATHSEP**MOD**ENDPATHSEP*:
testtesttesttest4_1.al, testtesttesttest4_2.al truncate to testtest
directory *DIR**PATHSEP*Yet*PATHSEP*Another*PATHSEP*AutoSplit*ENDPATHSEP*:
testtesttesttest4_1.al, testtesttesttest4_2.al truncate to testtest
## Files
*DIR*/*MOD*/autosplit.ix
*DIR*/*MOD*/test1.al
*DIR*/*MOD*/test2.al
*DIR*/*MOD*/test3.al
*DIR*/*MOD*/testtesttesttest4_1.al
*DIR*/*MOD*/testtesttesttest4_2.al
*DIR*/Just/Another/test5.al
*DIR*/*MOD*/test6.al
*DIR*/Yet/Another/AutoSplit/testtesttesttest4_1.al
*DIR*/Yet/Another/AutoSplit/testtesttesttest4_2.al
*DIR*/Yet/More/Attributes/test_a1.al
*DIR*/Yet/More/Attributes/test_a2.al
## Require
*MOD*/autosplit.ix
## Match
# Need to find these lines somewhere in the required file
sub test1\s*\(\$\);
sub test2\s*\(\$\$\);
sub test3\s*\(\$\$\$\);
sub testtesttesttest4_1\s*\(\$\);
sub testtesttesttest4_2\s*\(\$\$\);
sub test_a1\s*\(\$\)\s*:\s*locked\s*:\s*locked\s*;
sub test_a2\s*:\s*locked\s*;
## Tests
is (*MOD*::test1 (1), 'test 1');
is (*MOD*::test2 (1,2), 'test 2');
is (*MOD*::test3 (1,2,3), 'test 3');
ok (!defined eval "*MOD*::test1 () eq 'test 1'" and $@ =~ /^Not enough arguments for *MOD*::test1/, "Check prototypes mismatch fails") or print "# \$\@='$@'";
is (&*MOD*::testtesttesttest4_1, "test 4");
is (&*MOD*::testtesttesttest4_2, "duplicate test 4");
is (&Just::Another::test5, "another test 5");
# very messy way to interpolate function into regexp, but it's going to be
# needed to get : for Mac filespecs
like (&*MOD*::test6, qr!^\Q*INC**PATHSEP**MOD*\E\.pm \(autosplit into \Q@{[File::Spec->catfile('*DIR*','*MOD*', 'test6.al')]}\E\):\d+$!);
ok (Yet::Another::AutoSplit->testtesttesttest4_1 eq "another test 4");
################################################################
## Name
missing use AutoLoader;
## File
1;
__END__
## Get
## Files
# There should be no files.
################################################################
## Name
missing use AutoLoader; (but don't skip)
## Extra
0, 0
## File
1;
__END__
## Get
AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
## Require
*MOD*/autosplit.ix
## Files
*DIR*/*MOD*/autosplit.ix
################################################################
## Name
Split prior to checking whether obsolete files get deleted
## File
use AutoLoader 'AUTOLOAD';
1;
__END__
sub obsolete {our $hidden_a; return $hidden_a++;}
sub gonner {warn "This gonner function should never get called"}
## Get
AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
## Require
*MOD*/autosplit.ix
## Files
*DIR*/*MOD*/autosplit.ix
*DIR*/*MOD*/gonner.al
*DIR*/*MOD*/obsolete.al
## Tests
is (&*MOD*::obsolete, 0);
is (&*MOD*::obsolete, 1);
## Sleep
4
## SameAgain
True, so don't scrub this directory.
IIRC DOS FAT filesystems have only 2 second granularity.
################################################################
## Name
Check whether obsolete files get deleted
## File
use AutoLoader 'AUTOLOAD';
1;
__END__
sub skeleton {"bones"};
sub ghost {"scream"}; # This definition gets overwritten with the one below
sub ghoul {"wail"};
sub zombie {"You didn't use fire."};
sub flying_pig {"Oink oink flap flap"};
## Get
AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
## Require
*MOD*/autosplit.ix
## Files
*DIR*/*MOD*/autosplit.ix
*DIR*/*MOD*/skeleton.al
*DIR*/*MOD*/zombie.al
*DIR*/*MOD*/ghost.al
*DIR*/*MOD*/ghoul.al
*DIR*/*MOD*/flying_pig.al
## Tests
is (&*MOD*::skeleton, "bones", "skeleton");
eval {&*MOD*::gonner}; ok ($@ =~ m!^Can't locate auto/*MOD*/gonner.al in \@INC!, "Check &*MOD*::gonner is now a gonner") or print "# \$\@='$@'\n";
## Sleep
4
## SameAgain
True, so don't scrub this directory.
################################################################
## Name
Check whether obsolete files remain when keep is 1
## Extra
1, 1
## File
use AutoLoader 'AUTOLOAD';
1;
__END__
sub ghost {"bump"};
sub wraith {9};
## Get
AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
## Require
*MOD*/autosplit.ix
## Files
*DIR*/*MOD*/autosplit.ix
*DIR*/*MOD*/skeleton.al
*DIR*/*MOD*/zombie.al
*DIR*/*MOD*/ghost.al
*DIR*/*MOD*/ghoul.al
*DIR*/*MOD*/wraith.al
*DIR*/*MOD*/flying_pig.al
## Tests
is (&*MOD*::ghost, "bump");
is (&*MOD*::zombie, "You didn't use fire.", "Are our zombies undead?");
## Sleep
4
## SameAgain
True, so don't scrub this directory.
################################################################
## Name
Without the timestamp check make sure that nothing happens
## Extra
0, 1, 1
## Require
*MOD*/autosplit.ix
## Files
*DIR*/*MOD*/autosplit.ix
*DIR*/*MOD*/skeleton.al
*DIR*/*MOD*/zombie.al
*DIR*/*MOD*/ghost.al
*DIR*/*MOD*/ghoul.al
*DIR*/*MOD*/wraith.al
*DIR*/*MOD*/flying_pig.al
## Tests
is (&*MOD*::ghoul, "wail", "still haunted");
is (&*MOD*::zombie, "You didn't use fire.", "Are our zombies still undead?");
## Sleep
4
## SameAgain
True, so don't scrub this directory.
################################################################
## Name
With the timestamp check make sure that things happen (stuff gets deleted)
## Extra
0, 1, 0
## Get
AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
## Require
*MOD*/autosplit.ix
## Files
*DIR*/*MOD*/autosplit.ix
*DIR*/*MOD*/ghost.al
*DIR*/*MOD*/wraith.al
## Tests
is (&*MOD*::wraith, 9);
eval {&*MOD*::flying_pig}; ok ($@ =~ m!^Can't locate auto/*MOD*/flying_pig.al in \@INC!, "There are no flying pigs") or print "# \$\@='$@'\n";
--- NEW FILE: lib.t ---
#!./perl -w
BEGIN {
chdir 't';
@INC = '../lib';
@OrigINC = @INC;
}
use Test::More tests => 13;
use Config;
use File::Spec;
use File::Path;
#set up files and directories
my @lib_dir;
my $Lib_Dir;
my $Arch_Dir;
my $Auto_Dir;
my $Module;
BEGIN {
# lib.pm is documented to only work with Unix filepaths.
@lib_dir = qw(stuff moo);
$Lib_Dir = join "/", @lib_dir;
$Arch_Dir = join "/", @lib_dir, $Config{archname};
# create the auto/ directory and a module
$Auto_Dir = File::Spec->catdir(@lib_dir, $Config{archname},'auto');
$Module = File::Spec->catfile(@lib_dir, 'Yup.pm');
mkpath [$Auto_Dir];
open(MOD, ">$Module") || DIE $!;
print MOD <<'MODULE';
package Yup;
$Plan = 9;
return '42';
MODULE
close MOD;
}
END {
# cleanup the auto/ directory we created.
rmtree([$lib_dir[0]]);
}
use lib $Lib_Dir;
use lib $Lib_Dir;
BEGIN { use_ok('Yup') }
BEGIN {
if ($^O eq 'MacOS') {
for ($Lib_Dir, $Arch_Dir) {
tr|/|:|;
$_ .= ":" unless /:$/;
$_ = ":$_" unless /^:/; # we know this path is relative
}
}
is( $INC[1], $Lib_Dir, 'lib adding at end of @INC' );
print "# \@INC == @INC\n";
is( $INC[0], $Arch_Dir, ' auto/ dir in front of that' );
is( grep(/^\Q$Lib_Dir\E$/, @INC), 1, ' no duplicates' );
# Yes, %INC uses Unixy filepaths.
# Not on Mac OS, it doesn't ... it never has, at least.
my $path = join("/",$Lib_Dir, 'Yup.pm');
if ($^O eq 'MacOS') {
$path = $Lib_Dir . 'Yup.pm';
}
is( $INC{'Yup.pm'}, $path, '%INC set properly' );
is( eval { do 'Yup.pm' }, 42, 'do() works' );
ok( eval { require Yup; }, ' require()' );
ok( eval "use Yup; 1;", ' use()' );
is( $@, '' );
is_deeply(\@OrigINC, \@lib::ORIG_INC, '@lib::ORIG_INC' );
}
no lib $Lib_Dir;
unlike( do { eval 'use lib $Config{installsitelib};'; $@ || '' },
qr/::Config is read-only/, 'lib handles readonly stuff' );
BEGIN {
is( grep(/stuff/, @INC), 0, 'no lib' );
ok( !do 'Yup.pm', ' do() effected' );
}
--- NEW FILE: shellwords.pl ---
;# shellwords.pl
;#
;# Usage:
;# require 'shellwords.pl';
;# @words = shellwords($line);
;# or
;# @words = shellwords(@lines);
;# or
;# @words = shellwords(); # defaults to $_ (and clobbers it)
require Text::ParseWords;
*shellwords = \&Text::ParseWords::old_shellwords;
1;
--- NEW FILE: assert.pl ---
# assert.pl
# tchrist at convex.com (Tom Christiansen)
#
# Usage:
#
# &assert('@x > @y');
# &assert('$var > 10', $var, $othervar, @various_info);
#
# That is, if the first expression evals false, we blow up. The
# rest of the args, if any, are nice to know because they will
# be printed out by &panic, which is just the stack-backtrace
# routine shamelessly borrowed from the perl debugger.
sub assert {
&panic("ASSERTION BOTCHED: $_[$[]",$@) unless eval $_[$[];
}
sub panic {
package DB;
select(STDERR);
print "\npanic: @_\n";
exit 1 if $] <= 4.003; # caller broken
# stack traceback gratefully borrowed from perl debugger
local $_;
my $i;
my ($p,$f,$l,$s,$h,$a, at a, at frames);
for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
@a = @args;
for (@a) {
if (/^StB\000/ && length($_) == length($_main{'_main'})) {
$_ = sprintf("%s",$_);
}
else {
s/'/\\'/g;
s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
}
}
$w = $w ? '@ = ' : '$ = ';
$a = $h ? '(' . join(', ', @a) . ')' : '';
push(@frames, "$w&$s$a from file $f line $l\n");
}
for ($i=0; $i <= $#frames; $i++) {
print $frames[$i];
}
exit 1;
}
1;
--- NEW FILE: blib.t ---
#!./perl -Tw
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use strict;
use File::Spec;
my($blib, $blib_arch, $blib_lib, @blib_dirs);
sub _cleanup {
rmdir foreach reverse (@_);
unlink "stderr" unless $^O eq 'MacOS';
}
sub _mkdirs {
for my $dir (@_) {
next if -d $dir;
mkdir $dir or die "Can't mkdir $dir: $!" if ! -d $dir;
}
}
BEGIN {
if ($^O eq 'MacOS')
{
$MacPerl::Architecture = $MacPerl::Architecture; # shhhhh
$blib = ":blib:";
$blib_lib = ":blib:lib:";
$blib_arch = ":blib:lib:$MacPerl::Architecture:";
@blib_dirs = ($blib, $blib_lib, $blib_arch); # order
}
else
{
$blib = "blib";
$blib_arch = "blib/arch";
$blib_lib = "blib/lib";
@blib_dirs = ($blib, $blib_arch, $blib_lib);
}
_cleanup( @blib_dirs );
}
use Test::More tests => 7;
eval 'use blib;';
ok( $@ =~ /Cannot find blib/, 'Fails if blib directory not found' );
_mkdirs( @blib_dirs );
{
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings = join '', @_ };
use_ok('blib');
is( $warnings, '', 'use blib is nice and quiet' );
}
is( @INC, 3, '@INC now has 3 elements' );
is( $INC[2], '../lib', 'blib added to the front of @INC' );
if ($^O eq 'VMS') {
# Unix syntax is accepted going in but it's not what comes out
# So we don't use catdir above
$blib_arch = 'blib.arch]';
$blib_lib = 'blib.lib]';
}
elsif ($^O ne 'MacOS')
{
$blib_arch = File::Spec->catdir("blib","arch");
$blib_lib = File::Spec->catdir("blib","lib");
}
ok( grep(m|\Q$blib_lib\E$|, @INC[0,1]) == 1, " $blib_lib in \@INC");
ok( grep(m|\Q$blib_arch\E$|, @INC[0,1]) == 1, " $blib_arch in \@INC");
END { _cleanup( @blib_dirs ); }
--- NEW FILE: CGI.pm ---
package CGI;
require 5.004;
use Carp 'croak';
# See the bottom of this file for the POD documentation. Search for the
# string '=head'.
# You can run this file through either pod2man or pod2html to produce pretty
# documentation in manual or html file format (these utilities are part of the
# Perl 5 distribution).
# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
# It may be used and modified freely, but I do request that this copyright
# notice remain attached to the file. You may modify this module as you
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.
# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
[...7584 lines suppressed...]
}
sub print_tail {
print <<END;
<hr>
<address>Lincoln D. Stein</address><br>
<a href="/">Home Page</a>
END
}
=head1 BUGS
Please report them.
=head1 SEE ALSO
L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty>
=cut
--- NEW FILE: FindBin.pm ---
# FindBin.pm
#
# Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
=head1 NAME
FindBin - Locate directory of original perl script
=head1 SYNOPSIS
use FindBin;
use lib "$FindBin::Bin/../lib";
or
use FindBin qw($Bin);
use lib "$Bin/../lib";
=head1 DESCRIPTION
Locates the full path to the script bin directory to allow the use
of paths relative to the bin directory.
This allows a user to setup a directory tree for some software with
directories C<< <root>/bin >> and C<< <root>/lib >>, and then the above
example will allow the use of modules in the lib directory without knowing
where the software tree is installed.
If perl is invoked using the B<-e> option or the perl script is read from
C<STDIN> then FindBin sets both C<$Bin> and C<$RealBin> to the current
directory.
=head1 EXPORTABLE VARIABLES
$Bin - path to bin directory from where script was invoked
$Script - basename of script from which perl was invoked
$RealBin - $Bin with all links resolved
$RealScript - $Script with all links resolved
=head1 KNOWN ISSUES
If there are two modules using C<FindBin> from different directories
under the same interpreter, this won't work. Since C<FindBin> uses a
C<BEGIN> block, it'll be executed only once, and only the first caller
will get it right. This is a problem under mod_perl and other persistent
Perl environments, where you shouldn't use this module. Which also means
that you should avoid using C<FindBin> in modules that you plan to put
on CPAN. To make sure that C<FindBin> will work is to call the C<again>
function:
use FindBin;
FindBin::again(); # or FindBin->again;
In former versions of FindBin there was no C<again> function. The
workaround was to force the C<BEGIN> block to be executed again:
delete $INC{'FindBin.pm'};
require FindBin;
=head1 KNOWN BUGS
If perl is invoked as
perl filename
and I<filename> does not have executable rights and a program called
I<filename> exists in the users C<$ENV{PATH}> which satisfies both B<-x>
and B<-T> then FindBin assumes that it was invoked via the
C<$ENV{PATH}>.
Workaround is to invoke perl as
perl ./filename
=head1 AUTHORS
FindBin is supported as part of the core perl distribution. Please send bug
reports to E<lt>F<perlbug at perl.org>E<gt> using the perlbug program
included with perl.
Graham Barr E<lt>F<gbarr at pobox.com>E<gt>
Nick Ing-Simmons E<lt>F<nik at tiuk.ti.com>E<gt>
=head1 COPYRIGHT
Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
package FindBin;
use Carp;
require 5.000;
require Exporter;
use Cwd qw(getcwd cwd abs_path);
use Config;
use File::Basename;
use File::Spec;
@EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir);
%EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]);
@ISA = qw(Exporter);
$VERSION = "1.47";
sub cwd2 {
my $cwd = getcwd();
# getcwd might fail if it hasn't access to the current directory.
# try harder.
defined $cwd or $cwd = cwd();
$cwd;
}
sub init
{
*Dir = \$Bin;
*RealDir = \$RealBin;
if($0 eq '-e' || $0 eq '-')
{
# perl invoked with -e or script is on C<STDIN>
$Script = $RealScript = $0;
$Bin = $RealBin = cwd2();
}
else
{
my $script = $0;
if ($^O eq 'VMS')
{
($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*\])(.*)/s;
($RealBin,$RealScript) = ($Bin,$Script);
}
else
{
my $dosish = ($^O eq 'MSWin32' or $^O eq 'os2');
unless(($script =~ m#/# || ($dosish && $script =~ m#\\#))
&& -f $script)
{
my $dir;
foreach $dir (File::Spec->path)
{
my $scr = File::Spec->catfile($dir, $script);
if(-r $scr && (!$dosish || -x _))
{
$script = $scr;
if (-f $0)
{
# $script has been found via PATH but perl could have
# been invoked as 'perl file'. Do a dumb check to see
# if $script is a perl program, if not then $script = $0
#
# well we actually only check that it is an ASCII file
# we know its executable so it is probably a script
# of some sort.
$script = $0 unless(-T $script);
}
last;
}
}
}
croak("Cannot find current script '$0'") unless(-f $script);
# Ensure $script contains the complete path in case we C<chdir>
$script = File::Spec->catfile(cwd2(), $script)
unless File::Spec->file_name_is_absolute($script);
($Script,$Bin) = fileparse($script);
# Resolve $script if it is a link
while(1)
{
my $linktext = readlink($script);
($RealScript,$RealBin) = fileparse($script);
last unless defined $linktext;
$script = (File::Spec->file_name_is_absolute($linktext))
? $linktext
: File::Spec->catfile($RealBin, $linktext);
}
# Get absolute paths to directories
if ($Bin) {
my $BinOld = $Bin;
$Bin = abs_path($Bin);
defined $Bin or $Bin = File::Spec->canonpath($BinOld);
}
$RealBin = abs_path($RealBin) if($RealBin);
}
}
}
BEGIN { init }
*again = \&init;
1; # Keep require happy
--- NEW FILE: cacheout.pl ---
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: FileCache
# Open in their package.
sub cacheout'open {
open($_[0], $_[1]);
}
# Close as well
sub cacheout'close {
close($_[0]);
}
# But only this sub name is visible to them.
sub cacheout {
package cacheout;
($file) = @_;
if (!$isopen{$file}) {
if (++$numopen > $maxopen) {
local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
splice(@lru, $maxopen / 3);
$numopen -= @lru;
for (@lru) { &close($_); delete $isopen{$_}; }
}
&open($file, ($saw{$file}++ ? '>>' : '>') . $file)
|| die "Can't create $file: $!\n";
}
$isopen{$file} = ++$seq;
}
package cacheout;
$seq = 0;
$numopen = 0;
if (open(PARAM,'/usr/include/sys/param.h')) {
local($_, $.);
while (<PARAM>) {
$maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
}
close PARAM;
}
$maxopen = 16 unless $maxopen;
1;
--- NEW FILE: timelocal.pl ---
;# timelocal.pl
;#
;# Usage:
;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year);
;# $time = timegm($sec,$min,$hours,$mday,$mon,$year);
;# This file has been superseded by the Time::Local library module.
;# It is implemented as a call to that module for backwards compatibility
;# with code written for perl4; new code should use Time::Local directly.
;# The current implementation shares with the original the questionable
;# behavior of defining the timelocal() and timegm() functions in the
;# namespace of whatever package was current when the first instance of
;# C<require 'timelocal.pl';> was executed in a program.
use Time::Local;
*timelocal::cheat = \&Time::Local::cheat;
--- NEW FILE: ph.t ---
#!./perl
# Check for presence and correctness of .ph files; for now,
# just socket.ph and pals.
# -- Kurt Starsinic <kstar at isinet.com>
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
# All the constants which Socket.pm tries to make available:
my @possibly_defined = qw(
INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT
AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK
AF_INET AF_LAT AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP
AF_SNA AF_UNIX AF_UNSPEC AF_X25 MSG_DONTROUTE MSG_MAXIOVLEN MSG_OOB
MSG_PEEK PF_802 PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI
PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT
PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25 SOCK_DGRAM
SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SOMAXCONN
SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR
SO_KEEPALIVE SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO
SO_REUSEADDR SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK
);
# The libraries which I'm going to require:
my @libs = qw(Socket "sys/types.ph" "sys/socket.ph" "netinet/in.ph");
# These are defined by Socket.pm even if the C header files don't define them:
my %ok_to_miss = (
INADDR_NONE => 1,
INADDR_LOOPBACK => 1,
);
my $total_tests = scalar @libs + scalar @possibly_defined;
my $i = 0;
print "1..$total_tests\n";
foreach (@libs) {
$i++;
if (eval "require $_" ) {
print "ok $i\n";
} else {
print "# Skipping tests; $_ may be missing\n";
foreach ($i .. $total_tests) { print "ok $_\n" }
exit;
}
}
foreach (@possibly_defined) {
$i++;
$pm_val = eval "Socket::$_()";
$ph_val = eval "main::$_()";
if (defined $pm_val and !defined $ph_val) {
if ($ok_to_miss{$_}) { print "ok $i\n" }
else { print "not ok $i\n" }
next;
} elsif (defined $ph_val and !defined $pm_val) {
print "not ok $i\n";
next;
}
# Socket.pm converts these to network byte order, so we convert the
# socket.ph version to match; note that these cases skip the following
# `elsif', which is only applied to _numeric_ values, not literal
# bitmasks.
if ($_ eq 'INADDR_ANY'
or $_ eq 'INADDR_LOOPBACK'
or $_ eq 'INADDR_NONE') {
$ph_val = pack("N*", $ph_val); # htonl(3) equivalent
}
# Since Socket.pm and socket.ph wave their hands over macros differently,
# they could return functionally equivalent bitmaps with different numeric
# interpretations (due to sign extension). The only apparent case of this
# is SO_DONTLINGER (only on Solaris, and deprecated, at that):
elsif ($pm_val != $ph_val) {
$pm_val = oct(sprintf "0x%lx", $pm_val);
$ph_val = oct(sprintf "0x%lx", $ph_val);
}
if ($pm_val == $ph_val) { print "ok $i\n" }
else { print "not ok $i\n" }
}
--- NEW FILE: dumpvar.pl ---
require 5.002; # For (defined ref)
package dumpvar;
# Needed for PrettyPrinter only:
# require 5.001; # Well, it coredumps anyway undef DB in 5.000 (not now)
# translate control chars to ^X - Randal Schwartz
# Modifications to print types by Peter Gordon v1.0
# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
# Won't dump symbol tables and contents of debugged files by default
$winsize = 80 unless defined $winsize;
# Defaults
# $globPrint = 1;
$printUndef = 1 unless defined $printUndef;
$tick = "auto" unless defined $tick;
$unctrl = 'quote' unless defined $unctrl;
$subdump = 1;
$dumpReused = 0 unless defined $dumpReused;
$bareStringify = 1 unless defined $bareStringify;
sub main::dumpValue {
local %address;
local $^W=0;
(print "undef\n"), return unless defined $_[0];
(print &stringify($_[0]), "\n"), return unless ref $_[0];
push @_, -1 if @_ == 1;
dumpvar::unwrap($_[0], 0, $_[1]);
}
# This one is good for variable names:
sub unctrl {
local($_) = @_;
local($v) ;
return \$_ if ref \$_ eq "GLOB";
s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
$_;
}
sub uniescape {
join("",
map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) }
unpack("U*", $_[0]));
}
sub stringify {
local($_,$noticks) = @_;
local($v) ;
my $tick = $tick;
return 'undef' unless defined $_ or not $printUndef;
return $_ . "" if ref \$_ eq 'GLOB';
$_ = &{'overload::StrVal'}($_)
if $bareStringify and ref $_
and %overload:: and defined &{'overload::StrVal'};
if ($tick eq 'auto') {
if (/[\000-\011\013-\037\177]/) {
$tick = '"';
}else {
$tick = "'";
}
}
if ($tick eq "'") {
s/([\'\\])/\\$1/g;
} elsif ($unctrl eq 'unctrl') {
s/([\"\\])/\\$1/g ;
s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
# uniescape?
s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
if $quoteHighBit;
} elsif ($unctrl eq 'quote') {
s/([\"\\\$\@])/\\$1/g if $tick eq '"';
s/\033/\\e/g;
s/([\000-\037\177])/'\\c'._escaped_ord($1)/eg;
}
$_ = uniescape($_);
s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
($noticks || /^\d+(\.\d*)?\Z/)
? $_
: $tick . $_ . $tick;
}
# Ensure a resulting \ is escaped to be \\
sub _escaped_ord {
my $chr = shift;
$chr = chr(ord($chr)^64);
$chr =~ s{\\}{\\\\}g;
return $chr;
}
sub ShortArray {
my $tArrayDepth = $#{$_[0]} ;
$tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1
unless $arrayDepth eq '' ;
my $shortmore = "";
$shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
if (!grep(ref $_, @{$_[0]})) {
$short = "0..$#{$_[0]} '" .
join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
return $short if length $short <= $compactDump;
}
undef;
}
sub DumpElem {
my $short = &stringify($_[0], ref $_[0]);
if ($veryCompact && ref $_[0]
&& (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
my $end = "0..$#{$v} '" .
join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
} elsif ($veryCompact && ref $_[0]
&& (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
my $end = 1;
$short = $sp . "0..$#{$v} '" .
join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
} else {
print "$short\n";
unwrap($_[0],$_[1],$_[2]) if ref $_[0];
}
}
sub unwrap {
return if $DB::signal;
local($v) = shift ;
local($s) = shift ; # extra no of spaces
local($m) = shift ; # maximum recursion depth
return if $m == 0;
local(%v, at v,$sp,$value,$key, at sortKeys,$more,$shortmore,$short) ;
local($tHashDepth,$tArrayDepth) ;
$sp = " " x $s ;
$s += 3 ;
# Check for reused addresses
if (ref $v) {
my $val = $v;
$val = &{'overload::StrVal'}($v)
if %overload:: and defined &{'overload::StrVal'};
# Match type and address.
# Unblessed references will look like TYPE(0x...)
# Blessed references will look like Class=TYPE(0x...)
($start_part, $val) = split /=/,$val;
$val = $start_part unless defined $val;
($item_type, $address) =
$val =~ /([^\(]+) # Keep stuff that's
# not an open paren
\( # Skip open paren
(0x[0-9a-f]+) # Save the address
\) # Skip close paren
$/x; # Should be at end now
if (!$dumpReused && defined $address) {
$address{$address}++ ;
if ( $address{$address} > 1 ) {
print "${sp}-> REUSED_ADDRESS\n" ;
return ;
}
}
} elsif (ref \$v eq 'GLOB') {
# This is a raw glob. Special handling for that.
$address = "$v" . ""; # To avoid a bug with globs
$address{$address}++ ;
if ( $address{$address} > 1 ) {
print "${sp}*DUMPED_GLOB*\n" ;
return ;
}
}
if (ref $v eq 'Regexp') {
# Reformat the regexp to look the standard way.
my $re = "$v";
$re =~ s,/,\\/,g;
print "$sp-> qr/$re/\n";
return;
}
if ( $item_type eq 'HASH' ) {
# Hash ref or hash-based object.
my @sortKeys = sort keys(%$v) ;
undef $more ;
$tHashDepth = $#sortKeys ;
$tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
unless $hashDepth eq '' ;
$more = "....\n" if $tHashDepth < $#sortKeys ;
$shortmore = "";
$shortmore = ", ..." if $tHashDepth < $#sortKeys ;
$#sortKeys = $tHashDepth ;
if ($compactDump && !grep(ref $_, values %{$v})) {
#$short = $sp .
# (join ', ',
# Next row core dumps during require from DB on 5.000, even with map {"_"}
# map {&stringify($_) . " => " . &stringify($v->{$_})}
# @sortKeys) . "'$shortmore";
$short = $sp;
my @keys;
for (@sortKeys) {
push @keys, &stringify($_) . " => " . &stringify($v->{$_});
}
$short .= join ', ', @keys;
$short .= $shortmore;
(print "$short\n"), return if length $short <= $compactDump;
}
for $key (@sortKeys) {
return if $DB::signal;
$value = $ {$v}{$key} ;
print "$sp", &stringify($key), " => ";
DumpElem $value, $s, $m-1;
}
print "$sp empty hash\n" unless @sortKeys;
print "$sp$more" if defined $more ;
} elsif ( $item_type eq 'ARRAY' ) {
# Array ref or array-based object. Also: undef.
# See how big the array is.
$tArrayDepth = $#{$v} ;
undef $more ;
# Bigger than the max?
$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
if defined $arrayDepth && $arrayDepth ne '';
# Yep. Don't show it all.
$more = "....\n" if $tArrayDepth < $#{$v} ;
$shortmore = "";
$shortmore = " ..." if $tArrayDepth < $#{$v} ;
if ($compactDump && !grep(ref $_, @{$v})) {
if ($#$v >= 0) {
$short = $sp . "0..$#{$v} " .
join(" ",
map {exists $v->[$_] ? stringify $v->[$_] : "empty"} ($[..$tArrayDepth)
) . "$shortmore";
} else {
$short = $sp . "empty array";
}
(print "$short\n"), return if length $short <= $compactDump;
}
#if ($compactDump && $short = ShortArray($v)) {
# print "$short\n";
# return;
#}
for $num ($[ .. $tArrayDepth) {
return if $DB::signal;
print "$sp$num ";
if (exists $v->[$num]) {
if (defined $v->[$num]) {
DumpElem $v->[$num], $s, $m-1;
}
else {
print "undef\n";
}
} else {
print "empty slot\n";
}
}
print "$sp empty array\n" unless @$v;
print "$sp$more" if defined $more ;
} elsif ( $item_type eq 'SCALAR' ) {
unless (defined $$v) {
print "$sp-> undef\n";
return;
}
print "$sp-> ";
DumpElem $$v, $s, $m-1;
} elsif ( $item_type eq 'REF' ) {
print "$sp-> $$v\n";
return unless defined $$v;
unwrap($$v, $s+3, $m-1);
} elsif ( $item_type eq 'CODE' ) {
# Code object or reference.
print "$sp-> ";
dumpsub (0, $v);
} elsif ( $item_type eq 'GLOB' ) {
# Glob object or reference.
print "$sp-> ",&stringify($$v,1),"\n";
if ($globPrint) {
$s += 3;
dumpglob($s, "{$$v}", $$v, 1, $m-1);
} elsif (defined ($fileno = fileno($v))) {
print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
}
} elsif (ref \$v eq 'GLOB') {
# Raw glob (again?)
if ($globPrint) {
dumpglob($s, "{$v}", $v, 1, $m-1) if $globPrint;
} elsif (defined ($fileno = fileno(\$v))) {
print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
}
}
}
sub matchlex {
(my $var = $_[0]) =~ s/.//;
$var eq $_[1] or
($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
($1 eq '!') ^ (eval { $var =~ /$2$3/ });
}
sub matchvar {
$_[0] eq $_[1] or
($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
}
sub compactDump {
$compactDump = shift if @_;
$compactDump = 6*80-1 if $compactDump and $compactDump < 2;
$compactDump;
}
sub veryCompact {
$veryCompact = shift if @_;
compactDump(1) if !$compactDump and $veryCompact;
$veryCompact;
}
sub unctrlSet {
if (@_) {
my $in = shift;
if ($in eq 'unctrl' or $in eq 'quote') {
$unctrl = $in;
} else {
print "Unknown value for `unctrl'.\n";
}
}
$unctrl;
}
sub quote {
if (@_ and $_[0] eq '"') {
$tick = '"';
$unctrl = 'quote';
} elsif (@_ and $_[0] eq 'auto') {
$tick = 'auto';
$unctrl = 'quote';
} elsif (@_) { # Need to set
$tick = "'";
$unctrl = 'unctrl';
}
$tick;
}
sub dumpglob {
return if $DB::signal;
my ($off,$key, $val, $all, $m) = @_;
local(*entry) = $val;
my $fileno;
if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
print( (' ' x $off) . "\$", &unctrl($key), " = " );
DumpElem $entry, 3+$off, $m;
}
if (($key !~ /^_</ or $dumpDBFiles) and @entry) {
print( (' ' x $off) . "\@$key = (\n" );
unwrap(\@entry,3+$off,$m) ;
print( (' ' x $off) . ")\n" );
}
if ($key ne "main::" && $key ne "DB::" && %entry
&& ($dumpPackages or $key !~ /::$/)
&& ($key !~ /^_</ or $dumpDBFiles)
&& !($package eq "dumpvar" and $key eq "stab")) {
print( (' ' x $off) . "\%$key = (\n" );
unwrap(\%entry,3+$off,$m) ;
print( (' ' x $off) . ")\n" );
}
if (defined ($fileno = fileno(*entry))) {
print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
}
if ($all) {
if (defined &entry) {
dumpsub($off, $key);
}
}
}
sub dumplex {
return if $DB::signal;
my ($key, $val, $m, @vars) = @_;
return if @vars && !grep( matchlex($key, $_), @vars );
local %address;
my $off = 0; # It reads better this way
my $fileno;
if (UNIVERSAL::isa($val,'ARRAY')) {
print( (' ' x $off) . "$key = (\n" );
unwrap($val,3+$off,$m) ;
print( (' ' x $off) . ")\n" );
}
elsif (UNIVERSAL::isa($val,'HASH')) {
print( (' ' x $off) . "$key = (\n" );
unwrap($val,3+$off,$m) ;
print( (' ' x $off) . ")\n" );
}
elsif (UNIVERSAL::isa($val,'IO')) {
print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
}
# No lexical subroutines yet...
# elsif (UNIVERSAL::isa($val,'CODE')) {
# dumpsub($off, $$val);
# }
else {
print( (' ' x $off) . &unctrl($key), " = " );
DumpElem $$val, 3+$off, $m;
}
}
sub CvGV_name_or_bust {
my $in = shift;
return if $skipCvGV; # Backdoor to avoid problems if XS broken...
$in = \&$in; # Hard reference...
eval {require Devel::Peek; 1} or return;
my $gv = Devel::Peek::CvGV($in) or return;
*$gv{PACKAGE} . '::' . *$gv{NAME};
}
sub dumpsub {
my ($off,$sub) = @_;
my $ini = $sub;
my $s;
$sub = $1 if $sub =~ /^\{\*(.*)\}$/;
my $subref = defined $1 ? \&$sub : \&$ini;
my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
|| (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})
|| ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});
$place = '???' unless defined $place;
$s = $sub unless defined $s;
print( (' ' x $off) . "&$s in $place\n" );
}
sub findsubs {
return undef unless %DB::sub;
my ($addr, $name, $loc);
while (($name, $loc) = each %DB::sub) {
$addr = \&$name;
$subs{"$addr"} = $name;
}
$subdump = 0;
$subs{ shift() };
}
sub main::dumpvar {
my ($package,$m, at vars) = @_;
local(%address,$key,$val,$^W);
$package .= "::" unless $package =~ /::$/;
*stab = *{"main::"};
while ($package =~ /(\w+?::)/g){
*stab = $ {stab}{$1};
}
local $TotalStrings = 0;
local $Strings = 0;
local $CompleteTotal = 0;
while (($key,$val) = each(%stab)) {
return if $DB::signal;
next if @vars && !grep( matchvar($key, $_), @vars );
if ($usageOnly) {
globUsage(\$val, $key)
if ($package ne 'dumpvar' or $key ne 'stab')
and ref(\$val) eq 'GLOB';
} else {
dumpglob(0,$key, $val, 0, $m);
}
}
if ($usageOnly) {
print "String space: $TotalStrings bytes in $Strings strings.\n";
$CompleteTotal += $TotalStrings;
print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
}
}
sub scalarUsage {
my $size = length($_[0]);
$TotalStrings += $size;
$Strings++;
$size;
}
sub arrayUsage { # array ref, name
my $size = 0;
map {$size += scalarUsage($_)} @{$_[0]};
my $len = @{$_[0]};
print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
" (data: $size bytes)\n"
if defined $_[1];
$CompleteTotal += $size;
$size;
}
sub hashUsage { # hash ref, name
my @keys = keys %{$_[0]};
my @values = values %{$_[0]};
my $keys = arrayUsage \@keys;
my $values = arrayUsage \@values;
my $len = @keys;
my $total = $keys + $values;
print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
" (keys: $keys; values: $values; total: $total bytes)\n"
if defined $_[1];
$total;
}
sub globUsage { # glob ref, name
local *name = *{$_[0]};
$total = 0;
$total += scalarUsage $name if defined $name;
$total += arrayUsage \@name, $_[1] if @name;
$total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::"
and $_[1] ne "DB::"; #and !($package eq "dumpvar" and $key eq "stab"));
$total;
}
sub packageUsage {
my ($package, at vars) = @_;
$package .= "::" unless $package =~ /::$/;
local *stab = *{"main::"};
while ($package =~ /(\w+?::)/g){
*stab = $ {stab}{$1};
}
local $TotalStrings = 0;
local $CompleteTotal = 0;
my ($key,$val);
while (($key,$val) = each(%stab)) {
next if @vars && !grep($key eq $_, at vars);
globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
}
print "String space: $TotalStrings.\n";
$CompleteTotal += $TotalStrings;
print "\nGrand total = $CompleteTotal bytes\n";
}
1;
--- NEW FILE: autouse.pm ---
package autouse;
#use strict; # debugging only
use 5.003_90; # ->can, for my $var
$autouse::VERSION = '1.05';
$autouse::DEBUG ||= 0;
sub vet_import ($);
sub croak {
require Carp;
Carp::croak(@_);
}
sub import {
my $class = @_ ? shift : 'autouse';
croak "usage: use $class MODULE [,SUBS...]" unless @_;
my $module = shift;
(my $pm = $module) =~ s{::}{/}g;
$pm .= '.pm';
if (exists $INC{$pm}) {
vet_import $module;
local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
# $Exporter::Verbose = 1;
return $module->import(map { (my $f = $_) =~ s/\(.*?\)$//; $f } @_);
}
# It is not loaded: need to do real work.
my $callpkg = caller(0);
print "autouse called from $callpkg\n" if $autouse::DEBUG;
my $index;
for my $f (@_) {
my $proto;
$proto = $1 if (my $func = $f) =~ s/\((.*)\)$//;
my $closure_import_func = $func; # Full name
my $closure_func = $func; # Name inside package
my $index = rindex($func, '::');
if ($index == -1) {
$closure_import_func = "${callpkg}::$func";
} else {
$closure_func = substr $func, $index + 2;
croak "autouse into different package attempted"
unless substr($func, 0, $index) eq $module;
}
my $load_sub = sub {
unless ($INC{$pm}) {
require $pm;
vet_import $module;
}
no warnings 'redefine';
*$closure_import_func = \&{"${module}::$closure_func"};
print "autousing $module; "
."imported $closure_func as $closure_import_func\n"
if $autouse::DEBUG;
goto &$closure_import_func;
};
if (defined $proto) {
*$closure_import_func = eval "sub ($proto) { goto &\$load_sub }"
|| die;
} else {
*$closure_import_func = $load_sub;
}
}
}
sub vet_import ($) {
my $module = shift;
if (my $import = $module->can('import')) {
croak "autoused module has unique import() method"
unless defined(&Exporter::import)
&& $import == \&Exporter::import;
}
}
1;
__END__
=head1 NAME
autouse - postpone load of modules until a function is used
=head1 SYNOPSIS
use autouse 'Carp' => qw(carp croak);
carp "this carp was predeclared and autoused ";
=head1 DESCRIPTION
If the module C<Module> is already loaded, then the declaration
use autouse 'Module' => qw(func1 func2($;$));
is equivalent to
use Module qw(func1 func2);
if C<Module> defines func2() with prototype C<($;$)>, and func1() has
no prototypes. (At least if C<Module> uses C<Exporter>'s C<import>,
otherwise it is a fatal error.)
If the module C<Module> is not loaded yet, then the above declaration
declares functions func1() and func2() in the current package. When
these functions are called, they load the package C<Module> if needed,
and substitute themselves with the correct definitions.
=begin _deprecated
use Module qw(Module::func3);
will work and is the equivalent to:
use Module qw(func3);
It is not a very useful feature and has been deprecated.
=end _deprecated
=head1 WARNING
Using C<autouse> will move important steps of your program's execution
from compile time to runtime. This can
=over 4
=item *
Break the execution of your program if the module you C<autouse>d has
some initialization which it expects to be done early.
=item *
hide bugs in your code since important checks (like correctness of
prototypes) is moved from compile time to runtime. In particular, if
the prototype you specified on C<autouse> line is wrong, you will not
find it out until the corresponding function is executed. This will be
very unfortunate for functions which are not always called (note that
for such functions C<autouse>ing gives biggest win, for a workaround
see below).
=back
To alleviate the second problem (partially) it is advised to write
your scripts like this:
use Module;
use autouse Module => qw(carp($) croak(&$));
carp "this carp was predeclared and autoused ";
The first line ensures that the errors in your argument specification
are found early. When you ship your application you should comment
out the first line, since it makes the second one useless.
=head1 AUTHOR
Ilya Zakharevich (ilya at math.ohio-state.edu)
=head1 SEE ALSO
perl(1).
=cut
--- NEW FILE: bigint.pl ---
package bigint;
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Math::BigInt
#
# arbitrary size integer math package
#
# by Mark Biggar
#
# Canonical Big integer value are strings of the form
# /^[+-]\d+$/ with leading zeros suppressed
# Input values to these routines may be strings of the form
# /^\s*[+-]?[\d\s]+$/.
# Examples:
# '+0' canonical zero value
# ' -123 123 123' canonical value '-123123123'
# '1 23 456 7890' canonical value '+1234567890'
# Output values always in canonical form
#
# Actual math is done in an internal format consisting of an array
# whose first element is the sign (/^[+-]$/) and whose remaining
# elements are base 100000 digits with the least significant digit first.
# The string 'NaN' is used to represent the result when input arguments
# are not numbers, as well as the result of dividing by zero
#
# routines provided are:
#
# bneg(BINT) return BINT negation
# babs(BINT) return BINT absolute value
# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0)
# badd(BINT,BINT) return BINT addition
# bsub(BINT,BINT) return BINT subtraction
# bmul(BINT,BINT) return BINT multiplication
# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar
# bmod(BINT,BINT) return BINT modulus
# bgcd(BINT,BINT) return BINT greatest common divisor
# bnorm(BINT) return BINT normalization
#
# overcome a floating point problem on certain osnames (posix-bc, os390)
BEGIN {
my $x = 100000.0;
my $use_mult = int($x*1e-5)*1e5 == $x ? 1 : 0;
}
$zero = 0;
# normalize string form of number. Strip leading zeros. Strip any
# white space and add a sign, if missing.
# Strings that are not numbers result the value 'NaN'.
sub main'bnorm { #(num_str) return num_str
local($_) = @_;
s/\s+//g; # strip white space
if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number
substr($_,$[,0) = '+' unless $1; # Add missing sign
s/^-0/+0/;
$_;
} else {
'NaN';
}
}
# Convert a number from string format to internal base 100000 format.
# Assumes normalized value as input.
sub internal { #(num_str) return int_num_array
local($d) = @_;
($is,$il) = (substr($d,$[,1),length($d)-2);
substr($d,$[,1) = '';
($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
}
# Convert a number from internal base 100000 format to string format.
# This routine scribbles all over input array.
sub external { #(int_num_array) return num_str
$es = shift;
grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad
&'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize
}
# Negate input value.
sub main'bneg { #(num_str) return num_str
local($_) = &'bnorm(@_);
vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0';
s/^./N/ unless /^[-+]/; # works both in ASCII and EBCDIC
$_;
}
# Returns the absolute value of the input.
sub main'babs { #(num_str) return num_str
&abs(&'bnorm(@_));
}
sub abs { # post-normalized abs for internal use
local($_) = @_;
s/^-/+/;
$_;
}
# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
sub main'bcmp { #(num_str, num_str) return cond_code
local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
if ($x eq 'NaN') {
undef;
} elsif ($y eq 'NaN') {
undef;
} else {
&cmp($x,$y);
}
}
sub cmp { # post-normalized compare for internal use
local($cx, $cy) = @_;
return 0 if ($cx eq $cy);
local($sx, $sy) = (substr($cx, 0, 1), substr($cy, 0, 1));
local($ld);
if ($sx eq '+') {
return 1 if ($sy eq '-' || $cy eq '+0');
$ld = length($cx) - length($cy);
return $ld if ($ld);
return $cx cmp $cy;
} else { # $sx eq '-'
return -1 if ($sy eq '+');
$ld = length($cy) - length($cx);
return $ld if ($ld);
return $cy cmp $cx;
}
}
sub main'badd { #(num_str, num_str) return num_str
local(*x, *y); ($x, $y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
if ($x eq 'NaN') {
'NaN';
} elsif ($y eq 'NaN') {
'NaN';
} else {
@x = &internal($x); # convert to internal form
@y = &internal($y);
local($sx, $sy) = (shift @x, shift @y); # get signs
if ($sx eq $sy) {
&external($sx, &add(*x, *y)); # if same sign add
} else {
($x, $y) = (&abs($x),&abs($y)); # make abs
if (&cmp($y,$x) > 0) {
&external($sy, &sub(*y, *x));
} else {
&external($sx, &sub(*x, *y));
}
}
}
}
sub main'bsub { #(num_str, num_str) return num_str
&'badd($_[$[],&'bneg($_[$[+1]));
}
# GCD -- Euclids algorithm Knuth Vol 2 pg 296
sub main'bgcd { #(num_str, num_str) return num_str
local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
if ($x eq 'NaN' || $y eq 'NaN') {
'NaN';
} else {
($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0';
$x;
}
}
# routine to add two base 1e5 numbers
# stolen from Knuth Vol 2 Algorithm A pg 231
# there are separate routines to add and sub as per Kunth pg 233
sub add { #(int_num_array, int_num_array) return int_num_array
local(*x, *y) = @_;
$car = 0;
for $x (@x) {
last unless @y || $car;
$x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0;
}
for $y (@y) {
last unless $car;
$y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0;
}
(@x, @y, $car);
}
# subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
sub sub { #(int_num_array, int_num_array) return int_num_array
local(*sx, *sy) = @_;
$bar = 0;
for $sx (@sx) {
last unless @y || $bar;
$sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0);
}
@sx;
}
# multiply two numbers -- stolen from Knuth Vol 2 pg 233
sub main'bmul { #(num_str, num_str) return num_str
local(*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1]));
if ($x eq 'NaN') {
'NaN';
} elsif ($y eq 'NaN') {
'NaN';
} else {
@x = &internal($x);
@y = &internal($y);
local($signr) = (shift @x ne shift @y) ? '-' : '+';
@prod = ();
for $x (@x) {
($car, $cty) = (0, $[);
for $y (@y) {
$prod = $x * $y + $prod[$cty] + $car;
if ($use_mult) {
$prod[$cty++] =
$prod - ($car = int($prod * 1e-5)) * 1e5;
}
else {
$prod[$cty++] =
$prod - ($car = int($prod / 1e5)) * 1e5;
}
}
$prod[$cty] += $car if $car;
$x = shift @prod;
}
&external($signr, @x, @prod);
}
}
# modulus
sub main'bmod { #(num_str, num_str) return num_str
(&'bdiv(@_))[$[+1];
}
sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str
local (*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1]));
return wantarray ? ('NaN','NaN') : 'NaN'
if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
@x = &internal($x); @y = &internal($y);
$srem = $y[$[];
$sr = (shift @x ne shift @y) ? '-' : '+';
$car = $bar = $prd = 0;
if (($dd = int(1e5/($y[$#y]+1))) != 1) {
for $x (@x) {
$x = $x * $dd + $car;
if ($use_mult) {
$x -= ($car = int($x * 1e-5)) * 1e5;
}
else {
$x -= ($car = int($x / 1e5)) * 1e5;
}
}
push(@x, $car); $car = 0;
for $y (@y) {
$y = $y * $dd + $car;
if ($use_mult) {
$y -= ($car = int($y * 1e-5)) * 1e5;
}
else {
$y -= ($car = int($y / 1e5)) * 1e5;
}
}
}
else {
push(@x, 0);
}
@q = (); ($v2,$v1) = @y[-2,-1];
while ($#x > $#y) {
($u2,$u1,$u0) = @x[-3..-1];
$q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1));
--$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2);
if ($q) {
($car, $bar) = (0,0);
for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
$prd = $q * $y[$y] + $car;
if ($use_mult) {
$prd -= ($car = int($prd * 1e-5)) * 1e5;
}
else {
$prd -= ($car = int($prd / 1e5)) * 1e5;
}
$x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0));
}
if ($x[$#x] < $car + $bar) {
$car = 0; --$q;
for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
$x[$x] -= 1e5
if ($car = (($x[$x] += $y[$y] + $car) > 1e5));
}
}
}
pop(@x); unshift(@q, $q);
}
if (wantarray) {
@d = ();
if ($dd != 1) {
$car = 0;
for $x (reverse @x) {
$prd = $car * 1e5 + $x;
$car = $prd - ($tmp = int($prd / $dd)) * $dd;
unshift(@d, $tmp);
}
}
else {
@d = @x;
}
(&external($sr, @q), &external($srem, @d, $zero));
} else {
&external($sr, @q);
}
}
1;
--- NEW FILE: bigint.pm ---
package bigint;
require 5.005;
$VERSION = '0.07';
use Exporter;
@ISA = qw( Exporter );
@EXPORT_OK = qw( );
@EXPORT = qw( inf NaN );
use strict;
use overload;
##############################################################################
# These are all alike, and thus faked by AUTOLOAD
my @faked = qw/round_mode accuracy precision div_scale/;
use vars qw/$VERSION $AUTOLOAD $_lite/; # _lite for testsuite
sub AUTOLOAD
{
my $name = $AUTOLOAD;
$name =~ s/.*:://; # split package
no strict 'refs';
foreach my $n (@faked)
{
if ($n eq $name)
{
*{"bigint::$name"} = sub
{
my $self = shift;
no strict 'refs';
if (defined $_[0])
{
return Math::BigInt->$name($_[0]);
}
return Math::BigInt->$name();
};
return &$name;
}
}
# delayed load of Carp and avoid recursion
require Carp;
Carp::croak ("Can't call bigint\-\>$name, not a valid method");
}
sub upgrade
{
my $self = shift;
no strict 'refs';
# if (defined $_[0])
# {
# $Math::BigInt::upgrade = $_[0];
# }
return $Math::BigInt::upgrade;
}
sub _constant
{
# this takes a floating point constant string and returns it truncated to
# integer. For instance, '4.5' => '4', '1.234e2' => '123' etc
my $float = shift;
# some simple cases first
return $float if ($float =~ /^[+-]?[0-9]+$/); # '+123','-1','0' etc
return $float
if ($float =~ /^[+-]?[0-9]+\.?[eE]\+?[0-9]+$/); # 123e2, 123.e+2
return '0' if ($float =~ /^[+-]?[0]*\.[0-9]+$/); # .2, 0.2, -.1
if ($float =~ /^[+-]?[0-9]+\.[0-9]*$/) # 1., 1.23, -1.2 etc
{
$float =~ s/\..*//;
return $float;
}
my ($mis,$miv,$mfv,$es,$ev) = Math::BigInt::_split($float);
return $float if !defined $mis; # doesn't look like a number to me
my $ec = int($$ev);
my $sign = $$mis; $sign = '' if $sign eq '+';
if ($$es eq '-')
{
# ignore fraction part entirely
if ($ec >= length($$miv)) # 123.23E-4
{
return '0';
}
return $sign . substr ($$miv,0,length($$miv)-$ec); # 1234.45E-2 = 12
}
# xE+y
if ($ec >= length($$mfv))
{
$ec -= length($$mfv);
return $sign.$$miv.$$mfv if $ec == 0; # 123.45E+2 => 12345
return $sign.$$miv.$$mfv.'E'.$ec; # 123.45e+3 => 12345e1
}
$mfv = substr($$mfv,0,$ec);
return $sign.$$miv.$mfv; # 123.45e+1 => 1234
}
sub import
{
my $self = shift;
# some defaults
my $lib = '';
my @import = ( ':constant' ); # drive it w/ constant
my @a = @_; my $l = scalar @_; my $j = 0;
my ($ver,$trace); # version? trace?
my ($a,$p); # accuracy, precision
for ( my $i = 0; $i < $l ; $i++,$j++ )
{
if ($_[$i] =~ /^(l|lib)$/)
{
# this causes a different low lib to take care...
$lib = $_[$i+1] || '';
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] =~ /^(a|accuracy)$/)
{
$a = $_[$i+1];
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] =~ /^(p|precision)$/)
{
$p = $_[$i+1];
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] =~ /^(v|version)$/)
{
$ver = 1;
splice @a, $j, 1; $j --;
}
elsif ($_[$i] =~ /^(t|trace)$/)
{
$trace = 1;
splice @a, $j, 1; $j --;
}
else { die "unknown option $_[$i]"; }
}
my $class;
$_lite = 0; # using M::BI::L ?
if ($trace)
{
require Math::BigInt::Trace; $class = 'Math::BigInt::Trace';
}
else
{
# see if we can find Math::BigInt::Lite
if (!defined $a && !defined $p) # rounding won't work to well
{
eval 'require Math::BigInt::Lite;';
if ($@ eq '')
{
@import = ( ); # :constant in Lite, not MBI
Math::BigInt::Lite->import( ':constant' );
$_lite= 1; # signal okay
}
}
require Math::BigInt if $_lite == 0; # not already loaded?
$class = 'Math::BigInt'; # regardless of MBIL or not
}
push @import, 'lib' => $lib if $lib ne '';
# Math::BigInt::Trace or plain Math::BigInt
$class->import(@import);
bigint->accuracy($a) if defined $a;
bigint->precision($p) if defined $p;
if ($ver)
{
print "bigint\t\t\t v$VERSION\n";
print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite;
print "Math::BigInt\t\t v$Math::BigInt::VERSION";
my $config = Math::BigInt->config();
print " lib => $config->{lib} v$config->{lib_version}\n";
exit;
}
# we take care of floating point constants, since BigFloat isn't available
# and BigInt doesn't like them:
overload::constant float => sub { Math::BigInt->new( _constant(shift) ); };
$self->export_to_level(1,$self, at a); # export inf and NaN
}
sub inf () { Math::BigInt->binf(); }
sub NaN () { Math::BigInt->bnan(); }
1;
__END__
=head1 NAME
bigint - Transparent BigInteger support for Perl
=head1 SYNOPSIS
use bigint;
$x = 2 + 4.5,"\n"; # BigInt 6
print 2 ** 512,"\n"; # really is what you think it is
print inf + 42,"\n"; # inf
print NaN * 7,"\n"; # NaN
=head1 DESCRIPTION
All operators (including basic math operations) are overloaded. Integer
constants are created as proper BigInts.
Floating point constants are truncated to integer. All results are also
truncated.
=head2 Options
bigint recognizes some options that can be passed while loading it via use.
The options can (currently) be either a single letter form, or the long form.
The following options exist:
=over 2
=item a or accuracy
This sets the accuracy for all math operations. The argument must be greater
than or equal to zero. See Math::BigInt's bround() function for details.
perl -Mbigint=a,2 -le 'print 12345+1'
=item p or precision
This sets the precision for all math operations. The argument can be any
integer. Negative values mean a fixed number of digits after the dot, and
are <B>ignored</B> since all operations happen in integer space.
A positive value rounds to this digit left from the dot. 0 or 1 mean round to
integer and are ignore like negative values.
See Math::BigInt's bfround() function for details.
perl -Mbignum=p,5 -le 'print 123456789+123'
=item t or trace
This enables a trace mode and is primarily for debugging bigint or
Math::BigInt.
=item l or lib
Load a different math lib, see L<MATH LIBRARY>.
perl -Mbigint=l,GMP -e 'print 2 ** 512'
Currently there is no way to specify more than one library on the command
line. This will be hopefully fixed soon ;)
=item v or version
This prints out the name and version of all modules used and then exits.
perl -Mbigint=v
=head2 Math Library
Math with the numbers is done (by default) by a module called
Math::BigInt::Calc. This is equivalent to saying:
use bigint lib => 'Calc';
You can change this by using:
use bigint lib => 'BitVect';
The following would first try to find Math::BigInt::Foo, then
Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
use bigint lib => 'Foo,Math::BigInt::Bar';
Please see respective module documentation for further details.
=head2 Internal Format
The numbers are stored as objects, and their internals might change at anytime,
especially between math operations. The objects also might belong to different
classes, like Math::BigInt, or Math::BigInt::Lite. Mixing them together, even
with normal scalars is not extraordinary, but normal and expected.
You should not depend on the internal format, all accesses must go through
accessor methods. E.g. looking at $x->{sign} is not a good idea since there
is no guaranty that the object in question has such a hash key, nor is a hash
underneath at all.
=head2 Sign
The sign is either '+', '-', 'NaN', '+inf' or '-inf'.
You can access it with the sign() method.
A sign of 'NaN' is used to represent the result when input arguments are not
numbers or as a result of 0/0. '+inf' and '-inf' represent plus respectively
minus infinity. You will get '+inf' when dividing a positive number by 0, and
'-inf' when dividing any negative number by 0.
=head2 Methods
Since all numbers are now objects, you can use all functions that are part of
the BigInt API. You can only use the bxxx() notation, and not the fxxx()
notation, though.
=head2 Caveat
But a warning is in order. When using the following to make a copy of a number,
only a shallow copy will be made.
$x = 9; $y = $x;
$x = $y = 7;
Using the copy or the original with overloaded math is okay, e.g. the
following work:
$x = 9; $y = $x;
print $x + 1, " ", $y,"\n"; # prints 10 9
but calling any method that modifies the number directly will result in
B<both> the original and the copy beeing destroyed:
$x = 9; $y = $x;
print $x->badd(1), " ", $y,"\n"; # prints 10 10
$x = 9; $y = $x;
print $x->binc(1), " ", $y,"\n"; # prints 10 10
$x = 9; $y = $x;
print $x->bmul(2), " ", $y,"\n"; # prints 18 18
Using methods that do not modify, but testthe contents works:
$x = 9; $y = $x;
$z = 9 if $x->is_zero(); # works fine
See the documentation about the copy constructor and C<=> in overload, as
well as the documentation in BigInt for further details.
=head1 MODULES USED
C<bigint> is just a thin wrapper around various modules of the Math::BigInt
family. Think of it as the head of the family, who runs the shop, and orders
the others to do the work.
The following modules are currently used by bigint:
Math::BigInt::Lite (for speed, and only if it is loadable)
Math::BigInt
=head1 EXAMPLES
Some cool command line examples to impress the Python crowd ;) You might want
to compare them to the results under -Mbignum or -Mbigrat:
perl -Mbigint -le 'print sqrt(33)'
perl -Mbigint -le 'print 2*255'
perl -Mbigint -le 'print 4.5+2*255'
perl -Mbigint -le 'print 3/7 + 5/7 + 8/3'
perl -Mbigint -le 'print 123->is_odd()'
perl -Mbigint -le 'print log(2)'
perl -Mbigint -le 'print 2 ** 0.5'
perl -Mbigint=a,65 -le 'print 2 ** 0.2'
=head1 LICENSE
This program is free software; you may redistribute it and/or modify it under
the same terms as Perl itself.
=head1 SEE ALSO
Especially L<bigrat> as in C<perl -Mbigrat -le 'print 1/3+1/4'> and
L<bignum> as in C<perl -Mbignum -le 'print sqrt(2)'>.
L<Math::BigInt>, L<Math::BigRat> and L<Math::Big> as well
as L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
=head1 AUTHORS
(C) by Tels L<http://bloodgate.com/> in early 2002 - 2005.
=cut
--- NEW FILE: locale.t ---
#!./perl -wT
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
unshift @INC, '.';
require Config; import Config;
if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
print "1..0\n";
exit;
}
$| = 1;
}
use strict;
my $debug = 1;
use Dumpvalue;
my $dumper = Dumpvalue->new(
tick => qq{"},
quoteHighBit => 0,
unctrl => "quote"
);
sub debug {
return unless $debug;
my($mess) = join "", @_;
chop $mess;
print $dumper->stringify($mess,1), "\n";
}
sub debugf {
printf @_ if $debug;
}
my $have_setlocale = 0;
eval {
require POSIX;
import POSIX ':locale_h';
$have_setlocale++;
};
# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
# and mingw32 uses said silly CRT
$have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i);
# UWIN seems to loop after test 98, just skip for now
$have_setlocale = 0 if ($^O =~ /^uwin/);
my $last = $have_setlocale ? &last : &last_without_setlocale;
print "1..$last\n";
use vars qw(&LC_ALL);
$a = 'abc %';
sub ok {
my ($n, $result) = @_;
print 'not ' unless ($result);
print "ok $n\n";
}
# First we'll do a lot of taint checking for locales.
# This is the easiest to test, actually, as any locale,
# even the default locale will taint under 'use locale'.
sub is_tainted { # hello, camel two.
no warnings 'uninitialized' ;
my $dummy;
not eval { $dummy = join("", @_), kill 0; 1 }
}
sub check_taint ($$) {
ok $_[0], is_tainted($_[1]);
}
sub check_taint_not ($$) {
ok $_[0], not is_tainted($_[1]);
}
use locale; # engage locale and therefore locale taint.
check_taint_not 1, $a;
check_taint 2, uc($a);
check_taint 3, "\U$a";
check_taint 4, ucfirst($a);
check_taint 5, "\u$a";
check_taint 6, lc($a);
check_taint 7, "\L$a";
check_taint 8, lcfirst($a);
check_taint 9, "\l$a";
check_taint_not 10, sprintf('%e', 123.456);
check_taint_not 11, sprintf('%f', 123.456);
check_taint_not 12, sprintf('%g', 123.456);
check_taint_not 13, sprintf('%d', 123.456);
check_taint_not 14, sprintf('%x', 123.456);
$_ = $a; # untaint $_
$_ = uc($a); # taint $_
check_taint 15, $_;
/(\w)/; # taint $&, $`, $', $+, $1.
check_taint 16, $&;
check_taint 17, $`;
check_taint 18, $';
check_taint 19, $+;
check_taint 20, $1;
check_taint_not 21, $2;
/(.)/; # untaint $&, $`, $', $+, $1.
check_taint_not 22, $&;
check_taint_not 23, $`;
check_taint_not 24, $';
check_taint_not 25, $+;
check_taint_not 26, $1;
check_taint_not 27, $2;
/(\W)/; # taint $&, $`, $', $+, $1.
check_taint 28, $&;
check_taint 29, $`;
check_taint 30, $';
check_taint 31, $+;
check_taint 32, $1;
check_taint_not 33, $2;
/(\s)/; # taint $&, $`, $', $+, $1.
check_taint 34, $&;
check_taint 35, $`;
check_taint 36, $';
check_taint 37, $+;
check_taint 38, $1;
check_taint_not 39, $2;
/(\S)/; # taint $&, $`, $', $+, $1.
check_taint 40, $&;
check_taint 41, $`;
check_taint 42, $';
check_taint 43, $+;
check_taint 44, $1;
check_taint_not 45, $2;
$_ = $a; # untaint $_
check_taint_not 46, $_;
/(b)/; # this must not taint
check_taint_not 47, $&;
check_taint_not 48, $`;
check_taint_not 49, $';
check_taint_not 50, $+;
check_taint_not 51, $1;
check_taint_not 52, $2;
$_ = $a; # untaint $_
check_taint_not 53, $_;
$b = uc($a); # taint $b
s/(.+)/$b/; # this must taint only the $_
check_taint 54, $_;
check_taint_not 55, $&;
check_taint_not 56, $`;
check_taint_not 57, $';
check_taint_not 58, $+;
check_taint_not 59, $1;
check_taint_not 60, $2;
$_ = $a; # untaint $_
s/(.+)/b/; # this must not taint
check_taint_not 61, $_;
check_taint_not 62, $&;
check_taint_not 63, $`;
check_taint_not 64, $';
check_taint_not 65, $+;
check_taint_not 66, $1;
check_taint_not 67, $2;
$b = $a; # untaint $b
($b = $a) =~ s/\w/$&/;
check_taint 68, $b; # $b should be tainted.
check_taint_not 69, $a; # $a should be not.
$_ = $a; # untaint $_
s/(\w)/\l$1/; # this must taint
check_taint 70, $_;
check_taint 71, $&;
check_taint 72, $`;
check_taint 73, $';
check_taint 74, $+;
check_taint 75, $1;
check_taint_not 76, $2;
$_ = $a; # untaint $_
s/(\w)/\L$1/; # this must taint
check_taint 77, $_;
check_taint 78, $&;
check_taint 79, $`;
check_taint 80, $';
check_taint 81, $+;
check_taint 82, $1;
check_taint_not 83, $2;
$_ = $a; # untaint $_
s/(\w)/\u$1/; # this must taint
check_taint 84, $_;
check_taint 85, $&;
check_taint 86, $`;
check_taint 87, $';
check_taint 88, $+;
check_taint 89, $1;
check_taint_not 90, $2;
$_ = $a; # untaint $_
s/(\w)/\U$1/; # this must taint
check_taint 91, $_;
check_taint 92, $&;
check_taint 93, $`;
check_taint 94, $';
check_taint 95, $+;
check_taint 96, $1;
check_taint_not 97, $2;
# After all this tainting $a should be cool.
check_taint_not 98, $a;
sub last_without_setlocale { 98 }
# I think we've seen quite enough of taint.
# Let us do some *real* locale work now,
# unless setlocale() is missing (i.e. minitest).
exit unless $have_setlocale;
# Find locales.
debug "# Scanning for locales...\n";
# Note that it's okay that some languages have their native names
# capitalized here even though that's not "right". They are lowercased
# anyway later during the scanning process (and besides, some clueless
# vendor might have them capitalized errorneously anyway).
my $locales = <<EOF;
Afrikaans:af:za:1 15
Arabic:ar:dz eg sa:6 arabic8
Brezhoneg Breton:br:fr:1 15
Bulgarski Bulgarian:bg:bg:5
Chinese:zh:cn tw:cn.EUC eucCN eucTW euc.CN euc.TW Big5 GB2312 tw.EUC
Hrvatski Croatian:hr:hr:2
Cymraeg Welsh:cy:cy:1 14 15
Czech:cs:cz:2
Dansk Danish:dk:da:1 15
Nederlands Dutch:nl:be nl:1 15
English American British:en:au ca gb ie nz us uk zw:1 15 cp850
Esperanto:eo:eo:3
Eesti Estonian:et:ee:4 6 13
Suomi Finnish:fi:fi:1 15
Flamish::fl:1 15
Deutsch German:de:at be ch de lu:1 15
Euskaraz Basque:eu:es fr:1 15
Galego Galician:gl:es:1 15
Ellada Greek:el:gr:7 g8
Frysk:fy:nl:1 15
Greenlandic:kl:gl:4 6
Hebrew:iw:il:8 hebrew8
Hungarian:hu:hu:2
Indonesian:in:id:1 15
Gaeilge Irish:ga:IE:1 14 15
Italiano Italian:it:ch it:1 15
Nihongo Japanese:ja:jp:euc eucJP jp.EUC sjis
Korean:ko:kr:
Latine Latin:la:va:1 15
Latvian:lv:lv:4 6 13
Lithuanian:lt:lt:4 6 13
Macedonian:mk:mk:1 15
Maltese:mt:mt:3
Moldovan:mo:mo:2
Norsk Norwegian:no no\@nynorsk:no:1 15
Occitan:oc:es:1 15
Polski Polish:pl:pl:2
Rumanian:ro:ro:2
Russki Russian:ru:ru su ua:5 koi8 koi8r KOI8-R koi8u cp1251 cp866
Serbski Serbian:sr:yu:5
Slovak:sk:sk:2
Slovene Slovenian:sl:si:2
Sqhip Albanian:sq:sq:1 15
Svenska Swedish:sv:fi se:1 15
Thai:th:th:11 tis620
Turkish:tr:tr:9 turkish8
Yiddish:yi::1 15
EOF
if ($^O eq 'os390') {
# These cause heartburn. Broken locales?
$locales =~ s/Svenska Swedish:sv:fi se:1 15\n//;
$locales =~ s/Thai:th:th:11 tis620\n//;
}
sub in_utf8 () { $^H & 0x08 || (${^OPEN} || "") =~ /:utf8/ }
if (in_utf8) {
require "lib/locale/utf8";
} else {
require "lib/locale/latin1";
}
my @Locale;
my $Locale;
my @Alnum_;
my @utf8locale;
my %utf8skip;
sub getalnum_ {
sort grep /\w/, map { chr } 0..255
}
sub trylocale {
my $locale = shift;
if (setlocale(LC_ALL, $locale)) {
push @Locale, $locale;
}
}
sub decode_encodings {
my @enc;
foreach (split(/ /, shift)) {
if (/^(\d+)$/) {
push @enc, "ISO8859-$1";
push @enc, "iso8859$1"; # HP
if ($1 eq '1') {
push @enc, "roman8"; # HP
}
} else {
push @enc, $_;
push @enc, "$_.UTF-8";
}
}
if ($^O eq 'os390') {
push @enc, qw(IBM-037 IBM-819 IBM-1047);
}
return @enc;
}
trylocale("C");
trylocale("POSIX");
foreach (0..15) {
trylocale("ISO8859-$_");
trylocale("iso8859$_");
trylocale("iso8859-$_");
trylocale("iso_8859_$_");
trylocale("isolatin$_");
trylocale("isolatin-$_");
trylocale("iso_latin_$_");
}
# Sanitize the environment so that we can run the external 'locale'
# program without the taint mode getting grumpy.
# $ENV{PATH} is special in VMS.
delete $ENV{PATH} if $^O ne 'VMS' or $Config{d_setenv};
# Other subversive stuff.
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a 2>/dev/null|")) {
while (<LOCALES>) {
# It seems that /usr/bin/locale steadfastly outputs 8 bit data, which
# ain't great when we're running this testPERL_UNICODE= so that utf8
# locales will cause all IO hadles to default to (assume) utf8
next unless utf8::valid($_);
chomp;
trylocale($_);
}
close(LOCALES);
} elsif ($^O eq 'VMS' && defined($ENV{'SYS$I18N_LOCALE'}) && -d 'SYS$I18N_LOCALE') {
# The SYS$I18N_LOCALE logical name search list was not present on
# VAX VMS V5.5-12, but was on AXP && VAX VMS V6.2 as well as later versions.
opendir(LOCALES, "SYS\$I18N_LOCALE:");
while ($_ = readdir(LOCALES)) {
chomp;
trylocale($_);
}
close(LOCALES);
} else {
# This is going to be slow.
foreach my $locale (split(/\n/, $locales)) {
my ($locale_name, $language_codes, $country_codes, $encodings) =
split(/:/, $locale);
my @enc = decode_encodings($encodings);
foreach my $loc (split(/ /, $locale_name)) {
trylocale($loc);
foreach my $enc (@enc) {
trylocale("$loc.$enc");
}
$loc = lc $loc;
foreach my $enc (@enc) {
trylocale("$loc.$enc");
}
}
foreach my $lang (split(/ /, $language_codes)) {
trylocale($lang);
foreach my $country (split(/ /, $country_codes)) {
my $lc = "${lang}_${country}";
trylocale($lc);
foreach my $enc (@enc) {
trylocale("$lc.$enc");
}
my $lC = "${lang}_\U${country}";
trylocale($lC);
foreach my $enc (@enc) {
trylocale("$lC.$enc");
}
}
}
}
}
setlocale(LC_ALL, "C");
if ($^O eq 'darwin') {
# Darwin 8/Mac OS X 10.4 has bad Basque locales: perl bug #35895,
# Apple bug ID# 4139653. It also has a problem in Byelorussian.
if ($Config{osvers} ge '8' and $Config{osvers} lt '9') {
debug "# Skipping eu_ES, be_BY locales -- buggy in Darwin\n";
@Locale = grep ! m/^(eu_ES|be_BY.CP1131$)/, @Locale;
}
}
@Locale = sort @Locale;
debug "# Locales =\n";
for ( @Locale ) {
debug "# $_\n";
}
my %Problem;
my %Okay;
my %Testing;
my @Neoalpha;
my %Neoalpha;
sub tryneoalpha {
my ($Locale, $i, $test) = @_;
unless ($test) {
$Problem{$i}{$Locale} = 1;
debug "# failed $i with locale '$Locale'\n";
} else {
push @{$Okay{$i}}, $Locale;
}
}
foreach $Locale (@Locale) {
debug "# Locale = $Locale\n";
@Alnum_ = getalnum_();
debug "# w = ", join("", at Alnum_), "\n";
unless (setlocale(LC_ALL, $Locale)) {
foreach (99..103) {
$Problem{$_}{$Locale} = -1;
}
next;
}
# Sieve the uppercase and the lowercase.
my %UPPER = ();
my %lower = ();
my %BoThCaSe = ();
for (@Alnum_) {
if (/[^\d_]/) { # skip digits and the _
if (uc($_) eq $_) {
$UPPER{$_} = $_;
}
if (lc($_) eq $_) {
$lower{$_} = $_;
}
}
}
foreach (keys %UPPER) {
$BoThCaSe{$_}++ if exists $lower{$_};
}
foreach (keys %lower) {
$BoThCaSe{$_}++ if exists $UPPER{$_};
}
foreach (keys %BoThCaSe) {
delete $UPPER{$_};
delete $lower{$_};
}
debug "# UPPER = ", join("", sort keys %UPPER ), "\n";
debug "# lower = ", join("", sort keys %lower ), "\n";
debug "# BoThCaSe = ", join("", sort keys %BoThCaSe), "\n";
# Find the alphabets that are not alphabets in the default locale.
{
no locale;
@Neoalpha = ();
for (keys %UPPER, keys %lower) {
push(@Neoalpha, $_) if (/\W/);
$Neoalpha{$_} = $_;
}
}
@Neoalpha = sort @Neoalpha;
debug "# Neoalpha = ", join("", at Neoalpha), "\n";
if (@Neoalpha == 0) {
# If we have no Neoalphas the remaining tests are no-ops.
debug "# no Neoalpha, skipping tests 99..102 for locale '$Locale'\n";
foreach (99..102) {
push @{$Okay{$_}}, $Locale;
}
} else {
# Test \w.
my $word = join('', @Neoalpha);
my $badutf8;
{
local $SIG{__WARN__} = sub {
$badutf8 = $_[0] =~ /Malformed UTF-8/;
};
$Locale =~ /utf-?8/i;
}
if ($badutf8) {
debug "# Locale name contains bad UTF-8, skipping test 99 for locale '$Locale'\n";
} elsif ($Locale =~ /utf-?8/i) {
debug "# unknown whether locale and Unicode have the same \\w, skipping test 99 for locale '$Locale'\n";
push @{$Okay{99}}, $Locale;
} else {
if ($word =~ /^(\w+)$/) {
tryneoalpha($Locale, 99, 1);
} else {
tryneoalpha($Locale, 99, 0);
}
}
# Cross-check the whole 8-bit character set.
for (map { chr } 0..255) {
tryneoalpha($Locale, 100,
(/\w/ xor /\W/) ||
(/\d/ xor /\D/) ||
(/\s/ xor /\S/));
}
# Test for read-only scalars' locale vs non-locale comparisons.
{
no locale;
$a = "qwerty";
{
use locale;
tryneoalpha($Locale, 101, ($a cmp "qwerty") == 0);
}
}
{
my ($from, $to, $lesser, $greater,
@test, %test, $test, $yes, $no, $sign);
for (0..9) {
# Select a slice.
$from = int(($_*@Alnum_)/10);
$to = $from + int(@Alnum_/10);
$to = $#Alnum_ if ($to > $#Alnum_);
$lesser = join('', @Alnum_[$from..$to]);
# Select a slice one character on.
$from++; $to++;
$to = $#Alnum_ if ($to > $#Alnum_);
$greater = join('', @Alnum_[$from..$to]);
($yes, $no, $sign) = ($lesser lt $greater
? (" ", "not ", 1)
: ("not ", " ", -1));
# all these tests should FAIL (return 0).
# Exact lt or gt cannot be tested because
# in some locales, say, eacute and E may test equal.
@test =
(
$no.' ($lesser le $greater)', # 1
'not ($lesser ne $greater)', # 2
' ($lesser eq $greater)', # 3
$yes.' ($lesser ge $greater)', # 4
$yes.' ($lesser ge $greater)', # 5
$yes.' ($greater le $lesser )', # 7
'not ($greater ne $lesser )', # 8
' ($greater eq $lesser )', # 9
$no.' ($greater ge $lesser )', # 10
'not (($lesser cmp $greater) == -($sign))' # 11
);
@test{@test} = 0 x @test;
$test = 0;
for my $ti (@test) {
$test{$ti} = eval $ti;
$test ||= $test{$ti}
}
tryneoalpha($Locale, 102, $test == 0);
if ($test) {
debug "# lesser = '$lesser'\n";
debug "# greater = '$greater'\n";
debug "# lesser cmp greater = ",
$lesser cmp $greater, "\n";
debug "# greater cmp lesser = ",
$greater cmp $lesser, "\n";
debug "# (greater) from = $from, to = $to\n";
for my $ti (@test) {
debugf("# %-40s %-4s", $ti,
$test{$ti} ? 'FAIL' : 'ok');
if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
debugf("(%s == %4d)", $1, eval $1);
}
debug "\n#";
}
last;
}
}
}
}
use locale;
my ($x, $y) = (1.23, 1.23);
$a = "$x";
printf ''; # printf used to reset locale to "C"
$b = "$y";
debug "# 103..107: a = $a, b = $b, Locale = $Locale\n";
tryneoalpha($Locale, 103, $a eq $b);
my $c = "$x";
my $z = sprintf ''; # sprintf used to reset locale to "C"
my $d = "$y";
debug "# 104..107: c = $c, d = $d, Locale = $Locale\n";
tryneoalpha($Locale, 104, $c eq $d);
{
use warnings;
my $w = 0;
local $SIG{__WARN__} =
sub {
print "# @_\n";
$w++;
};
# The == (among other ops) used to warn for locales
# that had something else than "." as the radix character.
tryneoalpha($Locale, 105, $c == 1.23);
tryneoalpha($Locale, 106, $c == $x);
tryneoalpha($Locale, 107, $c == $d);
{
# no locale; # XXX did this ever work correctly?
my $e = "$x";
debug "# 108..110: e = $e, Locale = $Locale\n";
tryneoalpha($Locale, 108, $e == 1.23);
tryneoalpha($Locale, 109, $e == $x);
tryneoalpha($Locale, 110, $e == $c);
}
my $f = "1.23";
my $g = 2.34;
debug "# 111..115: f = $f, g = $g, locale = $Locale\n";
tryneoalpha($Locale, 111, $f == 1.23);
tryneoalpha($Locale, 112, $f == $x);
tryneoalpha($Locale, 113, $f == $c);
tryneoalpha($Locale, 114, abs(($f + $g) - 3.57) < 0.01);
tryneoalpha($Locale, 115, $w == 0);
}
# Does taking lc separately differ from taking
# the lc "in-line"? (This was the bug 19990704.002, change #3568.)
# The bug was in the caching of the 'o'-magic.
{
use locale;
sub lcA {
my $lc0 = lc $_[0];
my $lc1 = lc $_[1];
return $lc0 cmp $lc1;
}
sub lcB {
return lc($_[0]) cmp lc($_[1]);
}
my $x = "ab";
my $y = "aa";
my $z = "AB";
tryneoalpha($Locale, 116,
lcA($x, $y) == 1 && lcB($x, $y) == 1 ||
lcA($x, $z) == 0 && lcB($x, $z) == 0);
}
# Does lc of an UPPER (if different from the UPPER) match
# case-insensitively the UPPER, and does the UPPER match
# case-insensitively the lc of the UPPER. And vice versa.
{
use locale;
no utf8;
my $re = qr/[\[\(\{\*\+\?\|\^\$\\]/;
my @f = ();
foreach my $x (keys %UPPER) {
my $y = lc $x;
next unless uc $y eq $x;
print "# UPPER $x lc $y ",
$x =~ /$y/i ? 1 : 0, " ",
$y =~ /$x/i ? 1 : 0, "\n" if 0;
#
# If $x and $y contain regular expression characters
# AND THEY lowercase (/i) to regular expression characters,
# regcomp() will be mightily confused. No, the \Q doesn't
# help here (maybe regex engine internal lowercasing
# is done after the \Q?) An example of this happening is
# the bg_BG (Bulgarian) locale under EBCDIC (OS/390 USS):
# the chr(173) (the "[") is the lowercase of the chr(235).
#
# Similarly losing EBCDIC locales include cs_cz, cs_CZ,
# el_gr, el_GR, en_us.IBM-037 (!), en_US.IBM-037 (!),
# et_ee, et_EE, hr_hr, hr_HR, hu_hu, hu_HU, lt_LT,
# mk_mk, mk_MK, nl_nl.IBM-037, nl_NL.IBM-037,
# pl_pl, pl_PL, ro_ro, ro_RO, ru_ru, ru_RU,
# sk_sk, sk_SK, sl_si, sl_SI, tr_tr, tr_TR.
#
# Similar things can happen even under (bastardised)
# non-EBCDIC locales: in many European countries before the
# advent of ISO 8859-x nationally customised versions of
# ISO 646 were devised, reusing certain punctuation
# characters for modified characters needed by the
# country/language. For example, the "|" might have
# stood for U+00F6 or LATIN SMALL LETTER O WITH DIAERESIS.
#
if ($x =~ $re || $y =~ $re) {
print "# Regex characters in '$x' or '$y', skipping test 117 for locale '$Locale'\n";
next;
}
# With utf8 both will fail since the locale concept
# of upper/lower does not work well in Unicode.
push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
foreach my $x (keys %lower) {
my $y = uc $x;
next unless lc $y eq $x;
print "# lower $x uc $y ",
$x =~ /$y/i ? 1 : 0, " ",
$y =~ /$x/i ? 1 : 0, "\n" if 0;
if ($x =~ $re || $y =~ $re) { # See above.
print "# Regex characters in '$x' or '$y', skipping test 117 for locale '$Locale'\n";
next;
}
# With utf8 both will fail since the locale concept
# of upper/lower does not work well in Unicode.
push @f, $x unless $x =~ /$y/i == $y =~ /$x/i;
}
tryneoalpha($Locale, 117, @f == 0);
if (@f) {
print "# failed 117 locale '$Locale' characters @f\n"
}
}
}
}
# Recount the errors.
foreach (&last_without_setlocale()+1..$last) {
if ($Problem{$_} || !defined $Okay{$_} || !@{$Okay{$_}}) {
if ($_ == 102) {
print "# The failure of test 102 is not necessarily fatal.\n";
print "# It usually indicates a problem in the environment,\n";
print "# not in Perl itself.\n";
}
print "not ";
}
print "ok $_\n";
}
# Give final advice.
my $didwarn = 0;
foreach (99..$last) {
if ($Problem{$_}) {
my @f = sort keys %{ $Problem{$_} };
my $f = join(" ", @f);
$f =~ s/(.{50,60}) /$1\n#\t/g;
print
"#\n",
"# The locale ", (@f == 1 ? "definition" : "definitions"), "\n#\n",
"#\t", $f, "\n#\n",
"# on your system may have errors because the locale test $_\n",
"# failed in ", (@f == 1 ? "that locale" : "those locales"),
".\n";
print <<EOW;
#
# If your users are not using these locales you are safe for the moment,
# but please report this failure first to perlbug\@perl.com using the
# perlbug script (as described in the INSTALL file) so that the exact
# details of the failures can be sorted out first and then your operating
# system supplier can be alerted about these anomalies.
#
EOW
$didwarn = 1;
}
}
# Tell which locales were okay and which were not.
if ($didwarn) {
my (@s, @F);
foreach my $l (@Locale) {
my $p = 0;
foreach my $t (102..$last) {
$p++ if $Problem{$t}{$l};
}
push @s, $l if $p == 0;
push @F, $l unless $p == 0;
}
if (@s) {
my $s = join(" ", @s);
$s =~ s/(.{50,60}) /$1\n#\t/g;
warn
"# The following locales\n#\n",
"#\t", $s, "\n#\n",
"# tested okay.\n#\n",
} else {
warn "# None of your locales were fully okay.\n";
}
if (@F) {
my $F = join(" ", @F);
$F =~ s/(.{50,60}) /$1\n#\t/g;
warn
"# The following locales\n#\n",
"#\t", $F, "\n#\n",
"# had problems.\n#\n",
} else {
warn "# None of your locales were broken.\n";
}
if (@utf8locale) {
my $S = join(" ", @utf8locale);
$S =~ s/(.{50,60}) /$1\n#\t/g;
warn "#\n# The following locales\n#\n",
"#\t", $S, "\n#\n",
"# were skipped for the tests ",
join(" ", sort {$a<=>$b} keys %utf8skip), "\n",
"# because UTF-8 and locales do not work together in Perl.\n#\n";
}
}
sub last { 117 }
# eof
--- NEW FILE: vmsish.pm ---
package vmsish;
our $VERSION = '1.02';
=head1 NAME
vmsish - Perl pragma to control VMS-specific language features
=head1 SYNOPSIS
use vmsish;
use vmsish 'status'; # or '$?'
use vmsish 'exit';
use vmsish 'time';
use vmsish 'hushed';
no vmsish 'hushed';
vmsish::hushed($hush);
use vmsish;
no vmsish 'time';
=head1 DESCRIPTION
If no import list is supplied, all possible VMS-specific features are
assumed. Currently, there are four VMS-specific features available:
'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'.
If you're not running VMS, this module does nothing.
=over 6
=item C<vmsish status>
This makes C<$?> and C<system> return the native VMS exit status
instead of emulating the POSIX exit status.
=item C<vmsish exit>
This makes C<exit 1> produce a successful exit (with status SS$_NORMAL),
instead of emulating UNIX exit(), which considers C<exit 1> to indicate
an error. As with the CRTL's exit() function, C<exit 0> is also mapped
to an exit status of SS$_NORMAL, and any other argument to exit() is
used directly as Perl's exit status.
=item C<vmsish time>
This makes all times relative to the local time zone, instead of the
default of Universal Time (a.k.a Greenwich Mean Time, or GMT).
=item C<vmsish hushed>
This suppresses printing of VMS status messages to SYS$OUTPUT and
SYS$ERROR if Perl terminates with an error status. and allows
programs that are expecting "unix-style" Perl to avoid having to parse
VMS error messages. It does not suppress any messages from Perl
itself, just the messages generated by DCL after Perl exits. The DCL
symbol $STATUS will still have the termination status, but with a
high-order bit set:
EXAMPLE:
$ perl -e"exit 44;" Non-hushed error exit
%SYSTEM-F-ABORT, abort DCL message
$ show sym $STATUS
$STATUS == "%X0000002C"
$ perl -e"use vmsish qw(hushed); exit 44;" Hushed error exit
$ show sym $STATUS
$STATUS == "%X1000002C"
The 'hushed' flag has a global scope during compilation: the exit() or
die() commands that are compiled after 'vmsish hushed' will be hushed
when they are executed. Doing a "no vmsish 'hushed'" turns off the
hushed flag.
The status of the hushed flag also affects output of VMS error
messages from compilation errors. Again, you still get the Perl
error message (and the code in $STATUS)
EXAMPLE:
use vmsish 'hushed'; # turn on hushed flag
use Carp; # Carp compiled hushed
exit 44; # will be hushed
croak('I die'); # will be hushed
no vmsish 'hushed'; # turn off hushed flag
exit 44; # will not be hushed
croak('I die2'): # WILL be hushed, croak was compiled hushed
You can also control the 'hushed' flag at run-time, using the built-in
routine vmsish::hushed(). Without argument, it returns the hushed status.
Since vmsish::hushed is built-in, you do not need to "use vmsish" to call
it.
EXAMPLE:
if ($quiet_exit) {
vmsish::hushed(1);
}
print "Sssshhhh...I'm hushed...\n" if vmsish::hushed();
exit 44;
Note that an exit() or die() that is compiled 'hushed' because of "use
vmsish" is not un-hushed by calling vmsish::hushed(0) at runtime.
The messages from error exits from inside the Perl core are generally
more serious, and are not suppressed.
=back
See L<perlmod/Pragmatic Modules>.
=cut
my $IsVMS = $^O eq 'VMS';
sub bits {
my $bits = 0;
my $sememe;
foreach $sememe (@_) {
# Those hints are defined in vms/vmsish.h :
# HINT_M_VMSISH_STATUS and HINT_M_VMSISH_TIME
$bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?';
$bits |= 0x80000000, next if $sememe eq 'time';
}
$bits;
}
sub import {
return unless $IsVMS;
shift;
$^H |= bits(@_ ? @_ : qw(status time));
my $sememe;
foreach $sememe (@_ ? @_ : qw(exit hushed)) {
$^H{'vmsish_exit'} = 1 if $sememe eq 'exit';
vmsish::hushed(1) if $sememe eq 'hushed';
}
}
sub unimport {
return unless $IsVMS;
shift;
$^H &= ~ bits(@_ ? @_ : qw(status time));
my $sememe;
foreach $sememe (@_ ? @_ : qw(exit hushed)) {
$^H{'vmsish_exit'} = 0 if $sememe eq 'exit';
vmsish::hushed(0) if $sememe eq 'hushed';
}
}
1;
--- NEW FILE: bignum.pm ---
package bignum;
require 5.005;
$VERSION = '0.17';
use Exporter;
@EXPORT_OK = qw( );
@EXPORT = qw( inf NaN );
@ISA = qw( Exporter );
use strict;
##############################################################################
# These are all alike, and thus faked by AUTOLOAD
my @faked = qw/round_mode accuracy precision div_scale/;
use vars qw/$VERSION $AUTOLOAD $_lite/; # _lite for testsuite
sub AUTOLOAD
{
my $name = $AUTOLOAD;
$name =~ s/.*:://; # split package
no strict 'refs';
foreach my $n (@faked)
{
if ($n eq $name)
{
*{"bignum::$name"} = sub
{
my $self = shift;
no strict 'refs';
if (defined $_[0])
{
Math::BigInt->$name($_[0]);
return Math::BigFloat->$name($_[0]);
}
return Math::BigInt->$name();
};
return &$name;
}
}
# delayed load of Carp and avoid recursion
require Carp;
Carp::croak ("Can't call bignum\-\>$name, not a valid method");
}
sub upgrade
{
my $self = shift;
no strict 'refs';
# if (defined $_[0])
# {
# $Math::BigInt::upgrade = $_[0];
# $Math::BigFloat::upgrade = $_[0];
# }
return $Math::BigInt::upgrade;
}
sub import
{
my $self = shift;
# some defaults
my $lib = '';
my $upgrade = 'Math::BigFloat';
my $downgrade = 'Math::BigInt';
my @import = ( ':constant' ); # drive it w/ constant
my @a = @_; my $l = scalar @_; my $j = 0;
my ($ver,$trace); # version? trace?
my ($a,$p); # accuracy, precision
for ( my $i = 0; $i < $l ; $i++,$j++ )
{
if ($_[$i] eq 'upgrade')
{
# this causes upgrading
$upgrade = $_[$i+1]; # or undef to disable
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] eq 'downgrade')
{
# this causes downgrading
$downgrade = $_[$i+1]; # or undef to disable
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] =~ /^(l|lib)$/)
{
# this causes a different low lib to take care...
$lib = $_[$i+1] || '';
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] =~ /^(a|accuracy)$/)
{
$a = $_[$i+1];
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] =~ /^(p|precision)$/)
{
$p = $_[$i+1];
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] =~ /^(v|version)$/)
{
$ver = 1;
splice @a, $j, 1; $j --;
}
elsif ($_[$i] =~ /^(t|trace)$/)
{
$trace = 1;
splice @a, $j, 1; $j --;
}
else { die "unknown option $_[$i]"; }
}
my $class;
$_lite = 0; # using M::BI::L ?
if ($trace)
{
require Math::BigInt::Trace; $class = 'Math::BigInt::Trace';
$upgrade = 'Math::BigFloat::Trace';
}
else
{
# see if we can find Math::BigInt::Lite
if (!defined $a && !defined $p) # rounding won't work to well
{
eval 'require Math::BigInt::Lite;';
if ($@ eq '')
{
@import = ( ); # :constant in Lite, not MBI
Math::BigInt::Lite->import( ':constant' );
$_lite= 1; # signal okay
}
}
require Math::BigInt if $_lite == 0; # not already loaded?
$class = 'Math::BigInt'; # regardless of MBIL or not
}
push @import, 'lib' => $lib if $lib ne '';
# Math::BigInt::Trace or plain Math::BigInt
$class->import(@import, upgrade => $upgrade);
if ($trace)
{
require Math::BigFloat::Trace; $class = 'Math::BigFloat::Trace';
$downgrade = 'Math::BigInt::Trace';
}
else
{
require Math::BigFloat; $class = 'Math::BigFloat';
}
$class->import(':constant','downgrade',$downgrade);
bignum->accuracy($a) if defined $a;
bignum->precision($p) if defined $p;
if ($ver)
{
print "bignum\t\t\t v$VERSION\n";
print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite;
print "Math::BigInt\t\t v$Math::BigInt::VERSION";
my $config = Math::BigInt->config();
print " lib => $config->{lib} v$config->{lib_version}\n";
print "Math::BigFloat\t\t v$Math::BigFloat::VERSION\n";
exit;
}
$self->export_to_level(1,$self, at a); # export inf and NaN
}
sub inf () { Math::BigInt->binf(); }
sub NaN () { Math::BigInt->bnan(); }
1;
__END__
=head1 NAME
bignum - Transparent BigNumber support for Perl
=head1 SYNOPSIS
use bignum;
$x = 2 + 4.5,"\n"; # BigFloat 6.5
print 2 ** 512 * 0.1,"\n"; # really is what you think it is
print inf * inf,"\n"; # prints inf
print NaN * 3,"\n"; # prints NaN
=head1 DESCRIPTION
All operators (including basic math operations) are overloaded. Integer and
floating-point constants are created as proper BigInts or BigFloats,
respectively.
If you do
use bignum;
at the top of your script, Math::BigFloat and Math::BigInt will be loaded
and any constant number will be converted to an object (Math::BigFloat for
floats like 3.1415 and Math::BigInt for integers like 1234).
So, the following line:
$x = 1234;
creates actually a Math::BigInt and stores a reference to in $x.
This happens transparently and behind your back, so to speak.
You can see this with the following:
perl -Mbignum -le 'print ref(1234)'
Don't worry if it says Math::BigInt::Lite, bignum and friends will use Lite
if it is installed since it is faster for some operations. It will be
automatically upgraded to BigInt whenever neccessary:
perl -Mbignum -le 'print ref(2**255)'
This also means it is a bad idea to check for some specific package, since
the actual contents of $x might be something unexpected. Due to the
transparent way of bignum C<ref()> should not be neccessary, anyway.
Since Math::BigInt and BigFloat also overload the normal math operations,
the following line will still work:
perl -Mbignum -le 'print ref(1234+1234)'
Since numbers are actually objects, you can call all the usual methods from
BigInt/BigFloat on them. This even works to some extent on expressions:
perl -Mbignum -le '$x = 1234; print $x->bdec()'
perl -Mbignum -le 'print 1234->binc();'
perl -Mbignum -le 'print 1234->binc->badd(6);'
perl -Mbignum -le 'print +(1234)->binc()'
(Note that print doesn't do what you expect if the expression starts with
'(' hence the C<+>)
You can even chain the operations together as usual:
perl -Mbignum -le 'print 1234->binc->badd(6);'
1241
Under bignum (or bigint or bigrat), Perl will "upgrade" the numbers
appropriately. This means that:
perl -Mbignum -le 'print 1234+4.5'
1238.5
will work correctly. These mixed cases don't do always work when using
Math::BigInt or Math::BigFloat alone, or at least not in the way normal Perl
scalars work.
If you do want to work with large integers like under C<use integer;>, try
C<use bigint;>:
perl -Mbigint -le 'print 1234.5+4.5'
1238
There is also C<use bigrat;> which gives you big rationals:
perl -Mbigrat -le 'print 1234+4.1'
12381/10
The entire upgrading/downgrading is still experimental and might not work
as you expect or may even have bugs.
You might get errors like this:
Can't use an undefined value as an ARRAY reference at
/usr/local/lib/perl5/5.8.0/Math/BigInt/Calc.pm line 864
This means somewhere a routine got a BigFloat/Lite but expected a BigInt (or
vice versa) and the upgrade/downgrad path was missing. This is a bug, please
report it so that we can fix it.
You might consider using just Math::BigInt or Math::BigFloat, since they
allow you finer control over what get's done in which module/space. For
instance, simple loop counters will be Math::BigInts under C<use bignum;> and
this is slower than keeping them as Perl scalars:
perl -Mbignum -le 'for ($i = 0; $i < 10; $i++) { print ref($i); }'
Please note the following does not work as expected (prints nothing), since
overloading of '..' is not yet possible in Perl (as of v5.8.0):
perl -Mbignum -le 'for (1..2) { print ref($_); }'
=head2 Options
bignum recognizes some options that can be passed while loading it via use.
The options can (currently) be either a single letter form, or the long form.
The following options exist:
=over 2
=item a or accuracy
This sets the accuracy for all math operations. The argument must be greater
than or equal to zero. See Math::BigInt's bround() function for details.
perl -Mbignum=a,50 -le 'print sqrt(20)'
=item p or precision
This sets the precision for all math operations. The argument can be any
integer. Negative values mean a fixed number of digits after the dot, while
a positive value rounds to this digit left from the dot. 0 or 1 mean round to
integer. See Math::BigInt's bfround() function for details.
perl -Mbignum=p,-50 -le 'print sqrt(20)'
=item t or trace
This enables a trace mode and is primarily for debugging bignum or
Math::BigInt/Math::BigFloat.
=item l or lib
Load a different math lib, see L<MATH LIBRARY>.
perl -Mbignum=l,GMP -e 'print 2 ** 512'
Currently there is no way to specify more than one library on the command
line. This will be hopefully fixed soon ;)
=item v or version
This prints out the name and version of all modules used and then exits.
perl -Mbignum=v
=head2 Methods
Beside import() and AUTOLOAD() there are only a few other methods.
Since all numbers are now objects, you can use all functions that are part of
the BigInt or BigFloat API. It is wise to use only the bxxx() notation, and not
the fxxx() notation, though. This makes it possible that the underlying object
might morph into a different class than BigFloat.
=head2 Caveat
But a warning is in order. When using the following to make a copy of a number,
only a shallow copy will be made.
$x = 9; $y = $x;
$x = $y = 7;
If you want to make a real copy, use the following:
$y = $x->copy();
Using the copy or the original with overloaded math is okay, e.g. the
following work:
$x = 9; $y = $x;
print $x + 1, " ", $y,"\n"; # prints 10 9
but calling any method that modifies the number directly will result in
B<both> the original and the copy beeing destroyed:
$x = 9; $y = $x;
print $x->badd(1), " ", $y,"\n"; # prints 10 10
$x = 9; $y = $x;
print $x->binc(1), " ", $y,"\n"; # prints 10 10
$x = 9; $y = $x;
print $x->bmul(2), " ", $y,"\n"; # prints 18 18
Using methods that do not modify, but testthe contents works:
$x = 9; $y = $x;
$z = 9 if $x->is_zero(); # works fine
See the documentation about the copy constructor and C<=> in overload, as
well as the documentation in BigInt for further details.
=over 2
=item inf()
A shortcut to return Math::BigInt->binf(). Usefull because Perl does not always
handle bareword C<inf> properly.
=item NaN()
A shortcut to return Math::BigInt->bnan(). Usefull because Perl does not always
handle bareword C<NaN> properly.
=item upgrade()
Return the class that numbers are upgraded to, is in fact returning
C<$Math::BigInt::upgrade>.
=back
=head2 MATH LIBRARY
Math with the numbers is done (by default) by a module called
Math::BigInt::Calc. This is equivalent to saying:
use bignum lib => 'Calc';
You can change this by using:
use bignum lib => 'BitVect';
The following would first try to find Math::BigInt::Foo, then
Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
use bignum lib => 'Foo,Math::BigInt::Bar';
Please see respective module documentation for further details.
=head2 INTERNAL FORMAT
The numbers are stored as objects, and their internals might change at anytime,
especially between math operations. The objects also might belong to different
classes, like Math::BigInt, or Math::BigFLoat. Mixing them together, even
with normal scalars is not extraordinary, but normal and expected.
You should not depend on the internal format, all accesses must go through
accessor methods. E.g. looking at $x->{sign} is not a bright idea since there
is no guaranty that the object in question has such a hashkey, nor is a hash
underneath at all.
=head2 SIGN
The sign is either '+', '-', 'NaN', '+inf' or '-inf' and stored seperately.
You can access it with the sign() method.
A sign of 'NaN' is used to represent the result when input arguments are not
numbers or as a result of 0/0. '+inf' and '-inf' represent plus respectively
minus infinity. You will get '+inf' when dividing a positive number by 0, and
'-inf' when dividing any negative number by 0.
=head1 MODULES USED
C<bignum> is just a thin wrapper around various modules of the Math::BigInt
family. Think of it as the head of the family, who runs the shop, and orders
the others to do the work.
The following modules are currently used by bignum:
Math::BigInt::Lite (for speed, and only if it is loadable)
Math::BigInt
Math::BigFloat
=head1 EXAMPLES
Some cool command line examples to impress the Python crowd ;)
perl -Mbignum -le 'print sqrt(33)'
perl -Mbignum -le 'print 2*255'
perl -Mbignum -le 'print 4.5+2*255'
perl -Mbignum -le 'print 3/7 + 5/7 + 8/3'
perl -Mbignum -le 'print 123->is_odd()'
perl -Mbignum -le 'print log(2)'
perl -Mbignum -le 'print 2 ** 0.5'
perl -Mbignum=a,65 -le 'print 2 ** 0.2'
=head1 LICENSE
This program is free software; you may redistribute it and/or modify it under
the same terms as Perl itself.
=head1 SEE ALSO
Especially L<bigrat> as in C<perl -Mbigrat -le 'print 1/3+1/4'>.
L<Math::BigFloat>, L<Math::BigInt>, L<Math::BigRat> and L<Math::Big> as well
as L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
=head1 AUTHORS
(C) by Tels L<http://bloodgate.com/> in early 2002, 2003.
=cut
--- NEW FILE: ctime.pl ---
;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function.
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: the POSIX ctime function
;#
;# Waldemar Kebsch, Federal Republic of Germany, November 1988
;# kebsch.pad at nixpbe.UUCP
;# Modified March 1990, Feb 1991 to properly handle timezones
;# $RCSfile: ctime.pl,v $$Revision: 1.2 $$Date: 2006-12-04 17:00:13 $
;# Marion Hakanson (hakanson at cse.ogi.edu)
;# Oregon Graduate Institute of Science and Technology
;#
;# usage:
;#
;# #include <ctime.pl> # see the -P and -I option in perl.man
;# $Date = &ctime(time);
CONFIG: {
package ctime;
@DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
@MoY = ('Jan','Feb','Mar','Apr','May','Jun',
'Jul','Aug','Sep','Oct','Nov','Dec');
}
sub ctime {
package ctime;
local($time) = @_;
local($[) = 0;
local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
# Determine what time zone is in effect.
# Use GMT if TZ is defined as null, local time if TZ undefined.
# There's no portable way to find the system default timezone.
$TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : '';
($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
($TZ eq 'GMT') ? gmtime($time) : localtime($time);
# Hack to deal with 'PST8PDT' format of TZ
# Note that this can't deal with all the esoteric forms, but it
# does recognize the most common: [:]STDoff[DST[off][,rule]]
if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){
$TZ = $isdst ? $4 : $1;
}
$TZ .= ' ' unless $TZ eq '';
$year += 1900;
sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n",
$DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year);
}
1;
--- NEW FILE: getopt.pl ---
;# $RCSfile: getopt.pl,v $$Revision: 1.2 $$Date: 2006-12-04 17:00:14 $
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternatives: Getopt::Long or Getopt::Std
#
;# Process single-character switches with switch clustering. Pass one argument
;# which is a string containing all switches that take an argument. For each
;# switch found, sets $opt_x (where x is the switch name) to the value of the
;# argument, or 1 if no argument. Switches which take an argument don't care
;# whether there is a space between the switch and the argument.
;# Usage:
;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
sub Getopt {
local($argumentative) = @_;
local($_,$first,$rest);
local($[) = 0;
while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
($first,$rest) = ($1,$2);
if (index($argumentative,$first) >= $[) {
if ($rest ne '') {
shift(@ARGV);
}
else {
shift(@ARGV);
$rest = shift(@ARGV);
}
${"opt_$first"} = $rest;
}
else {
${"opt_$first"} = 1;
if ($rest ne '') {
$ARGV[0] = "-$rest";
}
else {
shift(@ARGV);
}
}
}
}
1;
--- NEW FILE: bigrat.pl ---
package bigrat;
require "bigint.pl";
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Arbitrary size rational math package
#
# by Mark Biggar
#
# Input values to these routines consist of strings of the form
# m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|.
# Examples:
# "+0/1" canonical zero value
# "3" canonical value "+3/1"
# " -123/123 123" canonical value "-1/1001"
# "123 456/7890" canonical value "+20576/1315"
# Output values always include a sign and no leading zeros or
# white space.
# This package makes use of the bigint package.
# The string 'NaN' is used to represent the result when input arguments
# that are not numbers, as well as the result of dividing by zero and
# the sqrt of a negative number.
# Extreamly naive algorthims are used.
#
# Routines provided are:
#
# rneg(RAT) return RAT negation
# rabs(RAT) return RAT absolute value
# rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0)
# radd(RAT,RAT) return RAT addition
# rsub(RAT,RAT) return RAT subtraction
# rmul(RAT,RAT) return RAT multiplication
# rdiv(RAT,RAT) return RAT division
# rmod(RAT) return (RAT,RAT) integer and fractional parts
# rnorm(RAT) return RAT normalization
# rsqrt(RAT, cycles) return RAT square root
# Convert a number to the canonical string form m|^[+-]\d+/\d+|.
sub main'rnorm { #(string) return rat_num
local($_) = @_;
s/\s+//g;
if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) {
&norm($1, $3 ? $3 : '+1');
} else {
'NaN';
}
}
# Normalize by reducing to lowest terms
sub norm { #(bint, bint) return rat_num
local($num,$dom) = @_;
if ($num eq 'NaN') {
'NaN';
} elsif ($dom eq 'NaN') {
'NaN';
} elsif ($dom =~ /^[+-]?0+$/) {
'NaN';
} else {
local($gcd) = &'bgcd($num,$dom);
$gcd =~ s/^-/+/;
if ($gcd ne '+1') {
$num = &'bdiv($num,$gcd);
$dom = &'bdiv($dom,$gcd);
} else {
$num = &'bnorm($num);
$dom = &'bnorm($dom);
}
substr($dom,$[,1) = '';
"$num/$dom";
}
}
# negation
sub main'rneg { #(rat_num) return rat_num
local($_) = &'rnorm(@_);
tr/-+/+-/ if ($_ ne '+0/1');
$_;
}
# absolute value
sub main'rabs { #(rat_num) return $rat_num
local($_) = &'rnorm(@_);
substr($_,$[,1) = '+' unless $_ eq 'NaN';
$_;
}
# multipication
sub main'rmul { #(rat_num, rat_num) return rat_num
local($xn,$xd) = split('/',&'rnorm($_[$[]));
local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
&norm(&'bmul($xn,$yn),&'bmul($xd,$yd));
}
# division
sub main'rdiv { #(rat_num, rat_num) return rat_num
local($xn,$xd) = split('/',&'rnorm($_[$[]));
local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
&norm(&'bmul($xn,$yd),&'bmul($xd,$yn));
}
# addition
sub main'radd { #(rat_num, rat_num) return rat_num
local($xn,$xd) = split('/',&'rnorm($_[$[]));
local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
&norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
}
# subtraction
sub main'rsub { #(rat_num, rat_num) return rat_num
local($xn,$xd) = split('/',&'rnorm($_[$[]));
local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
&norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
}
# comparison
sub main'rcmp { #(rat_num, rat_num) return cond_code
local($xn,$xd) = split('/',&'rnorm($_[$[]));
local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
&bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd));
}
# int and frac parts
sub main'rmod { #(rat_num) return (rat_num,rat_num)
local($xn,$xd) = split('/',&'rnorm(@_));
local($i,$f) = &'bdiv($xn,$xd);
if (wantarray) {
("$i/1", "$f/$xd");
} else {
"$i/1";
}
}
# square root by Newtons method.
# cycles specifies the number of iterations default: 5
sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str
local($x, $scale) = (&'rnorm($_[$[]), $_[$[+1]);
if ($x eq 'NaN') {
'NaN';
} elsif ($x =~ /^-/) {
'NaN';
} else {
local($gscale, $guess) = (0, '+1/1');
$scale = 5 if (!$scale);
while ($gscale++ < $scale) {
$guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2");
}
"$guess"; # quotes necessary due to perl bug
}
}
1;
--- NEW FILE: bigrat.pm ---
package bigrat;
require 5.005;
$VERSION = '0.08';
require Exporter;
@ISA = qw( Exporter );
@EXPORT_OK = qw( );
@EXPORT = qw( inf NaN );
use strict;
##############################################################################
# These are all alike, and thus faked by AUTOLOAD
my @faked = qw/round_mode accuracy precision div_scale/;
use vars qw/$VERSION $AUTOLOAD $_lite/; # _lite for testsuite
sub AUTOLOAD
{
my $name = $AUTOLOAD;
$name =~ s/.*:://; # split package
no strict 'refs';
foreach my $n (@faked)
{
if ($n eq $name)
{
*{"bigrat::$name"} = sub
{
my $self = shift;
no strict 'refs';
if (defined $_[0])
{
Math::BigInt->$name($_[0]);
Math::BigFloat->$name($_[0]);
return Math::BigRat->$name($_[0]);
}
return Math::BigInt->$name();
};
return &$name;
}
}
# delayed load of Carp and avoid recursion
require Carp;
Carp::croak ("Can't call bigrat\-\>$name, not a valid method");
}
sub upgrade
{
my $self = shift;
no strict 'refs';
# if (defined $_[0])
# {
# $Math::BigInt::upgrade = $_[0];
# $Math::BigFloat::upgrade = $_[0];
# }
return $Math::BigInt::upgrade;
}
sub import
{
my $self = shift;
# see also bignum->import() for additional comments
# some defaults
my $lib = ''; my $upgrade = 'Math::BigFloat';
my @import = ( ':constant' ); # drive it w/ constant
my @a = @_; my $l = scalar @_; my $j = 0;
my ($a,$p);
my ($ver,$trace); # version? trace?
for ( my $i = 0; $i < $l ; $i++,$j++ )
{
if ($_[$i] eq 'upgrade')
{
# this causes upgrading
$upgrade = $_[$i+1]; # or undef to disable
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s;
}
elsif ($_[$i] =~ /^(l|lib)$/)
{
# this causes a different low lib to take care...
$lib = $_[$i+1] || '';
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] =~ /^(a|accuracy)$/)
{
$a = $_[$i+1];
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] =~ /^(p|precision)$/)
{
$p = $_[$i+1];
my $s = 2; $s = 1 if @a-$j < 2; # avoid "can not modify non-existant..."
splice @a, $j, $s; $j -= $s; $i++;
}
elsif ($_[$i] =~ /^(v|version)$/)
{
$ver = 1;
splice @a, $j, 1; $j --;
}
elsif ($_[$i] =~ /^(t|trace)$/)
{
$trace = 1;
splice @a, $j, 1; $j --;
}
else
{
die ("unknown option $_[$i]");
}
}
my $class;
$_lite = 0; # using M::BI::L ?
if ($trace)
{
require Math::BigInt::Trace; $class = 'Math::BigInt::Trace';
$upgrade = 'Math::BigFloat::Trace';
}
else
{
# see if we can find Math::BigInt::Lite
if (!defined $a && !defined $p) # rounding won't work to well
{
eval 'require Math::BigInt::Lite;';
if ($@ eq '')
{
@import = ( ); # :constant in Lite, not MBI
Math::BigInt::Lite->import( ':constant' );
$_lite= 1; # signal okay
}
}
require Math::BigInt if $_lite == 0; # not already loaded?
$class = 'Math::BigInt'; # regardless of MBIL or not
}
push @import, 'lib' => $lib if $lib ne '';
# Math::BigInt::Trace or plain Math::BigInt
$class->import(@import, upgrade => $upgrade);
require Math::BigFloat;
Math::BigFloat->import( upgrade => 'Math::BigRat', ':constant' );
require Math::BigRat;
bigrat->accuracy($a) if defined $a;
bigrat->precision($p) if defined $p;
if ($ver)
{
print "bigrat\t\t\t v$VERSION\n";
print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite;
print "Math::BigInt\t\t v$Math::BigInt::VERSION";
my $config = Math::BigInt->config();
print " lib => $config->{lib} v$config->{lib_version}\n";
print "Math::BigFloat\t\t v$Math::BigFloat::VERSION\n";
print "Math::BigRat\t\t v$Math::BigRat::VERSION\n";
exit;
}
$self->export_to_level(1,$self, at a); # export inf and NaN
}
sub inf () { Math::BigInt->binf(); }
sub NaN () { Math::BigInt->bnan(); }
1;
__END__
=head1 NAME
bigrat - Transparent BigNumber/BigRational support for Perl
=head1 SYNOPSIS
use bigrat;
$x = 2 + 4.5,"\n"; # BigFloat 6.5
print 1/3 + 1/4,"\n"; # produces 7/12
=head1 DESCRIPTION
All operators (inlcuding basic math operations) are overloaded. Integer and
floating-point constants are created as proper BigInts or BigFloats,
respectively.
Other than L<bignum>, this module upgrades to Math::BigRat, meaning that
instead of 2.5 you will get 2+1/2 as output.
=head2 Modules Used
C<bigrat> is just a thin wrapper around various modules of the Math::BigInt
family. Think of it as the head of the family, who runs the shop, and orders
the others to do the work.
The following modules are currently used by bignum:
Math::BigInt::Lite (for speed, and only if it is loadable)
Math::BigInt
Math::BigFloat
Math::BigRat
=head2 Math Library
Math with the numbers is done (by default) by a module called
Math::BigInt::Calc. This is equivalent to saying:
use bigrat lib => 'Calc';
You can change this by using:
use bigrat lib => 'BitVect';
The following would first try to find Math::BigInt::Foo, then
Math::BigInt::Bar, and when this also fails, revert to Math::BigInt::Calc:
use bigrat lib => 'Foo,Math::BigInt::Bar';
Please see respective module documentation for further details.
=head2 Sign
The sign is either '+', '-', 'NaN', '+inf' or '-inf'.
A sign of 'NaN' is used to represent the result when input arguments are not
numbers or as a result of 0/0. '+inf' and '-inf' represent plus respectively
minus infinity. You will get '+inf' when dividing a positive number by 0, and
'-inf' when dividing any negative number by 0.
=head2 Methods
Since all numbers are not objects, you can use all functions that are part of
the BigInt or BigFloat API. It is wise to use only the bxxx() notation, and not
the fxxx() notation, though. This makes you independed on the fact that the
underlying object might morph into a different class than BigFloat.
=head2 Cavaet
But a warning is in order. When using the following to make a copy of a number,
only a shallow copy will be made.
$x = 9; $y = $x;
$x = $y = 7;
If you want to make a real copy, use the following:
$y = $x->copy();
Using the copy or the original with overloaded math is okay, e.g. the
following work:
$x = 9; $y = $x;
print $x + 1, " ", $y,"\n"; # prints 10 9
but calling any method that modifies the number directly will result in
B<both> the original and the copy beeing destroyed:
$x = 9; $y = $x;
print $x->badd(1), " ", $y,"\n"; # prints 10 10
$x = 9; $y = $x;
print $x->binc(1), " ", $y,"\n"; # prints 10 10
$x = 9; $y = $x;
print $x->bmul(2), " ", $y,"\n"; # prints 18 18
Using methods that do not modify, but testthe contents works:
$x = 9; $y = $x;
$z = 9 if $x->is_zero(); # works fine
See the documentation about the copy constructor and C<=> in overload, as
well as the documentation in BigInt for further details.
=head2 Options
bignum recognizes some options that can be passed while loading it via use.
The options can (currently) be either a single letter form, or the long form.
The following options exist:
=over 2
=item a or accuracy
This sets the accuracy for all math operations. The argument must be greater
than or equal to zero. See Math::BigInt's bround() function for details.
perl -Mbigrat=a,50 -le 'print sqrt(20)'
=item p or precision
This sets the precision for all math operations. The argument can be any
integer. Negative values mean a fixed number of digits after the dot, while
a positive value rounds to this digit left from the dot. 0 or 1 mean round to
integer. See Math::BigInt's bfround() function for details.
perl -Mbigrat=p,-50 -le 'print sqrt(20)'
=item t or trace
This enables a trace mode and is primarily for debugging bignum or
Math::BigInt/Math::BigFloat.
=item l or lib
Load a different math lib, see L<MATH LIBRARY>.
perl -Mbigrat=l,GMP -e 'print 2 ** 512'
Currently there is no way to specify more than one library on the command
line. This will be hopefully fixed soon ;)
=item v or version
This prints out the name and version of all modules used and then exits.
perl -Mbigrat=v
=head1 EXAMPLES
perl -Mbigrat -le 'print sqrt(33)'
perl -Mbigrat -le 'print 2*255'
perl -Mbigrat -le 'print 4.5+2*255'
perl -Mbigrat -le 'print 3/7 + 5/7 + 8/3'
perl -Mbigrat -le 'print 12->is_odd()';
=head1 LICENSE
This program is free software; you may redistribute it and/or modify it under
the same terms as Perl itself.
=head1 SEE ALSO
Especially L<bignum>.
L<Math::BigFloat>, L<Math::BigInt>, L<Math::BigRat> and L<Math::Big> as well
as L<Math::BigInt::BitVect>, L<Math::BigInt::Pari> and L<Math::BigInt::GMP>.
=head1 AUTHORS
(C) by Tels L<http://bloodgate.com/> in early 2002 - 2005.
=cut
--- NEW FILE: abbrev.pl ---
;# Usage:
;# %foo = ();
;# &abbrev(*foo,LIST);
;# ...
;# $long = $foo{$short};
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Text::Abbrev
#
package abbrev;
sub main'abbrev {
local(*domain) = @_;
shift(@_);
@cmp = @_;
local($[) = 0;
foreach $name (@_) {
@extra = split(//,$name);
$abbrev = shift(@extra);
$len = 1;
foreach $cmp (@cmp) {
next if $cmp eq $name;
while (@extra && substr($cmp,0,$len) eq $abbrev) {
$abbrev .= shift(@extra);
++$len;
}
}
$domain{$abbrev} = $name;
while ($#extra >= 0) {
$abbrev .= shift(@extra);
$domain{$abbrev} = $name;
}
}
}
1;
--- NEW FILE: if.t ---
#!./perl
BEGIN {
chdir 't' and @INC = '../lib' if -f 't/TEST';
}
my $t = 1;
print "1..5\n";
sub ok {
print "not " unless shift;
print "ok $t # ", shift, "\n";
$t++;
}
my $v_plus = $] + 1;
my $v_minus = $] - 1;
unless (eval 'use open ":std"; 1') {
# pretend that open.pm is present
$INC{'open.pm'} = 'open.pm';
eval 'sub open::foo{}'; # Just in case...
}
ok( eval "use if ($v_minus > \$]), strict => 'subs'; \${'f'} = 12" eq 12,
'"use if" with a false condition, fake pragma');
ok( eval "use if ($v_minus > \$]), strict => 'refs'; \${'f'} = 12" eq 12,
'"use if" with a false condition and a pragma');
ok( eval "use if ($v_plus > \$]), strict => 'subs'; \${'f'} = 12" eq 12,
'"use if" with a true condition, fake pragma');
ok( (not defined eval "use if ($v_plus > \$]), strict => 'refs'; \${'f'} = 12"
and $@ =~ /while "strict refs" in use/),
'"use if" with a true condition and a pragma');
# Old version had problems with the module name `open', which is a keyword too
# Use 'open' =>, since pre-5.6.0 could interpret differently
ok( (eval "use if ($v_plus > \$]), 'open' => IN => ':crlf'; 12" || 0) eq 12,
'"use if" with open');
--- NEW FILE: attributes.pm ---
package attributes;
our $VERSION = 0.06;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]);
use strict;
sub croak {
require Carp;
goto &Carp::croak;
}
sub carp {
require Carp;
goto &Carp::carp;
}
## forward declaration(s) rather than wrapping the bootstrap call in BEGIN{}
#sub reftype ($) ;
#sub _fetch_attrs ($) ;
#sub _guess_stash ($) ;
#sub _modify_attrs ;
#sub _warn_reserved () ;
#
# The extra trips through newATTRSUB in the interpreter wipe out any savings
# from avoiding the BEGIN block. Just do the bootstrap now.
BEGIN { bootstrap attributes }
sub import {
@_ > 2 && ref $_[2] or do {
require Exporter;
goto &Exporter::import;
};
my (undef,$home_stash,$svref, at attrs) = @_;
my $svtype = uc reftype($svref);
my $pkgmeth;
$pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES")
if defined $home_stash && $home_stash ne '';
my @badattrs;
if ($pkgmeth) {
my @pkgattrs = _modify_attrs($svref, @attrs);
@badattrs = $pkgmeth->($home_stash, $svref, @attrs);
if (!@badattrs && @pkgattrs) {
return unless _warn_reserved;
@pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs;
if (@pkgattrs) {
for my $attr (@pkgattrs) {
$attr =~ s/\(.+\z//s;
}
my $s = ((@pkgattrs == 1) ? '' : 's');
carp "$svtype package attribute$s " .
"may clash with future reserved word$s: " .
join(' : ' , @pkgattrs);
}
}
}
else {
@badattrs = _modify_attrs($svref, @attrs);
}
if (@badattrs) {
croak "Invalid $svtype attribute" .
(( @badattrs == 1 ) ? '' : 's') .
": " .
join(' : ', @badattrs);
}
}
sub get ($) {
@_ == 1 && ref $_[0] or
croak 'Usage: '.__PACKAGE__.'::get $ref';
my $svref = shift;
my $svtype = uc reftype $svref;
my $stash = _guess_stash $svref;
$stash = caller unless defined $stash;
my $pkgmeth;
$pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES")
if defined $stash && $stash ne '';
return $pkgmeth ?
(_fetch_attrs($svref), $pkgmeth->($stash, $svref)) :
(_fetch_attrs($svref))
;
}
sub require_version { goto &UNIVERSAL::VERSION }
1;
__END__
#The POD goes here
=head1 NAME
attributes - get/set subroutine or variable attributes
=head1 SYNOPSIS
sub foo : method ;
my ($x, at y,%z) : Bent = 1;
my $s = sub : method { ... };
use attributes (); # optional, to get subroutine declarations
my @attrlist = attributes::get(\&foo);
use attributes 'get'; # import the attributes::get subroutine
my @attrlist = get \&foo;
=head1 DESCRIPTION
Subroutine declarations and definitions may optionally have attribute lists
associated with them. (Variable C<my> declarations also may, but see the
warning below.) Perl handles these declarations by passing some information
about the call site and the thing being declared along with the attribute
list to this module. In particular, the first example above is equivalent to
the following:
use attributes __PACKAGE__, \&foo, 'method';
The second example in the synopsis does something equivalent to this:
use attributes ();
my ($x, at y,%z);
attributes::->import(__PACKAGE__, \$x, 'Bent');
attributes::->import(__PACKAGE__, \@y, 'Bent');
attributes::->import(__PACKAGE__, \%z, 'Bent');
($x, at y,%z) = 1;
Yes, that's a lot of expansion.
B<WARNING>: attribute declarations for variables are still evolving.
The semantics and interfaces of such declarations could change in
future versions. They are present for purposes of experimentation
with what the semantics ought to be. Do not rely on the current
implementation of this feature.
There are only a few attributes currently handled by Perl itself (or
directly by this module, depending on how you look at it.) However,
package-specific attributes are allowed by an extension mechanism.
(See L<"Package-specific Attribute Handling"> below.)
The setting of subroutine attributes happens at compile time.
Variable attributes in C<our> declarations are also applied at compile time.
However, C<my> variables get their attributes applied at run-time.
This means that you have to I<reach> the run-time component of the C<my>
before those attributes will get applied. For example:
my $x : Bent = 42 if 0;
will neither assign 42 to $x I<nor> will it apply the C<Bent> attribute
to the variable.
An attempt to set an unrecognized attribute is a fatal error. (The
error is trappable, but it still stops the compilation within that
C<eval>.) Setting an attribute with a name that's all lowercase
letters that's not a built-in attribute (such as "foo") will result in
a warning with B<-w> or C<use warnings 'reserved'>.
=head2 Built-in Attributes
The following are the built-in attributes for subroutines:
=over 4
=item locked
B<5.005 threads only! The use of the "locked" attribute currently
only makes sense if you are using the deprecated "Perl 5.005 threads"
implementation of threads.>
Setting this attribute is only meaningful when the subroutine or
method is to be called by multiple threads. When set on a method
subroutine (i.e., one marked with the B<method> attribute below),
Perl ensures that any invocation of it implicitly locks its first
argument before execution. When set on a non-method subroutine,
Perl ensures that a lock is taken on the subroutine itself before
execution. The semantics of the lock are exactly those of one
explicitly taken with the C<lock> operator immediately after the
subroutine is entered.
=item method
Indicates that the referenced subroutine is a method.
This has a meaning when taken together with the B<locked> attribute,
as described there. It also means that a subroutine so marked
will not trigger the "Ambiguous call resolved as CORE::%s" warning.
=item lvalue
Indicates that the referenced subroutine is a valid lvalue and can
be assigned to. The subroutine must return a modifiable value such
as a scalar variable, as described in L<perlsub>.
=back
For global variables there is C<unique> attribute: see L<perlfunc/our>.
=head2 Available Subroutines
The following subroutines are available for general use once this module
has been loaded:
=over 4
=item get
This routine expects a single parameter--a reference to a
subroutine or variable. It returns a list of attributes, which may be
empty. If passed invalid arguments, it uses die() (via L<Carp::croak|Carp>)
to raise a fatal exception. If it can find an appropriate package name
for a class method lookup, it will include the results from a
C<FETCH_I<type>_ATTRIBUTES> call in its return list, as described in
L<"Package-specific Attribute Handling"> below.
Otherwise, only L<built-in attributes|"Built-in Attributes"> will be returned.
=item reftype
This routine expects a single parameter--a reference to a subroutine or
variable. It returns the built-in type of the referenced variable,
ignoring any package into which it might have been blessed.
This can be useful for determining the I<type> value which forms part of
the method names described in L<"Package-specific Attribute Handling"> below.
=back
Note that these routines are I<not> exported by default.
=head2 Package-specific Attribute Handling
B<WARNING>: the mechanisms described here are still experimental. Do not
rely on the current implementation. In particular, there is no provision
for applying package attributes to 'cloned' copies of subroutines used as
closures. (See L<perlref/"Making References"> for information on closures.)
Package-specific attribute handling may change incompatibly in a future
release.
When an attribute list is present in a declaration, a check is made to see
whether an attribute 'modify' handler is present in the appropriate package
(or its @ISA inheritance tree). Similarly, when C<attributes::get> is
called on a valid reference, a check is made for an appropriate attribute
'fetch' handler. See L<"EXAMPLES"> to see how the "appropriate package"
determination works.
The handler names are based on the underlying type of the variable being
declared or of the reference passed. Because these attributes are
associated with subroutine or variable declarations, this deliberately
ignores any possibility of being blessed into some package. Thus, a
subroutine declaration uses "CODE" as its I<type>, and even a blessed
hash reference uses "HASH" as its I<type>.
The class methods invoked for modifying and fetching are these:
=over 4
=item FETCH_I<type>_ATTRIBUTES
This method receives a single argument, which is a reference to the
variable or subroutine for which package-defined attributes are desired.
The expected return value is a list of associated attributes.
This list may be empty.
=item MODIFY_I<type>_ATTRIBUTES
This method is called with two fixed arguments, followed by the list of
attributes from the relevant declaration. The two fixed arguments are
the relevant package name and a reference to the declared subroutine or
variable. The expected return value is a list of attributes which were
not recognized by this handler. Note that this allows for a derived class
to delegate a call to its base class, and then only examine the attributes
which the base class didn't already handle for it.
The call to this method is currently made I<during> the processing of the
declaration. In particular, this means that a subroutine reference will
probably be for an undefined subroutine, even if this declaration is
actually part of the definition.
=back
Calling C<attributes::get()> from within the scope of a null package
declaration C<package ;> for an unblessed variable reference will
not provide any starting package name for the 'fetch' method lookup.
Thus, this circumstance will not result in a method call for package-defined
attributes. A named subroutine knows to which symbol table entry it belongs
(or originally belonged), and it will use the corresponding package.
An anonymous subroutine knows the package name into which it was compiled
(unless it was also compiled with a null package declaration), and so it
will use that package name.
=head2 Syntax of Attribute Lists
An attribute list is a sequence of attribute specifications, separated by
whitespace or a colon (with optional whitespace).
Each attribute specification is a simple
name, optionally followed by a parenthesised parameter list.
If such a parameter list is present, it is scanned past as for the rules
for the C<q()> operator. (See L<perlop/"Quote and Quote-like Operators">.)
The parameter list is passed as it was found, however, and not as per C<q()>.
Some examples of syntactically valid attribute lists:
switch(10,foo(7,3)) : expensive
Ugly('\(") :Bad
_5x5
locked method
Some examples of syntactically invalid attribute lists (with annotation):
switch(10,foo() # ()-string not balanced
Ugly('(') # ()-string not balanced
5x5 # "5x5" not a valid identifier
Y2::north # "Y2::north" not a simple identifier
foo + bar # "+" neither a colon nor whitespace
=head1 EXPORTS
=head2 Default exports
None.
=head2 Available exports
The routines C<get> and C<reftype> are exportable.
=head2 Export tags defined
The C<:ALL> tag will get all of the above exports.
=head1 EXAMPLES
Here are some samples of syntactically valid declarations, with annotation
as to how they resolve internally into C<use attributes> invocations by
perl. These examples are primarily useful to see how the "appropriate
package" is found for the possible method lookups for package-defined
attributes.
=over 4
=item 1.
Code:
package Canine;
package Dog;
my Canine $spot : Watchful ;
Effect:
use attributes ();
attributes::->import(Canine => \$spot, "Watchful");
=item 2.
Code:
package Felis;
my $cat : Nervous;
Effect:
use attributes ();
attributes::->import(Felis => \$cat, "Nervous");
=item 3.
Code:
package X;
sub foo : locked ;
Effect:
use attributes X => \&foo, "locked";
=item 4.
Code:
package X;
sub Y::x : locked { 1 }
Effect:
use attributes Y => \&Y::x, "locked";
=item 5.
Code:
package X;
sub foo { 1 }
package Y;
BEGIN { *bar = \&X::foo; }
package Z;
sub Y::bar : locked ;
Effect:
use attributes X => \&X::foo, "locked";
=back
This last example is purely for purposes of completeness. You should not
be trying to mess with the attributes of something in a package that's
not your own.
=head1 SEE ALSO
L<perlsub/"Private Variables via my()"> and
L<perlsub/"Subroutine Attributes"> for details on the basic declarations;
L<attrs> for the obsolescent form of subroutine attribute specification
which this module replaces;
L<perlfunc/use> for details on the normal invocation mechanism.
=cut
--- NEW FILE: AutoLoader.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use strict;
use File::Spec;
use File::Path;
my $dir;
BEGIN
{
$dir = File::Spec->catdir( "auto-$$" );
unshift @INC, $dir;
}
use Test::More tests => 17;
# First we must set up some autoloader files
my $fulldir = File::Spec->catdir( $dir, 'auto', 'Foo' );
mkpath( $fulldir ) or die "Can't mkdir '$fulldir': $!";
open(FOO, '>', File::Spec->catfile( $fulldir, 'foo.al' ))
or die "Can't open foo file: $!";
print FOO <<'EOT';
package Foo;
sub foo { shift; shift || "foo" }
1;
EOT
close(FOO);
open(BAR, '>', File::Spec->catfile( $fulldir, 'bar.al' ))
or die "Can't open bar file: $!";
print BAR <<'EOT';
package Foo;
sub bar { shift; shift || "bar" }
1;
EOT
close(BAR);
open(BAZ, '>', File::Spec->catfile( $fulldir, 'bazmarkhian.al' ))
or die "Can't open bazmarkhian file: $!";
print BAZ <<'EOT';
package Foo;
sub bazmarkhianish { shift; shift || "baz" }
1;
EOT
close(BAZ);
open(BLECH, '>', File::Spec->catfile( $fulldir, 'blechanawilla.al' ))
or die "Can't open blech file: $!";
print BLECH <<'EOT';
package Foo;
sub blechanawilla { compilation error (
EOT
close(BLECH);
# This is just to keep the old SVR3 systems happy; they may fail
# to find the above file so we duplicate it where they should find it.
open(BLECH, '>', File::Spec->catfile( $fulldir, 'blechanawil.al' ))
or die "Can't open blech file: $!";
print BLECH <<'EOT';
package Foo;
sub blechanawilla { compilation error (
EOT
close(BLECH);
# Let's define the package
package Foo;
require AutoLoader;
AutoLoader->import( 'AUTOLOAD' );
sub new { bless {}, shift };
sub foo;
sub bar;
sub bazmarkhianish;
package main;
my $foo = new Foo;
my $result = $foo->can( 'foo' );
ok( $result, 'can() first time' );
is( $foo->foo, 'foo', 'autoloaded first time' );
is( $foo->foo, 'foo', 'regular call' );
is( $result, \&Foo::foo, 'can() returns ref to regular installed sub' );
eval {
$foo->will_fail;
};
like( $@, qr/^Can't locate/, 'undefined method' );
$result = $foo->can( 'will_fail' );
ok( ! $result, 'can() should fail on undefined methods' );
# Used to be trouble with this
eval {
my $foo = new Foo;
die "oops";
};
like( $@, qr/oops/, 'indirect method call' );
# Pass regular expression variable to autoloaded function. This used
# to go wrong because AutoLoader used regular expressions to generate
# autoloaded filename.
'foo' =~ /(\w+)/;
is( $foo->bar($1), 'foo', 'autoloaded method should not stomp match vars' );
is( $foo->bar($1), 'foo', '(again)' );
is( $foo->bazmarkhianish($1), 'foo', 'for any method call' );
is( $foo->bazmarkhianish($1), 'foo', '(again)' );
# Used to retry long subnames with shorter filenames on any old
# exception, including compilation error. Now AutoLoader only
# tries shorter filenames if it can't find the long one.
eval {
$foo->blechanawilla;
};
like( $@, qr/syntax error/, 'require error propagates' );
# test recursive autoloads
open(F, '>', File::Spec->catfile( $fulldir, 'a.al'))
or die "Cannot make 'a' file: $!";
print F <<'EOT';
package Foo;
BEGIN { b() }
sub a { ::ok( 1, 'adding a new autoloaded method' ); }
1;
EOT
close(F);
open(F, '>', File::Spec->catfile( $fulldir, 'b.al'))
or die "Cannot make 'b' file: $!";
print F <<'EOT';
package Foo;
sub b { ::ok( 1, 'adding a new autoloaded method' ) }
1;
EOT
close(F);
Foo::a();
package Bar;
AutoLoader->import();
::ok( ! defined &AUTOLOAD, 'AutoLoader should not export AUTOLOAD by default' );
package Foo;
AutoLoader->unimport();
eval { Foo->baz() };
::like( $@, qr/locate object method "baz"/,
'unimport() should remove imported AUTOLOAD()' );
package Baz;
sub AUTOLOAD { 'i am here' }
AutoLoader->import();
AutoLoader->unimport();
::is( Baz->AUTOLOAD(), 'i am here', '... but not non-imported AUTOLOAD()' );
package main;
# cleanup
END {
return unless $dir && -d $dir;
rmtree $dir;
}
--- NEW FILE: look.pl ---
;# Usage: &look(*FILEHANDLE,$key,$dict,$fold)
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
;# Sets file position in FILEHANDLE to be first line greater than or equal
;# (stringwise) to $key. Pass flags for dictionary order and case folding.
sub look {
local(*FH,$key,$dict,$fold) = @_;
local($max,$min,$mid,$_);
local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat(FH);
$blksize = 8192 unless $blksize;
$key =~ s/[^\w\s]//g if $dict;
$key = lc $key if $fold;
$max = int($size / $blksize);
while ($max - $min > 1) {
$mid = int(($max + $min) / 2);
seek(FH,$mid * $blksize,0);
$_ = <FH> if $mid; # probably a partial line
$_ = <FH>;
chop;
s/[^\w\s]//g if $dict;
$_ = lc $_ if $fold;
if ($_ lt $key) {
$min = $mid;
}
else {
$max = $mid;
}
}
$min *= $blksize;
seek(FH,$min,0);
<FH> if $min;
while (<FH>) {
chop;
s/[^\w\s]//g if $dict;
$_ = lc $_ if $fold;
last if $_ ge $key;
$min = tell(FH);
}
seek(FH,$min,0);
$min;
}
1;
--- NEW FILE: Fatal.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
print "1..15\n";
}
use strict;
use Fatal qw(open close :void opendir);
my $i = 1;
eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' };
print "not " unless $@ =~ /^Can't open/;
print "ok $i\n"; ++$i;
my $foo = 'FOO';
for ('$foo', "'$foo'", "*$foo", "\\*$foo") {
eval qq{ open $_, '<$0' };
print "not " if $@;
print "ok $i\n"; ++$i;
print "not " if $@ or scalar(<$foo>) !~ m|^#!./perl|;
print "ok $i\n"; ++$i;
eval qq{ close FOO };
print "not " if $@;
print "ok $i\n"; ++$i;
}
eval { opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' };
print "not " unless $@ =~ /^Can't open/;
print "ok $i\n"; ++$i;
eval { my $a = opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' };
print "not " if $@ =~ /^Can't open/;
print "ok $i\n"; ++$i;
--- NEW FILE: Dumpvalue.pm ---
use 5.006_001; # for (defined ref) and $#$v and our
package Dumpvalue;
use strict;
our $VERSION = '1.12';
our(%address, $stab, @stab, %stab, %subs);
# documentation nits, handle complex data structures better by chromatic
# translate control chars to ^X - Randal Schwartz
# Modifications to print types by Peter Gordon v1.0
# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
# Won't dump symbol tables and contents of debugged files by default
# (IZ) changes for objectification:
# c) quote() renamed to method set_quote();
# d) unctrlSet() renamed to method set_unctrl();
# f) Compiles with `use strict', but in two places no strict refs is needed:
# maybe more problems are waiting...
my %defaults = (
globPrint => 0,
printUndef => 1,
tick => "auto",
unctrl => 'quote',
subdump => 1,
dumpReused => 0,
bareStringify => 1,
hashDepth => '',
arrayDepth => '',
dumpDBFiles => '',
dumpPackages => '',
quoteHighBit => '',
usageOnly => '',
compactDump => '',
veryCompact => '',
stopDbSignal => '',
);
sub new {
my $class = shift;
my %opt = (%defaults, @_);
bless \%opt, $class;
}
sub set {
my $self = shift;
my %opt = @_;
@$self{keys %opt} = values %opt;
}
sub get {
my $self = shift;
wantarray ? @$self{@_} : $$self{pop @_};
}
sub dumpValue {
my $self = shift;
die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
local %address;
local $^W=0;
(print "undef\n"), return unless defined $_[0];
(print $self->stringify($_[0]), "\n"), return unless ref $_[0];
$self->unwrap($_[0],0);
}
sub dumpValues {
my $self = shift;
local %address;
local $^W=0;
(print "undef\n"), return unless defined $_[0];
$self->unwrap(\@_,0);
}
# This one is good for variable names:
sub unctrl {
local($_) = @_;
return \$_ if ref \$_ eq "GLOB";
s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
$_;
}
sub stringify {
my $self = shift;
local $_ = shift;
my $noticks = shift;
my $tick = $self->{tick};
return 'undef' unless defined $_ or not $self->{printUndef};
return $_ . "" if ref \$_ eq 'GLOB';
{ no strict 'refs';
$_ = &{'overload::StrVal'}($_)
if $self->{bareStringify} and ref $_
and %overload:: and defined &{'overload::StrVal'};
}
if ($tick eq 'auto') {
if (/[\000-\011\013-\037\177]/) {
$tick = '"';
} else {
$tick = "'";
}
}
if ($tick eq "'") {
s/([\'\\])/\\$1/g;
} elsif ($self->{unctrl} eq 'unctrl') {
s/([\"\\])/\\$1/g ;
s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
if $self->{quoteHighBit};
} elsif ($self->{unctrl} eq 'quote') {
s/([\"\\\$\@])/\\$1/g if $tick eq '"';
s/\033/\\e/g;
s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
}
s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
($noticks || /^\d+(\.\d*)?\Z/)
? $_
: $tick . $_ . $tick;
}
sub DumpElem {
my ($self, $v) = (shift, shift);
my $short = $self->stringify($v, ref $v);
my $shortmore = '';
if ($self->{veryCompact} && ref $v
&& (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
my $depth = $#$v;
($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1)
if $self->{arrayDepth} and $depth >= $self->{arrayDepth};
my @a = map $self->stringify($_), @$v[0..$depth];
print "0..$#{$v} @a$shortmore\n";
} elsif ($self->{veryCompact} && ref $v
&& (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
my @a = sort keys %$v;
my $depth = $#a;
($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
if $self->{hashDepth} and $depth >= $self->{hashDepth};
my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
@a[0..$depth];
local $" = ', ';
print "@b$shortmore\n";
} else {
print "$short\n";
$self->unwrap($v,shift);
}
}
sub unwrap {
my $self = shift;
return if $DB::signal and $self->{stopDbSignal};
my ($v) = shift ;
my ($s) = shift ; # extra no of spaces
my $sp;
my (%v, at v,$address,$short,$fileno);
$sp = " " x $s ;
$s += 3 ;
# Check for reused addresses
if (ref $v) {
my $val = $v;
{ no strict 'refs';
$val = &{'overload::StrVal'}($v)
if %overload:: and defined &{'overload::StrVal'};
}
($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
if (!$self->{dumpReused} && defined $address) {
$address{$address}++ ;
if ( $address{$address} > 1 ) {
print "${sp}-> REUSED_ADDRESS\n" ;
return ;
}
}
} elsif (ref \$v eq 'GLOB') {
$address = "$v" . ""; # To avoid a bug with globs
$address{$address}++ ;
if ( $address{$address} > 1 ) {
print "${sp}*DUMPED_GLOB*\n" ;
return ;
}
}
if (ref $v eq 'Regexp') {
my $re = "$v";
$re =~ s,/,\\/,g;
print "$sp-> qr/$re/\n";
return;
}
if ( UNIVERSAL::isa($v, 'HASH') ) {
my @sortKeys = sort keys(%$v) ;
my $more;
my $tHashDepth = $#sortKeys ;
$tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
unless $self->{hashDepth} eq '' ;
$more = "....\n" if $tHashDepth < $#sortKeys ;
my $shortmore = "";
$shortmore = ", ..." if $tHashDepth < $#sortKeys ;
$#sortKeys = $tHashDepth ;
if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
$short = $sp;
my @keys;
for (@sortKeys) {
push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
}
$short .= join ', ', @keys;
$short .= $shortmore;
(print "$short\n"), return if length $short <= $self->{compactDump};
}
for my $key (@sortKeys) {
return if $DB::signal and $self->{stopDbSignal};
my $value = $ {$v}{$key} ;
print $sp, $self->stringify($key), " => ";
$self->DumpElem($value, $s);
}
print "$sp empty hash\n" unless @sortKeys;
print "$sp$more" if defined $more ;
} elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
my $tArrayDepth = $#{$v} ;
my $more ;
$tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
unless $self->{arrayDepth} eq '' ;
$more = "....\n" if $tArrayDepth < $#{$v} ;
my $shortmore = "";
$shortmore = " ..." if $tArrayDepth < $#{$v} ;
if ($self->{compactDump} && !grep(ref $_, @{$v})) {
if ($#$v >= 0) {
$short = $sp . "0..$#{$v} " .
join(" ",
map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth)
) . "$shortmore";
} else {
$short = $sp . "empty array";
}
(print "$short\n"), return if length $short <= $self->{compactDump};
}
for my $num ($[ .. $tArrayDepth) {
return if $DB::signal and $self->{stopDbSignal};
print "$sp$num ";
if (exists $v->[$num]) {
$self->DumpElem($v->[$num], $s);
} else {
print "empty slot\n";
}
}
print "$sp empty array\n" unless @$v;
print "$sp$more" if defined $more ;
} elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
print "$sp-> ";
$self->DumpElem($$v, $s);
} elsif ( UNIVERSAL::isa($v, 'CODE') ) {
print "$sp-> ";
$self->dumpsub(0, $v);
} elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
print "$sp-> ",$self->stringify($$v,1),"\n";
if ($self->{globPrint}) {
$s += 3;
$self->dumpglob('', $s, "{$$v}", $$v, 1);
} elsif (defined ($fileno = fileno($v))) {
print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
}
} elsif (ref \$v eq 'GLOB') {
if ($self->{globPrint}) {
$self->dumpglob('', $s, "{$v}", $v, 1);
} elsif (defined ($fileno = fileno(\$v))) {
print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
}
}
}
sub matchvar {
$_[0] eq $_[1] or
($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
}
sub compactDump {
my $self = shift;
$self->{compactDump} = shift if @_;
$self->{compactDump} = 6*80-1
if $self->{compactDump} and $self->{compactDump} < 2;
$self->{compactDump};
}
sub veryCompact {
my $self = shift;
$self->{veryCompact} = shift if @_;
$self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
$self->{veryCompact};
}
sub set_unctrl {
my $self = shift;
if (@_) {
my $in = shift;
if ($in eq 'unctrl' or $in eq 'quote') {
$self->{unctrl} = $in;
} else {
print "Unknown value for `unctrl'.\n";
}
}
$self->{unctrl};
}
sub set_quote {
my $self = shift;
if (@_ and $_[0] eq '"') {
$self->{tick} = '"';
$self->{unctrl} = 'quote';
} elsif (@_ and $_[0] eq 'auto') {
$self->{tick} = 'auto';
$self->{unctrl} = 'quote';
} elsif (@_) { # Need to set
$self->{tick} = "'";
$self->{unctrl} = 'unctrl';
}
$self->{tick};
}
sub dumpglob {
my $self = shift;
return if $DB::signal and $self->{stopDbSignal};
my ($package, $off, $key, $val, $all) = @_;
local(*stab) = $val;
my $fileno;
if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
print( (' ' x $off) . "\$", &unctrl($key), " = " );
$self->DumpElem($stab, 3+$off);
}
if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
print( (' ' x $off) . "\@$key = (\n" );
$self->unwrap(\@stab,3+$off) ;
print( (' ' x $off) . ")\n" );
}
if ($key ne "main::" && $key ne "DB::" && %stab
&& ($self->{dumpPackages} or $key !~ /::$/)
&& ($key !~ /^_</ or $self->{dumpDBFiles})
&& !($package eq "Dumpvalue" and $key eq "stab")) {
print( (' ' x $off) . "\%$key = (\n" );
$self->unwrap(\%stab,3+$off) ;
print( (' ' x $off) . ")\n" );
}
if (defined ($fileno = fileno(*stab))) {
print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
}
if ($all) {
if (defined &stab) {
$self->dumpsub($off, $key);
}
}
}
sub CvGV_name {
my $self = shift;
my $in = shift;
return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken...
$in = \&$in; # Hard reference...
eval {require Devel::Peek; 1} or return;
my $gv = Devel::Peek::CvGV($in) or return;
*$gv{PACKAGE} . '::' . *$gv{NAME};
}
sub dumpsub {
my $self = shift;
my ($off,$sub) = @_;
my $ini = $sub;
my $s;
$sub = $1 if $sub =~ /^\{\*(.*)\}$/;
my $subref = defined $1 ? \&$sub : \&$ini;
my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
|| (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
|| ($self->{subdump} && ($s = $self->findsubs("$subref"))
&& $DB::sub{$s});
$s = $sub unless defined $s;
$place = '???' unless defined $place;
print( (' ' x $off) . "&$s in $place\n" );
}
sub findsubs {
my $self = shift;
return undef unless %DB::sub;
my ($addr, $name, $loc);
while (($name, $loc) = each %DB::sub) {
$addr = \&$name;
$subs{"$addr"} = $name;
}
$self->{subdump} = 0;
$subs{ shift() };
}
sub dumpvars {
my $self = shift;
my ($package, at vars) = @_;
local(%address,$^W);
my ($key,$val);
$package .= "::" unless $package =~ /::$/;
*stab = *main::;
while ($package =~ /(\w+?::)/g) {
*stab = $ {stab}{$1};
}
$self->{TotalStrings} = 0;
$self->{Strings} = 0;
$self->{CompleteTotal} = 0;
while (($key,$val) = each(%stab)) {
return if $DB::signal and $self->{stopDbSignal};
next if @vars && !grep( matchvar($key, $_), @vars );
if ($self->{usageOnly}) {
$self->globUsage(\$val, $key)
if ($package ne 'Dumpvalue' or $key ne 'stab')
and ref(\$val) eq 'GLOB';
} else {
$self->dumpglob($package, 0,$key, $val);
}
}
if ($self->{usageOnly}) {
print <<EOP;
String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
EOP
$self->{CompleteTotal} += $self->{TotalStrings};
print <<EOP;
Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
EOP
}
}
sub scalarUsage {
my $self = shift;
my $size;
if (UNIVERSAL::isa($_[0], 'ARRAY')) {
$size = $self->arrayUsage($_[0]);
} elsif (UNIVERSAL::isa($_[0], 'HASH')) {
$size = $self->hashUsage($_[0]);
} elsif (!ref($_[0])) {
$size = length($_[0]);
}
$self->{TotalStrings} += $size;
$self->{Strings}++;
$size;
}
sub arrayUsage { # array ref, name
my $self = shift;
my $size = 0;
map {$size += $self->scalarUsage($_)} @{$_[0]};
my $len = @{$_[0]};
print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
if defined $_[1];
$self->{CompleteTotal} += $size;
$size;
}
sub hashUsage { # hash ref, name
my $self = shift;
my @keys = keys %{$_[0]};
my @values = values %{$_[0]};
my $keys = $self->arrayUsage(\@keys);
my $values = $self->arrayUsage(\@values);
my $len = @keys;
my $total = $keys + $values;
print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
" (keys: $keys; values: $values; total: $total bytes)\n"
if defined $_[1];
$total;
}
sub globUsage { # glob ref, name
my $self = shift;
local *stab = *{$_[0]};
my $total = 0;
$total += $self->scalarUsage($stab) if defined $stab;
$total += $self->arrayUsage(\@stab, $_[1]) if @stab;
$total += $self->hashUsage(\%stab, $_[1])
if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
#and !($package eq "Dumpvalue" and $key eq "stab"));
$total;
}
1;
=head1 NAME
Dumpvalue - provides screen dump of Perl data.
=head1 SYNOPSIS
use Dumpvalue;
my $dumper = new Dumpvalue;
$dumper->set(globPrint => 1);
$dumper->dumpValue(\*::);
$dumper->dumpvars('main');
my $dump = $dumper->stringify($some_value);
=head1 DESCRIPTION
=head2 Creation
A new dumper is created by a call
$d = new Dumpvalue(option1 => value1, option2 => value2)
Recognized options:
=over 4
=item C<arrayDepth>, C<hashDepth>
Print only first N elements of arrays and hashes. If false, prints all the
elements.
=item C<compactDump>, C<veryCompact>
Change style of array and hash dump. If true, short array
may be printed on one line.
=item C<globPrint>
Whether to print contents of globs.
=item C<dumpDBFiles>
Dump arrays holding contents of debugged files.
=item C<dumpPackages>
Dump symbol tables of packages.
=item C<dumpReused>
Dump contents of "reused" addresses.
=item C<tick>, C<quoteHighBit>, C<printUndef>
Change style of string dump. Default value of C<tick> is C<auto>, one
can enable either double-quotish dump, or single-quotish by setting it
to C<"> or C<'>. By default, characters with high bit set are printed
I<as is>. If C<quoteHighBit> is set, they will be quoted.
=item C<usageOnly>
rudimentally per-package memory usage dump. If set,
C<dumpvars> calculates total size of strings in variables in the package.
=item unctrl
Changes the style of printout of strings. Possible values are
C<unctrl> and C<quote>.
=item subdump
Whether to try to find the subroutine name given the reference.
=item bareStringify
Whether to write the non-overloaded form of the stringify-overloaded objects.
=item quoteHighBit
Whether to print chars with high bit set in binary or "as is".
=item stopDbSignal
Whether to abort printing if debugger signal flag is raised.
=back
Later in the life of the object the methods may be queries with get()
method and set() method (which accept multiple arguments).
=head2 Methods
=over 4
=item dumpValue
$dumper->dumpValue($value);
$dumper->dumpValue([$value1, $value2]);
Prints a dump to the currently selected filehandle.
=item dumpValues
$dumper->dumpValues($value1, $value2);
Same as C< $dumper->dumpValue([$value1, $value2]); >.
=item stringify
my $dump = $dumper->stringify($value [,$noticks] );
Returns the dump of a single scalar without printing. If the second
argument is true, the return value does not contain enclosing ticks.
Does not handle data structures.
=item dumpvars
$dumper->dumpvars('my_package');
$dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
The optional arguments are considered as literal strings unless they
start with C<~> or C<!>, in which case they are interpreted as regular
expressions (possibly negated).
The second example prints entries with names C<foo>, and also entries
with names which ends on C<bar>, or are shorter than 5 chars.
=item set_quote
$d->set_quote('"');
Sets C<tick> and C<unctrl> options to suitable values for printout with the
given quote char. Possible values are C<auto>, C<'> and C<">.
=item set_unctrl
$d->set_unctrl('unctrl');
Sets C<unctrl> option with checking for an invalid argument.
Possible values are C<unctrl> and C<quote>.
=item compactDump
$d->compactDump(1);
Sets C<compactDump> option. If the value is 1, sets to a reasonable
big number.
=item veryCompact
$d->veryCompact(1);
Sets C<compactDump> and C<veryCompact> options simultaneously.
=item set
$d->set(option1 => value1, option2 => value2);
=item get
@values = $d->get('option1', 'option2');
=back
=cut
--- NEW FILE: hostname.pl ---
# From: asherman at fmrco.com (Aaron Sherman)
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Sys::Hostname
#
sub hostname
{
local(*P, at tmp,$hostname,$_);
if (open(P,"hostname 2>&1 |") && (@tmp = <P>) && close(P))
{
chop($hostname = $tmp[$#tmp]);
}
elsif (open(P,"uname -n 2>&1 |") && (@tmp = <P>) && close(P))
{
chop($hostname = $tmp[$#tmp]);
}
else
{
die "$0: Cannot get hostname from 'hostname' or 'uname -n'\n";
}
@tmp = ();
close P; # Just in case we failed in an odd spot....
$hostname;
}
1;
--- NEW FILE: SelfLoader.pm ---
package SelfLoader;
# use Carp;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(AUTOLOAD);
$VERSION = "1.0904";
sub Version {$VERSION}
$DEBUG = 0;
my %Cache; # private cache for all SelfLoader's client packages
# allow checking for valid ': attrlist' attachments
# (we use 'our' rather than 'my' here, due to the rather complex and buggy
# behaviour of lexicals with qr// and (??{$lex}) )
our $nested;
$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x;
our $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
our $attr_list = qr{ \s* : \s* (?: $one_attr )* }x;
sub croak { require Carp; goto &Carp::croak }
AUTOLOAD {
print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if $DEBUG;
my $SL_code = $Cache{$AUTOLOAD};
my $save = $@; # evals in both AUTOLOAD and _load_stubs can corrupt $@
unless ($SL_code) {
# Maybe this pack had stubs before __DATA__, and never initialized.
# Or, this maybe an automatic DESTROY method call when none exists.
$AUTOLOAD =~ m/^(.*)::/;
SelfLoader->_load_stubs($1) unless exists $Cache{"${1}::<DATA"};
$SL_code = $Cache{$AUTOLOAD};
$SL_code = "sub $AUTOLOAD { }"
if (!$SL_code and $AUTOLOAD =~ m/::DESTROY$/);
croak "Undefined subroutine $AUTOLOAD" unless $SL_code;
}
print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if $DEBUG;
eval $SL_code;
if ($@) {
$@ =~ s/ at .*\n//;
croak $@;
}
$@ = $save;
defined(&$AUTOLOAD) || die "SelfLoader inconsistency error";
delete $Cache{$AUTOLOAD};
goto &$AUTOLOAD
}
sub load_stubs { shift->_load_stubs((caller)[0]) }
sub _load_stubs {
# $endlines is used by Devel::SelfStubber to capture lines after __END__
my($self, $callpack, $endlines) = @_;
my $fh = \*{"${callpack}::DATA"};
my $currpack = $callpack;
my($line,$name, at lines, @stubs, $protoype);
print STDERR "SelfLoader::load_stubs($callpack)\n" if $DEBUG;
croak("$callpack doesn't contain an __DATA__ token")
unless fileno($fh);
$Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
local($/) = "\n";
while(defined($line = <$fh>) and $line !~ m/^__END__/) {
if ($line =~ m/^sub\s+([\w:]+)\s*((?:\([\\\$\@\%\&\*\;]*\))?(?:$attr_list)?)/) {
push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
$protoype = $2;
@lines = ($line);
if (index($1,'::') == -1) { # simple sub name
$name = "${currpack}::$1";
} else { # sub name with package
$name = $1;
$name =~ m/^(.*)::/;
if (defined(&{"${1}::AUTOLOAD"})) {
\&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
die 'SelfLoader Error: attempt to specify Selfloading',
" sub $name in non-selfloading module $1";
} else {
$self->export($1,'AUTOLOAD');
}
}
} elsif ($line =~ m/^package\s+([\w:]+)/) { # A package declared
push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
$self->_package_defined($line);
$name = '';
@lines = ();
$currpack = $1;
$Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
if (defined(&{"${1}::AUTOLOAD"})) {
\&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
die 'SelfLoader Error: attempt to specify Selfloading',
" package $currpack which already has AUTOLOAD";
} else {
$self->export($currpack,'AUTOLOAD');
}
} else {
push(@lines,$line);
}
}
if (defined($line) && $line =~ /^__END__/) { # __END__
unless ($line =~ /^__END__\s*DATA/) {
if ($endlines) {
# Devel::SelfStubber would like us to capture the lines after
# __END__ so it can write out the entire file
@$endlines = <$fh>;
}
close($fh);
}
}
push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
eval join('', @stubs) if @stubs;
}
sub _add_to_cache {
my($self,$fullname,$pack,$lines, $protoype) = @_;
return () unless $fullname;
(require Carp), Carp::carp("Redefining sub $fullname")
if exists $Cache{$fullname};
$Cache{$fullname} = join('', "package $pack; ",@$lines);
print STDERR "SelfLoader cached $fullname: $Cache{$fullname}" if $DEBUG;
# return stub to be eval'd
defined($protoype) ? "sub $fullname $protoype;" : "sub $fullname;"
}
sub _package_defined {}
1;
__END__
=head1 NAME
SelfLoader - load functions only on demand
=head1 SYNOPSIS
package FOOBAR;
use SelfLoader;
... (initializing code)
__DATA__
sub {....
=head1 DESCRIPTION
This module tells its users that functions in the FOOBAR package are to be
autoloaded from after the C<__DATA__> token. See also
L<perlsub/"Autoloading">.
=head2 The __DATA__ token
The C<__DATA__> token tells the perl compiler that the perl code
for compilation is finished. Everything after the C<__DATA__> token
is available for reading via the filehandle FOOBAR::DATA,
where FOOBAR is the name of the current package when the C<__DATA__>
token is reached. This works just the same as C<__END__> does in
package 'main', but for other modules data after C<__END__> is not
automatically retrievable, whereas data after C<__DATA__> is.
The C<__DATA__> token is not recognized in versions of perl prior to
5.001m.
Note that it is possible to have C<__DATA__> tokens in the same package
in multiple files, and that the last C<__DATA__> token in a given
package that is encountered by the compiler is the one accessible
by the filehandle. This also applies to C<__END__> and main, i.e. if
the 'main' program has an C<__END__>, but a module 'require'd (_not_ 'use'd)
by that program has a 'package main;' declaration followed by an 'C<__DATA__>',
then the C<DATA> filehandle is set to access the data after the C<__DATA__>
in the module, _not_ the data after the C<__END__> token in the 'main'
program, since the compiler encounters the 'require'd file later.
=head2 SelfLoader autoloading
The B<SelfLoader> works by the user placing the C<__DATA__>
token I<after> perl code which needs to be compiled and
run at 'require' time, but I<before> subroutine declarations
that can be loaded in later - usually because they may never
be called.
The B<SelfLoader> will read from the FOOBAR::DATA filehandle to
load in the data after C<__DATA__>, and load in any subroutine
when it is called. The costs are the one-time parsing of the
data after C<__DATA__>, and a load delay for the _first_
call of any autoloaded function. The benefits (hopefully)
are a speeded up compilation phase, with no need to load
functions which are never used.
The B<SelfLoader> will stop reading from C<__DATA__> if
it encounters the C<__END__> token - just as you would expect.
If the C<__END__> token is present, and is followed by the
token DATA, then the B<SelfLoader> leaves the FOOBAR::DATA
filehandle open on the line after that token.
The B<SelfLoader> exports the C<AUTOLOAD> subroutine to the
package using the B<SelfLoader>, and this loads the called
subroutine when it is first called.
There is no advantage to putting subroutines which will _always_
be called after the C<__DATA__> token.
=head2 Autoloading and package lexicals
A 'my $pack_lexical' statement makes the variable $pack_lexical
local _only_ to the file up to the C<__DATA__> token. Subroutines
declared elsewhere _cannot_ see these types of variables,
just as if you declared subroutines in the package but in another
file, they cannot see these variables.
So specifically, autoloaded functions cannot see package
lexicals (this applies to both the B<SelfLoader> and the Autoloader).
The C<vars> pragma provides an alternative to defining package-level
globals that will be visible to autoloaded routines. See the documentation
on B<vars> in the pragma section of L<perlmod>.
=head2 SelfLoader and AutoLoader
The B<SelfLoader> can replace the AutoLoader - just change 'use AutoLoader'
to 'use SelfLoader' (though note that the B<SelfLoader> exports
the AUTOLOAD function - but if you have your own AUTOLOAD and
are using the AutoLoader too, you probably know what you're doing),
and the C<__END__> token to C<__DATA__>. You will need perl version 5.001m
or later to use this (version 5.001 with all patches up to patch m).
There is no need to inherit from the B<SelfLoader>.
The B<SelfLoader> works similarly to the AutoLoader, but picks up the
subs from after the C<__DATA__> instead of in the 'lib/auto' directory.
There is a maintenance gain in not needing to run AutoSplit on the module
at installation, and a runtime gain in not needing to keep opening and
closing files to load subs. There is a runtime loss in needing
to parse the code after the C<__DATA__>. Details of the B<AutoLoader> and
another view of these distinctions can be found in that module's
documentation.
=head2 __DATA__, __END__, and the FOOBAR::DATA filehandle.
This section is only relevant if you want to use
the C<FOOBAR::DATA> together with the B<SelfLoader>.
Data after the C<__DATA__> token in a module is read using the
FOOBAR::DATA filehandle. C<__END__> can still be used to denote the end
of the C<__DATA__> section if followed by the token DATA - this is supported
by the B<SelfLoader>. The C<FOOBAR::DATA> filehandle is left open if an
C<__END__> followed by a DATA is found, with the filehandle positioned at
the start of the line after the C<__END__> token. If no C<__END__> token is
present, or an C<__END__> token with no DATA token on the same line, then
the filehandle is closed.
The B<SelfLoader> reads from wherever the current
position of the C<FOOBAR::DATA> filehandle is, until the
EOF or C<__END__>. This means that if you want to use
that filehandle (and ONLY if you want to), you should either
1. Put all your subroutine declarations immediately after
the C<__DATA__> token and put your own data after those
declarations, using the C<__END__> token to mark the end
of subroutine declarations. You must also ensure that the B<SelfLoader>
reads first by calling 'SelfLoader-E<gt>load_stubs();', or by using a
function which is selfloaded;
or
2. You should read the C<FOOBAR::DATA> filehandle first, leaving
the handle open and positioned at the first line of subroutine
declarations.
You could conceivably do both.
=head2 Classes and inherited methods.
For modules which are not classes, this section is not relevant.
This section is only relevant if you have methods which could
be inherited.
A subroutine stub (or forward declaration) looks like
sub stub;
i.e. it is a subroutine declaration without the body of the
subroutine. For modules which are not classes, there is no real
need for stubs as far as autoloading is concerned.
For modules which ARE classes, and need to handle inherited methods,
stubs are needed to ensure that the method inheritance mechanism works
properly. You can load the stubs into the module at 'require' time, by
adding the statement 'SelfLoader-E<gt>load_stubs();' to the module to do
this.
The alternative is to put the stubs in before the C<__DATA__> token BEFORE
releasing the module, and for this purpose the C<Devel::SelfStubber>
module is available. However this does require the extra step of ensuring
that the stubs are in the module. If this is done I strongly recommend
that this is done BEFORE releasing the module - it should NOT be done
at install time in general.
=head1 Multiple packages and fully qualified subroutine names
Subroutines in multiple packages within the same file are supported - but you
should note that this requires exporting the C<SelfLoader::AUTOLOAD> to
every package which requires it. This is done automatically by the
B<SelfLoader> when it first loads the subs into the cache, but you should
really specify it in the initialization before the C<__DATA__> by putting
a 'use SelfLoader' statement in each package.
Fully qualified subroutine names are also supported. For example,
__DATA__
sub foo::bar {23}
package baz;
sub dob {32}
will all be loaded correctly by the B<SelfLoader>, and the B<SelfLoader>
will ensure that the packages 'foo' and 'baz' correctly have the
B<SelfLoader> C<AUTOLOAD> method when the data after C<__DATA__> is first
parsed.
=cut
--- NEW FILE: Benchmark.pm ---
package Benchmark;
use strict;
=head1 NAME
Benchmark - benchmark running times of Perl code
=head1 SYNOPSIS
use Benchmark qw(:all) ;
timethis ($count, "code");
# Use Perl code in strings...
timethese($count, {
'Name1' => '...code1...',
'Name2' => '...code2...',
[...976 lines suppressed...]
if $$_ > $min_width;
++$$_;
++$total;
last STRETCHER
if $total >= 80;
}
}
# Dump the output
my $format = join( ' ', map { "%${_}s" } @col_widths ) . "\n";
substr( $format, 1, 0 ) = '-';
for ( @rows ) {
printf $format, @$_;
}
return \@rows ;
}
1;
--- NEW FILE: sigtrap.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use strict;
use Config;
use Test::More tests => 15;
use_ok( 'sigtrap' );
package main;
local %SIG;
# use a version of sigtrap.pm somewhat too high
eval{ sigtrap->import(99999) };
like( $@, qr/version 99999 required,/, 'import excessive version number' );
# use an invalid signal name
eval{ sigtrap->import('abadsignal') };
like( $@, qr/^Unrecognized argument abadsignal/, 'send bad signame to import' );
eval{ sigtrap->import('handler') };
like( $@, qr/^No argument specified/, 'send handler without subref' );
sigtrap->import('AFAKE');
is( $SIG{AFAKE}, \&sigtrap::handler_traceback, 'install normal handler' );
sigtrap->import('die', 'AFAKE', 'stack-trace', 'FAKE2');
is( $SIG{AFAKE}, \&sigtrap::handler_die, 'install the die handler' );
is( $SIG{FAKE2}, \&sigtrap::handler_traceback, 'install traceback handler' );
my @normal = qw( HUP INT PIPE TERM );
@SIG{@normal} = 1 x @normal;
sigtrap->import('normal-signals');
is( (grep { ref $_ } @SIG{@normal}), @normal, 'check normal-signals set' );
my @error = qw( ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP );
@SIG{@error} = 1 x @error;
sigtrap->import('error-signals');
is( (grep { ref $_ } @SIG{@error}), @error, 'check error-signals set' );
my @old = qw( ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP );
@SIG{@old} = 1 x @old;
sigtrap->import('old-interface-signals');
is( (grep { ref $_ } @SIG{@old}), @old, 'check old-interface-signals set' );
my $handler = sub {};
sigtrap->import(handler => $handler, 'FAKE3');
is( $SIG{FAKE3}, $handler, 'install custom handler' );
$SIG{FAKE} = 'IGNORE';
sigtrap->import('untrapped', 'FAKE');
is( $SIG{FAKE}, 'IGNORE', 'respect existing handler set to IGNORE' );
my $out = tie *STDOUT, 'TieOut';
$SIG{FAKE} = 'DEFAULT';
$sigtrap::Verbose = 1;
sigtrap->import('any', 'FAKE');
is( $SIG{FAKE}, \&sigtrap::handler_traceback, 'should set default handler' );
like( $out->read, qr/^Installing handler/, 'does it talk with $Verbose set?' );
# handler_die croaks with first argument
eval { sigtrap::handler_die('FAKE') };
like( $@, qr/^Caught a SIGFAKE/, 'does handler_die() croak?' );
package TieOut;
sub TIEHANDLE {
bless(\(my $scalar), $_[0]);
}
sub PRINT {
my $self = shift;
$$self .= join '', @_;
}
sub WRITE {
my ($self, $msg, $length) = @_;
$$self .= $msg;
}
sub read {
my $self = shift;
substr($$self, 0, length($$self), '');
}
--- NEW FILE: Benchmark.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = ('../lib');
}
use warnings;
use strict;
use vars qw($foo $bar $baz $ballast);
use Test::More tests => 194;
use Benchmark qw(:all);
my $delta = 0.4;
# Some timing ballast
sub fib {
my $n = shift;
return $n if $n < 2;
fib($n-1) + fib($n-2);
}
$ballast = 15;
my $All_Pattern =
qr/(\d+) +wallclock secs? +\( *(-?\d+\.\d\d) +usr +(-?\d+\.\d\d) +sys +\+ +(-?\d+\.\d\d) +cusr +(-?\d+\.\d\d) +csys += +(-?\d+\.\d\d) +CPU\)/;
my $Noc_Pattern =
qr/(\d+) +wallclock secs? +\( *(-?\d+\.\d\d) +usr +\+ +(-?\d+\.\d\d) +sys += +(-?\d+\.\d\d) +CPU\)/;
my $Nop_Pattern =
qr/(\d+) +wallclock secs? +\( *(-?\d+\.\d\d) +cusr +\+ +(-?\d+\.\d\d) +csys += +\d+\.\d\d +CPU\)/;
# Please don't trust the matching parenthises to be useful in this :-)
my $Default_Pattern = qr/$All_Pattern|$Noc_Pattern/;
my $t0 = new Benchmark;
isa_ok ($t0, 'Benchmark', "Ensure we can create a benchmark object");
# We use the benchmark object once we've done some work:
isa_ok(timeit(5, sub {++$foo}), 'Benchmark', "timeit CODEREF");
is ($foo, 5, "benchmarked code was run 5 times");
isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval");
is ($bar, 5, "benchmarked code was run 5 times");
# is coderef called with spurious arguments?
timeit( 1, sub { $foo = @_ });
is ($foo, 0, "benchmarked code called without arguments");
print "# Burning CPU to benchmark things will take time...\n";
# We need to do something fairly slow in the coderef.
# Same coderef. Same place in memory.
my $coderef = sub {$baz += fib($ballast)};
# The default is three.
$baz = 0;
my $threesecs = countit(0, $coderef);
isa_ok($threesecs, 'Benchmark', "countit 0, CODEREF");
isnt ($baz, 0, "benchmarked code was run");
my $in_threesecs = $threesecs->iters;
print "# $in_threesecs iterations\n";
ok ($in_threesecs > 0, "iters returned positive iterations");
my $estimate = int (100 * $in_threesecs / 3) / 100;
print "# from the 3 second run estimate $estimate iterations in 1 second...\n";
$baz = 0;
my $onesec = countit(1, $coderef);
isa_ok($onesec, 'Benchmark', "countit 1, CODEREF");
isnt ($baz, 0, "benchmarked code was run");
my $in_onesec = $onesec->iters;
print "# $in_onesec iterations\n";
ok ($in_onesec > 0, "iters returned positive iterations");
{
my $difference = $in_onesec - $estimate;
my $actual = abs ($difference / $in_onesec);
ok ($actual < $delta, "is $in_onesec within $delta of estimate ($estimate)");
print "# $in_onesec is between " . ($delta / 2) .
" and $delta of estimate. Not that safe.\n" if $actual > $delta/2;
}
# I found that the eval'ed version was 3 times faster than the coderef.
# (now it has a different ballast value)
$baz = 0;
my $again = countit(1, '$baz += fib($ballast)');
isa_ok($onesec, 'Benchmark', "countit 1, eval");
isnt ($baz, 0, "benchmarked code was run");
my $in_again = $again->iters;
print "# $in_again iterations\n";
ok ($in_again > 0, "iters returned positive iterations");
my $t1 = new Benchmark;
isa_ok ($t1, 'Benchmark', "Create another benchmark object now we're finished");
my $diff = timediff ($t1, $t0);
isa_ok ($diff, 'Benchmark', "Get the time difference");
isa_ok (timesum ($t0, $t1), 'Benchmark', "check timesum");
my $default = timestr ($diff);
isnt ($default, '', 'timestr ($diff)');
my $auto = timestr ($diff, 'auto');
is ($auto, $default, 'timestr ($diff, "auto") matches timestr ($diff)');
{
my $all = timestr ($diff, 'all');
like ($all, $All_Pattern, 'timestr ($diff, "all")');
print "# $all\n";
my ($wallclock, $usr, $sys, $cusr, $csys, $cpu) = $all =~ $All_Pattern;
is (timestr ($diff, 'none'), '', "none supresses output");
my $noc = timestr ($diff, 'noc');
like ($noc, qr/$wallclock +wallclock secs? +\( *$usr +usr +\+ +$sys +sys += +$cpu +CPU\)/, 'timestr ($diff, "noc")');
my $nop = timestr ($diff, 'nop');
like ($nop, qr/$wallclock +wallclock secs? +\( *$cusr +cusr +\+ +$csys +csys += +\d+\.\d\d +CPU\)/, 'timestr ($diff, "nop")');
if ($auto eq $noc) {
pass ('"auto" is "noc"');
} else {
is ($auto, $all, '"auto" isn\'t "noc", so should be eq to "all"');
}
like (timestr ($diff, 'all', 'E'),
qr/(\d+) +wallclock secs? +\( *\d\.\d+E[-+]?\d\d\d? +usr +\d\.\d+E[-+]?\d\d\d? +sys +\+ +\d\.\d+E[-+]?\d\d\d? +cusr +\d\.\d+E[-+]?\d\d\d? +csys += +\d\.\d+E[-+]?\d\d\d? +CPU\)/, 'timestr ($diff, "all", "E") [sprintf format of "E"]');
}
my $out = tie *OUT, 'TieOut';
my $iterations = 3;
$foo = 0;
select(OUT);
my $got = timethis($iterations, sub {++$foo});
select(STDOUT);
isa_ok($got, 'Benchmark', "timethis CODEREF");
is ($foo, $iterations, "benchmarked code was run $iterations times");
$got = $out->read();
like ($got, qr/^timethis $iterations/, 'default title');
like ($got, $Default_Pattern, 'default format is all or noc');
$bar = 0;
select(OUT);
$got = timethis($iterations, '++$bar');
select(STDOUT);
isa_ok($got, 'Benchmark', "timethis eval");
is ($bar, $iterations, "benchmarked code was run $iterations times");
$got = $out->read();
like ($got, qr/^timethis $iterations/, 'default title');
like ($got, $Default_Pattern, 'default format is all or noc');
my $title = 'lies, damn lies and benchmarks';
$foo = 0;
select(OUT);
$got = timethis($iterations, sub {++$foo}, $title);
select(STDOUT);
isa_ok($got, 'Benchmark', "timethis with title");
is ($foo, $iterations, "benchmarked code was run $iterations times");
$got = $out->read();
like ($got, qr/^$title:/, 'specify title');
like ($got, $Default_Pattern, 'default format is all or noc');
# default is auto, which is all or noc. nop can never match the default
$foo = 0;
select(OUT);
$got = timethis($iterations, sub {++$foo}, $title, 'nop');
select(STDOUT);
isa_ok($got, 'Benchmark', "timethis with format");
is ($foo, $iterations, "benchmarked code was run $iterations times");
$got = $out->read();
like ($got, qr/^$title:/, 'specify title');
like ($got, $Nop_Pattern, 'specify format as nop');
{
$foo = 0;
select(OUT);
my $start = time;
$got = timethis(-2, sub {$foo+= fib($ballast)}, $title, 'none');
my $end = time;
select(STDOUT);
isa_ok($got, 'Benchmark',
"timethis, at least 2 seconds with format 'none'");
ok ($foo > 0, "benchmarked code was run");
ok ($end - $start > 1, "benchmarked code ran for over 1 second");
$got = $out->read();
# Remove any warnings about having too few iterations.
$got =~ s/\(warning:[^\)]+\)//gs;
$got =~ s/^[ \t\n]+//s; # Remove all the whitespace from the beginning
is ($got, '', "format 'none' should suppress output");
}
$foo = $bar = $baz = 0;
select(OUT);
$got = timethese($iterations, { Foo => sub {++$foo}, Bar => '++$bar',
Baz => sub {++$baz} });
select(STDOUT);
is(ref ($got), 'HASH', "timethese should return a hashref");
isa_ok($got->{Foo}, 'Benchmark', "Foo value");
isa_ok($got->{Bar}, 'Benchmark', "Bar value");
isa_ok($got->{Baz}, 'Benchmark', "Baz value");
eq_set([keys %$got], [qw(Foo Bar Baz)], 'should be exactly three objects');
is ($foo, $iterations, "Foo code was run $iterations times");
is ($bar, $iterations, "Bar code was run $iterations times");
is ($baz, $iterations, "Baz code was run $iterations times");
$got = $out->read();
# Remove any warnings about having too few iterations.
$got =~ s/\(warning:[^\)]+\)//gs;
like ($got, qr/timing $iterations iterations of\s+Bar\W+Baz\W+Foo\W*?\.\.\./s,
'check title');
# Remove the title
$got =~ s/.*\.\.\.//s;
like ($got, qr/\bBar\b.*\bBaz\b.*\bFoo\b/s, 'check output is in sorted order');
like ($got, $Default_Pattern, 'should find default format somewhere');
{ # ensure 'use strict' does not leak from Benchmark.pm into benchmarked code
no strict;
select OUT;
eval {
timethese( 1,
{ undeclared_var => q{ $i++; $i-- },
symbolic_ref => q{ $bar = 42;
$foo = 'bar';
$q = ${$foo} },
},
'none'
);
};
is( $@, '', q{no strict leakage in name => 'code'} );
eval {
timethese( 1,
{ undeclared_var => sub { $i++; $i-- },
symbolic_ref => sub { $bar = 42;
$foo = 'bar';
return ${$foo} },
},
'none'
);
};
is( $@, '', q{no strict leakage in name => sub { code }} );
# clear out buffer
$out->read;
}
my $code_to_test = { Foo => sub {$foo+=fib($ballast-2)},
Bar => sub {$bar+=fib($ballast)}};
# Keep these for later.
my $results;
{
$foo = $bar = 0;
select(OUT);
my $start = times;
$results = timethese(-0.1, $code_to_test, 'none');
my $end = times;
select(STDOUT);
is(ref ($results), 'HASH', "timethese should return a hashref");
isa_ok($results->{Foo}, 'Benchmark', "Foo value");
isa_ok($results->{Bar}, 'Benchmark', "Bar value");
eq_set([keys %$results], [qw(Foo Bar)], 'should be exactly two objects');
ok ($foo > 0, "Foo code was run");
ok ($bar > 0, "Bar code was run");
ok (($end - $start) > 0.1, "benchmarked code ran for over 0.1 seconds");
$got = $out->read();
# Remove any warnings about having too few iterations.
$got =~ s/\(warning:[^\)]+\)//gs;
is ($got =~ tr/ \t\n//c, 0, "format 'none' should suppress output");
}
my $graph_dissassembly =
qr!^[ \t]+(\S+)[ \t]+(\w+)[ \t]+(\w+)[ \t]* # Title line
\n[ \t]*(\w+)[ \t]+([0-9.]+(?:/s)?)[ \t]+(-+)[ \t]+(-?\d+%)[ \t]*
\n[ \t]*(\w+)[ \t]+([0-9.]+(?:/s)?)[ \t]+(-?\d+%)[ \t]+(-+)[ \t]*$!xm;
sub check_graph_consistency {
my ( $ratetext, $slowc, $fastc,
$slowr, $slowratet, $slowslow, $slowfastt,
$fastr, $fastratet, $fastslowt, $fastfast)
= @_;
my $all_passed = 1;
$all_passed
&= is ($slowc, $slowr, "left col tag should be top row tag");
$all_passed
&= is ($fastc, $fastr, "right col tag should be bottom row tag");
$all_passed &=
like ($slowslow, qr/^-+/, "should be dash for comparing slow with slow");
$all_passed
&= is ($slowslow, $fastfast, "slow v slow should be same as fast v fast");
my $slowrate = $slowratet;
my $fastrate = $fastratet;
my ($slow_is_rate, $fast_is_rate);
unless ($slow_is_rate = $slowrate =~ s!/s!!) {
# Slow is expressed as iters per second.
$slowrate = 1/$slowrate if $slowrate;
}
unless ($fast_is_rate = $fastrate =~ s!/s!!) {
# Fast is expressed as iters per second.
$fastrate = 1/$fastrate if $fastrate;
}
if ($ratetext =~ /rate/i) {
$all_passed
&= ok ($slow_is_rate, "slow should be expressed as a rate");
$all_passed
&= ok ($fast_is_rate, "fast should be expressed as a rate");
} else {
$all_passed &=
ok (!$slow_is_rate, "slow should be expressed as a iters per second");
$all_passed &=
ok (!$fast_is_rate, "fast should be expressed as a iters per second");
}
(my $slowfast = $slowfastt) =~ s!%!!;
(my $fastslow = $fastslowt) =~ s!%!!;
if ($slowrate < $fastrate) {
pass ("slow rate is less than fast rate");
unless (ok ($slowfast <= 0 && $slowfast >= -100,
"slowfast should be less than or equal to zero, and >= -100")) {
print STDERR "# slowfast $slowfast\n";
$all_passed = 0;
}
unless (ok ($fastslow > 0, "fastslow should be > 0")) {
print STDERR "# fastslow $fastslow\n";
$all_passed = 0;
}
} else {
$all_passed
&= is ($slowrate, $fastrate,
"slow rate isn't less than fast rate, so should be the same");
# In OpenBSD the $slowfast is sometimes a really, really, really
# small number less than zero, and this gets stringified as -0.
$all_passed
&= like ($slowfast, qr/^-?0$/, "slowfast should be zero");
$all_passed
&= like ($fastslow, qr/^-?0$/, "fastslow should be zero");
}
return $all_passed;
}
sub check_graph_vs_output {
my ($chart, $got) = @_;
my ( $ratetext, $slowc, $fastc,
$slowr, $slowratet, $slowslow, $slowfastt,
$fastr, $fastratet, $fastslowt, $fastfast)
= $got =~ $graph_dissassembly;
my $all_passed
= check_graph_consistency ( $ratetext, $slowc, $fastc,
$slowr, $slowratet, $slowslow, $slowfastt,
$fastr, $fastratet, $fastslowt, $fastfast);
$all_passed
&= is_deeply ($chart, [['', $ratetext, $slowc, $fastc],
[$slowr, $slowratet, $slowslow, $slowfastt],
[$fastr, $fastratet, $fastslowt, $fastfast]],
"check the chart layout matches the formatted output");
unless ($all_passed) {
print STDERR "# Something went wrong there. I got this chart:\n";
print STDERR "# $_\n" foreach split /\n/, $got;
}
}
sub check_graph {
my ($title, $row1, $row2) = @_;
is (scalar @$title, 4, "Four entries in title row");
is (scalar @$row1, 4, "Four entries in first row");
is (scalar @$row2, 4, "Four entries in second row");
is (shift @$title, '', "First entry of output graph should be ''");
check_graph_consistency (@$title, @$row1, @$row2);
}
{
select(OUT);
my $start = times;
my $chart = cmpthese( -0.1, { a => "++\$i", b => "\$i = sqrt(\$i++)" }, "auto" ) ;
my $end = times;
select(STDOUT);
ok (($end - $start) > 0.05, "benchmarked code ran for over 0.05 seconds");
$got = $out->read();
# Remove any warnings about having too few iterations.
$got =~ s/\(warning:[^\)]+\)//gs;
like ($got, qr/running\W+a\W+b.*?for at least 0\.1 CPU second/s,
'check title');
# Remove the title
$got =~ s/.*\.\.\.//s;
like ($got, $Default_Pattern, 'should find default format somewhere');
like ($got, $graph_dissassembly, "Should find the output graph somewhere");
check_graph_vs_output ($chart, $got);
}
# Not giving auto should suppress timethese results.
{
select(OUT);
my $start = times;
my $chart = cmpthese( -0.1, { a => "++\$i", b => "\$i = sqrt(\$i++)" } ) ;
my $end = times;
select(STDOUT);
ok (($end - $start) > 0.05, "benchmarked code ran for over 0.05 seconds");
$got = $out->read();
# Remove any warnings about having too few iterations.
$got =~ s/\(warning:[^\)]+\)//gs;
unlike ($got, qr/running\W+a\W+b.*?for at least 0\.1 CPU second/s,
'should not have title');
# Remove the title
$got =~ s/.*\.\.\.//s;
unlike ($got, $Default_Pattern, 'should not find default format somewhere');
like ($got, $graph_dissassembly, "Should find the output graph somewhere");
check_graph_vs_output ($chart, $got);
}
{
$foo = $bar = 0;
select(OUT);
my $chart = cmpthese( 10, $code_to_test, 'nop' ) ;
select(STDOUT);
ok ($foo > 0, "Foo code was run");
ok ($bar > 0, "Bar code was run");
$got = $out->read();
# Remove any warnings about having too few iterations.
$got =~ s/\(warning:[^\)]+\)//gs;
like ($got, qr/timing 10 iterations of\s+Bar\W+Foo\W*?\.\.\./s,
'check title');
# Remove the title
$got =~ s/.*\.\.\.//s;
like ($got, $Nop_Pattern, 'specify format as nop');
like ($got, $graph_dissassembly, "Should find the output graph somewhere");
check_graph_vs_output ($chart, $got);
}
{
$foo = $bar = 0;
select(OUT);
my $chart = cmpthese( 10, $code_to_test, 'none' ) ;
select(STDOUT);
ok ($foo > 0, "Foo code was run");
ok ($bar > 0, "Bar code was run");
$got = $out->read();
# Remove any warnings about having too few iterations.
$got =~ s/\(warning:[^\)]+\)//gs;
$got =~ s/^[ \t\n]+//s; # Remove all the whitespace from the beginning
is ($got, '', "format 'none' should suppress output");
is (ref $chart, 'ARRAY', "output should be an array ref");
# Some of these will go bang if the preceding test fails. There will be
# a big clue as to why, from the previous test's diagnostic
is (ref $chart->[0], 'ARRAY', "output should be an array of arrays");
check_graph (@$chart);
}
{
$foo = $bar = 0;
select(OUT);
my $chart = cmpthese( $results ) ;
select(STDOUT);
is ($foo, 0, "Foo code was not run");
is ($bar, 0, "Bar code was not run");
$got = $out->read();
ok ($got !~ /\.\.\./s, 'check that there is no title');
like ($got, $graph_dissassembly, "Should find the output graph somewhere");
check_graph_vs_output ($chart, $got);
}
{
$foo = $bar = 0;
select(OUT);
my $chart = cmpthese( $results, 'none' ) ;
select(STDOUT);
is ($foo, 0, "Foo code was not run");
is ($bar, 0, "Bar code was not run");
$got = $out->read();
is ($got, '', "'none' should suppress all output");
is (ref $chart, 'ARRAY', "output should be an array ref");
# Some of these will go bang if the preceding test fails. There will be
# a big clue as to why, from the previous test's diagnostic
is (ref $chart->[0], 'ARRAY', "output should be an array of arrays");
check_graph (@$chart);
}
###}my $out = tie *OUT, 'TieOut'; my ($got); ###
my $debug = tie *STDERR, 'TieOut';
$bar = 0;
isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval");
is ($bar, 5, "benchmarked code was run 5 times");
is ($debug->read(), '', "There was no debug output");
Benchmark->debug(1);
$bar = 0;
select(OUT);
$got = timeit(5, '++$bar');
select(STDOUT);
isa_ok($got, 'Benchmark', "timeit eval");
is ($bar, 5, "benchmarked code was run 5 times");
is ($out->read(), '', "There was no STDOUT output with debug enabled");
isnt ($debug->read(), '', "There was STDERR debug output with debug enabled");
Benchmark->debug(0);
$bar = 0;
isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval");
is ($bar, 5, "benchmarked code was run 5 times");
is ($debug->read(), '', "There was no debug output debug disabled");
undef $debug;
untie *STDERR;
# To check the cache we are poking where we don't belong, inside the namespace.
# The way benchmark is written We can't actually check whehter the cache is
# being used, merely what's become cached.
clearallcache();
my @before_keys = keys %Benchmark::Cache;
$bar = 0;
isa_ok(timeit(5, '++$bar'), 'Benchmark', "timeit eval");
is ($bar, 5, "benchmarked code was run 5 times");
my @after5_keys = keys %Benchmark::Cache;
$bar = 0;
isa_ok(timeit(10, '++$bar'), 'Benchmark', "timeit eval");
is ($bar, 10, "benchmarked code was run 10 times");
ok (!eq_array ([keys %Benchmark::Cache], \@after5_keys), "10 differs from 5");
clearcache(10);
# Hash key order will be the same if there are the same keys.
is_deeply ([keys %Benchmark::Cache], \@after5_keys,
"cleared 10, only cached results for 5 should remain");
clearallcache();
is_deeply ([keys %Benchmark::Cache], \@before_keys,
"back to square 1 when we clear the cache again?");
{ # Check usage error messages
my %usage = %Benchmark::_Usage;
delete $usage{runloop}; # not public, not worrying about it just now
my @takes_no_args = qw(clearallcache disablecache enablecache);
my %cmpthese = ('forgot {}' => 'cmpthese( 42, foo => sub { 1 } )',
'not result' => 'cmpthese(42)',
'array ref' => 'cmpthese( 42, [ foo => sub { 1 } ] )',
);
while( my($name, $code) = each %cmpthese ) {
eval $code;
is( $@, $usage{cmpthese}, "cmpthese usage: $name" );
}
my %timethese = ('forgot {}' => 'timethese( 42, foo => sub { 1 } )',
'no code' => 'timethese(42)',
'array ref' => 'timethese( 42, [ foo => sub { 1 } ] )',
);
while( my($name, $code) = each %timethese ) {
eval $code;
is( $@, $usage{timethese}, "timethese usage: $name" );
}
while( my($func, $usage) = each %usage ) {
next if grep $func eq $_, @takes_no_args;
eval "$func()";
is( $@, $usage, "$func usage: no args" );
}
foreach my $func (@takes_no_args) {
eval "$func(42)";
is( $@, $usage{$func}, "$func usage: with args" );
}
}
package TieOut;
sub TIEHANDLE {
my $class = shift;
bless(\( my $ref = ''), $class);
}
sub PRINT {
my $self = shift;
$$self .= join('', @_);
}
sub PRINTF {
my $self = shift;
$$self .= sprintf shift, @_;
}
sub read {
my $self = shift;
return substr($$self, 0, length($$self), '');
}
--- NEW FILE: Memoize.pm ---
# -*- mode: perl; perl-indent-level: 2; -*-
# Memoize.pm
#
# Transparent memoization of idempotent functions
#
# Copyright 1998, 1999, 2000, 2001 M-J. Dominus.
# You may copy and distribute this program under the
# same terms as Perl itself. If in doubt,
# write to mjd-perl-memoize+ at plover.com for a license.
#
# Version 1.01 $Revision: 1.1 $ $Date: 2006-12-04 17:00:09 $
package Memoize;
$VERSION = '1.01';
# Compile-time constants
sub SCALAR () { 0 }
sub LIST () { 1 }
[...1008 lines suppressed...]
Joshua Gerth, Joshua Chamas, Jonathan Roy (again), Mark D. Anderson,
and Andrew Johnson for more suggestions about expiration, to Brent
Powers for the Memoize::ExpireLRU module, to Ariel Scolnicov for
delightful messages about the Fibonacci function, to Dion Almaer for
thought-provoking suggestions about the default normalizer, to Walt
Mankowski and Kurt Starsinic for much help investigating problems
under threaded Perl, to Alex Dudkevich for reporting the bug in
prototyped functions and for checking my patch, to Tony Bass for many
helpful suggestions, to Jonathan Roy (again) for finding a use for
C<unmemoize()>, to Philippe Verdret for enlightening discussion of
C<Hook::PrePostCall>, to Nat Torkington for advice I ignored, to Chris
Nandor for portability advice, to Randal Schwartz for suggesting the
'C<flush_cache> function, and to Jenda Krynicky for being a light in
the world.
Special thanks to Jarkko Hietaniemi, the 5.8.0 pumpking, for including
this module in the core and for his patient and helpful guidance
during the integration process.
=cut
--- NEW FILE: utf8_heavy.pl ---
package utf8;
use strict;
use warnings;
sub DEBUG () { 0 }
sub DESTROY {}
my %Cache;
our (%PropertyAlias, %PA_reverse, %PropValueAlias, %PVA_reverse, %PVA_abbr_map);
sub croak { require Carp; Carp::croak(@_) }
##
## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape.
## It's a data structure that encodes a set of Unicode characters.
##
sub SWASHNEW {
my ($class, $type, $list, $minbits, $none) = @_;
local $^D = 0 if $^D;
print STDERR "SWASHNEW @_\n" if DEBUG;
##
## Get the list of codepoints for the type.
## Called from utf8.c
##
## Given a $type, our goal is to fill $list with the set of codepoint
## ranges.
##
## To make the parsing of $type clear, this code takes the a rather
## unorthodox approach of last'ing out of the block once we have the
## info we need. Were this to be a subroutine, the 'last' would just
## be a 'return'.
##
my $file; ## file to load data from, and also part of the %Cache key.
my $ListSorted = 0;
if ($type)
{
$type =~ s/^\s+//;
$type =~ s/\s+$//;
print "type = $type\n" if DEBUG;
GETFILE:
{
##
## It could be a user-defined property.
##
my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
if (defined $caller1 && $type =~ /^(?:\w+)$/) {
my $prop = "${caller1}::$type";
if (exists &{$prop}) {
no strict 'refs';
$list = &{$prop};
last GETFILE;
}
}
my $wasIs;
($wasIs = $type =~ s/^Is(?:\s+|[-_])?//i)
or
$type =~ s/^(?:(?:General(?:\s+|_)?)?Category|gc)\s*[:=]\s*//i
or
$type =~ s/^(?:Script|sc)\s*[:=]\s*//i
or
$type =~ s/^Block\s*[:=]\s*/In/i;
##
## See if it's in some enumeration.
##
require "unicore/PVA.pl";
if ($type =~ /^([\w\s]+)[:=]\s*(.*)/) {
my ($enum, $val) = (lc $1, lc $2);
$enum =~ tr/ _-//d;
$val =~ tr/ _-//d;
my $pa = $PropertyAlias{$enum} ? $enum : $PA_reverse{$enum};
my $f = $PropValueAlias{$pa}{$val} ? $val : $PVA_reverse{$pa}{lc $val};
if ($pa and $f) {
$pa = "gc_sc" if $pa eq "gc" or $pa eq "sc";
$file = "unicore/lib/$pa/$PVA_abbr_map{$pa}{lc $f}.pl";
last GETFILE;
}
}
else {
my $t = lc $type;
$t =~ tr/ _-//d;
if ($PropValueAlias{gc}{$t} or $PropValueAlias{sc}{$t}) {
$file = "unicore/lib/gc_sc/$PVA_abbr_map{gc_sc}{$t}.pl";
last GETFILE;
}
}
##
## See if it's in the direct mapping table.
##
require "unicore/Exact.pl";
if (my $base = $utf8::Exact{$type}) {
$file = "unicore/lib/gc_sc/$base.pl";
last GETFILE;
}
##
## If not there exactly, try the canonical form. The canonical
## form is lowercased, with any separators (\s+|[-_]) removed.
##
my $canonical = lc $type;
$canonical =~ s/(?<=[a-z\d])(?:\s+|[-_])(?=[a-z\d])//g;
print "canonical = $canonical\n" if DEBUG;
require "unicore/Canonical.pl";
if (my $base = ($utf8::Canonical{$canonical} || $utf8::Canonical{ lc $utf8::PropertyAlias{$canonical} })) {
$file = "unicore/lib/gc_sc/$base.pl";
last GETFILE;
}
##
## See if it's a user-level "To".
##
my $caller0 = caller(0);
if (defined $caller0 && $type =~ /^To(?:\w+)$/) {
my $map = $caller0 . "::" . $type;
if (exists &{$map}) {
no strict 'refs';
$list = &{$map};
last GETFILE;
}
}
##
## Last attempt -- see if it's a standard "To" name
## (e.g. "ToLower") ToTitle is used by ucfirst().
## The user-level way to access ToDigit() and ToFold()
## is to use Unicode::UCD.
##
if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/)
{
$file = "unicore/To/$1.pl";
## would like to test to see if $file actually exists....
last GETFILE;
}
##
## If we reach this line, it's because we couldn't figure
## out what to do with $type. Ouch.
##
return $type;
}
if (defined $file) {
print "found it (file='$file')\n" if DEBUG;
##
## If we reach here, it was due to a 'last GETFILE' above
## (exception: user-defined properties and mappings), so we
## have a filename, so now we load it if we haven't already.
## If we have, return the cached results. The cache key is the
## file to load.
##
if ($Cache{$file} and ref($Cache{$file}) eq $class)
{
print "Returning cached '$file' for \\p{$type}\n" if DEBUG;
return $Cache{$class, $file};
}
$list = do $file;
}
$ListSorted = 1; ## we know that these lists are sorted
}
my $extras;
my $bits = 0;
my $ORIG = $list;
if ($list) {
my @tmp = split(/^/m, $list);
my %seen;
no warnings;
$extras = join '', grep /^[^0-9a-fA-F]/, @tmp;
$list = join '',
map { $_->[1] }
sort { $a->[0] <=> $b->[0] }
map { /^([0-9a-fA-F]+)/; [ hex($1), $_ ] }
grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right
}
if ($none) {
my $hextra = sprintf "%04x", $none + 1;
$list =~ s/\tXXXX$/\t$hextra/mg;
}
if ($minbits < 32) {
my $top = 0;
while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) {
my $min = hex $1;
my $max = defined $2 ? hex $2 : $min;
my $val = defined $3 ? hex $3 : 0;
$val += $max - $min if defined $3;
$top = $val if $val > $top;
}
$bits =
$top > 0xffff ? 32 :
$top > 0xff ? 16 :
$top > 1 ? 8 : 1
}
$bits = $minbits if $bits < $minbits;
my @extras;
for my $x ($extras) {
pos $x = 0;
while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
my $char = $1;
my $name = $2;
print STDERR "$1 => $2\n" if DEBUG;
if ($char =~ /[-+!&]/) {
my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really
my $subobj;
if ($c eq 'utf8') {
$subobj = utf8->SWASHNEW($t, "", 0, 0, 0);
}
elsif (exists &$name) {
$subobj = utf8->SWASHNEW($name, "", 0, 0, 0);
}
elsif ($c =~ /^([0-9a-fA-F]+)/) {
$subobj = utf8->SWASHNEW("", $c, 0, 0, 0);
}
return $subobj unless ref $subobj;
push @extras, $name => $subobj;
$bits = $subobj->{BITS} if $bits < $subobj->{BITS};
}
}
}
print STDERR "CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none\nEXTRAS =>\n$extras\nLIST =>\n$list\n" if DEBUG;
my $SWASH = bless {
TYPE => $type,
BITS => $bits,
EXTRAS => $extras,
LIST => $list,
NONE => $none,
@extras,
} => $class;
if ($file) {
$Cache{$class, $file} = $SWASH;
}
return $SWASH;
}
# NOTE: utf8.c:swash_init() assumes entries are never modified once generated.
sub SWASHGET {
# See utf8.c:Perl_swash_fetch for problems with this interface.
my ($self, $start, $len) = @_;
local $^D = 0 if $^D;
my $type = $self->{TYPE};
my $bits = $self->{BITS};
my $none = $self->{NONE};
print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if DEBUG;
my $end = $start + $len;
my $swatch = "";
my $key;
vec($swatch, $len - 1, $bits) = 0; # Extend to correct length.
if ($none) {
for $key (0 .. $len - 1) { vec($swatch, $key, $bits) = $none }
}
for ($self->{LIST}) {
pos $_ = 0;
if ($bits > 1) {
LINE:
while (/^([0-9a-fA-F]+)(?:[ \t]([0-9a-fA-F]+)?)?(?:[ \t]([0-9a-fA-F]+))?/mg) {
chomp;
my ($a, $b, $c) = ($1, $2, $3);
croak "$type: illegal mapping '$_'"
if $type =~ /^To/ &&
!(defined $a && defined $c);
my $min = hex $a;
my $max = defined $b ? hex $b : $min;
my $val = defined $c ? hex $c : 0;
next if $max < $start;
print "$min $max $val\n" if DEBUG;
if ($none) {
if ($min < $start) {
$val += $start - $min if $val < $none;
$min = $start;
}
for ($key = $min; $key <= $max; $key++) {
last LINE if $key >= $end;
print STDERR "$key => $val\n" if DEBUG;
vec($swatch, $key - $start, $bits) = $val;
++$val if $val < $none;
}
}
else {
if ($min < $start) {
$val += $start - $min;
$min = $start;
}
for ($key = $min; $key <= $max; $key++, $val++) {
last LINE if $key >= $end;
print STDERR "$key => $val\n" if DEBUG;
vec($swatch, $key - $start, $bits) = $val;
}
}
}
}
else {
LINE:
while (/^([0-9a-fA-F]+)(?:[ \t]+([0-9a-fA-F]+))?/mg) {
chomp;
my $min = hex $1;
my $max = defined $2 ? hex $2 : $min;
next if $max < $start;
if ($min < $start) {
$min = $start;
}
for ($key = $min; $key <= $max; $key++) {
last LINE if $key >= $end;
print STDERR "$key => 1\n" if DEBUG;
vec($swatch, $key - $start, 1) = 1;
}
}
}
}
for my $x ($self->{EXTRAS}) {
pos $x = 0;
while ($x =~ /^([-+!&])(.*)/mg) {
my $char = $1;
my $name = $2;
print STDERR "INDIRECT $1 $2\n" if DEBUG;
my $otherbits = $self->{$name}->{BITS};
croak("SWASHGET size mismatch") if $bits < $otherbits;
my $other = $self->{$name}->SWASHGET($start, $len);
if ($char eq '+') {
if ($bits == 1 and $otherbits == 1) {
$swatch |= $other;
}
else {
for ($key = 0; $key < $len; $key++) {
vec($swatch, $key, $bits) = vec($other, $key, $otherbits);
}
}
}
elsif ($char eq '!') {
if ($bits == 1 and $otherbits == 1) {
$swatch |= ~$other;
}
else {
for ($key = 0; $key < $len; $key++) {
if (!vec($other, $key, $otherbits)) {
vec($swatch, $key, $bits) = 1;
}
}
}
}
elsif ($char eq '-') {
if ($bits == 1 and $otherbits == 1) {
$swatch &= ~$other;
}
else {
for ($key = 0; $key < $len; $key++) {
if (vec($other, $key, $otherbits)) {
vec($swatch, $key, $bits) = 0;
}
}
}
}
elsif ($char eq '&') {
if ($bits == 1 and $otherbits == 1) {
$swatch &= $other;
}
else {
for ($key = 0; $key < $len; $key++) {
if (!vec($other, $key, $otherbits)) {
vec($swatch, $key, $bits) = 0;
}
}
}
}
}
}
if (DEBUG) {
print STDERR "CELLS ";
for ($key = 0; $key < $len; $key++) {
print STDERR vec($swatch, $key, $bits), " ";
}
print STDERR "\n";
}
$swatch;
}
1;
--- NEW FILE: AutoSplit.pm ---
package AutoSplit;
use 5.006_001;
use Exporter ();
use Config qw(%Config);
use Carp qw(carp);
use File::Basename ();
use File::Path qw(mkpath);
use File::Spec::Functions qw(curdir catfile catdir);
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
$CheckForAutoloader, $CheckModTime);
$VERSION = "1.04";
@ISA = qw(Exporter);
@EXPORT = qw(&autosplit &autosplit_lib_modules);
@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
=head1 NAME
AutoSplit - split a package for autoloading
=head1 SYNOPSIS
autosplit($file, $dir, $keep, $check, $modtime);
autosplit_lib_modules(@modules);
=head1 DESCRIPTION
This function will split up your program into files that the AutoLoader
module can handle. It is used by both the standard perl libraries and by
the MakeMaker utility, to automatically configure libraries for autoloading.
The C<autosplit> interface splits the specified file into a hierarchy
rooted at the directory C<$dir>. It creates directories as needed to reflect
class hierarchy, and creates the file F<autosplit.ix>. This file acts as
both forward declaration of all package routines, and as timestamp for the
last update of the hierarchy.
The remaining three arguments to C<autosplit> govern other options to
the autosplitter.
=over 2
=item $keep
If the third argument, I<$keep>, is false, then any
pre-existing C<*.al> files in the autoload directory are removed if
they are no longer part of the module (obsoleted functions).
$keep defaults to 0.
=item $check
The
fourth argument, I<$check>, instructs C<autosplit> to check the module
currently being split to ensure that it includes a C<use>
specification for the AutoLoader module, and skips the module if
AutoLoader is not detected.
$check defaults to 1.
=item $modtime
Lastly, the I<$modtime> argument specifies
that C<autosplit> is to check the modification time of the module
against that of the C<autosplit.ix> file, and only split the module if
it is newer.
$modtime defaults to 1.
=back
Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
with:
perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
Defined as a Make macro, it is invoked with file and directory arguments;
C<autosplit> will split the specified file into the specified directory and
delete obsolete C<.al> files, after checking first that the module does use
the AutoLoader, and ensuring that the module is not already currently split
in its current form (the modtime test).
The C<autosplit_lib_modules> form is used in the building of perl. It takes
as input a list of files (modules) that are assumed to reside in a directory
B<lib> relative to the current directory. Each file is sent to the
autosplitter one at a time, to be split into the directory B<lib/auto>.
In both usages of the autosplitter, only subroutines defined following the
perl I<__END__> token are split out into separate files. Some
routines may be placed prior to this marker to force their immediate loading
and parsing.
=head2 Multiple packages
As of version 1.01 of the AutoSplit module it is possible to have
multiple packages within a single file. Both of the following cases
are supported:
package NAME;
__END__
sub AAA { ... }
package NAME::option1;
sub BBB { ... }
package NAME::option2;
sub BBB { ... }
package NAME;
__END__
sub AAA { ... }
sub NAME::option1::BBB { ... }
sub NAME::option2::BBB { ... }
=head1 DIAGNOSTICS
C<AutoSplit> will inform the user if it is necessary to create the
top-level directory specified in the invocation. It is preferred that
the script or installation process that invokes C<AutoSplit> have
created the full directory path ahead of time. This warning may
indicate that the module is being split into an incorrect path.
C<AutoSplit> will warn the user of all subroutines whose name causes
potential file naming conflicts on machines with drastically limited
(8 characters or less) file name length. Since the subroutine name is
used as the file name, these warnings can aid in portability to such
systems.
Warnings are issued and the file skipped if C<AutoSplit> cannot locate
either the I<__END__> marker or a "package Name;"-style specification.
C<AutoSplit> will also emit general diagnostics for inability to
create directories or files.
=cut
# for portability warn about names longer than $maxlen
$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3
$Verbose = 1; # 0=none, 1=minimal, 2=list .al files
$Keep = 0;
$CheckForAutoloader = 1;
$CheckModTime = 1;
my $IndexFile = "autosplit.ix"; # file also serves as timestamp
my $maxflen = 255;
$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
if (defined (&Dos::UseLFN)) {
$maxflen = Dos::UseLFN() ? 255 : 11;
}
my $Is_VMS = ($^O eq 'VMS');
# allow checking for valid ': attrlist' attachments
# (we use 'our' rather than 'my' here, due to the rather complex and buggy
# behaviour of lexicals with qr// and (??{$lex}) )
our $nested;
$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x;
our $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
our $attr_list = qr{ \s* : \s* (?: $one_attr )* }x;
sub autosplit{
my($file, $autodir, $keep, $ckal, $ckmt) = @_;
# $file - the perl source file to be split (after __END__)
# $autodir - the ".../auto" dir below which to write split subs
# Handle optional flags:
$keep = $Keep unless defined $keep;
$ckal = $CheckForAutoloader unless defined $ckal;
$ckmt = $CheckModTime unless defined $ckmt;
autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
}
# This function is used during perl building/installation
# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
sub autosplit_lib_modules{
my(@modules) = @_; # list of Module names
while(defined($_ = shift @modules)){
while (m#(.*?[^:])::([^:].*)#) { # in case specified as ABC::XYZ
$_ = catfile($1, $2);
}
s|\\|/|g; # bug in ksh OS/2
s#^lib/##s; # incase specified as lib/*.pm
my($lib) = catfile(curdir(), "lib");
if ($Is_VMS) { # may need to convert VMS-style filespecs
$lib =~ s#^\[\]#.\/#;
}
s#^$lib\W+##s; # incase specified as ./lib/*.pm
if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
my ($dir,$name) = (/(.*])(.*)/s);
$dir =~ s/.*lib[\.\]]//s;
$dir =~ s#[\.\]]#/#g;
$_ = $dir . $name;
}
autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
$Keep, $CheckForAutoloader, $CheckModTime);
}
0;
}
# private functions
my $self_mod_time = (stat __FILE__)[9];
sub autosplit_file {
my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
= @_;
my(@outfiles);
local($_);
local($/) = "\n";
# where to write output files
$autodir ||= catfile(curdir(), "lib", "auto");
if ($Is_VMS) {
($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
$filename = VMS::Filespec::unixify($filename); # may have dirs
}
unless (-d $autodir){
mkpath($autodir,0,0755);
# We should never need to create the auto dir
# here. installperl (or similar) should have done
# it. Expecting it to exist is a valuable sanity check against
# autosplitting into some random directory by mistake.
print "Warning: AutoSplit had to create top-level " .
"$autodir unexpectedly.\n";
}
# allow just a package name to be used
$filename .= ".pm" unless ($filename =~ m/\.pm\z/);
open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
my($pm_mod_time) = (stat($filename))[9];
my($autoloader_seen) = 0;
my($in_pod) = 0;
my($def_package,$last_package,$this_package,$fnr);
while (<$in>) {
# Skip pod text.
$fnr++;
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/);
next if /^\s*#/;
# record last package name seen
$def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
last if /^__END__/;
}
if ($check_for_autoloader && !$autoloader_seen){
print "AutoSplit skipped $filename: no AutoLoader used\n"
if ($Verbose>=2);
return 0;
}
$_ or die "Can't find __END__ in $filename\n";
$def_package or die "Can't find 'package Name;' in $filename\n";
my($modpname) = _modpname($def_package);
# this _has_ to match so we have a reasonable timestamp file
die "Package $def_package ($modpname.pm) does not ".
"match filename $filename"
unless ($filename =~ m/\Q$modpname.pm\E$/ or
($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
$Is_VMS && $filename =~ m/$modpname.pm/i);
my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
if ($check_mod_time){
my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
if ($al_ts_time >= $pm_mod_time and
$al_ts_time >= $self_mod_time){
print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
if ($Verbose >= 2);
return undef; # one undef, not a list
}
}
my($modnamedir) = catdir($autodir, $modpname);
print "AutoSplitting $filename ($modnamedir)\n"
if $Verbose;
unless (-d $modnamedir){
mkpath($modnamedir,0,0777);
}
# We must try to deal with some SVR3 systems with a limit of 14
# characters for file names. Sadly we *cannot* simply truncate all
# file names to 14 characters on these systems because we *must*
# create filenames which exactly match the names used by AutoLoader.pm.
# This is a problem because some systems silently truncate the file
# names while others treat long file names as an error.
my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames
my(@subnames, $subname, %proto, %package);
my @cache = ();
my $caching = 1;
$last_package = '';
my $out;
while (<$in>) {
$fnr++;
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/);
# the following (tempting) old coding gives big troubles if a
# cut is forgotten at EOF:
# next if /^=\w/ .. /^=cut/;
if (/^package\s+([\w:]+)\s*;/) {
$this_package = $def_package = $1;
}
if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
print $out "# end of $last_package\::$subname\n1;\n"
if $last_package;
$subname = $1;
my $proto = $2 || '';
if ($subname =~ s/(.*):://){
$this_package = $1;
} else {
$this_package = $def_package;
}
my $fq_subname = "$this_package\::$subname";
$package{$fq_subname} = $this_package;
$proto{$fq_subname} = $proto;
push(@subnames, $fq_subname);
my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
$modpname = _modpname($this_package);
my($modnamedir) = catdir($autodir, $modpname);
mkpath($modnamedir,0,0777);
my($lpath) = catfile($modnamedir, "$lname.al");
my($spath) = catfile($modnamedir, "$sname.al");
my $path;
if (!$Is83 and open($out, ">$lpath")){
$path=$lpath;
print " writing $lpath\n" if ($Verbose>=2);
} else {
open($out, ">$spath") or die "Can't create $spath: $!\n";
$path=$spath;
print " writing $spath (with truncated name)\n"
if ($Verbose>=1);
}
push(@outfiles, $path);
my $lineno = $fnr - @cache;
print $out <<EOT;
# NOTE: Derived from $filename.
# Changes made here will be lost when autosplit is run again.
# See AutoSplit.pm.
package $this_package;
#line $lineno "$filename (autosplit into $path)"
EOT
print $out @cache;
@cache = ();
$caching = 0;
}
if($caching) {
push(@cache, $_) if @cache || /\S/;
} else {
print $out $_;
}
if(/^\}/) {
if($caching) {
print $out @cache;
@cache = ();
}
print $out "\n";
$caching = 1;
}
$last_package = $this_package if defined $this_package;
}
if ($subname) {
print $out @cache,"1;\n# end of $last_package\::$subname\n";
close($out);
}
close($in);
if (!$keep){ # don't keep any obsolete *.al files in the directory
my(%outfiles);
# @outfiles{@outfiles} = @outfiles;
# perl downcases all filenames on VMS (which upcases all filenames) so
# we'd better downcase the sub name list too, or subs with upper case
# letters in them will get their .al files deleted right after they're
# created. (The mixed case sub name won't match the all-lowercase
# filename, and so be cleaned up as a scrap file)
if ($Is_VMS or $Is83) {
%outfiles = map {lc($_) => lc($_) } @outfiles;
} else {
@outfiles{@outfiles} = @outfiles;
}
my(%outdirs, at outdirs);
for (@outfiles) {
$outdirs{File::Basename::dirname($_)}||=1;
}
for my $dir (keys %outdirs) {
opendir(my $outdir,$dir);
foreach (sort readdir($outdir)){
next unless /\.al\z/;
my($file) = catfile($dir, $_);
$file = lc $file if $Is83 or $Is_VMS;
next if $outfiles{$file};
print " deleting $file\n" if ($Verbose>=2);
my($deleted,$thistime); # catch all versions on VMS
do { $deleted += ($thistime = unlink $file) } while ($thistime);
carp "Unable to delete $file: $!" unless $deleted;
}
closedir($outdir);
}
}
open(my $ts,">$al_idx_file") or
carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!";
print $ts "# Index created by AutoSplit for $filename\n";
print $ts "# (file acts as timestamp)\n";
$last_package = '';
for my $fqs (@subnames) {
my($subname) = $fqs;
$subname =~ s/.*:://;
print $ts "package $package{$fqs};\n"
unless $last_package eq $package{$fqs};
print $ts "sub $subname $proto{$fqs};\n";
$last_package = $package{$fqs};
}
print $ts "1;\n";
close($ts);
_check_unique($filename, $Maxlen, 1, @outfiles);
@outfiles;
}
sub _modpname ($) {
my($package) = @_;
my $modpname = $package;
if ($^O eq 'MSWin32') {
$modpname =~ s#::#\\#g;
} else {
my @modpnames = ();
while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
push @modpnames, $1;
$modpname = $2;
}
$modpname = catfile(@modpnames, $modpname);
}
if ($Is_VMS) {
$modpname = VMS::Filespec::unixify($modpname); # may have dirs
}
$modpname;
}
sub _check_unique {
my($filename, $maxlen, $warn, @outfiles) = @_;
my(%notuniq) = ();
my(%shorts) = ();
my(@toolong) = grep(
length(File::Basename::basename($_))
> $maxlen,
@outfiles
);
foreach (@toolong){
my($dir) = File::Basename::dirname($_);
my($file) = File::Basename::basename($_);
my($trunc) = substr($file,0,$maxlen);
$notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
$shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
"$shorts{$dir}{$trunc}, $file" : $file;
}
if (%notuniq && $warn){
print "$filename: some names are not unique when " .
"truncated to $maxlen characters:\n";
foreach my $dir (sort keys %notuniq){
print " directory $dir:\n";
foreach my $trunc (sort keys %{$notuniq{$dir}}) {
print " $shorts{$dir}{$trunc} truncate to $trunc\n";
}
}
}
}
1;
__END__
# test functions so AutoSplit.pm can be applied to itself:
sub test1 ($) { "test 1\n"; }
sub test2 ($$) { "test 2\n"; }
sub test3 ($$$) { "test 3\n"; }
sub testtesttesttest4_1 { "test 4\n"; }
sub testtesttesttest4_2 { "duplicate test 4\n"; }
sub Just::Another::test5 { "another test 5\n"; }
sub test6 { return join ":", __FILE__,__LINE__; }
package Yet::Another::AutoSplit;
sub testtesttesttest4_1 ($) { "another test 4\n"; }
sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
package Yet::More::Attributes;
sub test_a1 ($) : locked :locked { 1; }
sub test_a2 : locked { 1; }
--- NEW FILE: charnames.pm ---
package charnames;
use strict;
use warnings;
use Carp;
use File::Spec;
our $VERSION = '1.05';
use bytes (); # for $bytes::hint_bits
$charnames::hint_bits = 0x20000; # HINT_LOCALIZE_HH
my %alias1 = (
# Icky 3.2 names with parentheses.
'LINE FEED' => 'LINE FEED (LF)',
'FORM FEED' => 'FORM FEED (FF)',
'CARRIAGE RETURN' => 'CARRIAGE RETURN (CR)',
'NEXT LINE' => 'NEXT LINE (NEL)',
# Convenience.
'LF' => 'LINE FEED (LF)',
'FF' => 'FORM FEED (FF)',
'CR' => 'CARRIAGE RETURN (CR)',
'NEL' => 'NEXT LINE (NEL)',
# More convenience. For futher convencience,
# it is suggested some way using using the NamesList
# aliases is implemented.
'ZWNJ' => 'ZERO WIDTH NON-JOINER',
'ZWJ' => 'ZERO WIDTH JOINER',
'BOM' => 'BYTE ORDER MARK',
);
my %alias2 = (
# Pre-3.2 compatibility (only for the first 256 characters).
'HORIZONTAL TABULATION' => 'CHARACTER TABULATION',
'VERTICAL TABULATION' => 'LINE TABULATION',
'FILE SEPARATOR' => 'INFORMATION SEPARATOR FOUR',
'GROUP SEPARATOR' => 'INFORMATION SEPARATOR THREE',
'RECORD SEPARATOR' => 'INFORMATION SEPARATOR TWO',
'UNIT SEPARATOR' => 'INFORMATION SEPARATOR ONE',
'PARTIAL LINE DOWN' => 'PARTIAL LINE FORWARD',
'PARTIAL LINE UP' => 'PARTIAL LINE BACKWARD',
);
my %alias3 = (
# User defined aliasses. Even more convenient :)
);
my $txt;
sub alias (@)
{
@_ or return %alias3;
my $alias = ref $_[0] ? $_[0] : { @_ };
@alias3{keys %$alias} = values %$alias;
} # alias
sub alias_file ($)
{
my ($arg, $file) = @_;
if (-f $arg && File::Spec->file_name_is_absolute ($arg)) {
$file = $arg;
}
elsif ($arg =~ m/^\w+$/) {
$file = "unicore/${arg}_alias.pl";
}
else {
croak "Charnames alias files can only have identifier characters";
}
if (my @alias = do $file) {
@alias == 1 && !defined $alias[0] and
croak "$file cannot be used as alias file for charnames";
@alias % 2 and
croak "$file did not return a (valid) list of alias pairs";
alias (@alias);
return (1);
}
0;
} # alias_file
# This is not optimized in any way yet
sub charnames
{
my $name = shift;
if (exists $alias1{$name}) {
$name = $alias1{$name};
}
elsif (exists $alias2{$name}) {
require warnings;
warnings::warnif('deprecated', qq{Unicode character name "$name" is deprecated, use "$alias2{$name}" instead});
$name = $alias2{$name};
}
elsif (exists $alias3{$name}) {
$name = $alias3{$name};
}
my $ord;
my @off;
my $fname;
if ($name eq "BYTE ORDER MARK") {
$fname = $name;
$ord = 0xFEFF;
} else {
## Suck in the code/name list as a big string.
## Lines look like:
## "0052\t\tLATIN CAPITAL LETTER R\n"
$txt = do "unicore/Name.pl" unless $txt;
## @off will hold the index into the code/name string of the start and
## end of the name as we find it.
## If :full, look for the name exactly
if ($^H{charnames_full} and $txt =~ /\t\t\Q$name\E$/m) {
@off = ($-[0], $+[0]);
}
## If we didn't get above, and :short allowed, look for the short name.
## The short name is like "greek:Sigma"
unless (@off) {
if ($^H{charnames_short} and $name =~ /^(.+?):(.+)/s) {
my ($script, $cname) = ($1, $2);
my $case = $cname =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
if ($txt =~ m/\t\t\U$script\E (?:$case )?LETTER \U\Q$cname\E$/m) {
@off = ($-[0], $+[0]);
}
}
}
## If we still don't have it, check for the name among the loaded
## scripts.
if (not @off) {
my $case = $name =~ /[[:upper:]]/ ? "CAPITAL" : "SMALL";
for my $script (@{$^H{charnames_scripts}}) {
if ($txt =~ m/\t\t$script (?:$case )?LETTER \U\Q$name\E$/m) {
@off = ($-[0], $+[0]);
last;
}
}
}
## If we don't have it by now, give up.
unless (@off) {
carp "Unknown charname '$name'";
return "\x{FFFD}";
}
##
## Now know where in the string the name starts.
## The code, in hex, is before that.
##
## The code can be 4-6 characters long, so we've got to sort of
## go look for it, just after the newline that comes before $off[0].
##
## This would be much easier if unicore/Name.pl had info in
## a name/code order, instead of code/name order.
##
## The +1 after the rindex() is to skip past the newline we're finding,
## or, if the rindex() fails, to put us to an offset of zero.
##
my $hexstart = rindex($txt, "\n", $off[0]) + 1;
## we know where it starts, so turn into number -
## the ordinal for the char.
$ord = hex substr($txt, $hexstart, $off[0] - $hexstart);
}
if ($^H & $bytes::hint_bits) { # "use bytes" in effect?
use bytes;
return chr $ord if $ord <= 255;
my $hex = sprintf "%04x", $ord;
if (not defined $fname) {
$fname = substr $txt, $off[0] + 2, $off[1] - $off[0] - 2;
}
croak "Character 0x$hex with name '$fname' is above 0xFF";
}
no warnings 'utf8'; # allow even illegal characters
return pack "U", $ord;
} # charnames
sub import
{
shift; ## ignore class name
if (not @_) {
carp("`use charnames' needs explicit imports list");
}
$^H |= $charnames::hint_bits;
$^H{charnames} = \&charnames ;
##
## fill %h keys with our @_ args.
##
my ($promote, %h, @args) = (0);
while (my $arg = shift) {
if ($arg eq ":alias") {
@_ or
croak ":alias needs an argument in charnames";
my $alias = shift;
if (ref $alias) {
ref $alias eq "HASH" or
croak "Only HASH reference supported as argument to :alias";
alias ($alias);
next;
}
if ($alias =~ m{:(\w+)$}) {
$1 eq "full" || $1 eq "short" and
croak ":alias cannot use existing pragma :$1 (reversed order?)";
alias_file ($1) and $promote = 1;
next;
}
alias_file ($alias);
next;
}
if (substr($arg, 0, 1) eq ':' and ! ($arg eq ":full" || $arg eq ":short")) {
warn "unsupported special '$arg' in charnames";
next;
}
push @args, $arg;
}
@args == 0 && $promote and @args = (":full");
@h{@args} = (1) x @args;
$^H{charnames_full} = delete $h{':full'};
$^H{charnames_short} = delete $h{':short'};
$^H{charnames_scripts} = [map uc, keys %h];
##
## If utf8? warnings are enabled, and some scripts were given,
## see if at least we can find one letter of each script.
##
if (warnings::enabled('utf8') && @{$^H{charnames_scripts}}) {
$txt = do "unicore/Name.pl" unless $txt;
for my $script (@{$^H{charnames_scripts}}) {
if (not $txt =~ m/\t\t$script (?:CAPITAL |SMALL )?LETTER /) {
warnings::warn('utf8', "No such script: '$script'");
}
}
}
} # import
my %viacode;
sub viacode
{
if (@_ != 1) {
carp "charnames::viacode() expects one argument";
return;
}
my $arg = shift;
# this comes actually from Unicode::UCD, where it is the named
# function _getcode (), but it avoids the overhead of loading it
my $hex;
if ($arg =~ /^[1-9]\d*$/) {
$hex = sprintf "%04X", $arg;
} elsif ($arg =~ /^(?:[Uu]\+|0[xX])?([[:xdigit:]]+)$/) {
$hex = $1;
} else {
carp("unexpected arg \"$arg\" to charnames::viacode()");
return;
}
# checking the length first is slightly faster
if (length($hex) > 5 && hex($hex) > 0x10FFFF) {
carp sprintf "Unicode characters only allocated up to U+10FFFF (you asked for U+%X)", $hex;
return;
}
return $viacode{$hex} if exists $viacode{$hex};
$txt = do "unicore/Name.pl" unless $txt;
return unless $txt =~ m/^$hex\t\t(.+)/m;
$viacode{$hex} = $1;
} # viacode
my %vianame;
sub vianame
{
if (@_ != 1) {
carp "charnames::vianame() expects one name argument";
return ()
}
my $arg = shift;
return chr hex $1 if $arg =~ /^U\+([0-9a-fA-F]+)$/;
return $vianame{$arg} if exists $vianame{$arg};
$txt = do "unicore/Name.pl" unless $txt;
my $pos = index $txt, "\t\t$arg\n";
if ($[ <= $pos) {
my $posLF = rindex $txt, "\n", $pos;
(my $code = substr $txt, $posLF + 1, 6) =~ tr/\t//d;
return $vianame{$arg} = hex $code;
# If $pos is at the 1st line, $posLF must be $[ - 1 (not found);
# then $posLF + 1 equals to $[ (at the beginning of $txt).
# Otherwise $posLF is the position of "\n";
# then $posLF + 1 must be the position of the next to "\n"
# (the beginning of the line).
# substr($txt, $posLF + 1, 6) may be "0000\t\t", "00A1\t\t",
# "10300\t", "100000", etc. So we can get the code via removing TAB.
} else {
return;
}
} # vianame
1;
__END__
=head1 NAME
charnames - define character names for C<\N{named}> string literal escapes
=head1 SYNOPSIS
use charnames ':full';
print "\N{GREEK SMALL LETTER SIGMA} is called sigma.\n";
use charnames ':short';
print "\N{greek:Sigma} is an upper-case sigma.\n";
use charnames qw(cyrillic greek);
print "\N{sigma} is Greek sigma, and \N{be} is Cyrillic b.\n";
use charnames ":full", ":alias" => {
e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
};
print "\N{e_ACUTE} is a small letter e with an acute.\n";
use charnames ();
print charnames::viacode(0x1234); # prints "ETHIOPIC SYLLABLE SEE"
printf "%04X", charnames::vianame("GOTHIC LETTER AHSA"); # prints "10330"
=head1 DESCRIPTION
Pragma C<use charnames> supports arguments C<:full>, C<:short>, script
names and customized aliases. If C<:full> is present, for expansion of
C<\N{CHARNAME}>, the string C<CHARNAME> is first looked up in the list of
standard Unicode character names. If C<:short> is present, and
C<CHARNAME> has the form C<SCRIPT:CNAME>, then C<CNAME> is looked up
as a letter in script C<SCRIPT>. If pragma C<use charnames> is used
with script name arguments, then for C<\N{CHARNAME}> the name
C<CHARNAME> is looked up as a letter in the given scripts (in the
specified order). Customized aliases are explained in L</CUSTOM ALIASES>.
For lookup of C<CHARNAME> inside a given script C<SCRIPTNAME>
this pragma looks for the names
SCRIPTNAME CAPITAL LETTER CHARNAME
SCRIPTNAME SMALL LETTER CHARNAME
SCRIPTNAME LETTER CHARNAME
in the table of standard Unicode names. If C<CHARNAME> is lowercase,
then the C<CAPITAL> variant is ignored, otherwise the C<SMALL> variant
is ignored.
Note that C<\N{...}> is compile-time, it's a special form of string
constant used inside double-quoted strings: in other words, you cannot
use variables inside the C<\N{...}>. If you want similar run-time
functionality, use charnames::vianame().
For the C0 and C1 control characters (U+0000..U+001F, U+0080..U+009F)
as of Unicode 3.1, there are no official Unicode names but you can use
instead the ISO 6429 names (LINE FEED, ESCAPE, and so forth). In
Unicode 3.2 (as of Perl 5.8) some naming changes take place ISO 6429
has been updated, see L</ALIASES>. Also note that the U+UU80, U+0081,
U+0084, and U+0099 do not have names even in ISO 6429.
Since the Unicode standard uses "U+HHHH", so can you: "\N{U+263a}"
is the Unicode smiley face, or "\N{WHITE SMILING FACE}".
=head1 CUSTOM TRANSLATORS
The mechanism of translation of C<\N{...}> escapes is general and not
hardwired into F<charnames.pm>. A module can install custom
translations (inside the scope which C<use>s the module) with the
following magic incantation:
use charnames (); # for $charnames::hint_bits
sub import {
shift;
$^H |= $charnames::hint_bits;
$^H{charnames} = \&translator;
}
Here translator() is a subroutine which takes C<CHARNAME> as an
argument, and returns text to insert into the string instead of the
C<\N{CHARNAME}> escape. Since the text to insert should be different
in C<bytes> mode and out of it, the function should check the current
state of C<bytes>-flag as in:
use bytes (); # for $bytes::hint_bits
sub translator {
if ($^H & $bytes::hint_bits) {
return bytes_translator(@_);
}
else {
return utf8_translator(@_);
}
}
=head1 CUSTOM ALIASES
This version of charnames supports three mechanisms of adding local
or customized aliases to standard Unicode naming conventions (:full)
=head2 Anonymous hashes
use charnames ":full", ":alias" => {
e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
};
my $str = "\N{e_ACUTE}";
=head2 Alias file
use charnames ":full", ":alias" => "pro";
will try to read "unicore/pro_alias.pl" from the @INC path. This
file should return a list in plain perl:
(
A_GRAVE => "LATIN CAPITAL LETTER A WITH GRAVE",
A_CIRCUM => "LATIN CAPITAL LETTER A WITH CIRCUMFLEX",
A_DIAERES => "LATIN CAPITAL LETTER A WITH DIAERESIS",
A_TILDE => "LATIN CAPITAL LETTER A WITH TILDE",
A_BREVE => "LATIN CAPITAL LETTER A WITH BREVE",
A_RING => "LATIN CAPITAL LETTER A WITH RING ABOVE",
A_MACRON => "LATIN CAPITAL LETTER A WITH MACRON",
);
=head2 Alias shortcut
use charnames ":alias" => ":pro";
works exactly the same as the alias pairs, only this time,
":full" is inserted automatically as first argument (if no
other argument is given).
=head1 charnames::viacode(code)
Returns the full name of the character indicated by the numeric code.
The example
print charnames::viacode(0x2722);
prints "FOUR TEARDROP-SPOKED ASTERISK".
Returns undef if no name is known for the code.
This works only for the standard names, and does not yet apply
to custom translators.
Notice that the name returned for of U+FEFF is "ZERO WIDTH NO-BREAK
SPACE", not "BYTE ORDER MARK".
=head1 charnames::vianame(name)
Returns the code point indicated by the name.
The example
printf "%04X", charnames::vianame("FOUR TEARDROP-SPOKED ASTERISK");
prints "2722".
Returns undef if the name is unknown.
This works only for the standard names, and does not yet apply
to custom translators.
=head1 ALIASES
A few aliases have been defined for convenience: instead of having
to use the official names
LINE FEED (LF)
FORM FEED (FF)
CARRIAGE RETURN (CR)
NEXT LINE (NEL)
(yes, with parentheses) one can use
LINE FEED
FORM FEED
CARRIAGE RETURN
NEXT LINE
LF
FF
CR
NEL
One can also use
BYTE ORDER MARK
BOM
and
ZWNJ
ZWJ
for ZERO WIDTH NON-JOINER and ZERO WIDTH JOINER.
For backward compatibility one can use the old names for
certain C0 and C1 controls
old new
HORIZONTAL TABULATION CHARACTER TABULATION
VERTICAL TABULATION LINE TABULATION
FILE SEPARATOR INFORMATION SEPARATOR FOUR
GROUP SEPARATOR INFORMATION SEPARATOR THREE
RECORD SEPARATOR INFORMATION SEPARATOR TWO
UNIT SEPARATOR INFORMATION SEPARATOR ONE
PARTIAL LINE DOWN PARTIAL LINE FORWARD
PARTIAL LINE UP PARTIAL LINE BACKWARD
but the old names in addition to giving the character
will also give a warning about being deprecated.
=head1 ILLEGAL CHARACTERS
If you ask by name for a character that does not exist, a warning is
given and the Unicode I<replacement character> "\x{FFFD}" is returned.
If you ask by code for a character that does not exist, no warning is
given and C<undef> is returned. (Though if you ask for a code point
past U+10FFFF you do get a warning.)
=head1 BUGS
Since evaluation of the translation function happens in a middle of
compilation (of a string literal), the translation function should not
do any C<eval>s or C<require>s. This restriction should be lifted in
a future version of Perl.
=cut
--- NEW FILE: Switch.pm ---
package Switch;
use strict;
use vars qw($VERSION);
use Carp;
$VERSION = '2.10_01';
# LOAD FILTERING MODULE...
use Filter::Util::Call;
sub __();
# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
my $offset;
my $fallthrough;
my ($Perl5, $Perl6) = (0,0);
sub import
{
$fallthrough = grep /\bfallthrough\b/, @_;
$offset = (caller)[2]+1;
filter_add({}) unless @_>1 && $_[1] eq 'noimport';
my $pkg = caller;
no strict 'refs';
for ( qw( on_defined on_exists ) )
{
*{"${pkg}::$_"} = \&$_;
}
*{"${pkg}::__"} = \&__ if grep /__/, @_;
$Perl6 = 1 if grep(/Perl\s*6/i, @_);
$Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
1;
}
sub unimport
{
filter_del()
}
sub filter
{
my($self) = @_ ;
local $Switch::file = (caller)[1];
my $status = 1;
$status = filter_read(1_000_000);
return $status if $status<0;
$_ = filter_blocks($_,$offset);
$_ = "# line $offset\n" . $_ if $offset; undef $offset;
return $status;
}
use Text::Balanced ':ALL';
sub line
{
my ($pretext,$offset) = @_;
($pretext=~tr/\n/\n/)+($offset||0);
}
sub is_block
{
local $SIG{__WARN__}=sub{die$@};
local $^W=1;
my $ishash = defined eval 'my $hr='.$_[0];
undef $@;
return !$ishash;
}
my $EOP = qr/\n\n|\Z/;
my $CUT = qr/\n=cut.*$EOP/;
my $pod_or_DATA = qr/ ^=(?:head[1-4]|item) .*? $CUT
| ^=pod .*? $CUT
| ^=for .*? $EOP
| ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
| ^__(DATA|END)__\n.*
/smx;
my $casecounter = 1;
sub filter_blocks
{
my ($source, $line) = @_;
return $source unless $Perl5 && $source =~ /case|switch/
|| $Perl6 && $source =~ /when|given|default/;
pos $source = 0;
my $text = "";
component: while (pos $source < length $source)
{
if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
{
$text .= q{use Switch 'noimport'};
next component;
}
my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
if (defined $pos[0])
{
my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
$text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
next component;
}
if ($source =~ m/\G\s*($pod_or_DATA)/gc) {
next component;
}
@pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
if (defined $pos[0])
{
$text .= " " if $pos[0] < $pos[2];
$text .= substr($source,$pos[0],$pos[4]-$pos[0]);
next component;
}
if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
|| $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
|| $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
{
my $keyword = $3;
my $arg = $4;
$text .= $1.$2.'S_W_I_T_C_H: while (1) ';
unless ($arg) {
@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
or do {
die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
};
$arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
}
$arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
$arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
$arg =~ s {^\s*[(]\s*/} { ( qr/} ||
$arg =~ s {^\s*[(]\s*qw} { ( \\qw};
@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
or do {
die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
};
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
$code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
$text .= $code . 'continue {last}';
next component;
}
elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
|| $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
|| $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
{
my $keyword = $2;
$text .= $1 . ($keyword eq "default"
? "if (1)"
: "if (Switch::case");
if ($keyword eq "default") {
# Nothing to do
}
elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
$text .= " " if $pos[0] < $pos[2];
$text .= "sub " if is_block $code;
$text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
}
elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
$code =~ s {^\s*[(]\s*%} { ( \\\%} ||
$code =~ s {^\s*[(]\s*m\b} { ( qr} ||
$code =~ s {^\s*[(]\s*/} { ( qr/} ||
$code =~ s {^\s*[(]\s*qw} { ( \\qw};
$text .= " " if $pos[0] < $pos[2];
$text .= "$code)";
}
elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
$code =~ s {^\s*%} { \%} ||
$code =~ s {^\s*@} { \@};
$text .= " " if $pos[0] < $pos[2];
$text .= "$code)";
}
elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
$code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
$code =~ s {^\s*m} { qr} ||
$code =~ s {^\s*/} { qr/} ||
$code =~ s {^\s*qw} { \\qw};
$text .= " " if $pos[0] < $pos[2];
$text .= "$code)";
}
elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
|| $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
$text .= ' \\' if $2 eq '%';
$text .= " $code)";
}
else {
die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
}
die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
or do {
if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
$casecounter++;
next component;
}
die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
};
my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
$code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
unless $fallthrough;
$text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
$casecounter++;
next component;
}
$source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
$text .= $1;
}
$text;
}
sub in
{
my ($x,$y) = @_;
my @numy;
for my $nextx ( @$x )
{
my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
for my $j ( 0..$#$y )
{
my $nexty = $y->[$j];
push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
if @numy <= $j;
return 1 if $numx && $numy[$j] && $nextx==$nexty
|| $nextx eq $nexty;
}
}
return "";
}
sub on_exists
{
my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
[ keys %$ref ]
}
sub on_defined
{
my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
[ grep { defined $ref->{$_} } keys %$ref ]
}
sub switch(;$)
{
my ($s_val) = @_ ? $_[0] : $_;
my $s_ref = ref $s_val;
if ($s_ref eq 'CODE')
{
$::_S_W_I_T_C_H =
sub { my $c_val = $_[0];
return $s_val == $c_val if ref $c_val eq 'CODE';
return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
return $s_val->($c_val);
};
}
elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
{
$::_S_W_I_T_C_H =
sub { my $c_val = $_[0];
my $c_ref = ref $c_val;
return $s_val == $c_val if $c_ref eq ""
&& defined $c_val
&& (~$c_val&$c_val) eq 0;
return $s_val eq $c_val if $c_ref eq "";
return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
return $c_val->($s_val) if $c_ref eq 'CODE';
return $c_val->call($s_val) if $c_ref eq 'Switch';
return scalar $s_val=~/$c_val/
if $c_ref eq 'Regexp';
return scalar $c_val->{$s_val}
if $c_ref eq 'HASH';
return;
};
}
elsif ($s_ref eq "") # STRING SCALAR
{
$::_S_W_I_T_C_H =
sub { my $c_val = $_[0];
my $c_ref = ref $c_val;
return $s_val eq $c_val if $c_ref eq "";
return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
return $c_val->($s_val) if $c_ref eq 'CODE';
return $c_val->call($s_val) if $c_ref eq 'Switch';
return scalar $s_val=~/$c_val/
if $c_ref eq 'Regexp';
return scalar $c_val->{$s_val}
if $c_ref eq 'HASH';
return;
};
}
elsif ($s_ref eq 'ARRAY')
{
$::_S_W_I_T_C_H =
sub { my $c_val = $_[0];
my $c_ref = ref $c_val;
return in($s_val,[$c_val]) if $c_ref eq "";
return in($s_val,$c_val) if $c_ref eq 'ARRAY';
return $c_val->(@$s_val) if $c_ref eq 'CODE';
return $c_val->call(@$s_val)
if $c_ref eq 'Switch';
return scalar grep {$_=~/$c_val/} @$s_val
if $c_ref eq 'Regexp';
return scalar grep {$c_val->{$_}} @$s_val
if $c_ref eq 'HASH';
return;
};
}
elsif ($s_ref eq 'Regexp')
{
$::_S_W_I_T_C_H =
sub { my $c_val = $_[0];
my $c_ref = ref $c_val;
return $c_val=~/s_val/ if $c_ref eq "";
return scalar grep {$_=~/s_val/} @$c_val
if $c_ref eq 'ARRAY';
return $c_val->($s_val) if $c_ref eq 'CODE';
return $c_val->call($s_val) if $c_ref eq 'Switch';
return $s_val eq $c_val if $c_ref eq 'Regexp';
return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
if $c_ref eq 'HASH';
return;
};
}
elsif ($s_ref eq 'HASH')
{
$::_S_W_I_T_C_H =
sub { my $c_val = $_[0];
my $c_ref = ref $c_val;
return $s_val->{$c_val} if $c_ref eq "";
return scalar grep {$s_val->{$_}} @$c_val
if $c_ref eq 'ARRAY';
return $c_val->($s_val) if $c_ref eq 'CODE';
return $c_val->call($s_val) if $c_ref eq 'Switch';
return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
if $c_ref eq 'Regexp';
return $s_val==$c_val if $c_ref eq 'HASH';
return;
};
}
elsif ($s_ref eq 'Switch')
{
$::_S_W_I_T_C_H =
sub { my $c_val = $_[0];
return $s_val == $c_val if ref $c_val eq 'Switch';
return $s_val->call(@$c_val)
if ref $c_val eq 'ARRAY';
return $s_val->call($c_val);
};
}
else
{
croak "Cannot switch on $s_ref";
}
return 1;
}
sub case($) { local $SIG{__WARN__} = \&carp;
$::_S_W_I_T_C_H->(@_); }
# IMPLEMENT __
my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
sub __() { $placeholder }
sub __arg($)
{
my $index = $_[0]+1;
bless { arity=>0, impl=>sub{$_[$index]} };
}
sub hosub(&@)
{
# WRITE THIS
}
sub call
{
my ($self, at args) = @_;
return $self->{impl}->(0, at args);
}
sub meta_bop(&)
{
my ($op) = @_;
sub
{
my ($left, $right, $reversed) = @_;
($right,$left) = @_ if $reversed;
my $rop = ref $right eq 'Switch'
? $right
: bless { arity=>0, impl=>sub{$right} };
my $lop = ref $left eq 'Switch'
? $left
: bless { arity=>0, impl=>sub{$left} };
my $arity = $lop->{arity} + $rop->{arity};
return bless {
arity => $arity,
impl => sub { my $start = shift;
return $op->($lop->{impl}->($start, at _),
$rop->{impl}->($start+$lop->{arity}, at _));
}
};
};
}
sub meta_uop(&)
{
my ($op) = @_;
sub
{
my ($left) = @_;
my $lop = ref $left eq 'Switch'
? $left
: bless { arity=>0, impl=>sub{$left} };
my $arity = $lop->{arity};
return bless {
arity => $arity,
impl => sub { $op->($lop->{impl}->(@_)) }
};
};
}
use overload
"+" => meta_bop {$_[0] + $_[1]},
"-" => meta_bop {$_[0] - $_[1]},
"*" => meta_bop {$_[0] * $_[1]},
"/" => meta_bop {$_[0] / $_[1]},
"%" => meta_bop {$_[0] % $_[1]},
"**" => meta_bop {$_[0] ** $_[1]},
"<<" => meta_bop {$_[0] << $_[1]},
">>" => meta_bop {$_[0] >> $_[1]},
"x" => meta_bop {$_[0] x $_[1]},
"." => meta_bop {$_[0] . $_[1]},
"<" => meta_bop {$_[0] < $_[1]},
"<=" => meta_bop {$_[0] <= $_[1]},
">" => meta_bop {$_[0] > $_[1]},
">=" => meta_bop {$_[0] >= $_[1]},
"==" => meta_bop {$_[0] == $_[1]},
"!=" => meta_bop {$_[0] != $_[1]},
"<=>" => meta_bop {$_[0] <=> $_[1]},
"lt" => meta_bop {$_[0] lt $_[1]},
"le" => meta_bop {$_[0] le $_[1]},
"gt" => meta_bop {$_[0] gt $_[1]},
"ge" => meta_bop {$_[0] ge $_[1]},
"eq" => meta_bop {$_[0] eq $_[1]},
"ne" => meta_bop {$_[0] ne $_[1]},
"cmp" => meta_bop {$_[0] cmp $_[1]},
"\&" => meta_bop {$_[0] & $_[1]},
"^" => meta_bop {$_[0] ^ $_[1]},
"|" => meta_bop {$_[0] | $_[1]},
"atan2" => meta_bop {atan2 $_[0], $_[1]},
"neg" => meta_uop {-$_[0]},
"!" => meta_uop {!$_[0]},
"~" => meta_uop {~$_[0]},
"cos" => meta_uop {cos $_[0]},
"sin" => meta_uop {sin $_[0]},
"exp" => meta_uop {exp $_[0]},
"abs" => meta_uop {abs $_[0]},
"log" => meta_uop {log $_[0]},
"sqrt" => meta_uop {sqrt $_[0]},
"bool" => sub { croak "Can't use && or || in expression containing __" },
# "&()" => sub { $_[0]->{impl} },
# "||" => meta_bop {$_[0] || $_[1]},
# "&&" => meta_bop {$_[0] && $_[1]},
# fallback => 1,
;
1;
__END__
=head1 NAME
Switch - A switch statement for Perl
=head1 VERSION
This document describes version 2.10 of Switch,
released Dec 29, 2003.
=head1 SYNOPSIS
use Switch;
switch ($val) {
case 1 { print "number 1" }
case "a" { print "string a" }
case [1..10,42] { print "number in list" }
case (@array) { print "number in list" }
case /\w+/ { print "pattern" }
case qr/\w+/ { print "pattern" }
case (%hash) { print "entry in hash" }
case (\%hash) { print "entry in hash" }
case (\&sub) { print "arg to subroutine" }
else { print "previous case not true" }
}
=head1 BACKGROUND
[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
and wherefores of this control structure]
In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
it is useful to generalize this notion of distributed conditional
testing as far as possible. Specifically, the concept of "matching"
between the switch value and the various case values need not be
restricted to numeric (or string or referential) equality, as it is in other
languages. Indeed, as Table 1 illustrates, Perl
offers at least eighteen different ways in which two values could
generate a match.
Table 1: Matching a switch value ($s) with a case value ($c)
Switch Case Type of Match Implied Matching Code
Value Value
====== ===== ===================== =============
number same numeric or referential match if $s == $c;
or ref equality
object method result of method call match if $s->$c();
ref name match if defined $s->$c();
or ref
other other string equality match if $s eq $c;
non-ref non-ref
scalar scalar
string regexp pattern match match if $s =~ /$c/;
array scalar array entry existence match if 0<=$c && $c<@$s;
ref array entry definition match if defined $s->[$c];
array entry truth match if $s->[$c];
array array array intersection match if intersects(@$s, @$c);
ref ref (apply this table to
all pairs of elements
$s->[$i] and
$c->[$j])
array regexp array grep match if grep /$c/, @$s;
ref
hash scalar hash entry existence match if exists $s->{$c};
ref hash entry definition match if defined $s->{$c};
hash entry truth match if $s->{$c};
hash regexp hash grep match if grep /$c/, keys %$s;
ref
sub scalar return value defn match if defined $s->($c);
ref return value truth match if $s->($c);
sub array return value defn match if defined $s->(@$c);
ref ref return value truth match if $s->(@$c);
In reality, Table 1 covers 31 alternatives, because only the equality and
intersection tests are commutative; in all other cases, the roles of
the C<$s> and C<$c> variables could be reversed to produce a
different test. For example, instead of testing a single hash for
the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
one could test for the existence of a single key in a series of hashes
(C<match if exists $c-E<gt>{$s}>).
As L<perltodo> observes, a Perl case mechanism must support all these
"ways to do it".
=head1 DESCRIPTION
The Switch.pm module implements a generalized case mechanism that covers
the numerous possible combinations of switch and case values described above.
The module augments the standard Perl syntax with two new control
statements: C<switch> and C<case>. The C<switch> statement takes a
single scalar argument of any type, specified in parentheses.
C<switch> stores this value as the
current switch value in a (localized) control variable.
The value is followed by a block which may contain one or more
Perl statements (including the C<case> statement described below).
The block is unconditionally executed once the switch value has
been cached.
A C<case> statement takes a single scalar argument (in mandatory
parentheses if it's a variable; otherwise the parens are optional) and
selects the appropriate type of matching between that argument and the
current switch value. The type of matching used is determined by the
respective types of the switch value and the C<case> argument, as
specified in Table 1. If the match is successful, the mandatory
block associated with the C<case> statement is executed.
In most other respects, the C<case> statement is semantically identical
to an C<if> statement. For example, it can be followed by an C<else>
clause, and can be used as a postfix statement qualifier.
However, when a C<case> block has been executed control is automatically
transferred to the statement after the immediately enclosing C<switch>
block, rather than to the next statement within the block. In other
words, the success of any C<case> statement prevents other cases in the
same scope from executing. But see L<"Allowing fall-through"> below.
Together these two new statements provide a fully generalized case
mechanism:
use Switch;
# AND LATER...
%special = ( woohoo => 1, d'oh => 1 );
while (<>) {
switch ($_) {
case (%special) { print "homer\n"; } # if $special{$_}
case /a-z/i { print "alpha\n"; } # if $_ =~ /a-z/i
case [1..9] { print "small num\n"; } # if $_ in [1..9]
case { $_[0] >= 10 } { # if $_ >= 10
my $age = <>;
switch (sub{ $_[0] < $age } ) {
case 20 { print "teens\n"; } # if 20 < $age
case 30 { print "twenties\n"; } # if 30 < $age
else { print "history\n"; }
}
}
print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
}
Note that C<switch>es can be nested within C<case> (or any other) blocks,
and a series of C<case> statements can try different types of matches
-- hash membership, pattern match, array intersection, simple equality,
etc. -- against the same switch value.
The use of intersection tests against an array reference is particularly
useful for aggregating integral cases:
sub classify_digit
{
switch ($_[0]) { case 0 { return 'zero' }
case [2,4,6,8] { return 'even' }
case [1,3,4,7,9] { return 'odd' }
case /[A-F]/i { return 'hex' }
}
}
=head2 Allowing fall-through
Fall-though (trying another case after one has already succeeded)
is usually a Bad Idea in a switch statement. However, this
is Perl, not a police state, so there I<is> a way to do it, if you must.
If a C<case> block executes an untargeted C<next>, control is
immediately transferred to the statement I<after> the C<case> statement
(i.e. usually another case), rather than out of the surrounding
C<switch> block.
For example:
switch ($val) {
case 1 { handle_num_1(); next } # and try next case...
case "1" { handle_str_1(); next } # and try next case...
case [0..9] { handle_num_any(); } # and we're done
case /\d/ { handle_dig_any(); next } # and try next case...
case /.*/ { handle_str_any(); next } # and try next case...
}
If $val held the number C<1>, the above C<switch> block would call the
first three C<handle_...> subroutines, jumping to the next case test
each time it encountered a C<next>. After the thrid C<case> block
was executed, control would jump to the end of the enclosing
C<switch> block.
On the other hand, if $val held C<10>, then only the last two C<handle_...>
subroutines would be called.
Note that this mechanism allows the notion of I<conditional fall-through>.
For example:
switch ($val) {
case [0..9] { handle_num_any(); next if $val < 7; }
case /\d/ { handle_dig_any(); }
}
If an untargeted C<last> statement is executed in a case block, this
immediately transfers control out of the enclosing C<switch> block
(in other words, there is an implicit C<last> at the end of each
normal C<case> block). Thus the previous example could also have been
written:
switch ($val) {
case [0..9] { handle_num_any(); last if $val >= 7; next; }
case /\d/ { handle_dig_any(); }
}
=head2 Automating fall-through
In situations where case fall-through should be the norm, rather than an
exception, an endless succession of terminal C<next>s is tedious and ugly.
Hence, it is possible to reverse the default behaviour by specifying
the string "fallthrough" when importing the module. For example, the
following code is equivalent to the first example in L<"Allowing fall-through">:
use Switch 'fallthrough';
switch ($val) {
case 1 { handle_num_1(); }
case "1" { handle_str_1(); }
case [0..9] { handle_num_any(); last }
case /\d/ { handle_dig_any(); }
case /.*/ { handle_str_any(); }
}
Note the explicit use of a C<last> to preserve the non-fall-through
behaviour of the third case.
=head2 Alternative syntax
Perl 6 will provide a built-in switch statement with essentially the
same semantics as those offered by Switch.pm, but with a different
pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
C<case> will be pronounced C<when>. In addition, the C<when> statement
will not require switch or case values to be parenthesized.
This future syntax is also (largely) available via the Switch.pm module, by
importing it with the argument C<"Perl6">. For example:
use Switch 'Perl6';
given ($val) {
when 1 { handle_num_1(); }
when ($str1) { handle_str_1(); }
when [0..9] { handle_num_any(); last }
when /\d/ { handle_dig_any(); }
when /.*/ { handle_str_any(); }
default { handle anything else; }
}
Note that scalars still need to be parenthesized, since they would be
ambiguous in Perl 5.
Note too that you can mix and match both syntaxes by importing the module
with:
use Switch 'Perl5', 'Perl6';
=head2 Higher-order Operations
One situation in which C<switch> and C<case> do not provide a good
substitute for a cascaded C<if>, is where a switch value needs to
be tested against a series of conditions. For example:
sub beverage {
switch (shift) {
case sub { $_[0] < 10 } { return 'milk' }
case sub { $_[0] < 20 } { return 'coke' }
case sub { $_[0] < 30 } { return 'beer' }
case sub { $_[0] < 40 } { return 'wine' }
case sub { $_[0] < 50 } { return 'malt' }
case sub { $_[0] < 60 } { return 'Moet' }
else { return 'milk' }
}
}
The need to specify each condition as a subroutine block is tiresome. To
overcome this, when importing Switch.pm, a special "placeholder"
subroutine named C<__> [sic] may also be imported. This subroutine
converts (almost) any expression in which it appears to a reference to a
higher-order function. That is, the expression:
use Switch '__';
__ < 2 + __
is equivalent to:
sub { $_[0] < 2 + $_[1] }
With C<__>, the previous ugly case statements can be rewritten:
case __ < 10 { return 'milk' }
case __ < 20 { return 'coke' }
case __ < 30 { return 'beer' }
case __ < 40 { return 'wine' }
case __ < 50 { return 'malt' }
case __ < 60 { return 'Moet' }
else { return 'milk' }
The C<__> subroutine makes extensive use of operator overloading to
perform its magic. All operations involving __ are overloaded to
produce an anonymous subroutine that implements a lazy version
of the original operation.
The only problem is that operator overloading does not allow the
boolean operators C<&&> and C<||> to be overloaded. So a case statement
like this:
case 0 <= __ && __ < 10 { return 'digit' }
doesn't act as expected, because when it is
executed, it constructs two higher order subroutines
and then treats the two resulting references as arguments to C<&&>:
sub { 0 <= $_[0] } && sub { $_[0] < 10 }
This boolean expression is inevitably true, since both references are
non-false. Fortunately, the overloaded C<'bool'> operator catches this
situation and flags it as a error.
=head1 DEPENDENCIES
The module is implemented using Filter::Util::Call and Text::Balanced
and requires both these modules to be installed.
=head1 AUTHOR
Damian Conway (damian at conway.org). The maintainer of this module is now Rafael
Garcia-Suarez (rgarciasuarez at free.fr).
=head1 BUGS
There are undoubtedly serious bugs lurking somewhere in code this funky :-)
Bug reports and other feedback are most welcome.
=head1 LIMITATIONS
Due to the heuristic nature of Switch.pm's source parsing, the presence
of regexes specified with raw C<?...?> delimiters may cause mysterious
errors. The workaround is to use C<m?...?> instead.
Due to the way source filters work in Perl, you can't use Switch inside
an string C<eval>.
If your source file is longer then 1 million characters and you have a
switch statement that crosses the 1 million (or 2 million, etc.)
character boundary you will get mysterious errors. The workaround is to
use smaller source files.
=head1 COPYRIGHT
Copyright (c) 1997-2003, Damian Conway. All Rights Reserved.
This module is free software. It may be used, redistributed
and/or modified under the same terms as Perl itself.
--- NEW FILE: flush.pl ---
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: IO::Handle
#
;# Usage: &flush(FILEHANDLE)
;# flushes the named filehandle
;# Usage: &printflush(FILEHANDLE, "prompt: ")
;# prints arguments and flushes filehandle
sub flush {
local($old) = select(shift);
$| = 1;
print "";
$| = 0;
select($old);
}
sub printflush {
local($old) = select(shift);
$| = 1;
print @_;
$| = 0;
select($old);
}
1;
--- NEW FILE: strict.pm ---
package strict;
$strict::VERSION = "1.03";
my %bitmask = (
refs => 0x00000002,
subs => 0x00000200,
vars => 0x00000400
);
sub bits {
my $bits = 0;
my @wrong;
foreach my $s (@_) {
push @wrong, $s unless exists $bitmask{$s};
$bits |= $bitmask{$s} || 0;
}
if (@wrong) {
require Carp;
Carp::croak("Unknown 'strict' tag(s) '@wrong'");
}
$bits;
}
my $default_bits = bits(qw(refs subs vars));
sub import {
shift;
$^H |= @_ ? bits(@_) : $default_bits;
}
sub unimport {
shift;
$^H &= ~ (@_ ? bits(@_) : $default_bits);
}
1;
__END__
=head1 NAME
strict - Perl pragma to restrict unsafe constructs
=head1 SYNOPSIS
use strict;
use strict "vars";
use strict "refs";
use strict "subs";
use strict;
no strict "vars";
=head1 DESCRIPTION
If no import list is supplied, all possible restrictions are assumed.
(This is the safest mode to operate in, but is sometimes too strict for
casual programming.) Currently, there are three possible things to be
strict about: "subs", "vars", and "refs".
=over 6
=item C<strict refs>
This generates a runtime error if you
use symbolic references (see L<perlref>).
use strict 'refs';
$ref = \$foo;
print $$ref; # ok
$ref = "foo";
print $$ref; # runtime error; normally ok
$file = "STDOUT";
print $file "Hi!"; # error; note: no comma after $file
There is one exception to this rule:
$bar = \&{'foo'};
&$bar;
is allowed so that C<goto &$AUTOLOAD> would not break under stricture.
=item C<strict vars>
This generates a compile-time error if you access a variable that wasn't
declared via C<our> or C<use vars>,
localized via C<my()>, or wasn't fully qualified. Because this is to avoid
variable suicide problems and subtle dynamic scoping issues, a merely
local() variable isn't good enough. See L<perlfunc/my> and
L<perlfunc/local>.
use strict 'vars';
$X::foo = 1; # ok, fully qualified
my $foo = 10; # ok, my() var
local $foo = 9; # blows up
package Cinna;
our $bar; # Declares $bar in current package
$bar = 'HgS'; # ok, global declared via pragma
The local() generated a compile-time error because you just touched a global
name without fully qualifying it.
Because of their special use by sort(), the variables $a and $b are
exempted from this check.
=item C<strict subs>
This disables the poetry optimization, generating a compile-time error if
you try to use a bareword identifier that's not a subroutine, unless it
is a simple identifier (no colons) and that it appears in curly braces or
on the left hand side of the C<< => >> symbol.
use strict 'subs';
$SIG{PIPE} = Plumber; # blows up
$SIG{PIPE} = "Plumber"; # just fine: quoted string is always ok
$SIG{PIPE} = \&Plumber; # preferred form
=back
See L<perlmodlib/Pragmatic Modules>.
=head1 HISTORY
C<strict 'subs'>, with Perl 5.6.1, erroneously permitted to use an unquoted
compound identifier (e.g. C<Foo::Bar>) as a hash key (before C<< => >> or
inside curlies), but without forcing it always to a literal string.
Starting with Perl 5.8.1 strict is strict about its restrictions:
if unknown restrictions are used, the strict pragma will abort with
Unknown 'strict' tag(s) '...'
=cut
--- NEW FILE: strict.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = '../lib';
}
$| = 1;
my $Is_VMS = $^O eq 'VMS';
my $Is_MSWin32 = $^O eq 'MSWin32';
my $Is_NetWare = $^O eq 'NetWare';
my $tmpfile = "tmp0000";
my $i = 0 ;
1 while -e ++$tmpfile;
END { if ($tmpfile) { 1 while unlink $tmpfile; } }
my @prgs = () ;
foreach (sort glob($^O eq 'MacOS' ? ":lib:strict:*" : "lib/strict/*")) {
next if -d || /(~|\.orig|,v)$/;
open F, "<$_" or die "Cannot open $_: $!\n" ;
while (<F>) {
last if /^__END__/ ;
}
{
local $/ = undef;
@prgs = (@prgs, split "\n########\n", <F>) ;
}
close F or die "Could not close: $!" ;
}
undef $/;
print "1.." . (@prgs + 4) . "\n";
for (@prgs){
my $switch = "";
my @temps = () ;
if (s/^\s*-\w+//){
$switch = $&;
}
my($prog,$expected) = split(/\nEXPECT\n/, $_);
if ( $prog =~ /--FILE--/) {
my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
shift @files ;
die "Internal error test $i didn't split into pairs, got " .
scalar(@files) . "[" . join("%%%%", @files) ."]\n"
if @files % 2 ;
while (@files > 2) {
my $filename = shift @files ;
my $code = shift @files ;
$code =~ s|\./abc|:abc|g if $^O eq 'MacOS';
push @temps, $filename ;
open F, ">$filename" or die "Cannot open $filename: $!\n" ;
print F $code ;
close F or die "Could not close: $!" ;
}
shift @files ;
$prog = shift @files ;
$prog =~ s|\./abc|:abc|g if $^O eq 'MacOS';
}
open TEST, ">$tmpfile" or die "Could not open: $!";
print TEST $prog,"\n";
close TEST or die "Could not close: $!";
my $results = $Is_MSWin32 ?
`.\\perl -I../lib $switch $tmpfile 2>&1` :
$^O eq 'NetWare' ?
`perl -I../lib $switch $tmpfile 2>&1` :
$^O eq 'MacOS' ?
`$^X -I::lib -MMac::err=unix $switch $tmpfile` :
`./perl $switch $tmpfile 2>&1`;
my $status = $?;
$results =~ s/\n+$//;
# allow expected output to be written as if $prog is on STDIN
$results =~ s/tmp\d+/-/g;
$results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
$expected =~ s/\n+$//;
$expected =~ s|(\./)?abc\.pm|:abc.pm|g if $^O eq 'MacOS';
$expected =~ s|./abc|:abc|g if $^O eq 'MacOS';
my $prefix = ($results =~ s/^PREFIX\n//) ;
if ( $results =~ s/^SKIPPED\n//) {
print "$results\n" ;
}
elsif (($prefix and $results !~ /^\Q$expected/) or
(!$prefix and $results ne $expected)){
print STDERR "PROG: $switch\n$prog\n";
print STDERR "EXPECTED:\n$expected\n";
print STDERR "GOT:\n$results\n";
print "not ";
}
print "ok " . ++$i . "\n";
foreach (@temps)
{ unlink $_ if $_ }
}
eval qq(use strict 'garbage');
print +($@ =~ /^Unknown 'strict' tag\(s\) 'garbage'/)
? "ok ".++$i."\n" : "not ok ".++$i."\t# $@";
eval qq(no strict 'garbage');
print +($@ =~ /^Unknown 'strict' tag\(s\) 'garbage'/)
? "ok ".++$i."\n" : "not ok ".++$i."\t# $@";
eval qq(use strict qw(foo bar));
print +($@ =~ /^Unknown 'strict' tag\(s\) 'foo bar'/)
? "ok ".++$i."\n" : "not ok ".++$i."\t# $@";
eval qq(no strict qw(foo bar));
print +($@ =~ /^Unknown 'strict' tag\(s\) 'foo bar'/)
? "ok ".++$i."\n" : "not ok ".++$i."\t# $@";
--- NEW FILE: lib_pm.PL ---
use Config;
use File::Basename qw(&basename &dirname);
use File::Spec;
use Cwd;
my $origdir = cwd;
chdir dirname($0);
my $file = basename($0, '.PL');
$file =~ s!_(pm)$!.$1!i;
my $useConfig;
my $Config_archname;
my $Config_version;
my $Config_inc_version_list;
# Expand the variables only if explicitly requested because
# otherwise relocating Perl becomes much harder.
if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) {
$useConfig = '';
$Config_archname = qq('$Config{archname}');
$Config_version = qq('$Config{version}');
my @Config_inc_version_list =
reverse split / /, $Config{inc_version_list};
$Config_inc_version_list =
@Config_inc_version_list ?
qq(@Config_inc_version_list) : q(());
} else {
$useConfig = 'use Config;';
$Config_archname = q($Config{archname});
$Config_version = q($Config{version});
$Config_inc_version_list =
q(reverse split / /, $Config{inc_version_list});
}
open OUT,">$file" or die "Can't create $file: $!";
print "Extracting $file (with variable substitutions)\n";
# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
package lib;
# THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL.
# ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD.
$useConfig
use strict;
my \$archname = $Config_archname;
my \$version = $Config_version;
my \@inc_version_list = $Config_inc_version_list;
!GROK!THIS!
print OUT <<'!NO!SUBS!';
our @ORIG_INC = @INC; # take a handy copy of 'original' value
our $VERSION = '0.5565';
my $Is_MacOS = $^O eq 'MacOS';
my $Mac_FS;
if ($Is_MacOS) {
require File::Spec;
$Mac_FS = eval { require Mac::FileSpec::Unixish };
}
sub import {
shift;
my %names;
foreach (reverse @_) {
my $path = $_; # we'll be modifying it, so break the alias
if ($path eq '') {
require Carp;
Carp::carp("Empty compile time value given to use lib");
}
$path = _nativize($path);
if (-e $path && ! -d _) {
require Carp;
Carp::carp("Parameter to use lib must be directory, not file");
}
unshift(@INC, $path);
# Add any previous version directories we found at configure time
foreach my $incver (@inc_version_list)
{
my $dir = $Is_MacOS
? File::Spec->catdir( $path, $incver )
: "$path/$incver";
unshift(@INC, $dir) if -d $dir;
}
# Put a corresponding archlib directory in front of $path if it
# looks like $path has an archlib directory below it.
my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
= _get_dirs($path);
unshift(@INC, $arch_dir) if -d $arch_auto_dir;
unshift(@INC, $version_dir) if -d $version_dir;
unshift(@INC, $version_arch_dir) if -d $version_arch_dir;
}
# remove trailing duplicates
@INC = grep { ++$names{$_} == 1 } @INC;
return;
}
sub unimport {
shift;
my %names;
foreach (@_) {
my $path = _nativize($_);
my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
= _get_dirs($path);
++$names{$path};
++$names{$arch_dir} if -d $arch_auto_dir;
++$names{$version_dir} if -d $version_dir;
++$names{$version_arch_dir} if -d $version_arch_dir;
}
# Remove ALL instances of each named directory.
@INC = grep { !exists $names{$_} } @INC;
return;
}
sub _get_dirs {
my($dir) = @_;
my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
# we could use this for all platforms in the future, but leave it
# Mac-only for now, until there is more time for testing it.
if ($Is_MacOS) {
$arch_auto_dir = File::Spec->catdir( $dir, $archname, 'auto' );
$arch_dir = File::Spec->catdir( $dir, $archname, );
$version_dir = File::Spec->catdir( $dir, $version );
$version_arch_dir = File::Spec->catdir( $dir, $version, $archname );
} else {
$arch_auto_dir = "$dir/$archname/auto";
$arch_dir = "$dir/$archname";
$version_dir = "$dir/$version";
$version_arch_dir = "$dir/$version/$archname";
}
return($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
}
sub _nativize {
my($dir) = @_;
if ($Is_MacOS && $Mac_FS && ! -d $dir) {
$dir = Mac::FileSpec::Unixish::nativize($dir);
$dir .= ":" unless $dir =~ /:$/;
}
return $dir;
}
1;
__END__
=head1 NAME
lib - manipulate @INC at compile time
=head1 SYNOPSIS
use lib LIST;
no lib LIST;
=head1 DESCRIPTION
This is a small simple module which simplifies the manipulation of @INC
at compile time.
It is typically used to add extra directories to perl's search path so
that later C<use> or C<require> statements will find modules which are
not located on perl's default search path.
=head2 Adding directories to @INC
The parameters to C<use lib> are added to the start of the perl search
path. Saying
use lib LIST;
is I<almost> the same as saying
BEGIN { unshift(@INC, LIST) }
For each directory in LIST (called $dir here) the lib module also
checks to see if a directory called $dir/$archname/auto exists.
If so the $dir/$archname directory is assumed to be a corresponding
architecture specific directory and is added to @INC in front of $dir.
To avoid memory leaks, all trailing duplicate entries in @INC are
removed.
=head2 Deleting directories from @INC
You should normally only add directories to @INC. If you need to
delete directories from @INC take care to only delete those which you
added yourself or which you are certain are not needed by other modules
in your script. Other modules may have added directories which they
need for correct operation.
The C<no lib> statement deletes all instances of each named directory
from @INC.
For each directory in LIST (called $dir here) the lib module also
checks to see if a directory called $dir/$archname/auto exists.
If so the $dir/$archname directory is assumed to be a corresponding
architecture specific directory and is also deleted from @INC.
=head2 Restoring original @INC
When the lib module is first loaded it records the current value of @INC
in an array C<@lib::ORIG_INC>. To restore @INC to that value you
can say
@INC = @lib::ORIG_INC;
=head1 CAVEATS
In order to keep lib.pm small and simple, it only works with Unix
filepaths. This doesn't mean it only works on Unix, but non-Unix
users must first translate their file paths to Unix conventions.
# VMS users wanting to put [.stuff.moo] into
# their @INC would write
use lib 'stuff/moo';
=head1 NOTES
In the future, this module will likely use File::Spec for determining
paths, as it does now for Mac OS (where Unix-style or Mac-style paths
work, and Unix-style paths are converted properly to Mac-style paths
before being added to @INC).
=head1 SEE ALSO
FindBin - optional module which deals with paths relative to the source file.
=head1 AUTHOR
Tim Bunce, 2nd June 1995.
=cut
!NO!SUBS!
close OUT or die "Can't close $file: $!";
chdir $origdir;
--- NEW FILE: Shell.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use Test::More tests => 7;
BEGIN { use_ok('Shell'); }
my $so = Shell->new;
ok($so, 'Shell->new');
my $Is_VMS = $^O eq 'VMS';
my $Is_MSWin32 = $^O eq 'MSWin32';
my $Is_NetWare = $^O eq 'NetWare';
$Shell::capture_stderr = 1;
# Now test that that works ..
my $tmpfile = 'sht0001';
while ( -f $tmpfile ) {
$tmpfile++;
}
END { -f $tmpfile && (open STDERR, '>&SAVERR' and unlink $tmpfile) }
open(SAVERR, ">&STDERR");
open(STDERR, ">$tmpfile");
xXx_not_there(); # Ok someone could have a program called this :(
# On os2 the warning is on by default...
ok(($^O eq 'os2' xor !(-s $tmpfile)), '$Shell::capture_stderr');
$Shell::capture_stderr = 0;
# someone will have to fill in the blanks for other platforms
if ($Is_VMS) {
ok(directory(), 'Execute command');
my @files = directory('*.*');
ok(@files, 'Quoted arguments');
ok(eq_array(\@files, [$so->directory('*.*')]), 'object method');
eval { $so->directory };
ok(!$@, '2 methods calls');
} elsif ($Is_MSWin32) {
ok(dir(), 'Execute command');
my @files = dir('*.*');
ok(@files, 'Quoted arguments');
ok(eq_array(\@files, [$so->dir('*.*')]), 'object method');
eval { $so->dir };
ok(!$@, '2 methods calls');
} else {
ok(ls(), 'Execute command');
my @files = ls('*');
ok(@files, 'Quoted arguments');
ok(eq_array(\@files, [$so->ls('*')]), 'object method');
eval { $so->ls };
ok(!$@, '2 methods calls');
}
open(STDERR, ">&SAVERR") ;
--- NEW FILE: Dumpvalue.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
if (ord('A') == 193) {
print "1..0 # skip: EBCDIC\n";
exit 0;
}
require Config;
if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
print "1..0 # Skip -- Perl configured without List::Util module\n";
exit 0;
}
}
use vars qw( $foo @bar %baz );
use Test::More tests => 88;
use_ok( 'Dumpvalue' );
my $d;
ok( $d = Dumpvalue->new(), 'create a new Dumpvalue object' );
$d->set( globPrint => 1, dumpReused => 1 );
is( $d->{globPrint}, 1, 'set an option correctly' );
is( $d->get('globPrint'), 1, 'get an option correctly' );
is( $d->get('globPrint', 'dumpReused'), qw( 1 1 ), 'get multiple options' );
# check to see if unctrl works
is( ref( Dumpvalue::unctrl(*FOO) ), 'GLOB', 'unctrl should not modify GLOB' );
is( Dumpvalue::unctrl('donotchange'), 'donotchange', "unctrl shouldn't modify");
like( Dumpvalue::unctrl("bo\007nd"), qr/bo\^.nd/, 'unctrl should escape' );
# check to see if stringify works
is( $d->stringify(), 'undef', 'stringify handles undef okay' );
# the default is 1, but we want two single quotes
$d->{printUndef} = 0;
is( $d->stringify(), "''", 'stringify skips undef when asked nicely' );
is( $d->stringify(*FOO), *FOO . "", 'stringify stringifies globs alright' );
# check for double-quotes if there's an unprintable character
$d->{tick} = 'auto';
like( $d->stringify("hi\005"), qr/^"hi/, 'added double-quotes when necessary' );
# if no unprintable character, escape ticks or backslashes
is( $d->stringify('hi'), "'hi'", 'used single-quotes when appropriate' );
# if 'unctrl' is set
$d->{unctrl} = 'unctrl';
like( $d->stringify('double and whack:\ "'), qr!\\ \"!, 'escaped with unctrl' );
like( $d->stringify("a\005"), qr/^"a\^/, 'escaped ASCII value in unctrl' );
like( $d->stringify("b\205"), qr!^'b.'$!, 'no high-bit escape value in unctrl');
$d->{quoteHighBit} = 1;
like( $d->stringify("b\205"), qr!^'b\\205!, 'high-bit now escaped in unctrl');
# if 'quote' is set
$d->{unctrl} = 'quote';
is( $d->stringify('5@ $1'), "'5\@ \$1'", 'quoted $ and @ fine' );
is( $d->stringify("5@\033\$1"), '"5\@\e\$1"', 'quoted $ and @ and \033 fine' );
like( $d->stringify("\037"), qr/^"\\c/, 'escaped ASCII value okay' );
# add ticks, if necessary
is( $d->stringify("no ticks", 1), 'no ticks', 'avoid ticks if asked' );
my $out = tie *OUT, 'TieOut';
select(OUT);
# test DumpElem, it does its magic with veryCompact set
$d->{veryCompact} = 1;
$d->DumpElem([1, 2, 3]);
is( $out->read, "0..2 1 2 3\n", 'DumpElem worked on array ref');
$d->DumpElem({ one => 1, two => 2 });
is( $out->read, "'one' => 1, 'two' => 2\n", 'DumpElem worked on hash ref' );
$d->DumpElem('hi');
is( $out->read, "'hi'\n", 'DumpElem worked on simple scalar' );
$d->{veryCompact} = 0;
$d->DumpElem([]);
like( $out->read, qr/ARRAY/, 'DumpElem okay with reference and no veryCompact');
# should compact simple arrays just fine
$d->{veryCompact} = 1;
$d->DumpElem([1, 2, 3]);
is( $out->read, "0..2 1 2 3\n", 'dumped array fine' );
$d->{arrayDepth} = 2;
$d->DumpElem([1, 2, 3]);
is( $out->read, "0..2 1 2 ...\n", 'dumped limited array fine' );
# should compact simple hashes just fine
$d->DumpElem({ a => 1, b => 2, c => 3 });
is( $out->read, "'a' => 1, 'b' => 2, 'c' => 3\n", 'dumped hash fine' );
$d->{hashDepth} = 2;
$d->DumpElem({ a => 1, b => 2, c => 3 });
is( $out->read, "'a' => 1, 'b' => 2 ...\n", 'dumped limited hash fine' );
# should just stringify what it is
$d->{veryCompact} = 0;
$d->DumpElem([]);
like( $out->read, qr/ARRAY.+empty array/s, 'stringified empty array ref' );
$d->DumpElem({});
like( $out->read, qr/HASH.+empty hash/s, 'stringified empty hash ref' );
$d->DumpElem(1);
is( $out->read, "1\n", 'stringified simple scalar' );
# test unwrap
$DB::signal = $d->{stopDbSignal} = 1;
is( $d->unwrap(), undef, 'unwrap returns if DB signal is set' );
undef $DB::signal;
my $foo = 7;
$d->{dumpReused} = 0;
$d->unwrap(\$foo);
is( $out->read, "-> 7\n", 'unwrap worked on scalar' );
$d->unwrap(\$foo);
is( $out->read, "-> REUSED_ADDRESS\n", 'unwrap worked on scalar' );
$d->unwrap({ one => 1 });
# leaving this at zero may cause some subsequent tests to fail
# if they reuse an address creating an anonymous variable
$d->{dumpReused} = 1;
is( $out->read, "'one' => 1\n", 'unwrap worked on hash' );
$d->unwrap([ 2, 3 ]);
is( $out->read, "0 2\n1 3\n", 'unwrap worked on array' );
$d->unwrap(*FOO);
is( $out->read, '', 'unwrap ignored glob on first try');
$d->unwrap(*FOO);
is( $out->read, "*DUMPED_GLOB*\n", 'unwrap worked on glob');
$d->unwrap(qr/foo(.+)/);
is( $out->read, "-> qr/(?-xism:foo(.+))/\n", 'unwrap worked on Regexp' );
$d->unwrap( sub {} );
like( $out->read, qr/^-> &CODE/, 'unwrap worked on sub ref' );
# test matchvar
# test to see if first arg 'eq' second
ok( Dumpvalue::matchvar(1, 1), 'matchvar matched numbers fine' );
ok( Dumpvalue::matchvar('hi', 'hi'), 'matchvar matched strings fine' );
ok( !Dumpvalue::matchvar('hello', 1), 'matchvar caught failed match fine' );
# test compactDump, which doesn't do much
is( $d->compactDump(3), 3, 'set compactDump to 3' );
is( $d->compactDump(1), 479, 'compactDump reset to 6*80-1 when less than 2' );
# test veryCompact, which does slightly more, setting compactDump sometimes
$d->{compactDump} = 0;
is( $d->veryCompact(1), 1, 'set veryCompact successfully' );
ok( $d->compactDump(), 'and it set compactDump as well' );
# test set_unctrl
$d->set_unctrl('impossible value');
like( $out->read, qr/^Unknown value/, 'set_unctrl caught bad value' );
is( $d->set_unctrl('quote'), 'quote', 'set quote fine' );
is( $d->set_unctrl(), 'quote', 'retrieved quote fine' );
# test set_quote
$d->set_quote('"');
is( $d->{tick}, '"', 'set_quote set tick right' );
is( $d->{unctrl}, 'quote', 'set unctrl right too' );
$d->set_quote('auto');
is( $d->{tick}, 'auto', 'set_quote set auto right' );
$d->set_quote('foo');
is( $d->{tick}, "'", 'default value set to " correctly' );
# test dumpglob
# should do nothing if debugger signal flag is raised
$d->{stopDbSignal} = $DB::signal = 1;
is( $d->dumpglob(*DB::signal), undef, 'returned early with DB signal set' );
undef $DB::signal;
# test dumping "normal" variables, this is a nasty glob trick
$foo = 1;
$d->dumpglob( '', 2, 'foo', local *foo = \$foo );
is( $out->read, " \$foo = 1\n", 'dumped glob for $foo correctly' );
@bar = (1, 2);
# the key name is a little different here
$d->dumpglob( '', 0, 'boo', *bar );
is( $out->read, "\@boo = (\n 0..1 1 2\n)\n", 'dumped glob for @bar fine' );
%baz = ( one => 1, two => 2 );
$d->dumpglob( '', 0, 'baz', *baz );
is( $out->read, "\%baz = (\n 'one' => 1, 'two' => 2\n)\n",
'dumped glob for %baz fine' );
SKIP: {
skip( "Couldn't open $0 for reading", 1 ) unless open(FILE, $0);
my $fileno = fileno(FILE);
$d->dumpglob( '', 0, 'FILE', *FILE );
is( $out->read, "FileHandle(FILE) => fileno($fileno)\n",
'dumped filehandle from glob fine' );
}
$d->dumpglob( '', 0, 'read', *TieOut::read );
is( $out->read, '', 'no sub dumped without $all set' );
$d->dumpglob( '', 0, 'read', \&TieOut::read, 1 );
is( $out->read, "&read in ???\n", 'sub dumped when requested' );
# see if it dumps DB-like values correctly
$d->{dumpDBFiles} = 1;
$d->dumpglob( '', 0, '_<foo', *foo );
is( $out->read, "\$_<foo = 1\n", 'dumped glob for $_<foo correctly (DB)' );
# test CvGV name
SKIP: {
if (" $Config::Config{'extensions'} " !~ m[ Devel/Peek ]) {
skip( 'no Devel::Peek', 2 );
}
use_ok( 'Devel::Peek' );
is( $d->CvGV_name(\&TieOut::read), 'TieOut::read', 'CvGV_name found sub' );
}
# test dumpsub
$d->dumpsub( '', 'TieOut::read' );
like( $out->read, qr/&TieOut::read in/, 'dumpsub found sub fine' );
# test findsubs
is( $d->findsubs(), undef, 'findsubs returns nothing without %DB::sub' );
$DB::sub{'TieOut::read'} = 'TieOut';
is( $d->findsubs( \&TieOut::read ), 'TieOut::read', 'findsubs reported sub' );
# now that it's capable of finding the package...
$d->dumpsub( '', 'TieOut::read' );
is( $out->read, "&TieOut::read in TieOut\n", 'dumpsub found sub fine again' );
# this should print just a usage message
$d->{usageOnly} = 1;
$d->dumpvars( 'Fake', 'veryfake' );
like( $out->read, qr/^String space:/, 'printed usage message fine' );
delete $d->{usageOnly};
# this should report @INC and %INC
$d->dumpvars( 'main', 'INC' );
like( $out->read, qr/\@INC =/, 'dumped variables from a package' );
# this should report nothing
$DB::signal = 1;
$d->dumpvars( 'main', 'INC' );
is( $out->read, '', 'no dump when $DB::signal is set' );
undef $DB::signal;
is( $d->scalarUsage('12345'), 5, 'scalarUsage reports length correctly' );
is( $d->arrayUsage( [1, 2, 3], 'a' ), 3, 'arrayUsage reports correct lengths' );
is( $out->read, "\@a = 3 items (data: 3 bytes)\n", 'arrayUsage message okay' );
is( $d->hashUsage({ one => 1 }, 'b'), 4, 'hashUsage reports correct lengths' );
is( $out->read, "\%b = 1 item (keys: 3; values: 1; total: 4 bytes)\n",
'hashUsage message okay' );
is( $d->hashUsage({ one => [ 1, 2, 3 ]}, 'c'), 6, 'complex hash okay' );
is( $out->read, "\%c = 1 item (keys: 3; values: 3; total: 6 bytes)\n",
'hashUsage complex message okay' );
$foo = 'one';
@foo = ('two');
%foo = ( three => '123' );
is( $d->globUsage(\*foo, 'foo'), 14, 'globUsage reports length correctly' );
like( $out->read, qr/\@foo =.+\%foo =/s, 'globValue message okay' );
# and now, the real show
$d->dumpValue(undef);
is( $out->read, "undef\n", 'dumpValue caught undef value okay' );
$d->dumpValue($foo);
is( $out->read, "'one'\n", 'dumpValue worked' );
$d->dumpValue(@foo);
is( $out->read, "'two'\n", 'dumpValue worked on array' );
$d->dumpValue(\$foo);
is( $out->read, "-> 'one'\n", 'dumpValue worked on scalar ref' );
# dumpValues (the rest of these should be caught by unwrap)
$d->dumpValues(undef);
is( $out->read, "undef\n", 'dumpValues caught undef value fine' );
$d->dumpValues(\@foo);
is( $out->read, "0 0..0 'two'\n", 'dumpValues worked on array ref' );
$d->dumpValues('one', 'two');
is( $out->read, "0..1 'one' 'two'\n", 'dumpValues worked on multiple values' );
package TieOut;
use overload '"' => sub { "overloaded!" };
sub TIEHANDLE {
my $class = shift;
bless(\( my $ref), $class);
}
sub PRINT {
my $self = shift;
$$self .= join('', @_);
}
sub read {
my $self = shift;
return substr($$self, 0, length($$self), '');
}
--- NEW FILE: Fatal.pm ---
package Fatal;
use 5.006_001;
use Carp;
use strict;
our($AUTOLOAD, $Debug, $VERSION);
$VERSION = 1.03;
$Debug = 0 unless defined $Debug;
sub import {
my $self = shift(@_);
my($sym, $pkg);
my $void = 0;
$pkg = (caller)[0];
foreach $sym (@_) {
if ($sym eq ":void") {
$void = 1;
}
else {
&_make_fatal($sym, $pkg, $void);
}
}
};
sub AUTOLOAD {
my $cmd = $AUTOLOAD;
$cmd =~ s/.*:://;
&_make_fatal($cmd, (caller)[0]);
goto &$AUTOLOAD;
}
sub fill_protos {
my $proto = shift;
my ($n, $isref, @out, @out1, $seen_semi) = -1;
while ($proto =~ /\S/) {
$n++;
push(@out1,[$n, at out]) if $seen_semi;
push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
$seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
die "Unknown prototype letters: \"$proto\"";
}
push(@out1,[$n+1, at out]);
@out1;
}
sub write_invocation {
my ($core, $call, $name, $void, @argvs) = @_;
if (@argvs == 1) { # No optional arguments
my @argv = @{$argvs[0]};
shift @argv;
return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
} else {
my $else = "\t";
my (@out, @argv, $n);
while (@argvs) {
@argv = @{shift @argvs};
$n = shift @argv;
push @out, "$ {else}if (\@_ == $n) {\n";
$else = "\t} els";
push @out,
"\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
}
push @out, <<EOC;
}
die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
EOC
return join '', @out;
}
}
sub one_invocation {
my ($core, $call, $name, $void, @argv) = @_;
local $" = ', ';
if ($void) {
return qq/(defined wantarray)?$call(@argv):
$call(@argv) || croak "Can't $name(\@_)/ .
($core ? ': $!' : ', \$! is \"$!\"') . '"'
} else {
return qq{$call(@argv) || croak "Can't $name(\@_)} .
($core ? ': $!' : ', \$! is \"$!\"') . '"';
}
}
sub _make_fatal {
my($sub, $pkg, $void) = @_;
my($name, $code, $sref, $real_proto, $proto, $core, $call);
my $ini = $sub;
$sub = "${pkg}::$sub" unless $sub =~ /::/;
$name = $sub;
$name =~ s/.*::// or $name =~ s/^&//;
print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
if (defined(&$sub)) { # user subroutine
$sref = \&$sub;
$proto = prototype $sref;
$call = '&$sref';
} elsif ($sub eq $ini) { # Stray user subroutine
die "$sub is not a Perl subroutine"
} else { # CORE subroutine
$proto = eval { prototype "CORE::$name" };
die "$name is neither a builtin, nor a Perl subroutine"
if $@;
die "Cannot make a non-overridable builtin fatal"
if not defined $proto;
$core = 1;
$call = "CORE::$name";
}
if (defined $proto) {
$real_proto = " ($proto)";
} else {
$real_proto = '';
$proto = '@';
}
$code = <<EOS;
sub$real_proto {
local(\$", \$!) = (', ', 0);
EOS
my @protos = fill_protos($proto);
$code .= write_invocation($core, $call, $name, $void, @protos);
$code .= "}\n";
print $code if $Debug;
{
no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
$code = eval("package $pkg; use Carp; $code");
die if $@;
no warnings; # to avoid: Subroutine foo redefined ...
*{$sub} = $code;
}
}
1;
__END__
=head1 NAME
Fatal - replace functions with equivalents which succeed or die
=head1 SYNOPSIS
use Fatal qw(open close);
sub juggle { . . . }
import Fatal 'juggle';
=head1 DESCRIPTION
C<Fatal> provides a way to conveniently replace functions which normally
return a false value when they fail with equivalents which raise exceptions
if they are not successful. This lets you use these functions without
having to test their return values explicitly on each call. Exceptions
can be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details.
The do-or-die equivalents are set up simply by calling Fatal's
C<import> routine, passing it the names of the functions to be
replaced. You may wrap both user-defined functions and overridable
CORE operators (except C<exec>, C<system> which cannot be expressed
via prototypes) in this way.
If the symbol C<:void> appears in the import list, then functions
named later in that import list raise an exception only when
these are called in void context--that is, when their return
values are ignored. For example
use Fatal qw/:void open close/;
# properly checked, so no exception raised on error
if(open(FH, "< /bogotic") {
warn "bogo file, dude: $!";
}
# not checked, so error raises an exception
close FH;
=head1 AUTHOR
Lionel.Cons at cern.ch
prototype updates by Ilya Zakharevich ilya at math.ohio-state.edu
=cut
--- NEW FILE: vars.pm ---
package vars;
use 5.006;
our $VERSION = '1.01';
use warnings::register;
use strict qw(vars subs);
sub import {
my $callpack = caller;
my ($pack, @imports) = @_;
my ($sym, $ch);
foreach (@imports) {
if (($ch, $sym) = /^([\$\@\%\*\&])(.+)/) {
if ($sym =~ /\W/) {
# time for a more-detailed check-up
if ($sym =~ /^\w+[[{].*[]}]$/) {
require Carp;
Carp::croak("Can't declare individual elements of hash or array");
} elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
warnings::warn("No need to declare built-in vars");
} elsif (($^H &= strict::bits('vars'))) {
require Carp;
Carp::croak("'$_' is not a valid variable name under strict vars");
}
}
$sym = "${callpack}::$sym" unless $sym =~ /::/;
*$sym =
( $ch eq "\$" ? \$$sym
: $ch eq "\@" ? \@$sym
: $ch eq "\%" ? \%$sym
: $ch eq "\*" ? \*$sym
: $ch eq "\&" ? \&$sym
: do {
require Carp;
Carp::croak("'$_' is not a valid variable name");
});
} else {
require Carp;
Carp::croak("'$_' is not a valid variable name");
}
}
};
1;
__END__
=head1 NAME
vars - Perl pragma to predeclare global variable names (obsolete)
=head1 SYNOPSIS
use vars qw($frob @mung %seen);
=head1 DESCRIPTION
NOTE: For variables in the current package, the functionality provided
by this pragma has been superseded by C<our> declarations, available
in Perl v5.6.0 or later. See L<perlfunc/our>.
This will predeclare all the variables whose names are
in the list, allowing you to use them under "use strict", and
disabling any typo warnings.
Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and
C<use subs> declarations are not BLOCK-scoped. They are thus effective
for the entire file in which they appear. You may not rescind such
declarations with C<no vars> or C<no subs>.
Packages such as the B<AutoLoader> and B<SelfLoader> that delay
loading of subroutines within packages can create problems with
package lexicals defined using C<my()>. While the B<vars> pragma
cannot duplicate the effect of package lexicals (total transparency
outside of the package), it can act as an acceptable substitute by
pre-declaring global symbols, ensuring their availability to the
later-loaded routines.
See L<perlmodlib/Pragmatic Modules>.
=cut
--- NEW FILE: open2.pl ---
# This is a compatibility interface to IPC::Open2. New programs should
# do
#
# use IPC::Open2;
#
# instead of
#
# require 'open2.pl';
package main;
use IPC::Open2 'open2';
1
--- NEW FILE: bigintpl.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
require "bigint.pl";
$test = 0;
$| = 1;
print "1..246\n";
while (<DATA>) {
chop;
if (/^&/) {
$f = $_;
} else {
++$test;
@args = split(/:/,$_,99);
$ans = pop(@args);
$try = "$f('" . join("','", @args) . "');";
if (($ans1 = eval($try)) eq $ans) {
print "ok $test\n";
} else {
print "not ok $test\n";
print "# '$try' expected: '$ans' got: '$ans1'\n";
}
}
}
__END__
&bnorm
abc:NaN
1 a:NaN
1bcd2:NaN
11111b:NaN
+1z:NaN
-1z:NaN
0:+0
+0:+0
+00:+0
+0 0 0:+0
000000 0000000 00000:+0
-0:+0
-0000:+0
+1:+1
+01:+1
+001:+1
+00000100000:+100000
123456789:+123456789
-1:-1
-01:-1
-001:-1
-123456789:-123456789
-00000100000:-100000
&bneg
abd:NaN
+0:+0
+1:-1
-1:+1
+123456789:-123456789
-123456789:+123456789
&babs
abc:NaN
+0:+0
+1:+1
-1:+1
+123456789:+123456789
-123456789:+123456789
&bcmp
abc:abc:
abc:+0:
+0:abc:
+0:+0:0
-1:+0:-1
+0:-1:1
+1:+0:1
+0:+1:-1
-1:+1:-1
+1:-1:1
-1:-1:0
+1:+1:0
+123:+123:0
+123:+12:1
+12:+123:-1
-123:-123:0
-123:-12:-1
-12:-123:1
+123:+124:-1
+124:+123:1
-123:-124:1
-124:-123:-1
&badd
abc:abc:NaN
abc:+0:NaN
+0:abc:NaN
+0:+0:+0
+1:+0:+1
+0:+1:+1
+1:+1:+2
-1:+0:-1
+0:-1:-1
-1:-1:-2
-1:+1:+0
+1:-1:+0
+9:+1:+10
+99:+1:+100
+999:+1:+1000
+9999:+1:+10000
+99999:+1:+100000
+999999:+1:+1000000
+9999999:+1:+10000000
+99999999:+1:+100000000
+999999999:+1:+1000000000
+9999999999:+1:+10000000000
+99999999999:+1:+100000000000
+10:-1:+9
+100:-1:+99
+1000:-1:+999
+10000:-1:+9999
+100000:-1:+99999
+1000000:-1:+999999
+10000000:-1:+9999999
+100000000:-1:+99999999
+1000000000:-1:+999999999
+10000000000:-1:+9999999999
+123456789:+987654321:+1111111110
-123456789:+987654321:+864197532
-123456789:-987654321:-1111111110
+123456789:-987654321:-864197532
&bsub
abc:abc:NaN
abc:+0:NaN
+0:abc:NaN
+0:+0:+0
+1:+0:+1
+0:+1:-1
+1:+1:+0
-1:+0:-1
+0:-1:+1
-1:-1:+0
-1:+1:-2
+1:-1:+2
+9:+1:+8
+99:+1:+98
+999:+1:+998
+9999:+1:+9998
+99999:+1:+99998
+999999:+1:+999998
+9999999:+1:+9999998
+99999999:+1:+99999998
+999999999:+1:+999999998
+9999999999:+1:+9999999998
+99999999999:+1:+99999999998
+10:-1:+11
+100:-1:+101
+1000:-1:+1001
+10000:-1:+10001
+100000:-1:+100001
+1000000:-1:+1000001
+10000000:-1:+10000001
+100000000:-1:+100000001
+1000000000:-1:+1000000001
+10000000000:-1:+10000000001
+123456789:+987654321:-864197532
-123456789:+987654321:-1111111110
-123456789:-987654321:+864197532
+123456789:-987654321:+1111111110
&bmul
abc:abc:NaN
abc:+0:NaN
+0:abc:NaN
+0:+0:+0
+0:+1:+0
+1:+0:+0
+0:-1:+0
-1:+0:+0
+123456789123456789:+0:+0
+0:+123456789123456789:+0
-1:-1:+1
-1:+1:-1
+1:-1:-1
+1:+1:+1
+2:+3:+6
-2:+3:-6
+2:-3:-6
-2:-3:+6
+111:+111:+12321
+10101:+10101:+102030201
+1001001:+1001001:+1002003002001
+100010001:+100010001:+10002000300020001
+10000100001:+10000100001:+100002000030000200001
+11111111111:+9:+99999999999
+22222222222:+9:+199999999998
+33333333333:+9:+299999999997
+44444444444:+9:+399999999996
+55555555555:+9:+499999999995
+66666666666:+9:+599999999994
+77777777777:+9:+699999999993
+88888888888:+9:+799999999992
+99999999999:+9:+899999999991
&bdiv
abc:abc:NaN
abc:+1:abc:NaN
+1:abc:NaN
+0:+0:NaN
+0:+1:+0
+1:+0:NaN
+0:-1:+0
-1:+0:NaN
+1:+1:+1
-1:-1:+1
+1:-1:-1
-1:+1:-1
+1:+2:+0
+2:+1:+2
+1000000000:+9:+111111111
+2000000000:+9:+222222222
+3000000000:+9:+333333333
+4000000000:+9:+444444444
+5000000000:+9:+555555555
+6000000000:+9:+666666666
+7000000000:+9:+777777777
+8000000000:+9:+888888888
+9000000000:+9:+1000000000
+35500000:+113:+314159
+71000000:+226:+314159
+106500000:+339:+314159
+1000000000:+3:+333333333
+10:+5:+2
+100:+4:+25
+1000:+8:+125
+10000:+16:+625
+999999999999:+9:+111111111111
+999999999999:+99:+10101010101
+999999999999:+999:+1001001001
+999999999999:+9999:+100010001
+999999999999999:+99999:+10000100001
&bmod
abc:abc:NaN
abc:+1:abc:NaN
+1:abc:NaN
+0:+0:NaN
+0:+1:+0
+1:+0:NaN
+0:-1:+0
-1:+0:NaN
+1:+1:+0
-1:-1:+0
+1:-1:+0
-1:+1:+0
+1:+2:+1
+2:+1:+0
+1000000000:+9:+1
+2000000000:+9:+2
+3000000000:+9:+3
+4000000000:+9:+4
+5000000000:+9:+5
+6000000000:+9:+6
+7000000000:+9:+7
+8000000000:+9:+8
+9000000000:+9:+0
+35500000:+113:+33
+71000000:+226:+66
+106500000:+339:+99
+1000000000:+3:+1
+10:+5:+0
+100:+4:+0
+1000:+8:+0
+10000:+16:+0
+999999999999:+9:+0
+999999999999:+99:+0
+999999999999:+999:+0
+999999999999:+9999:+0
+999999999999999:+99999:+0
&bgcd
abc:abc:NaN
abc:+0:NaN
+0:abc:NaN
+0:+0:+0
+0:+1:+1
+1:+0:+1
+1:+1:+1
+2:+3:+1
+3:+2:+1
+100:+625:+25
+4096:+81:+1
--- NEW FILE: h2ph.t ---
#!./perl
# quickie tests to see if h2ph actually runs and does more or less what is
# expected
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
my $extracted_program = '../utils/h2ph'; # unix, nt, ...
if ($^O eq 'VMS') { $extracted_program = '[-.utils]h2ph.com'; }
if (!(-e $extracted_program)) {
print "1..0 # Skip: $extracted_program was not built\n";
exit 0;
}
print "1..2\n";
# quickly compare two text files
sub txt_compare {
local ($/, $A, $B);
for (($A,$B) = @_) { open(_,"<$_") ? $_ = <_> : die "$_ : $!"; close _ }
$A cmp $B;
}
# does it run?
$ok = system("$^X \"-I../lib\" $extracted_program -d. \"-Q\" lib/h2ph.h");
print(($ok == 0 ? "" : "not "), "ok 1\n");
# does it work? well, does it do what we expect? :-)
$ok = txt_compare("lib/h2ph.ph", "lib/h2ph.pht");
print(($ok == 0 ? "" : "not "), "ok 2\n");
# cleanup - should this be in an END block?
unlink("lib/h2ph.ph");
unlink("_h2ph_pre.ph");
--- NEW FILE: FileHandle.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
print "1..0\n";
exit 0;
}
if ($^O eq 'mpeix') {
print "1..0 # Skip: broken on MPE/iX\n";
exit 0;
}
}
use FileHandle;
use strict subs;
autoflush STDOUT 1;
$mystdout = new_from_fd FileHandle 1,"w";
$| = 1;
autoflush $mystdout;
print "1..12\n";
print $mystdout "ok ".fileno($mystdout)."\n";
$fh = (new FileHandle "./TEST", O_RDONLY
or new FileHandle "TEST", O_RDONLY)
and print "ok 2\n";
$buffer = <$fh>;
print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n";
ungetc $fh ord 'A';
CORE::read($fh, $buf,1);
print $buf eq 'A' ? "ok 4\n" : "not ok 4\n";
close $fh;
$fh = new FileHandle;
print "not " unless ($fh->open("< TEST") && <$fh> eq $buffer);
print "ok 5\n";
$fh->seek(0,0);
print "#possible mixed CRLF/LF in t/TEST\nnot " unless (<$fh> eq $buffer);
print "ok 6\n";
$fh->seek(0,2);
$line = <$fh>;
print "not " if (defined($line) || !$fh->eof);
print "ok 7\n";
print "not " unless ($fh->open("TEST","r") && !$fh->tell && $fh->close);
print "ok 8\n";
autoflush STDOUT 0;
print "not " if ($|);
print "ok 9\n";
autoflush STDOUT 1;
print "not " unless ($|);
print "ok 10\n";
if ($^O eq 'dos')
{
printf("ok %d\n",11);
exit(0);
}
($rd,$wr) = FileHandle::pipe;
if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32' || $^O eq 'NetWare' ||
$Config{d_fork} ne 'define') {
$wr->autoflush;
$wr->printf("ok %d\n",11);
print $rd->getline;
}
else {
if (fork) {
$wr->close;
print $rd->getline;
}
else {
$rd->close;
$wr->printf("ok %d\n",11);
exit(0);
}
}
print FileHandle->new('','r') ? "not ok 12\n" : "ok 12\n";
--- NEW FILE: CPAN.pm ---
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN;
$VERSION = '1.76_02';
$VERSION = eval $VERSION;
# $Id: CPAN.pm,v 1.2 2006-12-04 17:00:06 dslinux_cayenne Exp $
# only used during development:
$Revision = "";
# $Revision = "[".substr(q$Revision: 1.2 $, 10)."]";
use Carp ();
use Config ();
use Cwd ();
use DirHandle;
use Exporter ();
use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
use File::Basename ();
use File::Copy ();
use File::Find;
[...7129 lines suppressed...]
If a Makefile.PL requires special customization of libraries, prompts
the user for special input, etc. then you may find CPAN is not able to
build the distribution. In that case, you should attempt the
traditional method of building a Perl module package from a shell.
=head1 AUTHOR
Andreas Koenig E<lt>andreas.koenig at anima.deE<gt>
=head1 TRANSLATIONS
Kawai,Takanori provides a Japanese translation of this manpage at
http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm
=head1 SEE ALSO
perl(1), CPAN::Nox(3)
=cut
--- NEW FILE: finddepth.pl ---
# Usage:
# require "finddepth.pl";
#
# &finddepth('/foo','/bar');
#
# sub wanted { ... }
# where wanted does whatever you want. $dir contains the
# current directory name, and $_ the current filename within
# that directory. $name contains "$dir/$_". You are cd'ed
# to $dir when the function is called. The function may
# set $prune to prune the tree.
#
# This library is primarily for find2perl, which, when fed
#
# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
#
# spits out something like this
#
# sub wanted {
# /^\.nfs.*$/ &&
# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
# int(-M _) > 7 &&
# unlink($_)
# ||
# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
# $dev < 0 &&
# ($prune = 1);
# }
use File::Find ();
*name = *File::Find::name;
*prune = *File::Find::prune;
*dir = *File::Find::dir;
*topdir = *File::Find::topdir;
*topdev = *File::Find::topdev;
*topino = *File::Find::topino;
*topmode = *File::Find::topmode;
*topnlink = *File::Find::topnlink;
sub finddepth {
&File::Find::finddepth(\&wanted, @_);
}
1;
--- NEW FILE: PerlIO.pm ---
package PerlIO;
our $VERSION = '1.04';
# Map layer name to package that defines it
our %alias;
sub import
{
my $class = shift;
while (@_)
{
my $layer = shift;
if (exists $alias{$layer})
{
$layer = $alias{$layer}
}
else
{
$layer = "${class}::$layer";
}
eval "require $layer";
warn $@ if $@;
}
}
sub F_UTF8 () { 0x8000 }
1;
__END__
=head1 NAME
PerlIO - On demand loader for PerlIO layers and root of PerlIO::* name space
=head1 SYNOPSIS
open($fh,"<:crlf", "my.txt"); # support platform-native and CRLF text files
open($fh,"<","his.jpg"); # portably open a binary file for reading
binmode($fh);
Shell:
PERLIO=perlio perl ....
=head1 DESCRIPTION
When an undefined layer 'foo' is encountered in an C<open> or
C<binmode> layer specification then C code performs the equivalent of:
use PerlIO 'foo';
The perl code in PerlIO.pm then attempts to locate a layer by doing
require PerlIO::foo;
Otherwise the C<PerlIO> package is a place holder for additional
PerlIO related functions.
The following layers are currently defined:
=over 4
=item :unix
Lowest level layer which provides basic PerlIO operations in terms of
UNIX/POSIX numeric file descriptor calls
(open(), read(), write(), lseek(), close()).
=item :stdio
Layer which calls C<fread>, C<fwrite> and C<fseek>/C<ftell> etc. Note
that as this is "real" stdio it will ignore any layers beneath it and
got straight to the operating system via the C library as usual.
=item :perlio
A from scratch implementation of buffering for PerlIO. Provides fast
access to the buffer for C<sv_gets> which implements perl's readline/E<lt>E<gt>
and in general attempts to minimize data copying.
C<:perlio> will insert a C<:unix> layer below itself to do low level IO.
=item :crlf
A layer that implements DOS/Windows like CRLF line endings. On read
converts pairs of CR,LF to a single "\n" newline character. On write
converts each "\n" to a CR,LF pair. Note that this layer likes to be
one of its kind: it silently ignores attempts to be pushed into the
layer stack more than once.
It currently does I<not> mimic MS-DOS as far as treating of Control-Z
as being an end-of-file marker.
(Gory details follow) To be more exact what happens is this: after
pushing itself to the stack, the C<:crlf> layer checks all the layers
below itself to find the first layer that is capable of being a CRLF
layer but is not yet enabled to be a CRLF layer. If it finds such a
layer, it enables the CRLFness of that other deeper layer, and then
pops itself off the stack. If not, fine, use the one we just pushed.
The end result is that a C<:crlf> means "please enable the first CRLF
layer you can find, and if you can't find one, here would be a good
spot to place a new one."
Based on the C<:perlio> layer.
=item :mmap
A layer which implements "reading" of files by using C<mmap()> to
make (whole) file appear in the process's address space, and then
using that as PerlIO's "buffer". This I<may> be faster in certain
circumstances for large files, and may result in less physical memory
use when multiple processes are reading the same file.
Files which are not C<mmap()>-able revert to behaving like the C<:perlio>
layer. Writes also behave like C<:perlio> layer as C<mmap()> for write
needs extra house-keeping (to extend the file) which negates any advantage.
The C<:mmap> layer will not exist if platform does not support C<mmap()>.
=item :utf8
Declares that the stream accepts perl's internal encoding of
characters. (Which really is UTF-8 on ASCII machines, but is
UTF-EBCDIC on EBCDIC machines.) This allows any character perl can
represent to be read from or written to the stream. The UTF-X encoding
is chosen to render simple text parts (i.e. non-accented letters,
digits and common punctuation) human readable in the encoded file.
Here is how to write your native data out using UTF-8 (or UTF-EBCDIC)
and then read it back in.
open(F, ">:utf8", "data.utf");
print F $out;
close(F);
open(F, "<:utf8", "data.utf");
$in = <F>;
close(F);
=item :bytes
This is the inverse of C<:utf8> layer. It turns off the flag
on the layer below so that data read from it is considered to
be "octets" i.e. characters in range 0..255 only. Likewise
on output perl will warn if a "wide" character is written
to a such a stream.
=item :raw
The C<:raw> layer is I<defined> as being identical to calling
C<binmode($fh)> - the stream is made suitable for passing binary data
i.e. each byte is passed as-is. The stream will still be
buffered.
In Perl 5.6 and some books the C<:raw> layer (previously sometimes also
referred to as a "discipline") is documented as the inverse of the
C<:crlf> layer. That is no longer the case - other layers which would
alter binary nature of the stream are also disabled. If you want UNIX
line endings on a platform that normally does CRLF translation, but still
want UTF-8 or encoding defaults the appropriate thing to do is to add
C<:perlio> to PERLIO environment variable.
The implementation of C<:raw> is as a pseudo-layer which when "pushed"
pops itself and then any layers which do not declare themselves as suitable
for binary data. (Undoing :utf8 and :crlf are implemented by clearing
flags rather than popping layers but that is an implementation detail.)
As a consequence of the fact that C<:raw> normally pops layers
it usually only makes sense to have it as the only or first element in
a layer specification. When used as the first element it provides
a known base on which to build e.g.
open($fh,":raw:utf8",...)
will construct a "binary" stream, but then enable UTF-8 translation.
=item :pop
A pseudo layer that removes the top-most layer. Gives perl code
a way to manipulate the layer stack. Should be considered
as experimental. Note that C<:pop> only works on real layers
and will not undo the effects of pseudo layers like C<:utf8>.
An example of a possible use might be:
open($fh,...)
...
binmode($fh,":encoding(...)"); # next chunk is encoded
...
binmode($fh,":pop"); # back to un-encoded
A more elegant (and safer) interface is needed.
=item :win32
On Win32 platforms this I<experimental> layer uses native "handle" IO
rather than unix-like numeric file descriptor layer. Known to be
buggy as of perl 5.8.2.
=back
=head2 Custom Layers
It is possible to write custom layers in addition to the above builtin
ones, both in C/XS and Perl. Two such layers (and one example written
in Perl using the latter) come with the Perl distribution.
=over 4
=item :encoding
Use C<:encoding(ENCODING)> either in open() or binmode() to install
a layer that does transparently character set and encoding transformations,
for example from Shift-JIS to Unicode. Note that under C<stdio>
an C<:encoding> also enables C<:utf8>. See L<PerlIO::encoding>
for more information.
=item :via
Use C<:via(MODULE)> either in open() or binmode() to install a layer
that does whatever transformation (for example compression /
decompression, encryption / decryption) to the filehandle.
See L<PerlIO::via> for more information.
=back
=head2 Alternatives to raw
To get a binary stream an alternate method is to use:
open($fh,"whatever")
binmode($fh);
this has advantage of being backward compatible with how such things have
had to be coded on some platforms for years.
To get an un-buffered stream specify an unbuffered layer (e.g. C<:unix>)
in the open call:
open($fh,"<:unix",$path)
=head2 Defaults and how to override them
If the platform is MS-DOS like and normally does CRLF to "\n"
translation for text files then the default layers are :
unix crlf
(The low level "unix" layer may be replaced by a platform specific low
level layer.)
Otherwise if C<Configure> found out how to do "fast" IO using system's
stdio, then the default layers are:
unix stdio
Otherwise the default layers are
unix perlio
These defaults may change once perlio has been better tested and tuned.
The default can be overridden by setting the environment variable
PERLIO to a space separated list of layers (C<unix> or platform low
level layer is always pushed first).
This can be used to see the effect of/bugs in the various layers e.g.
cd .../perl/t
PERLIO=stdio ./perl harness
PERLIO=perlio ./perl harness
For the various value of PERLIO see L<perlrun/PERLIO>.
=head2 Querying the layers of filehandles
The following returns the B<names> of the PerlIO layers on a filehandle.
my @layers = PerlIO::get_layers($fh); # Or FH, *FH, "FH".
The layers are returned in the order an open() or binmode() call would
use them. Note that the "default stack" depends on the operating
system and on the Perl version, and both the compile-time and
runtime configurations of Perl.
The following table summarizes the default layers on UNIX-like and
DOS-like platforms and depending on the setting of the C<$ENV{PERLIO}>:
PERLIO UNIX-like DOS-like
------ --------- --------
unset / "" unix perlio / stdio [1] unix crlf
stdio unix perlio / stdio [1] stdio
perlio unix perlio unix perlio
mmap unix mmap unix mmap
# [1] "stdio" if Configure found out how to do "fast stdio" (depends
# on the stdio implementation) and in Perl 5.8, otherwise "unix perlio"
By default the layers from the input side of the filehandle is
returned, to get the output side use the optional C<output> argument:
my @layers = PerlIO::get_layers($fh, output => 1);
(Usually the layers are identical on either side of a filehandle but
for example with sockets there may be differences, or if you have
been using the C<open> pragma.)
There is no set_layers(), nor does get_layers() return a tied array
mirroring the stack, or anything fancy like that. This is not
accidental or unintentional. The PerlIO layer stack is a bit more
complicated than just a stack (see for example the behaviour of C<:raw>).
You are supposed to use open() and binmode() to manipulate the stack.
B<Implementation details follow, please close your eyes.>
The arguments to layers are by default returned in parenthesis after
the name of the layer, and certain layers (like C<utf8>) are not real
layers but instead flags on real layers: to get all of these returned
separately use the optional C<details> argument:
my @layer_and_args_and_flags = PerlIO::get_layers($fh, details => 1);
The result will be up to be three times the number of layers:
the first element will be a name, the second element the arguments
(unspecified arguments will be C<undef>), the third element the flags,
the fourth element a name again, and so forth.
B<You may open your eyes now.>
=head1 AUTHOR
Nick Ing-Simmons E<lt>nick at ing-simmons.netE<gt>
=head1 SEE ALSO
L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<perliol>,
L<Encode>
=cut
--- NEW FILE: warnings.pm ---
# -*- buffer-read-only: t -*-
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file was created by warnings.pl
# Any changes made here will be lost.
#
package warnings;
our $VERSION = '1.05';
=head1 NAME
warnings - Perl pragma to control optional warnings
=head1 SYNOPSIS
use warnings;
no warnings;
use warnings "all";
no warnings "all";
use warnings::register;
if (warnings::enabled()) {
warnings::warn("some warning");
}
if (warnings::enabled("void")) {
warnings::warn("void", "some warning");
}
if (warnings::enabled($object)) {
warnings::warn($object, "some warning");
}
warnings::warnif("some warning");
warnings::warnif("void", "some warning");
warnings::warnif($object, "some warning");
=head1 DESCRIPTION
The C<warnings> pragma is a replacement for the command line flag C<-w>,
but the pragma is limited to the enclosing block, while the flag is global.
See L<perllexwarn> for more information.
If no import list is supplied, all possible warnings are either enabled
or disabled.
A number of functions are provided to assist module authors.
=over 4
=item use warnings::register
Creates a new warnings category with the same name as the package where
the call to the pragma is used.
=item warnings::enabled()
Use the warnings category with the same name as the current package.
Return TRUE if that warnings category is enabled in the calling module.
Otherwise returns FALSE.
=item warnings::enabled($category)
Return TRUE if the warnings category, C<$category>, is enabled in the
calling module.
Otherwise returns FALSE.
=item warnings::enabled($object)
Use the name of the class for the object reference, C<$object>, as the
warnings category.
Return TRUE if that warnings category is enabled in the first scope
where the object is used.
Otherwise returns FALSE.
=item warnings::warn($message)
Print C<$message> to STDERR.
Use the warnings category with the same name as the current package.
If that warnings category has been set to "FATAL" in the calling module
then die. Otherwise return.
=item warnings::warn($category, $message)
Print C<$message> to STDERR.
If the warnings category, C<$category>, has been set to "FATAL" in the
calling module then die. Otherwise return.
=item warnings::warn($object, $message)
Print C<$message> to STDERR.
Use the name of the class for the object reference, C<$object>, as the
warnings category.
If that warnings category has been set to "FATAL" in the scope where C<$object>
is first used then die. Otherwise return.
=item warnings::warnif($message)
Equivalent to:
if (warnings::enabled())
{ warnings::warn($message) }
=item warnings::warnif($category, $message)
Equivalent to:
if (warnings::enabled($category))
{ warnings::warn($category, $message) }
=item warnings::warnif($object, $message)
Equivalent to:
if (warnings::enabled($object))
{ warnings::warn($object, $message) }
=back
See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
=cut
use Carp ();
our %Offsets = (
# Warnings Categories added in Perl 5.008
'all' => 0,
'closure' => 2,
'deprecated' => 4,
'exiting' => 6,
'glob' => 8,
'io' => 10,
'closed' => 12,
'exec' => 14,
'layer' => 16,
'newline' => 18,
'pipe' => 20,
'unopened' => 22,
'misc' => 24,
'numeric' => 26,
'once' => 28,
'overflow' => 30,
'pack' => 32,
'portable' => 34,
'recursion' => 36,
'redefine' => 38,
'regexp' => 40,
'severe' => 42,
'debugging' => 44,
'inplace' => 46,
'internal' => 48,
'malloc' => 50,
'signal' => 52,
'substr' => 54,
'syntax' => 56,
'ambiguous' => 58,
'bareword' => 60,
'digit' => 62,
'parenthesis' => 64,
'precedence' => 66,
'printf' => 68,
'prototype' => 70,
'qw' => 72,
'reserved' => 74,
'semicolon' => 76,
'taint' => 78,
'threads' => 80,
'uninitialized' => 82,
'unpack' => 84,
'untie' => 86,
'utf8' => 88,
'void' => 90,
'y2k' => 92,
);
our %Bits = (
'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
);
our %DeadBits = (
'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
);
$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
$LAST_BIT = 94 ;
$BYTES = 12 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
sub Croaker
{
local $Carp::CarpInternal{'warnings'};
delete $Carp::CarpInternal{'warnings'};
Carp::croak(@_);
}
sub bits
{
# called from B::Deparse.pm
push @_, 'all' unless @_;
my $mask;
my $catmask ;
my $fatal = 0 ;
my $no_fatal = 0 ;
foreach my $word ( @_ ) {
if ($word eq 'FATAL') {
$fatal = 1;
$no_fatal = 0;
}
elsif ($word eq 'NONFATAL') {
$fatal = 0;
$no_fatal = 1;
}
elsif ($catmask = $Bits{$word}) {
$mask |= $catmask ;
$mask |= $DeadBits{$word} if $fatal ;
$mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
}
else
{ Croaker("Unknown warnings category '$word'")}
}
return $mask ;
}
sub import
{
shift;
my $catmask ;
my $fatal = 0 ;
my $no_fatal = 0 ;
my $mask = ${^WARNING_BITS} ;
if (vec($mask, $Offsets{'all'}, 1)) {
$mask |= $Bits{'all'} ;
$mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
}
push @_, 'all' unless @_;
foreach my $word ( @_ ) {
if ($word eq 'FATAL') {
$fatal = 1;
$no_fatal = 0;
}
elsif ($word eq 'NONFATAL') {
$fatal = 0;
$no_fatal = 1;
}
elsif ($catmask = $Bits{$word}) {
$mask |= $catmask ;
$mask |= $DeadBits{$word} if $fatal ;
$mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
}
else
{ Croaker("Unknown warnings category '$word'")}
}
${^WARNING_BITS} = $mask ;
}
sub unimport
{
shift;
my $catmask ;
my $mask = ${^WARNING_BITS} ;
if (vec($mask, $Offsets{'all'}, 1)) {
$mask |= $Bits{'all'} ;
$mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
}
push @_, 'all' unless @_;
foreach my $word ( @_ ) {
if ($word eq 'FATAL') {
next;
}
elsif ($catmask = $Bits{$word}) {
$mask &= ~($catmask | $DeadBits{$word} | $All);
}
else
{ Croaker("Unknown warnings category '$word'")}
}
${^WARNING_BITS} = $mask ;
}
my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
sub __chk
{
my $category ;
my $offset ;
my $isobj = 0 ;
if (@_) {
# check the category supplied.
$category = shift ;
if (my $type = ref $category) {
Croaker("not an object")
if exists $builtin_type{$type};
$category = $type;
$isobj = 1 ;
}
$offset = $Offsets{$category};
Croaker("Unknown warnings category '$category'")
unless defined $offset;
}
else {
$category = (caller(1))[0] ;
$offset = $Offsets{$category};
Croaker("package '$category' not registered for warnings")
unless defined $offset ;
}
my $this_pkg = (caller(1))[0] ;
my $i = 2 ;
my $pkg ;
if ($isobj) {
while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
}
$i -= 2 ;
}
else {
for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
last if $pkg ne $this_pkg ;
}
$i = 2
if !$pkg || $pkg eq $this_pkg ;
}
my $callers_bitmask = (caller($i))[9] ;
return ($callers_bitmask, $offset, $i) ;
}
sub enabled
{
Croaker("Usage: warnings::enabled([category])")
unless @_ == 1 || @_ == 0 ;
my ($callers_bitmask, $offset, $i) = __chk(@_) ;
return 0 unless defined $callers_bitmask ;
return vec($callers_bitmask, $offset, 1) ||
vec($callers_bitmask, $Offsets{'all'}, 1) ;
}
sub warn
{
Croaker("Usage: warnings::warn([category,] 'message')")
unless @_ == 2 || @_ == 1 ;
my $message = pop ;
my ($callers_bitmask, $offset, $i) = __chk(@_) ;
Carp::croak($message)
if vec($callers_bitmask, $offset+1, 1) ||
vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
Carp::carp($message) ;
}
sub warnif
{
Croaker("Usage: warnings::warnif([category,] 'message')")
unless @_ == 2 || @_ == 1 ;
my $message = pop ;
my ($callers_bitmask, $offset, $i) = __chk(@_) ;
return
unless defined $callers_bitmask &&
(vec($callers_bitmask, $offset, 1) ||
vec($callers_bitmask, $Offsets{'all'}, 1)) ;
Carp::croak($message)
if vec($callers_bitmask, $offset+1, 1) ||
vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
Carp::carp($message) ;
}
1;
# ex: set ro:
--- NEW FILE: English.t ---
#!./perl -i.inplace
# note the extra switch, for the test below
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use Test::More tests => 55;
use English qw( -no_match_vars ) ;
use Config;
use Errno;
is( $PID, $$, '$PID' );
$_ = 1;
is( $ARG, $_, '$ARG' );
sub foo {
is($ARG[0], $_[0], '@ARG' );
}
foo(1);
"abc" =~ /b/;
ok( !$PREMATCH, '$PREMATCH undefined' );
ok( !$MATCH, '$MATCH undefined' );
ok( !$POSTMATCH, '$POSTMATCH undefined' );
$OFS = " ";
$ORS = "\n";
{
local(*IN, *OUT);
if ($^O ne 'dos') {
pipe(IN, OUT);
} else {
open(OUT, ">en.tmp");
}
select(OUT);
$| = 1;
print 'ok', '7';
# since $| is 1, this should be true
ok( $OUTPUT_AUTOFLUSH, '$OUTPUT_AUTOFLUSH should be true' );
my $close = close OUT;
ok( !($close) == $CHILD_ERROR, '$CHILD_ERROR should be false' );
open(IN, "<en.tmp") if ($^O eq 'dos');
my $foo = <IN>;
like( $foo, qr/ok 7/, '$OFS' );
# chomp is true because $ORS is "\n"
ok( chomp($foo), '$ORS should be \n' );
}
is( $FORMAT_NAME, 'OUT', '$FORMAT_NAME' );
is( $FORMAT_TOP_NAME, 'OUT_TOP', '$FORMAT_TOP_NAME' );
is( $FORMAT_FORMFEED, "\f", '$FORMAT_FORMFEED' );
is( $FORMAT_LINES_LEFT, 0, '$FORMAT_LINES_LEFT' );
is( $FORMAT_LINES_PER_PAGE, 60, '$FORMAT_LINES_PER_PAGE' );
is( $FORMAT_LINE_BREAK_CHARACTERS, " \n-", '$FORMAT_LINE_BREAK_CHARACTERS');
is( $FORMAT_PAGE_NUMBER, 0, '$FORMAT_PAGE_NUMBER' );
is( $ACCUMULATOR, $^A, '$ACCUMULATOR' );
undef $OUTPUT_FIELD_SEPARATOR;
if ($threads) { $" = "\n" } else { $LIST_SEPARATOR = "\n" };
@foo = (8, 9);
@foo = split(/\n/, "@foo");
is( $foo[0], 8, '$"' );
is( $foo[1], 9, '$LIST_SEPARATOR' );
undef $OUTPUT_RECORD_SEPARATOR;
eval 'NO SUCH FUNCTION';
like( $EVAL_ERROR, qr/method/, '$EVAL_ERROR' );
is( $UID, $<, '$UID' );
is( $GID, $(, '$GID' );
is( $EUID, $>, '$EUID' );
is( $EGID, $), '$EGID' );
is( $PROGRAM_NAME, $0, '$PROGRAM_NAME' );
is( $BASETIME, $^T, '$BASETIME' );
is( $PERL_VERSION, $^V, '$PERL_VERSION' );
is( $DEBUGGING, $^D, '$DEBUGGING' );
is( $WARNING, 0, '$WARNING' );
like( $EXECUTABLE_NAME, qr/perl/i, '$EXECUTABLE_NAME' );
is( $OSNAME, $Config{osname}, '$OSNAME' );
# may be non-portable
ok( $SYSTEM_FD_MAX >= 2, '$SYSTEM_FD_MAX should be at least 2' );
is( $INPLACE_EDIT, '.inplace', '$INPLACE_EDIT' );
'aabbcc' =~ /(.{2}).+(.{2})(?{ 9 })/;
is( $LAST_PAREN_MATCH, 'cc', '$LAST_PARENT_MATCH' );
is( $LAST_REGEXP_CODE_RESULT, 9, '$LAST_REGEXP_CODE_RESULT' );
is( $LAST_MATCH_START[1], 0, '@LAST_MATCH_START' );
is( $LAST_MATCH_END[1], 2, '@LAST_MATCH_END' );
ok( !$PERLDB, '$PERLDB should be false' );
{
local $INPUT_RECORD_SEPARATOR = "\n\n";
like( <DATA>, qr/a paragraph./, '$INPUT_RECORD_SEPARATOR' );
}
like( <DATA>, qr/second paragraph..\z/s, '$INPUT_RECORD_SEPARATOR' );
is( $INPUT_LINE_NUMBER, 2, '$INPUT_LINE_NUMBER' );
my %hash;
$SUBSCRIPT_SEPARATOR = '|';
$hash{d,e,f} = 1;
$SUBSEP = ',';
$hash{'a', 'b', 'c'} = 1;
my @keys = sort keys %hash;
is( $keys[0], 'a,b,c', '$SUBSCRIPT_SEPARATOR' );
is( $keys[1], 'd|e|f', '$SUBSCRIPT_SEPARATOR' );
eval { is( $EXCEPTIONS_BEING_CAUGHT, 1, '$EXCEPTIONS_BEING_CAUGHT' ) };
ok( !$EXCEPTIONS_BEING_CAUGHT, '$EXCEPTIONS_BEING_CAUGHT should be false' );
eval { local *F; my $f = 'asdasdasd'; ++$f while -e $f; open(F, $f); };
is( $OS_ERROR, $ERRNO, '$OS_ERROR' );
ok( $OS_ERROR{ENOENT}, '%OS_ERROR (ENOENT should be set)' );
package B;
use English;
"abc" =~ /b/;
main::is( $PREMATCH, 'a', '$PREMATCH defined' );
main::is( $MATCH, 'b', '$MATCH defined' );
main::is( $POSTMATCH, 'c', '$POSTMATCH defined' );
{
my $s = "xyz";
$s =~ s/y/t$MATCH/;
main::is( $s, "xtyz", '$MATCH defined in right side of s///' );
}
package C;
use English qw( -no_match_vars ) ;
"abc" =~ /b/;
main::ok( !$PREMATCH, '$PREMATCH disabled' );
main::ok( !$MATCH, '$MATCH disabled' );
main::ok( !$POSTMATCH, '$POSTMATCH disabled' );
__END__
This is a line.
This is a paragraph.
This is a second paragraph.
It has several lines.
--- NEW FILE: dbm_filter_util.pl ---
use strict;
use warnings;
sub StoreData
{
my $hashref = shift ;
my $store = shift ;
my (undef, $file, $line) = caller;
ok 1, "StoreData called from $file, line $line";
ok ref $store eq 'HASH', "Store Data is a hash reference";
ok tied %$hashref, "Storing to tied hash";
while (my ($k, $v) = each %$store) {
no warnings 'uninitialized';
#diag "Stored [$k][$v]";
$$hashref{$k} = $v ;
}
}
sub VerifyData
{
my $hashref = shift ;
my $expected = shift ;
my %expected = %$expected;
my (undef, $file, $line) = caller;
ok 1, "VerifyData called from $file, line $line";
ok ref $expected eq 'HASH', "Expected data is a hash reference";
ok tied %$hashref, "Verifying a tied hash";
my %bad = ();
while (my ($k, $v) = each %$hashref) {
no warnings 'uninitialized';
if ($expected{$k} eq $v) {
#diag "Match [$k][$v]";
delete $expected{$k} ;
}
else {
#diag "No Match [$k][$v]";
$bad{$k} = $v;
}
}
if( ! ok(keys(%bad) + keys(%expected) == 0, "Expected == Actual") ) {
my $bad = "Expected does not match actual\n";
if (keys %expected ) {
$bad .=" No Match from Expected:\n" ;
while (my ($k, $v) = each %expected) {
$bad .= "\t'$k' =>\t'$v'\n";
}
}
if (keys %bad ) {
$bad .= "\n No Match from Actual:\n" ;
while (my ($k, $v) = each %bad) {
no warnings 'uninitialized';
$bad .= "\t'$k' =>\t'$v'\n";
}
}
diag "${bad}\n" ;
}
}
1;
--- NEW FILE: DB.pm ---
#
# Documentation is at the __END__
#
package DB;
# "private" globals
my ($running, $ready, $deep, $usrctxt, $evalarg,
@stack, @saved, @skippkg, @clients);
my $preeval = {};
my $posteval = {};
my $ineval = {};
####
#
# Globals - must be defined at startup so that clients can refer to
# them right after a C<require DB;>
#
####
BEGIN {
# these are hardcoded in perl source (some are magical)
$DB::sub = ''; # name of current subroutine
%DB::sub = (); # "filename:fromline-toline" for every known sub
$DB::single = 0; # single-step flag (set it to 1 to enable stops in BEGIN/use)
$DB::signal = 0; # signal flag (will cause a stop at the next line)
$DB::trace = 0; # are we tracing through subroutine calls?
@DB::args = (); # arguments of current subroutine or @ARGV array
@DB::dbline = (); # list of lines in currently loaded file
%DB::dbline = (); # actions in current file (keyed by line number)
@DB::ret = (); # return value of last sub executed in list context
$DB::ret = ''; # return value of last sub executed in scalar context
# other "public" globals
$DB::package = ''; # current package space
$DB::filename = ''; # current filename
$DB::subname = ''; # currently executing sub (fullly qualified name)
$DB::lineno = ''; # current line number
$DB::VERSION = $DB::VERSION = '1.01';
# initialize private globals to avoid warnings
$running = 1; # are we running, or are we stopped?
@stack = (0);
@clients = ();
$deep = 100;
$ready = 0;
@saved = ();
@skippkg = ();
$usrctxt = '';
$evalarg = '';
}
####
# entry point for all subroutine calls
#
sub sub {
push(@stack, $DB::single);
$DB::single &= 1;
$DB::single |= 4 if $#stack == $deep;
if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) {
&$DB::sub;
$DB::single |= pop(@stack);
$DB::ret = undef;
}
elsif (wantarray) {
@DB::ret = &$DB::sub;
$DB::single |= pop(@stack);
@DB::ret;
}
else {
$DB::ret = &$DB::sub;
$DB::single |= pop(@stack);
$DB::ret;
}
}
####
# this is called by perl for every statement
#
sub DB {
return unless $ready;
&save;
($DB::package, $DB::filename, $DB::lineno) = caller;
return if @skippkg and grep { $_ eq $DB::package } @skippkg;
$usrctxt = "package $DB::package;"; # this won't let them modify, alas
local(*DB::dbline) = "::_<$DB::filename";
# we need to check for pseudofiles on Mac OS (these are files
# not attached to a filename, but instead stored in Dev:Pseudo)
# since this is done late, $DB::filename will be "wrong" after
# skippkg
if ($^O eq 'MacOS' && $#DB::dbline < 0) {
$DB::filename = 'Dev:Pseudo';
*DB::dbline = "::_<$DB::filename";
}
my ($stop, $action);
if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
if ($stop eq '1') {
$DB::signal |= 1;
}
else {
$stop = 0 unless $stop; # avoid un_init warning
$evalarg = "\$DB::signal |= do { $stop; }"; &eval;
$DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/; # clear any temp breakpt
}
}
if ($DB::single || $DB::trace || $DB::signal) {
$DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #';
DB->loadfile($DB::filename, $DB::lineno);
}
$evalarg = $action, &eval if $action;
if ($DB::single || $DB::signal) {
_outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4;
$DB::single = 0;
$DB::signal = 0;
$running = 0;
&eval if ($evalarg = DB->prestop);
my $c;
for $c (@clients) {
# perform any client-specific prestop actions
&eval if ($evalarg = $c->cprestop);
# Now sit in an event loop until something sets $running
do {
$c->idle; # call client event loop; must not block
if ($running == 2) { # client wants something eval-ed
&eval if ($evalarg = $c->evalcode);
$running = 0;
}
} until $running;
# perform any client-specific poststop actions
&eval if ($evalarg = $c->cpoststop);
}
&eval if ($evalarg = DB->poststop);
}
($@, $!, $,, $/, $\, $^W) = @saved;
();
}
####
# this takes its argument via $evalarg to preserve current @_
#
sub eval {
($@, $!, $,, $/, $\, $^W) = @saved;
eval "$usrctxt $evalarg; &DB::save";
_outputall($@) if $@;
}
###############################################################################
# no compile-time subroutine call allowed before this point #
###############################################################################
use strict; # this can run only after DB() and sub() are defined
sub save {
@saved = ($@, $!, $,, $/, $\, $^W);
$, = ""; $/ = "\n"; $\ = ""; $^W = 0;
}
sub catch {
for (@clients) { $_->awaken; }
$DB::signal = 1;
$ready = 1;
}
####
#
# Client callable (read inheritable) methods defined after this point
#
####
sub register {
my $s = shift;
$s = _clientname($s) if ref($s);
push @clients, $s;
}
sub done {
my $s = shift;
$s = _clientname($s) if ref($s);
@clients = grep {$_ ne $s} @clients;
$s->cleanup;
# $running = 3 unless @clients;
exit(0) unless @clients;
}
sub _clientname {
my $name = shift;
"$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
return $1;
}
sub next {
my $s = shift;
$DB::single = 2;
$running = 1;
}
sub step {
my $s = shift;
$DB::single = 1;
$running = 1;
}
sub cont {
my $s = shift;
my $i = shift;
$s->set_tbreak($i) if $i;
for ($i = 0; $i <= $#stack;) {
$stack[$i++] &= ~1;
}
$DB::single = 0;
$running = 1;
}
####
# XXX caller must experimentally determine $i (since it depends
# on how many client call frames are between this call and the DB call).
# Such is life.
#
sub ret {
my $s = shift;
my $i = shift; # how many levels to get to DB sub
$i = 0 unless defined $i;
$stack[$#stack-$i] |= 1;
$DB::single = 0;
$running = 1;
}
####
# XXX caller must experimentally determine $start (since it depends
# on how many client call frames are between this call and the DB call).
# Such is life.
#
sub backtrace {
my $self = shift;
my $start = shift;
my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i);
$start = 1 unless $start;
for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
@a = @DB::args;
for (@a) {
s/'/\\'/g;
s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
}
$w = $w ? '@ = ' : '$ = ';
$a = $h ? '(' . join(', ', @a) . ')' : '';
$e =~ s/\n\s*\;\s*\Z// if $e;
$e =~ s/[\\\']/\\$1/g if $e;
if ($r) {
$s = "require '$e'";
} elsif (defined $r) {
$s = "eval '$e'";
} elsif ($s eq '(eval)') {
$s = "eval {...}";
}
$f = "file `$f'" unless $f eq '-e';
push @ret, "$w&$s$a from $f line $l";
last if $DB::signal;
}
return @ret;
}
sub _outputall {
my $c;
for $c (@clients) {
$c->output(@_);
}
}
sub trace_toggle {
my $s = shift;
$DB::trace = !$DB::trace;
}
####
# without args: returns all defined subroutine names
# with subname args: returns a listref [file, start, end]
#
sub subs {
my $s = shift;
if (@_) {
my(@ret) = ();
while (@_) {
my $name = shift;
push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/]
if exists $DB::sub{$name};
}
return @ret;
}
return keys %DB::sub;
}
####
# first argument is a filename whose subs will be returned
# if a filename is not supplied, all subs in the current
# filename are returned.
#
sub filesubs {
my $s = shift;
my $fname = shift;
$fname = $DB::filename unless $fname;
return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub;
}
####
# returns a list of all filenames that DB knows about
#
sub files {
my $s = shift;
my(@f) = grep(m|^_<|, keys %main::);
return map { substr($_,2) } @f;
}
####
# returns reference to an array holding the lines in currently
# loaded file
#
sub lines {
my $s = shift;
return \@DB::dbline;
}
####
# loadfile($file, $line)
#
sub loadfile {
my $s = shift;
my($file, $line) = @_;
if (!defined $main::{'_<' . $file}) {
my $try;
if (($try) = grep(m|^_<.*$file|, keys %main::)) {
$file = substr($try,2);
}
}
if (defined($main::{'_<' . $file})) {
my $c;
# _outputall("Loading file $file..");
*DB::dbline = "::_<$file";
$DB::filename = $file;
for $c (@clients) {
# print "2 ", $file, '|', $line, "\n";
$c->showfile($file, $line);
}
return $file;
}
return undef;
}
sub lineevents {
my $s = shift;
my $fname = shift;
my(%ret) = ();
my $i;
$fname = $DB::filename unless $fname;
local(*DB::dbline) = "::_<$fname";
for ($i = 1; $i <= $#DB::dbline; $i++) {
$ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})]
if defined $DB::dbline{$i};
}
return %ret;
}
sub set_break {
my $s = shift;
my $i = shift;
my $cond = shift;
$i ||= $DB::lineno;
$cond ||= '1';
$i = _find_subline($i) if ($i =~ /\D/);
$s->output("Subroutine not found.\n") unless $i;
if ($i) {
if ($DB::dbline[$i] == 0) {
$s->output("Line $i not breakable.\n");
}
else {
$DB::dbline{$i} =~ s/^[^\0]*/$cond/;
}
}
}
sub set_tbreak {
my $s = shift;
my $i = shift;
$i = _find_subline($i) if ($i =~ /\D/);
$s->output("Subroutine not found.\n") unless $i;
if ($i) {
if ($DB::dbline[$i] == 0) {
$s->output("Line $i not breakable.\n");
}
else {
$DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
}
}
}
sub _find_subline {
my $name = shift;
$name =~ s/\'/::/;
$name = "${DB::package}\:\:" . $name if $name !~ /::/;
$name = "main" . $name if substr($name,0,2) eq "::";
my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/);
if ($from) {
local *DB::dbline = "::_<$fname";
++$from while $DB::dbline[$from] == 0 && $from < $to;
return $from;
}
return undef;
}
sub clr_breaks {
my $s = shift;
my $i;
if (@_) {
while (@_) {
$i = shift;
$i = _find_subline($i) if ($i =~ /\D/);
$s->output("Subroutine not found.\n") unless $i;
if (defined $DB::dbline{$i}) {
$DB::dbline{$i} =~ s/^[^\0]+//;
if ($DB::dbline{$i} =~ s/^\0?$//) {
delete $DB::dbline{$i};
}
}
}
}
else {
for ($i = 1; $i <= $#DB::dbline ; $i++) {
if (defined $DB::dbline{$i}) {
$DB::dbline{$i} =~ s/^[^\0]+//;
if ($DB::dbline{$i} =~ s/^\0?$//) {
delete $DB::dbline{$i};
}
}
}
}
}
sub set_action {
my $s = shift;
my $i = shift;
my $act = shift;
$i = _find_subline($i) if ($i =~ /\D/);
$s->output("Subroutine not found.\n") unless $i;
if ($i) {
if ($DB::dbline[$i] == 0) {
$s->output("Line $i not actionable.\n");
}
else {
$DB::dbline{$i} =~ s/\0[^\0]*//;
$DB::dbline{$i} .= "\0" . $act;
}
}
}
sub clr_actions {
my $s = shift;
my $i;
if (@_) {
while (@_) {
my $i = shift;
$i = _find_subline($i) if ($i =~ /\D/);
$s->output("Subroutine not found.\n") unless $i;
if ($i && $DB::dbline[$i] != 0) {
$DB::dbline{$i} =~ s/\0[^\0]*//;
delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
}
}
}
else {
for ($i = 1; $i <= $#DB::dbline ; $i++) {
if (defined $DB::dbline{$i}) {
$DB::dbline{$i} =~ s/\0[^\0]*//;
delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
}
}
}
}
sub prestop {
my ($client, $val) = @_;
return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
}
sub poststop {
my ($client, $val) = @_;
return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
}
#
# "pure virtual" methods
#
# client-specific pre/post-stop actions.
sub cprestop {}
sub cpoststop {}
# client complete startup
sub awaken {}
sub skippkg {
my $s = shift;
push @skippkg, @_ if @_;
}
sub evalcode {
my ($client, $val) = @_;
if (defined $val) {
$running = 2; # hand over to DB() to evaluate in its context
$ineval->{$client} = $val;
}
return $ineval->{$client};
}
sub ready {
my $s = shift;
return $ready = 1;
}
# stubs
sub init {}
sub stop {}
sub idle {}
sub cleanup {}
sub output {}
#
# client init
#
for (@clients) { $_->init }
$SIG{'INT'} = \&DB::catch;
# disable this if stepping through END blocks is desired
# (looks scary and deconstructivist with Swat)
END { $ready = 0 }
1;
__END__
=head1 NAME
DB - programmatic interface to the Perl debugging API (draft, subject to
change)
=head1 SYNOPSIS
package CLIENT;
use DB;
@ISA = qw(DB);
# these (inherited) methods can be called by the client
CLIENT->register() # register a client package name
CLIENT->done() # de-register from the debugging API
CLIENT->skippkg('hide::hide') # ask DB not to stop in this package
CLIENT->cont([WHERE]) # run some more (until BREAK or another breakpt)
CLIENT->step() # single step
CLIENT->next() # step over
CLIENT->ret() # return from current subroutine
CLIENT->backtrace() # return the call stack description
CLIENT->ready() # call when client setup is done
CLIENT->trace_toggle() # toggle subroutine call trace mode
CLIENT->subs([SUBS]) # return subroutine information
CLIENT->files() # return list of all files known to DB
CLIENT->lines() # return lines in currently loaded file
CLIENT->loadfile(FILE,LINE) # load a file and let other clients know
CLIENT->lineevents() # return info on lines with actions
CLIENT->set_break([WHERE],[COND])
CLIENT->set_tbreak([WHERE])
CLIENT->clr_breaks([LIST])
CLIENT->set_action(WHERE,ACTION)
CLIENT->clr_actions([LIST])
CLIENT->evalcode(STRING) # eval STRING in executing code's context
CLIENT->prestop([STRING]) # execute in code context before stopping
CLIENT->poststop([STRING])# execute in code context before resuming
# These methods will be called at the appropriate times.
# Stub versions provided do nothing.
# None of these can block.
CLIENT->init() # called when debug API inits itself
CLIENT->stop(FILE,LINE) # when execution stops
CLIENT->idle() # while stopped (can be a client event loop)
CLIENT->cleanup() # just before exit
CLIENT->output(LIST) # called to print any output that API must show
=head1 DESCRIPTION
Perl debug information is frequently required not just by debuggers,
but also by modules that need some "special" information to do their
job properly, like profilers.
This module abstracts and provides all of the hooks into Perl internal
debugging functionality, so that various implementations of Perl debuggers
(or packages that want to simply get at the "privileged" debugging data)
can all benefit from the development of this common code. Currently used
by Swat, the perl/Tk GUI debugger.
Note that multiple "front-ends" can latch into this debugging API
simultaneously. This is intended to facilitate things like
debugging with a command line and GUI at the same time, debugging
debuggers etc. [Sounds nice, but this needs some serious support -- GSAR]
In particular, this API does B<not> provide the following functions:
=over 4
=item *
data display
=item *
command processing
=item *
command alias management
=item *
user interface (tty or graphical)
=back
These are intended to be services performed by the clients of this API.
This module attempts to be squeaky clean w.r.t C<use strict;> and when
warnings are enabled.
=head2 Global Variables
The following "public" global names can be read by clients of this API.
Beware that these should be considered "readonly".
=over 8
=item $DB::sub
Name of current executing subroutine.
=item %DB::sub
The keys of this hash are the names of all the known subroutines. Each value
is an encoded string that has the sprintf(3) format
C<("%s:%d-%d", filename, fromline, toline)>.
=item $DB::single
Single-step flag. Will be true if the API will stop at the next statement.
=item $DB::signal
Signal flag. Will be set to a true value if a signal was caught. Clients may
check for this flag to abort time-consuming operations.
=item $DB::trace
This flag is set to true if the API is tracing through subroutine calls.
=item @DB::args
Contains the arguments of current subroutine, or the C<@ARGV> array if in the
toplevel context.
=item @DB::dbline
List of lines in currently loaded file.
=item %DB::dbline
Actions in current file (keys are line numbers). The values are strings that
have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>.
=item $DB::package
Package namespace of currently executing code.
=item $DB::filename
Currently loaded filename.
=item $DB::subname
Fully qualified name of currently executing subroutine.
=item $DB::lineno
Line number that will be executed next.
=back
=head2 API Methods
The following are methods in the DB base class. A client must
access these methods by inheritance (*not* by calling them directly),
since the API keeps track of clients through the inheritance
mechanism.
=over 8
=item CLIENT->register()
register a client object/package
=item CLIENT->evalcode(STRING)
eval STRING in executing code context
=item CLIENT->skippkg('D::hide')
ask DB not to stop in these packages
=item CLIENT->run()
run some more (until a breakpt is reached)
=item CLIENT->step()
single step
=item CLIENT->next()
step over
=item CLIENT->done()
de-register from the debugging API
=back
=head2 Client Callback Methods
The following "virtual" methods can be defined by the client. They will
be called by the API at appropriate points. Note that unless specified
otherwise, the debug API only defines empty, non-functional default versions
of these methods.
=over 8
=item CLIENT->init()
Called after debug API inits itself.
=item CLIENT->prestop([STRING])
Usually inherited from DB package. If no arguments are passed,
returns the prestop action string.
=item CLIENT->stop()
Called when execution stops (w/ args file, line).
=item CLIENT->idle()
Called while stopped (can be a client event loop).
=item CLIENT->poststop([STRING])
Usually inherited from DB package. If no arguments are passed,
returns the poststop action string.
=item CLIENT->evalcode(STRING)
Usually inherited from DB package. Ask for a STRING to be C<eval>-ed
in executing code context.
=item CLIENT->cleanup()
Called just before exit.
=item CLIENT->output(LIST)
Called when API must show a message (warnings, errors etc.).
=back
=head1 BUGS
The interface defined by this module is missing some of the later additions
to perl's debugging functionality. As such, this interface should be considered
highly experimental and subject to change.
=head1 AUTHOR
Gurusamy Sarathy gsar at activestate.com
This code heavily adapted from an early version of perl5db.pl attributable
to Larry Wall and the Perl Porters.
=cut
--- NEW FILE: pwd.pl ---
;# pwd.pl - keeps track of current working directory in PWD environment var
;#
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Cwd
#
;# $RCSfile: pwd.pl,v $$Revision: 1.2 $$Date: 2006-12-04 17:00:16 $
;#
;# $Log: pwd.pl,v $
;# Revision 1.2 2006-12-04 17:00:16 dslinux_cayenne
;# Adding fresh perl source to HEAD to branch from
;#
;#
;# Usage:
;# require "pwd.pl";
;# &initpwd;
;# ...
;# &chdir($newdir);
package pwd;
sub main'initpwd {
if ($ENV{'PWD'}) {
local($dd,$di) = stat('.');
local($pd,$pi) = stat($ENV{'PWD'});
if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
chop($ENV{'PWD'} = `pwd`);
}
}
else {
chop($ENV{'PWD'} = `pwd`);
}
if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
local($pd,$pi) = stat($2);
local($dd,$di) = stat($1);
if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
$ENV{'PWD'}="$2$3";
}
}
}
sub main'chdir {
local($newdir) = shift;
$newdir =~ s|/{2,}|/|g;
if (chdir $newdir) {
if ($newdir =~ m#^/#) {
$ENV{'PWD'} = $newdir;
}
else {
local(@curdir) = split(m#/#,$ENV{'PWD'});
@curdir = '' unless @curdir;
foreach $component (split(m#/#, $newdir)) {
next if $component eq '.';
pop(@curdir),next if $component eq '..';
push(@curdir,$component);
}
$ENV{'PWD'} = join('/', at curdir) || '/';
}
}
else {
0;
}
}
1;
--- NEW FILE: importenv.pl ---
;# $RCSfile: importenv.pl,v $$Revision: 1.2 $$Date: 2006-12-04 17:00:15 $
;# This file, when interpreted, pulls the environment into normal variables.
;# Usage:
;# require 'importenv.pl';
;# or
;# #include <importenv.pl>
local($tmp,$key) = '';
foreach $key (keys(%ENV)) {
$tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
}
eval $tmp;
1;
--- NEW FILE: integer.pm ---
package integer;
our $VERSION = '1.00';
=head1 NAME
integer - Perl pragma to use integer arithmetic instead of floating point
=head1 SYNOPSIS
use integer;
$x = 10/3;
# $x is now 3, not 3.33333333333333333
=head1 DESCRIPTION
This tells the compiler to use integer operations from here to the end
of the enclosing BLOCK. On many machines, this doesn't matter a great
deal for most computations, but on those without floating point
hardware, it can make a big difference in performance.
Note that this only affects how most of the arithmetic and relational
B<operators> handle their operands and results, and B<not> how all
numbers everywhere are treated. Specifically, C<use integer;> has the
effect that before computing the results of the arithmetic operators
(+, -, *, /, %, +=, -=, *=, /=, %=, and unary minus), the comparison
operators (<, <=, >, >=, ==, !=, <=>), and the bitwise operators (|, &,
^, <<, >>, |=, &=, ^=, <<=, >>=), the operands have their fractional
portions truncated (or floored), and the result will have its
fractional portion truncated as well. In addition, the range of
operands and results is restricted to that of familiar two's complement
integers, i.e., -(2**31) .. (2**31-1) on 32-bit architectures, and
-(2**63) .. (2**63-1) on 64-bit architectures. For example, this code
use integer;
$x = 5.8;
$y = 2.5;
$z = 2.7;
$a = 2**31 - 1; # Largest positive integer on 32-bit machines
$, = ", ";
print $x, -$x, $x + $y, $x - $y, $x / $y, $x * $y, $y == $z, $a, $a + 1;
will print: 5.8, -5, 7, 3, 2, 10, 1, 2147483647, -2147483648
Note that $x is still printed as having its true non-integer value of
5.8 since it wasn't operated on. And note too the wrap-around from the
largest positive integer to the largest negative one. Also, arguments
passed to functions and the values returned by them are B<not> affected
by C<use integer;>. E.g.,
srand(1.5);
$, = ", ";
print sin(.5), cos(.5), atan2(1,2), sqrt(2), rand(10);
will give the same result with or without C<use integer;> The power
operator C<**> is also not affected, so that 2 ** .5 is always the
square root of 2. Now, it so happens that the pre- and post- increment
and decrement operators, ++ and --, are not affected by C<use integer;>
either. Some may rightly consider this to be a bug -- but at least it's
a long-standing one.
Finally, C<use integer;> also has an additional affect on the bitwise
operators. Normally, the operands and results are treated as
B<unsigned> integers, but with C<use integer;> the operands and results
are B<signed>. This means, among other things, that ~0 is -1, and -2 &
-5 is -6.
Internally, native integer arithmetic (as provided by your C compiler)
is used. This means that Perl's own semantics for arithmetic
operations may not be preserved. One common source of trouble is the
modulus of negative numbers, which Perl does one way, but your hardware
may do another.
% perl -le 'print (4 % -3)'
-2
% perl -Minteger -le 'print (4 % -3)'
1
See L<perlmodlib/"Pragmatic Modules">, L<perlop/"Integer Arithmetic">
=cut
$integer::hint_bits = 0x1;
sub import {
$^H |= $integer::hint_bits;
}
sub unimport {
$^H &= ~$integer::hint_bits;
}
1;
--- NEW FILE: less.pm ---
package less;
our $VERSION = '0.01';
=head1 NAME
less - perl pragma to request less of something from the compiler
=head1 SYNOPSIS
use less; # unimplemented
=head1 DESCRIPTION
Currently unimplemented, this may someday be a compiler directive
to make certain trade-offs, such as perhaps
use less 'memory';
use less 'CPU';
use less 'fat';
=cut
1;
--- NEW FILE: termcap.pl ---
;# $RCSfile: termcap.pl,v $$Revision: 1.2 $$Date: 2006-12-04 17:00:17 $
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Term::Cap
#
;#
;# Usage:
;# require 'ioctl.pl';
;# ioctl(TTY,$TIOCGETP,$foo);
;# ($ispeed,$ospeed) = unpack('cc',$foo);
;# require 'termcap.pl';
;# &Tgetent('vt100'); # sets $TC{'cm'}, etc.
;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
;#
sub Tgetent {
local($TERM) = @_;
local($TERMCAP,$_,$entry,$loop,$field);
# warn "Tgetent: no ospeed set" unless $ospeed;
foreach $key (keys %TC) {
delete $TC{$key};
}
$TERM = $ENV{'TERM'} unless $TERM;
$TERM =~ s/(\W)/\\$1/g;
$TERMCAP = $ENV{'TERMCAP'};
$TERMCAP = '/etc/termcap' unless $TERMCAP;
if ($TERMCAP !~ m:^/:) {
if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
$TERMCAP = '/etc/termcap';
}
}
if ($TERMCAP =~ m:^/:) {
$entry = '';
do {
$loop = "
open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
while (<TERMCAP>) {
next if /^#/;
next if /^\t/;
if (/(^|\\|)${TERM}[:\\|]/) {
chop;
while (chop eq '\\\\') {
\$_ .= <TERMCAP>;
chop;
}
\$_ .= ':';
last;
}
}
close TERMCAP;
\$entry .= \$_;
";
eval $loop;
} while s/:tc=([^:]+):/:/ && ($TERM = $1);
$TERMCAP = $entry;
}
foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
if ($field =~ /^\w\w$/) {
$TC{$field} = 1;
}
elsif ($field =~ /^(\w\w)#(.*)/) {
$TC{$1} = $2 if $TC{$1} eq '';
}
elsif ($field =~ /^(\w\w)=(.*)/) {
$entry = $1;
$_ = $2;
s/\\E/\033/g;
s/\\(200)/pack('c',0)/eg; # NUL character
s/\\(0\d\d)/pack('c',oct($1))/eg; # octal
s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg; # hex
s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
s/\\n/\n/g;
s/\\r/\r/g;
s/\\t/\t/g;
s/\\b/\b/g;
s/\\f/\f/g;
s/\\\^/\377/g;
s/\^\?/\177/g;
s/\^(.)/pack('c',ord($1) & 31)/eg;
s/\\(.)/$1/g;
s/\377/^/g;
$TC{$entry} = $_ if $TC{$entry} eq '';
}
}
$TC{'pc'} = "\0" if $TC{'pc'} eq '';
$TC{'bc'} = "\b" if $TC{'bc'} eq '';
}
@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
sub Tputs {
local($string,$affcnt,$FH) = @_;
local($ms);
if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
$ms = $1;
$ms *= $affcnt if $2;
$string = $3;
$decr = $Tputs[$ospeed];
if ($decr > .1) {
$ms += $decr / 2;
$string .= $TC{'pc'} x ($ms / $decr);
}
}
print $FH $string if $FH;
$string;
}
sub Tgoto {
local($string) = shift(@_);
local($result) = '';
local($after) = '';
local($code,$tmp) = @_;
local(@tmp);
@tmp = ($tmp,$code);
local($online) = 0;
while ($string =~ /^([^%]*)%(.)(.*)/) {
$result .= $1;
$code = $2;
$string = $3;
if ($code eq 'd') {
$result .= sprintf("%d",shift(@tmp));
}
elsif ($code eq '.') {
$tmp = shift(@tmp);
if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
if ($online) {
++$tmp, $after .= $TC{'up'} if $TC{'up'};
}
else {
++$tmp, $after .= $TC{'bc'};
}
}
$result .= sprintf("%c",$tmp);
$online = !$online;
}
elsif ($code eq '+') {
$result .= sprintf("%c",shift(@tmp)+ord($string));
$string = substr($string,1,99);
$online = !$online;
}
elsif ($code eq 'r') {
($code,$tmp) = @tmp;
@tmp = ($tmp,$code);
$online = !$online;
}
elsif ($code eq '>') {
($code,$tmp,$string) = unpack("CCa99",$string);
if ($tmp[$[] > $code) {
$tmp[$[] += $tmp;
}
}
elsif ($code eq '2') {
$result .= sprintf("%02d",shift(@tmp));
$online = !$online;
}
elsif ($code eq '3') {
$result .= sprintf("%03d",shift(@tmp));
$online = !$online;
}
elsif ($code eq 'i') {
($code,$tmp) = @tmp;
@tmp = ($code+1,$tmp+1);
}
else {
return "OOPS";
}
}
$result . $string . $after;
}
1;
--- NEW FILE: newgetopt.pl ---
# $Id: newgetopt.pl,v 1.2 2006-12-04 17:00:15 dslinux_cayenne Exp $
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
# It is now just a wrapper around the Getopt::Long module.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Getopt::Long
{ package newgetopt;
# Values for $order. See GNU getopt.c for details.
$REQUIRE_ORDER = 0;
$PERMUTE = 1;
$RETURN_IN_ORDER = 2;
# Handle POSIX compliancy.
if ( defined $ENV{"POSIXLY_CORRECT"} ) {
$autoabbrev = 0; # no automatic abbrev of options (???)
$getopt_compat = 0; # disallow '+' to start options
$option_start = "(--|-)";
$order = $REQUIRE_ORDER;
$bundling = 0;
$passthrough = 0;
}
else {
$autoabbrev = 1; # automatic abbrev of options
$getopt_compat = 1; # allow '+' to start options
$option_start = "(--|-|\\+)";
$order = $PERMUTE;
$bundling = 0;
$passthrough = 0;
}
# Other configurable settings.
$debug = 0; # for debugging
$ignorecase = 1; # ignore case when matching options
$argv_end = "--"; # don't change this!
}
use Getopt::Long;
################ Subroutines ################
sub NGetOpt {
$Getopt::Long::debug = $newgetopt::debug
if defined $newgetopt::debug;
$Getopt::Long::autoabbrev = $newgetopt::autoabbrev
if defined $newgetopt::autoabbrev;
$Getopt::Long::getopt_compat = $newgetopt::getopt_compat
if defined $newgetopt::getopt_compat;
$Getopt::Long::option_start = $newgetopt::option_start
if defined $newgetopt::option_start;
$Getopt::Long::order = $newgetopt::order
if defined $newgetopt::order;
$Getopt::Long::bundling = $newgetopt::bundling
if defined $newgetopt::bundling;
$Getopt::Long::ignorecase = $newgetopt::ignorecase
if defined $newgetopt::ignorecase;
$Getopt::Long::ignorecase = $newgetopt::ignorecase
if defined $newgetopt::ignorecase;
$Getopt::Long::passthrough = $newgetopt::passthrough
if defined $newgetopt::passthrough;
&GetOptions;
}
################ Package return ################
1;
################ End of newgetopt.pl ################
--- NEW FILE: fields.pm ---
package fields;
require 5.005;
use strict;
no strict 'refs';
unless( eval q{require warnings::register; warnings::register->import} ) {
*warnings::warnif = sub {
require Carp;
Carp::carp(@_);
}
}
use vars qw(%attr $VERSION);
$VERSION = '2.03';
# constant.pm is slow
sub PUBLIC () { 2**0 }
sub PRIVATE () { 2**1 }
sub INHERITED () { 2**2 }
sub PROTECTED () { 2**3 }
# The %attr hash holds the attributes of the currently assigned fields
# per class. The hash is indexed by class names and the hash value is
# an array reference. The first element in the array is the lowest field
# number not belonging to a base class. The remaining elements' indices
# are the field numbers. The values are integer bit masks, or undef
# in the case of base class private fields (which occupy a slot but are
# otherwise irrelevant to the class).
sub import {
my $class = shift;
return unless @_;
my $package = caller(0);
# avoid possible typo warnings
%{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
my $fields = \%{"$package\::FIELDS"};
my $fattr = ($attr{$package} ||= [1]);
my $next = @$fattr;
# Quiet pseudo-hash deprecation warning for uses of fields::new.
bless \%{"$package\::FIELDS"}, 'pseudohash';
if ($next > $fattr->[0]
and ($fields->{$_[0]} || 0) >= $fattr->[0])
{
# There are already fields not belonging to base classes.
# Looks like a possible module reload...
$next = $fattr->[0];
}
foreach my $f (@_) {
my $fno = $fields->{$f};
# Allow the module to be reloaded so long as field positions
# have not changed.
if ($fno and $fno != $next) {
require Carp;
if ($fno < $fattr->[0]) {
if ($] < 5.006001) {
warn("Hides field '$f' in base class") if $^W;
} else {
warnings::warnif("Hides field '$f' in base class") ;
}
} else {
Carp::croak("Field name '$f' already in use");
}
}
$fields->{$f} = $next;
$fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
$next += 1;
}
if (@$fattr > $next) {
# Well, we gave them the benefit of the doubt by guessing the
# module was reloaded, but they appear to be declaring fields
# in more than one place. We can't be sure (without some extra
# bookkeeping) that the rest of the fields will be declared or
# have the same positions, so punt.
require Carp;
Carp::croak ("Reloaded module must declare all fields at once");
}
}
sub inherit {
require base;
goto &base::inherit_fields;
}
sub _dump # sometimes useful for debugging
{
for my $pkg (sort keys %attr) {
print "\n$pkg";
if (@{"$pkg\::ISA"}) {
print " (", join(", ", @{"$pkg\::ISA"}), ")";
}
print "\n";
my $fields = \%{"$pkg\::FIELDS"};
for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
my $no = $fields->{$f};
print " $no: $f";
my $fattr = $attr{$pkg}[$no];
if (defined $fattr) {
my @a;
push(@a, "public") if $fattr & PUBLIC;
push(@a, "private") if $fattr & PRIVATE;
push(@a, "inherited") if $fattr & INHERITED;
print "\t(", join(", ", @a), ")";
}
print "\n";
}
}
}
if ($] < 5.009) {
*new = sub {
my $class = shift;
$class = ref $class if ref $class;
return bless [\%{$class . "::FIELDS"}], $class;
}
} else {
*new = sub {
my $class = shift;
$class = ref $class if ref $class;
require Hash::Util;
my $self = bless {}, $class;
# The lock_keys() prototype won't work since we require Hash::Util :(
&Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'});
return $self;
}
}
sub phash {
die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
my $h;
my $v;
if (@_) {
if (ref $_[0] eq 'ARRAY') {
my $a = shift;
@$h{@$a} = 1 .. @$a;
if (@_) {
$v = shift;
unless (! @_ and ref $v eq 'ARRAY') {
require Carp;
Carp::croak ("Expected at most two array refs\n");
}
}
}
else {
if (@_ % 2) {
require Carp;
Carp::croak ("Odd number of elements initializing pseudo-hash\n");
}
my $i = 0;
@$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
$i = 0;
$v = [grep $i++ % 2, @_];
}
}
else {
$h = {};
$v = [];
}
[ $h, @$v ];
}
1;
__END__
=head1 NAME
fields - compile-time class fields
=head1 SYNOPSIS
{
package Foo;
use fields qw(foo bar _Foo_private);
sub new {
my Foo $self = shift;
unless (ref $self) {
$self = fields::new($self);
$self->{_Foo_private} = "this is Foo's secret";
}
$self->{foo} = 10;
$self->{bar} = 20;
return $self;
}
}
my $var = Foo->new;
$var->{foo} = 42;
# this will generate an error
$var->{zap} = 42;
# subclassing
{
package Bar;
use base 'Foo';
use fields qw(baz _Bar_private); # not shared with Foo
sub new {
my $class = shift;
my $self = fields::new($class);
$self->SUPER::new(); # init base fields
$self->{baz} = 10; # init own fields
$self->{_Bar_private} = "this is Bar's secret";
return $self;
}
}
=head1 DESCRIPTION
The C<fields> pragma enables compile-time verified class fields.
NOTE: The current implementation keeps the declared fields in the %FIELDS
hash of the calling package, but this may change in future versions.
Do B<not> update the %FIELDS hash directly, because it must be created
at compile-time for it to be fully useful, as is done by this pragma.
B<Only valid for perl before 5.9.0:>
If a typed lexical variable holding a reference is used to access a
hash element and a package with the same name as the type has
declared class fields using this pragma, then the operation is
turned into an array access at compile time.
The related C<base> pragma will combine fields from base classes and any
fields declared using the C<fields> pragma. This enables field
inheritance to work properly.
Field names that start with an underscore character are made private to
the class and are not visible to subclasses. Inherited fields can be
overridden but will generate a warning if used together with the C<-w>
switch.
B<Only valid for perls before 5.9.0:>
The effect of all this is that you can have objects with named
fields which are as compact and as fast arrays to access. This only
works as long as the objects are accessed through properly typed
variables. If the objects are not typed, access is only checked at
run time.
The following functions are supported:
=over 4
=item new
B< perl before 5.9.0: > fields::new() creates and blesses a
pseudo-hash comprised of the fields declared using the C<fields>
pragma into the specified class.
B< perl 5.9.0 and higher: > fields::new() creates and blesses a
restricted-hash comprised of the fields declared using the C<fields>
pragma into the specified class.
This function is usable with or without pseudo-hashes. It is the
recommended way to construct a fields-based object.
This makes it possible to write a constructor like this:
package Critter::Sounds;
use fields qw(cat dog bird);
sub new {
my $self = shift;
$self = fields::new($self) unless ref $self;
$self->{cat} = 'meow'; # scalar element
@$self{'dog','bird'} = ('bark','tweet'); # slice
return $self;
}
=item phash
B< before perl 5.9.0: >
fields::phash() can be used to create and initialize a plain (unblessed)
pseudo-hash. This function should always be used instead of creating
pseudo-hashes directly.
If the first argument is a reference to an array, the pseudo-hash will
be created with keys from that array. If a second argument is supplied,
it must also be a reference to an array whose elements will be used as
the values. If the second array contains less elements than the first,
the trailing elements of the pseudo-hash will not be initialized.
This makes it particularly useful for creating a pseudo-hash from
subroutine arguments:
sub dogtag {
my $tag = fields::phash([qw(name rank ser_num)], [@_]);
}
fields::phash() also accepts a list of key-value pairs that will
be used to construct the pseudo hash. Examples:
my $tag = fields::phash(name => "Joe",
rank => "captain",
ser_num => 42);
my $pseudohash = fields::phash(%args);
B< perl 5.9.0 and higher: >
Pseudo-hashes have been removed from Perl as of 5.10. Consider using
restricted hashes or fields::new() instead. Using fields::phash()
will cause an error.
=back
=head1 SEE ALSO
L<base>
=cut
--- NEW FILE: Test.pm ---
require 5.004;
package Test;
# Time-stamp: "2004-04-28 21:46:51 ADT"
use strict;
use Carp;
use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish
qw($TESTOUT $TESTERR %Program_Lines $told_about_diff
$ONFAIL %todo %history $planned @FAILDETAIL) #private-ish
);
# In case a test is run in a persistent environment.
sub _reset_globals {
%todo = ();
%history = ();
@FAILDETAIL = ();
$ntest = 1;
$TestLevel = 0; # how many extra stack frames to skip
$planned = 0;
}
$VERSION = '1.25';
require Exporter;
@ISA=('Exporter');
@EXPORT = qw(&plan &ok &skip);
@EXPORT_OK = qw($ntest $TESTOUT $TESTERR);
$|=1;
$TESTOUT = *STDOUT{IO};
$TESTERR = *STDERR{IO};
# Use of this variable is strongly discouraged. It is set mainly to
# help test coverage analyzers know which test is running.
$ENV{REGRESSION_TEST} = $0;
=head1 NAME
Test - provides a simple framework for writing test scripts
=head1 SYNOPSIS
use strict;
use Test;
# use a BEGIN block so we print our plan before MyModule is loaded
BEGIN { plan tests => 14, todo => [3,4] }
# load your module...
use MyModule;
# Helpful notes. All note-lines must start with a "#".
print "# I'm testing MyModule version $MyModule::VERSION\n";
ok(0); # failure
ok(1); # success
ok(0); # ok, expected failure (see todo list, above)
ok(1); # surprise success!
ok(0,1); # failure: '0' ne '1'
ok('broke','fixed'); # failure: 'broke' ne 'fixed'
ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/
ok(sub { 1+1 }, 2); # success: '2' eq '2'
ok(sub { 1+1 }, 3); # failure: '2' ne '3'
my @list = (0,0);
ok @list, 3, "\@list=".join(',', at list); #extra notes
ok 'segmentation fault', '/(?i)success/'; #regex match
skip(
$^O =~ m/MSWin/ ? "Skip if MSWin" : 0, # whether to skip
$foo, $bar # arguments just like for ok(...)
);
skip(
$^O =~ m/MSWin/ ? 0 : "Skip unless MSWin", # whether to skip
$foo, $bar # arguments just like for ok(...)
);
=head1 DESCRIPTION
This module simplifies the task of writing test files for Perl modules,
such that their output is in the format that
L<Test::Harness|Test::Harness> expects to see.
=head1 QUICK START GUIDE
To write a test for your new (and probably not even done) module, create
a new file called F<t/test.t> (in a new F<t> directory). If you have
multiple test files, to test the "foo", "bar", and "baz" feature sets,
then feel free to call your files F<t/foo.t>, F<t/bar.t>, and
F<t/baz.t>
=head2 Functions
This module defines three public functions, C<plan(...)>, C<ok(...)>,
and C<skip(...)>. By default, all three are exported by
the C<use Test;> statement.
=over 4
=item C<plan(...)>
BEGIN { plan %theplan; }
This should be the first thing you call in your test script. It
declares your testing plan, how many there will be, if any of them
should be allowed to fail, and so on.
Typical usage is just:
use Test;
BEGIN { plan tests => 23 }
These are the things that you can put in the parameters to plan:
=over
=item C<tests =E<gt> I<number>>
The number of tests in your script.
This means all ok() and skip() calls.
=item C<todo =E<gt> [I<1,5,14>]>
A reference to a list of tests which are allowed to fail.
See L</TODO TESTS>.
=item C<onfail =E<gt> sub { ... }>
=item C<onfail =E<gt> \&some_sub>
A subroutine reference to be run at the end of the test script, if
any of the tests fail. See L</ONFAIL>.
=back
You must call C<plan(...)> once and only once. You should call it
in a C<BEGIN {...}> block, like so:
BEGIN { plan tests => 23 }
=cut
sub plan {
croak "Test::plan(%args): odd number of arguments" if @_ & 1;
croak "Test::plan(): should not be called more than once" if $planned;
local($\, $,); # guard against -l and other things that screw with
# print
_reset_globals();
_read_program( (caller)[1] );
my $max=0;
while (@_) {
my ($k,$v) = splice(@_, 0, 2);
if ($k =~ /^test(s)?$/) { $max = $v; }
elsif ($k eq 'todo' or
$k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
elsif ($k eq 'onfail') {
ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
$ONFAIL = $v;
}
else { carp "Test::plan(): skipping unrecognized directive '$k'" }
}
my @todo = sort { $a <=> $b } keys %todo;
if (@todo) {
print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
} else {
print $TESTOUT "1..$max\n";
}
++$planned;
print $TESTOUT "# Running under perl version $] for $^O",
(chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n";
print $TESTOUT "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n"
if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber();
print $TESTOUT "# MacPerl version $MacPerl::Version\n"
if defined $MacPerl::Version;
printf $TESTOUT
"# Current time local: %s\n# Current time GMT: %s\n",
scalar(localtime($^T)), scalar(gmtime($^T));
print $TESTOUT "# Using Test.pm version $VERSION\n";
# Retval never used:
return undef;
}
sub _read_program {
my($file) = shift;
return unless defined $file and length $file
and -e $file and -f _ and -r _;
open(SOURCEFILE, "<$file") || return;
$Program_Lines{$file} = [<SOURCEFILE>];
close(SOURCEFILE);
foreach my $x (@{$Program_Lines{$file}})
{ $x =~ tr/\cm\cj\n\r//d }
unshift @{$Program_Lines{$file}}, '';
return 1;
}
=begin _private
=item B<_to_value>
my $value = _to_value($input);
Converts an C<ok> parameter to its value. Typically this just means
running it, if it's a code reference. You should run all inputted
values through this.
=cut
sub _to_value {
my ($v) = @_;
return ref $v eq 'CODE' ? $v->() : $v;
}
sub _quote {
my $str = $_[0];
return "<UNDEF>" unless defined $str;
$str =~ s/\\/\\\\/g;
$str =~ s/"/\\"/g;
$str =~ s/\a/\\a/g;
$str =~ s/[\b]/\\b/g;
$str =~ s/\e/\\e/g;
$str =~ s/\f/\\f/g;
$str =~ s/\n/\\n/g;
$str =~ s/\r/\\r/g;
$str =~ s/\t/\\t/g;
$str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
$str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
$str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg;
#if( $_[1] ) {
# substr( $str , 218-3 ) = "..."
# if length($str) >= 218 and !$ENV{PERL_TEST_NO_TRUNC};
#}
return qq("$str");
}
=end _private
=item C<ok(...)>
ok(1 + 1 == 2);
ok($have, $expect);
ok($have, $expect, $diagnostics);
This function is the reason for C<Test>'s existence. It's
the basic function that
handles printing "C<ok>" or "C<not ok>", along with the
current test number. (That's what C<Test::Harness> wants to see.)
In its most basic usage, C<ok(...)> simply takes a single scalar
expression. If its value is true, the test passes; if false,
the test fails. Examples:
# Examples of ok(scalar)
ok( 1 + 1 == 2 ); # ok if 1 + 1 == 2
ok( $foo =~ /bar/ ); # ok if $foo contains 'bar'
ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns
# 'Armondo'
ok( @a == @b ); # ok if @a and @b are the same length
The expression is evaluated in scalar context. So the following will
work:
ok( @stuff ); # ok if @stuff has any elements
ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is
# defined.
A special case is if the expression is a subroutine reference (in either
C<sub {...}> syntax or C<\&foo> syntax). In
that case, it is executed and its value (true or false) determines if
the test passes or fails. For example,
ok( sub { # See whether sleep works at least passably
my $start_time = time;
sleep 5;
time() - $start_time >= 4
});
In its two-argument form, C<ok(I<arg1>, I<arg2>)> compares the two
scalar values to see if they match. They match if both are undefined,
or if I<arg2> is a regex that matches I<arg1>, or if they compare equal
with C<eq>.
# Example of ok(scalar, scalar)
ok( "this", "that" ); # not ok, 'this' ne 'that'
ok( "", undef ); # not ok, "" is defined
The second argument is considered a regex if it is either a regex
object or a string that looks like a regex. Regex objects are
constructed with the qr// operator in recent versions of perl. A
string is considered to look like a regex if its first and last
characters are "/", or if the first character is "m"
and its second and last characters are both the
same non-alphanumeric non-whitespace character. These regexp
Regex examples:
ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/
ok( 'JaffO', 'm|Jaff|' ); # ok, 'JaffO' =~ m|Jaff|
ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/;
ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i;
If either (or both!) is a subroutine reference, it is run and used
as the value for comparing. For example:
ok sub {
open(OUT, ">x.dat") || die $!;
print OUT "\x{e000}";
close OUT;
my $bytecount = -s 'x.dat';
unlink 'x.dat' or warn "Can't unlink : $!";
return $bytecount;
},
4
;
The above test passes two values to C<ok(arg1, arg2)> -- the first
a coderef, and the second is the number 4. Before C<ok> compares them,
it calls the coderef, and uses its return value as the real value of
this parameter. Assuming that C<$bytecount> returns 4, C<ok> ends up
testing C<4 eq 4>. Since that's true, this test passes.
Finally, you can append an optional third argument, in
C<ok(I<arg1>,I<arg2>, I<note>)>, where I<note> is a string value that
will be printed if the test fails. This should be some useful
information about the test, pertaining to why it failed, and/or
a description of the test. For example:
ok( grep($_ eq 'something unique', @stuff), 1,
"Something that should be unique isn't!\n".
'@stuff = '.join ', ', @stuff
);
Unfortunately, a note cannot be used with the single argument
style of C<ok()>. That is, if you try C<ok(I<arg1>, I<note>)>, then
C<Test> will interpret this as C<ok(I<arg1>, I<arg2>)>, and probably
end up testing C<I<arg1> eq I<arg2>> -- and that's not what you want!
All of the above special cases can occasionally cause some
problems. See L</BUGS and CAVEATS>.
=cut
# A past maintainer of this module said:
# <<ok(...)'s special handling of subroutine references is an unfortunate
# "feature" that can't be removed due to compatibility.>>
#
sub ok ($;$$) {
croak "ok: plan before you test!" if !$planned;
local($\,$,); # guard against -l and other things that screw with
# print
my ($pkg,$file,$line) = caller($TestLevel);
my $repetition = ++$history{"$file:$line"};
my $context = ("$file at line $line".
($repetition > 1 ? " fail \#$repetition" : ''));
# Are we comparing two values?
my $compare = 0;
my $ok=0;
my $result = _to_value(shift);
my ($expected, $isregex, $regex);
if (@_ == 0) {
$ok = $result;
} else {
$compare = 1;
$expected = _to_value(shift);
if (!defined $expected) {
$ok = !defined $result;
} elsif (!defined $result) {
$ok = 0;
} elsif (ref($expected) eq 'Regexp') {
$ok = $result =~ /$expected/;
$regex = $expected;
} elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
(undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
$ok = $result =~ /$regex/;
} else {
$ok = $result eq $expected;
}
}
my $todo = $todo{$ntest};
if ($todo and $ok) {
$context .= ' TODO?!' if $todo;
print $TESTOUT "ok $ntest # ($context)\n";
} else {
# Issuing two seperate prints() causes problems on VMS.
if (!$ok) {
print $TESTOUT "not ok $ntest\n";
}
else {
print $TESTOUT "ok $ntest\n";
}
$ok or _complain($result, $expected,
{
'repetition' => $repetition, 'package' => $pkg,
'result' => $result, 'todo' => $todo,
'file' => $file, 'line' => $line,
'context' => $context, 'compare' => $compare,
@_ ? ('diagnostic' => _to_value(shift)) : (),
});
}
++ $ntest;
$ok;
}
sub _complain {
my($result, $expected, $detail) = @_;
$$detail{expected} = $expected if defined $expected;
# Get the user's diagnostic, protecting against multi-line
# diagnostics.
my $diag = $$detail{diagnostic};
$diag =~ s/\n/\n#/g if defined $diag;
$$detail{context} .= ' *TODO*' if $$detail{todo};
if (!$$detail{compare}) {
if (!$diag) {
print $TESTERR "# Failed test $ntest in $$detail{context}\n";
} else {
print $TESTERR "# Failed test $ntest in $$detail{context}: $diag\n";
}
} else {
my $prefix = "Test $ntest";
print $TESTERR "# $prefix got: " . _quote($result) .
" ($$detail{context})\n";
$prefix = ' ' x (length($prefix) - 5);
my $expected_quoted = (defined $$detail{regex})
? 'qr{'.($$detail{regex}).'}' : _quote($expected);
print $TESTERR "# $prefix Expected: $expected_quoted",
$diag ? " ($diag)" : (), "\n";
_diff_complain( $result, $expected, $detail, $prefix )
if defined($expected) and 2 < ($expected =~ tr/\n//);
}
if(defined $Program_Lines{ $$detail{file} }[ $$detail{line} ]) {
print $TESTERR
"# $$detail{file} line $$detail{line} is: $Program_Lines{ $$detail{file} }[ $$detail{line} ]\n"
if $Program_Lines{ $$detail{file} }[ $$detail{line} ]
=~ m/[^\s\#\(\)\{\}\[\]\;]/; # Otherwise it's uninformative
undef $Program_Lines{ $$detail{file} }[ $$detail{line} ];
# So we won't repeat it.
}
push @FAILDETAIL, $detail;
return;
}
sub _diff_complain {
my($result, $expected, $detail, $prefix) = @_;
return _diff_complain_external(@_) if $ENV{PERL_TEST_DIFF};
return _diff_complain_algdiff(@_)
if eval { require Algorithm::Diff; Algorithm::Diff->VERSION(1.15); 1; };
$told_about_diff++ or print $TESTERR <<"EOT";
# $prefix (Install the Algorithm::Diff module to have differences in multiline
# $prefix output explained. You might also set the PERL_TEST_DIFF environment
# $prefix variable to run a diff program on the output.)
EOT
;
return;
}
sub _diff_complain_external {
my($result, $expected, $detail, $prefix) = @_;
my $diff = $ENV{PERL_TEST_DIFF} || die "WHAAAA?";
require File::Temp;
my($got_fh, $got_filename) = File::Temp::tempfile("test-got-XXXXX");
my($exp_fh, $exp_filename) = File::Temp::tempfile("test-exp-XXXXX");
unless ($got_fh && $exp_fh) {
warn "Can't get tempfiles";
return;
}
print $got_fh $result;
print $exp_fh $expected;
if (close($got_fh) && close($exp_fh)) {
my $diff_cmd = "$diff $exp_filename $got_filename";
print $TESTERR "#\n# $prefix $diff_cmd\n";
if (open(DIFF, "$diff_cmd |")) {
local $_;
while (<DIFF>) {
print $TESTERR "# $prefix $_";
}
close(DIFF);
}
else {
warn "Can't run diff: $!";
}
} else {
warn "Can't write to tempfiles: $!";
}
unlink($got_filename);
unlink($exp_filename);
return;
}
sub _diff_complain_algdiff {
my($result, $expected, $detail, $prefix) = @_;
my @got = split(/^/, $result);
my @exp = split(/^/, $expected);
my $diff_kind;
my @diff_lines;
my $diff_flush = sub {
return unless $diff_kind;
my $count_lines = @diff_lines;
my $s = $count_lines == 1 ? "" : "s";
my $first_line = $diff_lines[0][0] + 1;
print $TESTERR "# $prefix ";
if ($diff_kind eq "GOT") {
print $TESTERR "Got $count_lines extra line$s at line $first_line:\n";
for my $i (@diff_lines) {
print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n";
}
} elsif ($diff_kind eq "EXP") {
if ($count_lines > 1) {
my $last_line = $diff_lines[-1][0] + 1;
print $TESTERR "Lines $first_line-$last_line are";
}
else {
print $TESTERR "Line $first_line is";
}
print $TESTERR " missing:\n";
for my $i (@diff_lines) {
print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n";
}
} elsif ($diff_kind eq "CH") {
if ($count_lines > 1) {
my $last_line = $diff_lines[-1][0] + 1;
print $TESTERR "Lines $first_line-$last_line are";
}
else {
print $TESTERR "Line $first_line is";
}
print $TESTERR " changed:\n";
for my $i (@diff_lines) {
print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n";
print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n";
}
}
# reset
$diff_kind = undef;
@diff_lines = ();
};
my $diff_collect = sub {
my $kind = shift;
&$diff_flush() if $diff_kind && $diff_kind ne $kind;
$diff_kind = $kind;
push(@diff_lines, [@_]);
};
Algorithm::Diff::traverse_balanced(
\@got, \@exp,
{
DISCARD_A => sub { &$diff_collect("GOT", @_) },
DISCARD_B => sub { &$diff_collect("EXP", @_) },
CHANGE => sub { &$diff_collect("CH", @_) },
MATCH => sub { &$diff_flush() },
},
);
&$diff_flush();
return;
}
#~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~
=item C<skip(I<skip_if_true>, I<args...>)>
This is used for tests that under some conditions can be skipped. It's
basically equivalent to:
if( $skip_if_true ) {
ok(1);
} else {
ok( args... );
}
...except that the C<ok(1)> emits not just "C<ok I<testnum>>" but
actually "C<ok I<testnum> # I<skip_if_true_value>>".
The arguments after the I<skip_if_true> are what is fed to C<ok(...)> if
this test isn't skipped.
Example usage:
my $if_MSWin =
$^O =~ m/MSWin/ ? 'Skip if under MSWin' : '';
# A test to be skipped if under MSWin (i.e., run except under MSWin)
skip($if_MSWin, thing($foo), thing($bar) );
Or, going the other way:
my $unless_MSWin =
$^O =~ m/MSWin/ ? '' : 'Skip unless under MSWin';
# A test to be skipped unless under MSWin (i.e., run only under MSWin)
skip($unless_MSWin, thing($foo), thing($bar) );
The tricky thing to remember is that the first parameter is true if
you want to I<skip> the test, not I<run> it; and it also doubles as a
note about why it's being skipped. So in the first codeblock above, read
the code as "skip if MSWin -- (otherwise) test whether C<thing($foo)> is
C<thing($bar)>" or for the second case, "skip unless MSWin...".
Also, when your I<skip_if_reason> string is true, it really should (for
backwards compatibility with older Test.pm versions) start with the
string "Skip", as shown in the above examples.
Note that in the above cases, C<thing($foo)> and C<thing($bar)>
I<are> evaluated -- but as long as the C<skip_if_true> is true,
then we C<skip(...)> just tosses out their value (i.e., not
bothering to treat them like values to C<ok(...)>. But if
you need to I<not> eval the arguments when skipping the
test, use
this format:
skip( $unless_MSWin,
sub {
# This code returns true if the test passes.
# (But it doesn't even get called if the test is skipped.)
thing($foo) eq thing($bar)
}
);
or even this, which is basically equivalent:
skip( $unless_MSWin,
sub { thing($foo) }, sub { thing($bar) }
);
That is, both are like this:
if( $unless_MSWin ) {
ok(1); # but it actually appends "# $unless_MSWin"
# so that Test::Harness can tell it's a skip
} else {
# Not skipping, so actually call and evaluate...
ok( sub { thing($foo) }, sub { thing($bar) } );
}
=cut
sub skip ($;$$$) {
local($\, $,); # guard against -l and other things that screw with
# print
my $whyskip = _to_value(shift);
if (!@_ or $whyskip) {
$whyskip = '' if $whyskip =~ m/^\d+$/;
$whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old
# versions required the reason
# to start with 'skip'
# We print in one shot for VMSy reasons.
my $ok = "ok $ntest # skip";
$ok .= " $whyskip" if length $whyskip;
$ok .= "\n";
print $TESTOUT $ok;
++ $ntest;
return 1;
} else {
# backwards compatiblity (I think). skip() used to be
# called like ok(), which is weird. I haven't decided what to do with
# this yet.
# warn <<WARN if $^W;
#This looks like a skip() using the very old interface. Please upgrade to
#the documented interface as this has been deprecated.
#WARN
local($TestLevel) = $TestLevel+1; #to ignore this stack frame
return &ok(@_);
}
}
=back
=cut
END {
$ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
}
1;
__END__
=head1 TEST TYPES
=over 4
=item * NORMAL TESTS
These tests are expected to succeed. Usually, most or all of your tests
are in this category. If a normal test doesn't succeed, then that
means that something is I<wrong>.
=item * SKIPPED TESTS
The C<skip(...)> function is for tests that might or might not be
possible to run, depending
on the availability of platform-specific features. The first argument
should evaluate to true (think "yes, please skip") if the required
feature is I<not> available. After the first argument, C<skip(...)> works
exactly the same way as C<ok(...)> does.
=item * TODO TESTS
TODO tests are designed for maintaining an B<executable TODO list>.
These tests are I<expected to fail.> If a TODO test does succeed,
then the feature in question shouldn't be on the TODO list, now
should it?
Packages should NOT be released with succeeding TODO tests. As soon
as a TODO test starts working, it should be promoted to a normal test,
and the newly working feature should be documented in the release
notes or in the change log.
=back
=head1 ONFAIL
BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
Although test failures should be enough, extra diagnostics can be
triggered at the end of a test run. C<onfail> is passed an array ref
of hash refs that describe each test failure. Each hash will contain
at least the following fields: C<package>, C<repetition>, and
C<result>. (You shouldn't rely on any other fields being present.) If the test
had an expected value or a diagnostic (or "note") string, these will also be
included.
The I<optional> C<onfail> hook might be used simply to print out the
version of your package and/or how to report problems. It might also
be used to generate extremely sophisticated diagnostics for a
particularly bizarre test failure. However it's not a panacea. Core
dumps or other unrecoverable errors prevent the C<onfail> hook from
running. (It is run inside an C<END> block.) Besides, C<onfail> is
probably over-kill in most cases. (Your test code should be simpler
than the code it is testing, yes?)
=head1 BUGS and CAVEATS
=over
=item *
C<ok(...)>'s special handing of strings which look like they might be
regexes can also cause unexpected behavior. An innocent:
ok( $fileglob, '/path/to/some/*stuff/' );
will fail, since Test.pm considers the second argument to be a regex!
The best bet is to use the one-argument form:
ok( $fileglob eq '/path/to/some/*stuff/' );
=item *
C<ok(...)>'s use of string C<eq> can sometimes cause odd problems
when comparing
numbers, especially if you're casting a string to a number:
$foo = "1.0";
ok( $foo, 1 ); # not ok, "1.0" ne 1
Your best bet is to use the single argument form:
ok( $foo == 1 ); # ok "1.0" == 1
=item *
As you may have inferred from the above documentation and examples,
C<ok>'s prototype is C<($;$$)> (and, incidentally, C<skip>'s is
C<($;$$$)>). This means, for example, that you can do C<ok @foo, @bar>
to compare the I<size> of the two arrays. But don't be fooled into
thinking that C<ok @foo, @bar> means a comparison of the contents of two
arrays -- you're comparing I<just> the number of elements of each. It's
so easy to make that mistake in reading C<ok @foo, @bar> that you might
want to be very explicit about it, and instead write C<ok scalar(@foo),
scalar(@bar)>.
=item *
This almost definitely doesn't do what you expect:
ok $thingy->can('some_method');
Why? Because C<can> returns a coderef to mean "yes it can (and the
method is this...)", and then C<ok> sees a coderef and thinks you're
passing a function that you want it to call and consider the truth of
the result of! I.e., just like:
ok $thingy->can('some_method')->();
What you probably want instead is this:
ok $thingy->can('some_method') && 1;
If the C<can> returns false, then that is passed to C<ok>. If it
returns true, then the larger expression S<< C<<
$thingy->can('some_method') && 1 >> >> returns 1, which C<ok> sees as
a simple signal of success, as you would expect.
=item *
The syntax for C<skip> is about the only way it can be, but it's still
quite confusing. Just start with the above examples and you'll
be okay.
Moreover, users may expect this:
skip $unless_mswin, foo($bar), baz($quux);
to not evaluate C<foo($bar)> and C<baz($quux)> when the test is being
skipped. But in reality, they I<are> evaluated, but C<skip> just won't
bother comparing them if C<$unless_mswin> is true.
You could do this:
skip $unless_mswin, sub{foo($bar)}, sub{baz($quux)};
But that's not terribly pretty. You may find it simpler or clearer in
the long run to just do things like this:
if( $^O =~ m/MSWin/ ) {
print "# Yay, we're under $^O\n";
ok foo($bar), baz($quux);
ok thing($whatever), baz($stuff);
ok blorp($quux, $whatever);
ok foo($barzbarz), thang($quux);
} else {
print "# Feh, we're under $^O. Watch me skip some tests...\n";
for(1 .. 4) { skip "Skip unless under MSWin" }
}
But be quite sure that C<ok> is called exactly as many times in the
first block as C<skip> is called in the second block.
=back
=head1 ENVIRONMENT
If C<PERL_TEST_DIFF> environment variable is set, it will be used as a
command for comparing unexpected multiline results. If you have GNU
diff installed, you might want to set C<PERL_TEST_DIFF> to C<diff -u>.
If you don't have a suitable program, you might install the
C<Text::Diff> module and then set C<PERL_TEST_DIFF> to be C<perl
-MText::Diff -e 'print diff(@ARGV)'>. If C<PERL_TEST_DIFF> isn't set
but the C<Algorithm::Diff> module is available, then it will be used
to show the differences in multiline results.
=for comment
If C<PERL_TEST_NO_TRUNC> is set, then the initial "Got 'something' but
expected 'something_else'" readings for long multiline output values aren't
truncated at about the 230th column, as they normally could be in some
cases. Normally you won't need to use this, unless you were carefully
parsing the output of your test programs.
=head1 NOTE
A past developer of this module once said that it was no longer being
actively developed. However, rumors of its demise were greatly
exaggerated. Feedback and suggestions are quite welcome.
Be aware that the main value of this module is its simplicity. Note
that there are already more ambitious modules out there, such as
L<Test::More> and L<Test::Unit>.
Some earlier versions of this module had docs with some confusing
typoes in the description of C<skip(...)>.
=head1 SEE ALSO
L<Test::Harness>
L<Test::Simple>, L<Test::More>, L<Devel::Cover>
L<Test::Builder> for building your own testing library.
L<Test::Unit> is an interesting XUnit-style testing library.
L<Test::Inline> and L<SelfTest> let you embed tests in code.
=head1 AUTHOR
Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved.
Copyright (c) 2001-2002 Michael G. Schwern.
Copyright (c) 2002-2004 and counting Sean M. Burke.
Current maintainer: Sean M. Burke. E<lt>sburke at cpan.orgE<gt>
This package is free software and is provided "as is" without express
or implied warranty. It may be used, redistributed and/or modified
under the same terms as Perl itself.
=cut
# "Your mistake was a hidden intention."
# -- /Oblique Strategies/, Brian Eno and Peter Schmidt
--- NEW FILE: syslog.pl ---
#
# syslog.pl
#
# $Log: syslog.pl,v $
# Revision 1.2 2006-12-04 17:00:17 dslinux_cayenne
# Adding fresh perl source to HEAD to branch from
#
#
# tom christiansen <tchrist at convex.com>
# modified to use sockets by Larry Wall <lwall at jpl-devvax.jpl.nasa.gov>
# NOTE: openlog now takes three arguments, just like openlog(3)
#
# call syslog() with a string priority and a list of printf() args
# like syslog(3)
#
# usage: require 'syslog.pl';
#
# then (put these all in a script to test function)
#
#
# do openlog($program,'cons,pid','user');
# do syslog('info','this is another test');
# do syslog('mail|warning','this is a better test: %d', time);
# do closelog();
#
# do syslog('debug','this is the last test');
# do openlog("$program $$",'ndelay','user');
# do syslog('notice','fooprogram: this is really done');
#
# $! = 55;
# do syslog('info','problem was %m'); # %m == $! in syslog(3)
package syslog;
use warnings::register;
$host = 'localhost' unless $host; # set $syslog'host to change
if ($] >= 5 && warnings::enabled()) {
warnings::warn("You should 'use Sys::Syslog' instead; continuing");
}
require 'syslog.ph';
eval 'use Socket; 1' ||
eval { require "socket.ph" } ||
require "sys/socket.ph";
$maskpri = &LOG_UPTO(&LOG_DEBUG);
sub main'openlog {
($ident, $logopt, $facility) = @_; # package vars
$lo_pid = $logopt =~ /\bpid\b/;
$lo_ndelay = $logopt =~ /\bndelay\b/;
$lo_cons = $logopt =~ /\bcons\b/;
$lo_nowait = $logopt =~ /\bnowait\b/;
&connect if $lo_ndelay;
}
sub main'closelog {
$facility = $ident = '';
&disconnect;
}
sub main'setlogmask {
local($oldmask) = $maskpri;
$maskpri = shift;
$oldmask;
}
sub main'syslog {
local($priority) = shift;
local($mask) = shift;
local($message, $whoami);
local(@words, $num, $numpri, $numfac, $sum);
local($facility) = $facility; # may need to change temporarily.
die "syslog: expected both priority and mask" unless $mask && $priority;
@words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
undef $numpri;
undef $numfac;
foreach (@words) {
$num = &xlate($_); # Translate word to number.
if (/^kern$/ || $num < 0) {
die "syslog: invalid level/facility: $_\n";
}
elsif ($num <= &LOG_PRIMASK) {
die "syslog: too many levels given: $_\n" if defined($numpri);
$numpri = $num;
return 0 unless &LOG_MASK($numpri) & $maskpri;
}
else {
die "syslog: too many facilities given: $_\n" if defined($numfac);
$facility = $_;
$numfac = $num;
}
}
die "syslog: level must be given\n" unless defined($numpri);
if (!defined($numfac)) { # Facility not specified in this call.
$facility = 'user' unless $facility;
$numfac = &xlate($facility);
}
&connect unless $connected;
$whoami = $ident;
if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
$whoami = $1;
$mask = $2;
}
unless ($whoami) {
($whoami = getlogin) ||
($whoami = getpwuid($<)) ||
($whoami = 'syslog');
}
$whoami .= "[$$]" if $lo_pid;
$mask =~ s/%m/$!/g;
$mask .= "\n" unless $mask =~ /\n$/;
$message = sprintf ($mask, @_);
$sum = $numpri + $numfac;
unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
if ($lo_cons) {
if ($pid = fork) {
unless ($lo_nowait) {
do {$died = wait;} until $died == $pid || $died < 0;
}
}
else {
open(CONS,">/dev/console");
print CONS "<$facility.$priority>$whoami: $message\r";
exit if defined $pid; # if fork failed, we're parent
close CONS;
}
}
}
}
sub xlate {
local($name) = @_;
$name = uc $name;
$name = "LOG_$name" unless $name =~ /^LOG_/;
$name = "syslog'$name";
defined &$name ? &$name : -1;
}
sub connect {
$pat = 'S n C4 x8';
$af_unix = &AF_UNIX;
$af_inet = &AF_INET;
$stream = &SOCK_STREAM;
$datagram = &SOCK_DGRAM;
($name,$aliases,$proto) = getprotobyname('udp');
$udp = $proto;
($name,$aliases,$port,$proto) = getservbyname('syslog','udp');
$syslog = $port;
if (chop($myname = `hostname`)) {
($name,$aliases,$addrtype,$length, at addrs) = gethostbyname($myname);
die "Can't lookup $myname\n" unless $name;
@bytes = unpack("C4",$addrs[0]);
}
else {
@bytes = (0,0,0,0);
}
$this = pack($pat, $af_inet, 0, @bytes);
if ($host =~ /^\d+\./) {
@bytes = split(/\./,$host);
}
else {
($name,$aliases,$addrtype,$length, at addrs) = gethostbyname($host);
die "Can't lookup $host\n" unless $name;
@bytes = unpack("C4",$addrs[0]);
}
$that = pack($pat,$af_inet,$syslog, at bytes);
socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n";
bind(SYSLOG,$this) || die "bind: $!\n";
connect(SYSLOG,$that) || die "connect: $!\n";
local($old) = select(SYSLOG); $| = 1; select($old);
$connected = 1;
}
sub disconnect {
close SYSLOG;
$connected = 0;
}
1;
--- NEW FILE: SelectSaver.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..3\n";
use SelectSaver;
open(FOO, ">foo-$$") || die;
print "ok 1\n";
{
my $saver = new SelectSaver(FOO);
print "foo\n";
}
# Get data written to file
open(FOO, "foo-$$") || die;
chomp($foo = <FOO>);
close FOO;
unlink "foo-$$";
print "ok 2\n" if $foo eq "foo";
print "ok 3\n";
--- NEW FILE: Carp.pm ---
package Carp;
our $VERSION = '1.04';
=head1 NAME
carp - warn of errors (from perspective of caller)
cluck - warn of errors with stack backtrace
(not exported by default)
croak - die of errors (from perspective of caller)
confess - die of errors with stack backtrace
shortmess - return the message that carp and croak produce
longmess - return the message that cluck and confess produce
=head1 SYNOPSIS
use Carp;
croak "We're outta here!";
use Carp qw(cluck);
cluck "This is how we got here!";
print FH Carp::shortmess("This will have caller's details added");
print FH Carp::longmess("This will have stack backtrace added");
=head1 DESCRIPTION
The Carp routines are useful in your own modules because
they act like die() or warn(), but with a message which is more
likely to be useful to a user of your module. In the case of
cluck, confess, and longmess that context is a summary of every
call in the call-stack. For a shorter message you can use carp,
croak or shortmess which report the error as being from where
your module was called. There is no guarantee that that is where
the error was, but it is a good educated guess.
You can also alter the way the output and logic of C<Carp> works, by
changing some global variables in the C<Carp> namespace. See the
section on C<GLOBAL VARIABLES> below.
Here is a more complete description of how shortmess works. What
it does is search the call-stack for a function call stack where
it hasn't been told that there shouldn't be an error. If every
call is marked safe, it then gives up and gives a full stack
backtrace instead. In other words it presumes that the first likely
looking potential suspect is guilty. Its rules for telling whether
a call shouldn't generate errors work as follows:
=over 4
=item 1.
Any call from a package to itself is safe.
=item 2.
Packages claim that there won't be errors on calls to or from
packages explicitly marked as safe by inclusion in @CARP_NOT, or
(if that array is empty) @ISA. The ability to override what
@ISA says is new in 5.8.
=item 3.
The trust in item 2 is transitive. If A trusts B, and B
trusts C, then A trusts C. So if you do not override @ISA
with @CARP_NOT, then this trust relationship is identical to,
"inherits from".
=item 4.
Any call from an internal Perl module is safe. (Nothing keeps
user modules from marking themselves as internal to Perl, but
this practice is discouraged.)
=item 5.
Any call to Carp is safe. (This rule is what keeps it from
reporting the error where you call carp/croak/shortmess.)
=back
=head2 Forcing a Stack Trace
As a debugging aid, you can force Carp to treat a croak as a confess
and a carp as a cluck across I<all> modules. In other words, force a
detailed stack trace to be given. This can be very helpful when trying
to understand why, or from where, a warning or error is being generated.
This feature is enabled by 'importing' the non-existent symbol
'verbose'. You would typically enable it by saying
perl -MCarp=verbose script.pl
or by including the string C<MCarp=verbose> in the PERL5OPT
environment variable.
Alternately, you can set the global variable C<$Carp::Verbose> to true.
See the C<GLOBAL VARIABLES> section below.
=cut
# This package is heavily used. Be small. Be fast. Be good.
# Comments added by Andy Wardley <abw at kfs.org> 09-Apr-98, based on an
# _almost_ complete understanding of the package. Corrections and
# comments are welcome.
# The members of %Internal are packages that are internal to perl.
# Carp will not report errors from within these packages if it
# can. The members of %CarpInternal are internal to Perl's warning
# system. Carp will not report errors from within these packages
# either, and will not report calls *to* these packages for carp and
# croak. They replace $CarpLevel, which is deprecated. The
# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
# text and function arguments should be formatted when printed.
# Comments added by Jos I. Boumans <kane at dwim.org> 11-Aug-2004
# I can not get %CarpInternal or %Internal to work as advertised,
# therefor leaving it out of the below documentation.
# $CarpLevel may be decprecated according to the last comment, but
# after 6 years, it's still around and in heavy use ;)
=pod
=head1 GLOBAL VARIABLES
=head2 $Carp::CarpLevel
This variable determines how many call frames are to be skipped when
reporting where an error occurred on a call to one of C<Carp>'s
functions. For example:
$Carp::CarpLevel = 1;
sub bar { .... or _error('Wrong input') }
sub _error { Carp::carp(@_) }
This would make Carp report the error as coming from C<bar>'s caller,
rather than from C<_error>'s caller, as it normally would.
Defaults to C<0>.
=head2 $Carp::MaxEvalLen
This variable determines how many characters of a string-eval are to
be shown in the output. Use a value of C<0> to show all text.
Defaults to C<0>.
=head2 $Carp::MaxArgLen
This variable determines how many characters of each argument to a
function to print. Use a value of C<0> to show the full length of the
argument.
Defaults to C<64>.
=head2 $Carp::MaxArgNums
This variable determines how many arguments to each function to show.
Use a value of C<0> to show all arguments to a function call.
Defaults to C<8>.
=head2 $Carp::Verbose
This variable makes C<Carp> use the C<longmess> function at all times.
This effectively means that all calls to C<carp> become C<cluck> and
all calls to C<croak> become C<confess>.
Note, this is analogous to using C<use Carp 'verbose'>.
Defaults to C<0>.
=cut
$CarpInternal{Carp}++;
$CarpInternal{warnings}++;
$CarpLevel = 0; # How many extra package levels to skip on carp.
# How many calls to skip on confess.
# Reconciling these notions is hard, use
# %Internal and %CarpInternal instead.
$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
$MaxArgLen = 64; # How much of each argument to print. 0 = all.
$MaxArgNums = 8; # How many arguments to print. 0 = all.
$Verbose = 0; # If true then make shortmess call longmess instead
require Exporter;
@ISA = ('Exporter');
@EXPORT = qw(confess croak carp);
@EXPORT_OK = qw(cluck verbose longmess shortmess);
@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
=head1 BUGS
The Carp routines don't handle exception objects currently.
If called with a first argument that is a reference, they simply
call die() or warn(), as appropriate.
=cut
# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
# then the following method will be called by the Exporter which knows
# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
# 'verbose'.
sub export_fail {
shift;
$Verbose = shift if $_[0] eq 'verbose';
return @_;
}
# longmess() crawls all the way up the stack reporting on all the function
# calls made. The error string, $error, is originally constructed from the
# arguments passed into longmess() via confess(), cluck() or shortmess().
# This gets appended with the stack trace messages which are generated for
# each function call on the stack.
sub longmess {
{
local($@, $!);
# XXX fix require to not clear $@ or $!?
# don't use require unless we need to (for Safe compartments)
require Carp::Heavy unless $INC{"Carp/Heavy.pm"};
}
# Icky backwards compatibility wrapper. :-(
my $call_pack = caller();
if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
return longmess_heavy(@_);
}
else {
local $CarpLevel = $CarpLevel + 1;
return longmess_heavy(@_);
}
}
# shortmess() is called by carp() and croak() to skip all the way up to
# the top-level caller's package and report the error from there. confess()
# and cluck() generate a full stack trace so they call longmess() to
# generate that. In verbose mode shortmess() calls longmess() so
# you always get a stack trace
sub shortmess { # Short-circuit &longmess if called via multiple packages
{
local($@, $!);
# XXX fix require to not clear $@ or $!?
# don't use require unless we need to (for Safe compartments)
require Carp::Heavy unless $INC{"Carp/Heavy.pm"};
}
# Icky backwards compatibility wrapper. :-(
my $call_pack = caller();
local @CARP_NOT = caller();
shortmess_heavy(@_);
}
# the following four functions call longmess() or shortmess() depending on
# whether they should generate a full stack trace (confess() and cluck())
# or simply report the caller's package (croak() and carp()), respectively.
# confess() and croak() die, carp() and cluck() warn.
sub croak { die shortmess @_ }
sub confess { die longmess @_ }
sub carp { warn shortmess @_ }
sub cluck { warn longmess @_ }
1;
--- NEW FILE: overload.pm ---
package overload;
our $VERSION = '1.04';
$overload::hint_bits = 0x20000; # HINT_LOCALIZE_HH
sub nil {}
sub OVERLOAD {
$package = shift;
my %arg = @_;
my ($sub, $fb);
$ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
*{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
for (keys %arg) {
if ($_ eq 'fallback') {
$fb = $arg{$_};
} else {
$sub = $arg{$_};
[...1395 lines suppressed...]
from two overloaded packages.
Relation between overloading and tie()ing is broken. Overloading is
triggered or not basing on the I<previous> class of tie()d value.
This happens because the presence of overloading is checked too early,
before any tie()d access is attempted. If the FETCH()ed class of the
tie()d value does not change, a simple workaround is to access the value
immediately after tie()ing, so that after this call the I<previous> class
coincides with the current one.
B<Needed:> a way to fix this without a speed penalty.
Barewords are not covered by overloaded string constants.
This document is confusing. There are grammos and misleading language
used in places. It would seem a total rewrite is needed.
=cut
--- NEW FILE: bytes.t ---
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
plan tests => 20;
my $a = chr(0x100);
is(ord($a), 0x100, "ord sanity check");
is(length($a), 1, "length sanity check");
is(substr($a, 0, 1), "\x{100}", "substr sanity check");
is(index($a, "\x{100}"), 0, "index sanity check");
is(rindex($a, "\x{100}"), 0, "rindex sanity check");
is(bytes::length($a), 2, "bytes::length sanity check");
is(bytes::chr(0x100), chr(0), "bytes::chr sanity check");
{
use bytes;
my $b = chr(0x100); # affected by 'use bytes'
is(ord($b), 0, "chr truncates under use bytes");
is(length($b), 1, "length truncated under use bytes");
is(bytes::ord($b), 0, "bytes::ord truncated under use bytes");
is(bytes::length($b), 1, "bytes::length truncated under use bytes");
is(bytes::substr($b, 0, 1), "\0", "bytes::substr truncated under use bytes");
}
my $c = chr(0x100);
{
use bytes;
if (ord('A') == 193) { # EBCDIC?
is(ord($c), 0x8c, "ord under use bytes looks at the 1st byte");
} else {
is(ord($c), 0xc4, "ord under use bytes looks at the 1st byte");
}
is(length($c), 2, "length under use bytes looks at bytes");
is(bytes::length($c), 2, "bytes::length under use bytes looks at bytes");
if (ord('A') == 193) { # EBCDIC?
is(bytes::ord($c), 0x8c, "bytes::ord under use bytes looks at the 1st byte");
} else {
is(bytes::ord($c), 0xc4, "bytes::ord under use bytes looks at the 1st byte");
}
is(bytes::substr($c, 0, 1), "\xc4", "bytes::substr under use bytes looks at bytes");
is(bytes::index($c, "\x80"), 1, "bytes::index under use bytes looks at bytes");
is(bytes::rindex($c, "\xc4"), 0, "bytes::rindex under use bytes looks at bytes");
}
{
fresh_perl_like ('use bytes; bytes::moo()',
qr/Undefined subroutine bytes::moo/, {stderr=>1},
"Check Carp is loaded for AUTOLOADing errors")
}
--- NEW FILE: bigfloat.pl ---
package bigfloat;
require "bigint.pl";
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Math::BigFloat
#
# Arbitrary length float math package
#
# by Mark Biggar
#
# number format
# canonical strings have the form /[+-]\d+E[+-]\d+/
# Input values can have embedded whitespace
# Error returns
# 'NaN' An input parameter was "Not a Number" or
# divide by zero or sqrt of negative number
# Division is computed to
# max($div_scale,length(dividend)+length(divisor))
# digits by default.
# Also used for default sqrt scale
$div_scale = 40;
# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
$rnd_mode = 'even';
# bigfloat routines
#
# fadd(NSTR, NSTR) return NSTR addition
# fsub(NSTR, NSTR) return NSTR subtraction
# fmul(NSTR, NSTR) return NSTR multiplication
# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places
# fneg(NSTR) return NSTR negation
# fabs(NSTR) return NSTR absolute value
# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0
# fround(NSTR, SCALE) return NSTR round to SCALE digits
# ffround(NSTR, SCALE) return NSTR round at SCALEth place
# fnorm(NSTR) return (NSTR) normalize
# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places
# Convert a number to canonical string form.
# Takes something that looks like a number and converts it to
# the form /^[+-]\d+E[+-]\d+$/.
sub main'fnorm { #(string) return fnum_str
local($_) = @_;
s/\s+//g; # strip white space
if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/
&& ($2 ne '' || defined($4))) {
my $x = defined($4) ? $4 : '';
&norm(($1 ? "$1$2$x" : "+$2$x"), (($x ne '') ? $6-length($x) : $6));
} else {
'NaN';
}
}
# normalize number -- for internal use
sub norm { #(mantissa, exponent) return fnum_str
local($_, $exp) = @_;
if ($_ eq 'NaN') {
'NaN';
} else {
s/^([+-])0+/$1/; # strip leading zeros
if (length($_) == 1) {
'+0E+0';
} else {
$exp += length($1) if (s/(0+)$//); # strip trailing zeros
sprintf("%sE%+ld", $_, $exp);
}
}
}
# negation
sub main'fneg { #(fnum_str) return fnum_str
local($_) = &'fnorm($_[$[]);
vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
if ( ord("\t") == 9 ) { # ascii
s/^H/N/;
}
else { # ebcdic character set
s/\373/N/;
}
$_;
}
# absolute value
sub main'fabs { #(fnum_str) return fnum_str
local($_) = &'fnorm($_[$[]);
s/^-/+/; # mash sign
$_;
}
# multiplication
sub main'fmul { #(fnum_str, fnum_str) return fnum_str
local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
if ($x eq 'NaN' || $y eq 'NaN') {
'NaN';
} else {
local($xm,$xe) = split('E',$x);
local($ym,$ye) = split('E',$y);
&norm(&'bmul($xm,$ym),$xe+$ye);
}
}
# addition
sub main'fadd { #(fnum_str, fnum_str) return fnum_str
local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
if ($x eq 'NaN' || $y eq 'NaN') {
'NaN';
} else {
local($xm,$xe) = split('E',$x);
local($ym,$ye) = split('E',$y);
($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
&norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
}
}
# subtraction
sub main'fsub { #(fnum_str, fnum_str) return fnum_str
&'fadd($_[$[],&'fneg($_[$[+1]));
}
# division
# args are dividend, divisor, scale (optional)
# result has at most max(scale, length(dividend), length(divisor)) digits
sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
{
local($x,$y,$scale) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]),$_[$[+2]);
if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
'NaN';
} else {
local($xm,$xe) = split('E',$x);
local($ym,$ye) = split('E',$y);
$scale = $div_scale if (!$scale);
$scale = length($xm)-1 if (length($xm)-1 > $scale);
$scale = length($ym)-1 if (length($ym)-1 > $scale);
$scale = $scale + length($ym) - length($xm);
&norm(&round(&'bdiv($xm.('0' x $scale),$ym),&'babs($ym)),
$xe-$ye-$scale);
}
}
# round int $q based on fraction $r/$base using $rnd_mode
sub round { #(int_str, int_str, int_str) return int_str
local($q,$r,$base) = @_;
if ($q eq 'NaN' || $r eq 'NaN') {
'NaN';
} elsif ($rnd_mode eq 'trunc') {
$q; # just truncate
} else {
local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
if ( $cmp < 0 ||
($cmp == 0 &&
( $rnd_mode eq 'zero' ||
($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) ||
($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) ||
($rnd_mode eq 'even' && $q =~ /[24680]$/) ||
($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) {
$q; # round down
} else {
&'badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1'));
# round up
}
}
}
# round the mantissa of $x to $scale digits
sub main'fround { #(fnum_str, scale) return fnum_str
local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]);
if ($x eq 'NaN' || $scale <= 0) {
$x;
} else {
local($xm,$xe) = split('E',$x);
if (length($xm)-1 <= $scale) {
$x;
} else {
&norm(&round(substr($xm,$[,$scale+1),
"+0".substr($xm,$[+$scale+1,1),"+10"),
$xe+length($xm)-$scale-1);
}
}
}
# round $x at the 10 to the $scale digit place
sub main'ffround { #(fnum_str, scale) return fnum_str
local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]);
if ($x eq 'NaN') {
'NaN';
} else {
local($xm,$xe) = split('E',$x);
if ($xe >= $scale) {
$x;
} else {
$xe = length($xm)+$xe-$scale;
if ($xe < 1) {
'+0E+0';
} elsif ($xe == 1) {
# The first substr preserves the sign, which means that
# we'll pass a non-normalized "-0" to &round when rounding
# -0.006 (for example), purely so that &round won't lose
# the sign.
&norm(&round(substr($xm,$[,1).'0',
"+0".substr($xm,$[+1,1),"+10"), $scale);
} else {
&norm(&round(substr($xm,$[,$xe),
"+0".substr($xm,$[+$xe,1),"+10"), $scale);
}
}
}
}
# compare 2 values returns one of undef, <0, =0, >0
# returns undef if either or both input value are not numbers
sub main'fcmp #(fnum_str, fnum_str) return cond_code
{
local($x, $y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
if ($x eq "NaN" || $y eq "NaN") {
undef;
} else {
ord($y) <=> ord($x)
||
( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
(($xe <=> $ye) * (substr($x,$[,1).'1')
|| &bigint'cmp($xm,$ym))
);
}
}
# square root by Newtons method.
sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
local($x, $scale) = (&'fnorm($_[$[]), $_[$[+1]);
if ($x eq 'NaN' || $x =~ /^-/) {
'NaN';
} elsif ($x eq '+0E+0') {
'+0E+0';
} else {
local($xm, $xe) = split('E',$x);
$scale = $div_scale if (!$scale);
$scale = length($xm)-1 if ($scale < length($xm)-1);
local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
while ($gs < 2*$scale) {
$guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
$gs *= 2;
}
&'fround($guess, $scale);
}
}
1;
--- NEW FILE: sort.t ---
#!./perl
# This tests the behavior of sort() under the different 'use sort' forms.
# Algorithm by John P. Linderman.
my ($BigWidth, $BigEnough, $RootWidth, $ItemFormat, @TestSizes, $WellSoaked);
BEGIN {
chdir 't' if -d 't';
@INC = qw(../lib);
$BigWidth = 6; # Digits in $BigEnough-1
$BigEnough = 10**$BigWidth; # Largest array we'll attempt
$RootWidth = int(($BigWidth+1)/2); # Digits in sqrt($BigEnough-1)
$ItemFormat = "%0${RootWidth}d%0${BigWidth}d"; # Array item format
@TestSizes = (0, 1, 2); # Small special cases
# Testing all the way up to $BigEnough takes too long
# for casual testing. There are some cutoffs (~256)
# in pp_sort that should be tested, but 10_000 is ample.
$WellSoaked = 10_000; # <= $BigEnough
for (my $ts = 3; $ts < $WellSoaked; $ts *= 10**(1/3)) {
push(@TestSizes, int($ts)); # about 3 per decade
}
}
use strict;
use warnings;
use Test::More tests => @TestSizes * 2 # sort() tests
* 4 # number of pragmas to test
+ 1 # extra test for qsort instability
+ 3 # tests for sort::current
+ 3; # tests for "defaults" and "no sort"
# Generate array of specified size for testing sort.
#
# We ensure repeated items, where possible, by drawing the $size items
# from a pool of size sqrt($size). Each randomly chosen item is
# tagged with the item index, so we can detect original input order,
# and reconstruct the original array order.
sub genarray {
my $size = int(shift); # fractions not welcome
my ($items, $i);
my @a;
if ($size < 0) { $size = 0; } # avoid complexity with sqrt
elsif ($size > $BigEnough) { $size = $BigEnough; }
$#a = $size - 1; # preallocate array
$items = int(sqrt($size)); # number of distinct items
for ($i = 0; $i < $size; ++$i) {
$a[$i] = sprintf($ItemFormat, int($items * rand()), $i);
}
return \@a;
}
# Check for correct order (including stability)
sub checkorder {
my $aref = shift;
my $status = ''; # so far, so good
my ($i, $disorder);
for ($i = 0; $i < $#$aref; ++$i) {
# Equality shouldn't happen, but catch it in the contents check
next if ($aref->[$i] le $aref->[$i+1]);
$disorder = (substr($aref->[$i], 0, $RootWidth) eq
substr($aref->[$i+1], 0, $RootWidth)) ?
"Instability" : "Disorder";
# Keep checking if merely unstable... disorder is much worse.
$status =
"$disorder at element $i between $aref->[$i] and $aref->[$i+1]";
last unless ($disorder eq "Instability");
}
return $status;
}
# Verify that the two array refs reference identical arrays
sub checkequal {
my ($aref, $bref) = @_;
my $status = '';
my $i;
if (@$aref != @$bref) {
$status = "Sizes differ: " . @$aref . " vs " . @$bref;
} else {
for ($i = 0; $i < @$aref; ++$i) {
next if ($aref->[$i] eq $bref->[$i]);
$status = "Element $i differs: $aref->[$i] vs $bref->[$i]";
last;
}
}
return $status;
}
# Test sort on arrays of various sizes (set up in @TestSizes)
sub main {
my ($expect_unstable) = @_;
my ($ts, $unsorted, @sorted, $status);
my $unstable_num = 0;
foreach $ts (@TestSizes) {
$unsorted = genarray($ts);
# Sort only on item portion of each element.
# There will typically be many repeated items,
# and their order had better be preserved.
@sorted = sort { substr($a, 0, $RootWidth)
cmp
substr($b, 0, $RootWidth) } @$unsorted;
$status = checkorder(\@sorted);
# Put the items back into the original order.
# The contents of the arrays had better be identical.
if ($expect_unstable && $status =~ /^Instability/) {
$status = '';
++$unstable_num;
}
is($status, '', "order ok for size $ts");
@sorted = sort { substr($a, $RootWidth)
cmp
substr($b, $RootWidth) } @sorted;
$status = checkequal(\@sorted, $unsorted);
is($status, '', "contents ok for size $ts");
}
# If the following test (#58) fails, see the comments in pp_sort.c
# for Perl_sortsv().
if ($expect_unstable) {
ok($unstable_num > 0, 'Instability ok');
}
}
# Test with no pragma still loaded -- stability expected (this is a mergesort)
main(0);
# XXX We're using this eval "..." trick to force recompilation,
# to ensure that the correct pragma is enabled when main() is run.
# Currently 'use sort' modifies $sort::hints at compile-time, but
# pp_sort() fetches its value at run-time.
# The order of those evals is important.
eval q{
use sort qw(_qsort);
is(sort::current(), 'quicksort', 'sort::current for _qsort');
main(1);
};
die $@ if $@;
eval q{
use sort qw(_mergesort);
is(sort::current(), 'mergesort', 'sort::current for _mergesort');
main(0);
};
die $@ if $@;
eval q{
use sort qw(_qsort stable);
is(sort::current(), 'quicksort stable', 'sort::current for _qsort stable');
main(0);
};
die $@ if $@;
# Tests added to check "defaults" subpragma, and "no sort"
eval q{
no sort qw(_qsort);
is(sort::current(), 'stable', 'sort::current after no _qsort');
};
die $@ if $@;
eval q{
use sort qw(defaults _qsort);
is(sort::current(), 'quicksort', 'sort::current after defaults _qsort');
};
die $@ if $@;
eval q{
use sort qw(defaults stable);
is(sort::current(), 'stable', 'sort::current after defaults stable');
};
die $@ if $@;
--- NEW FILE: SelfLoader.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
$dir = "self-$$";
$sep = "/";
if ($^O eq 'MacOS') {
$dir = ":" . $dir;
$sep = ":";
}
@INC = $dir;
push @INC, '../lib';
print "1..19\n";
# First we must set up some selfloader files
mkdir $dir, 0755 or die "Can't mkdir $dir: $!";
open(FOO, ">$dir${sep}Foo.pm") or die;
print FOO <<'EOT';
package Foo;
use SelfLoader;
sub new { bless {}, shift }
sub foo;
sub bar;
sub bazmarkhianish;
sub a;
sub never; # declared but definition should never be read
1;
__DATA__
sub foo { shift; shift || "foo" };
sub bar { shift; shift || "bar" }
sub bazmarkhianish { shift; shift || "baz" }
package sheep;
sub bleat { shift; shift || "baa" }
__END__
sub never { die "D'oh" }
EOT
close(FOO);
open(BAR, ">$dir${sep}Bar.pm") or die;
print BAR <<'EOT';
package Bar;
use SelfLoader;
@ISA = 'Baz';
sub new { bless {}, shift }
sub a;
1;
__DATA__
sub a { 'a Bar'; }
sub b { 'b Bar' }
__END__ DATA
sub never { die "D'oh" }
EOT
close(BAR);
};
package Baz;
sub a { 'a Baz' }
sub b { 'b Baz' }
sub c { 'c Baz' }
package main;
use Foo;
use Bar;
$foo = new Foo;
print "not " unless $foo->foo eq 'foo'; # selfloaded first time
print "ok 1\n";
print "not " unless $foo->foo eq 'foo'; # regular call
print "ok 2\n";
# Try an undefined method
eval {
$foo->will_fail;
};
if ($@ =~ /^Undefined subroutine/) {
print "ok 3\n";
} else {
print "not ok 3 $@\n";
}
# Used to be trouble with this
eval {
my $foo = new Foo;
die "oops";
};
if ($@ =~ /oops/) {
print "ok 4\n";
} else {
print "not ok 4 $@\n";
}
# Pass regular expression variable to autoloaded function. This used
# to go wrong in AutoLoader because it used regular expressions to generate
# autoloaded filename.
"foo" =~ /(\w+)/;
print "not " unless $1 eq 'foo';
print "ok 5\n";
print "not " unless $foo->bar($1) eq 'foo';
print "ok 6\n";
print "not " unless $foo->bar($1) eq 'foo';
print "ok 7\n";
print "not " unless $foo->bazmarkhianish($1) eq 'foo';
print "ok 8\n";
print "not " unless $foo->bazmarkhianish($1) eq 'foo';
print "ok 9\n";
# Check nested packages inside __DATA__
print "not " unless sheep::bleat() eq 'baa';
print "ok 10\n";
# Now check inheritance:
$bar = new Bar;
# Before anything is SelfLoaded there is no declaration of Foo::b so we should
# get Baz::b
print "not " unless $bar->b() eq 'b Baz';
print "ok 11\n";
# There is no Bar::c so we should get Baz::c
print "not " unless $bar->c() eq 'c Baz';
print "ok 12\n";
# This selfloads Bar::a because it is stubbed. It also stubs Bar::b as a side
# effect
print "not " unless $bar->a() eq 'a Bar';
print "ok 13\n";
print "not " unless $bar->b() eq 'b Bar';
print "ok 14\n";
print "not " unless $bar->c() eq 'c Baz';
print "ok 15\n";
# Check that __END__ is honoured
# Try an subroutine that should never be noticed by selfloader
eval {
$foo->never;
};
if ($@ =~ /^Undefined subroutine/) {
print "ok 16\n";
} else {
print "not ok 16 $@\n";
}
# Try to read from the data file handle
my $foodata = <Foo::DATA>;
close Foo::DATA;
if (defined $foodata) {
print "not ok 17 # $foodata\n";
} else {
print "ok 17\n";
}
# Check that __END__ DATA is honoured
# Try an subroutine that should never be noticed by selfloader
eval {
$bar->never;
};
if ($@ =~ /^Undefined subroutine/) {
print "ok 18\n";
} else {
print "not ok 18 $@\n";
}
# Try to read from the data file handle
my $bardata = <Bar::DATA>;
close Bar::DATA;
if ($bardata ne "sub never { die \"D'oh\" }\n") {
print "not ok 19 # $bardata\n";
} else {
print "ok 19\n";
}
# cleanup
END {
return unless $dir && -d $dir;
unlink "$dir${sep}Foo.pm", "$dir${sep}Bar.pm";
rmdir "$dir";
}
--- NEW FILE: English.pm ---
package English;
our $VERSION = '1.02';
require Exporter;
@ISA = (Exporter);
=head1 NAME
English - use nice English (or awk) names for ugly punctuation variables
=head1 SYNOPSIS
use English qw( -no_match_vars ) ; # Avoids regex performance penalty
use English;
...
if ($ERRNO =~ /denied/) { ... }
=head1 DESCRIPTION
This module provides aliases for the built-in variables whose
names no one seems to like to read. Variables with side-effects
which get triggered just by accessing them (like $0) will still
be affected.
For those variables that have an B<awk> version, both long
and short English alternatives are provided. For example,
the C<$/> variable can be referred to either $RS or
$INPUT_RECORD_SEPARATOR if you are using the English module.
See L<perlvar> for a complete list of these.
=head1 PERFORMANCE
This module can provoke sizeable inefficiencies for regular expressions,
due to unfortunate implementation details. If performance matters in
your application and you don't need $PREMATCH, $MATCH, or $POSTMATCH,
try doing
use English qw( -no_match_vars ) ;
. B<It is especially important to do this in modules to avoid penalizing
all applications which use them.>
=cut
no warnings;
my $globbed_match ;
# Grandfather $NAME import
sub import {
my $this = shift;
my @list = grep { ! /^-no_match_vars$/ } @_ ;
local $Exporter::ExportLevel = 1;
if ( @_ == @list ) {
*EXPORT = \@COMPLETE_EXPORT ;
$globbed_match ||= (
eval q{
*MATCH = *& ;
*PREMATCH = *` ;
*POSTMATCH = *' ;
1 ;
}
|| do {
require Carp ;
Carp::croak "Can't create English for match leftovers: $@" ;
}
) ;
}
else {
*EXPORT = \@MINIMAL_EXPORT ;
}
Exporter::import($this,grep {s/^\$/*/} @list);
}
@MINIMAL_EXPORT = qw(
*ARG
*LAST_PAREN_MATCH
*INPUT_LINE_NUMBER
*NR
*INPUT_RECORD_SEPARATOR
*RS
*OUTPUT_AUTOFLUSH
*OUTPUT_FIELD_SEPARATOR
*OFS
*OUTPUT_RECORD_SEPARATOR
*ORS
*LIST_SEPARATOR
*SUBSCRIPT_SEPARATOR
*SUBSEP
*FORMAT_PAGE_NUMBER
*FORMAT_LINES_PER_PAGE
*FORMAT_LINES_LEFT
*FORMAT_NAME
*FORMAT_TOP_NAME
*FORMAT_LINE_BREAK_CHARACTERS
*FORMAT_FORMFEED
*CHILD_ERROR
*OS_ERROR
*ERRNO
*EXTENDED_OS_ERROR
*EVAL_ERROR
*PROCESS_ID
*PID
*REAL_USER_ID
*UID
*EFFECTIVE_USER_ID
*EUID
*REAL_GROUP_ID
*GID
*EFFECTIVE_GROUP_ID
*EGID
*PROGRAM_NAME
*PERL_VERSION
*ACCUMULATOR
*COMPILING
*DEBUGGING
*SYSTEM_FD_MAX
*INPLACE_EDIT
*PERLDB
*BASETIME
*WARNING
*EXECUTABLE_NAME
*OSNAME
*LAST_REGEXP_CODE_RESULT
*EXCEPTIONS_BEING_CAUGHT
*LAST_SUBMATCH_RESULT
@LAST_MATCH_START
@LAST_MATCH_END
);
@MATCH_EXPORT = qw(
*MATCH
*PREMATCH
*POSTMATCH
);
@COMPLETE_EXPORT = ( @MINIMAL_EXPORT, @MATCH_EXPORT ) ;
# The ground of all being. @ARG is deprecated (5.005 makes @_ lexical)
*ARG = *_ ;
# Matching.
*LAST_PAREN_MATCH = *+ ;
*LAST_SUBMATCH_RESULT = *^N ;
*LAST_MATCH_START = *-{ARRAY} ;
*LAST_MATCH_END = *+{ARRAY} ;
# Input.
*INPUT_LINE_NUMBER = *. ;
*NR = *. ;
*INPUT_RECORD_SEPARATOR = */ ;
*RS = */ ;
# Output.
*OUTPUT_AUTOFLUSH = *| ;
*OUTPUT_FIELD_SEPARATOR = *, ;
*OFS = *, ;
*OUTPUT_RECORD_SEPARATOR = *\ ;
*ORS = *\ ;
# Interpolation "constants".
*LIST_SEPARATOR = *" ;
*SUBSCRIPT_SEPARATOR = *; ;
*SUBSEP = *; ;
# Formats
*FORMAT_PAGE_NUMBER = *% ;
*FORMAT_LINES_PER_PAGE = *= ;
*FORMAT_LINES_LEFT = *- ;
*FORMAT_NAME = *~ ;
*FORMAT_TOP_NAME = *^ ;
*FORMAT_LINE_BREAK_CHARACTERS = *: ;
*FORMAT_FORMFEED = *^L ;
# Error status.
*CHILD_ERROR = *? ;
*OS_ERROR = *! ;
*ERRNO = *! ;
*OS_ERROR = *! ;
*ERRNO = *! ;
*EXTENDED_OS_ERROR = *^E ;
*EVAL_ERROR = *@ ;
# Process info.
*PROCESS_ID = *$ ;
*PID = *$ ;
*REAL_USER_ID = *< ;
*UID = *< ;
*EFFECTIVE_USER_ID = *> ;
*EUID = *> ;
*REAL_GROUP_ID = *( ;
*GID = *( ;
*EFFECTIVE_GROUP_ID = *) ;
*EGID = *) ;
*PROGRAM_NAME = *0 ;
# Internals.
*PERL_VERSION = *^V ;
*ACCUMULATOR = *^A ;
*COMPILING = *^C ;
*DEBUGGING = *^D ;
*SYSTEM_FD_MAX = *^F ;
*INPLACE_EDIT = *^I ;
*PERLDB = *^P ;
*LAST_REGEXP_CODE_RESULT = *^R ;
*EXCEPTIONS_BEING_CAUGHT = *^S ;
*BASETIME = *^T ;
*WARNING = *^W ;
*EXECUTABLE_NAME = *^X ;
*OSNAME = *^O ;
# Deprecated.
# *ARRAY_BASE = *[ ;
# *OFMT = *# ;
# *MULTILINE_MATCHING = ** ;
# *OLD_PERL_VERSION = *] ;
1;
--- NEW FILE: FindBin.t ---
#!./perl
BEGIN {
# Can't chdir in BEGIN before FindBin runs, as it then can't find us.
@INC = -d 't' ? 'lib' : '../lib';
}
print "1..2\n";
use FindBin qw($Bin);
print "# $Bin\n";
if ($^O eq 'MacOS') {
print "not " unless $Bin =~ m,:lib:$,;
} else {
print "not " unless $Bin =~ m,[/.]lib\]?$,;
}
print "ok 1\n";
$0 = "-";
FindBin::again();
print "not " if $FindBin::Script ne "-";
print "ok 2\n";
--- NEW FILE: constant.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use warnings;
use vars qw{ @warnings };
BEGIN { # ...and save 'em for later
$SIG{'__WARN__'} = sub { push @warnings, @_ }
}
END { print STDERR @warnings }
use strict;
use Test::More tests => 81;
my $TB = Test::More->builder;
BEGIN { use_ok('constant'); }
use constant PI => 4 * atan2 1, 1;
ok defined PI, 'basic scalar constant';
is substr(PI, 0, 7), '3.14159', ' in substr()';
sub deg2rad { PI * $_[0] / 180 }
my $ninety = deg2rad 90;
cmp_ok abs($ninety - 1.5707), '<', 0.0001, ' in math expression';
use constant UNDEF1 => undef; # the right way
use constant UNDEF2 => ; # the weird way
use constant 'UNDEF3' ; # the 'short' way
use constant EMPTY => ( ) ; # the right way for lists
is UNDEF1, undef, 'right way to declare an undef';
is UNDEF2, undef, ' weird way';
is UNDEF3, undef, ' short way';
# XXX Why is this way different than the other ones?
my @undef = UNDEF1;
is @undef, 1;
is $undef[0], undef;
@undef = UNDEF2;
is @undef, 0;
@undef = UNDEF3;
is @undef, 0;
@undef = EMPTY;
is @undef, 0;
use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5;
use constant COUNTLIST => reverse 1, 2, 3, 4, 5;
use constant COUNTLAST => (COUNTLIST)[-1];
is COUNTDOWN, '54321';
my @cl = COUNTLIST;
is @cl, 5;
is COUNTDOWN, join '', @cl;
is COUNTLAST, 1;
is((COUNTLIST)[1], 4);
use constant ABC => 'ABC';
is "abc${\( ABC )}abc", "abcABCabc";
use constant DEF => 'D', 'E', chr ord 'F';
is "d e f @{[ DEF ]} d e f", "d e f D E F d e f";
use constant SINGLE => "'";
use constant DOUBLE => '"';
use constant BACK => '\\';
my $tt = BACK . SINGLE . DOUBLE ;
is $tt, q(\\'");
use constant MESS => q('"'\\"'"\\);
is MESS, q('"'\\"'"\\);
is length(MESS), 8;
use constant TRAILING => '12 cats';
{
no warnings 'numeric';
cmp_ok TRAILING, '==', 12;
}
is TRAILING, '12 cats';
use constant LEADING => " \t1234";
cmp_ok LEADING, '==', 1234;
is LEADING, " \t1234";
use constant ZERO1 => 0;
use constant ZERO2 => 0.0;
use constant ZERO3 => '0.0';
is ZERO1, '0';
is ZERO2, '0';
is ZERO3, '0.0';
{
package Other;
use constant PI => 3.141;
}
cmp_ok(abs(PI - 3.1416), '<', 0.0001);
is Other::PI, 3.141;
use constant E2BIG => $! = 7;
cmp_ok E2BIG, '==', 7;
# This is something like "Arg list too long", but the actual message
# text may vary, so we can't test much better than this.
cmp_ok length(E2BIG), '>', 6;
is @warnings, 0 or diag join "\n", "unexpected warning", @warnings;
@warnings = (); # just in case
undef &PI;
ok @warnings && ($warnings[0] =~ /Constant sub.* undefined/) or
diag join "\n", "unexpected warning", @warnings;
shift @warnings;
is @warnings, 0, "unexpected warning";
my $curr_test = $TB->current_test;
use constant CSCALAR => \"ok 37\n";
use constant CHASH => { foo => "ok 38\n" };
use constant CARRAY => [ undef, "ok 39\n" ];
use constant CPHASH => [ { foo => 1 }, "ok 40\n" ];
use constant CCODE => sub { "ok $_[0]\n" };
print ${+CSCALAR};
print CHASH->{foo};
print CARRAY->[1];
print CPHASH->{foo};
print CCODE->($curr_test+5);
$TB->current_test($curr_test+5);
eval q{ CPHASH->{bar} };
like $@, qr/^No such pseudo-hash field/, "test missing pseudo-hash field";
eval q{ CCODE->{foo} };
ok scalar($@ =~ /^Constant is not a HASH/);
# Allow leading underscore
use constant _PRIVATE => 47;
is _PRIVATE, 47;
# Disallow doubled leading underscore
eval q{
use constant __DISALLOWED => "Oops";
};
like $@, qr/begins with '__'/;
# Check on declared() and %declared. This sub should be EXACTLY the
# same as the one quoted in the docs!
sub declared ($) {
use constant 1.01; # don't omit this!
my $name = shift;
$name =~ s/^::/main::/;
my $pkg = caller;
my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
$constant::declared{$full_name};
}
ok declared 'PI';
ok $constant::declared{'main::PI'};
ok !declared 'PIE';
ok !$constant::declared{'main::PIE'};
{
package Other;
use constant IN_OTHER_PACK => 42;
::ok ::declared 'IN_OTHER_PACK';
::ok $constant::declared{'Other::IN_OTHER_PACK'};
::ok ::declared 'main::PI';
::ok $constant::declared{'main::PI'};
}
ok declared 'Other::IN_OTHER_PACK';
ok $constant::declared{'Other::IN_OTHER_PACK'};
@warnings = ();
eval q{
no warnings;
use warnings 'constant';
use constant 'BEGIN' => 1 ;
use constant 'INIT' => 1 ;
use constant 'CHECK' => 1 ;
use constant 'END' => 1 ;
use constant 'DESTROY' => 1 ;
use constant 'AUTOLOAD' => 1 ;
use constant 'STDIN' => 1 ;
use constant 'STDOUT' => 1 ;
use constant 'STDERR' => 1 ;
use constant 'ARGV' => 1 ;
use constant 'ARGVOUT' => 1 ;
use constant 'ENV' => 1 ;
use constant 'INC' => 1 ;
use constant 'SIG' => 1 ;
};
is @warnings, 15 ;
my @Expected_Warnings =
(
qr/^Constant name 'BEGIN' is a Perl keyword at/,
qr/^Constant subroutine BEGIN redefined at/,
qr/^Constant name 'INIT' is a Perl keyword at/,
qr/^Constant name 'CHECK' is a Perl keyword at/,
qr/^Constant name 'END' is a Perl keyword at/,
qr/^Constant name 'DESTROY' is a Perl keyword at/,
qr/^Constant name 'AUTOLOAD' is a Perl keyword at/,
qr/^Constant name 'STDIN' is forced into package main:: a/,
qr/^Constant name 'STDOUT' is forced into package main:: at/,
qr/^Constant name 'STDERR' is forced into package main:: at/,
qr/^Constant name 'ARGV' is forced into package main:: at/,
qr/^Constant name 'ARGVOUT' is forced into package main:: at/,
qr/^Constant name 'ENV' is forced into package main:: at/,
qr/^Constant name 'INC' is forced into package main:: at/,
qr/^Constant name 'SIG' is forced into package main:: at/,
);
for my $idx (0..$#warnings) {
like $warnings[$idx], $Expected_Warnings[$idx];
}
@warnings = ();
use constant {
THREE => 3,
FAMILY => [ qw( John Jane Sally ) ],
AGES => { John => 33, Jane => 28, Sally => 3 },
RFAM => [ [ qw( John Jane Sally ) ] ],
SPIT => sub { shift },
PHFAM => [ { John => 1, Jane => 2, Sally => 3 }, 33, 28, 3 ],
};
is @{+FAMILY}, THREE;
is @{+FAMILY}, @{RFAM->[0]};
is FAMILY->[2], RFAM->[0]->[2];
is AGES->{FAMILY->[1]}, 28;
{ no warnings 'deprecated'; is PHFAM->{John}, AGES->{John}; }
is PHFAM->[3], AGES->{FAMILY->[2]};
is @{+PHFAM}, SPIT->(THREE+1);
is THREE**3, SPIT->(@{+FAMILY}**3);
is AGES->{FAMILY->[THREE-1]}, PHFAM->[THREE];
# Allow name of digits/underscores only if it begins with underscore
{
use warnings FATAL => 'constant';
eval q{
use constant _1_2_3 => 'allowed';
};
ok( $@ eq '' );
}
--- NEW FILE: integer.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use integer;
use Test::More tests => 11;
use Config;
my $x = 4.5;
my $y = 5.6;
my $z;
$z = $x + $y;
is($z, 9, "plus");
$z = $x - $y;
is($z, -1, "minus");
$z = $x * $y;
is($z, 20, "times");
$z = $x / $y;
is($z, 0, "divide");
$z = $x / $y;
is($z, 0, "modulo");
is($x, 4.5, "scalar still floating point");
isnt(sqrt($x), 2, "functions still floating point");
isnt($x ** .5, 2, "power still floating point");
is(++$x, 5.5, "++ still floating point");
SKIP: {
my $ivsize = $Config{ivsize};
skip "ivsize == $ivsize", 2 unless $ivsize == 4 || $ivsize == 8;
if ($ivsize == 4) {
$z = 2**31 - 1;
is($z + 1, -2147483648, "left shift");
} elsif ($ivsize == 8) {
$z = 2**63 - 1;
is($z + 1, -9223372036854775808, "left shift");
}
}
is(~0, -1, "signed instead of unsigned");
--- NEW FILE: Env.pm ---
package Env;
our $VERSION = '1.00';
=head1 NAME
Env - perl module that imports environment variables as scalars or arrays
=head1 SYNOPSIS
use Env;
use Env qw(PATH HOME TERM);
use Env qw($SHELL @LD_LIBRARY_PATH);
=head1 DESCRIPTION
Perl maintains environment variables in a special hash named C<%ENV>. For
when this access method is inconvenient, the Perl module C<Env> allows
environment variables to be treated as scalar or array variables.
The C<Env::import()> function ties environment variables with suitable
names to global Perl variables with the same names. By default it
ties all existing environment variables (C<keys %ENV>) to scalars. If
the C<import> function receives arguments, it takes them to be a list of
variables to tie; it's okay if they don't yet exist. The scalar type
prefix '$' is inferred for any element of this list not prefixed by '$'
or '@'. Arrays are implemented in terms of C<split> and C<join>, using
C<$Config::Config{path_sep}> as the delimiter.
After an environment variable is tied, merely use it like a normal variable.
You may access its value
@path = split(/:/, $PATH);
print join("\n", @LD_LIBRARY_PATH), "\n";
or modify it
$PATH .= ":.";
push @LD_LIBRARY_PATH, $dir;
however you'd like. Bear in mind, however, that each access to a tied array
variable requires splitting the environment variable's string anew.
The code:
use Env qw(@PATH);
push @PATH, '.';
is equivalent to:
use Env qw(PATH);
$PATH .= ":.";
except that if C<$ENV{PATH}> started out empty, the second approach leaves
it with the (odd) value "C<:.>", but the first approach leaves it with "C<.>".
To remove a tied environment variable from
the environment, assign it the undefined value
undef $PATH;
undef @LD_LIBRARY_PATH;
=head1 LIMITATIONS
On VMS systems, arrays tied to environment variables are read-only. Attempting
to change anything will cause a warning.
=head1 AUTHOR
Chip Salzenberg E<lt>F<chip at fin.uucp>E<gt>
and
Gregor N. Purdy E<lt>F<gregor at focusresearch.com>E<gt>
=cut
sub import {
my ($callpack) = caller(0);
my $pack = shift;
my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
return unless @vars;
@vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars;
eval "package $callpack; use vars qw(" . join(' ', @vars) . ")";
die $@ if $@;
foreach (@vars) {
my ($type, $name) = m/^([\$\@])(.*)$/;
if ($type eq '$') {
tie ${"${callpack}::$name"}, Env, $name;
} else {
if ($^O eq 'VMS') {
tie @{"${callpack}::$name"}, Env::Array::VMS, $name;
} else {
tie @{"${callpack}::$name"}, Env::Array, $name;
}
}
}
}
sub TIESCALAR {
bless \($_[1]);
}
sub FETCH {
my ($self) = @_;
$ENV{$$self};
}
sub STORE {
my ($self, $value) = @_;
if (defined($value)) {
$ENV{$$self} = $value;
} else {
delete $ENV{$$self};
}
}
######################################################################
package Env::Array;
use Config;
use Tie::Array;
@ISA = qw(Tie::Array);
my $sep = $Config::Config{path_sep};
sub TIEARRAY {
bless \($_[1]);
}
sub FETCHSIZE {
my ($self) = @_;
my @temp = split($sep, $ENV{$$self});
return scalar(@temp);
}
sub STORESIZE {
my ($self, $size) = @_;
my @temp = split($sep, $ENV{$$self});
$#temp = $size - 1;
$ENV{$$self} = join($sep, @temp);
}
sub CLEAR {
my ($self) = @_;
$ENV{$$self} = '';
}
sub FETCH {
my ($self, $index) = @_;
return (split($sep, $ENV{$$self}))[$index];
}
sub STORE {
my ($self, $index, $value) = @_;
my @temp = split($sep, $ENV{$$self});
$temp[$index] = $value;
$ENV{$$self} = join($sep, @temp);
return $value;
}
sub PUSH {
my $self = shift;
my @temp = split($sep, $ENV{$$self});
push @temp, @_;
$ENV{$$self} = join($sep, @temp);
return scalar(@temp);
}
sub POP {
my ($self) = @_;
my @temp = split($sep, $ENV{$$self});
my $result = pop @temp;
$ENV{$$self} = join($sep, @temp);
return $result;
}
sub UNSHIFT {
my $self = shift;
my @temp = split($sep, $ENV{$$self});
my $result = unshift @temp, @_;
$ENV{$$self} = join($sep, @temp);
return $result;
}
sub SHIFT {
my ($self) = @_;
my @temp = split($sep, $ENV{$$self});
my $result = shift @temp;
$ENV{$$self} = join($sep, @temp);
return $result;
}
sub SPLICE {
my $self = shift;
my $offset = shift;
my $length = shift;
my @temp = split($sep, $ENV{$$self});
if (wantarray) {
my @result = splice @temp, $self, $offset, $length, @_;
$ENV{$$self} = join($sep, @temp);
return @result;
} else {
my $result = scalar splice @temp, $offset, $length, @_;
$ENV{$$self} = join($sep, @temp);
return $result;
}
}
######################################################################
package Env::Array::VMS;
use Tie::Array;
@ISA = qw(Tie::Array);
sub TIEARRAY {
bless \($_[1]);
}
sub FETCHSIZE {
my ($self) = @_;
my $i = 0;
while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
return $i;
}
sub FETCH {
my ($self, $index) = @_;
return $ENV{$$self . ';' . $index};
}
1;
--- NEW FILE: blib.pm ---
package blib;
=head1 NAME
blib - Use MakeMaker's uninstalled version of a package
=head1 SYNOPSIS
perl -Mblib script [args...]
perl -Mblib=dir script [args...]
=head1 DESCRIPTION
Looks for MakeMaker-like I<'blib'> directory structure starting in
I<dir> (or current directory) and working back up to five levels of '..'.
Intended for use on command line with B<-M> option as a way of testing
arbitrary scripts against an uninstalled version of a package.
However it is possible to :
use blib;
or
use blib '..';
etc. if you really must.
=head1 BUGS
Pollutes global name space for development only task.
=head1 AUTHOR
Nick Ing-Simmons nik at tiuk.ti.com
=cut
use Cwd;
use File::Spec;
use vars qw($VERSION $Verbose);
$VERSION = '1.03';
$Verbose = 0;
sub import
{
my $package = shift;
my $dir = getcwd;
if ($^O eq 'VMS') { ($dir = VMS::Filespec::unixify($dir)) =~ s-/\z--; }
if (@_)
{
$dir = shift;
$dir =~ s/blib\z//;
$dir =~ s,/+\z,,;
$dir = File::Spec->curdir unless ($dir);
die "$dir is not a directory\n" unless (-d $dir);
}
my $i = 5;
my($blib, $blib_lib, $blib_arch);
while ($i--)
{
$blib = File::Spec->catdir($dir, "blib");
$blib_lib = File::Spec->catdir($blib, "lib");
if ($^O eq 'MacOS')
{
$blib_arch = File::Spec->catdir($blib_lib, $MacPerl::Architecture);
}
else
{
$blib_arch = File::Spec->catdir($blib, "arch");
}
if (-d $blib && -d $blib_arch && -d $blib_lib)
{
unshift(@INC,$blib_arch,$blib_lib);
warn "Using $blib\n" if $Verbose;
return;
}
$dir = File::Spec->catdir($dir, File::Spec->updir);
}
die "Cannot find blib even in $dir\n";
}
1;
--- NEW FILE: overload.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config;
if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
print "1..0 # Skip -- Perl configured without List::Util module\n";
exit 0;
}
}
package Oscalar;
use overload (
# Anonymous subroutines:
'+' => sub {new Oscalar $ {$_[0]}+$_[1]},
'-' => sub {new Oscalar
$_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
'<=>' => sub {new Oscalar
[...1143 lines suppressed...]
my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2;
my ($ein, $zwei) = (1, 2);
my %map = (one => 1, un => 1, ein => 1, deux => 2, two => 2, zwei => 2);
foreach my $op (qw(<=> == != < <= > >=)) {
foreach my $l (keys %map) {
foreach my $r (keys %map) {
my $ocode = "\$$l $op \$$r";
my $rcode = "$map{$l} $op $map{$r}";
my $got = eval $ocode;
die if $@;
my $expect = eval $rcode;
die if $@;
test ($got, $expect, $ocode) or print "# $rcode\n";
}
}
}
# Last test is:
sub last {493}
--- NEW FILE: Internals.t ---
#!/usr/bin/perl -Tw
BEGIN {
if( $ENV{PERL_CORE} ) {
@INC = '../lib';
chdir 't';
}
}
use Test::More tests => 33;
my $foo;
my @foo;
my %foo;
ok( !Internals::SvREADONLY $foo );
ok( Internals::SvREADONLY $foo, 1 );
ok( Internals::SvREADONLY $foo );
ok( !Internals::SvREADONLY $foo, 0 );
ok( !Internals::SvREADONLY $foo );
ok( !Internals::SvREADONLY @foo );
ok( Internals::SvREADONLY @foo, 1 );
ok( Internals::SvREADONLY @foo );
ok( !Internals::SvREADONLY @foo, 0 );
ok( !Internals::SvREADONLY @foo );
ok( !Internals::SvREADONLY $foo[2] );
ok( Internals::SvREADONLY $foo[2], 1 );
ok( Internals::SvREADONLY $foo[2] );
ok( !Internals::SvREADONLY $foo[2], 0 );
ok( !Internals::SvREADONLY $foo[2] );
ok( !Internals::SvREADONLY %foo );
ok( Internals::SvREADONLY %foo, 1 );
ok( Internals::SvREADONLY %foo );
ok( !Internals::SvREADONLY %foo, 0 );
ok( !Internals::SvREADONLY %foo );
ok( !Internals::SvREADONLY $foo{foo} );
ok( Internals::SvREADONLY $foo{foo}, 1 );
ok( Internals::SvREADONLY $foo{foo} );
ok( !Internals::SvREADONLY $foo{foo}, 0 );
ok( !Internals::SvREADONLY $foo{foo} );
is( Internals::SvREFCNT($foo), 1 );
{
my $bar = \$foo;
is( Internals::SvREFCNT($foo), 2 );
is( Internals::SvREFCNT($bar), 1 );
}
is( Internals::SvREFCNT($foo), 1 );
is( Internals::SvREFCNT(@foo), 1 );
is( Internals::SvREFCNT($foo[2]), 1 );
is( Internals::SvREFCNT(%foo), 1 );
is( Internals::SvREFCNT($foo{foo}), 1 );
--- NEW FILE: NEXT.pm ---
package NEXT;
$VERSION = '0.60';
use Carp;
use strict;
sub NEXT::ELSEWHERE::ancestors
{
my @inlist = shift;
my @outlist = ();
while (my $next = shift @inlist) {
push @outlist, $next;
no strict 'refs';
unshift @inlist, @{"$outlist[-1]::ISA"};
}
return @outlist;
}
sub NEXT::ELSEWHERE::ordered_ancestors
{
my @inlist = shift;
my @outlist = ();
while (my $next = shift @inlist) {
push @outlist, $next;
no strict 'refs';
push @inlist, @{"$outlist[-1]::ISA"};
}
return sort { $a->isa($b) ? -1
: $b->isa($a) ? +1
: 0 } @outlist;
}
sub AUTOLOAD
{
my ($self) = @_;
my $caller = (caller(1))[3];
my $wanted = $NEXT::AUTOLOAD || 'NEXT::AUTOLOAD';
undef $NEXT::AUTOLOAD;
my ($caller_class, $caller_method) = $caller =~ m{(.*)::(.*)}g;
my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
croak "Can't call $wanted from $caller"
unless $caller_method eq $wanted_method;
local ($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN) =
($NEXT::NEXT{$self,$wanted_method}, $NEXT::SEEN);
unless ($NEXT::NEXT{$self,$wanted_method}) {
my @forebears =
NEXT::ELSEWHERE::ancestors ref $self || $self,
$wanted_class;
while (@forebears) {
last if shift @forebears eq $caller_class
}
no strict 'refs';
@{$NEXT::NEXT{$self,$wanted_method}} =
map { *{"${_}::$caller_method"}{CODE}||() } @forebears
unless $wanted_method eq 'AUTOLOAD';
@{$NEXT::NEXT{$self,$wanted_method}} =
map { (*{"${_}::AUTOLOAD"}{CODE}) ? "${_}::AUTOLOAD" : ()} @forebears
unless @{$NEXT::NEXT{$self,$wanted_method}||[]};
$NEXT::SEEN->{$self,*{$caller}{CODE}}++;
}
my $call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
while ($wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/
&& defined $call_method
&& $NEXT::SEEN->{$self,$call_method}++) {
$call_method = shift @{$NEXT::NEXT{$self,$wanted_method}};
}
unless (defined $call_method) {
return unless $wanted_class =~ /^NEXT:.*:ACTUAL/;
(local $Carp::CarpLevel)++;
croak qq(Can't locate object method "$wanted_method" ),
qq(via package "$caller_class");
};
return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
no strict 'refs';
($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*:://
if $wanted_method eq 'AUTOLOAD';
$$call_method = $caller_class."::NEXT::".$wanted_method;
return $call_method->(@_);
}
no strict 'vars';
package NEXT::UNSEEN; @ISA = 'NEXT';
package NEXT::DISTINCT; @ISA = 'NEXT';
package NEXT::ACTUAL; @ISA = 'NEXT';
package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT';
package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT';
package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT';
package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT';
package EVERY::LAST; @ISA = 'EVERY';
package EVERY; @ISA = 'NEXT';
sub AUTOLOAD
{
my ($self) = @_;
my $caller = (caller(1))[3];
my $wanted = $EVERY::AUTOLOAD || 'EVERY::AUTOLOAD';
undef $EVERY::AUTOLOAD;
my ($wanted_class, $wanted_method) = $wanted =~ m{(.*)::(.*)}g;
local $NEXT::ALREADY_IN_EVERY{$self,$wanted_method} =
$NEXT::ALREADY_IN_EVERY{$self,$wanted_method};
return if $NEXT::ALREADY_IN_EVERY{$self,$wanted_method}++;
my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
$wanted_class;
@forebears = reverse @forebears if $wanted_class =~ /\bLAST\b/;
no strict 'refs';
my %seen;
my @every = map { my $sub = "${_}::$wanted_method";
!*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
} @forebears
unless $wanted_method eq 'AUTOLOAD';
my $want = wantarray;
if (@every) {
if ($want) {
return map {($_, [$self->$_(@_[1..$#_])])} @every;
}
elsif (defined $want) {
return { map {($_, scalar($self->$_(@_[1..$#_])))}
@every
};
}
else {
$self->$_(@_[1..$#_]) for @every;
return;
}
}
@every = map { my $sub = "${_}::AUTOLOAD";
!*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
} @forebears;
if ($want) {
return map { $$_ = ref($self)."::EVERY::".$wanted_method;
($_, [$self->$_(@_[1..$#_])]);
} @every;
}
elsif (defined $want) {
return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
($_, scalar($self->$_(@_[1..$#_])))
} @every
};
}
else {
for (@every) {
$$_ = ref($self)."::EVERY::".$wanted_method;
$self->$_(@_[1..$#_]);
}
return;
}
}
1;
__END__
=head1 NAME
NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
=head1 SYNOPSIS
use NEXT;
package A;
sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
package B;
use base qw( A );
sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
package C;
sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
package D;
use base qw( B C );
sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
package main;
my $obj = bless {}, "D";
$obj->method(); # Calls D::method, A::method, C::method
$obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
# Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
=head1 DESCRIPTION
NEXT.pm adds a pseudoclass named C<NEXT> to any program
that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
C<m> is redispatched as if the calling method had not originally been found.
In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
left-to-right search of C<$self>'s class hierarchy that resulted in the
original call to C<m>.
Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
begins a new dispatch that is restricted to searching the ancestors
of the current class. C<$self-E<gt>NEXT::m()> can backtrack
past the current class -- to look for a suitable method in other
ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
A typical use would be in the destructors of a class hierarchy,
as illustrated in the synopsis above. Each class in the hierarchy
has a DESTROY method that performs some class-specific action
and then redispatches the call up the hierarchy. As a result,
when an object of class D is destroyed, the destructors of I<all>
its parent classes are called (in depth-first, left-to-right order).
Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
If such a method determined that it was not able to handle a
particular call, it might choose to redispatch that call, in the
hope that some other C<AUTOLOAD> (above it, or to its left) might
do better.
By default, if a redispatch attempt fails to find another method
elsewhere in the objects class hierarchy, it quietly gives up and does
nothing (but see L<"Enforcing redispatch">). This gracious acquiesence
is also unlike the (generally annoying) behaviour of C<SUPER>, which
throws an exception if it cannot redispatch.
Note that it is a fatal error for any method (including C<AUTOLOAD>)
to attempt to redispatch any method that does not have the
same name. For example:
sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
=head2 Enforcing redispatch
It is possible to make C<NEXT> redispatch more demandingly (i.e. like
C<SUPER> does), so that the redispatch throws an exception if it cannot
find a "next" method to call.
To do this, simple invoke the redispatch as:
$self->NEXT::ACTUAL::method();
rather than:
$self->NEXT::method();
The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
or it should throw an exception.
C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
semantics:
sub AUTOLOAD {
if ($AUTOLOAD =~ /foo|bar/) {
# handle here
}
else { # try elsewhere
shift()->NEXT::ACTUAL::AUTOLOAD(@_);
}
}
By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
method call, an exception will be thrown (as usually happens in the absence of
a suitable C<AUTOLOAD>).
=head2 Avoiding repetitions
If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
# A B
# / \ /
# C D
# \ /
# E
use NEXT;
package A;
sub foo { print "called A::foo\n"; shift->NEXT::foo() }
package B;
sub foo { print "called B::foo\n"; shift->NEXT::foo() }
package C; @ISA = qw( A );
sub foo { print "called C::foo\n"; shift->NEXT::foo() }
package D; @ISA = qw(A B);
sub foo { print "called D::foo\n"; shift->NEXT::foo() }
package E; @ISA = qw(C D);
sub foo { print "called E::foo\n"; shift->NEXT::foo() }
E->foo();
then derived classes may (re-)inherit base-class methods through two or
more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
will invoke the multiply inherited method as many times as it is
inherited. For example, the above code prints:
called E::foo
called C::foo
called A::foo
called D::foo
called A::foo
called B::foo
(i.e. C<A::foo> is called twice).
In some cases this I<may> be the desired effect within a diamond hierarchy,
but in others (e.g. for destructors) it may be more appropriate to
call each method only once during a sequence of redispatches.
To cover such cases, you can redispatch methods via:
$self->NEXT::DISTINCT::method();
rather than:
$self->NEXT::method();
This causes the redispatcher to only visit each distinct C<method> method
once. That is, to skip any classes in the hierarchy that it has
already visited during redispatch. So, for example, if the
previous example were rewritten:
package A;
sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
package B;
sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
package C; @ISA = qw( A );
sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
package D; @ISA = qw(A B);
sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
package E; @ISA = qw(C D);
sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
E->foo();
then it would print:
called E::foo
called C::foo
called A::foo
called D::foo
called B::foo
and omit the second call to C<A::foo> (since it would not be distinct
from the first call to C<A::foo>).
Note that you can also use:
$self->NEXT::DISTINCT::ACTUAL::method();
or:
$self->NEXT::ACTUAL::DISTINCT::method();
to get both unique invocation I<and> exception-on-failure.
Note that, for historical compatibility, you can also use
C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
=head2 Invoking all versions of a method with a single call
Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
Its behaviour is considerably simpler than that of the C<NEXT> family.
A call to:
$obj->EVERY::foo();
calls I<every> method named C<foo> that the object in C<$obj> has inherited.
That is:
use NEXT;
package A; @ISA = qw(B D X);
sub foo { print "A::foo " }
package B; @ISA = qw(D X);
sub foo { print "B::foo " }
package X; @ISA = qw(D);
sub foo { print "X::foo " }
package D;
sub foo { print "D::foo " }
package main;
my $obj = bless {}, 'A';
$obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
Prefixing a method call with C<EVERY::> causes every method in the
object's hierarchy with that name to be invoked. As the above example
illustrates, they are not called in Perl's usual "left-most-depth-first"
order. Instead, they are called "breadth-first-dependency-wise".
That means that the inheritance tree of the object is traversed breadth-first
and the resulting order of classes is used as the sequence in which methods
are called. However, that sequence is modified by imposing a rule that the
appropritae method of a derived class must be called before the same method of
any ancestral class. That's why, in the above example, C<X::foo> is called
before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
In general, there's no need to worry about the order of calls. They will be
left-to-right, breadth-first, most-derived-first. This works perfectly for
most inherited methods (including destructors), but is inappropriate for
some kinds of methods (such as constructors, cloners, debuggers, and
initializers) where it's more appropriate that the least-derived methods be
called first (as more-derived methods may rely on the behaviour of their
"ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
$obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
you can use the C<EVERY::LAST> pseudo-class:
$obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo
which reverses the order of method call.
Whichever version is used, the actual methods are called in the same
context (list, scalar, or void) as the original call via C<EVERY>, and return:
=over
=item *
A hash of array references in list context. Each entry of the hash has the
fully qualified method name as its key and a reference to an array containing
the method's list-context return values as its value.
=item *
A reference to a hash of scalar values in scalar context. Each entry of the hash has the
fully qualified method name as its key and the method's scalar-context return values as its value.
=item *
Nothing in void context (obviously).
=back
=head2 Using C<EVERY> methods
The typical way to use an C<EVERY> call is to wrap it in another base
method, that all classes inherit. For example, to ensure that every
destructor an object inherits is actually called (as opposed to just the
left-most-depth-first-est one):
package Base;
sub DESTROY { $_[0]->EVERY::Destroy }
package Derived1;
use base 'Base';
sub Destroy {...}
package Derived2;
use base 'Base', 'Derived1';
sub Destroy {...}
et cetera. Every derived class than needs its own clean-up
behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
which the call to C<EVERY::LAST::Destroy> in the inherited destructor
then correctly picks up.
Likewise, to create a class hierarchy in which every initializer inherited by
a new object is invoked:
package Base;
sub new {
my ($class, %args) = @_;
my $obj = bless {}, $class;
$obj->EVERY::LAST::Init(\%args);
}
package Derived1;
use base 'Base';
sub Init {
my ($argsref) = @_;
...
}
package Derived2;
use base 'Base', 'Derived1';
sub Init {
my ($argsref) = @_;
...
}
et cetera. Every derived class than needs some additional initialization
behaviour simply adds its own C<Init> method (I<not> a C<new> method),
which the call to C<EVERY::LAST::Init> in the inherited constructor
then correctly picks up.
=head1 AUTHOR
Damian Conway (damian at conway.org)
=head1 BUGS AND IRRITATIONS
Because it's a module, not an integral part of the interpreter, NEXT.pm
has to guess where the surrounding call was found in the method
look-up sequence. In the presence of diamond inheritance patterns
it occasionally guesses wrong.
It's also too slow (despite caching).
Comment, suggestions, and patches welcome.
=head1 COPYRIGHT
Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
This module is free software. It may be used, redistributed
and/or modified under the same terms as Perl itself.
--- NEW FILE: Exporter.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
# Can't use Test::Simple/More, they depend on Exporter.
my $test = 1;
sub ok ($;$) {
my($ok, $name) = @_;
# You have to do it this way or VMS will get confused.
printf "%sok %d%s\n", ($ok ? '' : 'not '), $test,
(defined $name ? " - $name" : '');
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
$test++;
return $ok;
}
print "1..28\n";
require Exporter;
ok( 1, 'Exporter compiled' );
BEGIN {
# Methods which Exporter says it implements.
@Exporter_Methods = qw(import
export_to_level
require_version
export_fail
);
}
package Testing;
require Exporter;
@ISA = qw(Exporter);
# Make sure Testing can do everything its supposed to.
foreach my $meth (@::Exporter_Methods) {
::ok( Testing->can($meth), "subclass can $meth()" );
}
%EXPORT_TAGS = (
This => [qw(stuff %left)],
That => [qw(Above the @wailing)],
tray => [qw(Fasten $seatbelt)],
);
@EXPORT = qw(lifejacket is);
@EXPORT_OK = qw(under &your $seat);
$VERSION = '1.05';
::ok( Testing->require_version(1.05), 'require_version()' );
eval { Testing->require_version(1.11); 1 };
::ok( $@, 'require_version() fail' );
::ok( Testing->require_version(0), 'require_version(0)' );
sub lifejacket { 'lifejacket' }
sub stuff { 'stuff' }
sub Above { 'Above' }
sub the { 'the' }
sub Fasten { 'Fasten' }
sub your { 'your' }
sub under { 'under' }
use vars qw($seatbelt $seat @wailing %left);
$seatbelt = 'seatbelt';
$seat = 'seat';
@wailing = qw(AHHHHHH);
%left = ( left => "right" );
BEGIN {*is = \&Is};
sub Is { 'Is' };
Exporter::export_ok_tags;
my %tags = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS;
my %exportok = map { $_ => 1 } @EXPORT_OK;
my $ok = 1;
foreach my $tag (keys %tags) {
$ok = exists $exportok{$tag};
}
::ok( $ok, 'export_ok_tags()' );
package Foo;
Testing->import;
::ok( defined &lifejacket, 'simple import' );
my $got = eval {&lifejacket};
::ok ( $@ eq "", 'check we can call the imported subroutine')
or print STDERR "# \$\@ is $@\n";
::ok ( $got eq 'lifejacket', 'and that it gave the correct result')
or print STDERR "# expected 'lifejacket', got " .
(defined $got ? "'$got'" : "undef") . "\n";
# The string eval is important. It stops $Foo::{is} existing when
# Testing->import is called.
::ok( eval "defined &is",
"Import a subroutine where exporter must create the typeglob" );
my $got = eval "&is";
::ok ( $@ eq "", 'check we can call the imported autoloaded subroutine')
or chomp ($@), print STDERR "# \$\@ is $@\n";
::ok ( $got eq 'Is', 'and that it gave the correct result')
or print STDERR "# expected 'Is', got " .
(defined $got ? "'$got'" : "undef") . "\n";
package Bar;
my @imports = qw($seatbelt &Above stuff @wailing %left);
Testing->import(@imports);
::ok( (!grep { eval "!defined $_" } map({ /^\w/ ? "&$_" : $_ } @imports)),
'import by symbols' );
package Yar;
my @tags = qw(:This :tray);
Testing->import(@tags);
::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}),
'import by tags' );
package Arrr;
Testing->import(qw(!lifejacket));
::ok( !defined &lifejacket, 'deny import by !' );
package Mars;
Testing->import('/e/');
::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
'import by regex');
package Venus;
Testing->import('!/e/');
::ok( (!grep { eval "defined $_" } map { /^\w/ ? "&$_" : $_ }
grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
'deny import by regex');
::ok( !defined &lifejacket, 'further denial' );
package More::Testing;
@ISA = qw(Exporter);
$VERSION = 0;
eval { More::Testing->require_version(0); 1 };
::ok(!$@, 'require_version(0) and $VERSION = 0');
package Yet::More::Testing;
@ISA = qw(Exporter);
$VERSION = 0;
eval { Yet::More::Testing->require_version(10); 1 };
::ok($@ !~ /\(undef\)/, 'require_version(10) and $VERSION = 0');
my $warnings;
BEGIN {
$SIG{__WARN__} = sub { $warnings = join '', @_ };
package Testing::Unused::Vars;
@ISA = qw(Exporter);
@EXPORT = qw(this $TODO that);
package Foo;
Testing::Unused::Vars->import;
}
::ok( !$warnings, 'Unused variables can be exported without warning' ) ||
print "# $warnings\n";
package Moving::Target;
@ISA = qw(Exporter);
@EXPORT_OK = qw (foo);
sub foo {"foo"};
sub bar {"bar"};
package Moving::Target::Test;
Moving::Target->import (foo);
::ok (foo eq "foo", "imported foo before EXPORT_OK changed");
push @Moving::Target::EXPORT_OK, 'bar';
Moving::Target->import (bar);
::ok (bar eq "bar", "imported bar after EXPORT_OK changed");
package The::Import;
use Exporter 'import';
eval { import() };
::ok(\&import == \&Exporter::import, "imported the import routine");
@EXPORT = qw( wibble );
sub wibble {return "wobble"};
package Use::The::Import;
The::Import->import;
my $val = eval { wibble() };
::ok($val eq "wobble", "exported importer worked");
--- NEW FILE: filetest.pm ---
package filetest;
our $VERSION = '1.01';
=head1 NAME
filetest - Perl pragma to control the filetest permission operators
=head1 SYNOPSIS
$can_perhaps_read = -r "file"; # use the mode bits
{
use filetest 'access'; # intuit harder
$can_really_read = -r "file";
}
$can_perhaps_read = -r "file"; # use the mode bits again
=head1 DESCRIPTION
This pragma tells the compiler to change the behaviour of the filetest
permission operators, C<-r> C<-w> C<-x> C<-R> C<-W> C<-X>
(see L<perlfunc>).
The default behaviour is to use the mode bits as returned by the stat()
family of calls. This, however, may not be the right thing to do if
for example various ACL (access control lists) schemes are in use.
For such environments, C<use filetest> may help the permission
operators to return results more consistent with other tools.
Each "use filetest" or "no filetest" affects statements to the end of
the enclosing block.
There may be a slight performance decrease in the filetests
when C<use filetest> is in effect, because in some systems
the extended functionality needs to be emulated.
B<NOTE>: using the file tests for security purposes is a lost cause
from the start: there is a window open for race conditions (who is to
say that the permissions will not change between the test and the real
operation?). Therefore if you are serious about security, just try
the real operation and test for its success - think in terms of atomic
operations.
=head2 subpragma access
Currently only one subpragma, C<access> is implemented. It enables
(or disables) the use of access() or similar system calls. This
extended filetest functionality is used only when the argument of the
operators is a filename, not when it is a filehandle.
=cut
$filetest::hint_bits = 0x00400000; # HINT_FILETEST_ACCESS
sub import {
if ( $_[1] eq 'access' ) {
$^H |= $filetest::hint_bits;
} else {
die "filetest: the only implemented subpragma is 'access'.\n";
}
}
sub unimport {
if ( $_[1] eq 'access' ) {
$^H &= ~$filetest::hint_bits;
} else {
die "filetest: the only implemented subpragma is 'access'.\n";
}
}
1;
--- NEW FILE: diagnostics.t ---
#!./perl
BEGIN {
if ($^O eq 'MacOS') {
chdir '::' if -d '::pod' && -d '::t';
@INC = ':lib:';
} else {
chdir '..' if -d '../pod' && -d '../t';
@INC = 'lib';
}
}
use Test::More tests => 2;
BEGIN { use_ok('diagnostics') }
require base;
eval {
'base'->import(qw(I::do::not::exist));
};
like( $@, qr/^Base class package "I::do::not::exist" is empty/);
--- NEW FILE: DirHandle.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
if (not $Config{'d_readdir'}) {
print "1..0\n";
exit 0;
}
}
use DirHandle;
require './test.pl';
plan(5);
$dot = new DirHandle ($^O eq 'MacOS' ? ':' : '.');
ok(defined($dot));
@a = sort <*>;
do { $first = $dot->read } while defined($first) && $first =~ /^\./;
ok(+(grep { $_ eq $first } @a));
@b = sort($first, (grep {/^[^.]/} $dot->read));
ok(+(join("\0", @a) eq join("\0", @b)));
$dot->rewind;
@c = sort grep {/^[^.]/} $dot->read;
cmp_ok(+(join("\0", @b), 'eq', join("\0", @c)));
$dot->close;
$dot->rewind;
ok(!defined($dot->read));
--- NEW FILE: sigtrap.pm ---
package sigtrap;
=head1 NAME
sigtrap - Perl pragma to enable simple signal handling
=cut
use Carp;
$VERSION = 1.02;
$Verbose ||= 0;
sub import {
my $pkg = shift;
my $handler = \&handler_traceback;
my $saw_sig = 0;
my $untrapped = 0;
local $_;
Arg_loop:
while (@_) {
$_ = shift;
if (/^[A-Z][A-Z0-9]*$/) {
$saw_sig++;
unless ($untrapped and $SIG{$_} and $SIG{$_} ne 'DEFAULT') {
print "Installing handler $handler for $_\n" if $Verbose;
$SIG{$_} = $handler;
}
}
elsif ($_ eq 'normal-signals') {
unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM));
}
elsif ($_ eq 'error-signals') {
unshift @_, grep(exists $SIG{$_},
qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP));
}
elsif ($_ eq 'old-interface-signals') {
unshift @_,
grep(exists $SIG{$_},
qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP));
}
elsif ($_ eq 'stack-trace') {
$handler = \&handler_traceback;
}
elsif ($_ eq 'die') {
$handler = \&handler_die;
}
elsif ($_ eq 'handler') {
@_ or croak "No argument specified after 'handler'";
$handler = shift;
unless (ref $handler or $handler eq 'IGNORE'
or $handler eq 'DEFAULT') {
require Symbol;
$handler = Symbol::qualify($handler, (caller)[0]);
}
}
elsif ($_ eq 'untrapped') {
$untrapped = 1;
}
elsif ($_ eq 'any') {
$untrapped = 0;
}
elsif ($_ =~ /^\d/) {
$VERSION >= $_ or croak "sigtrap.pm version $_ required,"
. " but this is only version $VERSION";
}
else {
croak "Unrecognized argument $_";
}
}
unless ($saw_sig) {
@_ = qw(old-interface-signals);
goto Arg_loop;
}
}
sub handler_die {
croak "Caught a SIG$_[0]";
}
sub handler_traceback {
package DB; # To get subroutine args.
$SIG{'ABRT'} = DEFAULT;
kill 'ABRT', $$ if $panic++;
syswrite(STDERR, 'Caught a SIG', 12);
syswrite(STDERR, $_[0], length($_[0]));
syswrite(STDERR, ' at ', 4);
($pack,$file,$line) = caller;
syswrite(STDERR, $file, length($file));
syswrite(STDERR, ' line ', 6);
syswrite(STDERR, $line, length($line));
syswrite(STDERR, "\n", 1);
# Now go for broke.
for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
@a = ();
for $arg (@args) {
$_ = "$arg";
s/([\'\\])/\\$1/g;
s/([^\0]*)/'$1'/
unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
push(@a, $_);
}
$w = $w ? '@ = ' : '$ = ';
$a = $h ? '(' . join(', ', @a) . ')' : '';
$e =~ s/\n\s*\;\s*\Z// if $e;
$e =~ s/[\\\']/\\$1/g if $e;
if ($r) {
$s = "require '$e'";
} elsif (defined $r) {
$s = "eval '$e'";
} elsif ($s eq '(eval)') {
$s = "eval {...}";
}
$f = "file `$f'" unless $f eq '-e';
$mess = "$w$s$a called from $f line $l\n";
syswrite(STDERR, $mess, length($mess));
}
kill 'ABRT', $$;
}
1;
__END__
=head1 SYNOPSIS
use sigtrap;
use sigtrap qw(stack-trace old-interface-signals); # equivalent
use sigtrap qw(BUS SEGV PIPE ABRT);
use sigtrap qw(die INT QUIT);
use sigtrap qw(die normal-signals);
use sigtrap qw(die untrapped normal-signals);
use sigtrap qw(die untrapped normal-signals
stack-trace any error-signals);
use sigtrap 'handler' => \&my_handler, 'normal-signals';
use sigtrap qw(handler my_handler normal-signals
stack-trace error-signals);
=head1 DESCRIPTION
The B<sigtrap> pragma is a simple interface to installing signal
handlers. You can have it install one of two handlers supplied by
B<sigtrap> itself (one which provides a Perl stack trace and one which
simply C<die()>s), or alternately you can supply your own handler for it
to install. It can be told only to install a handler for signals which
are either untrapped or ignored. It has a couple of lists of signals to
trap, plus you can supply your own list of signals.
The arguments passed to the C<use> statement which invokes B<sigtrap>
are processed in order. When a signal name or the name of one of
B<sigtrap>'s signal lists is encountered a handler is immediately
installed, when an option is encountered it affects subsequently
installed handlers.
=head1 OPTIONS
=head2 SIGNAL HANDLERS
These options affect which handler will be used for subsequently
installed signals.
=over 4
=item B<stack-trace>
The handler used for subsequently installed signals outputs a Perl stack
trace to STDERR and then tries to dump core. This is the default signal
handler.
=item B<die>
The handler used for subsequently installed signals calls C<die>
(actually C<croak>) with a message indicating which signal was caught.
=item B<handler> I<your-handler>
I<your-handler> will be used as the handler for subsequently installed
signals. I<your-handler> can be any value which is valid as an
assignment to an element of C<%SIG>.
=back
=head2 SIGNAL LISTS
B<sigtrap> has a few built-in lists of signals to trap. They are:
=over 4
=item B<normal-signals>
These are the signals which a program might normally expect to encounter
and which by default cause it to terminate. They are HUP, INT, PIPE and
TERM.
=item B<error-signals>
These signals usually indicate a serious problem with the Perl
interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL,
QUIT, SEGV, SYS and TRAP.
=item B<old-interface-signals>
These are the signals which were trapped by default by the old
B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT,
SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to
B<sigtrap>, this list is used.
=back
For each of these three lists, the collection of signals set to be
trapped is checked before trapping; if your architecture does not
implement a particular signal, it will not be trapped but rather
silently ignored.
=head2 OTHER
=over 4
=item B<untrapped>
This token tells B<sigtrap> to install handlers only for subsequently
listed signals which aren't already trapped or ignored.
=item B<any>
This token tells B<sigtrap> to install handlers for all subsequently
listed signals. This is the default behavior.
=item I<signal>
Any argument which looks like a signal name (that is,
C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a
handler for that name.
=item I<number>
Require that at least version I<number> of B<sigtrap> is being used.
=back
=head1 EXAMPLES
Provide a stack trace for the old-interface-signals:
use sigtrap;
Ditto:
use sigtrap qw(stack-trace old-interface-signals);
Provide a stack trace on the 4 listed signals only:
use sigtrap qw(BUS SEGV PIPE ABRT);
Die on INT or QUIT:
use sigtrap qw(die INT QUIT);
Die on HUP, INT, PIPE or TERM:
use sigtrap qw(die normal-signals);
Die on HUP, INT, PIPE or TERM, except don't change the behavior for
signals which are already trapped or ignored:
use sigtrap qw(die untrapped normal-signals);
Die on receipt one of an of the B<normal-signals> which is currently
B<untrapped>, provide a stack trace on receipt of B<any> of the
B<error-signals>:
use sigtrap qw(die untrapped normal-signals
stack-trace any error-signals);
Install my_handler() as the handler for the B<normal-signals>:
use sigtrap 'handler', \&my_handler, 'normal-signals';
Install my_handler() as the handler for the normal-signals, provide a
Perl stack trace on receipt of one of the error-signals:
use sigtrap qw(handler my_handler normal-signals
stack-trace error-signals);
=cut
--- NEW FILE: DB.t ---
#!./perl -Tw
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config;
if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
print "1..0 # Skip -- Perl configured without List::Util module\n";
exit 0;
}
}
# symbolic references used later
use strict qw( vars subs );
# @DB::dbline values have both integer and string components (Benjamin Goldberg)
use Scalar::Util qw( dualvar );
my $dualfalse = dualvar(0, 'false');
my $dualtrue = dualvar(1, 'true');
use Test::More tests => 106;
# must happen at compile time for DB:: package variable localizations to work
BEGIN {
use_ok( 'DB' );
}
# test DB::sub()
{
my $callflag = 0;
local $DB::sub = sub {
$callflag += shift || 1;
my @vals = (1, 4, 9);
return @vals;
};
my $ret = DB::sub;
is( $ret, 3, 'DB::sub() should handle scalar context' );
is( $callflag, 1, '... should call $DB::sub contents' );
$ret = join(' ', DB::sub(2));
is( $ret, '1 4 9', '... should handle scalar context' );
is( $callflag, 3, '... should pass along arguments to the sub' );
ok( defined($DB::ret),'$DB::ret should be defined after successful return');
DB::sub;
ok( !defined($DB::ret), '... should respect void context' );
$DB::sub = '::DESTROY';
ok( !defined($DB::ret), '... should return undef for DESTROY()' );
}
# test DB::DB()
{
ok( ! defined DB::DB(),
'DB::DB() should return undef if $DB::ready is false');
is( DB::catch(), 1, 'DB::catch() should work' );
is( DB->skippkg('foo'), 1, 'DB->skippkg() should push args' );
# change packages to mess with caller()
package foo;
::ok( ! defined DB::DB(), 'DB::DB() should skip skippable packages' );
package main;
is( $DB::filename, $0, '... should set $DB::filename' );
is( $DB::lineno, __LINE__ - 4, '... should set $DB::lineno' );
DB::DB();
# stops at line 94
}
# test DB::save()
{
no warnings 'uninitialized';
# assigning a number to $! seems to produce an error message, when read
local ($@, $,, $/, $\, $^W, $!) = (1 .. 5);
DB::save();
is( "$@$!$,$/$\$^W", "1\n0", 'DB::save() should reset punctuation vars' );
}
# test DB::catch()
{
local $DB::signal;
DB::catch();
ok( $DB::signal, 'DB::catch() should set $DB::signal' );
# add clients and test to see if they are awakened
}
# test DB::_clientname()
is( DB::_clientname('foo=A(1)'), 'foo',
'DB::_clientname should return refname');
cmp_ok( DB::_clientname('bar'), 'eq', '',
'DB::_clientname should not return non refname');
# test DB::next() and DB::step()
{
local $DB::single;
DB->next();
is( $DB::single, 2, 'DB->next() should set $DB::single to 2' );
DB->step();
is( $DB::single, 1, 'DB->step() should set $DB::single to 1' );
}
# test DB::cont()
{
# cannot test @stack
local $DB::single = 1;
my $fdb = FakeDB->new();
DB::cont($fdb, 2);
is( $fdb->{tbreak}, 2, 'DB::cont() should set tbreak in object' );
is( $DB::single, 0, '... should set $DB::single to 0' );
}
# test DB::ret()
{
# cannot test @stack
local $DB::single = 1;
DB::ret();
is( $DB::single, 0, 'DB::ret() should set $DB::single to 0' );
}
# test DB::backtrace()
{
local (@DB::args, $DB::signal);
my $line = __LINE__ + 1;
my @ret = eval { DB->backtrace() };
like( $ret[0], qr/file.+\Q$0\E/, 'DB::backtrace() should report current file');
like( $ret[0], qr/line $line/, '... should report calling line number' );
like( $ret[0], qr/eval {...}/, '... should catch eval BLOCK' );
@ret = eval "one(2)";
is( scalar @ret, 1, '... should report from provided stack frame number' );
like( $ret[0], qr/\@ = &eval \'one.+?2\)\'/, #'
'... should find eval STRING construct');
$ret[0] = check_context(1);
like( $ret[0], qr/\$ = &main::check_context/,
'... should respect context of calling construct');
$DB::signal = 1;
@DB::args = (1, 7);
@ret = three(1);
is( scalar @ret, 1, '... should end loop if $DB::signal is true' );
# does not check 'require' or @DB::args mangling
}
sub check_context {
return (eval "one($_[0])")[-1];
}
sub one { DB->backtrace(@_) }
sub two { one(@_) }
sub three { two(@_) }
# test DB::trace_toggle
{
local $DB::trace = 0;
DB->trace_toggle;
ok( $DB::trace, 'DB::trace_toggle() should toggle $DB::trace' );
DB->trace_toggle;
ok( !$DB::trace, '... should toggle $DB::trace (back)' );
}
# test DB::subs()
{
local %DB::sub;
my $subs = DB->subs;
is( $subs, 0, 'DB::subs() should return keys of %DB::subs' );
%DB::sub = ( foo => 'foo:23-45' , bar => 'ba:r:7-890' );
$subs = DB->subs;
is( $subs, 2, '... same song, different key' );
my @subs = DB->subs( 'foo', 'boo', 'bar' );
is( scalar @subs, 2, '... should report only for requested subs' );
my @expected = ( [ 'foo', 23, 45 ], [ 'ba:r', 7, 890 ] );
ok( eq_array( \@subs, \@expected ), '... find file, start, end for subs' );
}
# test DB::filesubs()
{
local ($DB::filename, %DB::sub);
$DB::filename = 'baz';
%DB::sub = map { $_ => $_ } qw( bazbar bazboo boobar booboo boobaz );
my @ret = DB->filesubs();
is( scalar @ret, 2, 'DB::filesubs() should use $DB::filename with no args');
@ret = grep { /^baz/ } @ret;
is( scalar @ret, 2, '... should pick up subs in proper file' );
@ret = DB->filesubs('boo');
is( scalar @ret, 3, '... should use argument to find subs' );
@ret = grep { /^boo/ } @ret;
is( scalar @ret, 3, '... should pick up subs in proper file with argument');
}
# test DB::files()
{
my $dbf = () = DB::files();
my $main = () = grep ( m!^_<!, keys %main:: );
is( $dbf, $main, 'DB::files() should pick up filenames from %main::' );
}
# test DB::lines()
{
local @DB::dbline = ( 'foo' );
is( DB->lines->[0], 'foo', 'DB::lines() should return ref to @DB::dbline' );
}
# test DB::loadfile()
SKIP: {
local (*DB::dbline, $DB::filename);
ok( ! defined DB->loadfile('notafile'),
'DB::loadfile() should not find unloaded file' );
my $file = (grep { m|^_<.+\.pm| } keys %main:: )[0];
skip('cannot find loaded file', 3) unless $file;
$file =~ s/^_<..//;
my $db = DB->loadfile($file);
like( $db, qr!$file\z!, '... should find loaded file from partial name');
is( *DB::dbline, *{ "_<$db" } ,
'... should set *DB::dbline to associated glob');
is( $DB::filename, $db, '... should set $DB::filename to file name' );
# test clients
}
# test DB::lineevents()
{
use vars qw( *baz );
local $DB::filename = 'baz';
local *baz = *{ "main::_<baz" };
@baz = map { dualvar(1, $_) } qw( one two three four five );
%baz = (
1 => "foo\0bar",
3 => "boo\0far",
4 => "fazbaz",
);
my %ret = DB->lineevents();
is( scalar keys %ret, 3, 'DB::lineevents() should pick up defined lines' );
# array access in DB::lineevents() starts at element 1, not 0
is( join(' ', @{ $ret{1} }), 'two foo bar', '... should stash data in hash');
}
# test DB::set_break()
{
local ($DB::lineno, *DB::dbline, $DB::package);
%DB::dbline = (
1 => "\0",
2 => undef,
3 => "123\0\0\0abc",
4 => "\0abc",
);
*DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ];
local %DB::sub = (
'main::foo' => 'foo:1-4',
);
DB->set_break(1, 'foo');
is( $DB::dbline{1}, "foo\0", 'DB::set_break() should set break condition' );
$DB::lineno = 1;
DB->set_break(undef, 'bar');
is( $DB::dbline{1}, "bar\0",
'... should use $DB::lineno without specified line' );
DB->set_break(4);
is( $DB::dbline{4}, "1\0abc", '... should use default condition if needed');
local %DB::sub = (
'main::foo' => 'foo:1-4',
);
DB->set_break('foo', 'baz');
is( $DB::dbline{4}, "baz\0abc",
'... should use _find_subline() to resolve subname' );
my $db = FakeDB->new();
DB::set_break($db, 2);
like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
DB::set_break($db, 'nonfoo');
like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
}
# test DB::set_tbreak()
{
local ($DB::lineno, *DB::dbline, $DB::package);
*DB::dbline = [ $dualfalse, $dualtrue, $dualfalse, $dualfalse, $dualtrue ];
DB->set_tbreak(1);
is( $DB::dbline{1}, ';9', 'DB::set_tbreak() should set tbreak condition' );
local %DB::sub = (
'main::foo' => 'foo:1-4',
);
DB->set_tbreak('foo', 'baz');
is( $DB::dbline{4}, ';9',
'... should use _find_subline() to resolve subname' );
my $db = FakeDB->new();
DB::set_tbreak($db, 2);
like( $db->{output}, qr/2 not break/, '... should respect @DB::dbline' );
DB::set_break($db, 'nonfoo');
like( $db->{output}, qr/not found/, '... should warn on unfound sub' );
}
# test DB::_find_subline()
{
my @foo;
local *{ "::_<foo" } = \@foo;
local $DB::package;
local %DB::sub = (
'TEST::foo' => 'foo:10-15',
'main::foo' => 'foo:11-12',
'bar::bar' => 'foo:10-16',
);
$foo[11] = $dualtrue;
is( DB::_find_subline('TEST::foo'), 11,
'DB::_find_subline() should find fully qualified sub' );
is( DB::_find_subline("TEST'foo"), 11, '... should handle old package sep');
is( DB::_find_subline('foo'), 11,
'... should resolve unqualified package name to main::' );
$DB::package = 'bar';
is( DB::_find_subline('bar'), 11,
'... should resolve unqualified name with $DB::package, if defined' );
$foo[11] = $dualfalse;
is( DB::_find_subline('TEST::foo'), 15,
'... should increment past lines with no events' );
ok( ! defined DB::_find_subline('sirnotappearinginthisfilm'),
'... should not find nonexistant sub' );
}
# test DB::clr_breaks()
{
local *DB::dbline;
my %lines = (
1 => "\0",
2 => undef,
3 => "123\0\0\0abc",
4 => "\0\0\0abc",
);
%DB::dbline = %lines;
DB->clr_breaks(1 .. 4);
is( scalar keys %DB::dbline, 3, 'DB::clr_breaks() should clear breaks' );
ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action');
is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' );
local *{ "::_<foo" } = [ 0, 0, 0, 1 ];
local $DB::package;
local %DB::sub = (
'main::foo' => 'foo:1-3',
);
%DB::dbline = %lines;
DB->clr_breaks('foo');
is( $DB::dbline{3}, "\0\0\0abc",
'... should find lines via _find_subline()' );
my $db = FakeDB->new();
DB::clr_breaks($db, 'abadsubname');
is( $db->{output}, "Subroutine not found.\n",
'... should output warning if sub cannot be found');
@DB::dbline = (1 .. 4);
%DB::dbline = (%lines, 5 => "\0" );
DB::clr_breaks();
is( scalar keys %DB::dbline, 4,
'Relying on @DB::dbline in DB::clr_breaks() should clear breaks' );
ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
is( $DB::dbline{3}, "\0\0\0abc", '... should remove break, leaving action');
is( $DB::dbline{4}, "\0\0\0abc", '... should not remove set actions' );
ok( exists($DB::dbline{5}),
'... should only go to last index of @DB::dbline' );
}
# test DB::set_action()
{
local *DB::dbline;
%DB::dbline = (
2 => "\0abc",
);
*DB::dbline = [ $dualfalse, $dualfalse, $dualtrue, $dualtrue ];
DB->set_action(2, 'def');
is( $DB::dbline{2}, "\0def",
'DB::set_action() should replace existing action' );
DB->set_action(3, '');
is( $DB::dbline{3}, "\0", '... should set new action' );
my $db = FakeDB->new();
DB::set_action($db, 'abadsubname');
is( $db->{output}, "Subroutine not found.\n",
'... should output warning if sub cannot be found');
DB::set_action($db, 1);
like( $db->{output}, qr/1 not action/,
'... should warn if line cannot be actionivated' );
}
# test DB::clr_actions()
{
local *DB::dbline;
my %lines = (
1 => "\0",
2 => undef,
3 => "123\0abc",
4 => "abc\0",
);
%DB::dbline = %lines;
*DB::dbline = [ ($dualtrue) x 4 ];
DB->clr_actions(1 .. 4);
is( scalar keys %DB::dbline, 2, 'DB::clr_actions() should clear actions' );
ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
is( $DB::dbline{3}, "123", '... should remove action, leaving break');
is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' );
local *{ "::_<foo" } = [ 0, 0, 0, 1 ];
local $DB::package;
local %DB::sub = (
'main::foo' => 'foo:1-3',
);
%DB::dbline = %lines;
DB->clr_actions('foo');
is( $DB::dbline{3}, "123", '... should find lines via _find_subline()' );
my $db = FakeDB->new();
DB::clr_actions($db, 'abadsubname');
is( $db->{output}, "Subroutine not found.\n",
'... should output warning if sub cannot be found');
@DB::dbline = (1 .. 4);
%DB::dbline = (%lines, 5 => "\0" );
DB::clr_actions();
is( scalar keys %DB::dbline, 4,
'Relying on @DB::dbline in DB::clr_actions() should clear actions' );
ok( ! exists($DB::dbline{1}), '... should delete empty actions' );
is( $DB::dbline{3}, "123", '... should remove action, leaving break');
is( $DB::dbline{4}, "abc\0", '... should not remove set breaks' );
ok( exists($DB::dbline{5}),
'... should only go to last index of @DB::dbline' );
}
# test DB::prestop()
ok( ! defined DB::prestop('test'),
'DB::prestop() should return undef for undef value' );
DB::prestop('test', 897);
is( DB::prestop('test'), 897, '... should return value when set' );
# test DB::poststop(), not exactly parallel
ok( ! defined DB::poststop('tset'),
'DB::prestop() should return undef for undef value' );
DB::poststop('tset', 987);
is( DB::poststop('tset'), 987, '... should return value when set' );
# test DB::evalcode()
ok( ! defined DB::evalcode('foo'),
'DB::evalcode() should return undef for undef value' );
DB::evalcode('foo', 'bar');
is( DB::evalcode('foo'), 'bar', '... should return value when set' );
# test DB::_outputall(), must create fake clients first
ok( DB::register( FakeDB->new() ), 'DB::register() should work' );
DB::register( FakeDB->new() ) for ( 1 .. 2);
DB::_outputall(1, 2, 3);
is( $FakeDB::output, '123123123',
'DB::_outputall() should call output(@_) on all clients' );
# test virtual methods
for my $method (qw( cprestop cpoststop awaken init stop idle cleanup output )) {
ok( defined &{ "DB::$method" }, "DB::$method() should be defined" );
}
# DB::skippkg() uses lexical
# DB::ready() uses lexical
package FakeDB;
use vars qw( $output );
sub new {
bless({}, $_[0]);
}
sub set_tbreak {
my ($self, $val) = @_;
$self->{tbreak} = $val;
}
sub output {
my $self = shift;
if (ref $self) {
$self->{output} = join('', @_);
} else {
$output .= join('', @_);
}
}
--- NEW FILE: Digest.pm ---
package Digest;
use strict;
use vars qw($VERSION %MMAP $AUTOLOAD);
$VERSION = "1.14";
%MMAP = (
"SHA-1" => ["Digest::SHA1", ["Digest::SHA", 1], ["Digest::SHA2", 1]],
"SHA-224" => [["Digest::SHA", 224]],
"SHA-256" => [["Digest::SHA", 256], ["Digest::SHA2", 256]],
"SHA-384" => [["Digest::SHA", 384], ["Digest::SHA2", 384]],
"SHA-512" => [["Digest::SHA", 512], ["Digest::SHA2", 512]],
"HMAC-MD5" => "Digest::HMAC_MD5",
"HMAC-SHA-1" => "Digest::HMAC_SHA1",
"CRC-16" => [["Digest::CRC", type => "crc16"]],
"CRC-32" => [["Digest::CRC", type => "crc32"]],
"CRC-CCITT" => [["Digest::CRC", type => "crcccitt"]],
);
sub new
{
shift; # class ignored
my $algorithm = shift;
my $impl = $MMAP{$algorithm} || do {
$algorithm =~ s/\W+//;
"Digest::$algorithm";
};
$impl = [$impl] unless ref($impl);
my $err;
for (@$impl) {
my $class = $_;
my @args;
($class, @args) = @$class if ref($class);
no strict 'refs';
unless (exists ${"$class\::"}{"VERSION"}) {
eval "require $class";
if ($@) {
$err ||= $@;
next;
}
}
return $class->new(@args, @_);
}
die $err;
}
sub AUTOLOAD
{
my $class = shift;
my $algorithm = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
$class->new($algorithm, @_);
}
1;
__END__
=head1 NAME
Digest - Modules that calculate message digests
=head1 SYNOPSIS
$md5 = Digest->new("MD5");
$sha1 = Digest->new("SHA-1");
$sha256 = Digest->new("SHA-256");
$sha384 = Digest->new("SHA-384");
$sha512 = Digest->new("SHA-512");
$hmac = Digest->HMAC_MD5($key);
=head1 DESCRIPTION
The C<Digest::> modules calculate digests, also called "fingerprints"
or "hashes", of some data, called a message. The digest is (usually)
some small/fixed size string. The actual size of the digest depend of
the algorithm used. The message is simply a sequence of arbitrary
bytes or bits.
An important property of the digest algorithms is that the digest is
I<likely> to change if the message change in some way. Another
property is that digest functions are one-way functions, that is it
should be I<hard> to find a message that correspond to some given
digest. Algorithms differ in how "likely" and how "hard", as well as
how efficient they are to compute.
Note that the properties of the algorithms change over time, as the
algorithms are analyzed and machines grow faster. If your application
for instance depends on it being "impossible" to generate the same
digest for a different message it is wise to make it easy to plug in
stronger algorithms as the one used grow weaker. Using the interface
documented here should make it easy to change algorithms later.
All C<Digest::> modules provide the same programming interface. A
functional interface for simple use, as well as an object oriented
interface that can handle messages of arbitrary length and which can
read files directly.
The digest can be delivered in three formats:
=over 8
=item I<binary>
This is the most compact form, but it is not well suited for printing
or embedding in places that can't handle arbitrary data.
=item I<hex>
A twice as long string of lowercase hexadecimal digits.
=item I<base64>
A string of portable printable characters. This is the base64 encoded
representation of the digest with any trailing padding removed. The
string will be about 30% longer than the binary version.
L<MIME::Base64> tells you more about this encoding.
=back
The functional interface is simply importable functions with the same
name as the algorithm. The functions take the message as argument and
return the digest. Example:
use Digest::MD5 qw(md5);
$digest = md5($message);
There are also versions of the functions with "_hex" or "_base64"
appended to the name, which returns the digest in the indicated form.
=head1 OO INTERFACE
The following methods are available for all C<Digest::> modules:
=over 4
=item $ctx = Digest->XXX($arg,...)
=item $ctx = Digest->new(XXX => $arg,...)
=item $ctx = Digest::XXX->new($arg,...)
The constructor returns some object that encapsulate the state of the
message-digest algorithm. You can add data to the object and finally
ask for the digest. The "XXX" should of course be replaced by the proper
name of the digest algorithm you want to use.
The two first forms are simply syntactic sugar which automatically
load the right module on first use. The second form allow you to use
algorithm names which contains letters which are not legal perl
identifiers, e.g. "SHA-1". If no implementation for the given algorithm
can be found, then an exception is raised.
If new() is called as an instance method (i.e. $ctx->new) it will just
reset the state the object to the state of a newly created object. No
new object is created in this case, and the return value is the
reference to the object (i.e. $ctx).
=item $other_ctx = $ctx->clone
The clone method creates a copy of the digest state object and returns
a reference to the copy.
=item $ctx->reset
This is just an alias for $ctx->new.
=item $ctx->add( $data, ... )
The $data provided as argument are appended to the message we
calculate the digest for. The return value is the $ctx object itself.
=item $ctx->addfile( $io_handle )
The $io_handle is read until EOF and the content is appended to the
message we calculate the digest for. The return value is the $ctx
object itself.
=item $ctx->add_bits( $data, $nbits )
=item $ctx->add_bits( $bitstring )
The bits provided are appended to the message we calculate the digest
for. The return value is the $ctx object itself.
The two argument form of add_bits() will add the first $nbits bits
from data. For the last potentially partial byte only the high order
C<< $nbits % 8 >> bits are used. If $nbits is greater than C<<
length($data) * 8 >>, then this method would do the same as C<<
$ctx->add($data) >>, that is $nbits is silently ignored.
The one argument form of add_bits() takes a $bitstring of "1" and "0"
chars as argument. It's a shorthand for C<< $ctx->add_bits(pack("B*",
$bitstring), length($bitstring)) >>.
This example shows two calls that should have the same effect:
$ctx->add_bits("111100001010");
$ctx->add_bits("\xF0\xA0", 12);
Most digest algorithms are byte based. For those it is not possible
to add bits that are not a multiple of 8, and the add_bits() method
will croak if you try.
=item $ctx->digest
Return the binary digest for the message.
Note that the C<digest> operation is effectively a destructive,
read-once operation. Once it has been performed, the $ctx object is
automatically C<reset> and can be used to calculate another digest
value. Call $ctx->clone->digest if you want to calculate the digest
without reseting the digest state.
=item $ctx->hexdigest
Same as $ctx->digest, but will return the digest in hexadecimal form.
=item $ctx->b64digest
Same as $ctx->digest, but will return the digest as a base64 encoded
string.
=back
=head1 Digest speed
This table should give some indication on the relative speed of
different algorithms. It is sorted by throughput based on a benchmark
done with of some implementations of this API:
Algorithm Size Implementation MB/s
MD4 128 Digest::MD4 v1.3 165.0
MD5 128 Digest::MD5 v2.33 98.8
SHA-256 256 Digest::SHA2 v1.1.0 66.7
SHA-1 160 Digest::SHA v4.3.1 58.9
SHA-1 160 Digest::SHA1 v2.10 48.8
SHA-256 256 Digest::SHA v4.3.1 41.3
Haval-256 256 Digest::Haval256 v1.0.4 39.8
SHA-384 384 Digest::SHA2 v1.1.0 19.6
SHA-512 512 Digest::SHA2 v1.1.0 19.3
SHA-384 384 Digest::SHA v4.3.1 19.2
SHA-512 512 Digest::SHA v4.3.1 19.2
Whirlpool 512 Digest::Whirlpool v1.0.2 13.0
MD2 128 Digest::MD2 v2.03 9.5
Adler-32 32 Digest::Adler32 v0.03 1.3
CRC-16 16 Digest::CRC v0.05 1.1
CRC-32 32 Digest::CRC v0.05 1.1
MD5 128 Digest::Perl::MD5 v1.5 1.0
CRC-CCITT 16 Digest::CRC v0.05 0.8
These numbers was achieved Apr 2004 with ActivePerl-5.8.3 running
under Linux on a P4 2.8 GHz CPU. The last 5 entries differ by being
pure perl implementations of the algorithms, which explains why they
are so slow.
=head1 SEE ALSO
L<Digest::Adler32>, L<Digest::CRC>, L<Digest::Haval256>,
L<Digest::HMAC>, L<Digest::MD2>, L<Digest::MD4>, L<Digest::MD5>,
L<Digest::SHA>, L<Digest::SHA1>, L<Digest::SHA2>, L<Digest::Whirlpool>
New digest implementations should consider subclassing from L<Digest::base>.
L<MIME::Base64>
=head1 AUTHOR
Gisle Aas <gisle at aas.no>
The C<Digest::> interface is based on the interface originally
developed by Neil Winton for his C<MD5> module.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
Copyright 1998-2001,2003-2004 Gisle Aas.
Copyright 1995-1996 Neil Winton.
=cut
--- NEW FILE: getcwd.pl ---
# By Brandon S. Allbery
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Cwd
#
#
# Usage: $cwd = &getcwd;
sub getcwd
{
local($dotdots, $cwd, @pst, @cst, $dir, @tst);
unless (@cst = stat('.'))
{
warn "stat(.): $!";
return '';
}
$cwd = '';
do
{
$dotdots .= '/' if $dotdots;
$dotdots .= '..';
@pst = @cst;
unless (opendir(getcwd'PARENT, $dotdots)) #'))
{
warn "opendir($dotdots): $!";
return '';
}
unless (@cst = stat($dotdots))
{
warn "stat($dotdots): $!";
closedir(getcwd'PARENT); #');
return '';
}
if ($pst[$[] == $cst[$[] && $pst[$[ + 1] == $cst[$[ + 1])
{
$dir = '';
}
else
{
do
{
unless (defined ($dir = readdir(getcwd'PARENT))) #'))
{
warn "readdir($dotdots): $!";
closedir(getcwd'PARENT); #');
return '';
}
unless (@tst = lstat("$dotdots/$dir"))
{
# warn "lstat($dotdots/$dir): $!";
# closedir(getcwd'PARENT); #');
# return '';
}
}
while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] ||
$tst[$[ + 1] != $pst[$[ + 1]);
}
$cwd = "$dir/$cwd";
closedir(getcwd'PARENT); #');
} while ($dir ne '');
chop($cwd);
$cwd;
}
1;
--- NEW FILE: perl5db.pl ---
=head1 NAME
perl5db.pl - the perl debugger
=head1 SYNOPSIS
perl -d your_Perl_script
=head1 DESCRIPTION
C<perl5db.pl> is the perl debugger. It is loaded automatically by Perl when
you invoke a script with C<perl -d>. This documentation tries to outline the
structure and services provided by C<perl5db.pl>, and to describe how you
can use them.
=head1 GENERAL NOTES
The debugger can look pretty forbidding to many Perl programmers. There are
[...9389 lines suppressed...]
=head1 C<DB::fake>
Contains the C<at_exit> routine that the debugger uses to issue the
C<Debugged program terminated ...> message after the program completes. See
the C<END> block documentation for more details.
=cut
package DB::fake;
sub at_exit {
"Debugged program terminated. Use `q' to quit or `R' to restart.";
}
package DB; # Do not trace this 1; below!
1;
--- NEW FILE: vars.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = '../lib';
}
$| = 1;
print "1..27\n";
# catch "used once" warnings
my @warns;
BEGIN { $SIG{__WARN__} = sub { push @warns, @_ }; $^W = 1 };
%x = ();
$y = 3;
@z = ();
$X::x = 13;
use vars qw($p @q %r *s &t $X::p);
my $e = !(grep /^Name "X::x" used only once: possible typo/, @warns) && 'not ';
print "${e}ok 1\n";
$e = !(grep /^Name "main::x" used only once: possible typo/, @warns) && 'not ';
print "${e}ok 2\n";
$e = !(grep /^Name "main::y" used only once: possible typo/, @warns) && 'not ';
print "${e}ok 3\n";
$e = !(grep /^Name "main::z" used only once: possible typo/, @warns) && 'not ';
print "${e}ok 4\n";
($e, @warns) = @warns != 4 && 'not ';
print "${e}ok 5\n";
# this is inside eval() to avoid creation of symbol table entries and
# to avoid "used once" warnings
eval <<'EOE';
$e = ! $main::{p} && 'not ';
print "${e}ok 6\n";
$e = ! *q{ARRAY} && 'not ';
print "${e}ok 7\n";
$e = ! *r{HASH} && 'not ';
print "${e}ok 8\n";
$e = ! $main::{s} && 'not ';
print "${e}ok 9\n";
$e = ! *t{CODE} && 'not ';
print "${e}ok 10\n";
$e = defined $X::{q} && 'not ';
print "${e}ok 11\n";
$e = ! $X::{p} && 'not ';
print "${e}ok 12\n";
EOE
$e = $@ && 'not ';
print "${e}ok 13\n";
eval q{use vars qw(@X::y !abc); $e = ! *X::y{ARRAY} && 'not '};
print "${e}ok 14\n";
$e = $@ !~ /^'!abc' is not a valid variable name/ && 'not ';
print "${e}ok 15\n";
eval 'use vars qw($x[3])';
$e = $@ !~ /^Can't declare individual elements of hash or array/ && 'not ';
print "${e}ok 16\n";
{ local $^W;
eval 'use vars qw($!)';
($e, @warns) = ($@ || @warns) ? 'not ' : '';
print "${e}ok 17\n";
};
# NB the next test only works because vars.pm has already been loaded
eval 'use warnings "vars"; use vars qw($!)';
$e = ($@ || (shift(@warns)||'') !~ /^No need to declare built-in vars/)
&& 'not ';
print "${e}ok 18\n";
no strict 'vars';
eval 'use vars qw(@x%%)';
$e = $@ && 'not ';
print "${e}ok 19\n";
$e = ! *{'x%%'}{ARRAY} && 'not ';
print "${e}ok 20\n";
eval '$u = 3; @v = (); %w = ()';
$e = $@ && 'not ';
print "${e}ok 21\n";
use strict 'vars';
eval 'use vars qw(@y%%)';
$e = $@ !~ /^'\@y%%' is not a valid variable name under strict vars/ && 'not ';
print "${e}ok 22\n";
$e = *{'y%%'}{ARRAY} && 'not ';
print "${e}ok 23\n";
eval '$u = 3; @v = (); %w = ()';
my @errs = split /\n/, $@;
$e = @errs != 3 && 'not ';
print "${e}ok 24\n";
$e = !(grep(/^Global symbol "\$u" requires explicit package name/, @errs))
&& 'not ';
print "${e}ok 25\n";
$e = !(grep(/^Global symbol "\@v" requires explicit package name/, @errs))
&& 'not ';
print "${e}ok 26\n";
$e = !(grep(/^Global symbol "\%w" requires explicit package name/, @errs))
&& 'not ';
print "${e}ok 27\n";
--- NEW FILE: validate.pl ---
;# $RCSfile: validate.pl,v $$Revision: 1.2 $$Date: 2006-12-04 17:00:17 $
;# The validate routine takes a single multiline string consisting of
;# lines containing a filename plus a file test to try on it. (The
;# file test may also be a 'cd', causing subsequent relative filenames
;# to be interpreted relative to that directory.) After the file test
;# you may put '|| die' to make it a fatal error if the file test fails.
;# The default is '|| warn'. The file test may optionally have a ! prepended
;# to test for the opposite condition. If you do a cd and then list some
;# relative filenames, you may want to indent them slightly for readability.
;# If you supply your own "die" or "warn" message, you can use $file to
;# interpolate the filename.
;# Filetests may be bunched: -rwx tests for all of -r, -w and -x.
;# Only the first failed test of the bunch will produce a warning.
;# The routine returns the number of warnings issued.
;# Usage:
;# require "validate.pl";
;# $warnings += do validate('
;# /vmunix -e || die
;# /boot -e || die
;# /bin cd
;# csh -ex
;# csh !-ug
;# sh -ex
;# sh !-ug
;# /usr -d || warn "What happened to $file?\n"
;# ');
sub validate {
local($file,$test,$warnings,$oldwarnings);
foreach $check (split(/\n/,$_[0])) {
next if $check =~ /^#/;
next if $check =~ /^$/;
($file,$test) = split(' ',$check,2);
if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
$testlist = $2;
@testlist = split(//,$testlist);
}
else {
@testlist = ('Z');
}
$oldwarnings = $warnings;
foreach $one (@testlist) {
$this = $test;
$this =~ s/(-\w\b)/$1 \$file/g;
$this =~ s/-Z/-$one/;
$this .= ' || warn' unless $this =~ /\|\|/;
$this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/;
$this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
eval $this;
last if $warnings > $oldwarnings;
}
}
$warnings;
}
sub valmess {
local($disposition,$this) = @_;
$file = $cwd . '/' . $file unless $file =~ m|^/|;
if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
$neg = $1;
$tmp = $2;
$tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
$tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
$tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
$tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
$tmp eq 'R' && ($mess = "$file is not readable by you.");
$tmp eq 'W' && ($mess = "$file is not writable by you.");
$tmp eq 'X' && ($mess = "$file is not executable by you.");
$tmp eq 'O' && ($mess = "$file is not owned by you.");
$tmp eq 'e' && ($mess = "$file does not exist.");
$tmp eq 'z' && ($mess = "$file does not have zero size.");
$tmp eq 's' && ($mess = "$file does not have non-zero size.");
$tmp eq 'f' && ($mess = "$file is not a plain file.");
$tmp eq 'd' && ($mess = "$file is not a directory.");
$tmp eq 'l' && ($mess = "$file is not a symbolic link.");
$tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
$tmp eq 'S' && ($mess = "$file is not a socket.");
$tmp eq 'b' && ($mess = "$file is not a block special file.");
$tmp eq 'c' && ($mess = "$file is not a character special file.");
$tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
$tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
$tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
$tmp eq 'T' && ($mess = "$file is not a text file.");
$tmp eq 'B' && ($mess = "$file is not a binary file.");
if ($neg eq '!') {
$mess =~ s/ is not / should not be / ||
$mess =~ s/ does not / should not / ||
$mess =~ s/ not / /;
}
print STDERR $mess,"\n";
}
else {
$this =~ s/\$file/'$file'/g;
print STDERR "Can't do $this.\n";
}
if ($disposition eq 'die') { exit 1; }
++$warnings;
}
1;
--- NEW FILE: diagnostics.pm ---
package diagnostics;
=head1 NAME
diagnostics, splain - produce verbose warning diagnostics
=head1 SYNOPSIS
Using the C<diagnostics> pragma:
use diagnostics;
use diagnostics -verbose;
enable diagnostics;
disable diagnostics;
Using the C<splain> standalone filter program:
perl program 2>diag.out
splain [-v] [-p] diag.out
Using diagnostics to get stack traces from a misbehaving script:
perl -Mdiagnostics=-traceonly my_script.pl
=head1 DESCRIPTION
=head2 The C<diagnostics> Pragma
This module extends the terse diagnostics normally emitted by both the
perl compiler and the perl interpreter (from running perl with a -w
switch or C<use warnings>), augmenting them with the more
explicative and endearing descriptions found in L<perldiag>. Like the
other pragmata, it affects the compilation phase of your program rather
than merely the execution phase.
To use in your program as a pragma, merely invoke
use diagnostics;
at the start (or near the start) of your program. (Note
that this I<does> enable perl's B<-w> flag.) Your whole
compilation will then be subject(ed :-) to the enhanced diagnostics.
These still go out B<STDERR>.
Due to the interaction between runtime and compiletime issues,
and because it's probably not a very good idea anyway,
you may not use C<no diagnostics> to turn them off at compiletime.
However, you may control their behaviour at runtime using the
disable() and enable() methods to turn them off and on respectively.
The B<-verbose> flag first prints out the L<perldiag> introduction before
any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
escape sequences for pagers.
Warnings dispatched from perl itself (or more accurately, those that match
descriptions found in L<perldiag>) are only displayed once (no duplicate
descriptions). User code generated warnings a la warn() are unaffected,
allowing duplicate user messages to be displayed.
This module also adds a stack trace to the error message when perl dies.
This is useful for pinpointing what caused the death. The B<-traceonly> (or
just B<-t>) flag turns off the explanations of warning messages leaving just
the stack traces. So if your script is dieing, run it again with
perl -Mdiagnostics=-traceonly my_bad_script
to see the call stack at the time of death. By supplying the B<-warntrace>
(or just B<-w>) flag, any warnings emitted will also come with a stack
trace.
=head2 The I<splain> Program
While apparently a whole nuther program, I<splain> is actually nothing
more than a link to the (executable) F<diagnostics.pm> module, as well as
a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
the C<use diagnostics -verbose> directive.
The B<-p> flag is like the
$diagnostics::PRETTY variable. Since you're post-processing with
I<splain>, there's no sense in being able to enable() or disable() processing.
Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
=head1 EXAMPLES
The following file is certain to trigger a few errors at both
runtime and compiletime:
use diagnostics;
print NOWHERE "nothing\n";
print STDERR "\n\tThis message should be unadorned.\n";
warn "\tThis is a user warning";
print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
my $a, $b = scalar <STDIN>;
print "\n";
print $x/$y;
If you prefer to run your program first and look at its problem
afterwards, do this:
perl -w test.pl 2>test.out
./splain < test.out
Note that this is not in general possible in shells of more dubious heritage,
as the theoretical
(perl -w test.pl >/dev/tty) >& test.out
./splain < test.out
Because you just moved the existing B<stdout> to somewhere else.
If you don't want to modify your source code, but still have on-the-fly
warnings, do this:
exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
Nifty, eh?
If you want to control warnings on the fly, do something like this.
Make sure you do the C<use> first, or you won't be able to get
at the enable() or disable() methods.
use diagnostics; # checks entire compilation phase
print "\ntime for 1st bogus diags: SQUAWKINGS\n";
print BOGUS1 'nada';
print "done with 1st bogus\n";
disable diagnostics; # only turns off runtime warnings
print "\ntime for 2nd bogus: (squelched)\n";
print BOGUS2 'nada';
print "done with 2nd bogus\n";
enable diagnostics; # turns back on runtime warnings
print "\ntime for 3rd bogus: SQUAWKINGS\n";
print BOGUS3 'nada';
print "done with 3rd bogus\n";
disable diagnostics;
print "\ntime for 4th bogus: (squelched)\n";
print BOGUS4 'nada';
print "done with 4th bogus\n";
=head1 INTERNALS
Diagnostic messages derive from the F<perldiag.pod> file when available at
runtime. Otherwise, they may be embedded in the file itself when the
splain package is built. See the F<Makefile> for details.
If an extant $SIG{__WARN__} handler is discovered, it will continue
to be honored, but only after the diagnostics::splainthis() function
(the module's $SIG{__WARN__} interceptor) has had its way with your
warnings.
There is a $diagnostics::DEBUG variable you may set if you're desperately
curious what sorts of things are being intercepted.
BEGIN { $diagnostics::DEBUG = 1 }
=head1 BUGS
Not being able to say "no diagnostics" is annoying, but may not be
insurmountable.
The C<-pretty> directive is called too late to affect matters.
You have to do this instead, and I<before> you load the module.
BEGIN { $diagnostics::PRETTY = 1 }
I could start up faster by delaying compilation until it should be
needed, but this gets a "panic: top_level" when using the pragma form
in Perl 5.001e.
While it's true that this documentation is somewhat subserious, if you use
a program named I<splain>, you should expect a bit of whimsy.
=head1 AUTHOR
Tom Christiansen <F<tchrist at mox.perl.com>>, 25 June 1995.
=cut
use strict;
use 5.006;
use Carp;
$Carp::Internal{__PACKAGE__.""}++;
our $VERSION = 1.15;
our $DEBUG;
our $VERBOSE;
our $PRETTY;
our $TRACEONLY = 0;
our $WARNTRACE = 0;
use Config;
my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
if ($^O eq 'VMS') {
require VMS::Filespec;
$privlib = VMS::Filespec::unixify($privlib);
$archlib = VMS::Filespec::unixify($archlib);
}
my @trypod = (
"$archlib/pod/perldiag.pod",
"$privlib/pod/perldiag-$Config{version}.pod",
"$privlib/pod/perldiag.pod",
"$archlib/pods/perldiag.pod",
"$privlib/pods/perldiag-$Config{version}.pod",
"$privlib/pods/perldiag.pod",
);
# handy for development testing of new warnings etc
unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
if ($^O eq 'MacOS') {
# just updir one from each lib dir, we'll find it ...
($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
}
$DEBUG ||= 0;
my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
local $| = 1;
local $_;
my $standalone;
my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
CONFIG: {
our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
unless (caller) {
$standalone++;
require Getopt::Std;
Getopt::Std::getopts('pdvf:')
or die "Usage: $0 [-v] [-p] [-f splainpod]";
$PODFILE = $opt_f if $opt_f;
$DEBUG = 2 if $opt_d;
$VERBOSE = $opt_v;
$PRETTY = $opt_p;
}
if (open(POD_DIAG, $PODFILE)) {
warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
last CONFIG;
}
if (caller) {
INCPATH: {
for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
warn "Checking $file\n" if $DEBUG;
if (open(POD_DIAG, $file)) {
while (<POD_DIAG>) {
next unless
/^__END__\s*# wish diag dbase were more accessible/;
print STDERR "podfile is $file\n" if $DEBUG;
last INCPATH;
}
}
}
}
} else {
print STDERR "podfile is <DATA>\n" if $DEBUG;
*POD_DIAG = *main::DATA;
}
}
if (eof(POD_DIAG)) {
die "couldn't find diagnostic data in $PODFILE @INC $0";
}
%HTML_2_Troff = (
'amp' => '&', # ampersand
'lt' => '<', # left chevron, less-than
'gt' => '>', # right chevron, greater-than
'quot' => '"', # double quote
"Aacute" => "A\\*'", # capital A, acute accent
# etc
);
%HTML_2_Latin_1 = (
'amp' => '&', # ampersand
'lt' => '<', # left chevron, less-than
'gt' => '>', # right chevron, greater-than
'quot' => '"', # double quote
"Aacute" => "\xC1" # capital A, acute accent
# etc
);
%HTML_2_ASCII_7 = (
'amp' => '&', # ampersand
'lt' => '<', # left chevron, less-than
'gt' => '>', # right chevron, greater-than
'quot' => '"', # double quote
"Aacute" => "A" # capital A, acute accent
# etc
);
our %HTML_Escapes;
*HTML_Escapes = do {
if ($standalone) {
$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
} else {
\%HTML_2_Latin_1;
}
};
*THITHER = $standalone ? *STDOUT : *STDERR;
my %transfmt = ();
my $transmo = <<EOFUNC;
sub transmo {
#local \$^W = 0; # recursive warnings we do NOT need!
study;
EOFUNC
my %msg;
{
print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
local $/ = '';
local $_;
my $header;
my $for_item;
while (<POD_DIAG>) {
unescape();
if ($PRETTY) {
sub noop { return $_[0] } # spensive for a noop
sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
s/[LIF]<(.*?)>/italic($1)/ges;
} else {
s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
s/[LIF]<(.*?)>/$1/gs;
}
unless (/^=/) {
if (defined $header) {
if ( $header eq 'DESCRIPTION' &&
( /Optional warnings are enabled/
|| /Some of these messages are generic./
) )
{
next;
}
s/^/ /gm;
$msg{$header} .= $_;
undef $for_item;
}
next;
}
unless ( s/=item (.*?)\s*\z//) {
if ( s/=head1\sDESCRIPTION//) {
$msg{$header = 'DESCRIPTION'} = '';
undef $for_item;
}
elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
$for_item = $1;
}
next;
}
if( $for_item ) { $header = $for_item; undef $for_item }
else {
$header = $1;
while( $header =~ /[;,]\z/ ) {
<POD_DIAG> =~ /^\s*(.*?)\s*\z/;
$header .= ' '.$1;
}
}
# strip formatting directives from =item line
$header =~ s/[A-Z]<(.*?)>/$1/g;
my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header );
if (@toks > 1) {
my $conlen = 0;
for my $i (0..$#toks){
if( $i % 2 ){
if( $toks[$i] eq '%c' ){
$toks[$i] = '.';
} elsif( $toks[$i] eq '%d' ){
$toks[$i] = '\d+';
} elsif( $toks[$i] eq '%s' ){
$toks[$i] = $i == $#toks ? '.*' : '.*?';
} elsif( $toks[$i] =~ '%.(\d+)s' ){
$toks[$i] = ".{$1}";
} elsif( $toks[$i] =~ '^%l*x$' ){
$toks[$i] = '[\da-f]+';
}
} elsif( length( $toks[$i] ) ){
$toks[$i] =~ s/^.*$/\Q$&\E/;
$conlen += length( $toks[$i] );
}
}
my $lhs = join( '', @toks );
$transfmt{$header}{pat} =
" s{^$lhs}\n {\Q$header\E}s\n\t&& return 1;\n";
$transfmt{$header}{len} = $conlen;
} else {
$transfmt{$header}{pat} =
" m{^\Q$header\E} && return 1;\n";
$transfmt{$header}{len} = length( $header );
}
print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
if $msg{$header};
$msg{$header} = '';
}
close POD_DIAG unless *main::DATA eq *POD_DIAG;
die "No diagnostics?" unless %msg;
# Apply patterns in order of decreasing sum of lengths of fixed parts
# Seems the best way of hitting the right one.
for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
keys %transfmt ){
$transmo .= $transfmt{$hdr}{pat};
}
$transmo .= " return 0;\n}\n";
print STDERR $transmo if $DEBUG;
eval $transmo;
die $@ if $@;
}
if ($standalone) {
if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
while (defined (my $error = <>)) {
splainthis($error) || print THITHER $error;
}
exit;
}
my $olddie;
my $oldwarn;
sub import {
shift;
$^W = 1; # yup, clobbered the global variable;
# tough, if you want diags, you want diags.
return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
for (@_) {
/^-d(ebug)?$/ && do {
$DEBUG++;
next;
};
/^-v(erbose)?$/ && do {
$VERBOSE++;
next;
};
/^-p(retty)?$/ && do {
print STDERR "$0: I'm afraid it's too late for prettiness.\n";
$PRETTY++;
next;
};
/^-t(race)?$/ && do {
$TRACEONLY++;
next;
};
/^-w(arntrace)?$/ && do {
$WARNTRACE++;
next;
};
warn "Unknown flag: $_";
}
$oldwarn = $SIG{__WARN__};
$olddie = $SIG{__DIE__};
$SIG{__WARN__} = \&warn_trap;
$SIG{__DIE__} = \&death_trap;
}
sub enable { &import }
sub disable {
shift;
return unless $SIG{__WARN__} eq \&warn_trap;
$SIG{__WARN__} = $oldwarn || '';
$SIG{__DIE__} = $olddie || '';
}
sub warn_trap {
my $warning = $_[0];
if (caller eq $WHOAMI or !splainthis($warning)) {
if ($WARNTRACE) {
print STDERR Carp::longmess($warning);
} else {
print STDERR $warning;
}
}
goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
};
sub death_trap {
my $exception = $_[0];
# See if we are coming from anywhere within an eval. If so we don't
# want to explain the exception because it's going to get caught.
my $in_eval = 0;
my $i = 0;
while (my $caller = (caller($i++))[3]) {
if ($caller eq '(eval)') {
$in_eval = 1;
last;
}
}
splainthis($exception) unless $in_eval;
if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
return if $in_eval;
# We don't want to unset these if we're coming from an eval because
# then we've turned off diagnostics.
# Switch off our die/warn handlers so we don't wind up in our own
# traps.
$SIG{__DIE__} = $SIG{__WARN__} = '';
# Have carp skip over death_trap() when showing the stack trace.
local($Carp::CarpLevel) = 1;
confess "Uncaught exception from user code:\n\t$exception";
# up we go; where we stop, nobody knows, but i think we die now
# but i'm deeply afraid of the &$olddie guy reraising and us getting
# into an indirect recursion loop
};
my %exact_duplicate;
my %old_diag;
my $count;
my $wantspace;
sub splainthis {
return 0 if $TRACEONLY;
local $_ = shift;
local $\;
### &finish_compilation unless %msg;
s/\.?\n+$//;
my $orig = $_;
# return unless defined;
# get rid of the where-are-we-in-input part
s/, <.*?> (?:line|chunk).*$//;
# Discard 1st " at <file> line <no>" and all text beyond
# but be aware of messsages containing " at this-or-that"
my $real = 0;
my @secs = split( / at / );
$_ = $secs[0];
for my $i ( 1..$#secs ){
if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
$real = 1;
last;
} else {
$_ .= ' at ' . $secs[$i];
}
}
# remove parenthesis occurring at the end of some messages
s/^\((.*)\)$/$1/;
if ($exact_duplicate{$orig}++) {
return &transmo;
} else {
return 0 unless &transmo;
}
$orig = shorten($orig);
if ($old_diag{$_}) {
autodescribe();
print THITHER "$orig (#$old_diag{$_})\n";
$wantspace = 1;
} else {
autodescribe();
$old_diag{$_} = ++$count;
print THITHER "\n" if $wantspace;
$wantspace = 0;
print THITHER "$orig (#$old_diag{$_})\n";
if ($msg{$_}) {
print THITHER $msg{$_};
} else {
if (0 and $standalone) {
print THITHER " **** Error #$old_diag{$_} ",
($real ? "is" : "appears to be"),
" an unknown diagnostic message.\n\n";
}
return 0;
}
}
return 1;
}
sub autodescribe {
if ($VERBOSE and not $count) {
print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
"\n$msg{DESCRIPTION}\n";
}
}
sub unescape {
s {
E<
( [A-Za-z]+ )
>
} {
do {
exists $HTML_Escapes{$1}
? do { $HTML_Escapes{$1} }
: do {
warn "Unknown escape: E<$1> in $_";
"E<$1>";
}
}
}egx;
}
sub shorten {
my $line = $_[0];
if (length($line) > 79 and index($line, "\n") == -1) {
my $space_place = rindex($line, ' ', 79);
if ($space_place != -1) {
substr($line, $space_place, 1) = "\n\t";
}
}
return $line;
}
1 unless $standalone; # or it'll complain about itself
__END__ # wish diag dbase were more accessible
--- NEW FILE: DBM_Filter.pm ---
package DBM_Filter ;
use strict;
use warnings;
our $VERSION = '0.01';
package Tie::Hash ;
use strict;
use warnings;
use Carp;
our %LayerStack = ();
our %origDESTROY = ();
our %Filters = map { $_, undef } qw(
Fetch_Key
Fetch_Value
Store_Key
Store_Value
);
our %Options = map { $_, 1 } qw(
fetch
store
);
#sub Filter_Enable
#{
#}
#
#sub Filter_Disable
#{
#}
sub Filtered
{
my $this = shift;
return defined $LayerStack{$this} ;
}
sub Filter_Pop
{
my $this = shift;
my $stack = $LayerStack{$this} || return undef ;
my $filter = pop @{ $stack };
# remove the filter hooks if this is the last filter to pop
if ( @{ $stack } == 0 ) {
$this->filter_store_key ( undef );
$this->filter_store_value( undef );
$this->filter_fetch_key ( undef );
$this->filter_fetch_value( undef );
delete $LayerStack{$this};
}
return $filter;
}
sub Filter_Key_Push
{
&_do_Filter_Push;
}
sub Filter_Value_Push
{
&_do_Filter_Push;
}
sub Filter_Push
{
&_do_Filter_Push;
}
sub _do_Filter_Push
{
my $this = shift;
my %callbacks = ();
my $caller = (caller(1))[3];
$caller =~ s/^.*:://;
croak "$caller: no parameters present" unless @_ ;
if ( ! $Options{lc $_[0]} ) {
my $class = shift;
my @params = @_;
# if $class already contains "::", don't prefix "DBM_Filter::"
$class = "DBM_Filter::$class" unless $class =~ /::/;
# does the "DBM_Filter::$class" exist?
if ( ! defined %{ "${class}::"} ) {
# Nope, so try to load it.
eval " require $class ; " ;
croak "$caller: Cannot Load DBM Filter '$class': $@" if $@;
}
no strict 'refs';
my $fetch = *{ "${class}::Fetch" }{CODE};
my $store = *{ "${class}::Store" }{CODE};
my $filter = *{ "${class}::Filter" }{CODE};
use strict 'refs';
my $count = defined($filter) + defined($store) + defined($fetch) ;
if ( $count == 0 )
{ croak "$caller: No methods (Filter, Fetch or Store) found in class '$class'" }
elsif ( $count == 1 && ! defined $filter) {
my $need = defined($fetch) ? 'Store' : 'Fetch';
croak "$caller: Missing method '$need' in class '$class'" ;
}
elsif ( $count >= 2 && defined $filter)
{ croak "$caller: Can't mix Filter with Store and Fetch in class '$class'" }
if (defined $filter) {
my $callbacks = &{ $filter }(@params);
croak "$caller: '${class}::Filter' did not return a hash reference"
unless ref $callbacks && ref $callbacks eq 'HASH';
%callbacks = %{ $callbacks } ;
}
else {
$callbacks{Fetch} = $fetch;
$callbacks{Store} = $store;
}
}
else {
croak "$caller: not even params" unless @_ % 2 == 0;
%callbacks = @_;
}
my %filters = %Filters ;
my @got = ();
while (my ($k, $v) = each %callbacks )
{
my $key = $k;
$k = lc $k;
if ($k eq 'fetch') {
push @got, 'Fetch';
if ($caller eq 'Filter_Push')
{ $filters{Fetch_Key} = $filters{Fetch_Value} = $v }
elsif ($caller eq 'Filter_Key_Push')
{ $filters{Fetch_Key} = $v }
elsif ($caller eq 'Filter_Value_Push')
{ $filters{Fetch_Value} = $v }
}
elsif ($k eq 'store') {
push @got, 'Store';
if ($caller eq 'Filter_Push')
{ $filters{Store_Key} = $filters{Store_Value} = $v }
elsif ($caller eq 'Filter_Key_Push')
{ $filters{Store_Key} = $v }
elsif ($caller eq 'Filter_Value_Push')
{ $filters{Store_Value} = $v }
}
else
{ croak "$caller: Unknown key '$key'" }
croak "$caller: value associated with key '$key' is not a code reference"
unless ref $v && ref $v eq 'CODE';
}
if ( @got != 2 ) {
push @got, 'neither' if @got == 0 ;
croak "$caller: expected both Store & Fetch - got @got";
}
# remember the class
push @{ $LayerStack{$this} }, \%filters ;
my $str_this = "$this" ; # Avoid a closure with $this in the subs below
$this->filter_store_key ( sub { store_hook($str_this, 'Store_Key') });
$this->filter_store_value( sub { store_hook($str_this, 'Store_Value') });
$this->filter_fetch_key ( sub { fetch_hook($str_this, 'Fetch_Key') });
$this->filter_fetch_value( sub { fetch_hook($str_this, 'Fetch_Value') });
# Hijack the callers DESTROY method
$this =~ /^(.*)=/;
my $type = $1 ;
no strict 'refs';
if ( *{ "${type}::DESTROY" }{CODE} ne \&MyDESTROY )
{
$origDESTROY{$type} = *{ "${type}::DESTROY" }{CODE};
no warnings 'redefine';
*{ "${type}::DESTROY" } = \&MyDESTROY ;
}
}
sub store_hook
{
my $this = shift ;
my $type = shift ;
foreach my $layer (@{ $LayerStack{$this} })
{
&{ $layer->{$type} }() if defined $layer->{$type} ;
}
}
sub fetch_hook
{
my $this = shift ;
my $type = shift ;
foreach my $layer (reverse @{ $LayerStack{$this} })
{
&{ $layer->{$type} }() if defined $layer->{$type} ;
}
}
sub MyDESTROY
{
my $this = shift ;
delete $LayerStack{$this} ;
# call real DESTROY
$this =~ /^(.*)=/;
&{ $origDESTROY{$1} }($this);
}
1;
__END__
=head1 NAME
DBM_Filter -- Filter DBM keys/values
=head1 SYNOPSIS
use DBM_Filter ;
use SDBM_File; # or DB_File, or GDBM_File, or NDBM_File, or ODBM_File
$db = tie %hash, ...
$db->Filter_Push(Fetch => sub {...},
Store => sub {...});
$db->Filter_Push('my_filter1');
$db->Filter_Push('my_filter2', params...);
$db->Filter_Key_Push(...) ;
$db->Filter_Value_Push(...) ;
$db->Filter_Pop();
$db->Filtered();
package DBM_Filter::my_filter1;
sub Store { ... }
sub Fetch { ... }
1;
package DBM_Filter::my_filter2;
sub Filter
{
my @opts = @_;
...
return (
sub Store { ... },
sub Fetch { ... } );
}
1;
=head1 DESCRIPTION
This module provides an interface that allows filters to be applied
to tied Hashes associated with DBM files. It builds on the DBM Filter
hooks that are present in all the *DB*_File modules included with the
standard Perl source distribution from version 5.6.1 onwards. In addition
to the *DB*_File modules distributed with Perl, the BerkeleyDB module,
available on CPAN, supports the DBM Filter hooks. See L<perldbmfilter>
for more details on the DBM Filter hooks.
=head1 What is a DBM Filter?
A DBM Filter allows the keys and/or values in a tied hash to be modified
by some user-defined code just before it is written to the DBM file and
just after it is read back from the DBM file. For example, this snippet
of code
$some_hash{"abc"} = 42;
could potentially trigger two filters, one for the writing of the key
"abc" and another for writing the value 42. Similarly, this snippet
my ($key, $value) = each %some_hash
will trigger two filters, one for the reading of the key and one for
the reading of the value.
Like the existing DBM Filter functionality, this module arranges for the
C<$_> variable to be populated with the key or value that a filter will
check. This usually means that most DBM filters tend to be very short.
=head2 So what's new?
The main enhancements over the standard DBM Filter hooks are:
=over 4
=item *
A cleaner interface.
=item *
The ability to easily apply multiple filters to a single DBM file.
=item *
The ability to create "canned" filters. These allow commonly used filters
to be packaged into a stand-alone module.
=back
=head1 METHODS
This module will arrange for the following methods to be available via
the object returned from the C<tie> call.
=head2 $db->Filter_Push()
=head2 $db->Filter_Key_Push()
=head2 $db->Filter_Value_Push()
Add a filter to filter stack for the database, C<$db>. The three formats
vary only in whether they apply to the DBM key, the DBM value or both.
=over 5
=item Filter_Push
The filter is applied to I<both> keys and values.
=item Filter_Key_Push
The filter is applied to the key I<only>.
=item Filter_Value_Push
The filter is applied to the value I<only>.
=back
=head2 $db->Filter_Pop()
Removes the last filter that was applied to the DBM file associated with
C<$db>, if present.
=head2 $db->Filtered()
Returns TRUE if there are any filters applied to the DBM associated
with C<$db>. Otherwise returns FALSE.
=head1 Writing a Filter
Filters can be created in two main ways
=head2 Immediate Filters
An immediate filter allows you to specify the filter code to be used
at the point where the filter is applied to a dbm. In this mode the
Filter_*_Push methods expects to receive exactly two parameters.
my $db = tie %hash, 'SDBM_File', ...
$db->Filter_Push( Store => sub { },
Fetch => sub { });
The code reference associated with C<Store> will be called before any
key/value is written to the database and the code reference associated
with C<Fetch> will be called after any key/value is read from the
database.
For example, here is a sample filter that adds a trailing NULL character
to all strings before they are written to the DBM file, and removes the
trailing NULL when they are read from the DBM file
my $db = tie %hash, 'SDBM_File', ...
$db->Filter_Push( Store => sub { $_ .= "\x00" ; },
Fetch => sub { s/\x00$// ; });
Points to note:
=over 5
=item 1.
Both the Store and Fetch filters manipulate C<$_>.
=back
=head2 Canned Filters
Immediate filters are useful for one-off situations. For more generic
problems it can be useful to package the filter up in its own module.
The usage is for a canned filter is:
$db->Filter_Push("name", params)
where
=over 5
=item "name"
is the name of the module to load. If the string specified does not
contain the package separator characters "::", it is assumed to refer to
the full module name "DBM_Filter::name". This means that the full names
for canned filters, "null" and "utf8", included with this module are:
DBM_Filter::null
DBM_Filter::utf8
=item params
any optional parameters that need to be sent to the filter. See the
encode filter for an example of a module that uses parameters.
=back
The module that implements the canned filter can take one of two
forms. Here is a template for the first
package DBM_Filter::null ;
use strict;
use warnings;
sub Store
{
# store code here
}
sub Fetch
{
# fetch code here
}
1;
Notes:
=over 5
=item 1.
The package name uses the C<DBM_Filter::> prefix.
=item 2.
The module I<must> have both a Store and a Fetch method. If only one is
present, or neither are present, a fatal error will be thrown.
=back
The second form allows the filter to hold state information using a
closure, thus:
package DBM_Filter::encoding ;
use strict;
use warnings;
sub Filter
{
my @params = @_ ;
...
return {
Store => sub { $_ = $encoding->encode($_) },
Fetch => sub { $_ = $encoding->decode($_) }
} ;
}
1;
In this instance the "Store" and "Fetch" methods are encapsulated inside a
"Filter" method.
=head1 Filters Included
A number of canned filers are provided with this module. They cover a
number of the main areas that filters are needed when interfacing with
DBM files. They also act as templates for your own filters.
The filter included are:
=over 5
=item * utf8
This module will ensure that all data written to the DBM will be encoded
in UTF-8.
This module needs the Encode module.
=item * encode
Allows you to choose the character encoding will be store in the DBM file.
=item * compress
This filter will compress all data before it is written to the database
and uncompressed it on reading.
This module needs Compress::Zlib.
=item * int32
This module is used when interoperating with a C/C++ application that
uses a C int as either the key and/or value in the DBM file.
=item * null
This module ensures that all data written to the DBM file is null
terminated. This is useful when you have a perl script that needs
to interoperate with a DBM file that a C program also uses. A fairly
common issue is for the C application to include the terminating null
in a string when it writes to the DBM file. This filter will ensure that
all data written to the DBM file can be read by the C application.
=back
=head1 NOTES
=head2 Maintain Round Trip Integrity
When writing a DBM filter it is I<very> important to ensure that it is
possible to retrieve all data that you have written when the DBM filter
is in place. In practice, this means that whatever transformation is
applied to the data in the Store method, the I<exact> inverse operation
should be applied in the Fetch method.
If you don't provide an exact inverse transformation, you will find that
code like this will not behave as you expect.
while (my ($k, $v) = each %hash)
{
...
}
Depending on the transformation, you will find that one or more of the
following will happen
=over 5
=item 1
The loop will never terminate.
=item 2
Too few records will be retrieved.
=item 3
Too many will be retrieved.
=item 4
The loop will do the right thing for a while, but it will unexpectedly fail.
=back
=head2 Don't mix filtered & non-filtered data in the same database file.
This is just a restatement of the previous section. Unless you are
completely certain you know what you are doing, avoid mixing filtered &
non-filtered data.
=head1 EXAMPLE
Say you need to interoperate with a legacy C application that stores
keys as C ints and the values and null terminated UTF-8 strings. Here
is how you would set that up
my $db = tie %hash, 'SDBM_File', ...
$db->Filter_Key_Push('int32') ;
$db->Filter_Value_Push('utf8');
$db->Filter_Value_Push('null');
=head1 SEE ALSO
<DB_File>, L<GDBM_File>, L<NDBM_File>, L<ODBM_File>, L<SDBM_File>, L<perldbmfilter>
=head1 AUTHOR
Paul Marquess <pmqs at cpan.org>
--- NEW FILE: utf8.t ---
#!./perl
my $has_perlio;
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
unless ($has_perlio = find PerlIO::Layer 'perlio') {
print <<EOF;
# Since you don't have perlio you might get failures with UTF-8 locales.
EOF
}
}
no utf8; # Ironic, no?
# NOTE!
#
# Think carefully before adding tests here. In general this should be
# used only for about three categories of tests:
#
# (1) tests that absolutely require 'use utf8', and since that in general
# shouldn't be needed as the utf8 is being obsoleted, this should
# have rather few tests. If you want to test Unicode and regexes,
# you probably want to go to op/regexp or op/pat; if you want to test
# split, go to op/split; pack, op/pack; appending or joining,
# op/append or op/join, and so forth
#
# (2) tests that have to do with Unicode tokenizing (though it's likely
# that all the other Unicode tests sprinkled around the t/**/*.t are
# going to catch that)
#
# (3) complicated tests that simultaneously stress so many Unicode features
# that deciding into which other test script the tests should go to
# is hard -- maybe consider breaking up the complicated test
#
#
plan tests => 150;
{
# bug id 20001009.001
my ($a, $b);
{ use bytes; $a = "\xc3\xa4" }
{ use utf8; $b = "\xe4" }
my $test = 68;
ok($a ne $b);
{ use utf8; ok($a ne $b) }
}
{
# bug id 20000730.004
my $smiley = "\x{263a}";
for my $s ("\x{263a}",
$smiley,
"" . $smiley,
"" . "\x{263a}",
$smiley . "",
"\x{263a}" . "",
) {
my $length_chars = length($s);
my $length_bytes;
{ use bytes; $length_bytes = length($s) }
my @regex_chars = $s =~ m/(.)/g;
my $regex_chars = @regex_chars;
my @split_chars = split //, $s;
my $split_chars = @split_chars;
ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
"1/1/1/3");
}
for my $s ("\x{263a}" . "\x{263a}",
$smiley . $smiley,
"\x{263a}\x{263a}",
"$smiley$smiley",
"\x{263a}" x 2,
$smiley x 2,
) {
my $length_chars = length($s);
my $length_bytes;
{ use bytes; $length_bytes = length($s) }
my @regex_chars = $s =~ m/(.)/g;
my $regex_chars = @regex_chars;
my @split_chars = split //, $s;
my $split_chars = @split_chars;
ok("$length_chars/$regex_chars/$split_chars/$length_bytes" eq
"2/2/2/6");
}
}
{
my $w = 0;
local $SIG{__WARN__} = sub { print "#($_[0])\n"; $w++ };
my $x = eval q/"\\/ . "\x{100}" . q/"/;;
ok($w == 0 && $x eq "\x{100}");
}
{
use warnings;
use strict;
my $show = q(
sub show {
my $result;
$result .= '>' . join (',', map {ord} split //, $_) . '<'
foreach @_;
$result;
}
1;
);
eval $show or die $@; # We don't expect this sub definition to fail.
my $progfile = 'utf' . $$;
END {unlink_all $progfile}
# If I'm right 60 is '>' in ASCII, ' ' in EBCDIC
# 173 is not punctuation in either ASCII or EBCDIC
my (@char);
foreach (60, 173, 257, 65532) {
my $char = chr $_;
utf8::encode($char);
# I don't want to use map {ord} and I've no need to hardcode the UTF
# version
my $charsubst = $char;
$charsubst =~ s/(.)/ord ($1) . ','/ge;
chop $charsubst;
# Not testing this one against map {ord}
my $char_as_ord
= join " . ", map {sprintf 'chr (%d)', ord $_} split //, $char;
push @char, [$_, $char, $charsubst, $char_as_ord];
}
# Now we've done all the UTF8 munching hopefully we're safe
my @tests = (
['check our detection program works',
'my @a = ("'.chr(60).'\x2A", ""); $b = show @a', qr/^>60,42<><$/],
['check literal 8 bit input',
'$a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
['check no utf8; makes no change',
'no utf8; $a = "' . chr (173) . '"; $b = show $a', qr/^>173<$/],
# Now we do the real byte sequences that are valid UTF8
(map {
["the utf8 sequence for chr $_->[0]",
qq{\$a = "$_->[1]"; \$b = show \$a}, qr/^>$_->[2]<$/],
["no utf8; for the utf8 sequence for chr $_->[0]",
qq(no utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[2]<$/],
["use utf8; for the utf8 sequence for chr $_->[0]",
qq(use utf8; \$a = "$_->[1]"; \$b = show \$a), qr/^>$_->[0]<$/],
} @char),
# Interpolation of hex characters needs to take place now, as we're
# testing feeding malformed utf8 into perl. Bug now fixed was an
# "out of memory" error. We really need the "" [rather than qq()
# or q()] to get the best explosion.
["!Feed malformed utf8 into perl.", <<"BANG",
use utf8; %a = ("\xE1\xA0"=>"sterling");
print 'start'; printf '%x,', ord \$_ foreach keys %a; print "end\n";
BANG
qr/^Malformed UTF-8 character \(\d bytes?, need \d, .+\).*start\d+,end$/sm
],
);
foreach (@tests) {
my ($why, $prog, $expect) = @$_;
open P, ">$progfile" or die "Can't open '$progfile': $!";
binmode(P, ":bytes") if $has_perlio;
print P $show, $prog, '; print $b'
or die "Print to 'progfile' failed: $!";
close P or die "Can't close '$progfile': $!";
if ($why =~ s/^!//) {
print "# Possible delay...\n";
} else {
print "# $prog\n";
}
my $result = runperl ( stderr => 1, progfile => $progfile );
like ($result, $expect, $why);
}
print
"# Again! Again! [but this time as eval, and not the explosive one]\n";
# and now we've safely done them all as separate files, check that the
# evals do the same thing. Hopefully doing it later successfully decouples
# the previous tests from anything messy that may go wrong with the evals.
foreach (@tests) {
my ($why, $prog, $expect) = @$_;
next if $why =~ m/^!/; # Goes bang.
my $result = eval $prog;
if ($@) {
print "# prog is $prog\n";
print "# \$\@=", _qq($@), "\n";
}
like ($result, $expect, $why);
}
# See what the tokeniser does with hash keys.
print "# What does the tokeniser do with utf8 hash keys?\n";
@tests = (map {
# This is the control - I don't expect it to fail
["assign utf8 for chr $_->[0] to a hash",
qq(my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
qr/^>$_->[2]<$/],
["no utf8; assign utf8 for chr $_->[0] to a hash",
qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
qr/^>$_->[2]<$/],
["use utf8; assign utf8 for chr $_->[0] to a hash",
qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{\$a} = 1;
my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
qr/^>$_->[0]<$/],
# Now check literal $h{"x"} constructions.
["\$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
qq(my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
qr/^>$_->[2]<$/],
["no utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
qq(no utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
qr/^>$_->[2]<$/],
["use utf8; \$h{\"x\"} construction, where x is utf8 for chr $_->[0]",
qq(use utf8; my \$a = "$_->[1]"; my %h; \$h{"$_->[1]"} = 1;
my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
qr/^>$_->[0]<$/],
# Now check "x" => constructions.
["assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
qq(my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
qr/^>$_->[2]<$/],
["no utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
qq(no utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
qr/^>$_->[2]<$/],
["use utf8; assign \"x\"=>1 to a hash, where x is utf8 for chr $_->[0]",
qq(use utf8; my \$a = "$_->[1]"; my %h; %h = ("$_->[1]" => 1);
my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
qr/^>$_->[0]<$/],
# Check copies of hashes made from literal utf8 keys
["assign utf8 for chr $_->[0] to a hash, then copy it",
qq(my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
qr/^>$_->[2]<$/],
["no utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
qq(no utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1;; my %h = %i;
my \$b = show keys %h; \$b .= 'F' unless \$h{$_->[3]}; \$b),
qr/^>$_->[2]<$/],
["use utf8; assign utf8 for chr $_->[0] to a hash, then copy it",
qq(use utf8; my \$a = "$_->[1]"; my %i; \$i{\$a} = 1; my %h = %i;
my \$b = show keys %h; \$b .= 'F' unless \$h{chr $_->[0]}; \$b),
qr/^>$_->[0]<$/],
} @char);
foreach (@tests) {
my ($why, $prog, $expect) = @$_;
# print "# $prog\n";
my $result = eval $prog;
like ($result, $expect, $why);
}
}
#
# bug fixed by change #17928
# separate perl used because we rely on 'strict' not yet loaded;
# before the patch, the eval died with an error like:
# "my" variable $strict::VERSION can't be in a package
#
SKIP: {
skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193;
ok('' eq runperl(prog => <<'CODE'), "change #17928");
my $code = qq{ my \$\xe3\x83\x95\xe3\x83\xbc = 5; };
{
use utf8;
eval $code;
print $@ if $@;
}
CODE
}
{
use utf8;
$a = <<'END';
0 ....... 1 ....... 2 ....... 3 ....... 4 ....... 5 ....... 6 ....... 7 .......
END
my (@i, $s);
@i = ();
push @i, $s = index($a, '6'); # 60
push @i, $s = index($a, '.', $s); # next . after 60 is 62
push @i, $s = index($a, '5'); # 50
push @i, $s = index($a, '.', $s); # next . after 52 is 52
push @i, $s = index($a, '7'); # 70
push @i, $s = index($a, '.', $s); # next . after 70 is 72
push @i, $s = index($a, '4'); # 40
push @i, $s = index($a, '.', $s); # next . after 40 is 42
is("@i", "60 62 50 52 70 72 40 42", "utf8 heredoc index");
@i = ();
push @i, $s = rindex($a, '6'); # 60
push @i, $s = rindex($a, '.', $s); # previous . before 60 is 58
push @i, $s = rindex($a, '5'); # 50
push @i, $s = rindex($a, '.', $s); # previous . before 52 is 48
push @i, $s = rindex($a, '7'); # 70
push @i, $s = rindex($a, '.', $s); # previous . before 70 is 68
push @i, $s = rindex($a, '4'); # 40
push @i, $s = rindex($a, '.', $s); # previous . before 40 is 38
is("@i", "60 58 50 48 70 68 40 38", "utf8 heredoc rindex");
@i = ();
push @i, $s = index($a, '6'); # 60
push @i, index($a, '.', $s); # next . after 60 is 62
push @i, rindex($a, '.', $s); # previous . before 60 is 58
push @i, $s = rindex($a, '5'); # 60
push @i, index($a, '.', $s); # next . after 50 is 52
push @i, rindex($a, '.', $s); # previous . before 50 is 48
push @i, $s = index($a, '7', $s); # 70
push @i, index($a, '.', $s); # next . after 70 is 72
push @i, rindex($a, '.', $s); # previous . before 70 is 68
is("@i", "60 62 58 50 52 48 70 72 68", "utf8 heredoc index and rindex");
}
SKIP: {
skip("Embedded UTF-8 does not work in EBCDIC", 1) if ord("A") == 193;
use utf8;
eval qq{is(q \xc3\xbc test \xc3\xbc, qq\xc2\xb7 test \xc2\xb7,
"utf8 quote delimiters [perl #16823]");};
}
# Test the "internals".
{
my $a = "A";
my $b = chr(0x0FF);
my $c = chr(0x100);
ok( utf8::valid($a), "utf8::valid basic");
ok( utf8::valid($b), "utf8::valid beyond");
ok( utf8::valid($c), "utf8::valid unicode");
ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
ok( utf8::is_utf8($c), "utf8::is_utf8 unicode");
is(utf8::upgrade($a), 1, "utf8::upgrade basic");
is(utf8::upgrade($b), 2, "utf8::upgrade beyond");
is(utf8::upgrade($c), 2, "utf8::upgrade unicode");
is($a, "A", "basic");
is($b, "\xFF", "beyond");
is($c, "\x{100}", "unicode");
ok( utf8::valid($a), "utf8::valid basic");
ok( utf8::valid($b), "utf8::valid beyond");
ok( utf8::valid($c), "utf8::valid unicode");
ok( utf8::is_utf8($a), "utf8::is_utf8 basic");
ok( utf8::is_utf8($b), "utf8::is_utf8 beyond");
ok( utf8::is_utf8($c), "utf8::is_utf8 unicode");
is(utf8::downgrade($a), 1, "utf8::downgrade basic");
is(utf8::downgrade($b), 1, "utf8::downgrade beyond");
is($a, "A", "basic");
is($b, "\xFF", "beyond");
ok( utf8::valid($a), "utf8::valid basic");
ok( utf8::valid($b), "utf8::valid beyond");
ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
utf8::encode($a);
utf8::encode($b);
utf8::encode($c);
is($a, "A", "basic");
is(length($b), 2, "beyond length");
is(length($c), 2, "unicode length");
ok(utf8::valid($a), "utf8::valid basic");
ok(utf8::valid($b), "utf8::valid beyond");
ok(utf8::valid($c), "utf8::valid unicode");
# encode() clears the UTF-8 flag (unlike upgrade()).
ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
ok(!utf8::is_utf8($b), "!utf8::is_utf8 beyond");
ok(!utf8::is_utf8($c), "!utf8::is_utf8 unicode");
utf8::decode($a);
utf8::decode($b);
utf8::decode($c);
is($a, "A", "basic");
is($b, "\xFF", "beyond");
is($c, "\x{100}", "unicode");
ok(utf8::valid($a), "!utf8::valid basic");
ok(utf8::valid($b), "!utf8::valid beyond");
ok(utf8::valid($c), " utf8::valid unicode");
ok(!utf8::is_utf8($a), "!utf8::is_utf8 basic");
ok( utf8::is_utf8($b), " utf8::is_utf8 beyond"); # $b stays in UTF-8.
ok( utf8::is_utf8($c), " utf8::is_utf8 unicode");
}
{
eval {utf8::encode("£")};
like($@, qr/^Modification of a read-only value attempted/,
"utf8::encode should refuse to touch read-only values");
}
{
my $a = "456\xb6";
utf8::upgrade($a);
my $b = "123456\xb6";
$b =~ s/^...//;
utf8::upgrade($b);
is($b, $a, "utf8::upgrade OffsetOK");
}
{
fresh_perl_like ('use utf8; utf8::moo()',
qr/Undefined subroutine utf8::moo/, {stderr=>1},
"Check Carp is loaded for AUTOLOADing errors")
}
{
# failure of is_utf8_char() without NATIVE_TO_UTF on EBCDIC (0260..027F)
ok(utf8::valid(chr(0x250)), "0x250");
ok(utf8::valid(chr(0x260)), "0x260");
ok(utf8::valid(chr(0x270)), "0x270");
ok(utf8::valid(chr(0x280)), "0x280");
}
--- NEW FILE: utf8.pm ---
package utf8;
$utf8::hint_bits = 0x00800000;
our $VERSION = '1.06';
sub import {
$^H |= $utf8::hint_bits;
$enc{caller()} = $_[1] if $_[1];
}
sub unimport {
$^H &= ~$utf8::hint_bits;
}
sub AUTOLOAD {
require "utf8_heavy.pl";
goto &$AUTOLOAD if defined &$AUTOLOAD;
require Carp;
Carp::croak("Undefined subroutine $AUTOLOAD called");
}
1;
__END__
=head1 NAME
utf8 - Perl pragma to enable/disable UTF-8 (or UTF-EBCDIC) in source code
=head1 SYNOPSIS
use utf8;
no utf8;
# Convert a Perl scalar to/from UTF-8.
$num_octets = utf8::upgrade($string);
$success = utf8::downgrade($string[, FAIL_OK]);
# Change the native bytes of a Perl scalar to/from UTF-8 bytes.
utf8::encode($string);
utf8::decode($string);
$flag = utf8::is_utf8(STRING); # since Perl 5.8.1
$flag = utf8::valid(STRING);
=head1 DESCRIPTION
The C<use utf8> pragma tells the Perl parser to allow UTF-8 in the
program text in the current lexical scope (allow UTF-EBCDIC on EBCDIC based
platforms). The C<no utf8> pragma tells Perl to switch back to treating
the source text as literal bytes in the current lexical scope.
This pragma is primarily a compatibility device. Perl versions
earlier than 5.6 allowed arbitrary bytes in source code, whereas
in future we would like to standardize on the UTF-8 encoding for
source text.
B<Do not use this pragma for anything else than telling Perl that your
script is written in UTF-8.> The utility functions described below are
useful for their own purposes, but they are not really part of the
"pragmatic" effect.
Until UTF-8 becomes the default format for source text, either this
pragma or the L<encoding> pragma should be used to recognize UTF-8
in the source. When UTF-8 becomes the standard source format, this
pragma will effectively become a no-op. For convenience in what
follows the term I<UTF-X> is used to refer to UTF-8 on ASCII and ISO
Latin based platforms and UTF-EBCDIC on EBCDIC based platforms.
See also the effects of the C<-C> switch and its cousin, the
C<$ENV{PERL_UNICODE}>, in L<perlrun>.
Enabling the C<utf8> pragma has the following effect:
=over 4
=item *
Bytes in the source text that have their high-bit set will be treated
as being part of a literal UTF-8 character. This includes most
literals such as identifier names, string constants, and constant
regular expression patterns.
On EBCDIC platforms characters in the Latin 1 character set are
treated as being part of a literal UTF-EBCDIC character.
=back
Note that if you have bytes with the eighth bit on in your script
(for example embedded Latin-1 in your string literals), C<use utf8>
will be unhappy since the bytes are most probably not well-formed
UTF-8. If you want to have such bytes and use utf8, you can disable
utf8 until the end the block (or file, if at top level) by C<no utf8;>.
If you want to automatically upgrade your 8-bit legacy bytes to UTF-8,
use the L<encoding> pragma instead of this pragma. For example, if
you want to implicitly upgrade your ISO 8859-1 (Latin-1) bytes to UTF-8
as used in e.g. C<chr()> and C<\x{...}>, try this:
use encoding "latin-1";
my $c = chr(0xc4);
my $x = "\x{c5}";
In case you are wondering: yes, C<use encoding 'utf8';> works much
the same as C<use utf8;>.
=head2 Utility functions
The following functions are defined in the C<utf8::> package by the
Perl core. You do not need to say C<use utf8> to use these and in fact
you should not say that unless you really want to have UTF-8 source code.
=over 4
=item * $num_octets = utf8::upgrade($string)
Converts in-place the octet sequence in the native encoding
(Latin-1 or EBCDIC) to the equivalent character sequence in I<UTF-X>.
I<$string> already encoded as characters does no harm.
Returns the number of octets necessary to represent the string as I<UTF-X>.
Can be used to make sure that the UTF-8 flag is on,
so that C<\w> or C<lc()> work as Unicode on strings
containing characters in the range 0x80-0xFF (on ASCII and
derivatives).
B<Note that this function does not handle arbitrary encodings.>
Therefore I<Encode.pm> is recommended for the general purposes.
Affected by the encoding pragma.
=item * $success = utf8::downgrade($string[, FAIL_OK])
Converts in-place the character sequence in I<UTF-X>
to the equivalent octet sequence in the native encoding (Latin-1 or EBCDIC).
I<$string> already encoded as octets does no harm.
Returns true on success. On failure dies or, if the value of
C<FAIL_OK> is true, returns false.
Can be used to make sure that the UTF-8 flag is off,
e.g. when you want to make sure that the substr() or length() function
works with the usually faster byte algorithm.
B<Note that this function does not handle arbitrary encodings.>
Therefore I<Encode.pm> is recommended for the general purposes.
B<Not> affected by the encoding pragma.
B<NOTE:> this function is experimental and may change
or be removed without notice.
=item * utf8::encode($string)
Converts in-place the character sequence to the corresponding octet sequence
in I<UTF-X>. The UTF-8 flag is turned off. Returns nothing.
B<Note that this function does not handle arbitrary encodings.>
Therefore I<Encode.pm> is recommended for the general purposes.
=item * utf8::decode($string)
Attempts to convert in-place the octet sequence in I<UTF-X>
to the corresponding character sequence. The UTF-8 flag is turned on
only if the source string contains multiple-byte I<UTF-X> characters.
If I<$string> is invalid as I<UTF-X>, returns false; otherwise returns true.
B<Note that this function does not handle arbitrary encodings.>
Therefore I<Encode.pm> is recommended for the general purposes.
B<NOTE:> this function is experimental and may change
or be removed without notice.
=item * $flag = utf8::is_utf8(STRING)
(Since Perl 5.8.1) Test whether STRING is in UTF-8. Functionally
the same as Encode::is_utf8().
=item * $flag = utf8::valid(STRING)
[INTERNAL] Test whether STRING is in a consistent state regarding
UTF-8. Will return true is well-formed UTF-8 and has the UTF-8 flag
on B<or> if string is held as bytes (both these states are 'consistent').
Main reason for this routine is to allow Perl's testsuite to check
that operations have left strings in a consistent state. You most
probably want to use utf8::is_utf8() instead.
=back
C<utf8::encode> is like C<utf8::upgrade>, but the UTF8 flag is
cleared. See L<perlunicode> for more on the UTF8 flag and the C API
functions C<sv_utf8_upgrade>, C<sv_utf8_downgrade>, C<sv_utf8_encode>,
and C<sv_utf8_decode>, which are wrapped by the Perl functions
C<utf8::upgrade>, C<utf8::downgrade>, C<utf8::encode> and
C<utf8::decode>. Note that in the Perl 5.8.0 and 5.8.1 implementation
the functions utf8::is_utf8, utf8::valid, utf8::encode, utf8::decode,
utf8::upgrade, and utf8::downgrade are always available, without a
C<require utf8> statement-- this may change in future releases.
=head1 BUGS
One can have Unicode in identifier names, but not in package/class or
subroutine names. While some limited functionality towards this does
exist as of Perl 5.8.0, that is more accidental than designed; use of
Unicode for the said purposes is unsupported.
One reason of this unfinishedness is its (currently) inherent
unportability: since both package names and subroutine names may need
to be mapped to file and directory names, the Unicode capability of
the filesystem becomes important-- and there unfortunately aren't
portable answers.
=head1 SEE ALSO
L<perluniintro>, L<encoding>, L<perlrun>, L<bytes>, L<perlunicode>
=cut
--- NEW FILE: constant.pm ---
package constant;
use strict;
use 5.006_00;
use warnings::register;
our($VERSION, %declared);
$VERSION = '1.05';
#=======================================================================
# Some names are evil choices.
my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
my %forced_into_main = map +($_, 1),
qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
my %forbidden = (%keywords, %forced_into_main);
#=======================================================================
# import() - import symbols into user's namespace
#
# What we actually do is define a function in the caller's namespace
# which returns the value. The function we create will normally
# be inlined as a constant, thereby avoiding further sub calling
# overhead.
#=======================================================================
sub import {
my $class = shift;
return unless @_; # Ignore 'use constant;'
my %constants = ();
my $multiple = ref $_[0];
if ( $multiple ) {
if (ref $_[0] ne 'HASH') {
require Carp;
Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
}
%constants = %{+shift};
} else {
$constants{+shift} = undef;
}
foreach my $name ( keys %constants ) {
unless (defined $name) {
require Carp;
Carp::croak("Can't use undef as constant name");
}
my $pkg = caller;
# Normal constant name
if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) {
# Everything is okay
# Name forced into main, but we're not in main. Fatal.
} elsif ($forced_into_main{$name} and $pkg ne 'main') {
require Carp;
Carp::croak("Constant name '$name' is forced into main::");
# Starts with double underscore. Fatal.
} elsif ($name =~ /^__/) {
require Carp;
Carp::croak("Constant name '$name' begins with '__'");
# Maybe the name is tolerable
} elsif ($name =~ /^[A-Za-z_]\w*\z/) {
# Then we'll warn only if you've asked for warnings
if (warnings::enabled()) {
if ($keywords{$name}) {
warnings::warn("Constant name '$name' is a Perl keyword");
} elsif ($forced_into_main{$name}) {
warnings::warn("Constant name '$name' is " .
"forced into package main::");
}
}
# Looks like a boolean
# use constant FRED == fred;
} elsif ($name =~ /^[01]?\z/) {
require Carp;
if (@_) {
Carp::croak("Constant name '$name' is invalid");
} else {
Carp::croak("Constant name looks like boolean value");
}
} else {
# Must have bad characters
require Carp;
Carp::croak("Constant name '$name' has invalid characters");
}
{
no strict 'refs';
my $full_name = "${pkg}::$name";
$declared{$full_name}++;
if ($multiple) {
my $scalar = $constants{$name};
*$full_name = sub () { $scalar };
} else {
if (@_ == 1) {
my $scalar = $_[0];
*$full_name = sub () { $scalar };
} elsif (@_) {
my @list = @_;
*$full_name = sub () { @list };
} else {
*$full_name = sub () { };
}
}
}
}
}
1;
__END__
=head1 NAME
constant - Perl pragma to declare constants
=head1 SYNOPSIS
use constant PI => 4 * atan2(1, 1);
use constant DEBUG => 0;
print "Pi equals ", PI, "...\n" if DEBUG;
use constant {
SEC => 0,
MIN => 1,
HOUR => 2,
MDAY => 3,
MON => 4,
YEAR => 5,
WDAY => 6,
YDAY => 7,
ISDST => 8,
};
use constant WEEKDAYS => qw(
Sunday Monday Tuesday Wednesday Thursday Friday Saturday
);
print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n";
=head1 DESCRIPTION
This will declare a symbol to be a constant with the given value.
When you declare a constant such as C<PI> using the method shown
above, each machine your script runs upon can have as many digits
of accuracy as it can use. Also, your program will be easier to
read, more likely to be maintained (and maintained correctly), and
far less likely to send a space probe to the wrong planet because
nobody noticed the one equation in which you wrote C<3.14195>.
When a constant is used in an expression, perl replaces it with its
value at compile time, and may then optimize the expression further.
In particular, any code in an C<if (CONSTANT)> block will be optimized
away if the constant is false.
=head1 NOTES
As with all C<use> directives, defining a constant happens at
compile time. Thus, it's probably not correct to put a constant
declaration inside of a conditional statement (like C<if ($foo)
{ use constant ... }>).
Constants defined using this module cannot be interpolated into
strings like variables. However, concatenation works just fine:
print "Pi equals PI...\n"; # WRONG: does not expand "PI"
print "Pi equals ".PI."...\n"; # right
Even though a reference may be declared as a constant, the reference may
point to data which may be changed, as this code shows.
use constant ARRAY => [ 1,2,3,4 ];
print ARRAY->[1];
ARRAY->[1] = " be changed";
print ARRAY->[1];
Dereferencing constant references incorrectly (such as using an array
subscript on a constant hash reference, or vice versa) will be trapped at
compile time.
Constants belong to the package they are defined in. To refer to a
constant defined in another package, specify the full package name, as
in C<Some::Package::CONSTANT>. Constants may be exported by modules,
and may also be called as either class or instance methods, that is,
as C<< Some::Package->CONSTANT >> or as C<< $obj->CONSTANT >> where
C<$obj> is an instance of C<Some::Package>. Subclasses may define
their own constants to override those in their base class.
The use of all caps for constant names is merely a convention,
although it is recommended in order to make constants stand out
and to help avoid collisions with other barewords, keywords, and
subroutine names. Constant names must begin with a letter or
underscore. Names beginning with a double underscore are reserved. Some
poor choices for names will generate warnings, if warnings are enabled at
compile time.
=head2 List constants
Constants may be lists of more (or less) than one value. A constant
with no values evaluates to C<undef> in scalar context. Note that
constants with more than one value do I<not> return their last value in
scalar context as one might expect. They currently return the number
of values, but B<this may change in the future>. Do not use constants
with multiple values in scalar context.
B<NOTE:> This implies that the expression defining the value of a
constant is evaluated in list context. This may produce surprises:
use constant TIMESTAMP => localtime; # WRONG!
use constant TIMESTAMP => scalar localtime; # right
The first line above defines C<TIMESTAMP> as a 9-element list, as
returned by localtime() in list context. To set it to the string
returned by localtime() in scalar context, an explicit C<scalar>
keyword is required.
List constants are lists, not arrays. To index or slice them, they
must be placed in parentheses.
my @workdays = WEEKDAYS[1 .. 5]; # WRONG!
my @workdays = (WEEKDAYS)[1 .. 5]; # right
=head2 Defining multiple constants at once
Instead of writing multiple C<use constant> statements, you may define
multiple constants in a single statement by giving, instead of the
constant name, a reference to a hash where the keys are the names of
the constants to be defined. Obviously, all constants defined using
this method must have a single value.
use constant {
FOO => "A single value",
BAR => "This", "won't", "work!", # Error!
};
This is a fundamental limitation of the way hashes are constructed in
Perl. The error messages produced when this happens will often be
quite cryptic -- in the worst case there may be none at all, and
you'll only later find that something is broken.
When defining multiple constants, you cannot use the values of other
constants defined in the same declaration. This is because the
calling package doesn't know about any constant within that group
until I<after> the C<use> statement is finished.
use constant {
BITMASK => 0xAFBAEBA8,
NEGMASK => ~BITMASK, # Error!
};
=head2 Magic constants
Magical values and references can be made into constants at compile
time, allowing for way cool stuff like this. (These error numbers
aren't totally portable, alas.)
use constant E2BIG => ($! = 7);
print E2BIG, "\n"; # something like "Arg list too long"
print 0+E2BIG, "\n"; # "7"
You can't produce a tied constant by giving a tied scalar as the
value. References to tied variables, however, can be used as
constants without any problems.
=head1 TECHNICAL NOTES
In the current implementation, scalar constants are actually
inlinable subroutines. As of version 5.004 of Perl, the appropriate
scalar constant is inserted directly in place of some subroutine
calls, thereby saving the overhead of a subroutine call. See
L<perlsub/"Constant Functions"> for details about how and when this
happens.
In the rare case in which you need to discover at run time whether a
particular constant has been declared via this module, you may use
this function to examine the hash C<%constant::declared>. If the given
constant name does not include a package name, the current package is
used.
sub declared ($) {
use constant 1.01; # don't omit this!
my $name = shift;
$name =~ s/^::/main::/;
my $pkg = caller;
my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
$constant::declared{$full_name};
}
=head1 BUGS
In the current version of Perl, list constants are not inlined
and some symbols may be redefined without generating a warning.
It is not possible to have a subroutine or a keyword with the same
name as a constant in the same package. This is probably a Good Thing.
A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT
ENV INC SIG> is not allowed anywhere but in package C<main::>, for
technical reasons.
Unlike constants in some languages, these cannot be overridden
on the command line or via environment variables.
You can get into trouble if you use constants in a context which
automatically quotes barewords (as is true for any subroutine call).
For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will
be interpreted as a string. Use C<$hash{CONSTANT()}> or
C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from
kicking in. Similarly, since the C<< => >> operator quotes a bareword
immediately to its left, you have to say C<< CONSTANT() => 'value' >>
(or simply use a comma in place of the big arrow) instead of
C<< CONSTANT => 'value' >>.
=head1 AUTHOR
Tom Phoenix, E<lt>F<rootbeer at redcat.com>E<gt>, with help from
many other folks.
Multiple constant declarations at once added by Casey West,
E<lt>F<casey at geeknest.com>E<gt>.
Documentation mostly rewritten by Ilmari Karonen,
E<lt>F<perl at itz.pp.sci.fi>E<gt>.
=head1 COPYRIGHT
Copyright (C) 1997, 1999 Tom Phoenix
This module is free software; you can redistribute it or modify it
under the same terms as Perl itself.
=cut
--- NEW FILE: SelectSaver.pm ---
package SelectSaver;
our $VERSION = '1.01';
=head1 NAME
SelectSaver - save and restore selected file handle
=head1 SYNOPSIS
use SelectSaver;
{
my $saver = new SelectSaver(FILEHANDLE);
# FILEHANDLE is selected
}
# previous handle is selected
{
my $saver = new SelectSaver;
# new handle may be selected, or not
}
# previous handle is selected
=head1 DESCRIPTION
A C<SelectSaver> object contains a reference to the file handle that
was selected when it was created. If its C<new> method gets an extra
parameter, then that parameter is selected; otherwise, the selected
file handle remains unchanged.
When a C<SelectSaver> is destroyed, it re-selects the file handle
that was selected when it was created.
=cut
require 5.000;
use Carp;
use Symbol;
sub new {
@_ >= 1 && @_ <= 2 or croak 'usage: new SelectSaver [FILEHANDLE]';
my $fh = select;
my $self = bless \$fh, $_[0];
select qualify($_[1], caller) if @_ > 1;
$self;
}
sub DESTROY {
my $self = $_[0];
select $$self;
}
1;
--- NEW FILE: h2xs.t ---
#!./perl -w
# Some quick tests to see if h2xs actually runs and creates files as
# expected. File contents include date stamps and/or usernames
# hence are not checked. File existence is checked with -e though.
# This test depends on File::Path::rmtree() to clean up with.
# - pvhp
#
# We are now checking that the correct use $version; is present in
# Makefile.PL and $module.pm
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
# FIXME (or rather FIXh2xs)
require Config;
if (($Config::Config{'extensions'} !~ m!\bDevel/PPPort\b!) ){
print "1..0 # Skip -- Perl configured without Devel::PPPort module\n";
exit 0;
}
}
# use strict; # we are not really testing this
use File::Path; # for cleaning up with rmtree()
use Test::More;
use File::Spec;
use File::Find;
use ExtUtils::Manifest;
# Don't want its diagnostics getting in the way of ours.
$ExtUtils::Manifest::Quiet=1;
my $up = File::Spec->updir();
my $extracted_program = '../utils/h2xs'; # unix, nt, ...
if ($^O eq 'VMS') { $extracted_program = '[-.utils]h2xs.com'; }
if ($^O eq 'MacOS') { $extracted_program = '::utils:h2xs'; }
if (!(-e $extracted_program)) {
print "1..0 # Skip: $extracted_program was not built\n";
exit 0;
}
# You might also wish to bail out if your perl platform does not
# do `$^X -e 'warn "Writing h2xst"' 2>&1`; duplicity.
# ok on unix, nt, VMS, ...
my $dupe = '2>&1';
# ok on unix, nt, The extra \" are for VMS
my $lib = '"-I../lib" "-I../../lib"';
# The >&1 would create a file named &1 on MPW (STDERR && STDOUT are
# already merged).
if ($^O eq 'MacOS') {
$dupe = '';
# -x overcomes MPW $Config{startperl} anomaly
$lib = '-x -I::lib: -I:::lib:';
}
# $name should differ from system header file names and must
# not already be found in the t/ subdirectory for perl.
my $name = 'h2xst';
my $header = "$name.h";
my $thisversion = sprintf "%vd", $^V;
# If this test has failed previously a copy may be left.
rmtree($name);
my @tests = (
"-f -n $name", $], <<"EOXSFILES",
Defaulting to backwards compatibility with perl $thisversion
If you intend this module to be compatible with earlier perl versions, please
specify a minimum perl version with the -b option.
Writing $name/ppport.h
Writing $name/lib/$name.pm
Writing $name/$name.xs
Writing $name/fallback/const-c.inc
Writing $name/fallback/const-xs.inc
Writing $name/Makefile.PL
Writing $name/README
Writing $name/t/$name.t
Writing $name/Changes
Writing $name/MANIFEST
EOXSFILES
"-f -n $name -b $thisversion", $], <<"EOXSFILES",
Writing $name/ppport.h
Writing $name/lib/$name.pm
Writing $name/$name.xs
Writing $name/fallback/const-c.inc
Writing $name/fallback/const-xs.inc
Writing $name/Makefile.PL
Writing $name/README
Writing $name/t/$name.t
Writing $name/Changes
Writing $name/MANIFEST
EOXSFILES
"-f -n $name -b 5.6.1", "5.006001", <<"EOXSFILES",
Writing $name/ppport.h
Writing $name/lib/$name.pm
Writing $name/$name.xs
Writing $name/fallback/const-c.inc
Writing $name/fallback/const-xs.inc
Writing $name/Makefile.PL
Writing $name/README
Writing $name/t/$name.t
Writing $name/Changes
Writing $name/MANIFEST
EOXSFILES
"-f -n $name -b 5.5.3", "5.00503", <<"EOXSFILES",
Writing $name/ppport.h
Writing $name/lib/$name.pm
Writing $name/$name.xs
Writing $name/fallback/const-c.inc
Writing $name/fallback/const-xs.inc
Writing $name/Makefile.PL
Writing $name/README
Writing $name/t/$name.t
Writing $name/Changes
Writing $name/MANIFEST
EOXSFILES
"\"-X\" -f -n $name -b $thisversion", $], <<"EONOXSFILES",
Writing $name/lib/$name.pm
Writing $name/Makefile.PL
Writing $name/README
Writing $name/t/$name.t
Writing $name/Changes
Writing $name/MANIFEST
EONOXSFILES
"-f -n $name -b $thisversion $header", $], <<"EOXSFILES",
Writing $name/ppport.h
Writing $name/lib/$name.pm
Writing $name/$name.xs
Writing $name/fallback/const-c.inc
Writing $name/fallback/const-xs.inc
Writing $name/Makefile.PL
Writing $name/README
Writing $name/t/$name.t
Writing $name/Changes
Writing $name/MANIFEST
EOXSFILES
);
my $total_tests = 3; # opening, closing and deleting the header file.
for (my $i = $#tests; $i > 0; $i-=3) {
# 1 test for running it, 1 test for the expected result, and 1 for each file
# plus 1 to open and 1 to check for the use in lib/$name.pm and Makefile.PL
# And 1 more for our check for "bonus" files, 2 more for ExtUtil::Manifest.
# use the () to force list context and hence count the number of matches.
$total_tests += 9 + (() = $tests[$i] =~ /(Writing)/sg);
}
plan tests => $total_tests;
ok (open (HEADER, ">$header"), "open '$header'");
print HEADER <<HEADER or die $!;
#define Camel 2
#define Dromedary 1
HEADER
ok (close (HEADER), "close '$header'");
while (my ($args, $version, $expectation) = splice @tests, 0, 3) {
# h2xs warns about what it is writing hence the (possibly unportable)
# 2>&1 dupe:
# does it run?
my $prog = "$^X $lib $extracted_program $args $dupe";
@result = `$prog`;
cmp_ok ($?, "==", 0, "running $prog ");
$result = join("", at result);
# accomodate MPW # comment character prependage
if ($^O eq 'MacOS') {
$result =~ s/#\s*//gs;
}
#print "# expectation is >$expectation<\n";
#print "# result is >$result<\n";
# Was the output the list of files that were expected?
is ($result, $expectation, "running $prog");
my (%got);
find (sub {$got{$File::Find::name}++ unless -d $_}, $name);
foreach ($expectation =~ /Writing\s+(\S+)/gm) {
if ($^O eq 'MacOS') {
$_ = ':' . join(':',split(/\//,$_));
$_ =~ s/$name:t:1.t/$name:t\/1.t/; # is this an h2xs bug?
}
if ($^O eq 'VMS') {
$_ .= '.' unless $_ =~ m/\./;
$_ = lc($_) unless exists $got{$_};
}
ok (-e $_, "check for $_") and delete $got{$_};
}
my @extra = keys %got;
unless (ok (!@extra, "Are any extra files present?")) {
print "# These files are unexpectedly present:\n";
print "# $_\n" foreach sort @extra;
}
chdir ($name) or die "chdir $name failed: $!";
# Aargh. Something wants to load a bit of regexp. And we have to chdir
# for ExtUtils::Manifest. Caught between a rock and a hard place, so this
# seems the least evil thing to do:
push @INC, "../../lib";
my ($missing, $extra) = ExtUtils::Manifest::fullcheck();
is_deeply ($missing, [], "No files in the MANIFEST should be missing");
is_deeply ($extra, [], "and all files present should be in the MANIFEST");
pop @INC;
chdir ($up) or die "chdir $up failed: $!";
foreach my $leaf (File::Spec->catfile('lib', "$name.pm"), 'Makefile.PL') {
my $file = File::Spec->catfile($name, $leaf);
if (ok (open (FILE, $file), "open $file")) {
my $match = qr/use $version;/;
my $found;
while (<FILE>) {
last if $found = /$match/;
}
ok ($found, "looking for /$match/ in $file");
close FILE or die "close $file: $!";
}
}
# clean up
rmtree($name);
}
cmp_ok (unlink ($header), "==", 1, "unlink '$header'") or die "\$! is $!";
--- NEW FILE: find.pl ---
# Usage:
# require "find.pl";
#
# &find('/foo','/bar');
#
# sub wanted { ... }
# where wanted does whatever you want. $dir contains the
# current directory name, and $_ the current filename within
# that directory. $name contains "$dir/$_". You are cd'ed
# to $dir when the function is called. The function may
# set $prune to prune the tree.
#
# This library is primarily for find2perl, which, when fed
#
# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
#
# spits out something like this
#
# sub wanted {
# /^\.nfs.*$/ &&
# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
# int(-M _) > 7 &&
# unlink($_)
# ||
# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
# $dev < 0 &&
# ($prune = 1);
# }
#
# Set the variable $dont_use_nlink if you're using AFS, since AFS cheats.
use File::Find ();
*name = *File::Find::name;
*prune = *File::Find::prune;
*dir = *File::Find::dir;
*topdir = *File::Find::topdir;
*topdev = *File::Find::topdev;
*topino = *File::Find::topino;
*topmode = *File::Find::topmode;
*topnlink = *File::Find::topnlink;
sub find {
&File::Find::find(\&wanted, @_);
}
1;
--- NEW FILE: warnings.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = '../lib';
require Config; import Config;
require './test.pl';
}
use File::Path;
use File::Spec::Functions;
$| = 1;
my $Is_MacOS = $^O eq 'MacOS';
my $tmpfile = "tmp0000";
1 while -e ++$tmpfile;
END { if ($tmpfile) { 1 while unlink $tmpfile} }
my @prgs = () ;
my @w_files = () ;
if (@ARGV)
{ print "ARGV = [@ARGV]\n" ;
if ($^O eq 'MacOS') {
@w_files = map { s#^#:lib:warnings:#; $_ } @ARGV
} else {
@w_files = map { s#^#./lib/warnings/#; $_ } @ARGV
}
}
else
{ @w_files = sort glob(catfile(curdir(), "lib", "warnings", "*")) }
my $files = 0;
foreach my $file (@w_files) {
next if $file =~ /(~|\.orig|,v)$/;
next if $file =~ /perlio$/ && !(find PerlIO::Layer 'perlio');
next if -d $file;
open F, "<$file" or die "Cannot open $file: $!\n" ;
my $line = 0;
while (<F>) {
$line++;
last if /^__END__/ ;
}
{
local $/ = undef;
$files++;
@prgs = (@prgs, $file, split "\n########\n", <F>) ;
}
close F ;
}
undef $/;
plan tests => (scalar(@prgs)-$files);
for (@prgs){
unless (/\n/)
{
print "# From $_\n";
next;
}
my $switch = "";
my @temps = () ;
my @temp_path = () ;
if (s/^\s*-\w+//){
$switch = $&;
}
my($prog,$expected) = split(/\nEXPECT\n/, $_);
my ($todo, $todo_reason);
$todo = $prog =~ s/^#\s*TODO(.*)\n//m and $todo_reason = $1;
if ( $prog =~ /--FILE--/) {
my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
shift @files ;
die "Internal error test $test didn't split into pairs, got " .
scalar(@files) . "[" . join("%%%%", @files) ."]\n"
if @files % 2 ;
while (@files > 2) {
my $filename = shift @files ;
my $code = shift @files ;
push @temps, $filename ;
if ($filename =~ m#(.*)/#) {
mkpath($1);
push(@temp_path, $1);
}
open F, ">$filename" or die "Cannot open $filename: $!\n" ;
print F $code ;
close F or die "Cannot close $filename: $!\n";
}
shift @files ;
$prog = shift @files ;
}
# fix up some paths
if ($^O eq 'MacOS') {
$prog =~ s|require "./abc(d)?";|require ":abc$1";|g;
$prog =~ s|"\."|":"|g;
}
open TEST, ">$tmpfile" or die "Cannot open >$tmpfile: $!";
print TEST q{
BEGIN {
open(STDERR, ">&STDOUT")
or die "Can't dup STDOUT->STDERR: $!;";
}
};
print TEST "\n#line 1\n"; # So the line numbers don't get messed up.
print TEST $prog,"\n";
close TEST or die "Cannot close $tmpfile: $!";
my $results = runperl( switches => [$switch], stderr => 1, progfile => $tmpfile );
my $status = $?;
$results =~ s/\n+$//;
# allow expected output to be written as if $prog is on STDIN
$results =~ s/tmp\d+/-/g;
if ($^O eq 'VMS') {
# some tests will trigger VMS messages that won't be expected
$results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
# pipes double these sometimes
$results =~ s/\n\n/\n/g;
}
# bison says 'parse error' instead of 'syntax error',
# various yaccs may or may not capitalize 'syntax'.
$results =~ s/^(syntax|parse) error/syntax error/mig;
# allow all tests to run when there are leaks
$results =~ s/Scalars leaked: \d+\n//g;
# fix up some paths
if ($^O eq 'MacOS') {
$results =~ s|:abc\.pm\b|abc.pm|g;
$results =~ s|:abc(d)?\b|./abc$1|g;
}
$expected =~ s/\n+$//;
my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
# any special options? (OPTIONS foo bar zap)
my $option_regex = 0;
my $option_random = 0;
if ($expected =~ s/^OPTIONS? (.+)\n//) {
foreach my $option (split(' ', $1)) {
if ($option eq 'regex') { # allow regular expressions
$option_regex = 1;
}
elsif ($option eq 'random') { # all lines match, but in any order
$option_random = 1;
}
else {
die "$0: Unknown OPTION '$option'\n";
}
}
}
die "$0: can't have OPTION regex and random\n"
if $option_regex + option_random > 1;
my $ok = 1;
if ( $results =~ s/^SKIPPED\n//) {
print "$results\n" ;
}
elsif ($option_random)
{
$ok = randomMatch($results, $expected);
}
elsif (($prefix && (( $option_regex && $results !~ /^$expected/) ||
(!$option_regex && $results !~ /^\Q$expected/))) or
(!$prefix && (( $option_regex && $results !~ /^$expected/) ||
(!$option_regex && $results ne $expected)))) {
my $err_line = "PROG: $switch\n$prog\n" .
"EXPECTED:\n$expected\n" .
"GOT:\n$results\n";
if ($todo) {
$err_line =~ s/^/# /mg;
print $err_line; # Harness can't filter it out from STDERR.
}
else {
print STDERR $err_line;
}
$ok = 0;
}
$TODO = $todo ? $todo_reason : 0;
ok($ok);
foreach (@temps)
{ unlink $_ if $_ }
foreach (@temp_path)
{ rmtree $_ if -d $_ }
}
sub randomMatch
{
my $got = shift ;
my $expected = shift;
my @got = sort split "\n", $got ;
my @expected = sort split "\n", $expected ;
return "@got" eq "@expected";
}
--- NEW FILE: vmsish.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
require "./test.pl";
plan(tests => 25);
SKIP: {
skip("tests for non-VMS only", 1) if $^O eq 'VMS';
no utf8;
BEGIN { $Orig_Bits = $^H }
# make sure that all those 'use vmsish' calls didn't do anything.
is( $Orig_Bits, $^H, 'use vmsish a no-op' );
}
SKIP: {
skip("tests for VMS only", 24) unless $^O eq 'VMS';
#========== vmsish status ==========
`$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter.
is($?,0,"simple Perl invokation: POSIX success status");
{
use vmsish qw(status);
is(($? & 1),1, "importing vmsish [vmsish status]");
{
no vmsish qw(status); # check unimport function
is($?,0, "unimport vmsish [POSIX STATUS]");
}
# and lexical scoping
is(($? & 1),1,"lex scope of vmsish [vmsish status]");
}
is($?,0,"outer lex scope of vmsish [POSIX status]");
{
use vmsish qw(exit); # check import function
is($?,0,"importing vmsish exit [POSIX status]");
}
#========== vmsish exit, messages ==========
{
use vmsish qw(status);
$msg = do_a_perl('-e "exit 1"');
$msg =~ s/\n/\\n/g; # keep output on one line
like($msg,'ABORT', "POSIX ERR exit, DCL error message check");
is($?&1,0,"vmsish status check, POSIX ERR exit");
$msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
$msg =~ s/\n/\\n/g; # keep output on one line
ok(length($msg)==0,"vmsish OK exit, DCL error message check");
is($?&1,1, "vmsish status check, vmsish OK exit");
$msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
$msg =~ s/\n/\\n/g; # keep output on one line
like($msg, 'ABORT', "vmsish ERR exit, DCL error message check");
is($?&1,0,"vmsish ERR exit, vmsish status check");
$msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"');
$msg =~ s/\n/\\n/g; # keep output on one line
ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check");
$msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
$msg =~ s/\n/\\n/g; # keep output on one line
ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check");
$msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"');
$msg =~ s/\n/\\n/g; # keep output on one line
like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check");
$msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"');
$msg =~ s/\n/\\n/g; # keep output on one line
ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check");
$msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"');
$msg =~ s/\n/\\n/g; # keep output on one line
ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check");
$msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"');
$msg =~ s/\n/\\n/g; # keep output on one line
ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check");
local *TEST;
open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing');
print TEST "#! perl\n";
print TEST "use vmsish qw(hushed);\n";
print TEST "\$obvious = (\$compile(\$error;\n";
close TEST;
$msg = do_a_perl('vmsish_test.pl');
$msg =~ s/\n/\\n/g; # keep output on one line
ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check");
unlink 'vmsish_test.pl';
}
#========== vmsish time ==========
{
my($utctime, @utclocal, @utcgmtime, $utcmtime,
$vmstime, @vmslocal, @vmsgmtime, $vmsmtime,
$utcval, $vmaval, $offset);
# Make sure apparent local time isn't GMT
if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) {
$oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
$ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600;
eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }";
gmtime(0); # Force reset of tz offset
}
# Unless we are prepared to parse the timezone rules here and figure out
# what the correct offset was when the file was last revised, we need to
# use a file for which the current offset is known to be valid. That's why
# we create a file rather than using an existing one for the stat() test.
my $file = 'sys$scratch:vmsish_t_flirble.tmp';
open TMP, ">$file" or die "Couldn't open file $file";
close TMP;
END { 1 while unlink $file; }
{
use_ok('vmsish qw(time)');
# but that didn't get it in our current scope
use vmsish qw(time);
$vmstime = time;
@vmslocal = localtime($vmstime);
@vmsgmtime = gmtime($vmstime);
$vmsmtime = (stat $file)[9];
}
$utctime = time;
@utclocal = localtime($vmstime);
@utcgmtime = gmtime($vmstime);
$utcmtime = (stat $file)[9];
$offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
# We allow lots of leeway (10 sec) difference for these tests,
# since it's unlikely local time will differ from UTC by so small
# an amount, and it renders the test resistant to delays from
# things like stat() on a file mounted over a slow network link.
ok(abs($utctime - $vmstime + $offset) <= 10,"(time) UTC: $utctime VMS: $vmstime");
$utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
$utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0];
$vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
$vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0];
ok(abs($vmsval - $utcval + $offset) <= 10, "(localtime) UTC: $utcval VMS: $vmsval");
print "# UTC: @utclocal\n# VMS: @vmslocal\n";
$utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
$utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0];
$vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
$vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0];
ok(abs($vmsval - $utcval + $offset) <= 10, "(gmtime) UTC: $utcval VMS: $vmsval");
print "# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
ok(abs($utcmtime - $vmsmtime + $offset) <= 10,"(stat) UTC: $utcmtime VMS: $vmsmtime");
}
}
#====== need this to make sure error messages come out, even if
# they were turned off in invoking procedure
sub do_a_perl {
local *P;
open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing');
print P "\$ set message/facil/sever/ident/text\n";
print P "\$ define/nolog/user sys\$error _nla0:\n";
print P "\$ $Invoke_Perl @_\n";
close P;
my $x = `\@vmsish_test.com`;
unlink 'vmsish_test.com';
return $x;
}
--- NEW FILE: charnames.t ---
#!./perl
my @WARN;
BEGIN {
unless(grep /blib/, @INC) {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
$SIG{__WARN__} = sub { push @WARN, @_ };
}
require File::Spec;
$| = 1;
print "1..74\n";
use charnames ':full';
print "not " unless "Here\N{EXCLAMATION MARK}?" eq "Here!?";
print "ok 1\n";
{
use bytes; # TEST -utf8 can switch utf8 on
print "# \$res=$res \$\@='$@'\nnot "
if $res = eval <<'EOE'
use charnames ":full";
"Here: \N{CYRILLIC SMALL LETTER BE}!";
1
EOE
or $@ !~ /above 0xFF/;
print "ok 2\n";
# print "# \$res=$res \$\@='$@'\n";
print "# \$res=$res \$\@='$@'\nnot "
if $res = eval <<'EOE'
use charnames 'cyrillic';
"Here: \N{Be}!";
1
EOE
or $@ !~ /CYRILLIC CAPITAL LETTER BE.*above 0xFF/;
print "ok 3\n";
}
# If octal representation of unicode char is \0xyzt, then the utf8 is \3xy\2zt
if (ord('A') == 65) { # as on ASCII or UTF-8 machines
$encoded_be = "\320\261";
$encoded_alpha = "\316\261";
$encoded_bet = "\327\221";
$encoded_deseng = "\360\220\221\215";
}
else { # EBCDIC where UTF-EBCDIC may be used (this may be 1047 specific since
# UTF-EBCDIC is codepage specific)
$encoded_be = "\270\102\130";
$encoded_alpha = "\264\130";
$encoded_bet = "\270\125\130";
$encoded_deseng = "\336\102\103\124";
}
sub to_bytes {
pack"a*", shift;
}
{
use charnames ':full';
print "not " unless to_bytes("\N{CYRILLIC SMALL LETTER BE}") eq $encoded_be;
print "ok 4\n";
use charnames qw(cyrillic greek :short);
print "not " unless to_bytes("\N{be},\N{alpha},\N{hebrew:bet}")
eq "$encoded_be,$encoded_alpha,$encoded_bet";
print "ok 5\n";
}
{
use charnames ':full';
print "not " unless "\x{263a}" eq "\N{WHITE SMILING FACE}";
print "ok 6\n";
print "not " unless length("\x{263a}") == 1;
print "ok 7\n";
print "not " unless length("\N{WHITE SMILING FACE}") == 1;
print "ok 8\n";
print "not " unless sprintf("%vx", "\x{263a}") eq "263a";
print "ok 9\n";
print "not " unless sprintf("%vx", "\N{WHITE SMILING FACE}") eq "263a";
print "ok 10\n";
print "not " unless sprintf("%vx", "\xFF\N{WHITE SMILING FACE}") eq "ff.263a";
print "ok 11\n";
print "not " unless sprintf("%vx", "\x{ff}\N{WHITE SMILING FACE}") eq "ff.263a";
print "ok 12\n";
}
{
use charnames qw(:full);
use utf8;
my $x = "\x{221b}";
my $named = "\N{CUBE ROOT}";
print "not " unless ord($x) == ord($named);
print "ok 13\n";
}
{
use charnames qw(:full);
use utf8;
print "not " unless "\x{100}\N{CENT SIGN}" eq "\x{100}"."\N{CENT SIGN}";
print "ok 14\n";
}
{
use charnames ':full';
print "not "
unless to_bytes("\N{DESERET SMALL LETTER ENG}") eq $encoded_deseng;
print "ok 15\n";
}
{
# 20001114.001
no utf8; # naked Latin-1
if (ord("Ä") == 0xc4) { # Try to do this only on Latin-1.
use charnames ':full';
my $text = "\N{LATIN CAPITAL LETTER A WITH DIAERESIS}";
print "not " unless $text eq "\xc4" && ord($text) == 0xc4;
print "ok 16\n";
} else {
print "ok 16 # Skip: not Latin-1\n";
}
}
{
print "not " unless charnames::viacode(0x1234) eq "ETHIOPIC SYLLABLE SEE";
print "ok 17\n";
# Unused Hebrew.
print "not " if defined charnames::viacode(0x0590);
print "ok 18\n";
}
{
print "not " unless
sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")) eq "10330";
print "ok 19\n";
print "not " if
defined charnames::vianame("NONE SUCH");
print "ok 20\n";
}
{
# check that caching at least hasn't broken anything
print "not " unless charnames::viacode(0x1234) eq "ETHIOPIC SYLLABLE SEE";
print "ok 21\n";
print "not " unless
sprintf("%04X", charnames::vianame("GOTHIC LETTER AHSA")) eq "10330";
print "ok 22\n";
}
print "not " unless "\N{CHARACTER TABULATION}" eq "\t";
print "ok 23\n";
print "not " unless "\N{ESCAPE}" eq "\e";
print "ok 24\n";
print "not " unless "\N{NULL}" eq "\c@";
print "ok 25\n";
if ($^O eq 'MacOS')
{
print "not " unless "\N{CARRIAGE RETURN (CR)}" eq "\n";
print "ok 26\n";
print "not " unless "\N{CARRIAGE RETURN}" eq "\n";
print "ok 27\n";
print "not " unless "\N{CR}" eq "\n";
print "ok 28\n";
}
else
{
print "not " unless "\N{LINE FEED (LF)}" eq "\n";
print "ok 26\n";
print "not " unless "\N{LINE FEED}" eq "\n";
print "ok 27\n";
print "not " unless "\N{LF}" eq "\n";
print "ok 28\n";
}
my $nel = ord("A") == 193 ? qr/^(?:\x15|\x25)$/ : qr/^\x85$/;
print "not " unless "\N{NEXT LINE (NEL)}" =~ $nel;
print "ok 29\n";
print "not " unless "\N{NEXT LINE}" =~ $nel;
print "ok 30\n";
print "not " unless "\N{NEL}" =~ $nel;
print "ok 31\n";
print "not " unless "\N{BYTE ORDER MARK}" eq chr(0xFEFF);
print "ok 32\n";
print "not " unless "\N{BOM}" eq chr(0xFEFF);
print "ok 33\n";
{
use warnings 'deprecated';
print "not " unless "\N{HORIZONTAL TABULATION}" eq "\t";
print "ok 34\n";
print "not " unless grep { /"HORIZONTAL TABULATION" is deprecated/ } @WARN;
print "ok 35\n";
no warnings 'deprecated';
print "not " unless "\N{VERTICAL TABULATION}" eq "\013";
print "ok 36\n";
print "not " if grep { /"VERTICAL TABULATION" is deprecated/ } @WARN;
print "ok 37\n";
}
print "not " unless charnames::viacode(0xFEFF) eq "ZERO WIDTH NO-BREAK SPACE";
print "ok 38\n";
{
use warnings;
print "not " unless ord("\N{BOM}") == 0xFEFF;
print "ok 39\n";
}
print "not " unless ord("\N{ZWNJ}") == 0x200C;
print "ok 40\n";
print "not " unless ord("\N{ZWJ}") == 0x200D;
print "ok 41\n";
print "not " unless "\N{U+263A}" eq "\N{WHITE SMILING FACE}";
print "ok 42\n";
{
print "not " unless
0x3093 == charnames::vianame("HIRAGANA LETTER N");
print "ok 43\n";
print "not " unless
0x0397 == charnames::vianame("GREEK CAPITAL LETTER ETA");
print "ok 44\n";
}
print "not " if defined charnames::viacode(0x110000);
print "ok 45\n";
print "not " if grep { /you asked for U+110000/ } @WARN;
print "ok 46\n";
# ---- Alias extensions
my $tmpfile = "tmp0000";
my $alifile = File::Spec->catfile(File::Spec->updir, qw(lib unicore xyzzy_alias.pl));
my $i = 0;
1 while -e ++$tmpfile;
END { if ($tmpfile) { 1 while unlink $tmpfile; } }
my @prgs;
{ local $/ = undef;
@prgs = split "\n########\n", <DATA>;
}
my $i = 46;
for (@prgs) {
my ($code, $exp) = ((split m/\nEXPECT\n/), '$');
my ($prog, $fil) = ((split m/\nFILE\n/, $code), "");
open my $tmp, "> $tmpfile" or die "Could not open $tmpfile: $!";
print $tmp $prog, "\n";
close $tmp or die "Could not close $tmpfile: $!";
if ($fil) {
$fil .= "\n";
open my $ali, "> $alifile" or die "Could not open $alifile: $!";
print $ali $fil;
close $ali or die "Could not close $alifile: $!";
}
my $res = runperl( switches => $switch,
progfile => $tmpfile,
stderr => 1 );
my $status = $?;
$res =~ s/[\r\n]+$//;
$res =~ s/tmp\d+/-/g; # fake $prog from STDIN
$res =~ s/\n%[A-Z]+-[SIWEF]-.*$// # clip off DCL status msg
if $^O eq "VMS";
$exp =~ s/[\r\n]+$//;
if ($^O eq "MacOS") {
$exp =~ s{(\./)?abc\.pm}{:abc.pm}g;
$exp =~ s{./abc} {:abc}g;
}
my $pfx = ($res =~ s/^PREFIX\n//);
my $rexp = qr{^$exp};
if ($res =~ s/^SKIPPED\n//) {
print "$results\n";
}
elsif (($pfx and $res !~ /^\Q$expected/) or
(!$pfx and $res !~ $rexp)) {
print STDERR
"PROG:\n$prog\n",
"FILE:\n$fil",
"EXPECTED:\n$exp\n",
"GOT:\n$res\n";
print "not ";
}
print "ok ", ++$i, "\n";
1 while unlink $tmpfile;
$fil or next;
1 while unlink $alifile;
}
# [perl #30409] charnames.pm clobbers default variable
$_ = 'foobar';
eval "use charnames ':full';";
print "not " unless $_ eq 'foobar';
print "ok 74\n";
__END__
# unsupported pragma
use charnames ":scoobydoo";
"Here: \N{e_ACUTE}!\n";
EXPECT
unsupported special ':scoobydoo' in charnames at
########
# wrong type of alias (missing colon)
use charnames "alias";
"Here: \N{e_ACUTE}!\n";
EXPECT
Unknown charname 'e_ACUTE' at
########
# alias without an argument
use charnames ":alias";
"Here: \N{e_ACUTE}!\n";
EXPECT
:alias needs an argument in charnames at
########
# reversed sequence
use charnames ":alias" => ":full";
"Here: \N{e_ACUTE}!\n";
EXPECT
:alias cannot use existing pragma :full \(reversed order\?\) at
########
# alias with hashref but no :full
use charnames ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
"Here: \N{e_ACUTE}!\n";
EXPECT
Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
########
# alias with hashref but with :short
use charnames ":short", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
"Here: \N{e_ACUTE}!\n";
EXPECT
Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
########
# alias with hashref to :full OK
use charnames ":full", ":alias" => { e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE" };
"Here: \N{e_ACUTE}!\n";
EXPECT
$
########
# alias with hashref to :short but using :full
use charnames ":full", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE" };
"Here: \N{e_ACUTE}!\n";
EXPECT
Unknown charname 'LATIN:e WITH ACUTE' at
########
# alias with hashref to :short OK
use charnames ":short", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE" };
"Here: \N{e_ACUTE}!\n";
EXPECT
$
########
# alias with bad hashref
use charnames ":short", ":alias" => "e_ACUTE";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
unicore/e_ACUTE_alias.pl cannot be used as alias file for charnames at
########
# alias with arrayref
use charnames ":short", ":alias" => [ e_ACUTE => "LATIN:e WITH ACUTE" ];
"Here: \N{e_ACUTE}!\n";
EXPECT
Only HASH reference supported as argument to :alias at
########
# alias with bad hashref
use charnames ":short", ":alias" => { e_ACUTE => "LATIN:e WITH ACUTE", "a_ACUTE" };
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
Use of uninitialized value in string eq at
########
# alias with hashref two aliases
use charnames ":short", ":alias" => {
e_ACUTE => "LATIN:e WITH ACUTE",
a_ACUTE => "",
};
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
Unknown charname '' at
########
# alias with hashref two aliases
use charnames ":short", ":alias" => {
e_ACUTE => "LATIN:e WITH ACUTE",
a_ACUTE => "LATIN:a WITH ACUTE",
};
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
$
########
# alias with hashref using mixed aliasses
use charnames ":short", ":alias" => {
e_ACUTE => "LATIN:e WITH ACUTE",
a_ACUTE => "LATIN SMALL LETTER A WITH ACUT",
};
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
Unknown charname 'LATIN SMALL LETTER A WITH ACUT' at
########
# alias with hashref using mixed aliasses
use charnames ":short", ":alias" => {
e_ACUTE => "LATIN:e WITH ACUTE",
a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
};
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
Unknown charname 'LATIN SMALL LETTER A WITH ACUTE' at
########
# alias with hashref using mixed aliasses
use charnames ":full", ":alias" => {
e_ACUTE => "LATIN:e WITH ACUTE",
a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
};
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
Unknown charname 'LATIN:e WITH ACUTE' at
########
# alias with nonexisting file
use charnames ":full", ":alias" => "xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
unicore/xyzzy_alias.pl cannot be used as alias file for charnames at
########
# alias with bad file name
use charnames ":full", ":alias" => "xy 7-";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
Charnames alias files can only have identifier characters at
########
# alias with non_absolute (existing) file name (which it should /not/ use)
use charnames ":full", ":alias" => "perl";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
EXPECT
unicore/perl_alias.pl cannot be used as alias file for charnames at
########
# alias with bad file
use charnames ":full", ":alias" => "xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
FILE
#!perl
0;
EXPECT
unicore/xyzzy_alias.pl did not return a \(valid\) list of alias pairs at
########
# alias with file with empty list
use charnames ":full", ":alias" => "xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
FILE
#!perl
();
EXPECT
Unknown charname 'e_ACUTE' at
########
# alias with file OK but file has :short aliasses
use charnames ":full", ":alias" => "xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
FILE
#!perl
( e_ACUTE => "LATIN:e WITH ACUTE",
a_ACUTE => "LATIN:a WITH ACUTE",
);
EXPECT
Unknown charname 'LATIN:e WITH ACUTE' at
########
# alias with :short and file OK
use charnames ":short", ":alias" => "xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
FILE
#!perl
( e_ACUTE => "LATIN:e WITH ACUTE",
a_ACUTE => "LATIN:a WITH ACUTE",
);
EXPECT
$
########
# alias with :short and file OK has :long aliasses
use charnames ":short", ":alias" => "xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
FILE
#!perl
( e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
);
EXPECT
Unknown charname 'LATIN SMALL LETTER E WITH ACUTE' at
########
# alias with file implicit :full but file has :short aliasses
use charnames ":alias" => ":xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
FILE
#!perl
( e_ACUTE => "LATIN:e WITH ACUTE",
a_ACUTE => "LATIN:a WITH ACUTE",
);
EXPECT
Unknown charname 'LATIN:e WITH ACUTE' at
########
# alias with file implicit :full and file has :long aliasses
use charnames ":alias" => ":xyzzy";
"Here: \N{e_ACUTE}\N{a_ACUTE}!\n";
FILE
#!perl
( e_ACUTE => "LATIN SMALL LETTER E WITH ACUTE",
a_ACUTE => "LATIN SMALL LETTER A WITH ACUTE",
);
EXPECT
$
--- NEW FILE: Thread.pm ---
package Thread;
use strict;
our($VERSION, $ithreads, $othreads);
BEGIN {
$VERSION = '2.00';
use Config;
$ithreads = $Config{useithreads};
$othreads = $Config{use5005threads};
}
require Exporter;
use XSLoader ();
our(@ISA, @EXPORT, @EXPORT_OK);
@ISA = qw(Exporter);
BEGIN {
if ($ithreads) {
@EXPORT = qw(cond_wait cond_broadcast cond_signal)
} elsif ($othreads) {
@EXPORT_OK = qw(cond_signal cond_broadcast cond_wait);
}
push @EXPORT_OK, qw(async yield);
}
=head1 NAME
Thread - manipulate threads in Perl (for old code only)
=head1 CAVEAT
Perl has two thread models.
In Perl 5.005 the thread model was that all data is implicitly shared
and shared access to data has to be explicitly synchronized.
This model is called "5005threads".
In Perl 5.6 a new model was introduced in which all is was thread
local and shared access to data has to be explicitly declared.
This model is called "ithreads", for "interpreter threads".
In Perl 5.6 the ithreads model was not available as a public API,
only as an internal API that was available for extension writers,
and to implement fork() emulation on Win32 platforms.
In Perl 5.8 the ithreads model became available through the C<threads>
module.
Neither model is configured by default into Perl (except, as mentioned
above, in Win32 ithreads are always available.) You can see your
Perl's threading configuration by running C<perl -V> and looking for
the I<use...threads> variables, or inside script by C<use Config;>
and testing for C<$Config{use5005threads}> and C<$Config{useithreads}>.
For old code and interim backwards compatibility, the Thread module
has been reworked to function as a frontend for both 5005threads and
ithreads.
Note that the compatibility is not complete: because the data sharing
models are directly opposed, anything to do with data sharing has to
be thought differently. With the ithreads you must explicitly share()
variables between the threads.
For new code the use of the C<Thread> module is discouraged and
the direct use of the C<threads> and C<threads::shared> modules
is encouraged instead.
Finally, note that there are many known serious problems with the
5005threads, one of the least of which is that regular expression
match variables like $1 are not threadsafe, that is, they easily get
corrupted by competing threads. Other problems include more insidious
data corruption and mysterious crashes. You are seriously urged to
use ithreads instead.
=head1 SYNOPSIS
use Thread;
my $t = Thread->new(\&start_sub, @start_args);
$result = $t->join;
$result = $t->eval;
$t->detach;
if ($t->done) {
$t->join;
}
if($t->equal($another_thread)) {
# ...
}
yield();
my $tid = Thread->self->tid;
lock($scalar);
lock(@array);
lock(%hash);
lock(\&sub); # not available with ithreads
$flags = $t->flags; # not available with ithreads
my @list = Thread->list; # not available with ithreads
use Thread 'async';
=head1 DESCRIPTION
The C<Thread> module provides multithreading support for perl.
=head1 FUNCTIONS
=over 8
=item $thread = Thread->new(\&start_sub)
=item $thread = Thread->new(\&start_sub, LIST)
C<new> starts a new thread of execution in the referenced subroutine. The
optional list is passed as parameters to the subroutine. Execution
continues in both the subroutine and the code after the C<new> call.
C<Thread->new> returns a thread object representing the newly created
thread.
=item lock VARIABLE
C<lock> places a lock on a variable until the lock goes out of scope.
If the variable is locked by another thread, the C<lock> call will
block until it's available. C<lock> is recursive, so multiple calls
to C<lock> are safe--the variable will remain locked until the
outermost lock on the variable goes out of scope.
Locks on variables only affect C<lock> calls--they do I<not> affect normal
access to a variable. (Locks on subs are different, and covered in a bit.)
If you really, I<really> want locks to block access, then go ahead and tie
them to something and manage this yourself. This is done on purpose.
While managing access to variables is a good thing, Perl doesn't force
you out of its living room...
If a container object, such as a hash or array, is locked, all the
elements of that container are not locked. For example, if a thread
does a C<lock @a>, any other thread doing a C<lock($a[12])> won't
block.
With 5005threads you may also C<lock> a sub, using C<lock &sub>.
Any calls to that sub from another thread will block until the lock
is released. This behaviour is not equivalent to declaring the sub
with the C<locked> attribute. The C<locked> attribute serializes
access to a subroutine, but allows different threads non-simultaneous
access. C<lock &sub>, on the other hand, will not allow I<any> other
thread access for the duration of the lock.
Finally, C<lock> will traverse up references exactly I<one> level.
C<lock(\$a)> is equivalent to C<lock($a)>, while C<lock(\\$a)> is not.
=item async BLOCK;
C<async> creates a thread to execute the block immediately following
it. This block is treated as an anonymous sub, and so must have a
semi-colon after the closing brace. Like C<Thread->new>, C<async>
returns a thread object.
=item Thread->self
The C<Thread-E<gt>self> function returns a thread object that represents
the thread making the C<Thread-E<gt>self> call.
=item cond_wait VARIABLE
The C<cond_wait> function takes a B<locked> variable as
a parameter, unlocks the variable, and blocks until another thread
does a C<cond_signal> or C<cond_broadcast> for that same locked
variable. The variable that C<cond_wait> blocked on is relocked
after the C<cond_wait> is satisfied. If there are multiple threads
C<cond_wait>ing on the same variable, all but one will reblock waiting
to reaquire the lock on the variable. (So if you're only using
C<cond_wait> for synchronization, give up the lock as soon as
possible.)
=item cond_signal VARIABLE
The C<cond_signal> function takes a locked variable as a parameter and
unblocks one thread that's C<cond_wait>ing on that variable. If more than
one thread is blocked in a C<cond_wait> on that variable, only one (and
which one is indeterminate) will be unblocked.
If there are no threads blocked in a C<cond_wait> on the variable,
the signal is discarded.
=item cond_broadcast VARIABLE
The C<cond_broadcast> function works similarly to C<cond_signal>.
C<cond_broadcast>, though, will unblock B<all> the threads that are
blocked in a C<cond_wait> on the locked variable, rather than only
one.
=item yield
The C<yield> function allows another thread to take control of the
CPU. The exact results are implementation-dependent.
=back
=head1 METHODS
=over 8
=item join
C<join> waits for a thread to end and returns any values the thread
exited with. C<join> will block until the thread has ended, though
it won't block if the thread has already terminated.
If the thread being C<join>ed C<die>d, the error it died with will
be returned at this time. If you don't want the thread performing
the C<join> to die as well, you should either wrap the C<join> in
an C<eval> or use the C<eval> thread method instead of C<join>.
=item eval
The C<eval> method wraps an C<eval> around a C<join>, and so waits for
a thread to exit, passing along any values the thread might have returned.
Errors, of course, get placed into C<$@>. (Not available with ithreads.)
=item detach
C<detach> tells a thread that it is never going to be joined i.e.
that all traces of its existence can be removed once it stops running.
Errors in detached threads will not be visible anywhere - if you want
to catch them, you should use $SIG{__DIE__} or something like that.
=item equal
C<equal> tests whether two thread objects represent the same thread and
returns true if they do.
=item tid
The C<tid> method returns the tid of a thread. The tid is
a monotonically increasing integer assigned when a thread is
created. The main thread of a program will have a tid of zero,
while subsequent threads will have tids assigned starting with one.
=item flags
The C<flags> method returns the flags for the thread. This is the
integer value corresponding to the internal flags for the thread,
and the value may not be all that meaningful to you.
(Not available with ithreads.)
=item done
The C<done> method returns true if the thread you're checking has
finished, and false otherwise. (Not available with ithreads.)
=back
=head1 LIMITATIONS
The sequence number used to assign tids is a simple integer, and no
checking is done to make sure the tid isn't currently in use. If a
program creates more than 2**32 - 1 threads in a single run, threads
may be assigned duplicate tids. This limitation may be lifted in
a future version of Perl.
=head1 SEE ALSO
L<threads::shared> (not available with 5005threads)
L<attributes>, L<Thread::Queue>, L<Thread::Semaphore>,
L<Thread::Specific> (not available with ithreads)
=cut
#
# Methods
#
#
# Exported functions
#
sub async (&) {
return Thread->new($_[0]);
}
sub eval {
return eval { shift->join; };
}
sub unimplemented {
print $_[0], " unimplemented with ",
$Config{useithreads} ? "ithreads" : "5005threads", "\n";
}
sub unimplement {
for my $m (@_) {
no strict 'refs';
*{"Thread::$m"} = sub { unimplemented $m };
}
}
BEGIN {
if ($ithreads) {
if ($othreads) {
require Carp;
Carp::croak("This Perl has both ithreads and 5005threads (serious malconfiguration)");
}
XSLoader::load 'threads';
for my $m (qw(new join detach yield self tid equal list)) {
no strict 'refs';
*{"Thread::$m"} = \&{"threads::$m"};
}
require 'threads/shared.pm';
for my $m (qw(cond_signal cond_broadcast cond_wait)) {
no strict 'refs';
*{"Thread::$m"} = \&{"threads::shared::${m}_enabled"};
}
# trying to unimplement eval gives redefined warning
unimplement(qw(done flags));
} elsif ($othreads) {
XSLoader::load 'Thread';
} else {
require Carp;
Carp::croak("This Perl has neither ithreads nor 5005threads");
}
}
1;
--- NEW FILE: filetest.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use Config;
use Test::More tests => 15;
# these two should be kept in sync with the pragma itself
# if hint bits are changed there, other things *will* break
my $hint_bits = 0x00400000;
my $error = "filetest: the only implemented subpragma is 'access'.\n";
# can't use it yet, because of the import death
ok( require filetest, 'required pragma successfully' );
# and here's one culprit, right here
eval { filetest->import('bad subpragma') };
is( $@, $error, 'filetest dies with bad subpragma on import' );
is( $^H & $hint_bits, 0, 'hint bits not set without pragma in place' );
# now try the normal usage
# can't check $^H here; it's lexically magic (see perlvar)
# the test harness unintentionally hoards the goodies for itself
use_ok( 'filetest', 'access' );
# and import again, to see it here
filetest->import('access');
ok( $^H & $hint_bits, 'hint bits set with pragma loaded' );
# and now get rid of it
filetest->unimport('access');
is( $^H & $hint_bits, 0, 'hint bits not set with pragma unimported' );
eval { filetest->unimport() };
is( $@, $error, 'filetest dies without subpragma on unimport' );
# there'll be a compilation aborted failure here, with the eval string
eval "no filetest 'fake pragma'";
like( $@, qr/^$error/, 'filetest dies with bad subpragma on unuse' );
eval "use filetest 'bad subpragma'";
like( $@, qr/^$error/, 'filetest dies with bad subpragma on use' );
eval "use filetest";
like( $@, qr/^$error/, 'filetest dies with missing subpragma on use' );
eval "no filetest";
like( $@, qr/^$error/, 'filetest dies with missing subpragma on unuse' );
SKIP: {
# A real test for filetest.
# This works for systems with /usr/bin/chflags (i.e. BSD4.4 systems).
my $chflags = "/usr/bin/chflags";
my $tstfile = "filetest.tst";
skip("No $chflags available", 4) if !-x $chflags;
my $skip_eff_user_tests = (!$Config{d_setreuid} && !$Config{d_setresuid})
||
(!$Config{d_setregid} && !$Config{d_setresgid});
eval {
if (!-e $tstfile) {
open(T, ">$tstfile") or die "Can't create $tstfile: $!";
close T;
}
system($chflags, "uchg", $tstfile);
die "Can't exec $chflags uchg" if $? != 0;
};
skip("Errors in test using chflags: $@", 4) if $@;
{
use filetest 'access';
SKIP: {
skip("No tests on effective user id", 1)
if $skip_eff_user_tests;
is(-w $tstfile, undef, "$tstfile should not be recognized as writable");
}
is(-W $tstfile, undef, "$tstfile should not be recognized as writable");
}
{
no filetest 'access';
SKIP: {
skip("No tests on effective user id", 1)
if $skip_eff_user_tests;
is(-w $tstfile, 1, "$tstfile should be recognized as writable");
}
is(-W $tstfile, 1, "$tstfile should be recognized as writable");
}
# cleanup
system($chflags, "nouchg", $tstfile);
unlink $tstfile;
warn "Can't remove $tstfile: $!" if -e $tstfile;
}
--- NEW FILE: open.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
require Config; import Config;
}
use Test::More tests => 16;
# open::import expects 'open' as its first argument, but it clashes with open()
sub import {
open::import( 'open', @_ );
}
# can't use require_ok() here, with a name like 'open'
ok( require 'open.pm', 'requiring open' );
# this should fail
eval { import() };
like( $@, qr/needs explicit list of PerlIO layers/,
'import should fail without args' );
# the hint bits shouldn't be set yet
is( $^H & $open::hint_bits, 0,
'hint bits should not be set in $^H before open import' );
# prevent it from loading I18N::Langinfo, so we can test encoding failures
my $warn;
local $SIG{__WARN__} = sub {
$warn .= shift;
};
# and it shouldn't be able to find this layer
$warn = '';
eval q{ no warnings 'layer'; use open IN => ':macguffin' ; };
is( $warn, '',
'should not warn about unknown layer with bad layer provided' );
$warn = '';
eval q{ use warnings 'layer'; use open IN => ':macguffin' ; };
like( $warn, qr/Unknown PerlIO layer/,
'should warn about unknown layer with bad layer provided' );
# open :locale logic changed since open 1.04, new logic
# difficult to test portably.
# see if it sets the magic variables appropriately
import( 'IN', ':crlf' );
ok( $^H & $open::hint_bits,
'hint bits should be set in $^H after open import' );
is( $^H{'open_IN'}, 'crlf', 'should have set crlf layer' );
# it should reset them appropriately, too
import( 'IN', ':raw' );
is( $^H{'open_IN'}, 'raw', 'should have reset to raw layer' );
# it dies if you don't set IN, OUT, or IO
eval { import( 'sideways', ':raw' ) };
like( $@, qr/Unknown PerlIO layer class/, 'should croak with unknown class' );
# but it handles them all so well together
import( 'IO', ':raw :crlf' );
is( ${^OPEN}, ":raw :crlf\0:raw :crlf",
'should set multi types, multi layer' );
is( $^H{'open_IO'}, 'crlf', 'should record last layer set in %^H' );
SKIP: {
skip("no perlio, no :utf8", 4) unless (find PerlIO::Layer 'perlio');
eval <<EOE;
use open ':utf8';
open(O, ">utf8");
print O chr(0x100);
close O;
open(I, "<utf8");
is(ord(<I>), 0x100, ":utf8 single wide character round-trip");
close I;
EOE
open F, ">a";
@a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000
unshift @a, chr(0); # ... and a null byte in front just for fun
print F @a;
close F;
sub systell {
use Fcntl 'SEEK_CUR';
sysseek($_[0], 0, SEEK_CUR);
}
require bytes; # not use
my $ok;
open F, "<:utf8", "a";
$ok = $a = 0;
for (@a) {
unless (
($c = sysread(F, $b, 1)) == 1 &&
length($b) == 1 &&
ord($b) == ord($_) &&
systell(F) == ($a += bytes::length($b))
) {
print '# ord($_) == ', ord($_), "\n";
print '# ord($b) == ', ord($b), "\n";
print '# length($b) == ', length($b), "\n";
print '# bytes::length($b) == ', bytes::length($b), "\n";
print '# systell(F) == ', systell(F), "\n";
print '# $a == ', $a, "\n";
print '# $c == ', $c, "\n";
last;
}
$ok++;
}
close F;
ok($ok == @a,
"on :utf8 streams sysread() should work on characters, not bytes");
# syswrite() on should work on characters, not bytes
open G, ">:utf8", "b";
$ok = $a = 0;
for (@a) {
unless (
($c = syswrite(G, $_, 1)) == 1 &&
systell(G) == ($a += bytes::length($_))
) {
print '# ord($_) == ', ord($_), "\n";
print '# bytes::length($_) == ', bytes::length($_), "\n";
print '# systell(G) == ', systell(G), "\n";
print '# $a == ', $a, "\n";
print '# $c == ', $c, "\n";
print "not ";
last;
}
$ok++;
}
close G;
ok($ok == @a,
"on :utf8 streams syswrite() should work on characters, not bytes");
open G, "<:utf8", "b";
$ok = $a = 0;
for (@a) {
unless (
($c = sysread(G, $b, 1)) == 1 &&
length($b) == 1 &&
ord($b) == ord($_) &&
systell(G) == ($a += bytes::length($_))
) {
print '# ord($_) == ', ord($_), "\n";
print '# ord($b) == ', ord($b), "\n";
print '# length($b) == ', length($b), "\n";
print '# bytes::length($b) == ', bytes::length($b), "\n";
print '# systell(G) == ', systell(G), "\n";
print '# $a == ', $a, "\n";
print '# $c == ', $c, "\n";
last;
}
$ok++;
}
close G;
ok($ok == @a,
"checking syswrite() output on :utf8 streams by reading it back in");
}
SKIP: {
skip("no perlio", 1) unless (find PerlIO::Layer 'perlio');
use open IN => ':non-existent';
eval {
require Symbol; # Anything that exists but we havn't loaded
};
like($@, qr/Can't locate Symbol|Recursive call/i,
"test for an endless loop in PerlIO_find_layer");
}
END {
1 while unlink "utf8";
1 while unlink "a";
1 while unlink "b";
}
# the test cases beyond __DATA__ need to be executed separately
__DATA__
$ENV{LC_ALL} = 'nonexistent.euc';
eval { open::_get_locale_encoding() };
like( $@, qr/too ambiguous/, 'should die with ambiguous locale encoding' );
%%%
# the special :locale layer
$ENV{LC_ALL} = $ENV{LANG} = 'ru_RU.KOI8-R';
# the :locale will probe the locale environment variables like LANG
use open OUT => ':locale';
open(O, ">koi8");
print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
close O;
open(I, "<koi8");
printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
close I;
%%%
--- NEW FILE: bigfloatpl.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
require "bigfloat.pl";
$test = 0;
$| = 1;
print "1..355\n";
while (<DATA>) {
chop;
if (/^&/) {
$f = $_;
} elsif (/^\$.*/) {
eval "$_;";
} else {
++$test;
@args = split(/:/,$_,99);
$ans = pop(@args);
$try = "$f('" . join("','", @args) . "');";
if (($ans1 = eval($try)) eq $ans) {
print "ok $test\n";
} else {
print "not ok $test\n";
print "# '$try' expected: '$ans' got: '$ans1'\n";
}
}
}
__END__
&fnorm
abc:NaN
1 a:NaN
1bcd2:NaN
11111b:NaN
+1z:NaN
-1z:NaN
0:+0E+0
+0:+0E+0
+00:+0E+0
+0 0 0:+0E+0
000000 0000000 00000:+0E+0
-0:+0E+0
-0000:+0E+0
+1:+1E+0
+01:+1E+0
+001:+1E+0
+00000100000:+1E+5
123456789:+123456789E+0
-1:-1E+0
-01:-1E+0
-001:-1E+0
-123456789:-123456789E+0
-00000100000:-1E+5
123.456a:NaN
123.456:+123456E-3
0.01:+1E-2
.002:+2E-3
-0.0003:-3E-4
-.0000000004:-4E-10
123456E2:+123456E+2
123456E-2:+123456E-2
-123456E2:-123456E+2
-123456E-2:-123456E-2
1e1:+1E+1
2e-11:+2E-11
-3e111:-3E+111
-4e-1111:-4E-1111
&fneg
abd:NaN
+0:+0E+0
+1:-1E+0
-1:+1E+0
+123456789:-123456789E+0
-123456789:+123456789E+0
+123.456789:-123456789E-6
-123456.789:+123456789E-3
&fabs
abc:NaN
+0:+0E+0
+1:+1E+0
-1:+1E+0
+123456789:+123456789E+0
-123456789:+123456789E+0
+123.456789:+123456789E-6
-123456.789:+123456789E-3
&fround
$bigfloat::rnd_mode = 'trunc'
+10123456789:5:+10123E+6
-10123456789:5:-10123E+6
+10123456789:9:+101234567E+2
-10123456789:9:-101234567E+2
+101234500:6:+101234E+3
-101234500:6:-101234E+3
$bigfloat::rnd_mode = 'zero'
+20123456789:5:+20123E+6
-20123456789:5:-20123E+6
+20123456789:9:+201234568E+2
-20123456789:9:-201234568E+2
+201234500:6:+201234E+3
-201234500:6:-201234E+3
$bigfloat::rnd_mode = '+inf'
+30123456789:5:+30123E+6
-30123456789:5:-30123E+6
+30123456789:9:+301234568E+2
-30123456789:9:-301234568E+2
+301234500:6:+301235E+3
-301234500:6:-301234E+3
$bigfloat::rnd_mode = '-inf'
+40123456789:5:+40123E+6
-40123456789:5:-40123E+6
+40123456789:9:+401234568E+2
-40123456789:9:-401234568E+2
+401234500:6:+401234E+3
-401234500:6:-401235E+3
$bigfloat::rnd_mode = 'odd'
+50123456789:5:+50123E+6
-50123456789:5:-50123E+6
+50123456789:9:+501234568E+2
-50123456789:9:-501234568E+2
+501234500:6:+501235E+3
-501234500:6:-501235E+3
$bigfloat::rnd_mode = 'even'
+60123456789:5:+60123E+6
-60123456789:5:-60123E+6
+60123456789:9:+601234568E+2
-60123456789:9:-601234568E+2
+601234500:6:+601234E+3
-601234500:6:-601234E+3
&ffround
$bigfloat::rnd_mode = 'trunc'
+1.23:-1:+12E-1
-1.23:-1:-12E-1
+1.27:-1:+12E-1
-1.27:-1:-12E-1
+1.25:-1:+12E-1
-1.25:-1:-12E-1
+1.35:-1:+13E-1
-1.35:-1:-13E-1
-0.006:-1:+0E+0
-0.006:-2:+0E+0
$bigfloat::rnd_mode = 'zero'
+2.23:-1:+22E-1
-2.23:-1:-22E-1
+2.27:-1:+23E-1
-2.27:-1:-23E-1
+2.25:-1:+22E-1
-2.25:-1:-22E-1
+2.35:-1:+23E-1
-2.35:-1:-23E-1
-0.0065:-1:+0E+0
-0.0065:-2:-1E-2
-0.0065:-3:-6E-3
-0.0065:-4:-65E-4
-0.0065:-5:-65E-4
$bigfloat::rnd_mode = '+inf'
+3.23:-1:+32E-1
-3.23:-1:-32E-1
+3.27:-1:+33E-1
-3.27:-1:-33E-1
+3.25:-1:+33E-1
-3.25:-1:-32E-1
+3.35:-1:+34E-1
-3.35:-1:-33E-1
-0.0065:-1:+0E+0
-0.0065:-2:-1E-2
-0.0065:-3:-6E-3
-0.0065:-4:-65E-4
-0.0065:-5:-65E-4
$bigfloat::rnd_mode = '-inf'
+4.23:-1:+42E-1
-4.23:-1:-42E-1
+4.27:-1:+43E-1
-4.27:-1:-43E-1
+4.25:-1:+42E-1
-4.25:-1:-43E-1
+4.35:-1:+43E-1
-4.35:-1:-44E-1
-0.0065:-1:+0E+0
-0.0065:-2:-1E-2
-0.0065:-3:-7E-3
-0.0065:-4:-65E-4
-0.0065:-5:-65E-4
$bigfloat::rnd_mode = 'odd'
+5.23:-1:+52E-1
-5.23:-1:-52E-1
+5.27:-1:+53E-1
-5.27:-1:-53E-1
+5.25:-1:+53E-1
-5.25:-1:-53E-1
+5.35:-1:+53E-1
-5.35:-1:-53E-1
-0.0065:-1:+0E+0
-0.0065:-2:-1E-2
-0.0065:-3:-7E-3
-0.0065:-4:-65E-4
-0.0065:-5:-65E-4
$bigfloat::rnd_mode = 'even'
+6.23:-1:+62E-1
-6.23:-1:-62E-1
+6.27:-1:+63E-1
-6.27:-1:-63E-1
+6.25:-1:+62E-1
-6.25:-1:-62E-1
+6.35:-1:+64E-1
-6.35:-1:-64E-1
-0.0065:-1:+0E+0
-0.0065:-2:-1E-2
-0.0065:-3:-6E-3
-0.0065:-4:-65E-4
-0.0065:-5:-65E-4
&fcmp
abc:abc:
abc:+0:
+0:abc:
+0:+0:0
-1:+0:-1
+0:-1:1
+1:+0:1
+0:+1:-1
-1:+1:-1
+1:-1:1
-1:-1:0
+1:+1:0
+123:+123:0
+123:+12:1
+12:+123:-1
-123:-123:0
-123:-12:-1
-12:-123:1
+123:+124:-1
+124:+123:1
-123:-124:1
-124:-123:-1
&fadd
abc:abc:NaN
abc:+0:NaN
+0:abc:NaN
+0:+0:+0E+0
+1:+0:+1E+0
+0:+1:+1E+0
+1:+1:+2E+0
-1:+0:-1E+0
+0:-1:-1E+0
-1:-1:-2E+0
-1:+1:+0E+0
+1:-1:+0E+0
+9:+1:+1E+1
+99:+1:+1E+2
+999:+1:+1E+3
+9999:+1:+1E+4
+99999:+1:+1E+5
+999999:+1:+1E+6
+9999999:+1:+1E+7
+99999999:+1:+1E+8
+999999999:+1:+1E+9
+9999999999:+1:+1E+10
+99999999999:+1:+1E+11
+10:-1:+9E+0
+100:-1:+99E+0
+1000:-1:+999E+0
+10000:-1:+9999E+0
+100000:-1:+99999E+0
+1000000:-1:+999999E+0
+10000000:-1:+9999999E+0
+100000000:-1:+99999999E+0
+1000000000:-1:+999999999E+0
+10000000000:-1:+9999999999E+0
+123456789:+987654321:+111111111E+1
-123456789:+987654321:+864197532E+0
-123456789:-987654321:-111111111E+1
+123456789:-987654321:-864197532E+0
&fsub
abc:abc:NaN
abc:+0:NaN
+0:abc:NaN
+0:+0:+0E+0
+1:+0:+1E+0
+0:+1:-1E+0
+1:+1:+0E+0
-1:+0:-1E+0
+0:-1:+1E+0
-1:-1:+0E+0
-1:+1:-2E+0
+1:-1:+2E+0
+9:+1:+8E+0
+99:+1:+98E+0
+999:+1:+998E+0
+9999:+1:+9998E+0
+99999:+1:+99998E+0
+999999:+1:+999998E+0
+9999999:+1:+9999998E+0
+99999999:+1:+99999998E+0
+999999999:+1:+999999998E+0
+9999999999:+1:+9999999998E+0
+99999999999:+1:+99999999998E+0
+10:-1:+11E+0
+100:-1:+101E+0
+1000:-1:+1001E+0
+10000:-1:+10001E+0
+100000:-1:+100001E+0
+1000000:-1:+1000001E+0
+10000000:-1:+10000001E+0
+100000000:-1:+100000001E+0
+1000000000:-1:+1000000001E+0
+10000000000:-1:+10000000001E+0
+123456789:+987654321:-864197532E+0
-123456789:+987654321:-111111111E+1
-123456789:-987654321:+864197532E+0
+123456789:-987654321:+111111111E+1
&fmul
abc:abc:NaN
abc:+0:NaN
+0:abc:NaN
+0:+0:+0E+0
+0:+1:+0E+0
+1:+0:+0E+0
+0:-1:+0E+0
-1:+0:+0E+0
+123456789123456789:+0:+0E+0
+0:+123456789123456789:+0E+0
-1:-1:+1E+0
-1:+1:-1E+0
+1:-1:-1E+0
+1:+1:+1E+0
+2:+3:+6E+0
-2:+3:-6E+0
+2:-3:-6E+0
-2:-3:+6E+0
+111:+111:+12321E+0
+10101:+10101:+102030201E+0
+1001001:+1001001:+1002003002001E+0
+100010001:+100010001:+10002000300020001E+0
+10000100001:+10000100001:+100002000030000200001E+0
+11111111111:+9:+99999999999E+0
+22222222222:+9:+199999999998E+0
+33333333333:+9:+299999999997E+0
+44444444444:+9:+399999999996E+0
+55555555555:+9:+499999999995E+0
+66666666666:+9:+599999999994E+0
+77777777777:+9:+699999999993E+0
+88888888888:+9:+799999999992E+0
+99999999999:+9:+899999999991E+0
&fdiv
abc:abc:NaN
abc:+1:abc:NaN
+1:abc:NaN
+0:+0:NaN
+0:+1:+0E+0
+1:+0:NaN
+0:-1:+0E+0
-1:+0:NaN
+1:+1:+1E+0
-1:-1:+1E+0
+1:-1:-1E+0
-1:+1:-1E+0
+1:+2:+5E-1
+2:+1:+2E+0
+10:+5:+2E+0
+100:+4:+25E+0
+1000:+8:+125E+0
+10000:+16:+625E+0
+10000:-16:-625E+0
+999999999999:+9:+111111111111E+0
+999999999999:+99:+10101010101E+0
+999999999999:+999:+1001001001E+0
+999999999999:+9999:+100010001E+0
+999999999999999:+99999:+10000100001E+0
+1000000000:+9:+1111111111111111111111111111111111111111E-31
+2000000000:+9:+2222222222222222222222222222222222222222E-31
+3000000000:+9:+3333333333333333333333333333333333333333E-31
+4000000000:+9:+4444444444444444444444444444444444444444E-31
+5000000000:+9:+5555555555555555555555555555555555555556E-31
+6000000000:+9:+6666666666666666666666666666666666666667E-31
+7000000000:+9:+7777777777777777777777777777777777777778E-31
+8000000000:+9:+8888888888888888888888888888888888888889E-31
+9000000000:+9:+1E+9
+35500000:+113:+3141592920353982300884955752212389380531E-34
+71000000:+226:+3141592920353982300884955752212389380531E-34
+106500000:+339:+3141592920353982300884955752212389380531E-34
+1000000000:+3:+3333333333333333333333333333333333333333E-31
$bigfloat::div_scale = 20
+1000000000:+9:+11111111111111111111E-11
+2000000000:+9:+22222222222222222222E-11
+3000000000:+9:+33333333333333333333E-11
+4000000000:+9:+44444444444444444444E-11
+5000000000:+9:+55555555555555555556E-11
+6000000000:+9:+66666666666666666667E-11
+7000000000:+9:+77777777777777777778E-11
+8000000000:+9:+88888888888888888889E-11
+9000000000:+9:+1E+9
+35500000:+113:+314159292035398230088E-15
+71000000:+226:+314159292035398230088E-15
+106500000:+339:+31415929203539823009E-14
+1000000000:+3:+33333333333333333333E-11
$bigfloat::div_scale = 40
&fsqrt
+0:+0E+0
-1:NaN
-2:NaN
-16:NaN
-123.456:NaN
+1:+1E+0
+1.44:+12E-1
+2:+141421356237309504880168872420969807857E-38
+4:+2E+0
+16:+4E+0
+100:+1E+1
+123.456:+1111107555549866648462149404118219234119E-38
+15241.383936:+123456E-3
--- NEW FILE: FileCache.pm ---
package FileCache;
our $VERSION = '1.06';
=head1 NAME
FileCache - keep more files open than the system permits
=head1 SYNOPSIS
use FileCache;
# or
use FileCache maxopen => 16;
cacheout $mode, $path;
# or
cacheout $path;
print $path @data;
$fh = cacheout $mode, $path;
# or
$fh = cacheout $path;
print $fh @data;
=head1 DESCRIPTION
The C<cacheout> function will make sure that there's a filehandle open
for reading or writing available as the pathname you give it. It
automatically closes and re-opens files if you exceed your system's
maximum number of file descriptors, or the suggested maximum I<maxopen>.
=over
=item cacheout EXPR
The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
on it's first use, and appending (C<<< '>>' >>>) thereafter.
Returns EXPR on success for convenience. You may neglect the
return value and manipulate EXPR as the filehandle directly if you prefer.
=item cacheout MODE, EXPR
The 2-argument form of cacheout will use the supplied mode for the initial
and subsequent openings. Most valid modes for 3-argument C<open> are supported
namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
C< '|-' > and C< '-|' >
To pass supplemental arguments to a program opened with C< '|-' > or C< '-|' >
append them to the command string as you would system EXPR.
Returns EXPR on success for convenience. You may neglect the
return value and manipulate EXPR as the filehandle directly if you prefer.
=back
=head1 CAVEATS
While it is permissible to C<close> a FileCache managed file,
do not do so if you are calling C<FileCache::cacheout> from a package other
than which it was imported, or with another module which overrides C<close>.
If you must, use C<FileCache::cacheout_close>.
Although FileCache can be used with piped opens ('-|' or '|-') doing so is
strongly discouraged. If FileCache finds it necessary to close and then reopen
a pipe, the command at the far end of the pipe will be reexecuted - the results
of performing IO on FileCache'd pipes is unlikely to be what you expect. The
ability to use FileCache on pipes may be removed in a future release.
FileCache does not store the current file offset if it finds it necessary to
close a file. When the file is reopened, the offset will be as specified by the
original C<open> file mode. This could be construed to be a bug.
=head1 BUGS
F<sys/param.h> lies with its C<NOFILE> define on some systems,
so you may have to set I<maxopen> yourself.
=cut
require 5.006;
use Carp;
use Config;
use strict;
no strict 'refs';
# These are not C<my> for legacy reasons.
# Previous versions requested the user set $cacheout_maxopen by hand.
# Some authors fiddled with %saw to overcome the clobber on initial open.
use vars qw(%saw $cacheout_maxopen);
$cacheout_maxopen = 16;
use base 'Exporter';
our @EXPORT = qw[cacheout cacheout_close];
my %isopen;
my $cacheout_seq = 0;
sub import {
my ($pkg,%args) = @_;
# Use Exporter. %args are for us, not Exporter.
# Make sure to up export_to_level, or we will import into ourselves,
# rather than our calling package;
__PACKAGE__->export_to_level(1);
Exporter::import( $pkg );
# Truth is okay here because setting maxopen to 0 would be bad
return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
# XXX This code is crazy. Why is it a one element foreach loop?
# Why is it using $param both as a filename and filehandle?
foreach my $param ( '/usr/include/sys/param.h' ){
if (open($param, '<', $param)) {
local ($_, $.);
while (<$param>) {
if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
$cacheout_maxopen = $1 - 4;
close($param);
last;
}
}
close $param;
}
}
$cacheout_maxopen ||= 16;
}
# Open in their package.
sub cacheout_open {
return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
}
# Close in their package.
sub cacheout_close {
# Short-circuit in case the filehandle disappeared
my $pkg = caller($_[1]||0);
fileno(*{$pkg . '::' . $_[0]}) &&
CORE::close(*{$pkg . '::' . $_[0]});
delete $isopen{$_[0]};
}
# But only this sub name is visible to them.
sub cacheout {
my($mode, $file, $class, $ret, $ref, $narg);
croak "Not enough arguments for cacheout" unless $narg = scalar @_;
croak "Too many arguments for cacheout" if $narg > 2;
($mode, $file) = @_;
($file, $mode) = ($mode, $file) if $narg == 1;
croak "Invalid mode for cacheout" if $mode &&
( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
# Mode changed?
if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[1] ){
&cacheout_close($file, 1);
}
if( $isopen{$file}) {
$ret = $file;
$isopen{$file}->[0]++;
}
else{
if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
$cacheout_seq = 0;
$isopen{$_}->[0] = $cacheout_seq++ for
splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
&cacheout_close($_, 1) for @lru;
}
unless( $ref ){
$mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
}
#XXX should we just return the value from cacheout_open, no croak?
$ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
$isopen{$file} = [++$cacheout_seq, $mode];
}
return $ret;
}
1;
--- NEW FILE: dotsh.pl ---
#
# @(#)dotsh.pl 03/19/94
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
#
# Author: Charles Collins
#
# Description:
# This routine takes a shell script and 'dots' it into the current perl
# environment. This makes it possible to use existing system scripts
# to alter environment variables on the fly.
#
# Usage:
# &dotsh ('ShellScript', 'DependentVariable(s)');
#
# where
#
# 'ShellScript' is the full name of the shell script to be dotted
#
# 'DependentVariable(s)' is an optional list of shell variables in the
# form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is
# dependent upon. These variables MUST be defined using shell syntax.
#
# Example:
# &dotsh ('/foo/bar', 'arg1');
# &dotsh ('/foo/bar');
# &dotsh ('/foo/bar arg1 ... argN');
#
sub dotsh {
local(@sh) = @_;
local($tmp,$key,$shell,$command,$args,$vars) = '';
local(*dotsh);
undef *dotsh;
$dotsh = shift(@sh);
@dotsh = split (/\s/, $dotsh);
$command = shift (@dotsh);
$args = join (" ", @dotsh);
$vars = join ("\n", @sh);
open (_SH_ENV, "$command") || die "Could not open $dotsh!\n";
chop($_ = <_SH_ENV>);
$shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/);
close (_SH_ENV);
if (!$shell) {
if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/bash$|\/csh$/) {
$shell = "$ENV{'SHELL'} -c";
} else {
print "SHELL not recognized!\nUsing /bin/sh...\n";
$shell = "/bin/sh -c";
}
}
if (length($vars) > 0) {
open (_SH_ENV, "$shell \"$vars && . $command $args && set \" |") || die;
} else {
open (_SH_ENV, "$shell \". $command $args && set \" |") || die;
}
while (<_SH_ENV>) {
chop;
m/^([^=]*)=(.*)/s;
$ENV{$1} = $2;
}
close (_SH_ENV);
foreach $key (keys(%ENV)) {
$tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
}
eval $tmp;
}
1;
--- NEW FILE: bytes.pm ---
package bytes;
our $VERSION = '1.02';
$bytes::hint_bits = 0x00000008;
sub import {
$^H |= $bytes::hint_bits;
}
sub unimport {
$^H &= ~$bytes::hint_bits;
}
sub AUTOLOAD {
require "bytes_heavy.pl";
goto &$AUTOLOAD if defined &$AUTOLOAD;
require Carp;
Carp::croak("Undefined subroutine $AUTOLOAD called");
}
sub length ($);
sub chr ($);
sub ord ($);
sub substr ($$;$$);
sub index ($$;$);
sub rindex ($$;$);
1;
__END__
=head1 NAME
bytes - Perl pragma to force byte semantics rather than character semantics
=head1 SYNOPSIS
use bytes;
... chr(...); # or bytes::chr
... index(...); # or bytes::index
... length(...); # or bytes::length
... ord(...); # or bytes::ord
... rindex(...); # or bytes::rindex
... substr(...); # or bytes::substr
no bytes;
=head1 DESCRIPTION
The C<use bytes> pragma disables character semantics for the rest of the
lexical scope in which it appears. C<no bytes> can be used to reverse
the effect of C<use bytes> within the current lexical scope.
Perl normally assumes character semantics in the presence of character
data (i.e. data that has come from a source that has been marked as
being of a particular character encoding). When C<use bytes> is in
effect, the encoding is temporarily ignored, and each string is treated
as a series of bytes.
As an example, when Perl sees C<$x = chr(400)>, it encodes the character
in UTF-8 and stores it in $x. Then it is marked as character data, so,
for instance, C<length $x> returns C<1>. However, in the scope of the
C<bytes> pragma, $x is treated as a series of bytes - the bytes that make
up the UTF8 encoding - and C<length $x> returns C<2>:
$x = chr(400);
print "Length is ", length $x, "\n"; # "Length is 1"
printf "Contents are %vd\n", $x; # "Contents are 400"
{
use bytes; # or "require bytes; bytes::length()"
print "Length is ", length $x, "\n"; # "Length is 2"
printf "Contents are %vd\n", $x; # "Contents are 198.144"
}
chr(), ord(), substr(), index() and rindex() behave similarly.
For more on the implications and differences between character
semantics and byte semantics, see L<perluniintro> and L<perlunicode>.
=head1 LIMITATIONS
bytes::substr() does not work as an lvalue().
=head1 SEE ALSO
L<perluniintro>, L<perlunicode>, L<utf8>
=cut
--- NEW FILE: Shell.pm ---
package Shell;
use 5.006_001;
use strict;
use warnings;
use File::Spec::Functions;
our($capture_stderr, $raw, $VERSION, $AUTOLOAD);
$VERSION = '0.6';
sub new { bless \my $foo, shift }
sub DESTROY { }
sub import {
my $self = shift;
my ($callpack, $callfile, $callline) = caller;
my @EXPORT;
if (@_) {
@EXPORT = @_;
} else {
@EXPORT = 'AUTOLOAD';
}
foreach my $sym (@EXPORT) {
no strict 'refs';
*{"${callpack}::$sym"} = \&{"Shell::$sym"};
}
}
sub AUTOLOAD {
shift if ref $_[0] && $_[0]->isa( 'Shell' );
my $cmd = $AUTOLOAD;
$cmd =~ s/^.*:://;
my $null = File::Spec::Functions::devnull();
$Shell::capture_stderr ||= 0;
eval <<"*END*";
sub $AUTOLOAD {
shift if ref \$_[0] && \$_[0]->isa( 'Shell' );
if (\@_ < 1) {
\$Shell::capture_stderr == 1 ? `$cmd 2>&1` :
\$Shell::capture_stderr == -1 ? `$cmd 2>$null` :
`$cmd`;
} elsif ('$^O' eq 'os2') {
local(\*SAVEOUT, \*READ, \*WRITE);
open SAVEOUT, '>&STDOUT' or die;
pipe READ, WRITE or die;
open STDOUT, '>&WRITE' or die;
close WRITE;
my \$pid = system(1, '$cmd', \@_);
die "Can't execute $cmd: \$!\\n" if \$pid < 0;
open STDOUT, '>&SAVEOUT' or die;
close SAVEOUT;
if (wantarray) {
my \@ret = <READ>;
close READ;
waitpid \$pid, 0;
\@ret;
} else {
local(\$/) = undef;
my \$ret = <READ>;
close READ;
waitpid \$pid, 0;
\$ret;
}
} else {
my \$a;
my \@arr = \@_;
unless( \$Shell::raw ){
if ('$^O' eq 'MSWin32') {
# XXX this special-casing should not be needed
# if we do quoting right on Windows. :-(
#
# First, escape all quotes. Cover the case where we
# want to pass along a quote preceded by a backslash
# (i.e., C<"param \\""" end">).
# Ugly, yup? You know, windoze.
# Enclose in quotes only the parameters that need it:
# try this: c:\> dir "/w"
# and this: c:\> dir /w
for (\@arr) {
s/"/\\\\"/g;
s/\\\\\\\\"/\\\\\\\\"""/g;
\$_ = qq["\$_"] if /\\s/;
}
} else {
for (\@arr) {
s/(['\\\\])/\\\\\$1/g;
\$_ = \$_;
}
}
}
push \@arr, '2>&1' if \$Shell::capture_stderr == 1;
push \@arr, '2>$null' if \$Shell::capture_stderr == -1;
open(SUBPROC, join(' ', '$cmd', \@arr, '|'))
or die "Can't exec $cmd: \$!\\n";
if (wantarray) {
my \@ret = <SUBPROC>;
close SUBPROC; # XXX Oughta use a destructor.
\@ret;
} else {
local(\$/) = undef;
my \$ret = <SUBPROC>;
close SUBPROC;
\$ret;
}
}
}
*END*
die "$@\n" if $@;
goto &$AUTOLOAD;
}
1;
__END__
=head1 NAME
Shell - run shell commands transparently within perl
=head1 SYNOPSIS
use Shell qw(cat ps cp);
$passwd = cat('</etc/passwd');
@pslines = ps('-ww'),
cp("/etc/passwd", "/tmp/passwd");
# object oriented
my $sh = Shell->new;
print $sh->ls('-l');
=head1 DESCRIPTION
=head2 Caveats
This package is included as a show case, illustrating a few Perl features.
It shouldn't be used for production programs. Although it does provide a
simple interface for obtaining the standard output of arbitrary commands,
there may be better ways of achieving what you need.
Running shell commands while obtaining standard output can be done with the
C<qx/STRING/> operator, or by calling C<open> with a filename expression that
ends with C<|>, giving you the option to process one line at a time.
If you don't need to process standard output at all, you might use C<system>
(in preference of doing a print with the collected standard output).
Since Shell.pm and all of the aforementioned techniques use your system's
shell to call some local command, none of them is portable across different
systems. Note, however, that there are several built in functions and
library packages providing portable implementations of functions operating
on files, such as: C<glob>, C<link> and C<unlink>, C<mkdir> and C<rmdir>,
C<rename>, C<File::Compare>, C<File::Copy>, C<File::Find> etc.
Using Shell.pm while importing C<foo> creates a subroutine C<foo> in the
namespace of the importing package. Calling C<foo> with arguments C<arg1>,
C<arg2>,... results in a shell command C<foo arg1 arg2...>, where the
function name and the arguments are joined with a blank. (See the subsection
on Escaping magic characters.) Since the result is essentially a command
line to be passed to the shell, your notion of arguments to the Perl
function is not necessarily identical to what the shell treats as a
command line token, to be passed as an individual argument to the program.
Furthermore, note that this implies that C<foo> is callable by file name
only, which frequently depends on the setting of the program's environment.
Creating a Shell object gives you the opportunity to call any command
in the usual OO notation without requiring you to announce it in the
C<use Shell> statement. Don't assume any additional semantics being
associated with a Shell object: in no way is it similar to a shell
process with its environment or current working directory or any
other setting.
=head2 Escaping Magic Characters
It is, in general, impossible to take care of quoting the shell's
magic characters. For some obscure reason, however, Shell.pm quotes
apostrophes (C<'>) and backslashes (C<\>) on UNIX, and spaces and
quotes (C<">) on Windows.
=head2 Configuration
If you set $Shell::capture_stderr to true, the module will attempt to
capture the standard error output of the process as well. This is
done by adding C<2E<gt>&1> to the command line, so don't try this on
a system not supporting this redirection.
If you set $Shell::raw to true no quoting whatsoever is done.
=head1 BUGS
Quoting should be off by default.
It isn't possible to call shell built in commands, but it can be
done by using a workaround, e.g. shell( '-c', 'set' ).
Capturing standard error does not work on some systems (e.g. VMS).
=head1 AUTHOR
Date: Thu, 22 Sep 94 16:18:16 -0700
Message-Id: <9409222318.AA17072 at scalpel.netlabs.com>
To: perl5-porters at isu.edu
From: Larry Wall <lwall at scalpel.netlabs.com>
Subject: a new module I just wrote
Here's one that'll whack your mind a little out.
#!/usr/bin/perl
use Shell;
$foo = echo("howdy", "<funny>", "world");
print $foo;
$passwd = cat("</etc/passwd");
print $passwd;
sub ps;
print ps -ww;
cp("/etc/passwd", "/etc/passwd.orig");
That's maybe too gonzo. It actually exports an AUTOLOAD to the current
package (and uncovered a bug in Beta 3, by the way). Maybe the usual
usage should be
use Shell qw(echo cat ps cp);
Larry Wall
Changes by Jenda at Krynicky.cz and Dave Cottle <d.cottle at csc.canterbury.ac.nz>.
Changes for OO syntax and bug fixes by Casey West <casey at geeknest.com>.
C<$Shell::raw> and pod rewrite by Wolfgang Laun.
=cut
--- NEW FILE: Symbol.pm ---
package Symbol;
=head1 NAME
Symbol - manipulate Perl symbols and their names
=head1 SYNOPSIS
use Symbol;
$sym = gensym;
open($sym, "filename");
$_ = <$sym>;
# etc.
ungensym $sym; # no effect
# replace *FOO{IO} handle but not $FOO, %FOO, etc.
*FOO = geniosym;
print qualify("x"), "\n"; # "Test::x"
print qualify("x", "FOO"), "\n" # "FOO::x"
print qualify("BAR::x"), "\n"; # "BAR::x"
print qualify("BAR::x", "FOO"), "\n"; # "BAR::x"
print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global)
print qualify(\*x), "\n"; # returns \*x
print qualify(\*x, "FOO"), "\n"; # returns \*x
use strict refs;
print { qualify_to_ref $fh } "foo!\n";
$ref = qualify_to_ref $name, $pkg;
use Symbol qw(delete_package);
delete_package('Foo::Bar');
print "deleted\n" unless exists $Foo::{'Bar::'};
=head1 DESCRIPTION
C<Symbol::gensym> creates an anonymous glob and returns a reference
to it. Such a glob reference can be used as a file or directory
handle.
For backward compatibility with older implementations that didn't
support anonymous globs, C<Symbol::ungensym> is also provided.
But it doesn't do anything.
C<Symbol::geniosym> creates an anonymous IO handle. This can be
assigned into an existing glob without affecting the non-IO portions
of the glob.
C<Symbol::qualify> turns unqualified symbol names into qualified
variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
second parameter, C<qualify> uses it as the default package;
otherwise, it uses the package of its caller. Regardless, global
variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with
"main::".
Qualification applies only to symbol names (strings). References are
left unchanged under the assumption that they are glob references,
which are qualified by their nature.
C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
returns a glob ref rather than a symbol name, so you can use the result
even if C<use strict 'refs'> is in effect.
C<Symbol::delete_package> wipes out a whole package namespace. Note
this routine is not exported by default--you may want to import it
explicitly.
=head1 BUGS
C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that
lives in the specified package. Since perl, for performance reasons, does not
perform a symbol table lookup each time a function is called or a global
variable is accessed, some code that has already been loaded and that makes use
of symbols in package C<Foo> may stop working after you delete C<Foo>, even if
you reload the C<Foo> module afterwards.
=cut
BEGIN { require 5.005; }
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
@EXPORT_OK = qw(delete_package geniosym);
$VERSION = '1.06';
my $genpkg = "Symbol::";
my $genseq = 0;
my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
#
# Note that we never _copy_ the glob; we just make a ref to it.
# If we did copy it, then SVf_FAKE would be set on the copy, and
# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work.
#
sub gensym () {
my $name = "GEN" . $genseq++;
my $ref = \*{$genpkg . $name};
delete $$genpkg{$name};
$ref;
}
sub geniosym () {
my $sym = gensym();
# force the IO slot to be filled
select(select $sym);
*$sym{IO};
}
sub ungensym ($) {}
sub qualify ($;$) {
my ($name) = @_;
if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
my $pkg;
# Global names: special character, "^xyz", or other.
if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
# RGS 2001-11-05 : translate leading ^X to control-char
$name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
$pkg = "main";
}
else {
$pkg = (@_ > 1) ? $_[1] : caller;
}
$name = $pkg . "::" . $name;
}
$name;
}
sub qualify_to_ref ($;$) {
return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
}
#
# of Safe.pm lineage
#
sub delete_package ($) {
my $pkg = shift;
# expand to full symbol table name if needed
unless ($pkg =~ /^main::.*::$/) {
$pkg = "main$pkg" if $pkg =~ /^::/;
$pkg = "main::$pkg" unless $pkg =~ /^main::/;
$pkg .= '::' unless $pkg =~ /::$/;
}
my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
my $stem_symtab = *{$stem}{HASH};
return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
# free all the symbols in the package
my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
foreach my $name (keys %$leaf_symtab) {
undef *{$pkg . $name};
}
# delete the symbol table
%$leaf_symtab = ();
delete $stem_symtab->{$leaf};
}
1;
--- NEW FILE: subs.pm ---
package subs;
our $VERSION = '1.00';
=head1 NAME
subs - Perl pragma to predeclare sub names
=head1 SYNOPSIS
use subs qw(frob);
frob 3..10;
=head1 DESCRIPTION
This will predeclare all the subroutine whose names are
in the list, allowing you to use them without parentheses
even before they're declared.
Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and
C<use subs> declarations are not BLOCK-scoped. They are thus effective
for the entire file in which they appear. You may not rescind such
declarations with C<no vars> or C<no subs>.
See L<perlmodlib/Pragmatic Modules> and L<strict/strict subs>.
=cut
require 5.000;
sub import {
my $callpack = caller;
my $pack = shift;
my @imports = @_;
foreach $sym (@imports) {
*{"${callpack}::$sym"} = \&{"${callpack}::$sym"};
}
};
1;
--- NEW FILE: Exporter.pm ---
package Exporter;
require 5.006;
# Be lean.
#use strict;
#no strict 'refs';
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
our $VERSION = '5.58';
our (%Cache);
$Carp::Internal{Exporter} = 1;
sub as_heavy {
require Exporter::Heavy;
# Unfortunately, this does not work if the caller is aliased as *name = \&foo
# Thus the need to create a lot of identical subroutines
my $c = (caller(1))[3];
$c =~ s/.*:://;
\&{"Exporter::Heavy::heavy_$c"};
}
sub export {
goto &{as_heavy()};
}
sub import {
my $pkg = shift;
my $callpkg = caller($ExportLevel);
if ($pkg eq "Exporter" and @_ and $_[0] eq "import") {
*{$callpkg."::import"} = \&import;
return;
}
# We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"});
return export $pkg, $callpkg, @_
if $Verbose or $Debug or @$fail > 1;
my $export_cache = ($Cache{$pkg} ||= {});
my $args = @_ or @_ = @$exports;
local $_;
if ($args and not %$export_cache) {
s/^&//, $export_cache->{$_} = 1
foreach (@$exports, @{"$pkg\::EXPORT_OK"});
}
my $heavy;
# Try very hard not to use {} and hence have to enter scope on the foreach
# We bomb out of the loop with last as soon as heavy is set.
if ($args or $fail) {
($heavy = (/\W/ or $args and not exists $export_cache->{$_}
or @$fail and $_ eq $fail->[0])) and last
foreach (@_);
} else {
($heavy = /\W/) and last
foreach (@_);
}
return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy;
local $SIG{__WARN__} =
sub {require Carp; &Carp::carp};
# shortcut for the common case of no type character
*{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_;
}
# Default methods
sub export_fail {
my $self = shift;
@_;
}
# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as
# *name = \&foo. Thus the need to create a lot of identical subroutines
# Otherwise we could have aliased them to export().
sub export_to_level {
goto &{as_heavy()};
}
sub export_tags {
goto &{as_heavy()};
}
sub export_ok_tags {
goto &{as_heavy()};
}
sub require_version {
goto &{as_heavy()};
}
1;
__END__
=head1 NAME
Exporter - Implements default import method for modules
=head1 SYNOPSIS
In module YourModule.pm:
package YourModule;
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
or
package YourModule;
use Exporter 'import'; # gives you Exporter's import() method directly
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
In other files which wish to use YourModule:
use ModuleName qw(frobnicate); # import listed symbols
frobnicate ($left, $right) # calls YourModule::frobnicate
=head1 DESCRIPTION
The Exporter module implements an C<import> method which allows a module
to export functions and variables to its users' namespaces. Many modules
use Exporter rather than implementing their own C<import> method because
Exporter provides a highly flexible interface, with an implementation optimised
for the common case.
Perl automatically calls the C<import> method when processing a
C<use> statement for a module. Modules and C<use> are documented
in L<perlfunc> and L<perlmod>. Understanding the concept of
modules and how the C<use> statement operates is important to
understanding the Exporter.
=head2 How to Export
The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
symbols that are going to be exported into the users name space by
default, or which they can request to be exported, respectively. The
symbols can represent functions, scalars, arrays, hashes, or typeglobs.
The symbols must be given by full name with the exception that the
ampersand in front of a function is optional, e.g.
@EXPORT = qw(afunc $scalar @array); # afunc is a function
@EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc
If you are only exporting function names it is recommended to omit the
ampersand, as the implementation is faster this way.
=head2 Selecting What To Export
Do B<not> export method names!
Do B<not> export anything else by default without a good reason!
Exports pollute the namespace of the module user. If you must export
try to use @EXPORT_OK in preference to @EXPORT and avoid short or
common symbol names to reduce the risk of name clashes.
Generally anything not exported is still accessible from outside the
module using the ModuleName::item_name (or $blessed_ref-E<gt>method)
syntax. By convention you can use a leading underscore on names to
informally indicate that they are 'internal' and not for public use.
(It is actually possible to get private functions by saying:
my $subref = sub { ... };
$subref->(@args); # Call it as a function
$obj->$subref(@args); # Use it as a method
However if you use them for methods it is up to you to figure out
how to make inheritance work.)
As a general rule, if the module is trying to be object oriented
then export nothing. If it's just a collection of functions then
@EXPORT_OK anything but use @EXPORT with caution. For function and
method names use barewords in preference to names prefixed with
ampersands for the export lists.
Other module design guidelines can be found in L<perlmod>.
=head2 How to Import
In other files which wish to use your module there are three basic ways for
them to load your module and import its symbols:
=over 4
=item C<use ModuleName;>
This imports all the symbols from ModuleName's @EXPORT into the namespace
of the C<use> statement.
=item C<use ModuleName ();>
This causes perl to load your module but does not import any symbols.
=item C<use ModuleName qw(...);>
This imports only the symbols listed by the caller into their namespace.
All listed symbols must be in your @EXPORT or @EXPORT_OK, else an error
occurs. The advanced export features of Exporter are accessed like this,
but with list entries that are syntactically distinct from symbol names.
=back
Unless you want to use its advanced features, this is probably all you
need to know to use Exporter.
=head1 Advanced features
=head2 Specialised Import Lists
If any of the entries in an import list begins with !, : or / then
the list is treated as a series of specifications which either add to
or delete from the list of names to import. They are processed left to
right. Specifications are in the form:
[!]name This name only
[!]:DEFAULT All names in @EXPORT
[!]:tag All names in $EXPORT_TAGS{tag} anonymous list
[!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
A leading ! indicates that matching names should be deleted from the
list of names to import. If the first specification is a deletion it
is treated as though preceded by :DEFAULT. If you just want to import
extra names in addition to the default set you will still need to
include :DEFAULT explicitly.
e.g., Module.pm defines:
@EXPORT = qw(A1 A2 A3 A4 A5);
@EXPORT_OK = qw(B1 B2 B3 B4 B5);
%EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
Note that you cannot use tags in @EXPORT or @EXPORT_OK.
Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
An application using Module can say something like:
use Module qw(:DEFAULT :T2 !B3 A3);
Other examples include:
use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
Remember that most patterns (using //) will need to be anchored
with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
specifications are being processed and what is actually being imported
into modules.
=head2 Exporting without using Exporter's import method
Exporter has a special method, 'export_to_level' which is used in situations
where you can't directly call Exporter's import method. The export_to_level
method looks like:
MyPackage->export_to_level($where_to_export, $package, @what_to_export);
where $where_to_export is an integer telling how far up the calling stack
to export your symbols, and @what_to_export is an array telling what
symbols *to* export (usually this is @_). The $package argument is
currently unused.
For example, suppose that you have a module, A, which already has an
import function:
package A;
@ISA = qw(Exporter);
@EXPORT_OK = qw ($b);
sub import
{
$A::b = 1; # not a very useful import method
}
and you want to Export symbol $A::b back to the module that called
package A. Since Exporter relies on the import method to work, via
inheritance, as it stands Exporter::import() will never get called.
Instead, say the following:
package A;
@ISA = qw(Exporter);
@EXPORT_OK = qw ($b);
sub import
{
$A::b = 1;
A->export_to_level(1, @_);
}
This will export the symbols one level 'above' the current package - ie: to
the program or module that used package A.
Note: Be careful not to modify C<@_> at all before you call export_to_level
- or people using your package will get very unexplained results!
=head2 Exporting without inheriting from Exporter
By including Exporter in your @ISA you inherit an Exporter's import() method
but you also inherit several other helper methods which you probably don't
want. To avoid this you can do
package YourModule;
use Exporter qw( import );
which will export Exporter's own import() method into YourModule.
Everything will work as before but you won't need to include Exporter in
@YourModule::ISA.
=head2 Module Version Checking
The Exporter module will convert an attempt to import a number from a
module into a call to $module_name-E<gt>require_version($value). This can
be used to validate that the version of the module being used is
greater than or equal to the required version.
The Exporter module supplies a default require_version method which
checks the value of $VERSION in the exporting module.
Since the default require_version method treats the $VERSION number as
a simple numeric value it will regard version 1.10 as lower than
1.9. For this reason it is strongly recommended that you use numbers
with at least two decimal places, e.g., 1.09.
=head2 Managing Unknown Symbols
In some situations you may want to prevent certain symbols from being
exported. Typically this applies to extensions which have functions
or constants that may not exist on some systems.
The names of any symbols that cannot be exported should be listed
in the C<@EXPORT_FAIL> array.
If a module attempts to import any of these symbols the Exporter
will give the module an opportunity to handle the situation before
generating an error. The Exporter will call an export_fail method
with a list of the failed symbols:
@failed_symbols = $module_name->export_fail(@failed_symbols);
If the export_fail method returns an empty list then no error is
recorded and all the requested symbols are exported. If the returned
list is not empty then an error is generated for each symbol and the
export fails. The Exporter provides a default export_fail method which
simply returns the list unchanged.
Uses for the export_fail method include giving better error messages
for some symbols and performing lazy architectural checks (put more
symbols into @EXPORT_FAIL by default and then take them out if someone
actually tries to use them and an expensive check shows that they are
usable on that platform).
=head2 Tag Handling Utility Functions
Since the symbols listed within %EXPORT_TAGS must also appear in either
@EXPORT or @EXPORT_OK, two utility functions are provided which allow
you to easily add tagged sets of symbols to @EXPORT or @EXPORT_OK:
%EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT
Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK
Any names which are not tags are added to @EXPORT or @EXPORT_OK
unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
names being silently added to @EXPORT or @EXPORT_OK. Future versions
may make this a fatal error.
=head2 Generating combined tags
If several symbol categories exist in %EXPORT_TAGS, it's usually
useful to create the utility ":all" to simplify "use" statements.
The simplest way to do this is:
%EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
# add all the other ":class" tags to the ":all" class,
# deleting duplicates
{
my %seen;
push @{$EXPORT_TAGS{all}},
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
}
CGI.pm creates an ":all" tag which contains some (but not really
all) of its categories. That could be done with one small
change:
# add some of the other ":class" tags to the ":all" class,
# deleting duplicates
{
my %seen;
push @{$EXPORT_TAGS{all}},
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}}
foreach qw/html2 html3 netscape form cgi internal/;
}
Note that the tag names in %EXPORT_TAGS don't have the leading ':'.
=head2 C<AUTOLOAD>ed Constants
Many modules make use of C<AUTOLOAD>ing for constant subroutines to
avoid having to compile and waste memory on rarely used values (see
L<perlsub> for details on constant subroutines). Calls to such
constant subroutines are not optimized away at compile time because
they can't be checked at compile time for constancy.
Even if a prototype is available at compile time, the body of the
subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
examine both the C<()> prototype and the body of a subroutine at
compile time to detect that it can safely replace calls to that
subroutine with the constant value.
A workaround for this is to call the constants once in a C<BEGIN> block:
package My ;
use Socket ;
foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
BEGIN { SO_LINGER }
foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
SO_LINGER is encountered later in C<My> package.
If you are writing a package that C<AUTOLOAD>s, consider forcing
an C<AUTOLOAD> for any constants explicitly imported by other packages
or which are usually used when your package is C<use>d.
=cut
--- NEW FILE: if.pm ---
package if;
$VERSION = '0.05';
sub work {
my $method = shift() ? 'import' : 'unimport';
die "Too few arguments to `use if' (some code returning an empty list in list context?)"
unless @_ >= 2;
return unless shift; # CONDITION
my $p = $_[0]; # PACKAGE
(my $file = "$p.pm") =~ s!::!/!g;
require $file; # Works even if $_[0] is a keyword (like open)
my $m = $p->can($method);
goto &$m if $m;
}
sub import { shift; unshift @_, 1; goto &work }
sub unimport { shift; unshift @_, 0; goto &work }
1;
__END__
=head1 NAME
if - C<use> a Perl module if a condition holds
=head1 SYNOPSIS
use if CONDITION, MODULE => ARGUMENTS;
=head1 DESCRIPTION
The construct
use if CONDITION, MODULE => ARGUMENTS;
has no effect unless C<CONDITION> is true. In this case the effect is
the same as of
use MODULE ARGUMENTS;
Above C<< => >> provides necessary quoting of C<MODULE>. If not used (e.g.,
no ARGUMENTS to give), you'd better quote C<MODULE> yourselves.
=head1 BUGS
The current implementation does not allow specification of the
required version of the module.
=head1 AUTHOR
Ilya Zakharevich L<mailto:perl-module-if at ilyaz.org>.
=cut
--- NEW FILE: tainted.pl ---
# This subroutine returns true if its argument is tainted, false otherwise.
sub tainted {
local($@);
eval { kill 0 * $_[0] };
$@ =~ /^Insecure/;
}
1;
--- NEW FILE: Config.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require "./test.pl";
plan ('no_plan');
use_ok('Config');
}
use strict;
# Some (safe?) bets.
ok(keys %Config > 500, "Config has more than 500 entries");
my ($first) = Config::config_sh() =~ /^(\S+)=/m;
die "Can't find first entry in Config::config_sh()" unless defined $first;
print "# First entry is '$first'\n";
# It happens that the we know what the first key should be. This is somewhat
# cheating, but there was briefly a bug where the key got a bonus newline.
my ($first_each) = each %Config;
is($first_each, $first, "First key from each is correct");
ok(exists($Config{$first_each}), "First key exists");
ok(!exists($Config{"\n$first"}),
"Check that first key with prepended newline isn't falsely existing");
is($Config{PERL_REVISION}, 5, "PERL_REVISION is 5");
# Check that old config variable names are aliased to their new ones.
my %grandfathers = ( PERL_VERSION => 'PATCHLEVEL',
PERL_SUBVERSION => 'SUBVERSION',
PERL_CONFIG_SH => 'CONFIG'
);
while( my($new, $old) = each %grandfathers ) {
isnt($Config{$new}, undef, "$new is defined");
is($Config{$new}, $Config{$old}, "$new is aliased to $old");
}
ok( exists $Config{cc}, "has cc");
ok( exists $Config{ccflags}, "has ccflags");
ok(!exists $Config{python}, "has no python");
ok( exists $Config{d_fork}, "has d_fork");
ok(!exists $Config{d_bork}, "has no d_bork");
like($Config{ivsize}, qr/^(4|8)$/, "ivsize is 4 or 8 (it is $Config{ivsize})");
# byteorder is virtual, but it has rules.
like($Config{byteorder}, qr/^(1234|4321|12345678|87654321)$/,
"byteorder is 1234 or 4321 or 12345678 or 87654321 "
. "(it is $Config{byteorder})");
is(length $Config{byteorder}, $Config{ivsize},
"byteorder is as long as ivsize (which is $Config{ivsize})");
# ccflags_nolargefiles is virtual, too.
ok(exists $Config{ccflags_nolargefiles}, "has ccflags_nolargefiles");
# Utility functions.
{
# make sure we can export what we say we can export.
package Foo;
my @exports = qw(myconfig config_sh config_vars config_re);
Config->import(@exports);
foreach my $func (@exports) {
::ok( __PACKAGE__->can($func), "$func exported" );
}
}
like(Config::myconfig(), qr/osname=\Q$Config{osname}\E/, "myconfig");
like(Config::config_sh(), qr/osname='\Q$Config{osname}\E'/, "config_sh");
like(Config::config_sh(), qr/byteorder='[1-8]+'/,
"config_sh has a valid byteorder");
foreach my $line (Config::config_re('c.*')) {
like($line, qr/^c.*?=.*$/, 'config_re' );
}
my $out = tie *STDOUT, 'FakeOut';
Config::config_vars('cc'); # non-regex test of essential cfg-var
my $out1 = $$out;
$out->clear;
Config::config_vars('d_bork'); # non-regex, non-existent cfg-var
my $out2 = $$out;
$out->clear;
Config::config_vars('PERL_API_.*'); # regex, tagged multi-line answer
my $out3 = $$out;
$out->clear;
Config::config_vars('PERL_API_.*:'); # regex, tagged single-line answer
my $out4 = $$out;
$out->clear;
Config::config_vars(':PERL_API_.*:'); # regex, non-tagged single-line answer
my $out5 = $$out;
$out->clear;
Config::config_vars(':PERL_API_.*'); # regex, non-tagged multi-line answer
my $out6 = $$out;
$out->clear;
Config::config_vars('PERL_API_REVISION.*:'); # regex, tagged
my $out7 = $$out;
$out->clear;
# regex, non-tagged multi-line answer
Config::config_vars(':PERL_API_REVISION.*');
my $out8 = $$out;
$out->clear;
Config::config_vars('PERL_EXPENSIVE_.*:'); # non-matching regex
my $out9 = $$out;
$out->clear;
Config::config_vars('?flags'); # bogus regex, no explicit warning !
my $out10 = $$out;
$out->clear;
undef $out;
untie *STDOUT;
like($out1, qr/^cc='\Q$Config{cc}\E';/, "found config_var cc");
like($out2, qr/^d_bork='UNKNOWN';/, "config_var d_bork is UNKNOWN");
# test for leading, trailing colon effects
# Split in scalar context it deprecated, and will warn.
my @tmp;
is(scalar (@tmp = split(/;\n/, $out3)), 3, "3 lines found");
is(scalar (@tmp = split(/;\n/, $out6)), 3, "3 lines found");
is($out4 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out4");
is($out5 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out5");
is(scalar (@tmp = split(/=/, $out3)), 4, "found 'tag='");
is(scalar (@tmp = split(/=/, $out4)), 4, "found 'tag='");
my @api;
my @rev = @Config{qw(PERL_API_REVISION PERL_API_VERSION PERL_API_SUBVERSION)};
print ("# test tagged responses, multi-line and single-line\n");
foreach my $api ($out3, $out4) {
@api = $api =~ /PERL_API_(\w+)=(.*?)(?:;\n|\s)/mg;
is($api[0], "REVISION", "REVISION tag");
is($api[4], "VERSION", "VERSION tag");
is($api[2], "SUBVERSION", "SUBVERSION tag");
is($api[1], "'$rev[0]'", "REVISION is $rev[0]");
is($api[5], "'$rev[1]'", "VERSION is $rev[1]");
is($api[3], "'$rev[2]'", "SUBVERSION is $rev[2]");
}
print("# test non-tagged responses, multi-line and single-line\n");
foreach my $api ($out5, $out6) {
@api = split /(?: |;\n)/, $api;
is($api[0], "'$rev[0]'", "revision is $rev[0]");
is($api[2], "'$rev[1]'", "version is $rev[1]");
is($api[1], "'$rev[2]'", "subversion is $rev[2]");
}
# compare to each other, the outputs for trailing, leading colon
$out7 =~ s/ $//;
is("$out7;\n", "PERL_API_REVISION=$out8", "got expected diffs");
like($out9, qr/\bnot\s+found\b/, "$out9 - perl is FREE !");
like($out10, qr/\bnot\s+found\b/, "config_vars with invalid regexp");
# Read-only.
undef $@;
eval { $Config{d_bork} = 'borkbork' };
like($@, qr/Config is read-only/, "no STORE");
ok(!exists $Config{d_bork}, "still no d_bork");
undef $@;
eval { delete $Config{d_fork} };
like($@, qr/Config is read-only/, "no DELETE");
ok( exists $Config{d_fork}, "still d_fork");
undef $@;
eval { %Config = () };
like($@, qr/Config is read-only/, "no CLEAR");
ok( exists $Config{d_fork}, "still d_fork");
{
package FakeOut;
sub TIEHANDLE {
bless(\(my $text), $_[0]);
}
sub clear {
${ $_[0] } = '';
}
sub PRINT {
my $self = shift;
$$self .= join('', @_);
}
}
# Signal-related variables
# (this is actually a regression test for Configure.)
is($Config{sig_num_init} =~ tr/,/,/, $Config{sig_size}, "sig_num_init size");
is($Config{sig_name_init} =~ tr/,/,/, $Config{sig_size}, "sig_name_init size");
# Test the troublesome virtual stuff
my @virtual = qw(byteorder ccflags_nolargefiles ldflags_nolargefiles
libs_nolargefiles libswanted_nolargefiles);
# Also test that the first entry in config.sh is found correctly. There was
# special casing code for this
foreach my $pain ($first, @virtual) {
# No config var is named with anything that is a regexp metachar
ok(exists $Config{$pain}, "\$config('$pain') exists");
my @result = $Config{$pain};
is (scalar @result, 1, "single result for \$config('$pain')");
@result = Config::config_re($pain);
is (scalar @result, 1, "single result for config_re('$pain')");
like ($result[0], qr/^$pain=(['"])\Q$Config{$pain}\E\1$/, # grr '
"which is the expected result for $pain");
}
# Check that config entries appear correctly in @INC
# TestInit.pm has probably already messed with our @INC
# This little bit of evil is to avoid a @ in the program, in case it confuses
# shell 1 liners. Perl 1 rules.
my ($path, $ver, @orig_inc)
= split /\n/,
runperl (nolib=>1,
prog=>'print qq{$^X\n$]\n}; print qq{$_\n} while $_ = shift INC');
die "This perl is $] at $^X; other perl is $ver (at $path) "
. '- failed to find this perl' unless $] eq $ver;
my %orig_inc;
@orig_inc{@orig_inc} = ();
my $failed;
# This is the order that directories are pushed onto @INC in perl.c:
foreach my $lib (qw(applibexp archlibexp privlibexp sitearchexp sitelibexp
vendorarchexp vendorlibexp vendorlib_stem)) {
my $dir = $Config{$lib};
SKIP: {
skip "lib $lib not in \@INC on Win32" if $^O eq 'MSWin32';
skip "lib $lib not defined" unless defined $dir;
skip "lib $lib not set" unless length $dir;
# So we expect to find it in @INC
ok (exists $orig_inc{$dir}, "Expect $lib '$dir' to be in \@INC")
or $failed++;
}
}
_diag ('@INC is:', @orig_inc) if $failed;
--- NEW FILE: open3.pl ---
# This is a compatibility interface to IPC::Open3. New programs should
# do
#
# use IPC::Open3;
#
# instead of
#
# require 'open3.pl';
package main;
use IPC::Open3 'open3';
1
--- NEW FILE: fastcwd.pl ---
# By John Bazik
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
# Suggested alternative: Cwd
#
# Usage: $cwd = &fastcwd;
#
# This is a faster version of getcwd. It's also more dangerous because
# you might chdir out of a directory that you can't chdir back into.
sub fastcwd {
local($odev, $oino, $cdev, $cino, $tdev, $tino);
local(@path, $path);
local(*DIR);
($cdev, $cino) = stat('.');
for (;;) {
($odev, $oino) = ($cdev, $cino);
chdir('..');
($cdev, $cino) = stat('.');
last if $odev == $cdev && $oino == $cino;
opendir(DIR, '.');
for (;;) {
$_ = readdir(DIR);
next if $_ eq '.';
next if $_ eq '..';
last unless $_;
($tdev, $tino) = lstat($_);
last unless $tdev != $odev || $tino != $oino;
}
closedir(DIR);
unshift(@path, $_);
}
chdir($path = '/' . join('/', @path));
$path;
}
1;
--- NEW FILE: stat.pl ---
;# $RCSfile: stat.pl,v $$Revision: 1.2 $$Date: 2006-12-04 17:00:16 $
;# Usage:
;# require 'stat.pl';
;# @ary = stat(foo);
;# $st_dev = @ary[$ST_DEV];
;#
$ST_DEV = 0 + $[;
$ST_INO = 1 + $[;
$ST_MODE = 2 + $[;
$ST_NLINK = 3 + $[;
$ST_UID = 4 + $[;
$ST_GID = 5 + $[;
$ST_RDEV = 6 + $[;
$ST_SIZE = 7 + $[;
$ST_ATIME = 8 + $[;
$ST_MTIME = 9 + $[;
$ST_CTIME = 10 + $[;
$ST_BLKSIZE = 11 + $[;
$ST_BLOCKS = 12 + $[;
;# Usage:
;# require 'stat.pl';
;# do Stat('foo'); # sets st_* as a side effect
;#
sub Stat {
($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size,
$st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_));
}
1;
--- NEW FILE: sort.pm ---
package sort;
our $VERSION = '1.02';
# Currently the hints for pp_sort are stored in the global variable
# $sort::hints. An improvement would be to store them in $^H{SORT} and have
# this information available somewhere in the listop OP_SORT, to allow lexical
# scoping of this pragma. -- rgs 2002-04-30
our $hints = 0;
$sort::quicksort_bit = 0x00000001;
$sort::mergesort_bit = 0x00000002;
$sort::sort_bits = 0x000000FF; # allow 256 different ones
$sort::stable_bit = 0x00000100;
use strict;
sub import {
shift;
if (@_ == 0) {
require Carp;
Carp::croak("sort pragma requires arguments");
}
local $_;
no warnings 'uninitialized'; # bitops would warn
while ($_ = shift(@_)) {
if (/^_q(?:uick)?sort$/) {
$hints &= ~$sort::sort_bits;
$hints |= $sort::quicksort_bit;
} elsif ($_ eq '_mergesort') {
$hints &= ~$sort::sort_bits;
$hints |= $sort::mergesort_bit;
} elsif ($_ eq 'stable') {
$hints |= $sort::stable_bit;
} elsif ($_ eq 'defaults') {
$hints = 0;
} else {
require Carp;
Carp::croak("sort: unknown subpragma '$_'");
}
}
}
sub unimport {
shift;
if (@_ == 0) {
require Carp;
Carp::croak("sort pragma requires arguments");
}
local $_;
no warnings 'uninitialized'; # bitops would warn
while ($_ = shift(@_)) {
if (/^_q(?:uick)?sort$/) {
$hints &= ~$sort::sort_bits;
} elsif ($_ eq '_mergesort') {
$hints &= ~$sort::sort_bits;
} elsif ($_ eq 'stable') {
$hints &= ~$sort::stable_bit;
} else {
require Carp;
Carp::croak("sort: unknown subpragma '$_'");
}
}
}
sub current {
my @sort;
if ($hints) {
push @sort, 'quicksort' if $hints & $sort::quicksort_bit;
push @sort, 'mergesort' if $hints & $sort::mergesort_bit;
push @sort, 'stable' if $hints & $sort::stable_bit;
}
push @sort, 'mergesort' unless @sort;
join(' ', @sort);
}
1;
__END__
=head1 NAME
sort - perl pragma to control sort() behaviour
=head1 SYNOPSIS
use sort 'stable'; # guarantee stability
use sort '_quicksort'; # use a quicksort algorithm
use sort '_mergesort'; # use a mergesort algorithm
use sort 'defaults'; # revert to default behavior
no sort 'stable'; # stability not important
use sort '_qsort'; # alias for quicksort
my $current = sort::current(); # identify prevailing algorithm
=head1 DESCRIPTION
With the C<sort> pragma you can control the behaviour of the builtin
C<sort()> function.
In Perl versions 5.6 and earlier the quicksort algorithm was used to
implement C<sort()>, but in Perl 5.8 a mergesort algorithm was also made
available, mainly to guarantee worst case O(N log N) behaviour:
the worst case of quicksort is O(N**2). In Perl 5.8 and later,
quicksort defends against quadratic behaviour by shuffling large
arrays before sorting.
A stable sort means that for records that compare equal, the original
input ordering is preserved. Mergesort is stable, quicksort is not.
Stability will matter only if elements that compare equal can be
distinguished in some other way. That means that simple numerical
and lexical sorts do not profit from stability, since equal elements
are indistinguishable. However, with a comparison such as
{ substr($a, 0, 3) cmp substr($b, 0, 3) }
stability might matter because elements that compare equal on the
first 3 characters may be distinguished based on subsequent characters.
In Perl 5.8 and later, quicksort can be stabilized, but doing so will
add overhead, so it should only be done if it matters.
The best algorithm depends on many things. On average, mergesort
does fewer comparisons than quicksort, so it may be better when
complicated comparison routines are used. Mergesort also takes
advantage of pre-existing order, so it would be favored for using
C<sort()> to merge several sorted arrays. On the other hand, quicksort
is often faster for small arrays, and on arrays of a few distinct
values, repeated many times. You can force the
choice of algorithm with this pragma, but this feels heavy-handed,
so the subpragmas beginning with a C<_> may not persist beyond Perl 5.8.
The default algorithm is mergesort, which will be stable even if
you do not explicitly demand it.
But the stability of the default sort is a side-effect that could
change in later versions. If stability is important, be sure to
say so with a
use sort 'stable';
The C<no sort> pragma doesn't
I<forbid> what follows, it just leaves the choice open. Thus, after
no sort qw(_mergesort stable);
a mergesort, which happens to be stable, will be employed anyway.
Note that
no sort "_quicksort";
no sort "_mergesort";
have exactly the same effect, leaving the choice of sort algorithm open.
=head1 CAVEATS
This pragma is not lexically scoped: its effect is global to the program
it appears in. That means the following will probably not do what you
expect, because I<both> pragmas take effect at compile time, before
I<either> C<sort()> happens.
{ use sort "_quicksort";
print sort::current . "\n";
@a = sort @b;
}
{ use sort "stable";
print sort::current . "\n";
@c = sort @d;
}
# prints:
# quicksort stable
# quicksort stable
You can achieve the effect you probably wanted by using C<eval()>
to defer the pragmas until run time. Use the quoted argument
form of C<eval()>, I<not> the BLOCK form, as in
eval { use sort "_quicksort" }; # WRONG
or the effect will still be at compile time.
Reset to default options before selecting other subpragmas
(in case somebody carelessly left them on) and after sorting,
as a courtesy to others.
{ eval 'use sort qw(defaults _quicksort)'; # force quicksort
eval 'no sort "stable"'; # stability not wanted
print sort::current . "\n";
@a = sort @b;
eval 'use sort "defaults"'; # clean up, for others
}
{ eval 'use sort qw(defaults stable)'; # force stability
print sort::current . "\n";
@c = sort @d;
eval 'use sort "defaults"'; # clean up, for others
}
# prints:
# quicksort
# stable
Scoping for this pragma may change in future versions.
=cut
--- NEW FILE: AutoLoader.pm ---
package AutoLoader;
use strict;
use 5.006_001;
our($VERSION, $AUTOLOAD);
my $is_dosish;
my $is_epoc;
my $is_vms;
my $is_macos;
BEGIN {
$is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
$is_epoc = $^O eq 'epoc';
$is_vms = $^O eq 'VMS';
$is_macos = $^O eq 'MacOS';
$VERSION = '5.60';
}
AUTOLOAD {
my $sub = $AUTOLOAD;
my $filename;
# Braces used to preserve $1 et al.
{
# Try to find the autoloaded file from the package-qualified
# name of the sub. e.g., if the sub needed is
# Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is
# something like '/usr/lib/perl5/Getopt/Long.pm', and the
# autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'.
#
# However, if @INC is a relative path, this might not work. If,
# for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is
# 'lib/Getopt/Long.pm', and we want to require
# 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib').
# In this case, we simple prepend the 'auto/' and let the
# C<require> take care of the searching for us.
my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/);
$pkg =~ s#::#/#g;
if (defined($filename = $INC{"$pkg.pm"})) {
if ($is_macos) {
$pkg =~ tr#/#:#;
$filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s;
} else {
$filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s;
}
# if the file exists, then make sure that it is a
# a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al',
# or './lib/auto/foo/bar.al'. This avoids C<require> searching
# (and failing) to find the 'lib/auto/foo/bar.al' because it
# looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib').
if (-r $filename) {
unless ($filename =~ m|^/|s) {
if ($is_dosish) {
unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
if ($^O ne 'NetWare') {
$filename = "./$filename";
} else {
$filename = "$filename";
}
}
}
elsif ($is_epoc) {
unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
$filename = "./$filename";
}
}
elsif ($is_vms) {
# XXX todo by VMSmiths
$filename = "./$filename";
}
elsif (!$is_macos) {
$filename = "./$filename";
}
}
}
else {
$filename = undef;
}
}
unless (defined $filename) {
# let C<require> do the searching
$filename = "auto/$sub.al";
$filename =~ s#::#/#g;
}
}
my $save = $@;
local $!; # Do not munge the value.
eval { local $SIG{__DIE__}; require $filename };
if ($@) {
if (substr($sub,-9) eq '::DESTROY') {
no strict 'refs';
*$sub = sub {};
$@ = undef;
} elsif ($@ =~ /^Can't locate/) {
# The load might just have failed because the filename was too
# long for some old SVR3 systems which treat long names as errors.
# If we can successfully truncate a long name then it's worth a go.
# There is a slight risk that we could pick up the wrong file here
# but autosplit should have warned about that when splitting.
if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
eval { local $SIG{__DIE__}; require $filename };
}
}
if ($@){
$@ =~ s/ at .*\n//;
my $error = $@;
require Carp;
Carp::croak($error);
}
}
$@ = $save;
goto &$sub;
}
sub import {
my $pkg = shift;
my $callpkg = caller;
#
# Export symbols, but not by accident of inheritance.
#
if ($pkg eq 'AutoLoader') {
no strict 'refs';
*{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD
if @_ and $_[0] =~ /^&?AUTOLOAD$/;
}
#
# Try to find the autosplit index file. Eg., if the call package
# is POSIX, then $INC{POSIX.pm} is something like
# '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in
# '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that.
#
# However, if @INC is a relative path, this might not work. If,
# for example, @INC = ('lib'), then
# $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require
# 'auto/POSIX/autosplit.ix' (without the leading 'lib').
#
(my $calldir = $callpkg) =~ s#::#/#g;
my $path = $INC{$calldir . '.pm'};
if (defined($path)) {
# Try absolute path name.
if ($is_macos) {
(my $malldir = $calldir) =~ tr#/#:#;
$path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s;
} else {
$path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#;
}
eval { require $path; };
# If that failed, try relative path with normal @INC searching.
if ($@) {
$path ="auto/$calldir/autosplit.ix";
eval { require $path; };
}
if ($@) {
my $error = $@;
require Carp;
Carp::carp($error);
}
}
}
sub unimport {
my $callpkg = caller;
no strict 'refs';
my $symname = $callpkg . '::AUTOLOAD';
undef *{ $symname } if \&{ $symname } == \&AUTOLOAD;
*{ $symname } = \&{ $symname };
}
1;
__END__
=head1 NAME
AutoLoader - load subroutines only on demand
=head1 SYNOPSIS
package Foo;
use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
package Bar;
use AutoLoader; # don't import AUTOLOAD, define our own
sub AUTOLOAD {
...
$AutoLoader::AUTOLOAD = "...";
goto &AutoLoader::AUTOLOAD;
}
=head1 DESCRIPTION
The B<AutoLoader> module works with the B<AutoSplit> module and the
C<__END__> token to defer the loading of some subroutines until they are
used rather than loading them all at once.
To use B<AutoLoader>, the author of a module has to place the
definitions of subroutines to be autoloaded after an C<__END__> token.
(See L<perldata>.) The B<AutoSplit> module can then be run manually to
extract the definitions into individual files F<auto/funcname.al>.
B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
subroutine in is called in a client module of B<AutoLoader>,
B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
file with a name related to the location of the file from which the
client module was read. As an example, if F<POSIX.pm> is located in
F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
the C<.al> file has the same name as the subroutine, sans package. If
such a file exists, AUTOLOAD will read and evaluate it,
thus (presumably) defining the needed subroutine. AUTOLOAD will then
C<goto> the newly defined subroutine.
Once this process completes for a given function, it is defined, so
future calls to the subroutine will bypass the AUTOLOAD mechanism.
=head2 Subroutine Stubs
In order for object method lookup and/or prototype checking to operate
correctly even when methods have not yet been defined it is necessary to
"forward declare" each subroutine (as in C<sub NAME;>). See
L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
stubs", which are place holders with no code.
The AutoSplit and B<AutoLoader> modules automate the creation of forward
declarations. The AutoSplit module creates an 'index' file containing
forward declarations of all the AutoSplit subroutines. When the
AutoLoader module is 'use'd it loads these declarations into its callers
package.
Because of this mechanism it is important that B<AutoLoader> is always
C<use>d and not C<require>d.
=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
explicitly import it:
use AutoLoader 'AUTOLOAD';
=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
They typically need to check for some special cases (such as constants)
and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
Instead, they should define their own AUTOLOAD subroutines along these
lines:
use AutoLoader;
use Carp;
sub AUTOLOAD {
my $sub = $AUTOLOAD;
(my $constname = $sub) =~ s/.*:://;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
if ($! =~ /Invalid/ || $!{EINVAL}) {
$AutoLoader::AUTOLOAD = $sub;
goto &AutoLoader::AUTOLOAD;
}
else {
croak "Your vendor has not defined constant $constname";
}
}
*$sub = sub { $val }; # same as: eval "sub $sub { $val }";
goto &$sub;
}
If any module's own AUTOLOAD subroutine has no need to fallback to the
AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
subroutines), then that module should not use B<AutoLoader> at all.
=head2 Package Lexicals
Package lexicals declared with C<my> in the main block of a package
using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
the fact that the given scope ends at the C<__END__> marker. A module
using such variables as package globals will not work properly under the
B<AutoLoader>.
The C<vars> pragma (see L<perlmod/"vars">) may be used in such
situations as an alternative to explicitly qualifying all globals with
the package namespace. Variables pre-declared with this pragma will be
visible to any autoloaded routines (but will not be invisible outside
the package, unfortunately).
=head2 Not Using AutoLoader
You can stop using AutoLoader by simply
no AutoLoader;
=head2 B<AutoLoader> vs. B<SelfLoader>
The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
loading of subroutines.
B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
While this avoids the use of a hierarchy of disk files and the
associated open/close for each routine loaded, B<SelfLoader> suffers a
startup speed disadvantage in the one-time parsing of the lines after
C<__DATA__>, after which routines are cached. B<SelfLoader> can also
handle multiple packages in a file.
B<AutoLoader> only reads code as it is requested, and in many cases
should be faster, but requires a mechanism like B<AutoSplit> be used to
create the individual files. L<ExtUtils::MakeMaker> will invoke
B<AutoSplit> automatically if B<AutoLoader> is used in a module source
file.
=head1 CAVEATS
AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
old modules which use B<AutoLoader> should be changed to the new calling
style. Typically this just means changing a require to a use, adding
the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
from C<@ISA>.
On systems with restrictions on file name length, the file corresponding
to a subroutine may have a shorter name that the routine itself. This
can lead to conflicting file names. The I<AutoSplit> package warns of
these potential conflicts when used to split a module.
AutoLoader may fail to find the autosplit files (or even find the wrong
ones) in cases where C<@INC> contains relative paths, B<and> the program
does C<chdir>.
=head1 SEE ALSO
L<SelfLoader> - an autoloader that doesn't use external files.
=cut
--- NEW FILE: Cwd.pm ---
package Cwd;
=head1 NAME
Cwd - get pathname of current working directory
=head1 SYNOPSIS
use Cwd;
my $dir = getcwd;
use Cwd 'abs_path';
my $abs_path = abs_path($file);
=head1 DESCRIPTION
This module provides functions for determining the pathname of the
current working directory. It is recommended that getcwd (or another
*cwd() function) be used in I<all> code to ensure portability.
By default, it exports the functions cwd(), getcwd(), fastcwd(), and
fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
=head2 getcwd and friends
Each of these functions are called without arguments and return the
absolute path of the current working directory.
=over 4
=item getcwd
my $cwd = getcwd();
Returns the current working directory.
Re-implements the getcwd(3) (or getwd(3)) functions in Perl.
=item cwd
my $cwd = cwd();
The cwd() is the most natural form for the current architecture. For
most systems it is identical to `pwd` (but without the trailing line
terminator).
=item fastcwd
my $cwd = fastcwd();
A more dangerous version of getcwd(), but potentially faster.
It might conceivably chdir() you out of a directory that it can't
chdir() you back into. If fastcwd encounters a problem it will return
undef but will probably leave you in a different directory. For a
measure of extra security, if everything appears to have worked, the
fastcwd() function will check that it leaves you in the same directory
that it started in. If it has changed it will C<die> with the message
"Unstable directory path, current directory changed
unexpectedly". That should never happen.
=item fastgetcwd
my $cwd = fastgetcwd();
The fastgetcwd() function is provided as a synonym for cwd().
=item getdcwd
my $cwd = getdcwd();
my $cwd = getdcwd('C:');
The getdcwd() function is also provided on Win32 to get the current working
directory on the specified drive, since Windows maintains a separate current
working directory for each drive. If no drive is specified then the current
drive is assumed.
This function simply calls the Microsoft C library _getdcwd() function.
=back
=head2 abs_path and friends
These functions are exported only on request. They each take a single
argument and return the absolute pathname for it. If no argument is
given they'll use the current working directory.
=over 4
=item abs_path
my $abs_path = abs_path($file);
Uses the same algorithm as getcwd(). Symbolic links and relative-path
components ("." and "..") are resolved to return the canonical
pathname, just like realpath(3).
=item realpath
my $abs_path = realpath($file);
A synonym for abs_path().
=item fast_abs_path
my $abs_path = fast_abs_path($file);
A more dangerous, but potentially faster version of abs_path.
=back
=head2 $ENV{PWD}
If you ask to override your chdir() built-in function,
use Cwd qw(chdir);
then your PWD environment variable will be kept up to date. Note that
it will only be kept up to date if all packages which use chdir import
it from Cwd.
=head1 NOTES
=over 4
=item *
Since the path seperators are different on some operating systems ('/'
on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
modules wherever portability is a concern.
=item *
Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
functions are all aliases for the C<cwd()> function, which, on Mac OS,
calls `pwd`. Likewise, the C<abs_path()> function is an alias for
C<fast_abs_path()>.
=back
=head1 AUTHOR
Originally by the perl5-porters.
Maintained by Ken Williams <KWILLIAMS at cpan.org>
=head1 COPYRIGHT
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
Portions of the C code in this library are copyright (c) 1994 by the
Regents of the University of California. All rights reserved. The
license on this code is compatible with the licensing of the rest of
the distribution - please see the source code in F<Cwd.xs> for the
details.
=head1 SEE ALSO
L<File::chdir>
=cut
use strict;
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
$VERSION = '3.12';
@ISA = qw/ Exporter /;
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
# sys_cwd may keep the builtin command
# All the functionality of this module may provided by builtins,
# there is no sense to process the rest of the file.
# The best choice may be to have this in BEGIN, but how to return from BEGIN?
if ($^O eq 'os2') {
local $^W = 0;
*cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
*getcwd = \&cwd;
*fastgetcwd = \&cwd;
*fastcwd = \&cwd;
*fast_abs_path = \&sys_abspath if defined &sys_abspath;
*abs_path = \&fast_abs_path;
*realpath = \&fast_abs_path;
*fast_realpath = \&fast_abs_path;
return 1;
}
# If loading the XS stuff doesn't work, we can fall back to pure perl
eval {
if ( $] >= 5.006 ) {
require XSLoader;
XSLoader::load( __PACKAGE__, $VERSION );
} else {
require DynaLoader;
push @ISA, 'DynaLoader';
__PACKAGE__->bootstrap( $VERSION );
}
};
# Must be after the DynaLoader stuff:
$VERSION = eval $VERSION;
# Big nasty table of function aliases
my %METHOD_MAP =
(
VMS =>
{
cwd => '_vms_cwd',
getcwd => '_vms_cwd',
fastcwd => '_vms_cwd',
fastgetcwd => '_vms_cwd',
abs_path => '_vms_abs_path',
fast_abs_path => '_vms_abs_path',
},
MSWin32 =>
{
# We assume that &_NT_cwd is defined as an XSUB or in the core.
cwd => '_NT_cwd',
getcwd => '_NT_cwd',
fastcwd => '_NT_cwd',
fastgetcwd => '_NT_cwd',
abs_path => 'fast_abs_path',
realpath => 'fast_abs_path',
},
dos =>
{
cwd => '_dos_cwd',
getcwd => '_dos_cwd',
fastgetcwd => '_dos_cwd',
fastcwd => '_dos_cwd',
abs_path => 'fast_abs_path',
},
qnx =>
{
cwd => '_qnx_cwd',
getcwd => '_qnx_cwd',
fastgetcwd => '_qnx_cwd',
fastcwd => '_qnx_cwd',
abs_path => '_qnx_abs_path',
fast_abs_path => '_qnx_abs_path',
},
cygwin =>
{
getcwd => 'cwd',
fastgetcwd => 'cwd',
fastcwd => 'cwd',
abs_path => 'fast_abs_path',
realpath => 'fast_abs_path',
},
epoc =>
{
cwd => '_epoc_cwd',
getcwd => '_epoc_cwd',
fastgetcwd => '_epoc_cwd',
fastcwd => '_epoc_cwd',
abs_path => 'fast_abs_path',
},
MacOS =>
{
getcwd => 'cwd',
fastgetcwd => 'cwd',
fastcwd => 'cwd',
abs_path => 'fast_abs_path',
},
);
$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
$METHOD_MAP{nto} = $METHOD_MAP{qnx};
# Find the pwd command in the expected locations. We assume these
# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
# so everything works under taint mode.
my $pwd_cmd;
foreach my $try ('/bin/pwd',
'/usr/bin/pwd',
'/QOpenSys/bin/pwd', # OS/400 PASE.
) {
if( -x $try ) {
$pwd_cmd = $try;
last;
}
}
unless ($pwd_cmd) {
# Isn't this wrong? _backtick_pwd() will fail if somenone has
# pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
# See [perl #16774]. --jhi
$pwd_cmd = 'pwd';
}
# Lazy-load Carp
sub _carp { require Carp; Carp::carp(@_) }
sub _croak { require Carp; Carp::croak(@_) }
# The 'natural and safe form' for UNIX (pwd may be setuid root)
sub _backtick_pwd {
# Localize %ENV entries in a way that won't create new hash keys
my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
local @ENV{@localize};
my $cwd = `$pwd_cmd`;
# Belt-and-suspenders in case someone said "undef $/".
local $/ = "\n";
# `pwd` may fail e.g. if the disk is full
chomp($cwd) if defined $cwd;
$cwd;
}
# Since some ports may predefine cwd internally (e.g., NT)
# we take care not to override an existing definition for cwd().
unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
# The pwd command is not available in some chroot(2)'ed environments
my $sep = $Config::Config{path_sep} || ':';
my $os = $^O; # Protect $^O from tainting
if( $os eq 'MacOS' || (defined $ENV{PATH} &&
$os ne 'MSWin32' && # no pwd on Windows
grep { -x "$_/pwd" } split($sep, $ENV{PATH})) )
{
*cwd = \&_backtick_pwd;
}
else {
*cwd = \&getcwd;
}
}
# set a reasonable (and very safe) default for fastgetcwd, in case it
# isn't redefined later (20001212 rspier)
*fastgetcwd = \&cwd;
# By Brandon S. Allbery
#
# Usage: $cwd = getcwd();
sub getcwd
{
abs_path('.');
}
# By John Bazik
#
# Usage: $cwd = &fastcwd;
#
# This is a faster version of getcwd. It's also more dangerous because
# you might chdir out of a directory that you can't chdir back into.
sub fastcwd_ {
my($odev, $oino, $cdev, $cino, $tdev, $tino);
my(@path, $path);
local(*DIR);
my($orig_cdev, $orig_cino) = stat('.');
($cdev, $cino) = ($orig_cdev, $orig_cino);
for (;;) {
my $direntry;
($odev, $oino) = ($cdev, $cino);
CORE::chdir('..') || return undef;
($cdev, $cino) = stat('.');
last if $odev == $cdev && $oino == $cino;
opendir(DIR, '.') || return undef;
for (;;) {
$direntry = readdir(DIR);
last unless defined $direntry;
next if $direntry eq '.';
next if $direntry eq '..';
($tdev, $tino) = lstat($direntry);
last unless $tdev != $odev || $tino != $oino;
}
closedir(DIR);
return undef unless defined $direntry; # should never happen
unshift(@path, $direntry);
}
$path = '/' . join('/', @path);
if ($^O eq 'apollo') { $path = "/".$path; }
# At this point $path may be tainted (if tainting) and chdir would fail.
# Untaint it then check that we landed where we started.
$path =~ /^(.*)\z/s # untaint
&& CORE::chdir($1) or return undef;
($cdev, $cino) = stat('.');
die "Unstable directory path, current directory changed unexpectedly"
if $cdev != $orig_cdev || $cino != $orig_cino;
$path;
}
if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
# Keeps track of current working directory in PWD environment var
# Usage:
# use Cwd 'chdir';
# chdir $newdir;
my $chdir_init = 0;
sub chdir_init {
if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
my($dd,$di) = stat('.');
my($pd,$pi) = stat($ENV{'PWD'});
if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
$ENV{'PWD'} = cwd();
}
}
else {
my $wd = cwd();
$wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
$ENV{'PWD'} = $wd;
}
# Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
my($pd,$pi) = stat($2);
my($dd,$di) = stat($1);
if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
$ENV{'PWD'}="$2$3";
}
}
$chdir_init = 1;
}
sub chdir {
my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
$newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
chdir_init() unless $chdir_init;
my $newpwd;
if ($^O eq 'MSWin32') {
# get the full path name *before* the chdir()
$newpwd = Win32::GetFullPathName($newdir);
}
return 0 unless CORE::chdir $newdir;
if ($^O eq 'VMS') {
return $ENV{'PWD'} = $ENV{'DEFAULT'}
}
elsif ($^O eq 'MacOS') {
return $ENV{'PWD'} = cwd();
}
elsif ($^O eq 'MSWin32') {
$ENV{'PWD'} = $newpwd;
return 1;
}
if ($newdir =~ m#^/#s) {
$ENV{'PWD'} = $newdir;
} else {
my @curdir = split(m#/#,$ENV{'PWD'});
@curdir = ('') unless @curdir;
my $component;
foreach $component (split(m#/#, $newdir)) {
next if $component eq '.';
pop(@curdir),next if $component eq '..';
push(@curdir,$component);
}
$ENV{'PWD'} = join('/', at curdir) || '/';
}
1;
}
sub _perl_abs_path
{
my $start = @_ ? shift : '.';
my($dotdots, $cwd, @pst, @cst, $dir, @tst);
unless (@cst = stat( $start ))
{
_carp("stat($start): $!");
return '';
}
unless (-d _) {
# Make sure we can be invoked on plain files, not just directories.
# NOTE that this routine assumes that '/' is the only directory separator.
my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
or return cwd() . '/' . $start;
# Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
if (-l $start) {
my $link_target = readlink($start);
die "Can't resolve link $start: $!" unless defined $link_target;
require File::Spec;
$link_target = $dir . '/' . $link_target
unless File::Spec->file_name_is_absolute($link_target);
return abs_path($link_target);
}
return $dir ? abs_path($dir) . "/$file" : "/$file";
}
$cwd = '';
$dotdots = $start;
do
{
$dotdots .= '/..';
@pst = @cst;
local *PARENT;
unless (opendir(PARENT, $dotdots))
{
_carp("opendir($dotdots): $!");
return '';
}
unless (@cst = stat($dotdots))
{
_carp("stat($dotdots): $!");
closedir(PARENT);
return '';
}
if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
{
$dir = undef;
}
else
{
do
{
unless (defined ($dir = readdir(PARENT)))
{
_carp("readdir($dotdots): $!");
closedir(PARENT);
return '';
}
$tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
}
while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
$tst[1] != $pst[1]);
}
$cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
closedir(PARENT);
} while (defined $dir);
chop($cwd) unless $cwd eq '/'; # drop the trailing /
$cwd;
}
my $Curdir;
sub fast_abs_path {
local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
my $cwd = getcwd();
require File::Spec;
my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
# Detaint else we'll explode in taint mode. This is safe because
# we're not doing anything dangerous with it.
($path) = $path =~ /(.*)/;
($cwd) = $cwd =~ /(.*)/;
unless (-e $path) {
_croak("$path: No such file or directory");
}
unless (-d _) {
# Make sure we can be invoked on plain files, not just directories.
my ($vol, $dir, $file) = File::Spec->splitpath($path);
return File::Spec->catfile($cwd, $path) unless length $dir;
if (-l $path) {
my $link_target = readlink($path);
die "Can't resolve link $path: $!" unless defined $link_target;
$link_target = File::Spec->catpath($vol, $dir, $link_target)
unless File::Spec->file_name_is_absolute($link_target);
return fast_abs_path($link_target);
}
return $dir eq File::Spec->rootdir
? File::Spec->catpath($vol, $dir, $file)
: fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
}
if (!CORE::chdir($path)) {
_croak("Cannot chdir to $path: $!");
}
my $realpath = getcwd();
if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
_croak("Cannot chdir back to $cwd: $!");
}
$realpath;
}
# added function alias to follow principle of least surprise
# based on previous aliasing. --tchrist 27-Jan-00
*fast_realpath = \&fast_abs_path;
# --- PORTING SECTION ---
# VMS: $ENV{'DEFAULT'} points to default directory at all times
# 06-Mar-1996 Charles Bailey bailey at newman.upenn.edu
# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
# in the process logical name table as the default device and directory
# seen by Perl. This may not be the same as the default device
# and directory seen by DCL after Perl exits, since the effects
# the CRTL chdir() function persist only until Perl exits.
sub _vms_cwd {
return $ENV{'DEFAULT'};
}
sub _vms_abs_path {
return $ENV{'DEFAULT'} unless @_;
# may need to turn foo.dir into [.foo]
my $path = VMS::Filespec::pathify($_[0]);
$path = $_[0] unless defined $path;
return VMS::Filespec::rmsexpand($path);
}
sub _os2_cwd {
$ENV{'PWD'} = `cmd /c cd`;
chomp $ENV{'PWD'};
$ENV{'PWD'} =~ s:\\:/:g ;
return $ENV{'PWD'};
}
sub _win32_cwd {
$ENV{'PWD'} = Win32::GetCwd();
$ENV{'PWD'} =~ s:\\:/:g ;
return $ENV{'PWD'};
}
*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd;
sub _dos_cwd {
if (!defined &Dos::GetCwd) {
$ENV{'PWD'} = `command /c cd`;
chomp $ENV{'PWD'};
$ENV{'PWD'} =~ s:\\:/:g ;
} else {
$ENV{'PWD'} = Dos::GetCwd();
}
return $ENV{'PWD'};
}
sub _qnx_cwd {
local $ENV{PATH} = '';
local $ENV{CDPATH} = '';
local $ENV{ENV} = '';
$ENV{'PWD'} = `/usr/bin/fullpath -t`;
chomp $ENV{'PWD'};
return $ENV{'PWD'};
}
sub _qnx_abs_path {
local $ENV{PATH} = '';
local $ENV{CDPATH} = '';
local $ENV{ENV} = '';
my $path = @_ ? shift : '.';
local *REALPATH;
defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
die "Can't open /usr/bin/fullpath: $!";
my $realpath = <REALPATH>;
close REALPATH;
chomp $realpath;
return $realpath;
}
sub _epoc_cwd {
$ENV{'PWD'} = EPOC::getcwd();
return $ENV{'PWD'};
}
# Now that all the base-level functions are set up, alias the
# user-level functions to the right places
if (exists $METHOD_MAP{$^O}) {
my $map = $METHOD_MAP{$^O};
foreach my $name (keys %$map) {
local $^W = 0; # assignments trigger 'subroutine redefined' warning
no strict 'refs';
*{$name} = \&{$map->{$name}};
}
}
# In case the XS version doesn't load.
*abs_path = \&_perl_abs_path unless defined &abs_path;
# added function alias for those of us more
# used to the libc function. --tchrist 27-Jan-00
*realpath = \&abs_path;
1;
--- NEW FILE: subs.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
$ENV{PERL5LIB} = '../lib';
}
$| = 1;
undef $/;
my @prgs = split "\n########\n", <DATA>;
print "1..", scalar @prgs, "\n";
my $Is_VMS = $^O eq 'VMS';
my $Is_MSWin32 = $^O eq 'MSWin32';
my $Is_NetWare = $^O eq 'NetWare';
my $Is_MacOS = $^O eq 'MacOS';
my $tmpfile = "tmp0000";
my $i = 0 ;
1 while -e ++$tmpfile;
END { if ($tmpfile) { 1 while unlink $tmpfile} }
for (@prgs){
my $switch = "";
my @temps = () ;
if (s/^\s*-\w+//){
$switch = $&;
}
my($prog,$expected) = split(/\nEXPECT\n/, $_);
if ( $prog =~ /--FILE--/) {
my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
shift @files ;
die "Internal error test $i didn't split into pairs, got " .
scalar(@files) . "[" . join("%%%%", @files) ."]\n"
if @files % 2 ;
while (@files > 2) {
my $filename = shift @files ;
my $code = shift @files ;
push @temps, $filename ;
open F, ">$filename" or die "Cannot open $filename: $!\n" ;
print F $code ;
close F ;
}
shift @files ;
$prog = shift @files ;
}
open TEST, ">$tmpfile";
print TEST $prog,"\n";
close TEST;
my $results = $Is_VMS ?
`./perl $switch $tmpfile 2>&1` :
$Is_MSWin32 ?
`.\\perl -I../lib $switch $tmpfile 2>&1` :
$Is_NetWare ?
`perl -I../lib $switch $tmpfile 2>&1` :
$Is_MacOS ?
`$^X -I::lib -MMac::err=unix $switch $tmpfile` :
`./perl $switch $tmpfile 2>&1`;
my $status = $?;
$results =~ s/\n+$//;
# allow expected output to be written as if $prog is on STDIN
$results =~ s/tmp\d+/-/g;
$results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
# bison says 'parse error' instead of 'syntax error',
# various yaccs may or may not capitalize 'syntax'.
$results =~ s/^(syntax|parse) error/syntax error/mig;
$expected =~ s/\n+$//;
my $prefix = ($results =~ s/^PREFIX\n//) ;
if ( $results =~ s/^SKIPPED\n//) {
print "$results\n" ;
}
elsif (($prefix and $results !~ /^\Q$expected/) or
(!$prefix and $results ne $expected)){
print STDERR "PROG: $switch\n$prog\n";
print STDERR "EXPECTED:\n$expected\n";
print STDERR "GOT:\n$results\n";
print "not ";
}
print "ok ", ++$i, "\n";
foreach (@temps)
{ unlink $_ if $_ }
}
__END__
# Error - not predeclaring a sub
Fred 1,2 ;
sub Fred {}
EXPECT
Number found where operator expected at - line 3, near "Fred 1"
(Do you need to predeclare Fred?)
syntax error at - line 3, near "Fred 1"
Execution of - aborted due to compilation errors.
########
# Error - not predeclaring a sub in time
Fred 1,2 ;
use subs qw( Fred ) ;
sub Fred {}
EXPECT
Number found where operator expected at - line 3, near "Fred 1"
(Do you need to predeclare Fred?)
syntax error at - line 3, near "Fred 1"
BEGIN not safe after errors--compilation aborted at - line 4.
########
# AOK
use subs qw( Fred) ;
Fred 1,2 ;
sub Fred { print $_[0] + $_[1], "\n" }
EXPECT
3
########
# override a built-in function
use subs qw( open ) ;
open 1,2 ;
sub open { print $_[0] + $_[1], "\n" }
EXPECT
3
########
# override a built-in function, call after definition
use subs qw( open ) ;
sub open { print $_[0] + $_[1], "\n" }
open 1,2 ;
EXPECT
3
########
# override a built-in function, call with ()
use subs qw( open ) ;
open (1,2) ;
sub open { print $_[0] + $_[1], "\n" }
EXPECT
3
########
# override a built-in function, call with () after definition
use subs qw( open ) ;
sub open { print $_[0] + $_[1], "\n" }
open (1,2) ;
EXPECT
3
########
--FILE-- abc
Fred 1,2 ;
1;
--FILE--
use subs qw( Fred ) ;
require "./abc" ;
sub Fred { print $_[0] + $_[1], "\n" }
EXPECT
3
########
# check that it isn't affected by block scope
{
use subs qw( Fred ) ;
}
Fred 1, 2;
sub Fred { print $_[0] + $_[1], "\n" }
EXPECT
3
--- NEW FILE: exceptions.pl ---
# exceptions.pl
# tchrist at convex.com
#
# This library is no longer being maintained, and is included for backward
# compatibility with Perl 4 programs which may require it.
#
# In particular, this should not be used as an example of modern Perl
# programming techniques.
#
#
# Here's a little code I use for exception handling. It's really just
# glorfied eval/die. The way to use use it is when you might otherwise
# exit, use &throw to raise an exception. The first enclosing &catch
# handler looks at the exception and decides whether it can catch this kind
# (catch takes a list of regexps to catch), and if so, it returns the one it
# caught. If it *can't* catch it, then it will reraise the exception
# for someone else to possibly see, or to die otherwise.
#
# I use oddly named variables in order to make darn sure I don't conflict
# with my caller. I also hide in my own package, and eval the code in his.
#
# The EXCEPTION: prefix is so you can tell whether it's a user-raised
# exception or a perl-raised one (eval error).
#
# --tom
#
# examples:
# if (&catch('/$user_input/', 'regexp', 'syntax error') {
# warn "oops try again";
# redo;
# }
#
# if ($error = &catch('&subroutine()')) { # catches anything
#
# &throw('bad input') if /^$/;
sub catch {
package exception;
local($__code__, @__exceptions__) = @_;
local($__package__) = caller;
local($__exception__);
eval "package $__package__; $__code__";
if ($__exception__ = &'thrown) {
for (@__exceptions__) {
return $__exception__ if /$__exception__/;
}
&'throw($__exception__);
}
}
sub throw {
local($exception) = @_;
die "EXCEPTION: $exception\n";
}
sub thrown {
$@ =~ /^(EXCEPTION: )+(.+)/ && $2;
}
1;
--- NEW FILE: base.pm ---
package base;
use strict 'vars';
use vars qw($VERSION);
$VERSION = '2.07';
# constant.pm is slow
sub SUCCESS () { 1 }
sub PUBLIC () { 2**0 }
sub PRIVATE () { 2**1 }
sub INHERITED () { 2**2 }
sub PROTECTED () { 2**3 }
my $Fattr = \%fields::attr;
sub has_fields {
my($base) = shift;
my $fglob = ${"$base\::"}{FIELDS};
return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
}
sub has_version {
my($base) = shift;
my $vglob = ${$base.'::'}{VERSION};
return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
}
sub has_attr {
my($proto) = shift;
my($class) = ref $proto || $proto;
return exists $Fattr->{$class};
}
sub get_attr {
$Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
return $Fattr->{$_[0]};
}
if ($] < 5.009) {
*get_fields = sub {
# Shut up a possible typo warning.
() = \%{$_[0].'::FIELDS'};
my $f = \%{$_[0].'::FIELDS'};
# should be centralized in fields? perhaps
# fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
# is used here anyway, it doesn't matter.
bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
return $f;
}
}
else {
*get_fields = sub {
# Shut up a possible typo warning.
() = \%{$_[0].'::FIELDS'};
return \%{$_[0].'::FIELDS'};
}
}
sub import {
my $class = shift;
return SUCCESS unless @_;
# List of base classes from which we will inherit %FIELDS.
my $fields_base;
my $inheritor = caller(0);
foreach my $base (@_) {
next if $inheritor->isa($base);
if (has_version($base)) {
${$base.'::VERSION'} = '-1, set by base.pm'
unless defined ${$base.'::VERSION'};
}
else {
local $SIG{__DIE__};
eval "require $base";
# Only ignore "Can't locate" errors from our eval require.
# Other fatal errors (syntax etc) must be reported.
die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
unless (%{"$base\::"}) {
require Carp;
Carp::croak(<<ERROR);
Base class package "$base" is empty.
(Perhaps you need to 'use' the module which defines that package first.)
ERROR
}
${$base.'::VERSION'} = "-1, set by base.pm"
unless defined ${$base.'::VERSION'};
}
push @{"$inheritor\::ISA"}, $base;
if ( has_fields($base) || has_attr($base) ) {
# No multiple fields inheritence *suck*
if ($fields_base) {
require Carp;
Carp::croak("Can't multiply inherit %FIELDS");
} else {
$fields_base = $base;
}
}
}
if( defined $fields_base ) {
inherit_fields($inheritor, $fields_base);
}
}
sub inherit_fields {
my($derived, $base) = @_;
return SUCCESS unless $base;
my $battr = get_attr($base);
my $dattr = get_attr($derived);
my $dfields = get_fields($derived);
my $bfields = get_fields($base);
$dattr->[0] = @$battr;
if( keys %$dfields ) {
warn "$derived is inheriting from $base but already has its own ".
"fields!\n".
"This will cause problems.\n".
"Be sure you use base BEFORE declaring fields\n";
}
# Iterate through the base's fields adding all the non-private
# ones to the derived class. Hang on to the original attribute
# (Public, Private, etc...) and add Inherited.
# This is all too complicated to do efficiently with add_fields().
while (my($k,$v) = each %$bfields) {
my $fno;
if ($fno = $dfields->{$k} and $fno != $v) {
require Carp;
Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
}
if( $battr->[$v] & PRIVATE ) {
$dattr->[$v] = PRIVATE | INHERITED;
}
else {
$dattr->[$v] = INHERITED | $battr->[$v];
$dfields->{$k} = $v;
}
}
foreach my $idx (1..$#{$battr}) {
next if defined $dattr->[$idx];
$dattr->[$idx] = $battr->[$idx] & INHERITED;
}
}
1;
__END__
=head1 NAME
base - Establish IS-A relationship with base classes at compile time
=head1 SYNOPSIS
package Baz;
use base qw(Foo Bar);
=head1 DESCRIPTION
Allows you to both load one or more modules, while setting up inheritance from
those modules at the same time. Roughly similar in effect to
package Baz;
BEGIN {
require Foo;
require Bar;
push @ISA, qw(Foo Bar);
}
If any of the listed modules are not loaded yet, I<base> silently attempts to
C<require> them (and silently continues if the C<require> failed). Whether to
C<require> a base class module is determined by the absence of a global variable
$VERSION in the base package. If $VERSION is not detected even after loading
it, <base> will define $VERSION in the base package, setting it to the string
C<-1, set by base.pm>.
Will also initialize the fields if one of the base classes has it.
Multiple inheritence of fields is B<NOT> supported, if two or more
base classes each have inheritable fields the 'base' pragma will
croak. See L<fields>, L<public> and L<protected> for a description of
this feature.
=head1 DIAGNOSTICS
=over 4
=item Base class package "%s" is empty.
base.pm was unable to require the base package, because it was not
found in your path.
=back
=head1 HISTORY
This module was introduced with Perl 5.004_04.
=head1 CAVEATS
Due to the limitations of the implementation, you must use
base I<before> you declare any of your own fields.
=head1 SEE ALSO
L<fields>
=cut
--- NEW FILE: FileHandle.pm ---
package FileHandle;
use 5.006;
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
$VERSION = "2.01";
require IO::File;
@ISA = qw(IO::File);
@EXPORT = qw(_IOFBF _IOLBF _IONBF);
@EXPORT_OK = qw(
pipe
autoflush
output_field_separator
output_record_separator
input_record_separator
input_line_number
format_page_number
format_lines_per_page
format_lines_left
format_name
format_top_name
format_line_break_characters
format_formfeed
print
printf
getline
getlines
);
#
# Everything we're willing to export, we must first import.
#
import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK;
#
# Some people call "FileHandle::function", so all the functions
# that were in the old FileHandle class must be imported, too.
#
{
no strict 'refs';
my %import = (
'IO::Handle' =>
[qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets
eof flush error clearerr setbuf setvbuf _open_mode_string)],
'IO::Seekable' =>
[qw(seek tell getpos setpos)],
'IO::File' =>
[qw(new new_tmpfile open)]
);
for my $pkg (keys %import) {
for my $func (@{$import{$pkg}}) {
my $c = *{"${pkg}::$func"}{CODE}
or die "${pkg}::$func missing";
*$func = $c;
}
}
}
#
# Specialized importer for Fcntl magic.
#
sub import {
my $pkg = shift;
my $callpkg = caller;
require Exporter;
Exporter::export($pkg, $callpkg, @_);
#
# If the Fcntl extension is available,
# export its constants.
#
eval {
require Fcntl;
Exporter::export('Fcntl', $callpkg);
};
}
################################################
# This is the only exported function we define;
# the rest come from other classes.
#
sub pipe {
my $r = new IO::Handle;
my $w = new IO::Handle;
CORE::pipe($r, $w) or return undef;
($r, $w);
}
# Rebless standard file handles
bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle";
bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle";
bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle";
1;
__END__
=head1 NAME
FileHandle - supply object methods for filehandles
=head1 SYNOPSIS
use FileHandle;
$fh = new FileHandle;
if ($fh->open("< file")) {
print <$fh>;
$fh->close;
}
$fh = new FileHandle "> FOO";
if (defined $fh) {
print $fh "bar\n";
$fh->close;
}
$fh = new FileHandle "file", "r";
if (defined $fh) {
print <$fh>;
undef $fh; # automatically closes the file
}
$fh = new FileHandle "file", O_WRONLY|O_APPEND;
if (defined $fh) {
print $fh "corge\n";
undef $fh; # automatically closes the file
}
$pos = $fh->getpos;
$fh->setpos($pos);
$fh->setvbuf($buffer_var, _IOLBF, 1024);
($readfh, $writefh) = FileHandle::pipe;
autoflush STDOUT 1;
=head1 DESCRIPTION
NOTE: This class is now a front-end to the IO::* classes.
C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
newly created symbol (see the C<Symbol> package). If it receives any
parameters, they are passed to C<FileHandle::open>; if the open fails,
the C<FileHandle> object is destroyed. Otherwise, it is returned to
the caller.
C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
It requires two parameters, which are passed to C<FileHandle::fdopen>;
if the fdopen fails, the C<FileHandle> object is destroyed.
Otherwise, it is returned to the caller.
C<FileHandle::open> accepts one parameter or two. With one parameter,
it is just a front end for the built-in C<open> function. With two
parameters, the first parameter is a filename that may include
whitespace or other special characters, and the second parameter is
the open mode, optionally followed by a file permission value.
If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.)
or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
Perl C<open> operator.
If C<FileHandle::open> is given a numeric mode, it passes that mode
and the optional permissions value to the Perl C<sysopen> operator.
For convenience, C<FileHandle::import> tries to import the O_XXX
constants from the Fcntl module. If dynamic loading is not available,
this may fail, but the rest of FileHandle will still work.
C<FileHandle::fdopen> is like C<open> except that its first parameter
is not a filename but rather a file handle name, a FileHandle object,
or a file descriptor number.
If the C functions fgetpos() and fsetpos() are available, then
C<FileHandle::getpos> returns an opaque value that represents the
current position of the FileHandle, and C<FileHandle::setpos> uses
that value to return to a previously visited position.
If the C function setvbuf() is available, then C<FileHandle::setvbuf>
sets the buffering policy for the FileHandle. The calling sequence
for the Perl function is the same as its C counterpart, including the
macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
parameter specifies a scalar variable to use as a buffer. WARNING: A
variable used as a buffer by C<FileHandle::setvbuf> must not be
modified in any way until the FileHandle is closed or until
C<FileHandle::setvbuf> is called again, or memory corruption may
result!
See L<perlfunc> for complete descriptions of each of the following
supported C<FileHandle> methods, which are just front ends for the
corresponding built-in functions:
close
fileno
getc
gets
eof
clearerr
seek
tell
See L<perlvar> for complete descriptions of each of the following
supported C<FileHandle> methods:
autoflush
output_field_separator
output_record_separator
input_record_separator
input_line_number
format_page_number
format_lines_per_page
format_lines_left
format_name
format_top_name
format_line_break_characters
format_formfeed
Furthermore, for doing normal I/O you might need these:
=over 4
=item $fh->print
See L<perlfunc/print>.
=item $fh->printf
See L<perlfunc/printf>.
=item $fh->getline
This works like <$fh> described in L<perlop/"I/O Operators">
except that it's more readable and can be safely called in a
list context but still returns just one line.
=item $fh->getlines
This works like <$fh> when called in a list context to
read all the remaining lines in a file, except that it's more readable.
It will also croak() if accidentally called in a scalar context.
=back
There are many other functions available since FileHandle is descended
from IO::File, IO::Seekable, and IO::Handle. Please see those
respective pages for documentation on more functions.
=head1 SEE ALSO
The B<IO> extension,
L<perlfunc>,
L<perlop/"I/O Operators">.
=cut
More information about the dslinux-commit
mailing list