commit for archiving
This commit is contained in:
343
Perl/lib/AutoLoader.pm
Normal file
343
Perl/lib/AutoLoader.pm
Normal file
@@ -0,0 +1,343 @@
|
||||
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
|
||||
274
Perl/lib/Carp.pm
Normal file
274
Perl/lib/Carp.pm
Normal file
@@ -0,0 +1,274 @@
|
||||
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@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@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;
|
||||
104
Perl/lib/Config.pm
Normal file
104
Perl/lib/Config.pm
Normal file
@@ -0,0 +1,104 @@
|
||||
# This file was created by configpm when Perl was built. Any changes
|
||||
# made to this file will be lost the next time perl is built.
|
||||
|
||||
package Config;
|
||||
use strict;
|
||||
# use warnings; Pulls in Carp
|
||||
# use vars pulls in Carp
|
||||
@Config::EXPORT = qw(%Config);
|
||||
@Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re);
|
||||
|
||||
# Need to stub all the functions to make code such as print Config::config_sh
|
||||
# keep working
|
||||
|
||||
sub myconfig;
|
||||
sub config_sh;
|
||||
sub config_vars;
|
||||
sub config_re;
|
||||
|
||||
my %Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK);
|
||||
|
||||
our %Config;
|
||||
|
||||
# Define our own import method to avoid pulling in the full Exporter:
|
||||
sub import {
|
||||
my $pkg = shift;
|
||||
@_ = @Config::EXPORT unless @_;
|
||||
|
||||
my @funcs = grep $_ ne '%Config', @_;
|
||||
my $export_Config = @funcs < @_ ? 1 : 0;
|
||||
|
||||
no strict 'refs';
|
||||
my $callpkg = caller(0);
|
||||
foreach my $func (@funcs) {
|
||||
die sprintf qq{"%s" is not exported by the %s module\n},
|
||||
$func, __PACKAGE__ unless $Export_Cache{$func};
|
||||
*{$callpkg.'::'.$func} = \&{$func};
|
||||
}
|
||||
|
||||
*{"$callpkg\::Config"} = \%Config if $export_Config;
|
||||
return;
|
||||
}
|
||||
|
||||
die "Perl lib version (v5.8.8) doesn't match executable version ($])"
|
||||
unless $^V;
|
||||
|
||||
$^V eq v5.8.8
|
||||
or die "Perl lib version (v5.8.8) doesn't match executable version (" .
|
||||
sprintf("v%vd",$^V) . ")";
|
||||
|
||||
|
||||
sub FETCH {
|
||||
my($self, $key) = @_;
|
||||
|
||||
# check for cached value (which may be undef so we use exists not defined)
|
||||
return $self->{$key} if exists $self->{$key};
|
||||
|
||||
return $self->fetch_string($key);
|
||||
}
|
||||
sub TIEHASH {
|
||||
bless $_[1], $_[0];
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $config_heavy = 'Config_heavy.pl';
|
||||
if (defined &ActivePerl::_CONFIG_HEAVY) {
|
||||
$config_heavy = ActivePerl::_CONFIG_HEAVY();
|
||||
}
|
||||
require $config_heavy;
|
||||
goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
|
||||
die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
|
||||
}
|
||||
|
||||
sub __unused {
|
||||
# XXX Keep PerlApp happy
|
||||
require 'Config_heavy.pl';
|
||||
}
|
||||
|
||||
# tie returns the object, so the value returned to require will be true.
|
||||
tie %Config, 'Config', {
|
||||
archlibexp => 'C:\Perl\\lib',
|
||||
archname => 'MSWin32-x86-multi-thread',
|
||||
d_readlink => undef,
|
||||
d_symlink => undef,
|
||||
dlsrc => 'dl_win32.xs',
|
||||
dont_use_nlink => undef,
|
||||
exe_ext => '.exe',
|
||||
inc_version_list => '',
|
||||
intsize => '4',
|
||||
ldlibpthname => '',
|
||||
obj_ext => '.obj',
|
||||
osname => 'MSWin32',
|
||||
osvers => '4.0',
|
||||
path_sep => ';',
|
||||
privlibexp => 'C:\Perl\\lib',
|
||||
scriptdir => 'C:\Perl\\bin',
|
||||
sitearchexp => 'C:\Perl\\site\\lib',
|
||||
sitelibexp => 'C:\Perl\\site\\lib',
|
||||
so => 'dll',
|
||||
useithreads => 'define',
|
||||
usevendorprefix => undef,
|
||||
version => '5.8.8',
|
||||
};
|
||||
1205
Perl/lib/Config_heavy.pl
Normal file
1205
Perl/lib/Config_heavy.pl
Normal file
File diff suppressed because it is too large
Load Diff
497
Perl/lib/Data/Dump.pm
Normal file
497
Perl/lib/Data/Dump.pm
Normal file
@@ -0,0 +1,497 @@
|
||||
package Data::Dump;
|
||||
|
||||
use strict;
|
||||
use vars qw(@EXPORT_OK $VERSION $DEBUG);
|
||||
|
||||
require Exporter;
|
||||
*import = \&Exporter::import;
|
||||
@EXPORT_OK=qw(dump pp);
|
||||
|
||||
$VERSION = "1.08"; # $Date: 2006/11/29 10:47:17 $
|
||||
$DEBUG = 0;
|
||||
|
||||
use overload ();
|
||||
use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64);
|
||||
|
||||
$TRY_BASE64 = 50 unless defined $TRY_BASE64;
|
||||
|
||||
my %is_perl_keyword = map { $_ => 1 }
|
||||
qw( __FILE__ __LINE__ __PACKAGE__ __DATA__ __END__ AUTOLOAD BEGIN CORE
|
||||
DESTROY END EQ GE GT INIT LE LT NE abs accept alarm and atan2 bind
|
||||
binmode bless caller chdir chmod chomp chop chown chr chroot close
|
||||
closedir cmp connect continue cos crypt dbmclose dbmopen defined
|
||||
delete die do dump each else elsif endgrent endhostent endnetent
|
||||
endprotoent endpwent endservent eof eq eval exec exists exit exp fcntl
|
||||
fileno flock for foreach fork format formline ge getc getgrent
|
||||
getgrgid getgrnam gethostbyaddr gethostbyname gethostent getlogin
|
||||
getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid
|
||||
getpriority getprotobyname getprotobynumber getprotoent getpwent
|
||||
getpwnam getpwuid getservbyname getservbyport getservent getsockname
|
||||
getsockopt glob gmtime goto grep gt hex if index int ioctl join keys
|
||||
kill last lc lcfirst le length link listen local localtime lock log
|
||||
lstat lt m map mkdir msgctl msgget msgrcv msgsnd my ne next no not oct
|
||||
open opendir or ord pack package pipe pop pos print printf prototype
|
||||
push q qq qr quotemeta qw qx rand read readdir readline readlink
|
||||
readpipe recv redo ref rename require reset return reverse rewinddir
|
||||
rindex rmdir s scalar seek seekdir select semctl semget semop send
|
||||
setgrent sethostent setnetent setpgrp setpriority setprotoent setpwent
|
||||
setservent setsockopt shift shmctl shmget shmread shmwrite shutdown
|
||||
sin sleep socket socketpair sort splice split sprintf sqrt srand stat
|
||||
study sub substr symlink syscall sysopen sysread sysseek system
|
||||
syswrite tell telldir tie tied time times tr truncate uc ucfirst umask
|
||||
undef unless unlink unpack unshift untie until use utime values vec
|
||||
wait waitpid wantarray warn while write x xor y);
|
||||
|
||||
|
||||
sub dump
|
||||
{
|
||||
local %seen;
|
||||
local %refcnt;
|
||||
local %require;
|
||||
local @fixup;
|
||||
|
||||
my $name = "a";
|
||||
my @dump;
|
||||
|
||||
for my $v (@_) {
|
||||
my $val = _dump($v, $name, [], tied($v));
|
||||
push(@dump, [$name, $val]);
|
||||
} continue {
|
||||
$name++;
|
||||
}
|
||||
|
||||
my $out = "";
|
||||
if (%require) {
|
||||
for (sort keys %require) {
|
||||
$out .= "require $_;\n";
|
||||
}
|
||||
}
|
||||
if (%refcnt) {
|
||||
# output all those with refcounts first
|
||||
for (@dump) {
|
||||
my $name = $_->[0];
|
||||
if ($refcnt{$name}) {
|
||||
$out .= "my \$$name = $_->[1];\n";
|
||||
undef $_->[1];
|
||||
}
|
||||
}
|
||||
for (@fixup) {
|
||||
$out .= "$_;\n";
|
||||
}
|
||||
}
|
||||
|
||||
my $paren = (@dump != 1);
|
||||
$out .= "(" if $paren;
|
||||
$out .= format_list($paren, undef,
|
||||
map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]}
|
||||
@dump
|
||||
);
|
||||
$out .= ")" if $paren;
|
||||
|
||||
if (%refcnt || %require) {
|
||||
$out .= ";\n";
|
||||
$out =~ s/^/ /gm; # indent
|
||||
$out = "do {\n$out}";
|
||||
}
|
||||
|
||||
#use Data::Dumper; print Dumper(\%refcnt);
|
||||
#use Data::Dumper; print Dumper(\%seen);
|
||||
|
||||
print STDERR "$out\n" unless defined wantarray;
|
||||
$out;
|
||||
}
|
||||
|
||||
*pp = \&dump;
|
||||
|
||||
sub _dump
|
||||
{
|
||||
my $ref = ref $_[0];
|
||||
my $rval = $ref ? $_[0] : \$_[0];
|
||||
shift;
|
||||
|
||||
my($name, $idx, $dont_remember) = @_;
|
||||
|
||||
my($class, $type, $id);
|
||||
if (overload::StrVal($rval) =~ /^(?:([^=]+)=)?([A-Z]+)\(0x([^\)]+)\)$/) {
|
||||
$class = $1;
|
||||
$type = $2;
|
||||
$id = $3;
|
||||
} else {
|
||||
die "Can't parse " . overload::StrVal($rval);
|
||||
}
|
||||
if ($] < 5.008 && $type eq "SCALAR") {
|
||||
$type = "REF" if $ref eq "REF";
|
||||
}
|
||||
warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG;
|
||||
|
||||
unless ($dont_remember) {
|
||||
if (my $s = $seen{$id}) {
|
||||
my($sname, $sidx) = @$s;
|
||||
$refcnt{$sname}++;
|
||||
my $sref = fullname($sname, $sidx,
|
||||
($ref && $type eq "SCALAR"));
|
||||
warn "SEEN: [\$$name(@$idx)] => [\$$sname(@$sidx)] ($ref,$sref)" if $DEBUG;
|
||||
return $sref unless $sname eq $name;
|
||||
$refcnt{$name}++;
|
||||
push(@fixup, fullname($name,$idx)." = $sref");
|
||||
return "do{my \$fix}" if @$idx && $idx->[-1] eq '$';
|
||||
return "'fix'";
|
||||
}
|
||||
$seen{$id} = [$name, $idx];
|
||||
}
|
||||
|
||||
my $out;
|
||||
if ($type eq "SCALAR" || $type eq "REF") {
|
||||
if ($ref) {
|
||||
if ($class && $class eq "Regexp") {
|
||||
my $v = "$rval";
|
||||
|
||||
my $mod = "";
|
||||
if ($v =~ /^\(\?([msix-]+):([\x00-\xFF]*)\)\z/) {
|
||||
$mod = $1;
|
||||
$v = $2;
|
||||
$mod =~ s/-.*//;
|
||||
}
|
||||
|
||||
my $sep = '/';
|
||||
my $sep_count = ($v =~ tr/\///);
|
||||
if ($sep_count) {
|
||||
# see if we can find a better one
|
||||
for ('|', ',', ':', '#') {
|
||||
my $c = eval "\$v =~ tr/\Q$_\E//";
|
||||
#print "SEP $_ $c $sep_count\n";
|
||||
if ($c < $sep_count) {
|
||||
$sep = $_;
|
||||
$sep_count = $c;
|
||||
last if $sep_count == 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
$v =~ s/\Q$sep\E/\\$sep/g;
|
||||
|
||||
$out = "qr$sep$v$sep$mod";
|
||||
undef($class);
|
||||
}
|
||||
else {
|
||||
delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly
|
||||
my $val = _dump($$rval, $name, [@$idx, "\$"]);
|
||||
$out = $class ? "do{\\(my \$o = $val)}" : "\\$val";
|
||||
}
|
||||
} else {
|
||||
if (!defined $$rval) {
|
||||
$out = "undef";
|
||||
}
|
||||
elsif ($$rval =~ /^-?[1-9]\d{0,9}$/ || $$rval eq "0") {
|
||||
$out = $$rval;
|
||||
}
|
||||
else {
|
||||
$out = quote($$rval);
|
||||
}
|
||||
if ($class && !@$idx) {
|
||||
# Top is an object, not a reference to one as perl needs
|
||||
$refcnt{$name}++;
|
||||
my $obj = fullname($name, $idx);
|
||||
my $cl = quote($class);
|
||||
push(@fixup, "bless \\$obj, $cl");
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($type eq "GLOB") {
|
||||
if ($ref) {
|
||||
delete $seen{$id};
|
||||
my $val = _dump($$rval, $name, [@$idx, "*"]);
|
||||
$out = "\\$val";
|
||||
if ($out =~ /^\\\*Symbol::/) {
|
||||
$require{Symbol}++;
|
||||
$out = "Symbol::gensym()";
|
||||
}
|
||||
} else {
|
||||
my $val = "$$rval";
|
||||
$out = "$$rval";
|
||||
|
||||
for my $k (qw(SCALAR ARRAY HASH)) {
|
||||
my $gval = *$$rval{$k};
|
||||
next unless defined $gval;
|
||||
next if $k eq "SCALAR" && ! defined $$gval; # always there
|
||||
my $f = scalar @fixup;
|
||||
push(@fixup, "RESERVED"); # overwritten after _dump() below
|
||||
$gval = _dump($gval, $name, [@$idx, "*{$k}"]);
|
||||
$refcnt{$name}++;
|
||||
my $gname = fullname($name, $idx);
|
||||
$fixup[$f] = "$gname = $gval"; #XXX indent $gval
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($type eq "ARRAY") {
|
||||
my @vals;
|
||||
my $tied = tied_str(tied(@$rval));
|
||||
my $i = 0;
|
||||
for my $v (@$rval) {
|
||||
push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied));
|
||||
$i++;
|
||||
}
|
||||
$out = "[" . format_list(1, $tied, @vals) . "]";
|
||||
}
|
||||
elsif ($type eq "HASH") {
|
||||
my(@keys, @vals);
|
||||
my $tied = tied_str(tied(%$rval));
|
||||
|
||||
# statistics to determine variation in key lengths
|
||||
my $kstat_max = 0;
|
||||
my $kstat_sum = 0;
|
||||
my $kstat_sum2 = 0;
|
||||
|
||||
my @orig_keys = keys %$rval;
|
||||
my $text_keys = 0;
|
||||
for (@orig_keys) {
|
||||
$text_keys++, last unless $_ eq "0" || /^[-+]?[1-9]\d*(?:.\d+)?\z/;
|
||||
}
|
||||
|
||||
if ($text_keys) {
|
||||
@orig_keys = sort @orig_keys;
|
||||
}
|
||||
else {
|
||||
@orig_keys = sort { $a <=> $b } @orig_keys;
|
||||
}
|
||||
|
||||
for my $key (@orig_keys) {
|
||||
my $val = \$rval->{$key};
|
||||
$key = quote($key) if $is_perl_keyword{$key} ||
|
||||
!($key =~ /^[a-zA-Z_]\w{0,19}\z/ ||
|
||||
$key =~ /^-?[1-9]\d{0,8}\z/
|
||||
);
|
||||
|
||||
$kstat_max = length($key) if length($key) > $kstat_max;
|
||||
$kstat_sum += length($key);
|
||||
$kstat_sum2 += length($key)*length($key);
|
||||
|
||||
push(@keys, $key);
|
||||
push(@vals, _dump($$val, $name, [@$idx, "{$key}"], $tied));
|
||||
}
|
||||
my $nl = "";
|
||||
my $klen_pad = 0;
|
||||
my $tmp = "@keys @vals";
|
||||
if (length($tmp) > 60 || $tmp =~ /\n/ || $tied) {
|
||||
$nl = "\n";
|
||||
|
||||
# Determine what padding to add
|
||||
if ($kstat_max < 4) {
|
||||
$klen_pad = $kstat_max;
|
||||
}
|
||||
elsif (@keys >= 2) {
|
||||
my $n = @keys;
|
||||
my $avg = $kstat_sum/$n;
|
||||
my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1));
|
||||
|
||||
# I am not actually very happy with this heuristics
|
||||
if ($stddev / $kstat_max < 0.25) {
|
||||
$klen_pad = $kstat_max;
|
||||
}
|
||||
if ($DEBUG) {
|
||||
push(@keys, "__S");
|
||||
push(@vals, sprintf("%.2f (%d/%.1f/%.1f)",
|
||||
$stddev / $kstat_max,
|
||||
$kstat_max, $avg, $stddev));
|
||||
}
|
||||
}
|
||||
}
|
||||
$out = "{$nl";
|
||||
$out .= " # $tied$nl" if $tied;
|
||||
while (@keys) {
|
||||
my $key = shift @keys;
|
||||
my $val = shift @vals;
|
||||
my $pad = " " x ($klen_pad + 6);
|
||||
$val =~ s/\n/\n$pad/gm;
|
||||
$key = " $key" . " " x ($klen_pad - length($key)) if $nl;
|
||||
$out .= " $key => $val,$nl";
|
||||
}
|
||||
$out =~ s/,$/ / unless $nl;
|
||||
$out .= "}";
|
||||
}
|
||||
elsif ($type eq "CODE") {
|
||||
$out = 'sub { "???" }';
|
||||
}
|
||||
else {
|
||||
warn "Can't handle $type data";
|
||||
$out = "'#$type#'";
|
||||
}
|
||||
|
||||
if ($class && $ref) {
|
||||
$out = "bless($out, " . quote($class) . ")";
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub tied_str {
|
||||
my $tied = shift;
|
||||
if ($tied) {
|
||||
if (my $tied_ref = ref($tied)) {
|
||||
$tied = "tied $tied_ref";
|
||||
}
|
||||
else {
|
||||
$tied = "tied";
|
||||
}
|
||||
}
|
||||
return $tied;
|
||||
}
|
||||
|
||||
sub fullname
|
||||
{
|
||||
my($name, $idx, $ref) = @_;
|
||||
substr($name, 0, 0) = "\$";
|
||||
|
||||
my @i = @$idx; # need copy in order to not modify @$idx
|
||||
if ($ref && @i && $i[0] eq "\$") {
|
||||
shift(@i); # remove one deref
|
||||
$ref = 0;
|
||||
}
|
||||
while (@i && $i[0] eq "\$") {
|
||||
shift @i;
|
||||
$name = "\$$name";
|
||||
}
|
||||
|
||||
my $last_was_index;
|
||||
for my $i (@i) {
|
||||
if ($i eq "*" || $i eq "\$") {
|
||||
$last_was_index = 0;
|
||||
$name = "$i\{$name}";
|
||||
} elsif ($i =~ s/^\*//) {
|
||||
$name .= $i;
|
||||
$last_was_index++;
|
||||
} else {
|
||||
$name .= "->" unless $last_was_index++;
|
||||
$name .= $i;
|
||||
}
|
||||
}
|
||||
$name = "\\$name" if $ref;
|
||||
$name;
|
||||
}
|
||||
|
||||
sub format_list
|
||||
{
|
||||
my $paren = shift;
|
||||
my $comment = shift;
|
||||
my $indent_lim = $paren ? 0 : 1;
|
||||
my $tmp = "@_";
|
||||
if ($comment || (@_ > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/))) {
|
||||
my @elem = @_;
|
||||
for (@elem) { s/^/ /gm; } # indent
|
||||
return "\n" . ($comment ? " # $comment\n" : "") .
|
||||
join(",\n", @elem, "");
|
||||
} else {
|
||||
return join(", ", @_);
|
||||
}
|
||||
}
|
||||
|
||||
my %esc = (
|
||||
"\a" => "\\a",
|
||||
"\b" => "\\b",
|
||||
"\t" => "\\t",
|
||||
"\n" => "\\n",
|
||||
"\f" => "\\f",
|
||||
"\r" => "\\r",
|
||||
"\e" => "\\e",
|
||||
);
|
||||
|
||||
# put a string value in double quotes
|
||||
sub quote {
|
||||
local($_) = $_[0];
|
||||
if (length($_) > 20) {
|
||||
# Check for repeated string
|
||||
if (/^(.{1,5}?)(\1*)$/s) {
|
||||
my $base = quote($1);
|
||||
my $repeat = length($2)/length($1) + 1;
|
||||
return "($base x $repeat)";
|
||||
}
|
||||
}
|
||||
# If there are many '"' we might want to use qq() instead
|
||||
s/([\\\"\@\$])/\\$1/g;
|
||||
return qq("$_") unless /[^\040-\176]/; # fast exit
|
||||
|
||||
s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
|
||||
|
||||
# no need for 3 digits in escape for these
|
||||
s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
|
||||
|
||||
s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
|
||||
s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
|
||||
|
||||
if (length($_) > 40 && !/\\x\{/ && length($_) > (length($_[0]) * 2)) {
|
||||
# too much binary data, better to represent as a hex/base64 string
|
||||
|
||||
# Base64 is more compact than hex when string is longer than
|
||||
# 17 bytes (not counting any require statement needed).
|
||||
# But on the other hand, hex is much more readable.
|
||||
if ($TRY_BASE64 && length($_[0]) > $TRY_BASE64 &&
|
||||
eval { require MIME::Base64 })
|
||||
{
|
||||
$require{"MIME::Base64"}++;
|
||||
return "MIME::Base64::decode(\"" .
|
||||
MIME::Base64::encode($_[0],"") .
|
||||
"\")";
|
||||
}
|
||||
return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")";
|
||||
}
|
||||
|
||||
return qq("$_");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Data::Dump - Pretty printing of data structures
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Data::Dump qw(dump);
|
||||
|
||||
$str = dump(@list)
|
||||
@copy_of_list = eval $str;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a single function called dump() that takes a list
|
||||
of values as its argument and produces a string as its result. The string
|
||||
contains Perl code that, when C<eval>ed, produces a deep copy of the
|
||||
original arguments. The string is formatted for easy reading.
|
||||
|
||||
If dump() is called in a void context, then the dump is printed on
|
||||
STDERR instead of being returned.
|
||||
|
||||
If you don't like importing a function that overrides Perl's
|
||||
not-so-useful builtin, then you can also import the same function as
|
||||
pp(), mnemonic for "pretty-print".
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
The C<Data::Dump> module grew out of frustration with Sarathy's
|
||||
in-most-cases-excellent C<Data::Dumper>. Basic ideas and some code are shared
|
||||
with Sarathy's module.
|
||||
|
||||
The C<Data::Dump> module provides a much simpler interface than
|
||||
C<Data::Dumper>. No OO interface is available and there are no
|
||||
configuration options to worry about (yet :-). The other benefit is
|
||||
that the dump produced does not try to set any variables. It only
|
||||
returns what is needed to produce a copy of the arguments. This means
|
||||
that C<dump("foo")> simply returns C<"foo">, and C<dump(1..5)> simply
|
||||
returns C<(1, 2, 3, 4, 5)>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Data::Dumper>, L<Storable>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
The C<Data::Dump> module is written by Gisle Aas <gisle@aas.no>, based
|
||||
on C<Data::Dumper> by Gurusamy Sarathy <gsar@umich.edu>.
|
||||
|
||||
Copyright 1998-2000,2003-2004 Gisle Aas.
|
||||
Copyright 1996-1998 Gurusamy Sarathy.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
1264
Perl/lib/Data/Dumper.pm
Normal file
1264
Perl/lib/Data/Dumper.pm
Normal file
File diff suppressed because it is too large
Load Diff
833
Perl/lib/DynaLoader.pm
Normal file
833
Perl/lib/DynaLoader.pm
Normal file
@@ -0,0 +1,833 @@
|
||||
|
||||
# Generated from DynaLoader.pm.PL
|
||||
|
||||
package DynaLoader;
|
||||
|
||||
# And Gandalf said: 'Many folk like to know beforehand what is to
|
||||
# be set on the table; but those who have laboured to prepare the
|
||||
# feast like to keep their secret; for wonder makes the words of
|
||||
# praise louder.'
|
||||
|
||||
# (Quote from Tolkien suggested by Anno Siegel.)
|
||||
#
|
||||
# See pod text at end of file for documentation.
|
||||
# See also ext/DynaLoader/README in source tree for other information.
|
||||
#
|
||||
# Tim.Bunce@ig.co.uk, August 1994
|
||||
|
||||
use vars qw($VERSION *AUTOLOAD);
|
||||
|
||||
$VERSION = '1.05'; # avoid typo warning
|
||||
|
||||
require AutoLoader;
|
||||
*AUTOLOAD = \&AutoLoader::AUTOLOAD;
|
||||
|
||||
use Config;
|
||||
|
||||
# The following require can't be removed during maintenance
|
||||
# releases, sadly, because of the risk of buggy code that does
|
||||
# require Carp; Carp::croak "..."; without brackets dying
|
||||
# if Carp hasn't been loaded in earlier compile time. :-(
|
||||
# We'll let those bugs get found on the development track.
|
||||
require Carp if $] < 5.00450;
|
||||
|
||||
# enable debug/trace messages from DynaLoader perl code
|
||||
$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
|
||||
|
||||
#
|
||||
# Flags to alter dl_load_file behaviour. Assigned bits:
|
||||
# 0x01 make symbols available for linking later dl_load_file's.
|
||||
# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
|
||||
# (ignored under VMS; effect is built-in to image linking)
|
||||
#
|
||||
# This is called as a class method $module->dl_load_flags. The
|
||||
# definition here will be inherited and result on "default" loading
|
||||
# behaviour unless a sub-class of DynaLoader defines its own version.
|
||||
#
|
||||
|
||||
sub dl_load_flags { 0x00 }
|
||||
|
||||
# ($dl_dlext, $dlsrc)
|
||||
# = @Config::Config{'dlext', 'dlsrc'};
|
||||
($dl_dlext, $dlsrc) = ('dll','dl_win32.xs')
|
||||
;
|
||||
# Some systems need special handling to expand file specifications
|
||||
# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>)
|
||||
# See dl_expandspec() for more details. Should be harmless but
|
||||
# inefficient to define on systems that don't need it.
|
||||
$Is_VMS = $^O eq 'VMS';
|
||||
$do_expand = $Is_VMS;
|
||||
$Is_MacOS = $^O eq 'MacOS';
|
||||
|
||||
my $Mac_FS;
|
||||
$Mac_FS = eval { require Mac::FileSpec::Unixish } if $Is_MacOS;
|
||||
|
||||
@dl_require_symbols = (); # names of symbols we need
|
||||
@dl_resolve_using = (); # names of files to link with
|
||||
@dl_library_path = (); # path to look for files
|
||||
|
||||
#XSLoader.pm may have added elements before we were required
|
||||
#@dl_shared_objects = (); # shared objects for symbols we have
|
||||
#@dl_librefs = (); # things we have loaded
|
||||
#@dl_modules = (); # Modules we have loaded
|
||||
|
||||
# This is a fix to support DLD's unfortunate desire to relink -lc
|
||||
@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs";
|
||||
|
||||
# Initialise @dl_library_path with the 'standard' library path
|
||||
# for this platform as determined by Configure.
|
||||
|
||||
push(@dl_library_path, split(' ', $Config::Config{libpth}));
|
||||
|
||||
|
||||
my $ldlibpthname = $Config::Config{ldlibpthname};
|
||||
my $ldlibpthname_defined = defined $Config::Config{ldlibpthname};
|
||||
my $pthsep = $Config::Config{path_sep};
|
||||
|
||||
# Add to @dl_library_path any extra directories we can gather from environment
|
||||
# during runtime.
|
||||
|
||||
if ($ldlibpthname_defined &&
|
||||
exists $ENV{$ldlibpthname}) {
|
||||
push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname}));
|
||||
}
|
||||
|
||||
# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH.
|
||||
|
||||
if ($ldlibpthname_defined &&
|
||||
$ldlibpthname ne 'LD_LIBRARY_PATH' &&
|
||||
exists $ENV{LD_LIBRARY_PATH}) {
|
||||
push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH}));
|
||||
}
|
||||
|
||||
|
||||
# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
|
||||
# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
|
||||
boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
|
||||
!defined(&dl_error);
|
||||
|
||||
if ($dl_debug) {
|
||||
print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n";
|
||||
print STDERR "DynaLoader not linked into this perl\n"
|
||||
unless defined(&boot_DynaLoader);
|
||||
}
|
||||
|
||||
1; # End of main code
|
||||
|
||||
|
||||
sub croak { require Carp; Carp::croak(@_) }
|
||||
|
||||
sub bootstrap_inherit {
|
||||
my $module = $_[0];
|
||||
local *isa = *{"$module\::ISA"};
|
||||
local @isa = (@isa, 'DynaLoader');
|
||||
# Cannot goto due to delocalization. Will report errors on a wrong line?
|
||||
bootstrap(@_);
|
||||
}
|
||||
|
||||
# The bootstrap function cannot be autoloaded (without complications)
|
||||
# so we define it here:
|
||||
|
||||
sub bootstrap {
|
||||
# use local vars to enable $module.bs script to edit values
|
||||
local(@args) = @_;
|
||||
local($module) = $args[0];
|
||||
local(@dirs, $file);
|
||||
|
||||
unless ($module) {
|
||||
require Carp;
|
||||
Carp::confess("Usage: DynaLoader::bootstrap(module)");
|
||||
}
|
||||
|
||||
# A common error on platforms which don't support dynamic loading.
|
||||
# Since it's fatal and potentially confusing we give a detailed message.
|
||||
croak("Can't load module $module, dynamic loading not available in this perl.\n".
|
||||
" (You may need to build a new perl executable which either supports\n".
|
||||
" dynamic loading or has the $module module statically linked into it.)\n")
|
||||
unless defined(&dl_load_file);
|
||||
|
||||
my @modparts = split(/::/,$module);
|
||||
my $modfname = $modparts[-1];
|
||||
|
||||
# Some systems have restrictions on files names for DLL's etc.
|
||||
# mod2fname returns appropriate file base name (typically truncated)
|
||||
# It may also edit @modparts if required.
|
||||
$modfname = &mod2fname(\@modparts) if defined &mod2fname;
|
||||
|
||||
# Truncate the module name to 8.3 format for NetWare
|
||||
if (($^O eq 'NetWare') && (length($modfname) > 8)) {
|
||||
$modfname = substr($modfname, 0, 8);
|
||||
}
|
||||
|
||||
my $modpname = join(($Is_MacOS ? ':' : '/'),@modparts);
|
||||
|
||||
print STDERR "DynaLoader::bootstrap for $module ",
|
||||
($Is_MacOS
|
||||
? "(:auto:$modpname:$modfname.$dl_dlext)\n" :
|
||||
"(auto/$modpname/$modfname.$dl_dlext)\n")
|
||||
if $dl_debug;
|
||||
|
||||
foreach (@INC) {
|
||||
chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS;
|
||||
my $dir;
|
||||
if ($Is_MacOS) {
|
||||
my $path = $_;
|
||||
if ($Mac_FS && ! -d $path) {
|
||||
$path = Mac::FileSpec::Unixish::nativize($path);
|
||||
}
|
||||
$path .= ":" unless /:$/;
|
||||
$dir = "${path}auto:$modpname";
|
||||
} else {
|
||||
$dir = "$_/auto/$modpname";
|
||||
}
|
||||
|
||||
next unless -d $dir; # skip over uninteresting directories
|
||||
|
||||
# check for common cases to avoid autoload of dl_findfile
|
||||
my $try = $Is_MacOS ? "$dir:$modfname.$dl_dlext" : "$dir/$modfname.$dl_dlext";
|
||||
last if $file = ($do_expand) ? dl_expandspec($try) : ((-f $try) && $try);
|
||||
|
||||
# no luck here, save dir for possible later dl_findfile search
|
||||
push @dirs, $dir;
|
||||
}
|
||||
# last resort, let dl_findfile have a go in all known locations
|
||||
$file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file;
|
||||
|
||||
croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)")
|
||||
unless $file; # wording similar to error from 'require'
|
||||
|
||||
$file = uc($file) if $Is_VMS && $Config::Config{d_vms_case_sensitive_symbols};
|
||||
my $bootname = "boot_$module";
|
||||
$bootname =~ s/\W/_/g;
|
||||
@dl_require_symbols = ($bootname);
|
||||
|
||||
# Execute optional '.bootstrap' perl script for this module.
|
||||
# The .bs file can be used to configure @dl_resolve_using etc to
|
||||
# match the needs of the individual module on this architecture.
|
||||
my $bs = $file;
|
||||
$bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
|
||||
if (-s $bs) { # only read file if it's not empty
|
||||
print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
|
||||
eval { do $bs; };
|
||||
warn "$bs: $@\n" if $@;
|
||||
}
|
||||
|
||||
my $boot_symbol_ref;
|
||||
|
||||
if ($^O eq 'darwin') {
|
||||
if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) {
|
||||
goto boot; #extension library has already been loaded, e.g. darwin
|
||||
}
|
||||
}
|
||||
|
||||
# Many dynamic extension loading problems will appear to come from
|
||||
# this section of code: XYZ failed at line 123 of DynaLoader.pm.
|
||||
# Often these errors are actually occurring in the initialisation
|
||||
# C code of the extension XS file. Perl reports the error as being
|
||||
# in this perl code simply because this was the last perl code
|
||||
# it executed.
|
||||
|
||||
my $libref = dl_load_file($file, $module->dl_load_flags) or
|
||||
croak("Can't load '$file' for module $module: ".dl_error());
|
||||
|
||||
push(@dl_librefs,$libref); # record loaded object
|
||||
|
||||
my @unresolved = dl_undef_symbols();
|
||||
if (@unresolved) {
|
||||
require Carp;
|
||||
Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
|
||||
}
|
||||
|
||||
$boot_symbol_ref = dl_find_symbol($libref, $bootname) or
|
||||
croak("Can't find '$bootname' symbol in $file\n");
|
||||
|
||||
push(@dl_modules, $module); # record loaded module
|
||||
|
||||
boot:
|
||||
my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
|
||||
|
||||
# See comment block above
|
||||
|
||||
push(@dl_shared_objects, $file); # record files loaded
|
||||
|
||||
&$xs(@args);
|
||||
}
|
||||
|
||||
|
||||
#sub _check_file { # private utility to handle dl_expandspec vs -f tests
|
||||
# my($file) = @_;
|
||||
# return $file if (!$do_expand && -f $file); # the common case
|
||||
# return $file if ( $do_expand && ($file=dl_expandspec($file)));
|
||||
# return undef;
|
||||
#}
|
||||
|
||||
|
||||
# Let autosplit and the autoloader deal with these functions:
|
||||
__END__
|
||||
|
||||
|
||||
sub dl_findfile {
|
||||
# Read ext/DynaLoader/DynaLoader.doc for detailed information.
|
||||
# This function does not automatically consider the architecture
|
||||
# or the perl library auto directories.
|
||||
my (@args) = @_;
|
||||
my (@dirs, $dir); # which directories to search
|
||||
my (@found); # full paths to real files we have found
|
||||
my $dl_ext= 'dll'; # $Config::Config{'dlext'} suffix for perl extensions
|
||||
my $dl_so = 'dll'; # $Config::Config{'so'} suffix for shared libraries
|
||||
|
||||
print STDERR "dl_findfile(@args)\n" if $dl_debug;
|
||||
|
||||
# accumulate directories but process files as they appear
|
||||
arg: foreach(@args) {
|
||||
# Special fast case: full filepath requires no search
|
||||
if ($Is_VMS && m%[:>/\]]% && -f $_) {
|
||||
push(@found,dl_expandspec(VMS::Filespec::vmsify($_)));
|
||||
last arg unless wantarray;
|
||||
next;
|
||||
}
|
||||
elsif ($Is_MacOS) {
|
||||
if (m/:/ && -f $_) {
|
||||
push(@found,$_);
|
||||
last arg unless wantarray;
|
||||
}
|
||||
}
|
||||
elsif (m:/: && -f $_ && !$do_expand) {
|
||||
push(@found,$_);
|
||||
last arg unless wantarray;
|
||||
next;
|
||||
}
|
||||
|
||||
# Deal with directories first:
|
||||
# Using a -L prefix is the preferred option (faster and more robust)
|
||||
if (m:^-L:) { s/^-L//; push(@dirs, $_); next; }
|
||||
|
||||
if ($Is_MacOS) {
|
||||
# Otherwise we try to try to spot directories by a heuristic
|
||||
# (this is a more complicated issue than it first appears)
|
||||
if (m/:/ && -d $_) { push(@dirs, $_); next; }
|
||||
# Only files should get this far...
|
||||
my(@names, $name); # what filenames to look for
|
||||
s/^-l//;
|
||||
push(@names, $_);
|
||||
foreach $dir (@dirs, @dl_library_path) {
|
||||
next unless -d $dir;
|
||||
$dir =~ s/^([^:]+)$/:$1/;
|
||||
$dir =~ s/:$//;
|
||||
foreach $name (@names) {
|
||||
my($file) = "$dir:$name";
|
||||
print STDERR " checking in $dir for $name\n" if $dl_debug;
|
||||
if (-f $file) {
|
||||
push(@found, $file);
|
||||
next arg; # no need to look any further
|
||||
}
|
||||
}
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
# Otherwise we try to try to spot directories by a heuristic
|
||||
# (this is a more complicated issue than it first appears)
|
||||
if (m:/: && -d $_) { push(@dirs, $_); next; }
|
||||
|
||||
# VMS: we may be using native VMS directory syntax instead of
|
||||
# Unix emulation, so check this as well
|
||||
if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; }
|
||||
|
||||
# Only files should get this far...
|
||||
my(@names, $name); # what filenames to look for
|
||||
if (m:-l: ) { # convert -lname to appropriate library name
|
||||
s/-l//;
|
||||
push(@names,"lib$_.$dl_so");
|
||||
push(@names,"lib$_.a");
|
||||
} else { # Umm, a bare name. Try various alternatives:
|
||||
# these should be ordered with the most likely first
|
||||
push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o;
|
||||
push(@names,"$_.$dl_so") unless m/\.$dl_so$/o;
|
||||
push(@names,"lib$_.$dl_so") unless m:/:;
|
||||
push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs";
|
||||
push(@names, $_);
|
||||
}
|
||||
foreach $dir (@dirs, @dl_library_path) {
|
||||
next unless -d $dir;
|
||||
chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS;
|
||||
foreach $name (@names) {
|
||||
my($file) = "$dir/$name";
|
||||
print STDERR " checking in $dir for $name\n" if $dl_debug;
|
||||
$file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file);
|
||||
#$file = _check_file($file);
|
||||
if ($file) {
|
||||
push(@found, $file);
|
||||
next arg; # no need to look any further
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($dl_debug) {
|
||||
foreach(@dirs) {
|
||||
print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_;
|
||||
}
|
||||
print STDERR "dl_findfile found: @found\n";
|
||||
}
|
||||
return $found[0] unless wantarray;
|
||||
@found;
|
||||
}
|
||||
|
||||
|
||||
sub dl_expandspec {
|
||||
my($spec) = @_;
|
||||
# Optional function invoked if DynaLoader.pm sets $do_expand.
|
||||
# Most systems do not require or use this function.
|
||||
# Some systems may implement it in the dl_*.xs file in which case
|
||||
# this autoload version will not be called but is harmless.
|
||||
|
||||
# This function is designed to deal with systems which treat some
|
||||
# 'filenames' in a special way. For example VMS 'Logical Names'
|
||||
# (something like unix environment variables - but different).
|
||||
# This function should recognise such names and expand them into
|
||||
# full file paths.
|
||||
# Must return undef if $spec is invalid or file does not exist.
|
||||
|
||||
my $file = $spec; # default output to input
|
||||
|
||||
if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs
|
||||
require Carp;
|
||||
Carp::croak("dl_expandspec: should be defined in XS file!\n");
|
||||
} else {
|
||||
return undef unless -f $file;
|
||||
}
|
||||
print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug;
|
||||
$file;
|
||||
}
|
||||
|
||||
sub dl_find_symbol_anywhere
|
||||
{
|
||||
my $sym = shift;
|
||||
my $libref;
|
||||
foreach $libref (@dl_librefs) {
|
||||
my $symref = dl_find_symbol($libref,$sym);
|
||||
return $symref if $symref;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DynaLoader - Dynamically load C libraries into Perl code
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package YourPackage;
|
||||
require DynaLoader;
|
||||
@ISA = qw(... DynaLoader ...);
|
||||
bootstrap YourPackage;
|
||||
|
||||
# optional method for 'global' loading
|
||||
sub dl_load_flags { 0x01 }
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This document defines a standard generic interface to the dynamic
|
||||
linking mechanisms available on many platforms. Its primary purpose is
|
||||
to implement automatic dynamic loading of Perl modules.
|
||||
|
||||
This document serves as both a specification for anyone wishing to
|
||||
implement the DynaLoader for a new platform and as a guide for
|
||||
anyone wishing to use the DynaLoader directly in an application.
|
||||
|
||||
The DynaLoader is designed to be a very simple high-level
|
||||
interface that is sufficiently general to cover the requirements
|
||||
of SunOS, HP-UX, NeXT, Linux, VMS and other platforms.
|
||||
|
||||
It is also hoped that the interface will cover the needs of OS/2, NT
|
||||
etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime).
|
||||
|
||||
It must be stressed that the DynaLoader, by itself, is practically
|
||||
useless for accessing non-Perl libraries because it provides almost no
|
||||
Perl-to-C 'glue'. There is, for example, no mechanism for calling a C
|
||||
library function or supplying arguments. A C::DynaLib module
|
||||
is available from CPAN sites which performs that function for some
|
||||
common system types. And since the year 2000, there's also Inline::C,
|
||||
a module that allows you to write Perl subroutines in C. Also available
|
||||
from your local CPAN site.
|
||||
|
||||
DynaLoader Interface Summary
|
||||
|
||||
@dl_library_path
|
||||
@dl_resolve_using
|
||||
@dl_require_symbols
|
||||
$dl_debug
|
||||
@dl_librefs
|
||||
@dl_modules
|
||||
@dl_shared_objects
|
||||
Implemented in:
|
||||
bootstrap($modulename) Perl
|
||||
@filepaths = dl_findfile(@names) Perl
|
||||
$flags = $modulename->dl_load_flags Perl
|
||||
$symref = dl_find_symbol_anywhere($symbol) Perl
|
||||
|
||||
$libref = dl_load_file($filename, $flags) C
|
||||
$status = dl_unload_file($libref) C
|
||||
$symref = dl_find_symbol($libref, $symbol) C
|
||||
@symbols = dl_undef_symbols() C
|
||||
dl_install_xsub($name, $symref [, $filename]) C
|
||||
$message = dl_error C
|
||||
|
||||
=over 4
|
||||
|
||||
=item @dl_library_path
|
||||
|
||||
The standard/default list of directories in which dl_findfile() will
|
||||
search for libraries etc. Directories are searched in order:
|
||||
$dl_library_path[0], [1], ... etc
|
||||
|
||||
@dl_library_path is initialised to hold the list of 'normal' directories
|
||||
(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should
|
||||
ensure portability across a wide range of platforms.
|
||||
|
||||
@dl_library_path should also be initialised with any other directories
|
||||
that can be determined from the environment at runtime (such as
|
||||
LD_LIBRARY_PATH for SunOS).
|
||||
|
||||
After initialisation @dl_library_path can be manipulated by an
|
||||
application using push and unshift before calling dl_findfile().
|
||||
Unshift can be used to add directories to the front of the search order
|
||||
either to save search time or to override libraries with the same name
|
||||
in the 'normal' directories.
|
||||
|
||||
The load function that dl_load_file() calls may require an absolute
|
||||
pathname. The dl_findfile() function and @dl_library_path can be
|
||||
used to search for and return the absolute pathname for the
|
||||
library/object that you wish to load.
|
||||
|
||||
=item @dl_resolve_using
|
||||
|
||||
A list of additional libraries or other shared objects which can be
|
||||
used to resolve any undefined symbols that might be generated by a
|
||||
later call to load_file().
|
||||
|
||||
This is only required on some platforms which do not handle dependent
|
||||
libraries automatically. For example the Socket Perl extension
|
||||
library (F<auto/Socket/Socket.so>) contains references to many socket
|
||||
functions which need to be resolved when it's loaded. Most platforms
|
||||
will automatically know where to find the 'dependent' library (e.g.,
|
||||
F</usr/lib/libsocket.so>). A few platforms need to be told the
|
||||
location of the dependent library explicitly. Use @dl_resolve_using
|
||||
for this.
|
||||
|
||||
Example usage:
|
||||
|
||||
@dl_resolve_using = dl_findfile('-lsocket');
|
||||
|
||||
=item @dl_require_symbols
|
||||
|
||||
A list of one or more symbol names that are in the library/object file
|
||||
to be dynamically loaded. This is only required on some platforms.
|
||||
|
||||
=item @dl_librefs
|
||||
|
||||
An array of the handles returned by successful calls to dl_load_file(),
|
||||
made by bootstrap, in the order in which they were loaded.
|
||||
Can be used with dl_find_symbol() to look for a symbol in any of
|
||||
the loaded files.
|
||||
|
||||
=item @dl_modules
|
||||
|
||||
An array of module (package) names that have been bootstrap'ed.
|
||||
|
||||
=item @dl_shared_objects
|
||||
|
||||
An array of file names for the shared objects that were loaded.
|
||||
|
||||
=item dl_error()
|
||||
|
||||
Syntax:
|
||||
|
||||
$message = dl_error();
|
||||
|
||||
Error message text from the last failed DynaLoader function. Note
|
||||
that, similar to errno in unix, a successful function call does not
|
||||
reset this message.
|
||||
|
||||
Implementations should detect the error as soon as it occurs in any of
|
||||
the other functions and save the corresponding message for later
|
||||
retrieval. This will avoid problems on some platforms (such as SunOS)
|
||||
where the error message is very temporary (e.g., dlerror()).
|
||||
|
||||
=item $dl_debug
|
||||
|
||||
Internal debugging messages are enabled when $dl_debug is set true.
|
||||
Currently setting $dl_debug only affects the Perl side of the
|
||||
DynaLoader. These messages should help an application developer to
|
||||
resolve any DynaLoader usage problems.
|
||||
|
||||
$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined.
|
||||
|
||||
For the DynaLoader developer/porter there is a similar debugging
|
||||
variable added to the C code (see dlutils.c) and enabled if Perl was
|
||||
built with the B<-DDEBUGGING> flag. This can also be set via the
|
||||
PERL_DL_DEBUG environment variable. Set to 1 for minimal information or
|
||||
higher for more.
|
||||
|
||||
=item dl_findfile()
|
||||
|
||||
Syntax:
|
||||
|
||||
@filepaths = dl_findfile(@names)
|
||||
|
||||
Determine the full paths (including file suffix) of one or more
|
||||
loadable files given their generic names and optionally one or more
|
||||
directories. Searches directories in @dl_library_path by default and
|
||||
returns an empty list if no files were found.
|
||||
|
||||
Names can be specified in a variety of platform independent forms. Any
|
||||
names in the form B<-lname> are converted into F<libname.*>, where F<.*> is
|
||||
an appropriate suffix for the platform.
|
||||
|
||||
If a name does not already have a suitable prefix and/or suffix then
|
||||
the corresponding file will be searched for by trying combinations of
|
||||
prefix and suffix appropriate to the platform: "$name.o", "lib$name.*"
|
||||
and "$name".
|
||||
|
||||
If any directories are included in @names they are searched before
|
||||
@dl_library_path. Directories may be specified as B<-Ldir>. Any other
|
||||
names are treated as filenames to be searched for.
|
||||
|
||||
Using arguments of the form C<-Ldir> and C<-lname> is recommended.
|
||||
|
||||
Example:
|
||||
|
||||
@dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix));
|
||||
|
||||
|
||||
=item dl_expandspec()
|
||||
|
||||
Syntax:
|
||||
|
||||
$filepath = dl_expandspec($spec)
|
||||
|
||||
Some unusual systems, such as VMS, require special filename handling in
|
||||
order to deal with symbolic names for files (i.e., VMS's Logical Names).
|
||||
|
||||
To support these systems a dl_expandspec() function can be implemented
|
||||
either in the F<dl_*.xs> file or code can be added to the autoloadable
|
||||
dl_expandspec() function in F<DynaLoader.pm>. See F<DynaLoader.pm> for
|
||||
more information.
|
||||
|
||||
=item dl_load_file()
|
||||
|
||||
Syntax:
|
||||
|
||||
$libref = dl_load_file($filename, $flags)
|
||||
|
||||
Dynamically load $filename, which must be the path to a shared object
|
||||
or library. An opaque 'library reference' is returned as a handle for
|
||||
the loaded object. Returns undef on error.
|
||||
|
||||
The $flags argument to alters dl_load_file behaviour.
|
||||
Assigned bits:
|
||||
|
||||
0x01 make symbols available for linking later dl_load_file's.
|
||||
(only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
|
||||
(ignored under VMS; this is a normal part of image linking)
|
||||
|
||||
(On systems that provide a handle for the loaded object such as SunOS
|
||||
and HPUX, $libref will be that handle. On other systems $libref will
|
||||
typically be $filename or a pointer to a buffer containing $filename.
|
||||
The application should not examine or alter $libref in any way.)
|
||||
|
||||
This is the function that does the real work. It should use the
|
||||
current values of @dl_require_symbols and @dl_resolve_using if required.
|
||||
|
||||
SunOS: dlopen($filename)
|
||||
HP-UX: shl_load($filename)
|
||||
Linux: dld_create_reference(@dl_require_symbols); dld_link($filename)
|
||||
NeXT: rld_load($filename, @dl_resolve_using)
|
||||
VMS: lib$find_image_symbol($filename,$dl_require_symbols[0])
|
||||
|
||||
(The dlopen() function is also used by Solaris and some versions of
|
||||
Linux, and is a common choice when providing a "wrapper" on other
|
||||
mechanisms as is done in the OS/2 port.)
|
||||
|
||||
=item dl_unload_file()
|
||||
|
||||
Syntax:
|
||||
|
||||
$status = dl_unload_file($libref)
|
||||
|
||||
Dynamically unload $libref, which must be an opaque 'library reference' as
|
||||
returned from dl_load_file. Returns one on success and zero on failure.
|
||||
|
||||
This function is optional and may not necessarily be provided on all platforms.
|
||||
If it is defined, it is called automatically when the interpreter exits for
|
||||
every shared object or library loaded by DynaLoader::bootstrap. All such
|
||||
library references are stored in @dl_librefs by DynaLoader::Bootstrap as it
|
||||
loads the libraries. The files are unloaded in last-in, first-out order.
|
||||
|
||||
This unloading is usually necessary when embedding a shared-object perl (e.g.
|
||||
one configured with -Duseshrplib) within a larger application, and the perl
|
||||
interpreter is created and destroyed several times within the lifetime of the
|
||||
application. In this case it is possible that the system dynamic linker will
|
||||
unload and then subsequently reload the shared libperl without relocating any
|
||||
references to it from any files DynaLoaded by the previous incarnation of the
|
||||
interpreter. As a result, any shared objects opened by DynaLoader may point to
|
||||
a now invalid 'ghost' of the libperl shared object, causing apparently random
|
||||
memory corruption and crashes. This behaviour is most commonly seen when using
|
||||
Apache and mod_perl built with the APXS mechanism.
|
||||
|
||||
SunOS: dlclose($libref)
|
||||
HP-UX: ???
|
||||
Linux: ???
|
||||
NeXT: ???
|
||||
VMS: ???
|
||||
|
||||
(The dlclose() function is also used by Solaris and some versions of
|
||||
Linux, and is a common choice when providing a "wrapper" on other
|
||||
mechanisms as is done in the OS/2 port.)
|
||||
|
||||
=item dl_load_flags()
|
||||
|
||||
Syntax:
|
||||
|
||||
$flags = dl_load_flags $modulename;
|
||||
|
||||
Designed to be a method call, and to be overridden by a derived class
|
||||
(i.e. a class which has DynaLoader in its @ISA). The definition in
|
||||
DynaLoader itself returns 0, which produces standard behavior from
|
||||
dl_load_file().
|
||||
|
||||
=item dl_find_symbol()
|
||||
|
||||
Syntax:
|
||||
|
||||
$symref = dl_find_symbol($libref, $symbol)
|
||||
|
||||
Return the address of the symbol $symbol or C<undef> if not found. If the
|
||||
target system has separate functions to search for symbols of different
|
||||
types then dl_find_symbol() should search for function symbols first and
|
||||
then other types.
|
||||
|
||||
The exact manner in which the address is returned in $symref is not
|
||||
currently defined. The only initial requirement is that $symref can
|
||||
be passed to, and understood by, dl_install_xsub().
|
||||
|
||||
SunOS: dlsym($libref, $symbol)
|
||||
HP-UX: shl_findsym($libref, $symbol)
|
||||
Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol)
|
||||
NeXT: rld_lookup("_$symbol")
|
||||
VMS: lib$find_image_symbol($libref,$symbol)
|
||||
|
||||
|
||||
=item dl_find_symbol_anywhere()
|
||||
|
||||
Syntax:
|
||||
|
||||
$symref = dl_find_symbol_anywhere($symbol)
|
||||
|
||||
Applies dl_find_symbol() to the members of @dl_librefs and returns
|
||||
the first match found.
|
||||
|
||||
=item dl_undef_symbols()
|
||||
|
||||
Example
|
||||
|
||||
@symbols = dl_undef_symbols()
|
||||
|
||||
Return a list of symbol names which remain undefined after load_file().
|
||||
Returns C<()> if not known. Don't worry if your platform does not provide
|
||||
a mechanism for this. Most do not need it and hence do not provide it,
|
||||
they just return an empty list.
|
||||
|
||||
|
||||
=item dl_install_xsub()
|
||||
|
||||
Syntax:
|
||||
|
||||
dl_install_xsub($perl_name, $symref [, $filename])
|
||||
|
||||
Create a new Perl external subroutine named $perl_name using $symref as
|
||||
a pointer to the function which implements the routine. This is simply
|
||||
a direct call to newXSUB(). Returns a reference to the installed
|
||||
function.
|
||||
|
||||
The $filename parameter is used by Perl to identify the source file for
|
||||
the function if required by die(), caller() or the debugger. If
|
||||
$filename is not defined then "DynaLoader" will be used.
|
||||
|
||||
|
||||
=item bootstrap()
|
||||
|
||||
Syntax:
|
||||
|
||||
bootstrap($module)
|
||||
|
||||
This is the normal entry point for automatic dynamic loading in Perl.
|
||||
|
||||
It performs the following actions:
|
||||
|
||||
=over 8
|
||||
|
||||
=item *
|
||||
|
||||
locates an auto/$module directory by searching @INC
|
||||
|
||||
=item *
|
||||
|
||||
uses dl_findfile() to determine the filename to load
|
||||
|
||||
=item *
|
||||
|
||||
sets @dl_require_symbols to C<("boot_$module")>
|
||||
|
||||
=item *
|
||||
|
||||
executes an F<auto/$module/$module.bs> file if it exists
|
||||
(typically used to add to @dl_resolve_using any files which
|
||||
are required to load the module on the current platform)
|
||||
|
||||
=item *
|
||||
|
||||
calls dl_load_flags() to determine how to load the file.
|
||||
|
||||
=item *
|
||||
|
||||
calls dl_load_file() to load the file
|
||||
|
||||
=item *
|
||||
|
||||
calls dl_undef_symbols() and warns if any symbols are undefined
|
||||
|
||||
=item *
|
||||
|
||||
calls dl_find_symbol() for "boot_$module"
|
||||
|
||||
=item *
|
||||
|
||||
calls dl_install_xsub() to install it as "${module}::bootstrap"
|
||||
|
||||
=item *
|
||||
|
||||
calls &{"${module}::bootstrap"} to bootstrap the module (actually
|
||||
it uses the function reference returned by dl_install_xsub for speed)
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tim Bunce, 11 August 1994.
|
||||
|
||||
This interface is based on the work and comments of (in no particular
|
||||
order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno
|
||||
Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others.
|
||||
|
||||
Larry Wall designed the elegant inherited bootstrap mechanism and
|
||||
implemented the first Perl 5 dynamic loader using it.
|
||||
|
||||
Solaris global loading added by Nick Ing-Simmons with design/coding
|
||||
assistance from Tim Bunce, January 1996.
|
||||
|
||||
=cut
|
||||
222
Perl/lib/Errno.pm
Normal file
222
Perl/lib/Errno.pm
Normal file
@@ -0,0 +1,222 @@
|
||||
#
|
||||
# This file is auto-generated. ***ANY*** changes here will be lost
|
||||
#
|
||||
|
||||
package Errno;
|
||||
our (@EXPORT_OK,%EXPORT_TAGS,@ISA,$VERSION,%errno,$AUTOLOAD);
|
||||
use Exporter ();
|
||||
use Config;
|
||||
use strict;
|
||||
|
||||
"$Config{'archname'}-$Config{'osvers'}" eq
|
||||
"MSWin32-x86-multi-thread-4.0" or
|
||||
die "Errno architecture (MSWin32-x86-multi-thread-4.0) does not match executable architecture ($Config{'archname'}-$Config{'osvers'})";
|
||||
|
||||
$VERSION = "1.09_01";
|
||||
$VERSION = eval $VERSION;
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
@EXPORT_OK = qw(EROFS ESHUTDOWN EPROTONOSUPPORT ENFILE ENOLCK
|
||||
EADDRINUSE ECONNABORTED EBADF EDEADLK ENOTDIR EINVAL ENOTTY EXDEV
|
||||
ELOOP ECONNREFUSED EISCONN EFBIG ECONNRESET EPFNOSUPPORT ENOENT
|
||||
EDISCON EWOULDBLOCK EDOM EMSGSIZE EDESTADDRREQ ENOTSOCK EIO ENOSPC
|
||||
ENOBUFS EINPROGRESS ERANGE EADDRNOTAVAIL EAFNOSUPPORT ENOSYS EINTR
|
||||
EHOSTDOWN EREMOTE EILSEQ ENOMEM ENOTCONN ENETUNREACH EPIPE ESTALE
|
||||
EDQUOT EUSERS EOPNOTSUPP ESPIPE EALREADY EMFILE ENAMETOOLONG EACCES
|
||||
ENOEXEC EISDIR EPROCLIM EBUSY E2BIG EPERM EEXIST ETOOMANYREFS
|
||||
ESOCKTNOSUPPORT ETIMEDOUT ENXIO ESRCH ENODEV EFAULT EAGAIN EMLINK
|
||||
EDEADLOCK ENOPROTOOPT ECHILD ENETDOWN EHOSTUNREACH EPROTOTYPE
|
||||
ENETRESET ENOTEMPTY);
|
||||
|
||||
%EXPORT_TAGS = (
|
||||
POSIX => [qw(
|
||||
E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY
|
||||
EBADF EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK
|
||||
EDESTADDRREQ EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH
|
||||
EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
|
||||
EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS
|
||||
ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTCONN
|
||||
ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT
|
||||
EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE EROFS
|
||||
ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS
|
||||
EUSERS EWOULDBLOCK EXDEV
|
||||
)]
|
||||
);
|
||||
|
||||
sub EPERM () { 1 }
|
||||
sub ENOENT () { 2 }
|
||||
sub ESRCH () { 3 }
|
||||
sub EINTR () { 4 }
|
||||
sub EIO () { 5 }
|
||||
sub ENXIO () { 6 }
|
||||
sub E2BIG () { 7 }
|
||||
sub ENOEXEC () { 8 }
|
||||
sub EBADF () { 9 }
|
||||
sub ECHILD () { 10 }
|
||||
sub EAGAIN () { 11 }
|
||||
sub ENOMEM () { 12 }
|
||||
sub EACCES () { 13 }
|
||||
sub EFAULT () { 14 }
|
||||
sub EBUSY () { 16 }
|
||||
sub EEXIST () { 17 }
|
||||
sub EXDEV () { 18 }
|
||||
sub ENODEV () { 19 }
|
||||
sub ENOTDIR () { 20 }
|
||||
sub EISDIR () { 21 }
|
||||
sub EINVAL () { 22 }
|
||||
sub ENFILE () { 23 }
|
||||
sub EMFILE () { 24 }
|
||||
sub ENOTTY () { 25 }
|
||||
sub EFBIG () { 27 }
|
||||
sub ENOSPC () { 28 }
|
||||
sub ESPIPE () { 29 }
|
||||
sub EROFS () { 30 }
|
||||
sub EMLINK () { 31 }
|
||||
sub EPIPE () { 32 }
|
||||
sub EDOM () { 33 }
|
||||
sub ERANGE () { 34 }
|
||||
sub EDEADLK () { 36 }
|
||||
sub EDEADLOCK () { 36 }
|
||||
sub ENAMETOOLONG () { 38 }
|
||||
sub ENOLCK () { 39 }
|
||||
sub ENOSYS () { 40 }
|
||||
sub ENOTEMPTY () { 41 }
|
||||
sub EILSEQ () { 42 }
|
||||
sub EWOULDBLOCK () { 10035 }
|
||||
sub EINPROGRESS () { 10036 }
|
||||
sub EALREADY () { 10037 }
|
||||
sub ENOTSOCK () { 10038 }
|
||||
sub EDESTADDRREQ () { 10039 }
|
||||
sub EMSGSIZE () { 10040 }
|
||||
sub EPROTOTYPE () { 10041 }
|
||||
sub ENOPROTOOPT () { 10042 }
|
||||
sub EPROTONOSUPPORT () { 10043 }
|
||||
sub ESOCKTNOSUPPORT () { 10044 }
|
||||
sub EOPNOTSUPP () { 10045 }
|
||||
sub EPFNOSUPPORT () { 10046 }
|
||||
sub EAFNOSUPPORT () { 10047 }
|
||||
sub EADDRINUSE () { 10048 }
|
||||
sub EADDRNOTAVAIL () { 10049 }
|
||||
sub ENETDOWN () { 10050 }
|
||||
sub ENETUNREACH () { 10051 }
|
||||
sub ENETRESET () { 10052 }
|
||||
sub ECONNABORTED () { 10053 }
|
||||
sub ECONNRESET () { 10054 }
|
||||
sub ENOBUFS () { 10055 }
|
||||
sub EISCONN () { 10056 }
|
||||
sub ENOTCONN () { 10057 }
|
||||
sub ESHUTDOWN () { 10058 }
|
||||
sub ETOOMANYREFS () { 10059 }
|
||||
sub ETIMEDOUT () { 10060 }
|
||||
sub ECONNREFUSED () { 10061 }
|
||||
sub ELOOP () { 10062 }
|
||||
sub EHOSTDOWN () { 10064 }
|
||||
sub EHOSTUNREACH () { 10065 }
|
||||
sub EPROCLIM () { 10067 }
|
||||
sub EUSERS () { 10068 }
|
||||
sub EDQUOT () { 10069 }
|
||||
sub ESTALE () { 10070 }
|
||||
sub EREMOTE () { 10071 }
|
||||
sub EDISCON () { 10101 }
|
||||
|
||||
sub TIEHASH { bless [] }
|
||||
|
||||
sub FETCH {
|
||||
my ($self, $errname) = @_;
|
||||
my $proto = prototype("Errno::$errname");
|
||||
my $errno = "";
|
||||
if (defined($proto) && $proto eq "") {
|
||||
no strict 'refs';
|
||||
$errno = &$errname;
|
||||
$errno = 0 unless $! == $errno;
|
||||
}
|
||||
return $errno;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
require Carp;
|
||||
Carp::confess("ERRNO hash is read only!");
|
||||
}
|
||||
|
||||
*CLEAR = \&STORE;
|
||||
*DELETE = \&STORE;
|
||||
|
||||
sub NEXTKEY {
|
||||
my($k,$v);
|
||||
while(($k,$v) = each %Errno::) {
|
||||
my $proto = prototype("Errno::$k");
|
||||
last if (defined($proto) && $proto eq "");
|
||||
}
|
||||
$k
|
||||
}
|
||||
|
||||
sub FIRSTKEY {
|
||||
my $s = scalar keys %Errno::; # initialize iterator
|
||||
goto &NEXTKEY;
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my ($self, $errname) = @_;
|
||||
my $r = ref $errname;
|
||||
my $proto = !$r || $r eq 'CODE' ? prototype($errname) : undef;
|
||||
defined($proto) && $proto eq "";
|
||||
}
|
||||
|
||||
tie %!, __PACKAGE__;
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Errno - System errno constants
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Errno qw(EINTR EIO :POSIX);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Errno> defines and conditionally exports all the error constants
|
||||
defined in your system C<errno.h> include file. It has a single export
|
||||
tag, C<:POSIX>, which will export all POSIX defined error numbers.
|
||||
|
||||
C<Errno> also makes C<%!> magic such that each element of C<%!> has a
|
||||
non-zero value only if C<$!> is set to that value. For example:
|
||||
|
||||
use Errno;
|
||||
|
||||
unless (open(FH, "/fangorn/spouse")) {
|
||||
if ($!{ENOENT}) {
|
||||
warn "Get a wife!\n";
|
||||
} else {
|
||||
warn "This path is barred: $!";
|
||||
}
|
||||
}
|
||||
|
||||
If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
|
||||
returns C<"">. You may use C<exists $!{EFOO}> to check whether the
|
||||
constant is available on the system.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Importing a particular constant may not be very portable, because the
|
||||
import will fail on platforms that do not have that constant. A more
|
||||
portable way to set C<$!> to a valid value is to use:
|
||||
|
||||
if (exists &Errno::EFOO) {
|
||||
$! = &Errno::EFOO;
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Graham Barr <gbarr@pobox.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1997-8 Graham Barr. All rights reserved.
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
440
Perl/lib/Exporter.pm
Normal file
440
Perl/lib/Exporter.pm
Normal file
@@ -0,0 +1,440 @@
|
||||
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
|
||||
88
Perl/lib/bytes.pm
Normal file
88
Perl/lib/bytes.pm
Normal file
@@ -0,0 +1,88 @@
|
||||
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
|
||||
1434
Perl/lib/overload.pm
Normal file
1434
Perl/lib/overload.pm
Normal file
File diff suppressed because it is too large
Load Diff
136
Perl/lib/strict.pm
Normal file
136
Perl/lib/strict.pm
Normal file
@@ -0,0 +1,136 @@
|
||||
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
|
||||
82
Perl/lib/vars.pm
Normal file
82
Perl/lib/vars.pm
Normal file
@@ -0,0 +1,82 @@
|
||||
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
|
||||
497
Perl/lib/warnings.pm
Normal file
497
Perl/lib/warnings.pm
Normal file
@@ -0,0 +1,497 @@
|
||||
# -*- 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:
|
||||
51
Perl/lib/warnings/register.pm
Normal file
51
Perl/lib/warnings/register.pm
Normal file
@@ -0,0 +1,51 @@
|
||||
package warnings::register;
|
||||
|
||||
our $VERSION = '1.01';
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
warnings::register - warnings import function
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use warnings::register;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Creates a warnings category with the same name as the current package.
|
||||
|
||||
See L<warnings> and L<perllexwarn> for more information on this module's
|
||||
usage.
|
||||
|
||||
=cut
|
||||
|
||||
require warnings;
|
||||
|
||||
sub mkMask
|
||||
{
|
||||
my ($bit) = @_;
|
||||
my $mask = "";
|
||||
|
||||
vec($mask, $bit, 1) = 1;
|
||||
return $mask;
|
||||
}
|
||||
|
||||
sub import
|
||||
{
|
||||
shift;
|
||||
my $package = (caller(0))[0];
|
||||
if (! defined $warnings::Bits{$package}) {
|
||||
$warnings::Bits{$package} = mkMask($warnings::LAST_BIT);
|
||||
vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1;
|
||||
$warnings::Offsets{$package} = $warnings::LAST_BIT ++;
|
||||
foreach my $k (keys %warnings::Bits) {
|
||||
vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0;
|
||||
}
|
||||
$warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT);
|
||||
vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user