nephacks/cstrike15_src
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

initial

Browse Source
This commit is contained in:
nephacks
2025-06-04 03:22:50 +02:00
parent f234f23848
commit f12416cffd
14243 changed files with 6446499 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

237
devtools/srcsrv/perl/lib/Carp.pm Normal file
View File

@@ -0,0 +1,237 @@
package Carp;
our $VERSION = '1.0701';
# this file is an utra-lightweight stub. The first time a function is
# called, Carp::Heavy is loaded, and the real short/longmessmess_jmp
# subs are installed
our $MaxEvalLen = 0;
our $Verbose = 0;
our $CarpLevel = 0;
our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
our $MaxArgNums = 8; # How many arguments to print. 0 = all.
require Exporter;
our @ISA = ('Exporter');
our @EXPORT = qw(confess croak carp);
our @EXPORT_OK = qw(cluck verbose longmess shortmess);
our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
# 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'; @_ }
# fixed hooks for stashes to point to
sub longmess { goto &longmess_jmp }
sub shortmess { goto &shortmess_jmp }
# these two are replaced when Carp::Heavy is loaded
sub longmess_jmp {
local($@, $!);
eval { require Carp::Heavy };
return $@ if $@;
goto &longmess_real;
}
sub shortmess_jmp {
local($@, $!);
eval { require Carp::Heavy };
return $@ if $@;
goto &shortmess_real;
}
sub croak { die shortmess @_ }
sub confess { die longmess @_ }
sub carp { warn shortmess @_ }
sub cluck { warn longmess @_ }
1;
__END__
=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
=head1 SYNOPSIS
use Carp;
croak "We're outta here!";
use Carp qw(cluck);
cluck "This is how we got here!";
=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 C<carp>
or C<croak> 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 c<carp> and c<croak> work.
What they do is search the call-stack for a function call stack where
they have not been told that there shouldn't be an error. If every
call is marked safe, they give up and give a full stack backtrace
instead. In other words they presume that the first likely looking
potential suspect is guilty. Their 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 C<@CARP_NOT>, or
(if that array is empty) C<@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 C<@ISA>
with C<@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 Perl's warning system (eg Carp itself) is safe.
(This rule is what keeps it from reporting the error at the
point where you call C<carp> or C<croak>.)
=item 6.
C<$Carp::CarpLevel> can be set to skip a fixed number of additional
call levels. Using this is not recommended because it is very
difficult to get it to behave correctly.
=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.
=head1 GLOBAL VARIABLES
=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> and C<cluck> generate stack backtraces
just like C<cluck> and C<confess>. This is how C<use Carp 'verbose'>
is implemented internally.
Defaults to C<0>.
=head2 %Carp::Internal
This says what packages are internal to Perl. C<Carp> will never
report an error as being from a line in a package that is internal to
Perl. For example:
$Carp::Internal{ __PACKAGE__ }++;
# time passes...
sub foo { ... or confess("whatever") };
would give a full stack backtrace starting from the first caller
outside of __PACKAGE__. (Unless that package was also internal to
Perl.)
=head2 %Carp::CarpInternal
This says which packages are internal to Perl's warning system. For
generating a full stack backtrace this is the same as being internal
to Perl, the stack backtrace will not start inside packages that are
listed in C<%Carp::CarpInternal>. But it is slightly different for
the summary message generated by C<carp> or C<croak>. There errors
will not be reported on any lines that are calling packages in
C<%Carp::CarpInternal>.
For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
Therefore the full stack backtrace from C<confess> will not start
inside of C<Carp>, and the short message from calling C<croak> is
not placed on the line where C<croak> was called.
=head2 $Carp::CarpLevel
This variable determines how many additional call frames are to be
skipped that would not otherwise be when reporting where an error
occurred on a call to one of C<Carp>'s functions. It is fairly easy
to count these call frames on calls that generate a full stack
backtrace. However it is much harder to do this accounting for calls
that generate a short message. Usually people skip too many call
frames. If they are lucky they skip enough that C<Carp> goes all of
the way through the call stack, realizes that something is wrong, and
then generates a full stack backtrace. If they are unlucky then the
error is reported from somewhere misleading very high in the call
stack.
Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use
C<@CARP_NOT>, C<%Carp::Internal> and %Carp::CarpInternal>.
Defaults to C<0>.
=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.

441
devtools/srcsrv/perl/lib/Exporter.pm Normal file
View File

@@ -0,0 +1,441 @@
package Exporter;
require 5.006;
# Be lean.
#use strict;
#no strict 'refs';
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
our $VERSION = '5.60';
our (%Cache);
# Carp does this now for us, so we can finally live w/o Carp
#$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

244
devtools/srcsrv/perl/lib/Fcntl.pm Normal file
View File

@@ -0,0 +1,244 @@
package Fcntl;
=head1 NAME
Fcntl - load the C Fcntl.h defines
=head1 SYNOPSIS
use Fcntl;
use Fcntl qw(:DEFAULT :flock);
=head1 DESCRIPTION
This module is just a translation of the C F<fcntl.h> file.
Unlike the old mechanism of requiring a translated F<fcntl.ph>
file, this uses the B<h2xs> program (see the Perl source distribution)
and your native C compiler. This means that it has a
far more likely chance of getting the numbers right.
=head1 NOTE
Only C<#define> symbols get translated; you must still correctly
pack up your own arguments to pass as args for locking functions, etc.
=head1 EXPORTED SYMBOLS
By default your system's F_* and O_* constants (eg, F_DUPFD and
O_CREAT) and the FD_CLOEXEC constant are exported into your namespace.
You can request that the flock() constants (LOCK_SH, LOCK_EX, LOCK_NB
and LOCK_UN) be provided by using the tag C<:flock>. See L<Exporter>.
You can request that the old constants (FAPPEND, FASYNC, FCREAT,
FDEFER, FEXCL, FNDELAY, FNONBLOCK, FSYNC, FTRUNC) be provided for
compatibility reasons by using the tag C<:Fcompat>. For new
applications the newer versions of these constants are suggested
(O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK,
O_SYNC, O_TRUNC).
For ease of use also the SEEK_* constants (for seek() and sysseek(),
e.g. SEEK_END) and the S_I* constants (for chmod() and stat()) are
available for import. They can be imported either separately or using
the tags C<:seek> and C<:mode>.
Please refer to your native fcntl(2), open(2), fseek(3), lseek(2)
(equal to Perl's seek() and sysseek(), respectively), and chmod(2)
documentation to see what constants are implemented in your system.
See L<perlopentut> to learn about the uses of the O_* constants
with sysopen().
See L<perlfunc/seek> and L<perlfunc/sysseek> about the SEEK_* constants.
See L<perlfunc/stat> about the S_I* constants.
=cut
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD);
require Exporter;
use XSLoader ();
@ISA = qw(Exporter);
BEGIN {
$VERSION = "1.06";
}
# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)
@EXPORT =
qw(
FD_CLOEXEC
F_ALLOCSP
F_ALLOCSP64
F_COMPAT
F_DUP2FD
F_DUPFD
F_EXLCK
F_FREESP
F_FREESP64
F_FSYNC
F_FSYNC64
F_GETFD
F_GETFL
F_GETLK
F_GETLK64
F_GETOWN
F_NODNY
F_POSIX
F_RDACC
F_RDDNY
F_RDLCK
F_RWACC
F_RWDNY
F_SETFD
F_SETFL
F_SETLK
F_SETLK64
F_SETLKW
F_SETLKW64
F_SETOWN
F_SHARE
F_SHLCK
F_UNLCK
F_UNSHARE
F_WRACC
F_WRDNY
F_WRLCK
O_ACCMODE
O_ALIAS
O_APPEND
O_ASYNC
O_BINARY
O_CREAT
O_DEFER
O_DIRECT
O_DIRECTORY
O_DSYNC
O_EXCL
O_EXLOCK
O_LARGEFILE
O_NDELAY
O_NOCTTY
O_NOFOLLOW
O_NOINHERIT
O_NONBLOCK
O_RANDOM
O_RAW
O_RDONLY
O_RDWR
O_RSRC
O_RSYNC
O_SEQUENTIAL
O_SHLOCK
O_SYNC
O_TEMPORARY
O_TEXT
O_TRUNC
O_WRONLY
);
# Other items we are prepared to export if requested
@EXPORT_OK = qw(
DN_ACCESS
DN_ATTRIB
DN_CREATE
DN_DELETE
DN_MODIFY
DN_MULTISHOT
DN_RENAME
FAPPEND
FASYNC
FCREAT
FDEFER
FDSYNC
FEXCL
FLARGEFILE
FNDELAY
FNONBLOCK
FRSYNC
FSYNC
FTRUNC
F_GETLEASE
F_GETSIG
F_NOTIFY
F_SETLEASE
F_SETSIG
LOCK_EX
LOCK_MAND
LOCK_NB
LOCK_READ
LOCK_RW
LOCK_SH
LOCK_UN
LOCK_WRITE
O_IGNORE_CTTY
O_NOATIME
O_NOLINK
O_NOTRANS
SEEK_CUR
SEEK_END
SEEK_SET
S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT
S_IREAD S_IWRITE S_IEXEC
S_IRGRP S_IWGRP S_IXGRP S_IRWXG
S_IROTH S_IWOTH S_IXOTH S_IRWXO
S_IRUSR S_IWUSR S_IXUSR S_IRWXU
S_ISUID S_ISGID S_ISVTX S_ISTXT
_S_IFMT S_IFREG S_IFDIR S_IFLNK
&S_ISREG &S_ISDIR &S_ISLNK &S_ISSOCK &S_ISBLK &S_ISCHR &S_ISFIFO
&S_ISWHT &S_ISENFMT &S_IFMT &S_IMODE
);
# Named groups of exports
%EXPORT_TAGS = (
'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)],
'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FDSYNC FEXCL FLARGEFILE
FNDELAY FNONBLOCK FRSYNC FSYNC FTRUNC)],
'seek' => [qw(SEEK_SET SEEK_CUR SEEK_END)],
'mode' => [qw(S_ISUID S_ISGID S_ISVTX S_ISTXT
_S_IFMT S_IFREG S_IFDIR S_IFLNK
S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT
S_IRUSR S_IWUSR S_IXUSR S_IRWXU
S_IRGRP S_IWGRP S_IXGRP S_IRWXG
S_IROTH S_IWOTH S_IXOTH S_IRWXO
S_IREAD S_IWRITE S_IEXEC
S_ISREG S_ISDIR S_ISLNK S_ISSOCK
S_ISBLK S_ISCHR S_ISFIFO
S_ISWHT S_ISENFMT
S_IFMT S_IMODE
)],
);
# Force the constants to become inlined
BEGIN {
XSLoader::load 'Fcntl', $VERSION;
}
sub S_IFMT { @_ ? ( $_[0] & _S_IFMT() ) : _S_IFMT() }
sub S_IMODE { $_[0] & 07777 }
sub S_ISREG { ( $_[0] & _S_IFMT() ) == S_IFREG() }
sub S_ISDIR { ( $_[0] & _S_IFMT() ) == S_IFDIR() }
sub S_ISLNK { ( $_[0] & _S_IFMT() ) == S_IFLNK() }
sub S_ISSOCK { ( $_[0] & _S_IFMT() ) == S_IFSOCK() }
sub S_ISBLK { ( $_[0] & _S_IFMT() ) == S_IFBLK() }
sub S_ISCHR { ( $_[0] & _S_IFMT() ) == S_IFCHR() }
sub S_ISFIFO { ( $_[0] & _S_IFMT() ) == S_IFIFO() }
sub S_ISWHT { ( $_[0] & _S_IFMT() ) == S_IFWHT() }
sub S_ISENFMT { ( $_[0] & _S_IFMT() ) == S_IFENFMT() }
sub AUTOLOAD {
(my $constname = $AUTOLOAD) =~ s/.*:://;
die "&Fcntl::constant not defined" if $constname eq 'constant';
my ($error, $val) = constant($constname);
if ($error) {
my (undef,$file,$line) = caller;
die "$error at $file line $line.\n";
}
no strict 'refs';
*$AUTOLOAD = sub { $val };
goto &$AUTOLOAD;
}
1;

350
devtools/srcsrv/perl/lib/XSLoader.pm Normal file
View File

@@ -0,0 +1,350 @@
# Generated from XSLoader.pm.PL (resolved %Config::Config value)
package XSLoader;
$VERSION = "0.08";
#use strict;
# enable debug/trace messages from DynaLoader perl code
# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
my $dl_dlext = 'dll';
package DynaLoader;
# 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);
package XSLoader;
sub load {
package DynaLoader;
die q{XSLoader::load('Your::Module', $Your::Module::VERSION)} unless @_;
my($module) = $_[0];
# work with static linking too
my $b = "$module\::bootstrap";
goto &$b if defined &$b;
goto retry unless $module and defined &dl_load_file;
my @modparts = split(/::/,$module);
my $modfname = $modparts[-1];
my $modpname = join('/',@modparts);
my $modlibname = (caller())[1];
my $c = @modparts;
$modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext";
# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug;
my $bs = $file;
$bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
goto retry if not -f $file or -s $bs;
my $bootname = "boot_$module";
$bootname =~ s/\W/_/g;
@DynaLoader::dl_require_symbols = ($bootname);
my $boot_symbol_ref;
# 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, 0) or do {
require Carp;
Carp::croak("Can't load '$file' for module $module: " . dl_error());
};
push(@DynaLoader::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 do {
require Carp;
Carp::croak("Can't find '$bootname' symbol in $file\n");
};
push(@DynaLoader::dl_modules, $module); # record loaded module
boot:
my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
# See comment block above
push(@DynaLoader::dl_shared_objects, $file); # record files loaded
return &$xs(@_);
retry:
my $bootstrap_inherit = DynaLoader->can('bootstrap_inherit') ||
XSLoader->can('bootstrap_inherit');
goto &$bootstrap_inherit;
}
# Versions of DynaLoader prior to 5.6.0 don't have this function.
sub bootstrap_inherit {
package DynaLoader;
my $module = $_[0];
local *DynaLoader::isa = *{"$module\::ISA"};
local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader');
# Cannot goto due to delocalization. Will report errors on a wrong line?
require DynaLoader;
DynaLoader::bootstrap(@_);
}
1;
__END__
=head1 NAME
XSLoader - Dynamically load C libraries into Perl code
=head1 VERSION
Version 0.08
=head1 SYNOPSIS
package YourPackage;
use XSLoader;
XSLoader::load 'YourPackage', $YourPackage::VERSION;
=head1 DESCRIPTION
This module defines a standard I<simplified> interface to the dynamic
linking mechanisms available on many platforms. Its primary purpose is
to implement cheap automatic dynamic loading of Perl modules.
For a more complicated interface, see L<DynaLoader>. Many (most)
features of C<DynaLoader> are not implemented in C<XSLoader>, like for
example the C<dl_load_flags>, not honored by C<XSLoader>.
=head2 Migration from C<DynaLoader>
A typical module using L<DynaLoader|DynaLoader> starts like this:
package YourPackage;
require DynaLoader;
our @ISA = qw( OnePackage OtherPackage DynaLoader );
our $VERSION = '0.01';
bootstrap YourPackage $VERSION;
Change this to
package YourPackage;
use XSLoader;
our @ISA = qw( OnePackage OtherPackage );
our $VERSION = '0.01';
XSLoader::load 'YourPackage', $VERSION;
In other words: replace C<require DynaLoader> by C<use XSLoader>, remove
C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not
forget to quote the name of your package on the C<XSLoader::load> line,
and add comma (C<,>) before the arguments (C<$VERSION> above).
Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have
the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the
more backward-compatible
use vars qw($VERSION @ISA);
one can remove this reference to C<@ISA> together with the C<@ISA> assignment.
If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes
XSLoader::load 'YourPackage';
=head2 Backward compatible boilerplate
If you want to have your cake and eat it too, you need a more complicated
boilerplate.
package YourPackage;
use vars qw($VERSION @ISA);
@ISA = qw( OnePackage OtherPackage );
$VERSION = '0.01';
eval {
require XSLoader;
XSLoader::load('YourPackage', $VERSION);
1;
} or do {
require DynaLoader;
push @ISA, 'DynaLoader';
bootstrap YourPackage $VERSION;
};
The parentheses about C<XSLoader::load()> arguments are needed since we replaced
C<use XSLoader> by C<require>, so the compiler does not know that a function
C<XSLoader::load()> is present.
This boilerplate uses the low-overhead C<XSLoader> if present; if used with
an antic Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>.
=head1 Order of initialization: early load()
I<Skip this section if the XSUB functions are supposed to be called from other
modules only; read it only if you call your XSUBs from the code in your module,
or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">).
What is described here is equally applicable to the L<DynaLoader|DynaLoader>
interface.>
A sufficiently complicated module using XS would have both Perl code (defined
in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>). If this
Perl code makes calls into this XS code, and/or this XS code makes calls to
the Perl code, one should be careful with the order of initialization.
The call to C<XSLoader::load()> (or C<bootstrap()>) has three side effects:
=over
=item *
if C<$VERSION> was specified, a sanity check is done to ensure that the
versions of the F<.pm> and the (compiled) F<.xs> parts are compatible;
=item *
the XSUBs are made accessible from Perl;
=item *
if a C<BOOT:> section was present in the F<.xs> file, the code there is called.
=back
Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is
convenient to have XSUBs installed before the Perl code is defined; for
example, this makes prototypes for XSUBs visible to this Perl code.
Alternatively, if the C<BOOT:> section makes calls to Perl functions (or
uses Perl variables) defined in the F<.pm> file, they must be defined prior to
the call to C<XSLoader::load()> (or C<bootstrap()>).
The first situation being much more frequent, it makes sense to rewrite the
boilerplate as
package YourPackage;
use XSLoader;
use vars qw($VERSION @ISA);
BEGIN {
@ISA = qw( OnePackage OtherPackage );
$VERSION = '0.01';
# Put Perl code used in the BOOT: section here
XSLoader::load 'YourPackage', $VERSION;
}
# Put Perl code making calls into XSUBs here
=head2 The most hairy case
If the interdependence of your C<BOOT:> section and Perl code is
more complicated than this (e.g., the C<BOOT:> section makes calls to Perl
functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:>
section altogether. Replace it with a function C<onBOOT()>, and call it like
this:
package YourPackage;
use XSLoader;
use vars qw($VERSION @ISA);
BEGIN {
@ISA = qw( OnePackage OtherPackage );
$VERSION = '0.01';
XSLoader::load 'YourPackage', $VERSION;
}
# Put Perl code used in onBOOT() function here; calls to XSUBs are
# prototype-checked.
onBOOT;
# Put Perl initialization code assuming that XS is initialized here
=head1 DIAGNOSTICS
=over
=item C<Can't find '%s' symbol in %s>
B<(F)> The bootstrap symbol could not be found in the extension module.
=item C<Can't load '%s' for module %s: %s>
B<(F)> The loading or initialisation of the extension module failed.
The detailed error follows.
=item C<Undefined symbols present after loading %s: %s>
B<(W)> As the message says, some symbols stay undefined although the
extension module was correctly loaded and initialised. The list of undefined
symbols follows.
=item C<XSLoader::load('Your::Module', $Your::Module::VERSION)>
B<(F)> You tried to invoke C<load()> without any argument. You must supply
a module name, and optionally its version.
=back
=head1 LIMITATIONS
To reduce the overhead as much as possible, only one possible location
is checked to find the extension DLL (this location is where C<make install>
would put the DLL). If not found, the search for the DLL is transparently
delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list.
In particular, this is applicable to the structure of C<@INC> used for testing
not-yet-installed extensions. This means that running uninstalled extensions
may have much more overhead than running the same extensions after
C<make install>.
=head1 BUGS
Please report any bugs or feature requests via the perlbug(1) utility.
=head1 SEE ALSO
L<DynaLoader>
=head1 AUTHORS
Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>.
CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni
E<lt>sebastien@aperghis.netE<gt>.
Previous maintainer was Michael G Schwern <schwern@pobox.com>.
=head1 COPYRIGHT
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

BIN
devtools/srcsrv/perl/lib/auto/Data/Dumper/Dumper.dll Normal file
View File

Binary file not shown.

BIN
devtools/srcsrv/perl/lib/auto/fcntl/Fcntl.dll Normal file
View File

Binary file not shown.

88
devtools/srcsrv/perl/lib/bytes.pm Normal file
View 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

1280
devtools/srcsrv/perl/lib/data/Dumper.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1455
devtools/srcsrv/perl/lib/overload.pm Normal file
View File

File diff suppressed because it is too large Load Diff

136
devtools/srcsrv/perl/lib/strict.pm Normal file
View 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

497
devtools/srcsrv/perl/lib/warnings.pm Normal file
View 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
{
require Carp::Heavy; # this initializes %CarpInternal
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
devtools/srcsrv/perl/lib/warnings/register.pm Normal file
View 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;