Change-Id: Ic9dcad6db5d8198c0259acc39c006430d74b1a34
This commit is contained in:
2024-07-07 10:03:49 +08:00
commit c637eac89e
560 changed files with 177147 additions and 0 deletions

View File

@@ -0,0 +1,206 @@
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.74';
}
AUTOLOAD {
my $sub = $AUTOLOAD;
autoload_sub($sub);
goto &$sub;
}
sub autoload_sub {
my $sub = shift;
my $filename = AutoLoader::find_filename( $sub );
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;
return 1;
}
sub find_filename {
my $sub = shift;
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 = undef
unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s;
} else {
$filename = undef
unless $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 (defined $filename and -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;
}
}
return $filename;
}
sub import {
my $pkg = shift;
my $callpkg = caller;
#
# Export symbols, but not by accident of inheritance.
#
if ($pkg eq 'AutoLoader') {
if ( @_ and $_[0] =~ /^&?AUTOLOAD$/ ) {
no strict 'refs';
*{ $callpkg . '::AUTOLOAD' } = \&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, but only eval it if the
# transformation from module path to autosplit.ix path
# succeeded!
my $replaced_okay;
if ($is_macos) {
(my $malldir = $calldir) =~ tr#/#:#;
$replaced_okay = ($path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s);
} else {
$replaced_okay = ($path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#);
}
eval { require $path; } if $replaced_okay;
# If that failed, try relative path with normal @INC searching.
if (!$replaced_okay or $@) {
$path ="auto/$calldir/autosplit.ix";
eval { require $path; };
}
if ($@) {
my $error = $@;
require Carp;
Carp::carp($error);
}
}
}
sub unimport {
my $callpkg = caller;
no strict 'refs';
for my $exported (qw( AUTOLOAD )) {
my $symname = $callpkg . '::' . $exported;
undef *{ $symname } if \&{ $symname } == \&{ $exported };
*{ $symname } = \&{ $symname };
}
}
1;
__END__

619
common/perl-base/Carp.pm Normal file
View File

@@ -0,0 +1,619 @@
package Carp;
{ use 5.006; }
use strict;
use warnings;
BEGIN {
# Very old versions of warnings.pm load Carp. This can go wrong due
# to the circular dependency. If warnings is invoked before Carp,
# then warnings starts by loading Carp, then Carp (above) tries to
# invoke warnings, and gets nothing because warnings is in the process
# of loading and hasn't defined its import method yet. If we were
# only turning on warnings ("use warnings" above) this wouldn't be too
# bad, because Carp would just gets the state of the -w switch and so
# might not get some warnings that it wanted. The real problem is
# that we then want to turn off Unicode warnings, but "no warnings
# 'utf8'" won't be effective if we're in this circular-dependency
# situation. So, if warnings.pm is an affected version, we turn
# off all warnings ourselves by directly setting ${^WARNING_BITS}.
# On unaffected versions, we turn off just Unicode warnings, via
# the proper API.
if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) {
${^WARNING_BITS} = "";
} else {
"warnings"->unimport("utf8");
}
}
sub _fetch_sub { # fetch sub without autovivifying
my($pack, $sub) = @_;
$pack .= '::';
# only works with top-level packages
return unless exists($::{$pack});
for ($::{$pack}) {
return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
for ($$_{$sub}) {
return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
}
}
}
# UTF8_REGEXP_PROBLEM is a compile-time constant indicating whether Carp
# must avoid applying a regular expression to an upgraded (is_utf8)
# string. There are multiple problems, on different Perl versions,
# that require this to be avoided. All versions prior to 5.13.8 will
# load utf8_heavy.pl for the swash system, even if the regexp doesn't
# use character classes. Perl 5.6 and Perls [5.11.2, 5.13.11) exhibit
# specific problems when Carp is being invoked in the aftermath of a
# syntax error.
BEGIN {
if("$]" < 5.013011) {
*UTF8_REGEXP_PROBLEM = sub () { 1 };
} else {
*UTF8_REGEXP_PROBLEM = sub () { 0 };
}
}
# is_utf8() is essentially the utf8::is_utf8() function, which indicates
# whether a string is represented in the upgraded form (using UTF-8
# internally). As utf8::is_utf8() is only available from Perl 5.8
# onwards, extra effort is required here to make it work on Perl 5.6.
BEGIN {
if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
*is_utf8 = $sub;
} else {
# black magic for perl 5.6
*is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 };
}
}
# The downgrade() function defined here is to be used for attempts to
# downgrade where it is acceptable to fail. It must be called with a
# second argument that is a true value.
BEGIN {
if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
*downgrade = \&{"utf8::downgrade"};
} else {
*downgrade = sub {
my $r = "";
my $l = length($_[0]);
for(my $i = 0; $i != $l; $i++) {
my $o = ord(substr($_[0], $i, 1));
return if $o > 255;
$r .= chr($o);
}
$_[0] = $r;
};
}
}
our $VERSION = '1.42';
$VERSION =~ tr/_//d;
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.
our $RefArgFormatter = undef; # allow caller to format reference arguments
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
# 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.
our %CarpInternal;
our %Internal;
# disable these by default, so they can live w/o require Carp
$CarpInternal{Carp}++;
$CarpInternal{warnings}++;
$Internal{Exporter}++;
$Internal{'Exporter::Heavy'}++;
# 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'; @_ }
sub _cgc {
no strict 'refs';
return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
return;
}
sub longmess {
local($!, $^E);
# Icky backwards compatibility wrapper. :-(
#
# The story is that the original implementation hard-coded the
# number of call levels to go back, so calls to longmess were off
# by one. Other code began calling longmess and expecting this
# behaviour, so the replacement has to emulate that behaviour.
my $cgc = _cgc();
my $call_pack = $cgc ? $cgc->() : caller();
if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
return longmess_heavy(@_);
}
else {
local $CarpLevel = $CarpLevel + 1;
return longmess_heavy(@_);
}
}
our @CARP_NOT;
sub shortmess {
local($!, $^E);
my $cgc = _cgc();
# Icky backwards compatibility wrapper. :-(
local @CARP_NOT = $cgc ? $cgc->() : caller();
shortmess_heavy(@_);
}
sub croak { die shortmess @_ }
sub confess { die longmess @_ }
sub carp { warn shortmess @_ }
sub cluck { warn longmess @_ }
BEGIN {
if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
("$]" >= 5.012005 && "$]" < 5.013)) {
*CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
} else {
*CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
}
}
sub caller_info {
my $i = shift(@_) + 1;
my %call_info;
my $cgc = _cgc();
{
# Some things override caller() but forget to implement the
# @DB::args part of it, which we need. We check for this by
# pre-populating @DB::args with a sentinel which no-one else
# has the address of, so that we can detect whether @DB::args
# has been properly populated. However, on earlier versions
# of perl this check tickles a bug in CORE::caller() which
# leaks memory. So we only check on fixed perls.
@DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
package DB;
@call_info{
qw(pack file line sub has_args wantarray evaltext is_require) }
= $cgc ? $cgc->($i) : caller($i);
}
unless ( defined $call_info{file} ) {
return ();
}
my $sub_name = Carp::get_subname( \%call_info );
if ( $call_info{has_args} ) {
my @args;
if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
&& ref $DB::args[0] eq ref \$i
&& $DB::args[0] == \$i ) {
@DB::args = (); # Don't let anyone see the address of $i
local $@;
my $where = eval {
my $func = $cgc or return '';
my $gv =
(_fetch_sub B => 'svref_2object' or return '')
->($func)->GV;
my $package = $gv->STASH->NAME;
my $subname = $gv->NAME;
return unless defined $package && defined $subname;
# returning CORE::GLOBAL::caller isn't useful for tracing the cause:
return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
" in &${package}::$subname";
} || '';
@args
= "** Incomplete caller override detected$where; \@DB::args were not set **";
}
else {
@args = @DB::args;
my $overflow;
if ( $MaxArgNums and @args > $MaxArgNums )
{ # More than we want to show?
$#args = $MaxArgNums - 1;
$overflow = 1;
}
@args = map { Carp::format_arg($_) } @args;
if ($overflow) {
push @args, '...';
}
}
# Push the args onto the subroutine
$sub_name .= '(' . join( ', ', @args ) . ')';
}
$call_info{sub_name} = $sub_name;
return wantarray() ? %call_info : \%call_info;
}
# Transform an argument to a function into a string.
our $in_recurse;
sub format_arg {
my $arg = shift;
if ( ref($arg) ) {
# legitimate, let's not leak it.
if (!$in_recurse &&
do {
local $@;
local $in_recurse = 1;
local $SIG{__DIE__} = sub{};
eval {$arg->can('CARP_TRACE') }
})
{
return $arg->CARP_TRACE();
}
elsif (!$in_recurse &&
defined($RefArgFormatter) &&
do {
local $@;
local $in_recurse = 1;
local $SIG{__DIE__} = sub{};
eval {$arg = $RefArgFormatter->($arg); 1}
})
{
return $arg;
}
else
{
my $sub = _fetch_sub(overload => 'StrVal');
return $sub ? &$sub($arg) : "$arg";
}
}
return "undef" if !defined($arg);
downgrade($arg, 1);
return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
$arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
my $suffix = "";
if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
substr ( $arg, $MaxArgLen - 3 ) = "";
$suffix = "...";
}
if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
for(my $i = length($arg); $i--; ) {
my $c = substr($arg, $i, 1);
my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
substr $arg, $i, 0, "\\";
next;
}
my $o = ord($c);
# This code is repeated in Regexp::CARP_TRACE()
if ($] ge 5.007_003) {
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
|| utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
} elsif (ord("A") == 65) {
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if $o < 0x20 || $o > 0x7e;
} else { # Early EBCDIC
# 3 EBCDIC code pages supported then; all controls but one
# are the code points below SPACE. The other one is 0x5F on
# POSIX-BC; FF on the other two.
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if $o < ord(" ") || ((ord ("^") == 106)
? $o == 0x5f
: $o == 0xff);
}
}
} else {
$arg =~ s/([\"\\\$\@])/\\$1/g;
# This is all the ASCII printables spelled-out. It is portable to all
# Perl versions and platforms (such as EBCDIC). There are other more
# compact ways to do this, but may not work everywhere every version.
$arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
}
downgrade($arg, 1);
return "\"".$arg."\"".$suffix;
}
sub Regexp::CARP_TRACE {
my $arg = "$_[0]";
downgrade($arg, 1);
if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
for(my $i = length($arg); $i--; ) {
my $o = ord(substr($arg, $i, 1));
my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
# This code is repeated in format_arg()
if ($] ge 5.007_003) {
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
|| utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
} elsif (ord("A") == 65) {
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if $o < 0x20 || $o > 0x7e;
} else { # Early EBCDIC
substr $arg, $i, 1, sprintf("\\x{%x}", $o)
if $o < ord(" ") || ((ord ("^") == 106)
? $o == 0x5f
: $o == 0xff);
}
}
} else {
# See comment in format_arg() about this same regex.
$arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
}
downgrade($arg, 1);
my $suffix = "";
if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
($suffix, $arg) = ($1, $2);
}
if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
substr ( $arg, $MaxArgLen - 3 ) = "";
$suffix = "...".$suffix;
}
return "qr($arg)$suffix";
}
# Takes an inheritance cache and a package and returns
# an anon hash of known inheritances and anon array of
# inheritances which consequences have not been figured
# for.
sub get_status {
my $cache = shift;
my $pkg = shift;
$cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
return @{ $cache->{$pkg} };
}
# Takes the info from caller() and figures out the name of
# the sub/require/eval
sub get_subname {
my $info = shift;
if ( defined( $info->{evaltext} ) ) {
my $eval = $info->{evaltext};
if ( $info->{is_require} ) {
return "require $eval";
}
else {
$eval =~ s/([\\\'])/\\$1/g;
return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
}
}
# this can happen on older perls when the sub (or the stash containing it)
# has been deleted
if ( !defined( $info->{sub} ) ) {
return '__ANON__::__ANON__';
}
return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
}
# Figures out what call (from the point of view of the caller)
# the long error backtrace should start at.
sub long_error_loc {
my $i;
my $lvl = $CarpLevel;
{
++$i;
my $cgc = _cgc();
my @caller = $cgc ? $cgc->($i) : caller($i);
my $pkg = $caller[0];
unless ( defined($pkg) ) {
# This *shouldn't* happen.
if (%Internal) {
local %Internal;
$i = long_error_loc();
last;
}
elsif (defined $caller[2]) {
# this can happen when the stash has been deleted
# in that case, just assume that it's a reasonable place to
# stop (the file and line data will still be intact in any
# case) - the only issue is that we can't detect if the
# deleted package was internal (so don't do that then)
# -doy
redo unless 0 > --$lvl;
last;
}
else {
return 2;
}
}
redo if $CarpInternal{$pkg};
redo unless 0 > --$lvl;
redo if $Internal{$pkg};
}
return $i - 1;
}
sub longmess_heavy {
if ( ref( $_[0] ) ) { # don't break references as exceptions
return wantarray ? @_ : $_[0];
}
my $i = long_error_loc();
return ret_backtrace( $i, @_ );
}
# Returns a full stack backtrace starting from where it is
# told.
sub ret_backtrace {
my ( $i, @error ) = @_;
my $mess;
my $err = join '', @error;
$i++;
my $tid_msg = '';
if ( defined &threads::tid ) {
my $tid = threads->tid;
$tid_msg = " thread $tid" if $tid;
}
my %i = caller_info($i);
$mess = "$err at $i{file} line $i{line}$tid_msg";
if( defined $. ) {
local $@ = '';
local $SIG{__DIE__};
eval {
CORE::die;
};
if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
$mess .= $1;
}
}
$mess .= "\.\n";
while ( my %i = caller_info( ++$i ) ) {
$mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
}
return $mess;
}
sub ret_summary {
my ( $i, @error ) = @_;
my $err = join '', @error;
$i++;
my $tid_msg = '';
if ( defined &threads::tid ) {
my $tid = threads->tid;
$tid_msg = " thread $tid" if $tid;
}
my %i = caller_info($i);
return "$err at $i{file} line $i{line}$tid_msg\.\n";
}
sub short_error_loc {
# You have to create your (hash)ref out here, rather than defaulting it
# inside trusts *on a lexical*, as you want it to persist across calls.
# (You can default it on $_[2], but that gets messy)
my $cache = {};
my $i = 1;
my $lvl = $CarpLevel;
{
my $cgc = _cgc();
my $called = $cgc ? $cgc->($i) : caller($i);
$i++;
my $caller = $cgc ? $cgc->($i) : caller($i);
if (!defined($caller)) {
my @caller = $cgc ? $cgc->($i) : caller($i);
if (@caller) {
# if there's no package but there is other caller info, then
# the package has been deleted - treat this as a valid package
# in this case
redo if defined($called) && $CarpInternal{$called};
redo unless 0 > --$lvl;
last;
}
else {
return 0;
}
}
redo if $Internal{$caller};
redo if $CarpInternal{$caller};
redo if $CarpInternal{$called};
redo if trusts( $called, $caller, $cache );
redo if trusts( $caller, $called, $cache );
redo unless 0 > --$lvl;
}
return $i - 1;
}
sub shortmess_heavy {
return longmess_heavy(@_) if $Verbose;
return @_ if ref( $_[0] ); # don't break references as exceptions
my $i = short_error_loc();
if ($i) {
ret_summary( $i, @_ );
}
else {
longmess_heavy(@_);
}
}
# If a string is too long, trims it with ...
sub str_len_trim {
my $str = shift;
my $max = shift || 0;
if ( 2 < $max and $max < length($str) ) {
substr( $str, $max - 3 ) = '...';
}
return $str;
}
# Takes two packages and an optional cache. Says whether the
# first inherits from the second.
#
# Recursive versions of this have to work to avoid certain
# possible endless loops, and when following long chains of
# inheritance are less efficient.
sub trusts {
my $child = shift;
my $parent = shift;
my $cache = shift;
my ( $known, $partial ) = get_status( $cache, $child );
# Figure out consequences until we have an answer
while ( @$partial and not exists $known->{$parent} ) {
my $anc = shift @$partial;
next if exists $known->{$anc};
$known->{$anc}++;
my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
my @found = keys %$anc_knows;
@$known{@found} = ();
push @$partial, @$anc_partial;
}
return exists $known->{$parent};
}
# Takes a package and gives a list of those trusted directly
sub trusts_directly {
my $class = shift;
no strict 'refs';
my $stash = \%{"$class\::"};
for my $var (qw/ CARP_NOT ISA /) {
# Don't try using the variable until we know it exists,
# to avoid polluting the caller's namespace.
if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
return @{$stash->{$var}}
}
}
return;
}
if(!defined($warnings::VERSION) ||
do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
# Very old versions of warnings.pm import from Carp. This can go
# wrong due to the circular dependency. If Carp is invoked before
# warnings, then Carp starts by loading warnings, then warnings
# tries to import from Carp, and gets nothing because Carp is in
# the process of loading and hasn't defined its import method yet.
# So we work around that by manually exporting to warnings here.
no strict "refs";
*{"warnings::$_"} = \&$_ foreach @EXPORT;
}
1;
__END__

View File

@@ -0,0 +1,21 @@
package Carp::Heavy;
use Carp ();
our $VERSION = '1.42';
$VERSION =~ tr/_//d;
# Carp::Heavy was merged into Carp in version 1.12. Any mismatched versions
# after this point are not significant and can be ignored.
if(($Carp::VERSION || 0) < 1.12) {
my $cv = defined($Carp::VERSION) ? $Carp::VERSION : "undef";
die "Version mismatch between Carp $cv ($INC{q(Carp.pm)}) and Carp::Heavy $VERSION ($INC{q(Carp/Heavy.pm)}). Did you alter \@INC after Carp was loaded?\n";
}
1;
# Most of the machinery of Carp used to be here.
# It has been moved in Carp.pm now, but this placeholder remains for
# the benefit of modules that like to preload Carp::Heavy directly.
# This must load Carp, because some modules rely on the historical
# behaviour of Carp::Heavy loading Carp.

111
common/perl-base/Config.pm Normal file
View File

@@ -0,0 +1,111 @@
# 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.
# for a description of the variables, please have a look at the
# Glossary file, as written in the Porting folder, or use the url:
# http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
package Config;
use strict;
use warnings;
use vars '%Config', '$VERSION';
$VERSION = "5.026001";
# Skip @Config::EXPORT because it only contains %Config, which we special
# case below as it's not a function. @Config::EXPORT won't change in the
# lifetime of Perl 5.
my %Export_Cache = (myconfig => 1, config_sh => 1, config_vars => 1,
config_re => 1, compile_date => 1, local_patches => 1,
bincompat_options => 1, non_bincompat_options => 1,
header_files => 1);
@Config::EXPORT = qw(%Config);
@Config::EXPORT_OK = keys %Export_Cache;
# Need to stub all the functions to make code such as print Config::config_sh
# keep working
sub bincompat_options;
sub compile_date;
sub config_re;
sub config_sh;
sub config_vars;
sub header_files;
sub local_patches;
sub myconfig;
sub non_bincompat_options;
# Define our own import method to avoid pulling in the full Exporter:
sub import {
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 qq{"$func" is not exported by the Config module\n}
unless $Export_Cache{$func};
*{$callpkg.'::'.$func} = \&{$func};
}
*{"$callpkg\::Config"} = \%Config if $export_Config;
return;
}
die "$0: Perl lib version (5.26.1) doesn't match executable '$^X' version ($])"
unless $^V;
$^V eq 5.26.1
or die sprintf "%s: Perl lib version (5.26.1) doesn't match executable '$^X' version (%vd)", $0, $^V;
sub FETCH {
my($self, $key) = @_;
# check for cached value (which may be undef so we use exists not defined)
return exists $self->{$key} ? $self->{$key} : $self->fetch_string($key);
}
sub TIEHASH {
bless $_[1], $_[0];
}
sub DESTROY { }
sub AUTOLOAD {
require 'Config_heavy.pl';
goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
}
# tie returns the object, so the value returned to require will be true.
tie %Config, 'Config', {
archlibexp => '/usr/lib/x86_64-linux-gnu/perl/5.26',
archname => 'x86_64-linux-gnu-thread-multi',
cc => 'x86_64-linux-gnu-gcc',
d_readlink => 'define',
d_symlink => 'define',
dlext => 'so',
dlsrc => 'dl_dlopen.xs',
dont_use_nlink => undef,
exe_ext => '',
inc_version_list => '5.26.0 5.26.0/x86_64-linux-gnu-thread-multi',
intsize => '4',
ldlibpthname => 'LD_LIBRARY_PATH',
libpth => '/usr/local/lib /usr/lib/gcc/x86_64-linux-gnu/7/include-fixed /usr/include/x86_64-linux-gnu /usr/lib /lib/x86_64-linux-gnu /lib/../lib /usr/lib/x86_64-linux-gnu /usr/lib/../lib /lib',
osname => 'linux',
osvers => '4.9.0',
path_sep => ':',
privlibexp => '/usr/share/perl/5.26',
scriptdir => '/usr/bin',
sitearchexp => '/usr/local/lib/x86_64-linux-gnu/perl/5.26.1',
sitelibexp => '/usr/local/share/perl/5.26.1',
so => 'so',
useithreads => 'define',
usevendorprefix => 'define',
version => '5.26.1',
};

View File

@@ -0,0 +1,12 @@
######################################################################
# WARNING: 'lib/Config_git.pl' is generated by make_patchnum.pl
# DO NOT EDIT DIRECTLY - edit make_patchnum.pl instead
######################################################################
$Config::Git_Data=<<'ENDOFGIT';
git_commit_id=''
git_describe=''
git_branch=''
git_uncommitted_changes=''
git_commit_id_title=''
ENDOFGIT

File diff suppressed because one or more lines are too long

697
common/perl-base/Cwd.pm Normal file
View File

@@ -0,0 +1,697 @@
package Cwd;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
$VERSION = '3.67';
my $xs_version = $VERSION;
$VERSION =~ tr/_//d;
@ISA = qw/ Exporter /;
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
# sys_cwd may keep the builtin command
# All the functionality of this module may provided by builtins,
# there is no sense to process the rest of the file.
# The best choice may be to have this in BEGIN, but how to return from BEGIN?
if ($^O eq 'os2') {
local $^W = 0;
*cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
*getcwd = \&cwd;
*fastgetcwd = \&cwd;
*fastcwd = \&cwd;
*fast_abs_path = \&sys_abspath if defined &sys_abspath;
*abs_path = \&fast_abs_path;
*realpath = \&fast_abs_path;
*fast_realpath = \&fast_abs_path;
return 1;
}
# Need to look up the feature settings on VMS. The preferred way is to use the
# VMS::Feature module, but that may not be available to dual life modules.
my $use_vms_feature;
BEGIN {
if ($^O eq 'VMS') {
if (eval { local $SIG{__DIE__};
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
require VMS::Feature; }) {
$use_vms_feature = 1;
}
}
}
# Need to look up the UNIX report mode. This may become a dynamic mode
# in the future.
sub _vms_unix_rpt {
my $unix_rpt;
if ($use_vms_feature) {
$unix_rpt = VMS::Feature::current("filename_unix_report");
} else {
my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
$unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
}
return $unix_rpt;
}
# Need to look up the EFS character set mode. This may become a dynamic
# mode in the future.
sub _vms_efs {
my $efs;
if ($use_vms_feature) {
$efs = VMS::Feature::current("efs_charset");
} else {
my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
$efs = $env_efs =~ /^[ET1]/i;
}
return $efs;
}
# If loading the XS stuff doesn't work, we can fall back to pure perl
if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) {
eval {#eval is questionable since we are handling potential errors like
#"Cwd object version 3.48 does not match bootstrap parameter 3.50
#at lib/DynaLoader.pm line 216." by having this eval
if ( $] >= 5.006 ) {
require XSLoader;
XSLoader::load( __PACKAGE__, $xs_version);
} else {
require DynaLoader;
push @ISA, 'DynaLoader';
__PACKAGE__->bootstrap( $xs_version );
}
};
}
# Big nasty table of function aliases
my %METHOD_MAP =
(
VMS =>
{
cwd => '_vms_cwd',
getcwd => '_vms_cwd',
fastcwd => '_vms_cwd',
fastgetcwd => '_vms_cwd',
abs_path => '_vms_abs_path',
fast_abs_path => '_vms_abs_path',
},
MSWin32 =>
{
# We assume that &_NT_cwd is defined as an XSUB or in the core.
cwd => '_NT_cwd',
getcwd => '_NT_cwd',
fastcwd => '_NT_cwd',
fastgetcwd => '_NT_cwd',
abs_path => 'fast_abs_path',
realpath => 'fast_abs_path',
},
dos =>
{
cwd => '_dos_cwd',
getcwd => '_dos_cwd',
fastgetcwd => '_dos_cwd',
fastcwd => '_dos_cwd',
abs_path => 'fast_abs_path',
},
# QNX4. QNX6 has a $os of 'nto'.
qnx =>
{
cwd => '_qnx_cwd',
getcwd => '_qnx_cwd',
fastgetcwd => '_qnx_cwd',
fastcwd => '_qnx_cwd',
abs_path => '_qnx_abs_path',
fast_abs_path => '_qnx_abs_path',
},
cygwin =>
{
getcwd => 'cwd',
fastgetcwd => 'cwd',
fastcwd => 'cwd',
abs_path => 'fast_abs_path',
realpath => 'fast_abs_path',
},
epoc =>
{
cwd => '_epoc_cwd',
getcwd => '_epoc_cwd',
fastgetcwd => '_epoc_cwd',
fastcwd => '_epoc_cwd',
abs_path => 'fast_abs_path',
},
MacOS =>
{
getcwd => 'cwd',
fastgetcwd => 'cwd',
fastcwd => 'cwd',
abs_path => 'fast_abs_path',
},
amigaos =>
{
getcwd => '_backtick_pwd',
fastgetcwd => '_backtick_pwd',
fastcwd => '_backtick_pwd',
abs_path => 'fast_abs_path',
}
);
$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
# Find the pwd command in the expected locations. We assume these
# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
# so everything works under taint mode.
my $pwd_cmd;
if($^O ne 'MSWin32') {
foreach my $try ('/bin/pwd',
'/usr/bin/pwd',
'/QOpenSys/bin/pwd', # OS/400 PASE.
) {
if( -x $try ) {
$pwd_cmd = $try;
last;
}
}
}
# Android has a built-in pwd. Using $pwd_cmd will DTRT if
# this perl was compiled with -Dd_useshellcmds, which is the
# default for Android, but the block below is needed for the
# miniperl running on the host when cross-compiling, and
# potentially for native builds with -Ud_useshellcmds.
if ($^O =~ /android/) {
# If targetsh is executable, then we're either a full
# perl, or a miniperl for a native build.
if (-x $Config::Config{targetsh}) {
$pwd_cmd = "$Config::Config{targetsh} -c pwd"
}
else {
my $sh = $Config::Config{sh} || (-x '/system/bin/sh' ? '/system/bin/sh' : 'sh');
$pwd_cmd = "$sh -c pwd"
}
}
my $found_pwd_cmd = defined($pwd_cmd);
unless ($pwd_cmd) {
# Isn't this wrong? _backtick_pwd() will fail if someone has
# pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
# See [perl #16774]. --jhi
$pwd_cmd = 'pwd';
}
# Lazy-load Carp
sub _carp { require Carp; Carp::carp(@_) }
sub _croak { require Carp; Carp::croak(@_) }
# The 'natural and safe form' for UNIX (pwd may be setuid root)
sub _backtick_pwd {
# Localize %ENV entries in a way that won't create new hash keys.
# Under AmigaOS we don't want to localize as it stops perl from
# finding 'sh' in the PATH.
my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV) if $^O ne "amigaos";
local @ENV{@localize} if @localize;
my $cwd = `$pwd_cmd`;
# Belt-and-suspenders in case someone said "undef $/".
local $/ = "\n";
# `pwd` may fail e.g. if the disk is full
chomp($cwd) if defined $cwd;
$cwd;
}
# Since some ports may predefine cwd internally (e.g., NT)
# we take care not to override an existing definition for cwd().
unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
# The pwd command is not available in some chroot(2)'ed environments
my $sep = $Config::Config{path_sep} || ':';
my $os = $^O; # Protect $^O from tainting
# Try again to find a pwd, this time searching the whole PATH.
if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
my @candidates = split($sep, $ENV{PATH});
while (!$found_pwd_cmd and @candidates) {
my $candidate = shift @candidates;
$found_pwd_cmd = 1 if -x "$candidate/pwd";
}
}
# MacOS has some special magic to make `pwd` work.
if( $os eq 'MacOS' || $found_pwd_cmd )
{
*cwd = \&_backtick_pwd;
}
else {
*cwd = \&getcwd;
}
}
if ($^O eq 'cygwin') {
# We need to make sure cwd() is called with no args, because it's
# got an arg-less prototype and will die if args are present.
local $^W = 0;
my $orig_cwd = \&cwd;
*cwd = sub { &$orig_cwd() }
}
# set a reasonable (and very safe) default for fastgetcwd, in case it
# isn't redefined later (20001212 rspier)
*fastgetcwd = \&cwd;
# A non-XS version of getcwd() - also used to bootstrap the perl build
# process, when miniperl is running and no XS loading happens.
sub _perl_getcwd
{
abs_path('.');
}
# By John Bazik
#
# Usage: $cwd = &fastcwd;
#
# This is a faster version of getcwd. It's also more dangerous because
# you might chdir out of a directory that you can't chdir back into.
sub fastcwd_ {
my($odev, $oino, $cdev, $cino, $tdev, $tino);
my(@path, $path);
local(*DIR);
my($orig_cdev, $orig_cino) = stat('.');
($cdev, $cino) = ($orig_cdev, $orig_cino);
for (;;) {
my $direntry;
($odev, $oino) = ($cdev, $cino);
CORE::chdir('..') || return undef;
($cdev, $cino) = stat('.');
last if $odev == $cdev && $oino == $cino;
opendir(DIR, '.') || return undef;
for (;;) {
$direntry = readdir(DIR);
last unless defined $direntry;
next if $direntry eq '.';
next if $direntry eq '..';
($tdev, $tino) = lstat($direntry);
last unless $tdev != $odev || $tino != $oino;
}
closedir(DIR);
return undef unless defined $direntry; # should never happen
unshift(@path, $direntry);
}
$path = '/' . join('/', @path);
if ($^O eq 'apollo') { $path = "/".$path; }
# At this point $path may be tainted (if tainting) and chdir would fail.
# Untaint it then check that we landed where we started.
$path =~ /^(.*)\z/s # untaint
&& CORE::chdir($1) or return undef;
($cdev, $cino) = stat('.');
die "Unstable directory path, current directory changed unexpectedly"
if $cdev != $orig_cdev || $cino != $orig_cino;
$path;
}
if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
# Keeps track of current working directory in PWD environment var
# Usage:
# use Cwd 'chdir';
# chdir $newdir;
my $chdir_init = 0;
sub chdir_init {
if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
my($dd,$di) = stat('.');
my($pd,$pi) = stat($ENV{'PWD'});
if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
$ENV{'PWD'} = cwd();
}
}
else {
my $wd = cwd();
$wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
$ENV{'PWD'} = $wd;
}
# Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
my($pd,$pi) = stat($2);
my($dd,$di) = stat($1);
if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
$ENV{'PWD'}="$2$3";
}
}
$chdir_init = 1;
}
sub chdir {
my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
if ($^O eq "cygwin") {
$newdir =~ s|\A///+|//|;
$newdir =~ s|(?<=[^/])//+|/|g;
}
elsif ($^O ne 'MSWin32') {
$newdir =~ s|///*|/|g;
}
chdir_init() unless $chdir_init;
my $newpwd;
if ($^O eq 'MSWin32') {
# get the full path name *before* the chdir()
$newpwd = Win32::GetFullPathName($newdir);
}
return 0 unless CORE::chdir $newdir;
if ($^O eq 'VMS') {
return $ENV{'PWD'} = $ENV{'DEFAULT'}
}
elsif ($^O eq 'MacOS') {
return $ENV{'PWD'} = cwd();
}
elsif ($^O eq 'MSWin32') {
$ENV{'PWD'} = $newpwd;
return 1;
}
if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
$ENV{'PWD'} = cwd();
} elsif ($newdir =~ m#^/#s) {
$ENV{'PWD'} = $newdir;
} else {
my @curdir = split(m#/#,$ENV{'PWD'});
@curdir = ('') unless @curdir;
my $component;
foreach $component (split(m#/#, $newdir)) {
next if $component eq '.';
pop(@curdir),next if $component eq '..';
push(@curdir,$component);
}
$ENV{'PWD'} = join('/',@curdir) || '/';
}
1;
}
sub _perl_abs_path
{
my $start = @_ ? shift : '.';
my($dotdots, $cwd, @pst, @cst, $dir, @tst);
unless (@cst = stat( $start ))
{
_carp("stat($start): $!");
return '';
}
unless (-d _) {
# Make sure we can be invoked on plain files, not just directories.
# NOTE that this routine assumes that '/' is the only directory separator.
my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
or return cwd() . '/' . $start;
# Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
if (-l $start) {
my $link_target = readlink($start);
die "Can't resolve link $start: $!" unless defined $link_target;
require File::Spec;
$link_target = $dir . '/' . $link_target
unless File::Spec->file_name_is_absolute($link_target);
return abs_path($link_target);
}
return $dir ? abs_path($dir) . "/$file" : "/$file";
}
$cwd = '';
$dotdots = $start;
do
{
$dotdots .= '/..';
@pst = @cst;
local *PARENT;
unless (opendir(PARENT, $dotdots))
{
# probably a permissions issue. Try the native command.
require File::Spec;
return File::Spec->rel2abs( $start, _backtick_pwd() );
}
unless (@cst = stat($dotdots))
{
_carp("stat($dotdots): $!");
closedir(PARENT);
return '';
}
if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
{
$dir = undef;
}
else
{
do
{
unless (defined ($dir = readdir(PARENT)))
{
_carp("readdir($dotdots): $!");
closedir(PARENT);
return '';
}
$tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
}
while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
$tst[1] != $pst[1]);
}
$cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
closedir(PARENT);
} while (defined $dir);
chop($cwd) unless $cwd eq '/'; # drop the trailing /
$cwd;
}
my $Curdir;
sub fast_abs_path {
local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
my $cwd = getcwd();
require File::Spec;
my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
# Detaint else we'll explode in taint mode. This is safe because
# we're not doing anything dangerous with it.
($path) = $path =~ /(.*)/s;
($cwd) = $cwd =~ /(.*)/s;
unless (-e $path) {
_croak("$path: No such file or directory");
}
unless (-d _) {
# Make sure we can be invoked on plain files, not just directories.
my ($vol, $dir, $file) = File::Spec->splitpath($path);
return File::Spec->catfile($cwd, $path) unless length $dir;
if (-l $path) {
my $link_target = readlink($path);
die "Can't resolve link $path: $!" unless defined $link_target;
$link_target = File::Spec->catpath($vol, $dir, $link_target)
unless File::Spec->file_name_is_absolute($link_target);
return fast_abs_path($link_target);
}
return $dir eq File::Spec->rootdir
? File::Spec->catpath($vol, $dir, $file)
: fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
}
if (!CORE::chdir($path)) {
_croak("Cannot chdir to $path: $!");
}
my $realpath = getcwd();
if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
_croak("Cannot chdir back to $cwd: $!");
}
$realpath;
}
# added function alias to follow principle of least surprise
# based on previous aliasing. --tchrist 27-Jan-00
*fast_realpath = \&fast_abs_path;
# --- PORTING SECTION ---
# VMS: $ENV{'DEFAULT'} points to default directory at all times
# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
# in the process logical name table as the default device and directory
# seen by Perl. This may not be the same as the default device
# and directory seen by DCL after Perl exits, since the effects
# the CRTL chdir() function persist only until Perl exits.
sub _vms_cwd {
return $ENV{'DEFAULT'};
}
sub _vms_abs_path {
return $ENV{'DEFAULT'} unless @_;
my $path = shift;
my $efs = _vms_efs;
my $unix_rpt = _vms_unix_rpt;
if (defined &VMS::Filespec::vmsrealpath) {
my $path_unix = 0;
my $path_vms = 0;
$path_unix = 1 if ($path =~ m#(?<=\^)/#);
$path_unix = 1 if ($path =~ /^\.\.?$/);
$path_vms = 1 if ($path =~ m#[\[<\]]#);
$path_vms = 1 if ($path =~ /^--?$/);
my $unix_mode = $path_unix;
if ($efs) {
# In case of a tie, the Unix report mode decides.
if ($path_vms == $path_unix) {
$unix_mode = $unix_rpt;
} else {
$unix_mode = 0 if $path_vms;
}
}
if ($unix_mode) {
# Unix format
return VMS::Filespec::unixrealpath($path);
}
# VMS format
my $new_path = VMS::Filespec::vmsrealpath($path);
# Perl expects directories to be in directory format
$new_path = VMS::Filespec::pathify($new_path) if -d $path;
return $new_path;
}
# Fallback to older algorithm if correct ones are not
# available.
if (-l $path) {
my $link_target = readlink($path);
die "Can't resolve link $path: $!" unless defined $link_target;
return _vms_abs_path($link_target);
}
# may need to turn foo.dir into [.foo]
my $pathified = VMS::Filespec::pathify($path);
$path = $pathified if defined $pathified;
return VMS::Filespec::rmsexpand($path);
}
sub _os2_cwd {
my $pwd = `cmd /c cd`;
chomp $pwd;
$pwd =~ s:\\:/:g ;
$ENV{'PWD'} = $pwd;
return $pwd;
}
sub _win32_cwd_simple {
my $pwd = `cd`;
chomp $pwd;
$pwd =~ s:\\:/:g ;
$ENV{'PWD'} = $pwd;
return $pwd;
}
sub _win32_cwd {
my $pwd;
$pwd = Win32::GetCwd();
$pwd =~ s:\\:/:g ;
$ENV{'PWD'} = $pwd;
return $pwd;
}
*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
sub _dos_cwd {
my $pwd;
if (!defined &Dos::GetCwd) {
chomp($pwd = `command /c cd`);
$pwd =~ s:\\:/:g ;
} else {
$pwd = Dos::GetCwd();
}
$ENV{'PWD'} = $pwd;
return $pwd;
}
sub _qnx_cwd {
local $ENV{PATH} = '';
local $ENV{CDPATH} = '';
local $ENV{ENV} = '';
my $pwd = `/usr/bin/fullpath -t`;
chomp $pwd;
$ENV{'PWD'} = $pwd;
return $pwd;
}
sub _qnx_abs_path {
local $ENV{PATH} = '';
local $ENV{CDPATH} = '';
local $ENV{ENV} = '';
my $path = @_ ? shift : '.';
local *REALPATH;
defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
die "Can't open /usr/bin/fullpath: $!";
my $realpath = <REALPATH>;
close REALPATH;
chomp $realpath;
return $realpath;
}
sub _epoc_cwd {
return $ENV{'PWD'} = EPOC::getcwd();
}
# Now that all the base-level functions are set up, alias the
# user-level functions to the right places
if (exists $METHOD_MAP{$^O}) {
my $map = $METHOD_MAP{$^O};
foreach my $name (keys %$map) {
local $^W = 0; # assignments trigger 'subroutine redefined' warning
no strict 'refs';
*{$name} = \&{$map->{$name}};
}
}
# In case the XS version doesn't load.
*abs_path = \&_perl_abs_path unless defined &abs_path;
*getcwd = \&_perl_getcwd unless defined &getcwd;
# added function alias for those of us more
# used to the libc function. --tchrist 27-Jan-00
*realpath = \&abs_path;
1;
__END__

View File

@@ -0,0 +1,314 @@
# Generated from DynaLoader_pm.PL, this file is unique for every OS
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
BEGIN {
$VERSION = '1.42';
}
use Config;
# 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)
# (ignored under Android; the linker always uses RTLD_LOCAL)
#
# 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, $dl_so, $dlsrc) = @Config::Config{qw(dlext so dlsrc)};
$do_expand = 0;
@dl_require_symbols = (); # names of symbols we need
@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
# 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(@_);
}
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];
my $modfname_orig = $modfname; # For .bs file search
# 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;
my $modpname = join('/',@modparts);
print STDERR "DynaLoader::bootstrap for $module ",
"(auto/$modpname/$modfname.$dl_dlext)\n"
if $dl_debug;
my $dir;
foreach (@INC) {
$dir = "$_/auto/$modpname";
next unless -d $dir; # skip over uninteresting directories
# check for common cases to avoid autoload of dl_findfile
my $try = "$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'
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.
# N.B. The .bs file does not following the naming convention used
# by mod2fname.
my $bs = "$dir/$modfname_orig";
$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 { local @INC = ('.'); do $bs; };
warn "$bs: $@\n" if $@;
}
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 $flags = $module->dl_load_flags;
my $libref = dl_load_file($file, $flags) or
croak("Can't load '$file' for module $module: ".dl_error());
push(@dl_librefs,$libref); # record loaded object
$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 dl_findfile {
# 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= 'so'; # $Config::Config{'dlext'} suffix for perl extensions
#my $dl_so = 'so'; # $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 (m:/: && -f $_) {
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; }
# 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
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_dlext") unless m/\.$dl_dlext$/o;
push(@names,"$_.$dl_so") unless m/\.$dl_so$/o;
push(@names,"lib$_.$dl_so") unless m:/:;
push(@names, $_);
}
my $dirsep = '/';
foreach $dir (@dirs, @dl_library_path) {
next unless -d $dir;
foreach $name (@names) {
my($file) = "$dir$dirsep$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 Perl version should be excluded at build time.
# 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
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,1);
return $symref if $symref;
}
return undef;
}
__END__

229
common/perl-base/Errno.pm Normal file
View File

@@ -0,0 +1,229 @@
# -*- buffer-read-only: t -*-
#
# This file is auto-generated by ext/Errno/Errno_pm.PL.
# ***ANY*** changes here will be lost.
#
package Errno;
require Exporter;
use strict;
our $VERSION = "1.28";
$VERSION = eval $VERSION;
our @ISA = 'Exporter';
my %err;
BEGIN {
%err = (
EPERM => 1,
ENOENT => 2,
ESRCH => 3,
EINTR => 4,
EIO => 5,
ENXIO => 6,
E2BIG => 7,
ENOEXEC => 8,
EBADF => 9,
ECHILD => 10,
EAGAIN => 11,
EWOULDBLOCK => 11,
ENOMEM => 12,
EACCES => 13,
EFAULT => 14,
ENOTBLK => 15,
EBUSY => 16,
EEXIST => 17,
EXDEV => 18,
ENODEV => 19,
ENOTDIR => 20,
EISDIR => 21,
EINVAL => 22,
ENFILE => 23,
EMFILE => 24,
ENOTTY => 25,
ETXTBSY => 26,
EFBIG => 27,
ENOSPC => 28,
ESPIPE => 29,
EROFS => 30,
EMLINK => 31,
EPIPE => 32,
EDOM => 33,
ERANGE => 34,
EDEADLK => 35,
EDEADLOCK => 35,
ENAMETOOLONG => 36,
ENOLCK => 37,
ENOSYS => 38,
ENOTEMPTY => 39,
ELOOP => 40,
ENOMSG => 42,
EIDRM => 43,
ECHRNG => 44,
EL2NSYNC => 45,
EL3HLT => 46,
EL3RST => 47,
ELNRNG => 48,
EUNATCH => 49,
ENOCSI => 50,
EL2HLT => 51,
EBADE => 52,
EBADR => 53,
EXFULL => 54,
ENOANO => 55,
EBADRQC => 56,
EBADSLT => 57,
EBFONT => 59,
ENOSTR => 60,
ENODATA => 61,
ETIME => 62,
ENOSR => 63,
ENONET => 64,
ENOPKG => 65,
EREMOTE => 66,
ENOLINK => 67,
EADV => 68,
ESRMNT => 69,
ECOMM => 70,
EPROTO => 71,
EMULTIHOP => 72,
EDOTDOT => 73,
EBADMSG => 74,
EOVERFLOW => 75,
ENOTUNIQ => 76,
EBADFD => 77,
EREMCHG => 78,
ELIBACC => 79,
ELIBBAD => 80,
ELIBSCN => 81,
ELIBMAX => 82,
ELIBEXEC => 83,
EILSEQ => 84,
ERESTART => 85,
ESTRPIPE => 86,
EUSERS => 87,
ENOTSOCK => 88,
EDESTADDRREQ => 89,
EMSGSIZE => 90,
EPROTOTYPE => 91,
ENOPROTOOPT => 92,
EPROTONOSUPPORT => 93,
ESOCKTNOSUPPORT => 94,
ENOTSUP => 95,
EOPNOTSUPP => 95,
EPFNOSUPPORT => 96,
EAFNOSUPPORT => 97,
EADDRINUSE => 98,
EADDRNOTAVAIL => 99,
ENETDOWN => 100,
ENETUNREACH => 101,
ENETRESET => 102,
ECONNABORTED => 103,
ECONNRESET => 104,
ENOBUFS => 105,
EISCONN => 106,
ENOTCONN => 107,
ESHUTDOWN => 108,
ETOOMANYREFS => 109,
ETIMEDOUT => 110,
ECONNREFUSED => 111,
EHOSTDOWN => 112,
EHOSTUNREACH => 113,
EALREADY => 114,
EINPROGRESS => 115,
ESTALE => 116,
EUCLEAN => 117,
ENOTNAM => 118,
ENAVAIL => 119,
EISNAM => 120,
EREMOTEIO => 121,
EDQUOT => 122,
ENOMEDIUM => 123,
EMEDIUMTYPE => 124,
ECANCELED => 125,
ENOKEY => 126,
EKEYEXPIRED => 127,
EKEYREVOKED => 128,
EKEYREJECTED => 129,
EOWNERDEAD => 130,
ENOTRECOVERABLE => 131,
ERFKILL => 132,
EHWPOISON => 133,
);
# Generate proxy constant subroutines for all the values.
# Well, almost all the values. Unfortunately we can't assume that at this
# point that our symbol table is empty, as code such as if the parser has
# seen code such as C<exists &Errno::EINVAL>, it will have created the
# typeglob.
# Doing this before defining @EXPORT_OK etc means that even if a platform is
# crazy enough to define EXPORT_OK as an error constant, everything will
# still work, because the parser will upgrade the PCS to a real typeglob.
# We rely on the subroutine definitions below to update the internal caches.
# Don't use %each, as we don't want a copy of the value.
foreach my $name (keys %err) {
if ($Errno::{$name}) {
# We expect this to be reached fairly rarely, so take an approach
# which uses the least compile time effort in the common case:
eval "sub $name() { $err{$name} }; 1" or die $@;
} else {
$Errno::{$name} = \$err{$name};
}
}
}
our @EXPORT_OK = keys %err;
our %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 ENOTBLK
ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
EPFNOSUPPORT EPIPE EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART
EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT
ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV
)],
);
sub TIEHASH { bless \%err }
sub FETCH {
my (undef, $errname) = @_;
return "" unless exists $err{$errname};
my $errno = $err{$errname};
return $errno == $! ? $errno : 0;
}
sub STORE {
require Carp;
Carp::confess("ERRNO hash is read only!");
}
# This is the true return value
*CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space
sub NEXTKEY {
each %err;
}
sub FIRSTKEY {
my $s = scalar keys %err; # initialize iterator
each %err;
}
sub EXISTS {
my (undef, $errname) = @_;
exists $err{$errname};
}
sub _tie_it {
tie %{$_[0]}, __PACKAGE__;
}
__END__
# ex: set ro:

View File

@@ -0,0 +1,98 @@
package Exporter;
require 5.006;
# Be lean.
#use strict;
#no strict 'refs';
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
our $VERSION = '5.72';
our (%Cache);
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 = \@{"$pkg\::EXPORT"};
# But, avoid creating things if they don't exist, which saves a couple of
# hundred bytes per package processed.
my $fail = ${$pkg . '::'}{EXPORT_FAIL} && \@{"$pkg\::EXPORT_FAIL"};
return export $pkg, $callpkg, @_
if $Verbose or $Debug or $fail && @$fail > 1;
my $export_cache = ($Cache{$pkg} ||= {});
my $args = @_ or @_ = @$exports;
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 @$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} if not $SIG{__WARN__};
# 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__

View File

@@ -0,0 +1,239 @@
package Exporter::Heavy;
use strict;
no strict 'refs';
# On one line so MakeMaker will see it.
require Exporter; our $VERSION = $Exporter::VERSION;
#
# We go to a lot of trouble not to 'require Carp' at file scope,
# because Carp requires Exporter, and something has to give.
#
sub _rebuild_cache {
my ($pkg, $exports, $cache) = @_;
s/^&// foreach @$exports;
@{$cache}{@$exports} = (1) x @$exports;
my $ok = \@{"${pkg}::EXPORT_OK"};
if (@$ok) {
s/^&// foreach @$ok;
@{$cache}{@$ok} = (1) x @$ok;
}
}
sub heavy_export {
# Save the old __WARN__ handler in case it was defined
my $oldwarn = $SIG{__WARN__};
# First make import warnings look like they're coming from the "use".
local $SIG{__WARN__} = sub {
# restore it back so proper stacking occurs
local $SIG{__WARN__} = $oldwarn;
my $text = shift;
if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) {
require Carp;
local $Carp::CarpLevel = 1; # ignore package calling us too.
Carp::carp($text);
}
else {
warn $text;
}
};
local $SIG{__DIE__} = sub {
require Carp;
local $Carp::CarpLevel = 1; # ignore package calling us too.
Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
};
my($pkg, $callpkg, @imports) = @_;
my($type, $sym, $cache_is_current, $oops);
my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
$Exporter::Cache{$pkg} ||= {});
if (@imports) {
if (!%$export_cache) {
_rebuild_cache ($pkg, $exports, $export_cache);
$cache_is_current = 1;
}
if (grep m{^[/!:]}, @imports) {
my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
my $tagdata;
my %imports;
my($remove, $spec, @names, @allexports);
# negated first item implies starting with default set:
unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
foreach $spec (@imports){
$remove = $spec =~ s/^!//;
if ($spec =~ s/^://){
if ($spec eq 'DEFAULT'){
@names = @$exports;
}
elsif ($tagdata = $tagsref->{$spec}) {
@names = @$tagdata;
}
else {
warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
++$oops;
next;
}
}
elsif ($spec =~ m:^/(.*)/$:){
my $patn = $1;
@allexports = keys %$export_cache unless @allexports; # only do keys once
@names = grep(/$patn/, @allexports); # not anchored by default
}
else {
@names = ($spec); # is a normal symbol name
}
warn "Import ".($remove ? "del":"add").": @names "
if $Exporter::Verbose;
if ($remove) {
foreach $sym (@names) { delete $imports{$sym} }
}
else {
@imports{@names} = (1) x @names;
}
}
@imports = keys %imports;
}
my @carp;
foreach $sym (@imports) {
if (!$export_cache->{$sym}) {
if ($sym =~ m/^\d/) {
$pkg->VERSION($sym); # inherit from UNIVERSAL
# If the version number was the only thing specified
# then we should act as if nothing was specified:
if (@imports == 1) {
@imports = @$exports;
last;
}
# We need a way to emulate 'use Foo ()' but still
# allow an easy version check: "use Foo 1.23, ''";
if (@imports == 2 and !$imports[1]) {
@imports = ();
last;
}
} elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
# Last chance - see if they've updated EXPORT_OK since we
# cached it.
unless ($cache_is_current) {
%$export_cache = ();
_rebuild_cache ($pkg, $exports, $export_cache);
$cache_is_current = 1;
}
if (!$export_cache->{$sym}) {
# accumulate the non-exports
push @carp,
qq["$sym" is not exported by the $pkg module\n];
$oops++;
}
}
}
}
if ($oops) {
require Carp;
Carp::croak("@{carp}Can't continue after import errors");
}
}
else {
@imports = @$exports;
}
my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
$Exporter::FailCache{$pkg} ||= {});
if (@$fail) {
if (!%$fail_cache) {
# Build cache of symbols. Optimise the lookup by adding
# barewords twice... both with and without a leading &.
# (Technique could be applied to $export_cache at cost of memory)
my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose;
@{$fail_cache}{@expanded} = (1) x @expanded;
}
my @failed;
foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
if (@failed) {
@failed = $pkg->export_fail(@failed);
foreach $sym (@failed) {
require Carp;
Carp::carp(qq["$sym" is not implemented by the $pkg module ],
"on this architecture");
}
if (@failed) {
require Carp;
Carp::croak("Can't continue after import errors");
}
}
}
warn "Importing into $callpkg from $pkg: ",
join(", ",sort @imports) if $Exporter::Verbose;
foreach $sym (@imports) {
# shortcut for the common case of no type character
(*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
unless $sym =~ s/^(\W)//;
$type = $1;
no warnings 'once';
*{"${callpkg}::$sym"} =
$type eq '&' ? \&{"${pkg}::$sym"} :
$type eq '$' ? \${"${pkg}::$sym"} :
$type eq '@' ? \@{"${pkg}::$sym"} :
$type eq '%' ? \%{"${pkg}::$sym"} :
$type eq '*' ? *{"${pkg}::$sym"} :
do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
}
}
sub heavy_export_to_level
{
my $pkg = shift;
my $level = shift;
(undef) = shift; # XXX redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
}
# Utility functions
sub _push_tags {
my($pkg, $var, $syms) = @_;
my @nontag = ();
my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
push(@{"${pkg}::$var"},
map { $export_tags->{$_} ? @{$export_tags->{$_}}
: scalar(push(@nontag,$_),$_) }
(@$syms) ? @$syms : keys %$export_tags);
if (@nontag and $^W) {
# This may change to a die one day
require Carp;
Carp::carp(join(", ", @nontag)." are not tags of $pkg");
}
}
sub heavy_require_version {
my($self, $wanted) = @_;
my $pkg = ref $self || $self;
return ${pkg}->VERSION($wanted);
}
sub heavy_export_tags {
_push_tags((caller)[0], "EXPORT", \@_);
}
sub heavy_export_ok_tags {
_push_tags((caller)[0], "EXPORT_OK", \@_);
}
1;

138
common/perl-base/Fcntl.pm Normal file
View File

@@ -0,0 +1,138 @@
package Fcntl;
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
require Exporter;
require XSLoader;
@ISA = qw(Exporter);
$VERSION = '1.13';
XSLoader::load();
# 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
)],
);
# 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
F_GETLEASE
F_GETPIPE_SZ
F_GETSIG
F_NOTIFY
F_SETLEASE
F_SETPIPE_SZ
F_SETSIG
LOCK_MAND
LOCK_READ
LOCK_RW
LOCK_WRITE
O_ALT_IO
O_EVTONLY
O_IGNORE_CTTY
O_NOATIME
O_NOLINK
O_NOSIGPIPE
O_NOTRANS
O_SYMLINK
O_TTY_INIT
), map {@{$_}} values %EXPORT_TAGS);
1;

View File

@@ -0,0 +1,210 @@
package File::Basename;
# File::Basename is used during the Perl build, when the re extension may
# not be available, but we only actually need it if running under tainting.
BEGIN {
if (${^TAINT}) {
require re;
re->import('taint');
}
}
use strict;
use 5.006;
use warnings;
our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
$VERSION = "2.85";
fileparse_set_fstype($^O);
sub fileparse {
my($fullname,@suffices) = @_;
unless (defined $fullname) {
require Carp;
Carp::croak("fileparse(): need a valid pathname");
}
my $orig_type = '';
my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
my($taint) = substr($fullname,0,0); # Is $fullname tainted?
if ($type eq "VMS" and $fullname =~ m{/} ) {
# We're doing Unix emulation
$orig_type = $type;
$type = 'Unix';
}
my($dirpath, $basename);
if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) {
($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
$dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
}
elsif ($type eq "OS2") {
($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s);
$dirpath = './' unless $dirpath; # Can't be 0
$dirpath .= '/' unless $dirpath =~ m#[\\/]\z#;
}
elsif ($type eq "MacOS") {
($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
$dirpath = ':' unless $dirpath;
}
elsif ($type eq "AmigaOS") {
($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
$dirpath = './' unless $dirpath;
}
elsif ($type eq 'VMS' ) {
($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
$dirpath ||= ''; # should always be defined
}
else { # Default to Unix semantics.
($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s);
if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) {
# dev:[000000] is top of VMS tree, similar to Unix '/'
# so strip it off and treat the rest as "normal"
my $devspec = $1;
my $remainder = $3;
($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s);
$dirpath ||= ''; # should always be defined
$dirpath = $devspec.$dirpath;
}
$dirpath = './' unless $dirpath;
}
my $tail = '';
my $suffix = '';
if (@suffices) {
foreach $suffix (@suffices) {
my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
if ($basename =~ s/$pat//s) {
$taint .= substr($suffix,0,0);
$tail = $1 . $tail;
}
}
}
# Ensure taint is propagated from the path to its pieces.
$tail .= $taint;
wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
: ($basename .= $taint);
}
sub basename {
my($path) = shift;
# From BSD basename(1)
# The basename utility deletes any prefix ending with the last slash '/'
# character present in string (after first stripping trailing slashes)
_strip_trailing_sep($path);
my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) );
# From BSD basename(1)
# The suffix is not stripped if it is identical to the remaining
# characters in string.
if( length $suffix and !length $basename ) {
$basename = $suffix;
}
# Ensure that basename '/' == '/'
if( !length $basename ) {
$basename = $dirname;
}
return $basename;
}
sub dirname {
my $path = shift;
my($type) = $Fileparse_fstype;
if( $type eq 'VMS' and $path =~ m{/} ) {
# Parse as Unix
local($File::Basename::Fileparse_fstype) = '';
return dirname($path);
}
my($basename, $dirname) = fileparse($path);
if ($type eq 'VMS') {
$dirname ||= $ENV{DEFAULT};
}
elsif ($type eq 'MacOS') {
if( !length($basename) && $dirname !~ /^[^:]+:\z/) {
_strip_trailing_sep($dirname);
($basename,$dirname) = fileparse $dirname;
}
$dirname .= ":" unless $dirname =~ /:\z/;
}
elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
_strip_trailing_sep($dirname);
unless( length($basename) ) {
($basename,$dirname) = fileparse $dirname;
_strip_trailing_sep($dirname);
}
}
elsif ($type eq 'AmigaOS') {
if ( $dirname =~ /:\z/) { return $dirname }
chop $dirname;
$dirname =~ s{[^:/]+\z}{} unless length($basename);
}
else {
_strip_trailing_sep($dirname);
unless( length($basename) ) {
($basename,$dirname) = fileparse $dirname;
_strip_trailing_sep($dirname);
}
}
$dirname;
}
# Strip the trailing path separator.
sub _strip_trailing_sep {
my $type = $Fileparse_fstype;
if ($type eq 'MacOS') {
$_[0] =~ s/([^:]):\z/$1/s;
}
elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) {
$_[0] =~ s/([^:])[\\\/]*\z/$1/;
}
else {
$_[0] =~ s{(.)/*\z}{$1}s;
}
}
BEGIN {
my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc);
my @Types = (@Ignore_Case, qw(Unix));
sub fileparse_set_fstype {
my $old = $Fileparse_fstype;
if (@_) {
my $new_type = shift;
$Fileparse_fstype = 'Unix'; # default
foreach my $type (@Types) {
$Fileparse_fstype = $type if $new_type =~ /^$type/i;
}
$Fileparse_igncase =
(grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0;
}
return $old;
}
}
1;

View File

@@ -0,0 +1,90 @@
package File::Glob;
use strict;
our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, $DEFAULT_FLAGS);
require XSLoader;
@ISA = qw(Exporter);
# NOTE: The glob() export is only here for compatibility with 5.6.0.
# csh_glob() should not be used directly, unless you know what you're doing.
%EXPORT_TAGS = (
'glob' => [ qw(
GLOB_ABEND
GLOB_ALPHASORT
GLOB_ALTDIRFUNC
GLOB_BRACE
GLOB_CSH
GLOB_ERR
GLOB_ERROR
GLOB_LIMIT
GLOB_MARK
GLOB_NOCASE
GLOB_NOCHECK
GLOB_NOMAGIC
GLOB_NOSORT
GLOB_NOSPACE
GLOB_QUOTE
GLOB_TILDE
bsd_glob
glob
) ],
);
$EXPORT_TAGS{bsd_glob} = [@{$EXPORT_TAGS{glob}}];
pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob"
@EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
$VERSION = '1.28';
sub import {
require Exporter;
local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
Exporter::import(grep {
my $passthrough;
if ($_ eq ':case') {
$DEFAULT_FLAGS &= ~GLOB_NOCASE()
}
elsif ($_ eq ':nocase') {
$DEFAULT_FLAGS |= GLOB_NOCASE();
}
elsif ($_ eq ':globally') {
no warnings 'redefine';
*CORE::GLOBAL::glob = \&File::Glob::csh_glob;
}
elsif ($_ eq ':bsd_glob') {
no strict; *{caller."::glob"} = \&bsd_glob_override;
$passthrough = 1;
}
else {
$passthrough = 1;
}
$passthrough;
} @_);
}
XSLoader::load();
$DEFAULT_FLAGS = GLOB_CSH();
if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos)$/) {
$DEFAULT_FLAGS |= GLOB_NOCASE();
}
# File::Glob::glob() is deprecated because its prototype is different from
# CORE::glob() (use bsd_glob() instead)
sub glob {
use 5.024;
use warnings ();
warnings::warnif (deprecated =>
"File::Glob::glob() will disappear in perl 5.30. " .
"Use File::Glob::bsd_glob() instead.") unless state $warned ++;
splice @_, 1; # no flags
goto &bsd_glob;
}
1;
__END__

View File

@@ -0,0 +1,583 @@
package File::Path;
use 5.005_04;
use strict;
use Cwd 'getcwd';
use File::Basename ();
use File::Spec ();
BEGIN {
if ( $] < 5.006 ) {
# can't say 'opendir my $dh, $dirname'
# need to initialise $dh
eval 'use Symbol';
}
}
use Exporter ();
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
$VERSION = '2.12_01';
$VERSION = eval $VERSION;
@ISA = qw(Exporter);
@EXPORT = qw(mkpath rmtree);
@EXPORT_OK = qw(make_path remove_tree);
BEGIN {
for (qw(VMS MacOS MSWin32 os2)) {
no strict 'refs';
*{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 };
}
# These OSes complain if you want to remove a file that you have no
# write permission to:
*_FORCE_WRITABLE = (
grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2)
) ? sub () { 1 } : sub () { 0 };
# Unix-like systems need to stat each directory in order to detect
# race condition. MS-Windows is immune to this particular attack.
*_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 };
}
sub _carp {
require Carp;
goto &Carp::carp;
}
sub _croak {
require Carp;
goto &Carp::croak;
}
sub _error {
my $arg = shift;
my $message = shift;
my $object = shift;
if ( $arg->{error} ) {
$object = '' unless defined $object;
$message .= ": $!" if $!;
push @{ ${ $arg->{error} } }, { $object => $message };
}
else {
_carp( defined($object) ? "$message for $object: $!" : "$message: $!" );
}
}
sub __is_arg {
my ($arg) = @_;
# If client code blessed an array ref to HASH, this will not work
# properly. We could have done $arg->isa() wrapped in eval, but
# that would be expensive. This implementation should suffice.
# We could have also used Scalar::Util:blessed, but we choose not
# to add this dependency
return ( ref $arg eq 'HASH' );
}
sub make_path {
push @_, {} unless @_ and __is_arg( $_[-1] );
goto &mkpath;
}
sub mkpath {
my $old_style = !( @_ and __is_arg( $_[-1] ) );
my $arg;
my $paths;
if ($old_style) {
my ( $verbose, $mode );
( $paths, $verbose, $mode ) = @_;
$paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
$arg->{verbose} = $verbose;
$arg->{mode} = defined $mode ? $mode : oct '777';
}
else {
my %args_permitted = map { $_ => 1 } ( qw|
chmod
error
group
mask
mode
owner
uid
user
verbose
| );
my @bad_args = ();
$arg = pop @_;
for my $k (sort keys %{$arg}) {
push @bad_args, $k unless $args_permitted{$k};
}
_carp("Unrecognized option(s) passed to make_path(): @bad_args")
if @bad_args;
$arg->{mode} = delete $arg->{mask} if exists $arg->{mask};
$arg->{mode} = oct '777' unless exists $arg->{mode};
${ $arg->{error} } = [] if exists $arg->{error};
$arg->{owner} = delete $arg->{user} if exists $arg->{user};
$arg->{owner} = delete $arg->{uid} if exists $arg->{uid};
if ( exists $arg->{owner} and $arg->{owner} =~ /\D/ ) {
my $uid = ( getpwnam $arg->{owner} )[2];
if ( defined $uid ) {
$arg->{owner} = $uid;
}
else {
_error( $arg,
"unable to map $arg->{owner} to a uid, ownership not changed"
);
delete $arg->{owner};
}
}
if ( exists $arg->{group} and $arg->{group} =~ /\D/ ) {
my $gid = ( getgrnam $arg->{group} )[2];
if ( defined $gid ) {
$arg->{group} = $gid;
}
else {
_error( $arg,
"unable to map $arg->{group} to a gid, group ownership not changed"
);
delete $arg->{group};
}
}
if ( exists $arg->{owner} and not exists $arg->{group} ) {
$arg->{group} = -1; # chown will leave group unchanged
}
if ( exists $arg->{group} and not exists $arg->{owner} ) {
$arg->{owner} = -1; # chown will leave owner unchanged
}
$paths = [@_];
}
return _mkpath( $arg, $paths );
}
sub _mkpath {
my $arg = shift;
my $paths = shift;
my ( @created );
foreach my $path ( @{$paths} ) {
next unless defined($path) and length($path);
$path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT
# Logic wants Unix paths, so go with the flow.
if (_IS_VMS) {
next if $path eq '/';
$path = VMS::Filespec::unixify($path);
}
next if -d $path;
my $parent = File::Basename::dirname($path);
unless ( -d $parent or $path eq $parent ) {
push( @created, _mkpath( $arg, [$parent] ) );
}
print "mkdir $path\n" if $arg->{verbose};
if ( mkdir( $path, $arg->{mode} ) ) {
push( @created, $path );
if ( exists $arg->{owner} ) {
# NB: $arg->{group} guaranteed to be set during initialisation
if ( !chown $arg->{owner}, $arg->{group}, $path ) {
_error( $arg,
"Cannot change ownership of $path to $arg->{owner}:$arg->{group}"
);
}
}
if ( exists $arg->{chmod} ) {
if ( !chmod $arg->{chmod}, $path ) {
_error( $arg,
"Cannot change permissions of $path to $arg->{chmod}" );
}
}
}
else {
my $save_bang = $!;
my ( $e, $e1 ) = ( $save_bang, $^E );
$e .= "; $e1" if $e ne $e1;
# allow for another process to have created it meanwhile
if ( ! -d $path ) {
$! = $save_bang;
if ( $arg->{error} ) {
push @{ ${ $arg->{error} } }, { $path => $e };
}
else {
_croak("mkdir $path: $e");
}
}
}
}
return @created;
}
sub remove_tree {
push @_, {} unless @_ and __is_arg( $_[-1] );
goto &rmtree;
}
sub _is_subdir {
my ( $dir, $test ) = @_;
my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 );
my ( $tv, $td ) = File::Spec->splitpath( $test, 1 );
# not on same volume
return 0 if $dv ne $tv;
my @d = File::Spec->splitdir($dd);
my @t = File::Spec->splitdir($td);
# @t can't be a subdir if it's shorter than @d
return 0 if @t < @d;
return join( '/', @d ) eq join( '/', splice @t, 0, +@d );
}
sub rmtree {
my $old_style = !( @_ and __is_arg( $_[-1] ) );
my $arg;
my $paths;
if ($old_style) {
my ( $verbose, $safe );
( $paths, $verbose, $safe ) = @_;
$arg->{verbose} = $verbose;
$arg->{safe} = defined $safe ? $safe : 0;
if ( defined($paths) and length($paths) ) {
$paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
}
else {
_carp("No root path(s) specified\n");
return 0;
}
}
else {
my %args_permitted = map { $_ => 1 } ( qw|
error
keep_root
result
safe
verbose
| );
my @bad_args = ();
$arg = pop @_;
for my $k (sort keys %{$arg}) {
push @bad_args, $k unless $args_permitted{$k};
}
_carp("Unrecognized option(s) passed to remove_tree(): @bad_args")
if @bad_args;
${ $arg->{error} } = [] if exists $arg->{error};
${ $arg->{result} } = [] if exists $arg->{result};
$paths = [@_];
}
$arg->{prefix} = '';
$arg->{depth} = 0;
my @clean_path;
$arg->{cwd} = getcwd() or do {
_error( $arg, "cannot fetch initial working directory" );
return 0;
};
for ( $arg->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint
for my $p (@$paths) {
# need to fixup case and map \ to / on Windows
my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p;
my $ortho_cwd =
_IS_MSWIN32 ? _slash_lc( $arg->{cwd} ) : $arg->{cwd};
my $ortho_root_length = length($ortho_root);
$ortho_root_length-- if _IS_VMS; # don't compare '.' with ']'
if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
local $! = 0;
_error( $arg, "cannot remove path when cwd is $arg->{cwd}", $p );
next;
}
if (_IS_MACOS) {
$p = ":$p" unless $p =~ /:/;
$p .= ":" unless $p =~ /:\z/;
}
elsif ( _IS_MSWIN32 ) {
$p =~ s{[/\\]\z}{};
}
else {
$p =~ s{/\z}{};
}
push @clean_path, $p;
}
@{$arg}{qw(device inode perm)} = ( lstat $arg->{cwd} )[ 0, 1 ] or do {
_error( $arg, "cannot stat initial working directory", $arg->{cwd} );
return 0;
};
return _rmtree( $arg, \@clean_path );
}
sub _rmtree {
my $arg = shift;
my $paths = shift;
my $count = 0;
my $curdir = File::Spec->curdir();
my $updir = File::Spec->updir();
my ( @files, $root );
ROOT_DIR:
foreach my $root (@$paths) {
# since we chdir into each directory, it may not be obvious
# to figure out where we are if we generate a message about
# a file name. We therefore construct a semi-canonical
# filename, anchored from the directory being unlinked (as
# opposed to being truly canonical, anchored from the root (/).
my $canon =
$arg->{prefix}
? File::Spec->catfile( $arg->{prefix}, $root )
: $root;
my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
or next ROOT_DIR;
if ( -d _ ) {
$root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) )
if _IS_VMS;
if ( !chdir($root) ) {
# see if we can escalate privileges to get in
# (e.g. funny protection mask such as -w- instead of rwx)
# This uses fchmod to avoid traversing outside of the proper
# location (CVE-2017-6512)
my $root_fh;
if (open($root_fh, '<', $root)) {
my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1];
$perm &= oct '7777';
my $nperm = $perm | oct '700';
local $@;
if (
!(
$arg->{safe}
or $nperm == $perm
or !-d _
or $fh_dev ne $ldev
or $fh_inode ne $lino
or eval { chmod( $nperm, $root_fh ) }
)
)
{
_error( $arg,
"cannot make child directory read-write-exec", $canon );
next ROOT_DIR;
}
close $root_fh;
}
if ( !chdir($root) ) {
_error( $arg, "cannot chdir to child", $canon );
next ROOT_DIR;
}
}
my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ]
or do {
_error( $arg, "cannot stat current working directory", $canon );
next ROOT_DIR;
};
if (_NEED_STAT_CHECK) {
( $ldev eq $cur_dev and $lino eq $cur_inode )
or _croak(
"directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."
);
}
$perm &= oct '7777'; # don't forget setuid, setgid, sticky bits
my $nperm = $perm | oct '700';
# notabene: 0700 is for making readable in the first place,
# it's also intended to change it to writable in case we have
# to recurse in which case we are better than rm -rf for
# subtrees with strange permissions
if (
!(
$arg->{safe}
or $nperm == $perm
or chmod( $nperm, $curdir )
)
)
{
_error( $arg, "cannot make directory read+writeable", $canon );
$nperm = $perm;
}
my $d;
$d = gensym() if $] < 5.006;
if ( !opendir $d, $curdir ) {
_error( $arg, "cannot opendir", $canon );
@files = ();
}
else {
if ( !defined ${^TAINT} or ${^TAINT} ) {
# Blindly untaint dir names if taint mode is active
@files = map { /\A(.*)\z/s; $1 } readdir $d;
}
else {
@files = readdir $d;
}
closedir $d;
}
if (_IS_VMS) {
# Deleting large numbers of files from VMS Files-11
# filesystems is faster if done in reverse ASCIIbetical order.
# include '.' to '.;' from blead patch #31775
@files = map { $_ eq '.' ? '.;' : $_ } reverse @files;
}
@files = grep { $_ ne $updir and $_ ne $curdir } @files;
if (@files) {
# remove the contained files before the directory itself
my $narg = {%$arg};
@{$narg}{qw(device inode cwd prefix depth)} =
( $cur_dev, $cur_inode, $updir, $canon, $arg->{depth} + 1 );
$count += _rmtree( $narg, \@files );
}
# restore directory permissions of required now (in case the rmdir
# below fails), while we are still in the directory and may do so
# without a race via '.'
if ( $nperm != $perm and not chmod( $perm, $curdir ) ) {
_error( $arg, "cannot reset chmod", $canon );
}
# don't leave the client code in an unexpected directory
chdir( $arg->{cwd} )
or
_croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting.");
# ensure that a chdir upwards didn't take us somewhere other
# than we expected (see CVE-2002-0435)
( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ]
or _croak(
"cannot stat prior working directory $arg->{cwd}: $!, aborting."
);
if (_NEED_STAT_CHECK) {
( $arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode )
or _croak( "previous directory $arg->{cwd} "
. "changed before entering $canon, "
. "expected dev=$ldev ino=$lino, "
. "actual dev=$cur_dev ino=$cur_inode, aborting."
);
}
if ( $arg->{depth} or !$arg->{keep_root} ) {
if ( $arg->{safe}
&& ( _IS_VMS
? !&VMS::Filespec::candelete($root)
: !-w $root ) )
{
print "skipped $root\n" if $arg->{verbose};
next ROOT_DIR;
}
if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) {
_error( $arg, "cannot make directory writeable", $canon );
}
print "rmdir $root\n" if $arg->{verbose};
if ( rmdir $root ) {
push @{ ${ $arg->{result} } }, $root if $arg->{result};
++$count;
}
else {
_error( $arg, "cannot remove directory", $canon );
if (
_FORCE_WRITABLE
&& !chmod( $perm,
( _IS_VMS ? VMS::Filespec::fileify($root) : $root )
)
)
{
_error(
$arg,
sprintf( "cannot restore permissions to 0%o",
$perm ),
$canon
);
}
}
}
}
else {
# not a directory
$root = VMS::Filespec::vmsify("./$root")
if _IS_VMS
&& !File::Spec->file_name_is_absolute($root)
&& ( $root !~ m/(?<!\^)[\]>]+/ ); # not already in VMS syntax
if (
$arg->{safe}
&& (
_IS_VMS
? !&VMS::Filespec::candelete($root)
: !( -l $root || -w $root )
)
)
{
print "skipped $root\n" if $arg->{verbose};
next ROOT_DIR;
}
my $nperm = $perm & oct '7777' | oct '600';
if ( _FORCE_WRITABLE
and $nperm != $perm
and not chmod $nperm, $root )
{
_error( $arg, "cannot make file writeable", $canon );
}
print "unlink $canon\n" if $arg->{verbose};
# delete all versions under VMS
for ( ; ; ) {
if ( unlink $root ) {
push @{ ${ $arg->{result} } }, $root if $arg->{result};
}
else {
_error( $arg, "cannot unlink file", $canon );
_FORCE_WRITABLE and chmod( $perm, $root )
or _error( $arg,
sprintf( "cannot restore permissions to 0%o", $perm ),
$canon );
last;
}
++$count;
last unless _IS_VMS && lstat $root;
}
}
}
return $count;
}
sub _slash_lc {
# fix up slashes and case on MSWin32 so that we can determine that
# c:\path\to\dir is underneath C:/Path/To
my $path = shift;
$path =~ tr{\\}{/};
return lc($path);
}
1;
__END__

View File

@@ -0,0 +1,28 @@
package File::Spec;
use strict;
use vars qw(@ISA $VERSION);
$VERSION = '3.67';
$VERSION =~ tr/_//d;
my %module = (MacOS => 'Mac',
MSWin32 => 'Win32',
os2 => 'OS2',
VMS => 'VMS',
epoc => 'Epoc',
NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP.
cygwin => 'Cygwin',
amigaos => 'AmigaOS');
my $module = $module{$^O} || 'Unix';
require "File/Spec/$module.pm";
@ISA = ("File::Spec::$module");
1;
__END__

View File

@@ -0,0 +1,341 @@
package File::Spec::Unix;
use strict;
use vars qw($VERSION);
$VERSION = '3.67';
my $xs_version = $VERSION;
$VERSION =~ tr/_//d;
#dont try to load XSLoader and DynaLoader only to ultimately fail on miniperl
if(!defined &canonpath && defined &DynaLoader::boot_DynaLoader) {
eval {#eval is questionable since we are handling potential errors like
#"Cwd object version 3.48 does not match bootstrap parameter 3.50
#at lib/DynaLoader.pm line 216." by having this eval
if ( $] >= 5.006 ) {
require XSLoader;
XSLoader::load("Cwd", $xs_version);
} else {
require Cwd;
}
};
}
sub _pp_canonpath {
my ($self,$path) = @_;
return unless defined $path;
# Handle POSIX-style node names beginning with double slash (qnx, nto)
# (POSIX says: "a pathname that begins with two successive slashes
# may be interpreted in an implementation-defined manner, although
# more than two leading slashes shall be treated as a single slash.")
my $node = '';
my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
if ( $double_slashes_special
&& ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
$node = $1;
}
# This used to be
# $path =~ s|/+|/|g unless ($^O eq 'cygwin');
# but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
# (Mainly because trailing "" directories didn't get stripped).
# Why would cygwin avoid collapsing multiple slashes into one? --jhi
$path =~ s|/{2,}|/|g; # xx////xx -> xx/xx
$path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx
$path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx
$path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx
$path =~ s|^/\.\.$|/|; # /.. -> /
$path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx
return "$node$path";
}
*canonpath = \&_pp_canonpath unless defined &canonpath;
sub _pp_catdir {
my $self = shift;
$self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
}
*catdir = \&_pp_catdir unless defined &catdir;
sub _pp_catfile {
my $self = shift;
my $file = $self->canonpath(pop @_);
return $file unless @_;
my $dir = $self->catdir(@_);
$dir .= "/" unless substr($dir,-1) eq "/";
return $dir.$file;
}
*catfile = \&_pp_catfile unless defined &catfile;
sub curdir { '.' }
use constant _fn_curdir => ".";
sub devnull { '/dev/null' }
use constant _fn_devnull => "/dev/null";
sub rootdir { '/' }
use constant _fn_rootdir => "/";
my ($tmpdir, %tmpenv);
# Cache and return the calculated tmpdir, recording which env vars
# determined it.
sub _cache_tmpdir {
@tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]};
return $tmpdir = $_[1];
}
# Retrieve the cached tmpdir, checking first whether relevant env vars have
# changed and invalidated the cache.
sub _cached_tmpdir {
shift;
local $^W;
return if grep $ENV{$_} ne $tmpenv{$_}, @_;
return $tmpdir;
}
sub _tmpdir {
my $self = shift;
my @dirlist = @_;
my $taint = do { no strict 'refs'; ${"\cTAINT"} };
if ($taint) { # Check for taint mode on perl >= 5.8.0
require Scalar::Util;
@dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
}
elsif ($] < 5.007) { # No ${^TAINT} before 5.8
@dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist;
}
foreach (@dirlist) {
next unless defined && -d && -w _;
$tmpdir = $_;
last;
}
$tmpdir = $self->curdir unless defined $tmpdir;
$tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
if ( !$self->file_name_is_absolute($tmpdir) ) {
# See [perl #120593] for the full details
# If possible, return a full path, rather than '.' or 'lib', but
# jump through some hoops to avoid returning a tainted value.
($tmpdir) = grep {
$taint ? ! Scalar::Util::tainted($_) :
$] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1
} $self->rel2abs($tmpdir), $tmpdir;
}
return $tmpdir;
}
sub tmpdir {
my $cached = $_[0]->_cached_tmpdir('TMPDIR');
return $cached if defined $cached;
$_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR');
}
sub updir { '..' }
use constant _fn_updir => "..";
sub no_upwards {
my $self = shift;
return grep(!/^\.{1,2}\z/s, @_);
}
sub case_tolerant { 0 }
use constant _fn_case_tolerant => 0;
sub file_name_is_absolute {
my ($self,$file) = @_;
return scalar($file =~ m:^/:s);
}
sub path {
return () unless exists $ENV{PATH};
my @path = split(':', $ENV{PATH});
foreach (@path) { $_ = '.' if $_ eq '' }
return @path;
}
sub join {
my $self = shift;
return $self->catfile(@_);
}
sub splitpath {
my ($self,$path, $nofile) = @_;
my ($volume,$directory,$file) = ('','','');
if ( $nofile ) {
$directory = $path;
}
else {
$path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
$directory = $1;
$file = $2;
}
return ($volume,$directory,$file);
}
sub splitdir {
return split m|/|, $_[1], -1; # Preserve trailing fields
}
sub catpath {
my ($self,$volume,$directory,$file) = @_;
if ( $directory ne '' &&
$file ne '' &&
substr( $directory, -1 ) ne '/' &&
substr( $file, 0, 1 ) ne '/'
) {
$directory .= "/$file" ;
}
else {
$directory .= $file ;
}
return $directory ;
}
sub abs2rel {
my($self,$path,$base) = @_;
$base = $self->_cwd() unless defined $base and length $base;
($path, $base) = map $self->canonpath($_), $path, $base;
my $path_directories;
my $base_directories;
if (grep $self->file_name_is_absolute($_), $path, $base) {
($path, $base) = map $self->rel2abs($_), $path, $base;
my ($path_volume) = $self->splitpath($path, 1);
my ($base_volume) = $self->splitpath($base, 1);
# Can't relativize across volumes
return $path unless $path_volume eq $base_volume;
$path_directories = ($self->splitpath($path, 1))[1];
$base_directories = ($self->splitpath($base, 1))[1];
# For UNC paths, the user might give a volume like //foo/bar that
# strictly speaking has no directory portion. Treat it as if it
# had the root directory for that volume.
if (!length($base_directories) and $self->file_name_is_absolute($base)) {
$base_directories = $self->rootdir;
}
}
else {
my $wd= ($self->splitpath($self->_cwd(), 1))[1];
$path_directories = $self->catdir($wd, $path);
$base_directories = $self->catdir($wd, $base);
}
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
my @basechunks = $self->splitdir( $base_directories );
if ($base_directories eq $self->rootdir) {
return $self->curdir if $path_directories eq $self->rootdir;
shift @pathchunks;
return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
}
my @common;
while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
push @common, shift @pathchunks ;
shift @basechunks ;
}
return $self->curdir unless @pathchunks || @basechunks;
# @basechunks now contains the directories the resulting relative path
# must ascend out of before it can descend to $path_directory. If there
# are updir components, we must descend into the corresponding directories
# (this only works if they are no symlinks).
my @reverse_base;
while( defined(my $dir= shift @basechunks) ) {
if( $dir ne $self->updir ) {
unshift @reverse_base, $self->updir;
push @common, $dir;
}
elsif( @common ) {
if( @reverse_base && $reverse_base[0] eq $self->updir ) {
shift @reverse_base;
pop @common;
}
else {
unshift @reverse_base, pop @common;
}
}
}
my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
return $self->canonpath( $self->catpath('', $result_dirs, '') );
}
sub _same {
$_[1] eq $_[2];
}
sub rel2abs {
my ($self,$path,$base ) = @_;
# Clean up $path
if ( ! $self->file_name_is_absolute( $path ) ) {
# Figure out the effective $base and clean it up.
if ( !defined( $base ) || $base eq '' ) {
$base = $self->_cwd();
}
elsif ( ! $self->file_name_is_absolute( $base ) ) {
$base = $self->rel2abs( $base ) ;
}
else {
$base = $self->canonpath( $base ) ;
}
# Glom them together
$path = $self->catdir( $base, $path ) ;
}
return $self->canonpath( $path ) ;
}
# Internal routine to File::Spec, no point in making this public since
# it is the standard Cwd interface. Most of the platform-specific
# File::Spec subclasses use this.
sub _cwd {
require Cwd;
Cwd::getcwd();
}
# Internal method to reduce xx\..\yy -> yy
sub _collapse {
my($fs, $path) = @_;
my $updir = $fs->updir;
my $curdir = $fs->curdir;
my($vol, $dirs, $file) = $fs->splitpath($path);
my @dirs = $fs->splitdir($dirs);
pop @dirs if @dirs && $dirs[-1] eq '';
my @collapsed;
foreach my $dir (@dirs) {
if( $dir eq $updir and # if we have an updir
@collapsed and # and something to collapse
length $collapsed[-1] and # and its not the rootdir
$collapsed[-1] ne $updir and # nor another updir
$collapsed[-1] ne $curdir # nor the curdir
)
{ # then
pop @collapsed; # collapse
}
else { # else
push @collapsed, $dir; # just hang onto it
}
}
return $fs->catpath($vol,
$fs->catdir(@collapsed),
$file
);
}
1;

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,105 @@
package FileHandle;
use 5.006;
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
$VERSION = "2.03";
require IO::File;
@ISA = qw(IO::File);
@EXPORT = qw(_IOFBF _IOLBF _IONBF);
@EXPORT_OK = qw(
pipe
autoflush
output_field_separator
output_record_separator
input_record_separator
input_line_number
format_page_number
format_lines_per_page
format_lines_left
format_name
format_top_name
format_line_break_characters
format_formfeed
print
printf
getline
getlines
);
#
# Everything we're willing to export, we must first import.
#
IO::Handle->import( grep { !defined(&$_) } @EXPORT, @EXPORT_OK );
#
# Some people call "FileHandle::function", so all the functions
# that were in the old FileHandle class must be imported, too.
#
{
no strict 'refs';
my %import = (
'IO::Handle' =>
[qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets
eof flush error clearerr setbuf setvbuf _open_mode_string)],
'IO::Seekable' =>
[qw(seek tell getpos setpos)],
'IO::File' =>
[qw(new new_tmpfile open)]
);
for my $pkg (keys %import) {
for my $func (@{$import{$pkg}}) {
my $c = *{"${pkg}::$func"}{CODE}
or die "${pkg}::$func missing";
*$func = $c;
}
}
}
#
# Specialized importer for Fcntl magic.
#
sub import {
my $pkg = shift;
my $callpkg = caller;
require Exporter;
Exporter::export($pkg, $callpkg, @_);
#
# If the Fcntl extension is available,
# export its constants.
#
eval {
require Fcntl;
Exporter::export('Fcntl', $callpkg);
};
}
################################################
# This is the only exported function we define;
# the rest come from other classes.
#
sub pipe {
my $r = IO::Handle->new;
my $w = IO::Handle->new;
CORE::pipe($r, $w) or return undef;
($r, $w);
}
# Rebless standard file handles
bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle";
bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle";
bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle";
1;
__END__

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,300 @@
package Hash::Util;
require 5.007003;
use strict;
use Carp;
use warnings;
no warnings 'uninitialized';
use warnings::register;
use Scalar::Util qw(reftype);
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
fieldhash fieldhashes
all_keys
lock_keys unlock_keys
lock_value unlock_value
lock_hash unlock_hash
lock_keys_plus
hash_locked hash_unlocked
hashref_locked hashref_unlocked
hidden_keys legal_keys
lock_ref_keys unlock_ref_keys
lock_ref_value unlock_ref_value
lock_hashref unlock_hashref
lock_ref_keys_plus
hidden_ref_keys legal_ref_keys
hash_seed hash_value hv_store
bucket_stats bucket_stats_formatted bucket_info bucket_array
lock_hash_recurse unlock_hash_recurse
lock_hashref_recurse unlock_hashref_recurse
hash_traversal_mask
bucket_ratio
used_buckets
num_buckets
);
BEGIN {
# make sure all our XS routines are available early so their prototypes
# are correctly applied in the following code.
our $VERSION = '0.22';
require XSLoader;
XSLoader::load();
}
sub import {
my $class = shift;
if ( grep /fieldhash/, @_ ) {
require Hash::Util::FieldHash;
Hash::Util::FieldHash->import(':all'); # for re-export
}
unshift @_, $class;
goto &Exporter::import;
}
sub lock_ref_keys {
my($hash, @keys) = @_;
_clear_placeholders(%$hash);
if( @keys ) {
my %keys = map { ($_ => 1) } @keys;
my %original_keys = map { ($_ => 1) } keys %$hash;
foreach my $k (keys %original_keys) {
croak "Hash has key '$k' which is not in the new key set"
unless $keys{$k};
}
foreach my $k (@keys) {
$hash->{$k} = undef unless exists $hash->{$k};
}
Internals::SvREADONLY %$hash, 1;
foreach my $k (@keys) {
delete $hash->{$k} unless $original_keys{$k};
}
}
else {
Internals::SvREADONLY %$hash, 1;
}
return $hash;
}
sub unlock_ref_keys {
my $hash = shift;
Internals::SvREADONLY %$hash, 0;
return $hash;
}
sub lock_keys (\%;@) { lock_ref_keys(@_) }
sub unlock_keys (\%) { unlock_ref_keys(@_) }
#=item B<_clear_placeholders>
#
# This function removes any placeholder keys from a hash. See Perl_hv_clear_placeholders()
# in hv.c for what it does exactly. It is currently exposed as XS by universal.c and
# injected into the Hash::Util namespace.
#
# It is not intended for use outside of this module, and may be changed
# or removed without notice or deprecation cycle.
#
#=cut
#
# sub _clear_placeholders {} # just in case someone searches...
sub lock_ref_keys_plus {
my ($hash,@keys) = @_;
my @delete;
_clear_placeholders(%$hash);
foreach my $key (@keys) {
unless (exists($hash->{$key})) {
$hash->{$key}=undef;
push @delete,$key;
}
}
Internals::SvREADONLY(%$hash,1);
delete @{$hash}{@delete};
return $hash
}
sub lock_keys_plus(\%;@) { lock_ref_keys_plus(@_) }
sub lock_ref_value {
my($hash, $key) = @_;
# I'm doubtful about this warning, as it seems not to be true.
# Marking a value in the hash as RO is useful, regardless
# of the status of the hash itself.
carp "Cannot usefully lock values in an unlocked hash"
if !Internals::SvREADONLY(%$hash) && warnings::enabled;
Internals::SvREADONLY $hash->{$key}, 1;
return $hash
}
sub unlock_ref_value {
my($hash, $key) = @_;
Internals::SvREADONLY $hash->{$key}, 0;
return $hash
}
sub lock_value (\%$) { lock_ref_value(@_) }
sub unlock_value (\%$) { unlock_ref_value(@_) }
sub lock_hashref {
my $hash = shift;
lock_ref_keys($hash);
foreach my $value (values %$hash) {
Internals::SvREADONLY($value,1);
}
return $hash;
}
sub unlock_hashref {
my $hash = shift;
foreach my $value (values %$hash) {
Internals::SvREADONLY($value, 0);
}
unlock_ref_keys($hash);
return $hash;
}
sub lock_hash (\%) { lock_hashref(@_) }
sub unlock_hash (\%) { unlock_hashref(@_) }
sub lock_hashref_recurse {
my $hash = shift;
lock_ref_keys($hash);
foreach my $value (values %$hash) {
my $type = reftype($value);
if (defined($type) and $type eq 'HASH') {
lock_hashref_recurse($value);
}
Internals::SvREADONLY($value,1);
}
return $hash
}
sub unlock_hashref_recurse {
my $hash = shift;
foreach my $value (values %$hash) {
my $type = reftype($value);
if (defined($type) and $type eq 'HASH') {
unlock_hashref_recurse($value);
}
Internals::SvREADONLY($value,0);
}
unlock_ref_keys($hash);
return $hash;
}
sub lock_hash_recurse (\%) { lock_hashref_recurse(@_) }
sub unlock_hash_recurse (\%) { unlock_hashref_recurse(@_) }
sub hashref_locked {
my $hash=shift;
Internals::SvREADONLY(%$hash);
}
sub hash_locked(\%) { hashref_locked(@_) }
sub hashref_unlocked {
my $hash=shift;
!Internals::SvREADONLY(%$hash);
}
sub hash_unlocked(\%) { hashref_unlocked(@_) }
sub legal_keys(\%) { legal_ref_keys(@_) }
sub hidden_keys(\%){ hidden_ref_keys(@_) }
sub bucket_stats {
my ($hash) = @_;
my ($keys, $buckets, $used, @length_counts) = bucket_info($hash);
my $sum;
my $score;
for (1 .. $#length_counts) {
$sum += ($length_counts[$_] * $_);
$score += $length_counts[$_] * ( $_ * ($_ + 1 ) / 2 );
}
$score = $score /
(( $keys / (2 * $buckets )) * ( $keys + ( 2 * $buckets ) - 1 ))
if $keys;
my ($mean, $stddev)= (0, 0);
if ($used) {
$mean= $sum / $used;
$sum= 0;
$sum += ($length_counts[$_] * (($_-$mean)**2)) for 1 .. $#length_counts;
$stddev= sqrt($sum/$used);
}
return $keys, $buckets, $used, $keys ? ($score, $used/$buckets, ($keys-$used)/$keys, $mean, $stddev, @length_counts) : ();
}
sub _bucket_stats_formatted_bars {
my ($total, $ary, $start_idx, $title, $row_title)= @_;
my $return = "";
my $max_width= $total > 64 ? 64 : $total;
my $bar_width= $max_width / $total;
my $str= "";
if ( @$ary < 10) {
for my $idx ($start_idx .. $#$ary) {
$str .= $idx x sprintf("%.0f", ($ary->[$idx] * $bar_width));
}
} else {
$str= "-" x $max_width;
}
$return .= sprintf "%-7s %6d [%s]\n",$title, $total, $str;
foreach my $idx ($start_idx .. $#$ary) {
$return .= sprintf "%-.3s %3d %6.2f%% %6d [%s]\n",
$row_title,
$idx,
$ary->[$idx] / $total * 100,
$ary->[$idx],
"#" x sprintf("%.0f", ($ary->[$idx] * $bar_width)),
;
}
return $return;
}
sub bucket_stats_formatted {
my ($hashref)= @_;
my ($keys, $buckets, $used, $score, $utilization_ratio, $collision_pct,
$mean, $stddev, @length_counts) = bucket_stats($hashref);
my $return= sprintf "Keys: %d Buckets: %d/%d Quality-Score: %.2f (%s)\n"
. "Utilized Buckets: %.2f%% Optimal: %.2f%% Keys In Collision: %.2f%%\n"
. "Chain Length - mean: %.2f stddev: %.2f\n",
$keys, $used, $buckets, $score, $score <= 1.05 ? "Good" : $score < 1.2 ? "Poor" : "Bad",
$utilization_ratio * 100,
$keys/$buckets * 100,
$collision_pct * 100,
$mean, $stddev;
my @key_depth;
$key_depth[$_]= $length_counts[$_] + ( $key_depth[$_+1] || 0 )
for reverse 1 .. $#length_counts;
if ($keys) {
$return .= _bucket_stats_formatted_bars($buckets, \@length_counts, 0, "Buckets", "Len");
$return .= _bucket_stats_formatted_bars($keys, \@key_depth, 1, "Keys", "Pos");
}
return $return
}
1;

30
common/perl-base/IO.pm Normal file
View File

@@ -0,0 +1,30 @@
#
package IO;
use XSLoader ();
use Carp;
use strict;
use warnings;
our $VERSION = "1.38";
XSLoader::load 'IO', $VERSION;
sub import {
shift;
warnings::warnif('deprecated', qq{Parameterless "use IO" deprecated})
if @_ == 0 ;
my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir);
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l)
or croak $@;
}
1;
__END__

View File

@@ -0,0 +1,81 @@
#
package IO::File;
use 5.006_001;
use strict;
our($VERSION, @EXPORT, @EXPORT_OK, @ISA);
use Carp;
use Symbol;
use SelectSaver;
use IO::Seekable;
require Exporter;
@ISA = qw(IO::Handle IO::Seekable Exporter);
$VERSION = "1.16";
@EXPORT = @IO::Seekable::EXPORT;
eval {
# Make all Fcntl O_XXX constants available for importing
require Fcntl;
my @O = grep /^O_/, @Fcntl::EXPORT;
Fcntl->import(@O); # first we import what we want to export
push(@EXPORT, @O);
};
################################################
## Constructor
##
sub new {
my $type = shift;
my $class = ref($type) || $type || "IO::File";
@_ >= 0 && @_ <= 3
or croak "usage: $class->new([FILENAME [,MODE [,PERMS]]])";
my $fh = $class->SUPER::new();
if (@_) {
$fh->open(@_)
or return undef;
}
$fh;
}
################################################
## Open
##
sub open {
@_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
my ($fh, $file) = @_;
if (@_ > 2) {
my ($mode, $perms) = @_[2, 3];
if ($mode =~ /^\d+$/) {
defined $perms or $perms = 0666;
return sysopen($fh, $file, $mode, $perms);
} elsif ($mode =~ /:/) {
return open($fh, $mode, $file) if @_ == 3;
croak 'usage: $fh->open(FILENAME, IOLAYERS)';
} else {
return open($fh, IO::Handle::_open_mode_string($mode), $file);
}
}
open($fh, $file);
}
################################################
## Binmode
##
sub binmode {
( @_ == 1 or @_ == 2 ) or croak 'usage $fh->binmode([LAYER])';
my($fh, $layer) = @_;
return binmode $$fh unless $layer;
return binmode $$fh, $layer;
}
1;

View File

@@ -0,0 +1,391 @@
package IO::Handle;
use 5.006_001;
use strict;
our($VERSION, @EXPORT_OK, @ISA);
use Carp;
use Symbol;
use SelectSaver;
use IO (); # Load the XS module
require Exporter;
@ISA = qw(Exporter);
$VERSION = "1.36";
$VERSION = eval $VERSION;
@EXPORT_OK = qw(
autoflush
output_field_separator
output_record_separator
input_record_separator
input_line_number
format_page_number
format_lines_per_page
format_lines_left
format_name
format_top_name
format_line_break_characters
format_formfeed
format_write
print
printf
say
getline
getlines
printflush
flush
SEEK_SET
SEEK_CUR
SEEK_END
_IOFBF
_IOLBF
_IONBF
);
################################################
## Constructors, destructors.
##
sub new {
my $class = ref($_[0]) || $_[0] || "IO::Handle";
if (@_ != 1) {
# Since perl will automatically require IO::File if needed, but
# also initialises IO::File's @ISA as part of the core we must
# ensure IO::File is loaded if IO::Handle is. This avoids effect-
# ively "half-loading" IO::File.
if ($] > 5.013 && $class eq 'IO::File' && !$INC{"IO/File.pm"}) {
require IO::File;
shift;
return IO::File::->new(@_);
}
croak "usage: $class->new()";
}
my $io = gensym;
bless $io, $class;
}
sub new_from_fd {
my $class = ref($_[0]) || $_[0] || "IO::Handle";
@_ == 3 or croak "usage: $class->new_from_fd(FD, MODE)";
my $io = gensym;
shift;
IO::Handle::fdopen($io, @_)
or return undef;
bless $io, $class;
}
#
# There is no need for DESTROY to do anything, because when the
# last reference to an IO object is gone, Perl automatically
# closes its associated files (if any). However, to avoid any
# attempts to autoload DESTROY, we here define it to do nothing.
#
sub DESTROY {}
################################################
## Open and close.
##
sub _open_mode_string {
my ($mode) = @_;
$mode =~ /^\+?(<|>>?)$/
or $mode =~ s/^r(\+?)$/$1</
or $mode =~ s/^w(\+?)$/$1>/
or $mode =~ s/^a(\+?)$/$1>>/
or croak "IO::Handle: bad open mode: $mode";
$mode;
}
sub fdopen {
@_ == 3 or croak 'usage: $io->fdopen(FD, MODE)';
my ($io, $fd, $mode) = @_;
local(*GLOB);
if (ref($fd) && "".$fd =~ /GLOB\(/o) {
# It's a glob reference; Alias it as we cannot get name of anon GLOBs
my $n = qualify(*GLOB);
*GLOB = *{*$fd};
$fd = $n;
} elsif ($fd =~ m#^\d+$#) {
# It's an FD number; prefix with "=".
$fd = "=$fd";
}
open($io, _open_mode_string($mode) . '&' . $fd)
? $io : undef;
}
sub close {
@_ == 1 or croak 'usage: $io->close()';
my($io) = @_;
close($io);
}
################################################
## Normal I/O functions.
##
# flock
# select
sub opened {
@_ == 1 or croak 'usage: $io->opened()';
defined fileno($_[0]);
}
sub fileno {
@_ == 1 or croak 'usage: $io->fileno()';
fileno($_[0]);
}
sub getc {
@_ == 1 or croak 'usage: $io->getc()';
getc($_[0]);
}
sub eof {
@_ == 1 or croak 'usage: $io->eof()';
eof($_[0]);
}
sub print {
@_ or croak 'usage: $io->print(ARGS)';
my $this = shift;
print $this @_;
}
sub printf {
@_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])';
my $this = shift;
printf $this @_;
}
sub say {
@_ or croak 'usage: $io->say(ARGS)';
my $this = shift;
local $\ = "\n";
print $this @_;
}
# Special XS wrapper to make them inherit lexical hints from the caller.
_create_getline_subs( <<'END' ) or die $@;
sub getline {
@_ == 1 or croak 'usage: $io->getline()';
my $this = shift;
return scalar <$this>;
}
sub getlines {
@_ == 1 or croak 'usage: $io->getlines()';
wantarray or
croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
my $this = shift;
return <$this>;
}
1; # return true for error checking
END
*gets = \&getline; # deprecated
sub truncate {
@_ == 2 or croak 'usage: $io->truncate(LEN)';
truncate($_[0], $_[1]);
}
sub read {
@_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])';
read($_[0], $_[1], $_[2], $_[3] || 0);
}
sub sysread {
@_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])';
sysread($_[0], $_[1], $_[2], $_[3] || 0);
}
sub write {
@_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])';
local($\) = "";
$_[2] = length($_[1]) unless defined $_[2];
print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
}
sub syswrite {
@_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])';
if (defined($_[2])) {
syswrite($_[0], $_[1], $_[2], $_[3] || 0);
} else {
syswrite($_[0], $_[1]);
}
}
sub stat {
@_ == 1 or croak 'usage: $io->stat()';
stat($_[0]);
}
################################################
## State modification functions.
##
sub autoflush {
my $old = new SelectSaver qualify($_[0], caller);
my $prev = $|;
$| = @_ > 1 ? $_[1] : 1;
$prev;
}
sub output_field_separator {
carp "output_field_separator is not supported on a per-handle basis"
if ref($_[0]);
my $prev = $,;
$, = $_[1] if @_ > 1;
$prev;
}
sub output_record_separator {
carp "output_record_separator is not supported on a per-handle basis"
if ref($_[0]);
my $prev = $\;
$\ = $_[1] if @_ > 1;
$prev;
}
sub input_record_separator {
carp "input_record_separator is not supported on a per-handle basis"
if ref($_[0]);
my $prev = $/;
$/ = $_[1] if @_ > 1;
$prev;
}
sub input_line_number {
local $.;
() = tell qualify($_[0], caller) if ref($_[0]);
my $prev = $.;
$. = $_[1] if @_ > 1;
$prev;
}
sub format_page_number {
my $old;
$old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
my $prev = $%;
$% = $_[1] if @_ > 1;
$prev;
}
sub format_lines_per_page {
my $old;
$old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
my $prev = $=;
$= = $_[1] if @_ > 1;
$prev;
}
sub format_lines_left {
my $old;
$old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
my $prev = $-;
$- = $_[1] if @_ > 1;
$prev;
}
sub format_name {
my $old;
$old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
my $prev = $~;
$~ = qualify($_[1], caller) if @_ > 1;
$prev;
}
sub format_top_name {
my $old;
$old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
my $prev = $^;
$^ = qualify($_[1], caller) if @_ > 1;
$prev;
}
sub format_line_break_characters {
carp "format_line_break_characters is not supported on a per-handle basis"
if ref($_[0]);
my $prev = $:;
$: = $_[1] if @_ > 1;
$prev;
}
sub format_formfeed {
carp "format_formfeed is not supported on a per-handle basis"
if ref($_[0]);
my $prev = $^L;
$^L = $_[1] if @_ > 1;
$prev;
}
sub formline {
my $io = shift;
my $picture = shift;
local($^A) = $^A;
local($\) = "";
formline($picture, @_);
print $io $^A;
}
sub format_write {
@_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )';
if (@_ == 2) {
my ($io, $fmt) = @_;
my $oldfmt = $io->format_name(qualify($fmt,caller));
CORE::write($io);
$io->format_name($oldfmt);
} else {
CORE::write($_[0]);
}
}
sub fcntl {
@_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
my ($io, $op) = @_;
return fcntl($io, $op, $_[2]);
}
sub ioctl {
@_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
my ($io, $op) = @_;
return ioctl($io, $op, $_[2]);
}
# this sub is for compatibility with older releases of IO that used
# a sub called constant to determine if a constant existed -- GMB
#
# The SEEK_* and _IO?BF constants were the only constants at that time
# any new code should just check defined(&CONSTANT_NAME)
sub constant {
no strict 'refs';
my $name = shift;
(($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name})
? &{$name}() : undef;
}
# so that flush.pl can be deprecated
sub printflush {
my $io = shift;
my $old;
$old = new SelectSaver qualify($io, caller) if ref($io);
local $| = 1;
if(ref($io)) {
print $io @_;
}
else {
print @_;
}
}
1;

160
common/perl-base/IO/Pipe.pm Normal file
View File

@@ -0,0 +1,160 @@
# IO::Pipe.pm
#
# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Pipe;
use 5.006_001;
use IO::Handle;
use strict;
our($VERSION);
use Carp;
use Symbol;
$VERSION = "1.15";
sub new {
my $type = shift;
my $class = ref($type) || $type || "IO::Pipe";
@_ == 0 || @_ == 2 or croak "usage: $class->([READFH, WRITEFH])";
my $me = bless gensym(), $class;
my($readfh,$writefh) = @_ ? @_ : $me->handles;
pipe($readfh, $writefh)
or return undef;
@{*$me} = ($readfh, $writefh);
$me;
}
sub handles {
@_ == 1 or croak 'usage: $pipe->handles()';
(IO::Pipe::End->new(), IO::Pipe::End->new());
}
my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
sub _doit {
my $me = shift;
my $rw = shift;
my $pid = $do_spawn ? 0 : fork();
if($pid) { # Parent
return $pid;
}
elsif(defined $pid) { # Child or spawn
my $fh;
my $io = $rw ? \*STDIN : \*STDOUT;
my ($mode, $save) = $rw ? "r" : "w";
if ($do_spawn) {
require Fcntl;
$save = IO::Handle->new_from_fd($io, $mode);
my $handle = shift;
# Close in child:
unless ($^O eq 'MSWin32') {
fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
}
$fh = $rw ? ${*$me}[0] : ${*$me}[1];
} else {
shift;
$fh = $rw ? $me->reader() : $me->writer(); # close the other end
}
bless $io, "IO::Handle";
$io->fdopen($fh, $mode);
$fh->close;
if ($do_spawn) {
$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
my $err = $!;
$io->fdopen($save, $mode);
$save->close or croak "Cannot close $!";
croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
return $pid;
} else {
exec @_ or
croak "IO::Pipe: Cannot exec: $!";
}
}
else {
croak "IO::Pipe: Cannot fork: $!";
}
# NOT Reached
}
sub reader {
@_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
my $me = shift;
return undef
unless(ref($me) || ref($me = $me->new));
my $fh = ${*$me}[0];
my $pid;
$pid = $me->_doit(0, $fh, @_)
if(@_);
close ${*$me}[1];
bless $me, ref($fh);
*$me = *$fh; # Alias self to handle
$me->fdopen($fh->fileno,"r")
unless defined($me->fileno);
bless $fh; # Really wan't un-bless here
${*$me}{'io_pipe_pid'} = $pid
if defined $pid;
$me;
}
sub writer {
@_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
my $me = shift;
return undef
unless(ref($me) || ref($me = $me->new));
my $fh = ${*$me}[1];
my $pid;
$pid = $me->_doit(1, $fh, @_)
if(@_);
close ${*$me}[0];
bless $me, ref($fh);
*$me = *$fh; # Alias self to handle
$me->fdopen($fh->fileno,"w")
unless defined($me->fileno);
bless $fh; # Really wan't un-bless here
${*$me}{'io_pipe_pid'} = $pid
if defined $pid;
$me;
}
package IO::Pipe::End;
our(@ISA);
@ISA = qw(IO::Handle);
sub close {
my $fh = shift;
my $r = $fh->SUPER::close(@_);
waitpid(${*$fh}{'io_pipe_pid'},0)
if(defined ${*$fh}{'io_pipe_pid'});
$r;
}
1;
__END__

View File

@@ -0,0 +1,36 @@
#
package IO::Seekable;
use 5.006_001;
use Carp;
use strict;
our($VERSION, @EXPORT, @ISA);
use IO::Handle ();
# XXX we can't get these from IO::Handle or we'll get prototype
# mismatch warnings on C<use POSIX; use IO::File;> :-(
use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END);
require Exporter;
@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
@ISA = qw(Exporter);
$VERSION = "1.10";
$VERSION = eval $VERSION;
sub seek {
@_ == 3 or croak 'usage: $io->seek(POS, WHENCE)';
seek($_[0], $_[1], $_[2]);
}
sub sysseek {
@_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)';
sysseek($_[0], $_[1], $_[2]);
}
sub tell {
@_ == 1 or croak 'usage: $io->tell()';
tell($_[0]);
}
1;

View File

@@ -0,0 +1,248 @@
# IO::Select.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Select;
use strict;
use warnings::register;
use vars qw($VERSION @ISA);
require Exporter;
$VERSION = "1.22";
@ISA = qw(Exporter); # This is only so we can do version checking
sub VEC_BITS () {0}
sub FD_COUNT () {1}
sub FIRST_FD () {2}
sub new
{
my $self = shift;
my $type = ref($self) || $self;
my $vec = bless [undef,0], $type;
$vec->add(@_)
if @_;
$vec;
}
sub add
{
shift->_update('add', @_);
}
sub remove
{
shift->_update('remove', @_);
}
sub exists
{
my $vec = shift;
my $fno = $vec->_fileno(shift);
return undef unless defined $fno;
$vec->[$fno + FIRST_FD];
}
sub _fileno
{
my($self, $f) = @_;
return unless defined $f;
$f = $f->[0] if ref($f) eq 'ARRAY';
($f =~ /^\d+$/) ? $f : fileno($f);
}
sub _update
{
my $vec = shift;
my $add = shift eq 'add';
my $bits = $vec->[VEC_BITS];
$bits = '' unless defined $bits;
my $count = 0;
my $f;
foreach $f (@_)
{
my $fn = $vec->_fileno($f);
if ($add) {
next unless defined $fn;
my $i = $fn + FIRST_FD;
if (defined $vec->[$i]) {
$vec->[$i] = $f; # if array rest might be different, so we update
next;
}
$vec->[FD_COUNT]++;
vec($bits, $fn, 1) = 1;
$vec->[$i] = $f;
} else { # remove
if ( ! defined $fn ) { # remove if fileno undef'd
$fn = 0;
for my $fe (@{$vec}[FIRST_FD .. $#$vec]) {
if (defined($fe) && $fe == $f) {
$vec->[FD_COUNT]--;
$fe = undef;
vec($bits, $fn, 1) = 0;
last;
}
++$fn;
}
}
else {
my $i = $fn + FIRST_FD;
next unless defined $vec->[$i];
$vec->[FD_COUNT]--;
vec($bits, $fn, 1) = 0;
$vec->[$i] = undef;
}
}
$count++;
}
$vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
$count;
}
sub can_read
{
my $vec = shift;
my $timeout = shift;
my $r = $vec->[VEC_BITS];
defined($r) && (select($r,undef,undef,$timeout) > 0)
? handles($vec, $r)
: ();
}
sub can_write
{
my $vec = shift;
my $timeout = shift;
my $w = $vec->[VEC_BITS];
defined($w) && (select(undef,$w,undef,$timeout) > 0)
? handles($vec, $w)
: ();
}
sub has_exception
{
my $vec = shift;
my $timeout = shift;
my $e = $vec->[VEC_BITS];
defined($e) && (select(undef,undef,$e,$timeout) > 0)
? handles($vec, $e)
: ();
}
sub has_error
{
warnings::warn("Call to deprecated method 'has_error', use 'has_exception'")
if warnings::enabled();
goto &has_exception;
}
sub count
{
my $vec = shift;
$vec->[FD_COUNT];
}
sub bits
{
my $vec = shift;
$vec->[VEC_BITS];
}
sub as_string # for debugging
{
my $vec = shift;
my $str = ref($vec) . ": ";
my $bits = $vec->bits;
my $count = $vec->count;
$str .= defined($bits) ? unpack("b*", $bits) : "undef";
$str .= " $count";
my @handles = @$vec;
splice(@handles, 0, FIRST_FD);
for (@handles) {
$str .= " " . (defined($_) ? "$_" : "-");
}
$str;
}
sub _max
{
my($a,$b,$c) = @_;
$a > $b
? $a > $c
? $a
: $c
: $b > $c
? $b
: $c;
}
sub select
{
shift
if defined $_[0] && !ref($_[0]);
my($r,$w,$e,$t) = @_;
my @result = ();
my $rb = defined $r ? $r->[VEC_BITS] : undef;
my $wb = defined $w ? $w->[VEC_BITS] : undef;
my $eb = defined $e ? $e->[VEC_BITS] : undef;
if(select($rb,$wb,$eb,$t) > 0)
{
my @r = ();
my @w = ();
my @e = ();
my $i = _max(defined $r ? scalar(@$r)-1 : 0,
defined $w ? scalar(@$w)-1 : 0,
defined $e ? scalar(@$e)-1 : 0);
for( ; $i >= FIRST_FD ; $i--)
{
my $j = $i - FIRST_FD;
push(@r, $r->[$i])
if defined $rb && defined $r->[$i] && vec($rb, $j, 1);
push(@w, $w->[$i])
if defined $wb && defined $w->[$i] && vec($wb, $j, 1);
push(@e, $e->[$i])
if defined $eb && defined $e->[$i] && vec($eb, $j, 1);
}
@result = (\@r, \@w, \@e);
}
@result;
}
sub handles
{
my $vec = shift;
my $bits = shift;
my @h = ();
my $i;
my $max = scalar(@$vec) - 1;
for ($i = FIRST_FD; $i <= $max; $i++)
{
next unless defined $vec->[$i];
push(@h, $vec->[$i])
if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
}
@h;
}
1;
__END__

View File

@@ -0,0 +1,381 @@
# IO::Socket.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Socket;
require 5.006;
use IO::Handle;
use Socket 1.3;
use Carp;
use strict;
our(@ISA, $VERSION, @EXPORT_OK);
use Exporter;
use Errno;
# legacy
require IO::Socket::INET;
require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
@ISA = qw(IO::Handle);
$VERSION = "1.38";
@EXPORT_OK = qw(sockatmark);
sub import {
my $pkg = shift;
if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast
Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark');
} else {
my $callpkg = caller;
Exporter::export 'Socket', $callpkg, @_;
}
}
sub new {
my($class,%arg) = @_;
my $sock = $class->SUPER::new();
$sock->autoflush(1);
${*$sock}{'io_socket_timeout'} = delete $arg{Timeout};
return scalar(%arg) ? $sock->configure(\%arg)
: $sock;
}
my @domain2pkg;
sub register_domain {
my($p,$d) = @_;
$domain2pkg[$d] = $p;
}
sub configure {
my($sock,$arg) = @_;
my $domain = delete $arg->{Domain};
croak 'IO::Socket: Cannot configure a generic socket'
unless defined $domain;
croak "IO::Socket: Unsupported socket domain"
unless defined $domain2pkg[$domain];
croak "IO::Socket: Cannot configure socket in domain '$domain'"
unless ref($sock) eq "IO::Socket";
bless($sock, $domain2pkg[$domain]);
$sock->configure($arg);
}
sub socket {
@_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)';
my($sock,$domain,$type,$protocol) = @_;
socket($sock,$domain,$type,$protocol) or
return undef;
${*$sock}{'io_socket_domain'} = $domain;
${*$sock}{'io_socket_type'} = $type;
${*$sock}{'io_socket_proto'} = $protocol;
$sock;
}
sub socketpair {
@_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)';
my($class,$domain,$type,$protocol) = @_;
my $sock1 = $class->new();
my $sock2 = $class->new();
socketpair($sock1,$sock2,$domain,$type,$protocol) or
return ();
${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type;
${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol;
($sock1,$sock2);
}
sub connect {
@_ == 2 or croak 'usage: $sock->connect(NAME)';
my $sock = shift;
my $addr = shift;
my $timeout = ${*$sock}{'io_socket_timeout'};
my $err;
my $blocking;
$blocking = $sock->blocking(0) if $timeout;
if (!connect($sock, $addr)) {
if (defined $timeout && ($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
require IO::Select;
my $sel = new IO::Select $sock;
undef $!;
my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout);
if(@$e[0]) {
# Windows return from select after the timeout in case of
# WSAECONNREFUSED(10061) if exception set is not used.
# This behavior is different from Linux.
# Using the exception
# set we now emulate the behavior in Linux
# - Karthik Rajagopalan
$err = $sock->getsockopt(SOL_SOCKET,SO_ERROR);
$@ = "connect: $err";
}
elsif(!@$w[0]) {
$err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
$@ = "connect: timeout";
}
elsif (!connect($sock,$addr) &&
not ($!{EISCONN} || ($^O eq 'MSWin32' &&
($! == (($] < 5.019004) ? 10022 : Errno::EINVAL))))
) {
# Some systems refuse to re-connect() to
# an already open socket and set errno to EISCONN.
# Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or
# EINVAL (22) (5.19.4 onwards).
$err = $!;
$@ = "connect: $!";
}
}
elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
$err = $!;
$@ = "connect: $!";
}
}
$sock->blocking(1) if $blocking;
$! = $err if $err;
$err ? undef : $sock;
}
# Enable/disable blocking IO on sockets.
# Without args return the current status of blocking,
# with args change the mode as appropriate, returning the
# old setting, or in case of error during the mode change
# undef.
sub blocking {
my $sock = shift;
return $sock->SUPER::blocking(@_)
if $^O ne 'MSWin32' && $^O ne 'VMS';
# Windows handles blocking differently
#
# http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
# http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp
#
# 0x8004667e is FIONBIO
#
# which is used to set blocking behaviour.
# NOTE:
# This is a little confusing, the perl keyword for this is
# 'blocking' but the OS level behaviour is 'non-blocking', probably
# because sockets are blocking by default.
# Therefore internally we have to reverse the semantics.
my $orig= !${*$sock}{io_sock_nonblocking};
return $orig unless @_;
my $block = shift;
if ( !$block != !$orig ) {
${*$sock}{io_sock_nonblocking} = $block ? 0 : 1;
ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking}))
or return undef;
}
return $orig;
}
sub close {
@_ == 1 or croak 'usage: $sock->close()';
my $sock = shift;
${*$sock}{'io_socket_peername'} = undef;
$sock->SUPER::close();
}
sub bind {
@_ == 2 or croak 'usage: $sock->bind(NAME)';
my $sock = shift;
my $addr = shift;
return bind($sock, $addr) ? $sock
: undef;
}
sub listen {
@_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])';
my($sock,$queue) = @_;
$queue = 5
unless $queue && $queue > 0;
return listen($sock, $queue) ? $sock
: undef;
}
sub accept {
@_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])';
my $sock = shift;
my $pkg = shift || $sock;
my $timeout = ${*$sock}{'io_socket_timeout'};
my $new = $pkg->new(Timeout => $timeout);
my $peer = undef;
if(defined $timeout) {
require IO::Select;
my $sel = new IO::Select $sock;
unless ($sel->can_read($timeout)) {
$@ = 'accept: timeout';
$! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
return;
}
}
$peer = accept($new,$sock)
or return;
${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
return wantarray ? ($new, $peer)
: $new;
}
sub sockname {
@_ == 1 or croak 'usage: $sock->sockname()';
getsockname($_[0]);
}
sub peername {
@_ == 1 or croak 'usage: $sock->peername()';
my($sock) = @_;
${*$sock}{'io_socket_peername'} ||= getpeername($sock);
}
sub connected {
@_ == 1 or croak 'usage: $sock->connected()';
my($sock) = @_;
getpeername($sock);
}
sub send {
@_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])';
my $sock = $_[0];
my $flags = $_[2] || 0;
my $peer = $_[3] || $sock->peername;
croak 'send: Cannot determine peer address'
unless(defined $peer);
my $r = defined(getpeername($sock))
? send($sock, $_[1], $flags)
: send($sock, $_[1], $flags, $peer);
# remember who we send to, if it was successful
${*$sock}{'io_socket_peername'} = $peer
if(@_ == 4 && defined $r);
$r;
}
sub recv {
@_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])';
my $sock = $_[0];
my $len = $_[2];
my $flags = $_[3] || 0;
# remember who we recv'd from
${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
}
sub shutdown {
@_ == 2 or croak 'usage: $sock->shutdown(HOW)';
my($sock, $how) = @_;
${*$sock}{'io_socket_peername'} = undef;
shutdown($sock, $how);
}
sub setsockopt {
@_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
setsockopt($_[0],$_[1],$_[2],$_[3]);
}
my $intsize = length(pack("i",0));
sub getsockopt {
@_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)';
my $r = getsockopt($_[0],$_[1],$_[2]);
# Just a guess
$r = unpack("i", $r)
if(defined $r && length($r) == $intsize);
$r;
}
sub sockopt {
my $sock = shift;
@_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_)
: $sock->setsockopt(SOL_SOCKET,@_);
}
sub atmark {
@_ == 1 or croak 'usage: $sock->atmark()';
my($sock) = @_;
sockatmark($sock);
}
sub timeout {
@_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])';
my($sock,$val) = @_;
my $r = ${*$sock}{'io_socket_timeout'};
${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val
if(@_ == 2);
$r;
}
sub sockdomain {
@_ == 1 or croak 'usage: $sock->sockdomain()';
my $sock = shift;
if (!defined(${*$sock}{'io_socket_domain'})) {
my $addr = $sock->sockname();
${*$sock}{'io_socket_domain'} = sockaddr_family($addr)
if (defined($addr));
}
${*$sock}{'io_socket_domain'};
}
sub socktype {
@_ == 1 or croak 'usage: $sock->socktype()';
my $sock = shift;
${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE)
if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE}));
${*$sock}{'io_socket_type'}
}
sub protocol {
@_ == 1 or croak 'usage: $sock->protocol()';
my($sock) = @_;
${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL)
if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL}));
${*$sock}{'io_socket_proto'};
}
1;
__END__

View File

@@ -0,0 +1,311 @@
# IO::Socket::INET.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Socket::INET;
use strict;
our(@ISA, $VERSION);
use IO::Socket;
use Socket;
use Carp;
use Exporter;
use Errno;
@ISA = qw(IO::Socket);
$VERSION = "1.35";
my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
IO::Socket::INET->register_domain( AF_INET );
my %socket_type = ( tcp => SOCK_STREAM,
udp => SOCK_DGRAM,
icmp => SOCK_RAW
);
my %proto_number;
$proto_number{tcp} = Socket::IPPROTO_TCP() if defined &Socket::IPPROTO_TCP;
$proto_number{udp} = Socket::IPPROTO_UDP() if defined &Socket::IPPROTO_UDP;
$proto_number{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
my %proto_name = reverse %proto_number;
sub new {
my $class = shift;
unshift(@_, "PeerAddr") if @_ == 1;
return $class->SUPER::new(@_);
}
sub _cache_proto {
my @proto = @_;
for (map lc($_), $proto[0], split(' ', $proto[1])) {
$proto_number{$_} = $proto[2];
}
$proto_name{$proto[2]} = $proto[0];
}
sub _get_proto_number {
my $name = lc(shift);
return undef unless defined $name;
return $proto_number{$name} if exists $proto_number{$name};
my @proto = eval { getprotobyname($name) };
return undef unless @proto;
_cache_proto(@proto);
return $proto[2];
}
sub _get_proto_name {
my $num = shift;
return undef unless defined $num;
return $proto_name{$num} if exists $proto_name{$num};
my @proto = eval { getprotobynumber($num) };
return undef unless @proto;
_cache_proto(@proto);
return $proto[0];
}
sub _sock_info {
my($addr,$port,$proto) = @_;
my $origport = $port;
my @serv = ();
$port = $1
if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
if(defined $proto && $proto =~ /\D/) {
my $num = _get_proto_number($proto);
unless (defined $num) {
$@ = "Bad protocol '$proto'";
return;
}
$proto = $num;
}
if(defined $port) {
my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef;
my $pnum = ($port =~ m,^(\d+)$,)[0];
@serv = getservbyname($port, _get_proto_name($proto) || "")
if ($port =~ m,\D,);
$port = $serv[2] || $defport || $pnum;
unless (defined $port) {
$@ = "Bad service '$origport'";
return;
}
$proto = _get_proto_number($serv[3]) if @serv && !$proto;
}
return ($addr || undef,
$port || undef,
$proto || undef
);
}
sub _error {
my $sock = shift;
my $err = shift;
{
local($!);
my $title = ref($sock).": ";
$@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_);
$sock->close()
if(defined fileno($sock));
}
$! = $err;
return undef;
}
sub _get_addr {
my($sock,$addr_str, $multi) = @_;
my @addr;
if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) {
(undef, undef, undef, undef, @addr) = gethostbyname($addr_str);
} else {
my $h = inet_aton($addr_str);
push(@addr, $h) if defined $h;
}
@addr;
}
sub configure {
my($sock,$arg) = @_;
my($lport,$rport,$laddr,$raddr,$proto,$type);
$arg->{LocalAddr} = $arg->{LocalHost}
if exists $arg->{LocalHost} && !exists $arg->{LocalAddr};
($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
$arg->{LocalPort},
$arg->{Proto})
or return _error($sock, $!, $@);
$laddr = defined $laddr ? inet_aton($laddr)
: INADDR_ANY;
return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'")
unless(defined $laddr);
$arg->{PeerAddr} = $arg->{PeerHost}
if exists $arg->{PeerHost} && !exists $arg->{PeerAddr};
unless(exists $arg->{Listen}) {
($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
$arg->{PeerPort},
$proto)
or return _error($sock, $!, $@);
}
$proto ||= _get_proto_number('tcp');
$type = $arg->{Type} || $socket_type{lc _get_proto_name($proto)};
my @raddr = ();
if(defined $raddr) {
@raddr = $sock->_get_addr($raddr, $arg->{MultiHomed});
return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
unless @raddr;
}
while(1) {
$sock->socket(AF_INET, $type, $proto) or
return _error($sock, $!, "$!");
if (defined $arg->{Blocking}) {
defined $sock->blocking($arg->{Blocking})
or return _error($sock, $!, "$!");
}
if ($arg->{Reuse} || $arg->{ReuseAddr}) {
$sock->sockopt(SO_REUSEADDR,1) or
return _error($sock, $!, "$!");
}
if ($arg->{ReusePort}) {
$sock->sockopt(SO_REUSEPORT,1) or
return _error($sock, $!, "$!");
}
if ($arg->{Broadcast}) {
$sock->sockopt(SO_BROADCAST,1) or
return _error($sock, $!, "$!");
}
if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) {
$sock->bind($lport || 0, $laddr) or
return _error($sock, $!, "$!");
}
if(exists $arg->{Listen}) {
$sock->listen($arg->{Listen} || 5) or
return _error($sock, $!, "$!");
last;
}
# don't try to connect unless we're given a PeerAddr
last unless exists($arg->{PeerAddr});
$raddr = shift @raddr;
return _error($sock, $EINVAL, 'Cannot determine remote port')
unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
last
unless($type == SOCK_STREAM || defined $raddr);
return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
unless defined $raddr;
# my $timeout = ${*$sock}{'io_socket_timeout'};
# my $before = time() if $timeout;
undef $@;
if ($sock->connect(pack_sockaddr_in($rport, $raddr))) {
# ${*$sock}{'io_socket_timeout'} = $timeout;
return $sock;
}
return _error($sock, $!, $@ || "Timeout")
unless @raddr;
# if ($timeout) {
# my $new_timeout = $timeout - (time() - $before);
# return _error($sock,
# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
# "Timeout") if $new_timeout <= 0;
# ${*$sock}{'io_socket_timeout'} = $new_timeout;
# }
}
$sock;
}
sub connect {
@_ == 2 || @_ == 3 or
croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)';
my $sock = shift;
return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_));
}
sub bind {
@_ == 2 || @_ == 3 or
croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)';
my $sock = shift;
return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_))
}
sub sockaddr {
@_ == 1 or croak 'usage: $sock->sockaddr()';
my($sock) = @_;
my $name = $sock->sockname;
$name ? (sockaddr_in($name))[1] : undef;
}
sub sockport {
@_ == 1 or croak 'usage: $sock->sockport()';
my($sock) = @_;
my $name = $sock->sockname;
$name ? (sockaddr_in($name))[0] : undef;
}
sub sockhost {
@_ == 1 or croak 'usage: $sock->sockhost()';
my($sock) = @_;
my $addr = $sock->sockaddr;
$addr ? inet_ntoa($addr) : undef;
}
sub peeraddr {
@_ == 1 or croak 'usage: $sock->peeraddr()';
my($sock) = @_;
my $name = $sock->peername;
$name ? (sockaddr_in($name))[1] : undef;
}
sub peerport {
@_ == 1 or croak 'usage: $sock->peerport()';
my($sock) = @_;
my $name = $sock->peername;
$name ? (sockaddr_in($name))[0] : undef;
}
sub peerhost {
@_ == 1 or croak 'usage: $sock->peerhost()';
my($sock) = @_;
my $addr = $sock->peeraddr;
$addr ? inet_ntoa($addr) : undef;
}
1;
__END__

View File

@@ -0,0 +1,692 @@
# You may distribute under the terms of either the GNU General Public License
# or the Artistic License (the same terms as Perl itself)
#
# (C) Paul Evans, 2010-2015 -- leonerd@leonerd.org.uk
package IO::Socket::IP;
# $VERSION needs to be set before use base 'IO::Socket'
# - https://rt.cpan.org/Ticket/Display.html?id=92107
BEGIN {
$VERSION = '0.38';
}
use strict;
use warnings;
use base qw( IO::Socket );
use Carp;
use Socket 1.97 qw(
getaddrinfo getnameinfo
sockaddr_family
AF_INET
AI_PASSIVE
IPPROTO_TCP IPPROTO_UDP
IPPROTO_IPV6 IPV6_V6ONLY
NI_DGRAM NI_NUMERICHOST NI_NUMERICSERV NIx_NOHOST NIx_NOSERV
SO_REUSEADDR SO_REUSEPORT SO_BROADCAST SO_ERROR
SOCK_DGRAM SOCK_STREAM
SOL_SOCKET
);
my $AF_INET6 = eval { Socket::AF_INET6() }; # may not be defined
my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0;
use POSIX qw( dup2 );
use Errno qw( EINVAL EINPROGRESS EISCONN ENOTCONN ETIMEDOUT EWOULDBLOCK );
use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" );
# At least one OS (Android) is known not to have getprotobyname()
use constant HAVE_GETPROTOBYNAME => defined eval { getprotobyname( "tcp" ) };
my $IPv6_re = do {
# translation of RFC 3986 3.2.2 ABNF to re
my $IPv4address = do {
my $dec_octet = q<(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])>;
qq<$dec_octet(?: \\. $dec_octet){3}>;
};
my $IPv6address = do {
my $h16 = qq<[0-9A-Fa-f]{1,4}>;
my $ls32 = qq<(?: $h16 : $h16 | $IPv4address)>;
qq<(?:
(?: $h16 : ){6} $ls32
| :: (?: $h16 : ){5} $ls32
| (?: $h16 )? :: (?: $h16 : ){4} $ls32
| (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32
| (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32
| (?: (?: $h16 : ){0,3} $h16 )? :: $h16 : $ls32
| (?: (?: $h16 : ){0,4} $h16 )? :: $ls32
| (?: (?: $h16 : ){0,5} $h16 )? :: $h16
| (?: (?: $h16 : ){0,6} $h16 )? ::
)>
};
qr<$IPv6address>xo;
};
sub import
{
my $pkg = shift;
my @symbols;
foreach ( @_ ) {
if( $_ eq "-register" ) {
IO::Socket::IP::_ForINET->register_domain( AF_INET );
IO::Socket::IP::_ForINET6->register_domain( $AF_INET6 ) if defined $AF_INET6;
}
else {
push @symbols, $_;
}
}
@_ = ( $pkg, @symbols );
goto &IO::Socket::import;
}
# Convenient capability test function
{
my $can_disable_v6only;
sub CAN_DISABLE_V6ONLY
{
return $can_disable_v6only if defined $can_disable_v6only;
socket my $testsock, Socket::PF_INET6(), SOCK_STREAM, 0 or
die "Cannot socket(PF_INET6) - $!";
if( setsockopt $testsock, IPPROTO_IPV6, IPV6_V6ONLY, 0 ) {
return $can_disable_v6only = 1;
}
elsif( $! == EINVAL ) {
return $can_disable_v6only = 0;
}
else {
die "Cannot setsockopt() - $!";
}
}
}
sub new
{
my $class = shift;
my %arg = (@_ == 1) ? (PeerHost => $_[0]) : @_;
return $class->SUPER::new(%arg);
}
# IO::Socket may call this one; neaten up the arguments from IO::Socket::INET
# before calling our real _configure method
sub configure
{
my $self = shift;
my ( $arg ) = @_;
$arg->{PeerHost} = delete $arg->{PeerAddr}
if exists $arg->{PeerAddr} && !exists $arg->{PeerHost};
$arg->{PeerService} = delete $arg->{PeerPort}
if exists $arg->{PeerPort} && !exists $arg->{PeerService};
$arg->{LocalHost} = delete $arg->{LocalAddr}
if exists $arg->{LocalAddr} && !exists $arg->{LocalHost};
$arg->{LocalService} = delete $arg->{LocalPort}
if exists $arg->{LocalPort} && !exists $arg->{LocalService};
for my $type (qw(Peer Local)) {
my $host = $type . 'Host';
my $service = $type . 'Service';
if( defined $arg->{$host} ) {
( $arg->{$host}, my $s ) = $self->split_addr( $arg->{$host} );
# IO::Socket::INET compat - *Host parsed port always takes precedence
$arg->{$service} = $s if defined $s;
}
}
$self->_io_socket_ip__configure( $arg );
}
# Avoid simply calling it _configure, as some subclasses of IO::Socket::INET on CPAN already take that
sub _io_socket_ip__configure
{
my $self = shift;
my ( $arg ) = @_;
my %hints;
my @localinfos;
my @peerinfos;
my $listenqueue = $arg->{Listen};
if( defined $listenqueue and
( defined $arg->{PeerHost} || defined $arg->{PeerService} || defined $arg->{PeerAddrInfo} ) ) {
croak "Cannot Listen with a peer address";
}
if( defined $arg->{GetAddrInfoFlags} ) {
$hints{flags} = $arg->{GetAddrInfoFlags};
}
else {
$hints{flags} = $AI_ADDRCONFIG;
}
if( defined( my $family = $arg->{Family} ) ) {
$hints{family} = $family;
}
if( defined( my $type = $arg->{Type} ) ) {
$hints{socktype} = $type;
}
if( defined( my $proto = $arg->{Proto} ) ) {
unless( $proto =~ m/^\d+$/ ) {
my $protonum = HAVE_GETPROTOBYNAME
? getprotobyname( $proto )
: eval { Socket->${\"IPPROTO_\U$proto"}() };
defined $protonum or croak "Unrecognised protocol $proto";
$proto = $protonum;
}
$hints{protocol} = $proto;
}
# To maintain compatibility with IO::Socket::INET, imply a default of
# SOCK_STREAM + IPPROTO_TCP if neither hint is given
if( !defined $hints{socktype} and !defined $hints{protocol} ) {
$hints{socktype} = SOCK_STREAM;
$hints{protocol} = IPPROTO_TCP;
}
# Some OSes (NetBSD) don't seem to like just a protocol hint without a
# socktype hint as well. We'll set a couple of common ones
if( !defined $hints{socktype} and defined $hints{protocol} ) {
$hints{socktype} = SOCK_STREAM if $hints{protocol} == IPPROTO_TCP;
$hints{socktype} = SOCK_DGRAM if $hints{protocol} == IPPROTO_UDP;
}
if( my $info = $arg->{LocalAddrInfo} ) {
ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref";
@localinfos = @$info;
}
elsif( defined $arg->{LocalHost} or
defined $arg->{LocalService} or
HAVE_MSWIN32 and $arg->{Listen} ) {
# Either may be undef
my $host = $arg->{LocalHost};
my $service = $arg->{LocalService};
unless ( defined $host or defined $service ) {
$service = 0;
}
local $1; # Placate a taint-related bug; [perl #67962]
defined $service and $service =~ s/\((\d+)\)$// and
my $fallback_port = $1;
my %localhints = %hints;
$localhints{flags} |= AI_PASSIVE;
( my $err, @localinfos ) = getaddrinfo( $host, $service, \%localhints );
if( $err and defined $fallback_port ) {
( $err, @localinfos ) = getaddrinfo( $host, $fallback_port, \%localhints );
}
if( $err ) {
$@ = "$err";
$! = EINVAL;
return;
}
}
if( my $info = $arg->{PeerAddrInfo} ) {
ref $info eq "ARRAY" or croak "Expected 'PeerAddrInfo' to be an ARRAY ref";
@peerinfos = @$info;
}
elsif( defined $arg->{PeerHost} or defined $arg->{PeerService} ) {
defined( my $host = $arg->{PeerHost} ) or
croak "Expected 'PeerHost'";
defined( my $service = $arg->{PeerService} ) or
croak "Expected 'PeerService'";
local $1; # Placate a taint-related bug; [perl #67962]
defined $service and $service =~ s/\((\d+)\)$// and
my $fallback_port = $1;
( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%hints );
if( $err and defined $fallback_port ) {
( $err, @peerinfos ) = getaddrinfo( $host, $fallback_port, \%hints );
}
if( $err ) {
$@ = "$err";
$! = EINVAL;
return;
}
}
my $INT_1 = pack "i", 1;
my @sockopts_enabled;
push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEADDR, $INT_1 ] if $arg->{ReuseAddr};
push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEPORT, $INT_1 ] if $arg->{ReusePort};
push @sockopts_enabled, [ SOL_SOCKET, SO_BROADCAST, $INT_1 ] if $arg->{Broadcast};
if( my $sockopts = $arg->{Sockopts} ) {
ref $sockopts eq "ARRAY" or croak "Expected 'Sockopts' to be an ARRAY ref";
foreach ( @$sockopts ) {
ref $_ eq "ARRAY" or croak "Bad Sockopts item - expected ARRAYref";
@$_ >= 2 and @$_ <= 3 or
croak "Bad Sockopts item - expected 2 or 3 elements";
my ( $level, $optname, $value ) = @$_;
# TODO: consider more sanity checking on argument values
defined $value or $value = $INT_1;
push @sockopts_enabled, [ $level, $optname, $value ];
}
}
my $blocking = $arg->{Blocking};
defined $blocking or $blocking = 1;
my $v6only = $arg->{V6Only};
# IO::Socket::INET defines this key. IO::Socket::IP always implements the
# behaviour it requests, so we can ignore it, unless the caller is for some
# reason asking to disable it.
if( defined $arg->{MultiHomed} and !$arg->{MultiHomed} ) {
croak "Cannot disable the MultiHomed parameter";
}
my @infos;
foreach my $local ( @localinfos ? @localinfos : {} ) {
foreach my $peer ( @peerinfos ? @peerinfos : {} ) {
next if defined $local->{family} and defined $peer->{family} and
$local->{family} != $peer->{family};
next if defined $local->{socktype} and defined $peer->{socktype} and
$local->{socktype} != $peer->{socktype};
next if defined $local->{protocol} and defined $peer->{protocol} and
$local->{protocol} != $peer->{protocol};
my $family = $local->{family} || $peer->{family} or next;
my $socktype = $local->{socktype} || $peer->{socktype} or next;
my $protocol = $local->{protocol} || $peer->{protocol} || 0;
push @infos, {
family => $family,
socktype => $socktype,
protocol => $protocol,
localaddr => $local->{addr},
peeraddr => $peer->{addr},
};
}
}
if( !@infos ) {
# If there was a Family hint then create a plain unbound, unconnected socket
if( defined $hints{family} ) {
@infos = ( {
family => $hints{family},
socktype => $hints{socktype},
protocol => $hints{protocol},
} );
}
# If there wasn't, use getaddrinfo()'s AI_ADDRCONFIG side-effect to guess a
# suitable family first.
else {
( my $err, @infos ) = getaddrinfo( "", "0", \%hints );
if( $err ) {
$@ = "$err";
$! = EINVAL;
return;
}
# We'll take all the @infos anyway, because some OSes (HPUX) are known to
# ignore the AI_ADDRCONFIG hint and return AF_INET6 even if they don't
# support them
}
}
# In the nonblocking case, caller will be calling ->setup multiple times.
# Store configuration in the object for the ->setup method
# Yes, these are messy. Sorry, I can't help that...
${*$self}{io_socket_ip_infos} = \@infos;
${*$self}{io_socket_ip_idx} = -1;
${*$self}{io_socket_ip_sockopts} = \@sockopts_enabled;
${*$self}{io_socket_ip_v6only} = $v6only;
${*$self}{io_socket_ip_listenqueue} = $listenqueue;
${*$self}{io_socket_ip_blocking} = $blocking;
${*$self}{io_socket_ip_errors} = [ undef, undef, undef ];
# ->setup is allowed to return false in nonblocking mode
$self->setup or !$blocking or return undef;
return $self;
}
sub setup
{
my $self = shift;
while(1) {
${*$self}{io_socket_ip_idx}++;
last if ${*$self}{io_socket_ip_idx} >= @{ ${*$self}{io_socket_ip_infos} };
my $info = ${*$self}{io_socket_ip_infos}->[${*$self}{io_socket_ip_idx}];
$self->socket( @{$info}{qw( family socktype protocol )} ) or
( ${*$self}{io_socket_ip_errors}[2] = $!, next );
$self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking};
foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) {
my ( $level, $optname, $value ) = @$sockopt;
$self->setsockopt( $level, $optname, $value ) or ( $@ = "$!", return undef );
}
if( defined ${*$self}{io_socket_ip_v6only} and defined $AF_INET6 and $info->{family} == $AF_INET6 ) {
my $v6only = ${*$self}{io_socket_ip_v6only};
$self->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, pack "i", $v6only ) or ( $@ = "$!", return undef );
}
if( defined( my $addr = $info->{localaddr} ) ) {
$self->bind( $addr ) or
( ${*$self}{io_socket_ip_errors}[1] = $!, next );
}
if( defined( my $listenqueue = ${*$self}{io_socket_ip_listenqueue} ) ) {
$self->listen( $listenqueue ) or ( $@ = "$!", return undef );
}
if( defined( my $addr = $info->{peeraddr} ) ) {
if( $self->connect( $addr ) ) {
$! = 0;
return 1;
}
if( $! == EINPROGRESS or $! == EWOULDBLOCK ) {
${*$self}{io_socket_ip_connect_in_progress} = 1;
return 0;
}
# If connect failed but we have no system error there must be an error
# at the application layer, like a bad certificate with
# IO::Socket::SSL.
# In this case don't continue IP based multi-homing because the problem
# cannot be solved at the IP layer.
return 0 if ! $!;
${*$self}{io_socket_ip_errors}[0] = $!;
next;
}
return 1;
}
# Pick the most appropriate error, stringified
$! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0];
$@ = "$!";
return undef;
}
sub connect :method
{
my $self = shift;
# It seems that IO::Socket hides EINPROGRESS errors, making them look like
# a success. This is annoying here.
# Instead of putting up with its frankly-irritating intentional breakage of
# useful APIs I'm just going to end-run around it and call core's connect()
# directly
if( @_ ) {
my ( $addr ) = @_;
# Annoyingly IO::Socket's connect() is where the timeout logic is
# implemented, so we'll have to reinvent it here
my $timeout = ${*$self}{'io_socket_timeout'};
return connect( $self, $addr ) unless defined $timeout;
my $was_blocking = $self->blocking( 0 );
my $err = defined connect( $self, $addr ) ? 0 : $!+0;
if( !$err ) {
# All happy
$self->blocking( $was_blocking );
return 1;
}
elsif( not( $err == EINPROGRESS or $err == EWOULDBLOCK ) ) {
# Failed for some other reason
$self->blocking( $was_blocking );
return undef;
}
elsif( !$was_blocking ) {
# We shouldn't block anyway
return undef;
}
my $vec = ''; vec( $vec, $self->fileno, 1 ) = 1;
if( !select( undef, $vec, $vec, $timeout ) ) {
$self->blocking( $was_blocking );
$! = ETIMEDOUT;
return undef;
}
# Hoist the error by connect()ing a second time
$err = $self->getsockopt( SOL_SOCKET, SO_ERROR );
$err = 0 if $err == EISCONN; # Some OSes give EISCONN
$self->blocking( $was_blocking );
$! = $err, return undef if $err;
return 1;
}
return 1 if !${*$self}{io_socket_ip_connect_in_progress};
# See if a connect attempt has just failed with an error
if( my $errno = $self->getsockopt( SOL_SOCKET, SO_ERROR ) ) {
delete ${*$self}{io_socket_ip_connect_in_progress};
${*$self}{io_socket_ip_errors}[0] = $! = $errno;
return $self->setup;
}
# No error, so either connect is still in progress, or has completed
# successfully. We can tell by trying to connect() again; either it will
# succeed or we'll get EISCONN (connected successfully), or EALREADY
# (still in progress). This even works on MSWin32.
my $addr = ${*$self}{io_socket_ip_infos}[${*$self}{io_socket_ip_idx}]{peeraddr};
if( connect( $self, $addr ) or $! == EISCONN ) {
delete ${*$self}{io_socket_ip_connect_in_progress};
$! = 0;
return 1;
}
else {
$! = EINPROGRESS;
return 0;
}
}
sub connected
{
my $self = shift;
return defined $self->fileno &&
!${*$self}{io_socket_ip_connect_in_progress} &&
defined getpeername( $self ); # ->peername caches, we need to detect disconnection
}
sub _get_host_service
{
my $self = shift;
my ( $addr, $flags, $xflags ) = @_;
defined $addr or
$! = ENOTCONN, return;
$flags |= NI_DGRAM if $self->socktype == SOCK_DGRAM;
my ( $err, $host, $service ) = getnameinfo( $addr, $flags, $xflags || 0 );
croak "getnameinfo - $err" if $err;
return ( $host, $service );
}
sub _unpack_sockaddr
{
my ( $addr ) = @_;
my $family = sockaddr_family $addr;
if( $family == AF_INET ) {
return ( Socket::unpack_sockaddr_in( $addr ) )[1];
}
elsif( defined $AF_INET6 and $family == $AF_INET6 ) {
return ( Socket::unpack_sockaddr_in6( $addr ) )[1];
}
else {
croak "Unrecognised address family $family";
}
}
sub sockhost_service
{
my $self = shift;
my ( $numeric ) = @_;
$self->_get_host_service( $self->sockname, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
}
sub sockhost { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
sub sockport { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
sub sockhostname { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, 0, NIx_NOSERV ) )[0] }
sub sockservice { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, 0, NIx_NOHOST ) )[1] }
sub sockaddr { my $self = shift; _unpack_sockaddr $self->sockname }
sub peerhost_service
{
my $self = shift;
my ( $numeric ) = @_;
$self->_get_host_service( $self->peername, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
}
sub peerhost { my $self = shift; scalar +( $self->_get_host_service( $self->peername, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
sub peerport { my $self = shift; scalar +( $self->_get_host_service( $self->peername, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
sub peerhostname { my $self = shift; scalar +( $self->_get_host_service( $self->peername, 0, NIx_NOSERV ) )[0] }
sub peerservice { my $self = shift; scalar +( $self->_get_host_service( $self->peername, 0, NIx_NOHOST ) )[1] }
sub peeraddr { my $self = shift; _unpack_sockaddr $self->peername }
# This unbelievably dodgy hack works around the bug that IO::Socket doesn't do
# it
# https://rt.cpan.org/Ticket/Display.html?id=61577
sub accept
{
my $self = shift;
my ( $new, $peer ) = $self->SUPER::accept( @_ ) or return;
${*$new}{$_} = ${*$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
return wantarray ? ( $new, $peer )
: $new;
}
# This second unbelievably dodgy hack guarantees that $self->fileno doesn't
# change, which is useful during nonblocking connect
sub socket :method
{
my $self = shift;
return $self->SUPER::socket(@_) if not defined $self->fileno;
# I hate core prototypes sometimes...
socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef;
dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!";
}
# Versions of IO::Socket before 1.35 may leave socktype undef if from, say, an
# ->fdopen call. In this case we'll apply a fix
BEGIN {
if( eval($IO::Socket::VERSION) < 1.35 ) {
*socktype = sub {
my $self = shift;
my $type = $self->SUPER::socktype;
if( !defined $type ) {
$type = $self->sockopt( Socket::SO_TYPE() );
}
return $type;
};
}
}
sub as_inet
{
my $self = shift;
croak "Cannot downgrade a non-PF_INET socket to IO::Socket::INET" unless $self->sockdomain == AF_INET;
return IO::Socket::INET->new_from_fd( $self->fileno, "r+" );
}
sub split_addr
{
shift;
my ( $addr ) = @_;
local ( $1, $2 ); # Placate a taint-related bug; [perl #67962]
if( $addr =~ m/\A\[($IPv6_re)\](?::([^\s:]*))?\z/ or
$addr =~ m/\A([^\s:]*):([^\s:]*)\z/ ) {
return ( $1, $2 ) if defined $2 and length $2;
return ( $1, undef );
}
return ( $addr, undef );
}
sub join_addr
{
shift;
my ( $host, $port ) = @_;
$host = "[$host]" if $host =~ m/:/;
return join ":", $host, $port if defined $port;
return $host;
}
# Since IO::Socket->new( Domain => ... ) will delete the Domain parameter
# before calling ->configure, we need to keep track of which it was
package # hide from indexer
IO::Socket::IP::_ForINET;
use base qw( IO::Socket::IP );
sub configure
{
# This is evil
my $self = shift;
my ( $arg ) = @_;
bless $self, "IO::Socket::IP";
$self->configure( { %$arg, Family => Socket::AF_INET() } );
}
package # hide from indexer
IO::Socket::IP::_ForINET6;
use base qw( IO::Socket::IP );
sub configure
{
# This is evil
my $self = shift;
my ( $arg ) = @_;
bless $self, "IO::Socket::IP";
$self->configure( { %$arg, Family => Socket::AF_INET6() } );
}
0x55AA;

View File

@@ -0,0 +1,68 @@
# IO::Socket::UNIX.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package IO::Socket::UNIX;
use strict;
our(@ISA, $VERSION);
use IO::Socket;
use Carp;
@ISA = qw(IO::Socket);
$VERSION = "1.26";
$VERSION = eval $VERSION;
IO::Socket::UNIX->register_domain( AF_UNIX );
sub new {
my $class = shift;
unshift(@_, "Peer") if @_ == 1;
return $class->SUPER::new(@_);
}
sub configure {
my($sock,$arg) = @_;
my($bport,$cport);
my $type = $arg->{Type} || SOCK_STREAM;
$sock->socket(AF_UNIX, $type, 0) or
return undef;
if(exists $arg->{Local}) {
my $addr = sockaddr_un($arg->{Local});
$sock->bind($addr) or
return undef;
}
if(exists $arg->{Listen} && $type != SOCK_DGRAM) {
$sock->listen($arg->{Listen} || 5) or
return undef;
}
elsif(exists $arg->{Peer}) {
my $addr = sockaddr_un($arg->{Peer});
$sock->connect($addr) or
return undef;
}
$sock;
}
sub hostpath {
@_ == 1 or croak 'usage: $sock->hostpath()';
my $n = $_[0]->sockname || return undef;
(sockaddr_un($n))[0];
}
sub peerpath {
@_ == 1 or croak 'usage: $sock->peerpath()';
my $n = $_[0]->peername || return undef;
(sockaddr_un($n))[0];
}
1; # Keep require happy
__END__

View File

@@ -0,0 +1,38 @@
package IPC::Open2;
use strict;
our ($VERSION, @ISA, @EXPORT);
require 5.000;
require Exporter;
$VERSION = 1.04;
@ISA = qw(Exporter);
@EXPORT = qw(open2);
# &open2: tom christiansen, <tchrist@convex.com>
#
# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
# or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
#
# spawn the given $cmd and connect $rdr for
# reading and $wtr for writing. return pid
# of child, or 0 on failure.
#
# WARNING: this is dangerous, as you may block forever
# unless you are very careful.
#
# $wtr is left unbuffered.
#
# abort program if
# rdr or wtr are null
# a system call fails
require IPC::Open3;
sub open2 {
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
return IPC::Open3::_open3('open2', $_[1], $_[0], '>&STDERR', @_[2 .. $#_]);
}
1

View File

@@ -0,0 +1,330 @@
package IPC::Open3;
use strict;
no strict 'refs'; # because users pass me bareword filehandles
our ($VERSION, @ISA, @EXPORT);
require Exporter;
use Carp;
use Symbol qw(gensym qualify);
$VERSION = '1.20';
@ISA = qw(Exporter);
@EXPORT = qw(open3);
# &open3: Marc Horowitz <marc@mit.edu>
# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
# fixed for autovivving FHs, tchrist again
# allow fd numbers to be used, by Frank Tobin
# allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
#
# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
#
# spawn the given $cmd and connect rdr for
# reading, wtr for writing, and err for errors.
# if err is '', or the same as rdr, then stdout and
# stderr of the child are on the same fh. returns pid
# of child (or dies on failure).
# if wtr begins with '<&', then wtr will be closed in the parent, and
# the child will read from it directly. if rdr or err begins with
# '>&', then the child will send output directly to that fd. In both
# cases, there will be a dup() instead of a pipe() made.
# WARNING: this is dangerous, as you may block forever
# unless you are very careful.
#
# $wtr is left unbuffered.
#
# abort program if
# rdr or wtr are null
# a system call fails
our $Me = 'open3 (bug)'; # you should never see this, it's always localized
# Fatal.pm needs to be fixed WRT prototypes.
sub xpipe {
pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
}
# I tried using a * prototype character for the filehandle but it still
# disallows a bareword while compiling under strict subs.
sub xopen {
open $_[0], $_[1], @_[2..$#_] and return;
local $" = ', ';
carp "$Me: open(@_) failed: $!";
}
sub xclose {
$_[0] =~ /\A=?(\d+)\z/
? do { my $fh; open($fh, $_[1] . '&=' . $1) and close($fh); }
: close $_[0]
or croak "$Me: close($_[0]) failed: $!";
}
sub xfileno {
return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd
return fileno $_[0];
}
use constant FORCE_DEBUG_SPAWN => 0;
use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN;
sub _open3 {
local $Me = shift;
# simulate autovivification of filehandles because
# it's too ugly to use @_ throughout to make perl do it for us
# tchrist 5-Mar-00
# Historically, open3(undef...) has silently worked, so keep
# it working.
splice @_, 0, 1, undef if \$_[0] == \undef;
splice @_, 1, 1, undef if \$_[1] == \undef;
unless (eval {
$_[0] = gensym unless defined $_[0] && length $_[0];
$_[1] = gensym unless defined $_[1] && length $_[1];
1; })
{
# must strip crud for croak to add back, or looks ugly
$@ =~ s/(?<=value attempted) at .*//s;
croak "$Me: $@";
}
my @handles = ({ mode => '<', handle => \*STDIN },
{ mode => '>', handle => \*STDOUT },
{ mode => '>', handle => \*STDERR },
);
foreach (@handles) {
$_->{parent} = shift;
$_->{open_as} = gensym;
}
if (@_ > 1 and $_[0] eq '-') {
croak "Arguments don't make sense when the command is '-'"
}
$handles[2]{parent} ||= $handles[1]{parent};
$handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent};
my $package;
foreach (@handles) {
$_->{dup} = ($_->{parent} =~ s/^[<>]&//);
if ($_->{parent} !~ /\A=?(\d+)\z/) {
# force unqualified filehandles into caller's package
$package //= caller 1;
$_->{parent} = qualify $_->{parent}, $package;
}
next if $_->{dup} or $_->{dup_of_out};
if ($_->{mode} eq '<') {
xpipe $_->{open_as}, $_->{parent};
} else {
xpipe $_->{parent}, $_->{open_as};
}
}
my $kidpid;
if (!DO_SPAWN) {
# Used to communicate exec failures.
xpipe my $stat_r, my $stat_w;
$kidpid = fork;
croak "$Me: fork failed: $!" unless defined $kidpid;
if ($kidpid == 0) { # Kid
eval {
# A tie in the parent should not be allowed to cause problems.
untie *STDIN;
untie *STDOUT;
untie *STDERR;
close $stat_r;
require Fcntl;
my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0;
croak "$Me: fcntl failed: $!" unless $flags;
fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC
or croak "$Me: fcntl failed: $!";
# If she wants to dup the kid's stderr onto her stdout I need to
# save a copy of her stdout before I put something else there.
if (!$handles[2]{dup_of_out} && $handles[2]{dup}
&& xfileno($handles[2]{parent}) == fileno \*STDOUT) {
my $tmp = gensym;
xopen($tmp, '>&', $handles[2]{parent});
$handles[2]{parent} = $tmp;
}
foreach (@handles) {
if ($_->{dup_of_out}) {
xopen \*STDERR, ">&STDOUT"
if defined fileno STDERR && fileno STDERR != fileno STDOUT;
} elsif ($_->{dup}) {
xopen $_->{handle}, $_->{mode} . '&', $_->{parent}
if fileno $_->{handle} != xfileno($_->{parent});
} else {
xclose $_->{parent}, $_->{mode};
xopen $_->{handle}, $_->{mode} . '&=',
fileno $_->{open_as};
}
}
return 1 if ($_[0] eq '-');
exec @_ or do {
local($")=(" ");
croak "$Me: exec of @_ failed: $!";
};
} and do {
close $stat_w;
return 0;
};
my $bang = 0+$!;
my $err = $@;
utf8::encode $err if $] >= 5.008;
print $stat_w pack('IIa*', $bang, length($err), $err);
close $stat_w;
eval { require POSIX; POSIX::_exit(255); };
exit 255;
}
else { # Parent
close $stat_w;
my $to_read = length(pack('I', 0)) * 2;
my $bytes_read = read($stat_r, my $buf = '', $to_read);
if ($bytes_read) {
(my $bang, $to_read) = unpack('II', $buf);
read($stat_r, my $err = '', $to_read);
waitpid $kidpid, 0; # Reap child which should have exited
if ($err) {
utf8::decode $err if $] >= 5.008;
} else {
$err = "$Me: " . ($! = $bang);
}
$! = $bang;
die($err);
}
}
}
else { # DO_SPAWN
# All the bookkeeping of coincidence between handles is
# handled in spawn_with_handles.
my @close;
foreach (@handles) {
if ($_->{dup_of_out}) {
$_->{open_as} = $handles[1]{open_as};
} elsif ($_->{dup}) {
$_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/
? $_->{parent} : \*{$_->{parent}};
push @close, $_->{open_as};
} else {
push @close, \*{$_->{parent}}, $_->{open_as};
}
}
require IO::Pipe;
$kidpid = eval {
spawn_with_handles(\@handles, \@close, @_);
};
die "$Me: $@" if $@;
}
foreach (@handles) {
next if $_->{dup} or $_->{dup_of_out};
xclose $_->{open_as}, $_->{mode};
}
# If the write handle is a dup give it away entirely, close my copy
# of it.
xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup};
select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe
$kidpid;
}
sub open3 {
if (@_ < 4) {
local $" = ', ';
croak "open3(@_): not enough arguments";
}
return _open3 'open3', @_
}
sub spawn_with_handles {
my $fds = shift; # Fields: handle, mode, open_as
my $close_in_child = shift;
my ($fd, %saved, @errs);
foreach $fd (@$fds) {
$fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
$saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy};
}
foreach $fd (@$fds) {
bless $fd->{handle}, 'IO::Handle'
unless eval { $fd->{handle}->isa('IO::Handle') } ;
# If some of handles to redirect-to coincide with handles to
# redirect, we need to use saved variants:
my $open_as = $fd->{open_as};
my $fileno = fileno($open_as);
$fd->{handle}->fdopen(defined($fileno)
? $saved{$fileno} || $open_as
: $open_as,
$fd->{mode});
}
unless ($^O eq 'MSWin32') {
require Fcntl;
# Stderr may be redirected below, so we save the err text:
foreach $fd (@$close_in_child) {
next unless fileno $fd;
fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
unless $saved{fileno $fd}; # Do not close what we redirect!
}
}
my $pid;
unless (@errs) {
if (FORCE_DEBUG_SPAWN) {
pipe my $r, my $w or die "Pipe failed: $!";
$pid = fork;
die "Fork failed: $!" unless defined $pid;
if (!$pid) {
{ no warnings; exec @_ }
print $w 0 + $!;
close $w;
require POSIX;
POSIX::_exit(255);
}
close $w;
my $bad = <$r>;
if (defined $bad) {
$! = $bad;
undef $pid;
}
} else {
$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
}
if($@) {
push @errs, "IO::Pipe: Can't spawn-NOWAIT: $@";
} elsif(!$pid || $pid < 0) {
push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!";
}
}
# Do this in reverse, so that STDERR is restored first:
foreach $fd (reverse @$fds) {
$fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
}
foreach (values %saved) {
$_->close or croak "Can't close: $!";
}
croak join "\n", @errs if @errs;
return $pid;
}
1; # so require is happy

View File

@@ -0,0 +1,42 @@
# Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Maintained since 2013 by Paul Evans <leonerd@leonerd.org.uk>
package List::Util;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
all any first min max minstr maxstr none notall product reduce sum sum0 shuffle uniq uniqnum uniqstr
pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst
);
our $VERSION = "1.46_02";
our $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
require XSLoader;
XSLoader::load('List::Util', $XS_VERSION);
sub import
{
my $pkg = caller;
# (RT88848) Touch the caller's $a and $b, to avoid the warning of
# Name "main::a" used only once: possible typo" warning
no strict 'refs';
${"${pkg}::a"} = ${"${pkg}::a"};
${"${pkg}::b"} = ${"${pkg}::b"};
goto &Exporter::import;
}
# For objects returned by pairs()
sub List::Util::_Pair::key { shift->[0] }
sub List::Util::_Pair::value { shift->[1] }
1;

561
common/perl-base/POSIX.pm Normal file
View File

@@ -0,0 +1,561 @@
package POSIX;
use strict;
use warnings;
our ($AUTOLOAD, %SIGRT);
our $VERSION = '1.76';
require XSLoader;
use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD
F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND
O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC
O_WRONLY SEEK_CUR SEEK_END SEEK_SET
S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG
S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID
S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR);
my $loaded;
sub croak { require Carp; goto &Carp::croak }
sub usage { croak "Usage: POSIX::$_[0]" }
XSLoader::load();
my %replacement = (
L_tmpnam => undef,
atexit => 'END {}',
atof => undef,
atoi => undef,
atol => undef,
bsearch => \'not supplied',
calloc => undef,
clearerr => 'IO::Handle::clearerr',
div => '/, % and int',
execl => undef,
execle => undef,
execlp => undef,
execv => undef,
execve => undef,
execvp => undef,
fclose => 'IO::Handle::close',
fdopen => 'IO::Handle::new_from_fd',
feof => 'IO::Handle::eof',
ferror => 'IO::Handle::error',
fflush => 'IO::Handle::flush',
fgetc => 'IO::Handle::getc',
fgetpos => 'IO::Seekable::getpos',
fgets => 'IO::Handle::gets',
fileno => 'IO::Handle::fileno',
fopen => 'IO::File::open',
fprintf => 'printf',
fputc => 'print',
fputs => 'print',
fread => 'read',
free => undef,
freopen => 'open',
fscanf => '<> and regular expressions',
fseek => 'IO::Seekable::seek',
fsetpos => 'IO::Seekable::setpos',
fsync => 'IO::Handle::sync',
ftell => 'IO::Seekable::tell',
fwrite => 'print',
labs => 'abs',
ldiv => '/, % and int',
longjmp => 'die',
malloc => undef,
memchr => 'index()',
memcmp => 'eq',
memcpy => '=',
memmove => '=',
memset => 'x',
offsetof => undef,
putc => 'print',
putchar => 'print',
puts => 'print',
qsort => 'sort',
rand => \'non-portable, use Perl\'s rand instead',
realloc => undef,
scanf => '<> and regular expressions',
setbuf => 'IO::Handle::setbuf',
setjmp => 'eval {}',
setvbuf => 'IO::Handle::setvbuf',
siglongjmp => 'die',
sigsetjmp => 'eval {}',
srand => \'not supplied; refer to Perl\'s srand documentation',
sscanf => 'regular expressions',
strcat => '.=',
strchr => 'index()',
strcmp => 'eq',
strcpy => '=',
strcspn => 'regular expressions',
strlen => 'length',
strncat => '.=',
strncmp => 'eq',
strncpy => '=',
strpbrk => undef,
strrchr => 'rindex()',
strspn => undef,
strtok => undef,
tmpfile => 'IO::File::new_tmpfile',
tmpnam => 'use File::Temp',
ungetc => 'IO::Handle::ungetc',
vfprintf => undef,
vprintf => undef,
vsprintf => undef,
);
my %reimpl = (
abs => 'x => CORE::abs($_[0])',
alarm => 'seconds => CORE::alarm($_[0])',
assert => 'expr => croak "Assertion failed" if !$_[0]',
atan2 => 'x, y => CORE::atan2($_[0], $_[1])',
chdir => 'directory => CORE::chdir($_[0])',
chmod => 'mode, filename => CORE::chmod($_[0], $_[1])',
chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])',
closedir => 'dirhandle => CORE::closedir($_[0])',
cos => 'x => CORE::cos($_[0])',
creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])',
errno => '$! + 0',
exit => 'status => CORE::exit($_[0])',
exp => 'x => CORE::exp($_[0])',
fabs => 'x => CORE::abs($_[0])',
fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])',
fork => 'CORE::fork',
fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross.
getc => 'handle => CORE::getc($_[0])',
getchar => 'CORE::getc(STDIN)',
getegid => '$) + 0',
getenv => 'name => $ENV{$_[0]}',
geteuid => '$> + 0',
getgid => '$( + 0',
getgrgid => 'gid => CORE::getgrgid($_[0])',
getgrnam => 'name => CORE::getgrnam($_[0])',
getgroups => 'my %seen; grep !$seen{$_}++, split " ", $)',
getlogin => 'CORE::getlogin()',
getpgrp => 'CORE::getpgrp',
getpid => '$$',
getppid => 'CORE::getppid',
getpwnam => 'name => CORE::getpwnam($_[0])',
getpwuid => 'uid => CORE::getpwuid($_[0])',
gets => 'scalar <STDIN>',
getuid => '$<',
gmtime => 'time => CORE::gmtime($_[0])',
isatty => 'filehandle => -t $_[0]',
kill => 'pid, sig => CORE::kill $_[1], $_[0]',
link => 'oldfilename, newfilename => CORE::link($_[0], $_[1])',
localtime => 'time => CORE::localtime($_[0])',
log => 'x => CORE::log($_[0])',
mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])',
opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef',
pow => 'x, exponent => $_[0] ** $_[1]',
raise => 'sig => CORE::kill $_[0], $$; # Is this good enough',
readdir => 'dirhandle => CORE::readdir($_[0])',
remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])',
rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])',
rewind => 'filehandle => CORE::seek($_[0],0,0)',
rewinddir => 'dirhandle => CORE::rewinddir($_[0])',
rmdir => 'directoryname => CORE::rmdir($_[0])',
sin => 'x => CORE::sin($_[0])',
sqrt => 'x => CORE::sqrt($_[0])',
stat => 'filename => CORE::stat($_[0])',
strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"',
strstr => 'big, little => CORE::index($_[0], $_[1])',
system => 'command => CORE::system($_[0])',
time => 'CORE::time',
umask => 'mask => CORE::umask($_[0])',
unlink => 'filename => CORE::unlink($_[0])',
utime => 'filename, atime, mtime => CORE::utime($_[1], $_[2], $_[0])',
wait => 'CORE::wait()',
waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])',
);
sub import {
my $pkg = shift;
load_imports() unless $loaded++;
# Grandfather old foo_h form to new :foo_h form
s/^(?=\w+_h$)/:/ for my @list = @_;
my @unimpl = sort grep { exists $replacement{$_} } @list;
if (@unimpl) {
for my $u (@unimpl) {
warn "Unimplemented: POSIX::$u(): ", unimplemented_message($u);
}
croak(sprintf("Unimplemented: %s",
join(" ", map { "POSIX::$_()" } @unimpl)));
}
local $Exporter::ExportLevel = 1;
Exporter::import($pkg,@list);
}
eval join ';', map "sub $_", keys %replacement, keys %reimpl;
sub unimplemented_message {
my $func = shift;
my $how = $replacement{$func};
return "C-specific, stopped" unless defined $how;
return "$$how" if ref $how;
return "$how instead" if $how =~ /^use /;
return "Use method $how() instead" if $how =~ /::/;
return "C-specific: use $how instead";
}
sub AUTOLOAD {
my ($func) = ($AUTOLOAD =~ /.*::(.*)/);
die "POSIX.xs has failed to load\n" if $func eq 'constant';
if (my $code = $reimpl{$func}) {
my ($num, $arg) = (0, '');
if ($code =~ s/^(.*?) *=> *//) {
$arg = $1;
$num = 1 + $arg =~ tr/,//;
}
# no warnings to be consistent with the old implementation, where each
# function was in its own little AutoSplit world:
eval qq{ sub $func {
no warnings;
usage "$func($arg)" if \@_ != $num;
$code
} };
no strict;
goto &$AUTOLOAD;
}
if (exists $replacement{$func}) {
croak "Unimplemented: POSIX::$func(): ", unimplemented_message($func);
}
constant($func);
}
sub perror {
print STDERR "@_: " if @_;
print STDERR $!,"\n";
}
sub printf {
usage "printf(pattern, args...)" if @_ < 1;
CORE::printf STDOUT @_;
}
sub sprintf {
usage "sprintf(pattern, args...)" if @_ == 0;
CORE::sprintf(shift,@_);
}
sub load_imports {
my %default_export_tags = ( # cf. exports policy below
assert_h => [qw(assert NDEBUG)],
ctype_h => [],
dirent_h => [],
errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN
EALREADY EBADF EBADMSG EBUSY ECANCELED ECHILD ECONNABORTED
ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT EEXIST
EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EIDRM EILSEQ EINPROGRESS
EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE
ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS
ENODATA ENODEV ENOENT ENOEXEC ENOLCK ENOLINK ENOMEM ENOMSG
ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK ENOTCONN ENOTDIR
ENOTEMPTY ENOTRECOVERABLE ENOTSOCK ENOTSUP ENOTTY ENXIO
EOPNOTSUPP EOTHER EOVERFLOW EOWNERDEAD EPERM EPFNOSUPPORT EPIPE
EPROCLIM EPROTO EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE
ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE
ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV
errno)],
fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK
F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK
O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK
O_RDONLY O_RDWR O_TRUNC O_WRONLY
creat
SEEK_CUR SEEK_END SEEK_SET
S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID
S_IWGRP S_IWOTH S_IWUSR)],
float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG
DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP
DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP
FLT_DIG FLT_EPSILON FLT_MANT_DIG
FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP
FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP
FLT_RADIX FLT_ROUNDS
LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG
LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP
LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)],
grp_h => [],
limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX
INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON
MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX
PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN
SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX
ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX
_POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT
_POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX
_POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX
_POSIX_STREAM_MAX _POSIX_TZNAME_MAX)],
locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES
LC_MONETARY LC_NUMERIC LC_TIME NULL
localeconv setlocale)],
math_h => [qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL
FP_SUBNORMAL FP_ZERO
M_1_PI M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2 M_LOG10E M_LOG2E
M_PI M_PI_2 M_PI_4 M_SQRT1_2 M_SQRT2
HUGE_VAL INFINITY NAN
acos asin atan ceil cosh fabs floor fmod
frexp ldexp log10 modf pow sinh tan tanh)],
pwd_h => [],
setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)],
signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK
SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM
SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL
SIGPIPE %SIGRT SIGRTMIN SIGRTMAX SIGQUIT SIGSEGV SIGSTOP
SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIGBUS
SIGPOLL SIGPROF SIGSYS SIGTRAP SIGURG SIGVTALRM SIGXCPU SIGXFSZ
SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK
raise sigaction signal sigpending sigprocmask sigsuspend)],
stdarg_h => [],
stddef_h => [qw(NULL offsetof)],
stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid
NULL SEEK_CUR SEEK_END SEEK_SET
STREAM_MAX TMP_MAX stderr stdin stdout
clearerr fclose fdopen feof ferror fflush fgetc fgetpos
fgets fopen fprintf fputc fputs fread freopen
fscanf fseek fsetpos ftell fwrite getchar gets
perror putc putchar puts remove rewind
scanf setbuf setvbuf sscanf tmpfile tmpnam
ungetc vfprintf vprintf vsprintf)],
stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX
abort atexit atof atoi atol bsearch calloc div
free getenv labs ldiv malloc mblen mbstowcs mbtowc
qsort realloc strtod strtol strtoul wcstombs wctomb)],
string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat
strchr strcmp strcoll strcpy strcspn strerror strlen
strncat strncmp strncpy strpbrk strrchr strspn strstr
strtok strxfrm)],
sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG
S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
fstat mkfifo)],
sys_times_h => [],
sys_types_h => [],
sys_utsname_h => [qw(uname)],
sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
WNOHANG WSTOPSIG WTERMSIG WUNTRACED)],
termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400
B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL
CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK
ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR
INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST
PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION
TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW
TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART
VSTOP VSUSP VTIME
cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain
tcflow tcflush tcgetattr tcsendbreak tcsetattr )],
time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime
difftime mktime strftime tzset tzname)],
unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET
STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK
_PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON
_PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX
_PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED
_POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS
_POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX
_SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL
_SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS
_SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION
_exit access ctermid cuserid
dup2 dup execl execle execlp execv execve execvp
fpathconf fsync getcwd getegid geteuid getgid getgroups
getpid getuid isatty lseek pathconf pause setgid setpgid
setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)],
utime_h => [],
);
if ($^O eq 'MSWin32') {
$default_export_tags{winsock_h} = [qw(
WSAEINTR WSAEBADF WSAEACCES WSAEFAULT WSAEINVAL WSAEMFILE WSAEWOULDBLOCK
WSAEINPROGRESS WSAEALREADY WSAENOTSOCK WSAEDESTADDRREQ WSAEMSGSIZE
WSAEPROTOTYPE WSAENOPROTOOPT WSAEPROTONOSUPPORT WSAESOCKTNOSUPPORT
WSAEOPNOTSUPP WSAEPFNOSUPPORT WSAEAFNOSUPPORT WSAEADDRINUSE
WSAEADDRNOTAVAIL WSAENETDOWN WSAENETUNREACH WSAENETRESET WSAECONNABORTED
WSAECONNRESET WSAENOBUFS WSAEISCONN WSAENOTCONN WSAESHUTDOWN
WSAETOOMANYREFS WSAETIMEDOUT WSAECONNREFUSED WSAELOOP WSAENAMETOOLONG
WSAEHOSTDOWN WSAEHOSTUNREACH WSAENOTEMPTY WSAEPROCLIM WSAEUSERS
WSAEDQUOT WSAESTALE WSAEREMOTE WSAEDISCON WSAENOMORE WSAECANCELLED
WSAEINVALIDPROCTABLE WSAEINVALIDPROVIDER WSAEPROVIDERFAILEDINIT
WSAEREFUSED)];
}
my %other_export_tags = ( # cf. exports policy below
fenv_h => [qw(
FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD fegetround fesetround
)],
math_h_c99 => [ @{$default_export_tags{math_h}}, qw(
Inf NaN acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma
fmax fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal
isinf isless islessequal islessgreater isnan isnormal isunordered j0 j1
jn lgamma log1p log2 logb lrint lround nan nearbyint nextafter nexttoward
remainder remquo rint round scalbn signbit tgamma trunc y0 y1 yn
)],
netdb_h => [qw(EAI_AGAIN EAI_BADFLAGS EAI_FAIL
EAI_FAMILY EAI_MEMORY EAI_NONAME
EAI_OVERFLOW EAI_SERVICE EAI_SOCKTYPE
EAI_SYSTEM)],
stdlib_h_c99 => [ @{$default_export_tags{stdlib_h}}, 'strtold' ],
sys_socket_h => [qw(
MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK MSG_TRUNC MSG_WAITALL
)],
nan_payload => [ qw(getpayload setpayload setpayloadsig issignaling) ],
signal_h_si_code => [qw(
ILL_ILLOPC ILL_ILLOPN ILL_ILLADR ILL_ILLTRP ILL_PRVOPC ILL_PRVREG
ILL_COPROC ILL_BADSTK
FPE_INTDIV FPE_INTOVF FPE_FLTDIV FPE_FLTOVF FPE_FLTUND
FPE_FLTRES FPE_FLTINV FPE_FLTSUB
SEGV_MAPERR SEGV_ACCERR
BUS_ADRALN BUS_ADRERR BUS_OBJERR
TRAP_BRKPT TRAP_TRACE
CLD_EXITED CLD_KILLED CLD_DUMPED CLD_TRAPPED CLD_STOPPED CLD_CONTINUED
POLL_IN POLL_OUT POLL_MSG POLL_ERR POLL_PRI POLL_HUP
SI_USER SI_QUEUE SI_TIMER SI_ASYNCIO SI_MESGQ
)],
);
# exports policy:
# - new functions may not be added to @EXPORT, only to @EXPORT_OK
# - new SHOUTYCONSTANTS are OK to add to @EXPORT
{
# De-duplicate the export list:
my ( %export, %export_ok );
@export {map {@$_} values %default_export_tags} = ();
@export_ok{map {@$_} values %other_export_tags} = ();
# Doing the de-dup with a temporary hash has the advantage that the SVs in
# @EXPORT are actually shared hash key scalars, which will save some memory.
our @EXPORT = keys %export;
# you do not want to add symbols to the following list. add a new tag instead
our @EXPORT_OK = (qw(close lchown nice open pipe read sleep times write
printf sprintf),
grep {!exists $export{$_}} keys %reimpl, keys %replacement, keys %export_ok);
our %EXPORT_TAGS = ( %default_export_tags, %other_export_tags );
}
require Exporter;
}
package POSIX::SigAction;
sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] }
sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} };
sub mask { $_[0]->{MASK} = $_[1] if @_ > 1; $_[0]->{MASK} };
sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} };
sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} };
{
package POSIX::SigSet;
# This package is here entirely to make sure that POSIX::SigSet is seen by the
# PAUSE indexer, so that it will always be clearly indexed in core. This is to
# prevent the accidental case where a third-party distribution can accidentally
# claim the POSIX::SigSet package, as occurred in 2011-12. -- rjbs, 2011-12-30
}
package POSIX::SigRt;
require Tie::Hash;
our @ISA = 'Tie::StdHash';
our ($_SIGRTMIN, $_SIGRTMAX, $_sigrtn);
our $SIGACTION_FLAGS = 0;
sub _init {
$_SIGRTMIN = &POSIX::SIGRTMIN;
$_SIGRTMAX = &POSIX::SIGRTMAX;
$_sigrtn = $_SIGRTMAX - $_SIGRTMIN;
}
sub _croak {
&_init unless defined $_sigrtn;
die "POSIX::SigRt not available" unless defined $_sigrtn && $_sigrtn > 0;
}
sub _getsig {
&_croak;
my $rtsig = $_[0];
# Allow (SIGRT)?MIN( + n)?, a common idiom when doing these things in C.
$rtsig = $_SIGRTMIN + ($1 || 0)
if $rtsig =~ /^(?:(?:SIG)?RT)?MIN(\s*\+\s*(\d+))?$/;
return $rtsig;
}
sub _exist {
my $rtsig = _getsig($_[1]);
my $ok = $rtsig >= $_SIGRTMIN && $rtsig <= $_SIGRTMAX;
($rtsig, $ok);
}
sub _check {
my ($rtsig, $ok) = &_exist;
die "No POSIX::SigRt signal $_[1] (valid range SIGRTMIN..SIGRTMAX, or $_SIGRTMIN..$_SIGRTMAX)"
unless $ok;
return $rtsig;
}
sub new {
my ($rtsig, $handler, $flags) = @_;
my $sigset = POSIX::SigSet->new($rtsig);
my $sigact = POSIX::SigAction->new($handler, $sigset, $flags);
POSIX::sigaction($rtsig, $sigact);
}
sub EXISTS { &_exist }
sub FETCH { my $rtsig = &_check;
my $oa = POSIX::SigAction->new();
POSIX::sigaction($rtsig, undef, $oa);
return $oa->{HANDLER} }
sub STORE { my $rtsig = &_check; new($rtsig, $_[2], $SIGACTION_FLAGS) }
sub DELETE { delete $SIG{ &_check } }
sub CLEAR { &_exist; delete @SIG{ &POSIX::SIGRTMIN .. &POSIX::SIGRTMAX } }
sub SCALAR { &_croak; $_sigrtn + 1 }
tie %POSIX::SIGRT, 'POSIX::SigRt';
# and the expression on the line above is true, so we return true.

View File

@@ -0,0 +1,62 @@
# Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Maintained since 2013 by Paul Evans <leonerd@leonerd.org.uk>
package Scalar::Util;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
blessed refaddr reftype weaken unweaken isweak
dualvar isdual isvstring looks_like_number openhandle readonly set_prototype
tainted
);
our $VERSION = "1.46_02";
$VERSION = eval $VERSION;
require List::Util; # List::Util loads the XS
List::Util->VERSION( $VERSION ); # Ensure we got the right XS version (RT#100863)
our @EXPORT_FAIL;
unless (defined &weaken) {
push @EXPORT_FAIL, qw(weaken);
}
unless (defined &isweak) {
push @EXPORT_FAIL, qw(isweak isvstring);
}
unless (defined &isvstring) {
push @EXPORT_FAIL, qw(isvstring);
}
sub export_fail {
if (grep { /^(?:weaken|isweak)$/ } @_ ) {
require Carp;
Carp::croak("Weak references are not implemented in the version of perl");
}
if (grep { /^isvstring$/ } @_ ) {
require Carp;
Carp::croak("Vstrings are not implemented in the version of perl");
}
@_;
}
# set_prototype has been moved to Sub::Util with a different interface
sub set_prototype(&$)
{
my ( $code, $proto ) = @_;
return Sub::Util::set_prototype( $proto, $code );
}
1;
__END__

View File

@@ -0,0 +1,22 @@
package SelectSaver;
our $VERSION = '1.02';
require 5.000;
use Carp;
use Symbol;
sub new {
@_ >= 1 && @_ <= 2 or croak 'usage: SelectSaver->new( [FILEHANDLE] )';
my $fh = select;
my $self = bless \$fh, $_[0];
select qualify($_[1], caller) if @_ > 1;
$self;
}
sub DESTROY {
my $self = $_[0];
select $$self;
}
1;

444
common/perl-base/Socket.pm Normal file
View File

@@ -0,0 +1,444 @@
package Socket;
use strict;
{ use 5.006001; }
our $VERSION = '2.020_03'; # patched in perl5.git
# Still undocumented: SCM_*, SOMAXCONN, IOV_MAX, UIO_MAXIOV
use Carp;
use warnings::register;
require Exporter;
require XSLoader;
our @ISA = qw(Exporter);
# <@Nicholas> you can't change @EXPORT without breaking the implicit API
# Please put any new constants in @EXPORT_OK!
# List re-ordered to match documentation above. Try to keep the ordering
# consistent so it's easier to see which ones are or aren't documented.
our @EXPORT = qw(
PF_802 PF_AAL PF_APPLETALK PF_CCITT PF_CHAOS PF_CTF PF_DATAKIT
PF_DECnet PF_DLI PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_INET6
PF_ISO PF_KEY PF_LAST PF_LAT PF_LINK PF_MAX PF_NBS PF_NIT PF_NS PF_OSI
PF_OSINET PF_PUP PF_ROUTE PF_SNA PF_UNIX PF_UNSPEC PF_USER PF_WAN
PF_X25
AF_802 AF_AAL AF_APPLETALK AF_CCITT AF_CHAOS AF_CTF AF_DATAKIT
AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_INET6
AF_ISO AF_KEY AF_LAST AF_LAT AF_LINK AF_MAX AF_NBS AF_NIT AF_NS AF_OSI
AF_OSINET AF_PUP AF_ROUTE AF_SNA AF_UNIX AF_UNSPEC AF_USER AF_WAN
AF_X25
SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM
SOL_SOCKET
SO_ACCEPTCONN SO_ATTACH_FILTER SO_BACKLOG SO_BROADCAST SO_CHAMELEON
SO_DEBUG SO_DETACH_FILTER SO_DGRAM_ERRIND SO_DOMAIN SO_DONTLINGER
SO_DONTROUTE SO_ERROR SO_FAMILY SO_KEEPALIVE SO_LINGER SO_OOBINLINE
SO_PASSCRED SO_PASSIFNAME SO_PEERCRED SO_PROTOCOL SO_PROTOTYPE
SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT
SO_SECURITY_AUTHENTICATION SO_SECURITY_ENCRYPTION_NETWORK
SO_SECURITY_ENCRYPTION_TRANSPORT SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO
SO_STATE SO_TYPE SO_USELOOPBACK SO_XOPEN SO_XSE
IP_OPTIONS IP_HDRINCL IP_TOS IP_TTL IP_RECVOPTS IP_RECVRETOPTS
IP_RETOPTS
MSG_BCAST MSG_BTAG MSG_CTLFLAGS MSG_CTLIGNORE MSG_CTRUNC MSG_DONTROUTE
MSG_DONTWAIT MSG_EOF MSG_EOR MSG_ERRQUEUE MSG_ETAG MSG_FIN
MSG_MAXIOVLEN MSG_MCAST MSG_NOSIGNAL MSG_OOB MSG_PEEK MSG_PROXY MSG_RST
MSG_SYN MSG_TRUNC MSG_URG MSG_WAITALL MSG_WIRE
SHUT_RD SHUT_RDWR SHUT_WR
INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
SCM_CONNECT SCM_CREDENTIALS SCM_CREDS SCM_RIGHTS SCM_TIMESTAMP
SOMAXCONN
IOV_MAX
UIO_MAXIOV
sockaddr_family
pack_sockaddr_in unpack_sockaddr_in sockaddr_in
pack_sockaddr_in6 unpack_sockaddr_in6 sockaddr_in6
pack_sockaddr_un unpack_sockaddr_un sockaddr_un
inet_aton inet_ntoa
);
# List re-ordered to match documentation above. Try to keep the ordering
# consistent so it's easier to see which ones are or aren't documented.
our @EXPORT_OK = qw(
CR LF CRLF $CR $LF $CRLF
SOCK_NONBLOCK SOCK_CLOEXEC
IP_ADD_MEMBERSHIP IP_ADD_SOURCE_MEMBERSHIP IP_DROP_MEMBERSHIP
IP_DROP_SOURCE_MEMBERSHIP IP_MULTICAST_IF IP_MULTICAST_LOOP
IP_MULTICAST_TTL
IPPROTO_IP IPPROTO_IPV6 IPPROTO_RAW IPPROTO_ICMP IPPROTO_IGMP
IPPROTO_TCP IPPROTO_UDP IPPROTO_GRE IPPROTO_ESP IPPROTO_AH
IPPROTO_SCTP
IPTOS_LOWDELAY IPTOS_THROUGHPUT IPTOS_RELIABILITY IPTOS_MINCOST
TCP_CONGESTION TCP_CONNECTIONTIMEOUT TCP_CORK TCP_DEFER_ACCEPT TCP_INFO
TCP_INIT_CWND TCP_KEEPALIVE TCP_KEEPCNT TCP_KEEPIDLE TCP_KEEPINTVL
TCP_LINGER2 TCP_MAXRT TCP_MAXSEG TCP_MD5SIG TCP_NODELAY TCP_NOOPT
TCP_NOPUSH TCP_QUICKACK TCP_SACK_ENABLE TCP_STDURG TCP_SYNCNT
TCP_WINDOW_CLAMP
IN6ADDR_ANY IN6ADDR_LOOPBACK
IPV6_ADD_MEMBERSHIP IPV6_DROP_MEMBERSHIP IPV6_JOIN_GROUP
IPV6_LEAVE_GROUP IPV6_MTU IPV6_MTU_DISCOVER IPV6_MULTICAST_HOPS
IPV6_MULTICAST_IF IPV6_MULTICAST_LOOP IPV6_UNICAST_HOPS IPV6_V6ONLY
pack_ip_mreq unpack_ip_mreq pack_ip_mreq_source unpack_ip_mreq_source
pack_ipv6_mreq unpack_ipv6_mreq
inet_pton inet_ntop
getaddrinfo getnameinfo
AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN
AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES AI_NUMERICHOST
AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED
NI_DGRAM NI_IDN NI_IDN_ALLOW_UNASSIGNED NI_IDN_USE_STD3_ASCII_RULES
NI_NAMEREQD NI_NOFQDN NI_NUMERICHOST NI_NUMERICSERV
NIx_NOHOST NIx_NOSERV
EAI_ADDRFAMILY EAI_AGAIN EAI_BADFLAGS EAI_BADHINTS EAI_FAIL EAI_FAMILY
EAI_NODATA EAI_NONAME EAI_PROTOCOL EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM
);
our %EXPORT_TAGS = (
crlf => [qw(CR LF CRLF $CR $LF $CRLF)],
addrinfo => [qw(getaddrinfo getnameinfo), grep m/^(?:AI|NI|NIx|EAI)_/, @EXPORT_OK],
all => [@EXPORT, @EXPORT_OK],
);
BEGIN {
sub CR () {"\015"}
sub LF () {"\012"}
sub CRLF () {"\015\012"}
# These are not gni() constants; they're extensions for the perl API
# The definitions in Socket.pm and Socket.xs must match
sub NIx_NOHOST() {1 << 0}
sub NIx_NOSERV() {1 << 1}
}
*CR = \CR();
*LF = \LF();
*CRLF = \CRLF();
sub sockaddr_in {
if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die
my($af, $port, @quad) = @_;
warnings::warn "6-ARG sockaddr_in call is deprecated"
if warnings::enabled();
pack_sockaddr_in($port, inet_aton(join('.', @quad)));
} elsif (wantarray) {
croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1;
unpack_sockaddr_in(@_);
} else {
croak "usage: sin_sv = sockaddr_in(port,iaddr))" unless @_ == 2;
pack_sockaddr_in(@_);
}
}
sub sockaddr_in6 {
if (wantarray) {
croak "usage: (port,in6addr,scope_id,flowinfo) = sockaddr_in6(sin6_sv)" unless @_ == 1;
unpack_sockaddr_in6(@_);
}
else {
croak "usage: sin6_sv = sockaddr_in6(port,in6addr,[scope_id,[flowinfo]])" unless @_ >= 2 and @_ <= 4;
pack_sockaddr_in6(@_);
}
}
sub sockaddr_un {
if (wantarray) {
croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1;
unpack_sockaddr_un(@_);
} else {
croak "usage: sun_sv = sockaddr_un(filename)" unless @_ == 1;
pack_sockaddr_un(@_);
}
}
XSLoader::load(__PACKAGE__, $VERSION);
my %errstr;
if( defined &getaddrinfo ) {
# These are not part of the API, nothing uses them, and deleting them
# reduces the size of %Socket:: by about 12K
delete $Socket::{fake_getaddrinfo};
delete $Socket::{fake_getnameinfo};
} else {
require Scalar::Util;
*getaddrinfo = \&fake_getaddrinfo;
*getnameinfo = \&fake_getnameinfo;
# These numbers borrowed from GNU libc's implementation, but since
# they're only used by our emulation, it doesn't matter if the real
# platform's values differ
my %constants = (
AI_PASSIVE => 1,
AI_CANONNAME => 2,
AI_NUMERICHOST => 4,
AI_V4MAPPED => 8,
AI_ALL => 16,
AI_ADDRCONFIG => 32,
# RFC 2553 doesn't define this but Linux does - lets be nice and
# provide it since we can
AI_NUMERICSERV => 1024,
EAI_BADFLAGS => -1,
EAI_NONAME => -2,
EAI_NODATA => -5,
EAI_FAMILY => -6,
EAI_SERVICE => -8,
NI_NUMERICHOST => 1,
NI_NUMERICSERV => 2,
NI_NOFQDN => 4,
NI_NAMEREQD => 8,
NI_DGRAM => 16,
# Constants we don't support. Export them, but croak if anyone tries to
# use them
AI_IDN => 64,
AI_CANONIDN => 128,
AI_IDN_ALLOW_UNASSIGNED => 256,
AI_IDN_USE_STD3_ASCII_RULES => 512,
NI_IDN => 32,
NI_IDN_ALLOW_UNASSIGNED => 64,
NI_IDN_USE_STD3_ASCII_RULES => 128,
# Error constants we'll never return, so it doesn't matter what value
# these have, nor that we don't provide strings for them
EAI_SYSTEM => -11,
EAI_BADHINTS => -1000,
EAI_PROTOCOL => -1001
);
foreach my $name ( keys %constants ) {
my $value = $constants{$name};
no strict 'refs';
defined &$name or *$name = sub () { $value };
}
%errstr = (
# These strings from RFC 2553
EAI_BADFLAGS() => "invalid value for ai_flags",
EAI_NONAME() => "nodename nor servname provided, or not known",
EAI_NODATA() => "no address associated with nodename",
EAI_FAMILY() => "ai_family not supported",
EAI_SERVICE() => "servname not supported for ai_socktype",
);
}
# The following functions are used if the system does not have a
# getaddrinfo(3) function in libc; and are used to emulate it for the AF_INET
# family
# Borrowed from Regexp::Common::net
my $REGEXP_IPv4_DECIMAL = qr/25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}/;
my $REGEXP_IPv4_DOTTEDQUAD = qr/$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL/;
sub fake_makeerr
{
my ( $errno ) = @_;
my $errstr = $errno == 0 ? "" : ( $errstr{$errno} || $errno );
return Scalar::Util::dualvar( $errno, $errstr );
}
sub fake_getaddrinfo
{
my ( $node, $service, $hints ) = @_;
$node = "" unless defined $node;
$service = "" unless defined $service;
my ( $family, $socktype, $protocol, $flags ) = @$hints{qw( family socktype protocol flags )};
$family ||= Socket::AF_INET(); # 0 == AF_UNSPEC, which we want too
$family == Socket::AF_INET() or return fake_makeerr( EAI_FAMILY() );
$socktype ||= 0;
$protocol ||= 0;
$flags ||= 0;
my $flag_passive = $flags & AI_PASSIVE(); $flags &= ~AI_PASSIVE();
my $flag_canonname = $flags & AI_CANONNAME(); $flags &= ~AI_CANONNAME();
my $flag_numerichost = $flags & AI_NUMERICHOST(); $flags &= ~AI_NUMERICHOST();
my $flag_numericserv = $flags & AI_NUMERICSERV(); $flags &= ~AI_NUMERICSERV();
# These constants don't apply to AF_INET-only lookups, so we might as well
# just ignore them. For AI_ADDRCONFIG we just presume the host has ability
# to talk AF_INET. If not we'd have to return no addresses at all. :)
$flags &= ~(AI_V4MAPPED()|AI_ALL()|AI_ADDRCONFIG());
$flags & (AI_IDN()|AI_CANONIDN()|AI_IDN_ALLOW_UNASSIGNED()|AI_IDN_USE_STD3_ASCII_RULES()) and
croak "Socket::getaddrinfo() does not support IDN";
$flags == 0 or return fake_makeerr( EAI_BADFLAGS() );
$node eq "" and $service eq "" and return fake_makeerr( EAI_NONAME() );
my $canonname;
my @addrs;
if( $node ne "" ) {
return fake_makeerr( EAI_NONAME() ) if( $flag_numerichost and $node !~ m/^$REGEXP_IPv4_DOTTEDQUAD$/ );
( $canonname, undef, undef, undef, @addrs ) = gethostbyname( $node );
defined $canonname or return fake_makeerr( EAI_NONAME() );
undef $canonname unless $flag_canonname;
}
else {
$addrs[0] = $flag_passive ? Socket::inet_aton( "0.0.0.0" )
: Socket::inet_aton( "127.0.0.1" );
}
my @ports; # Actually ARRAYrefs of [ socktype, protocol, port ]
my $protname = "";
if( $protocol ) {
$protname = eval { getprotobynumber( $protocol ) };
}
if( $service ne "" and $service !~ m/^\d+$/ ) {
return fake_makeerr( EAI_NONAME() ) if( $flag_numericserv );
getservbyname( $service, $protname ) or return fake_makeerr( EAI_SERVICE() );
}
foreach my $this_socktype ( Socket::SOCK_STREAM(), Socket::SOCK_DGRAM(), Socket::SOCK_RAW() ) {
next if $socktype and $this_socktype != $socktype;
my $this_protname = "raw";
$this_socktype == Socket::SOCK_STREAM() and $this_protname = "tcp";
$this_socktype == Socket::SOCK_DGRAM() and $this_protname = "udp";
next if $protname and $this_protname ne $protname;
my $port;
if( $service ne "" ) {
if( $service =~ m/^\d+$/ ) {
$port = "$service";
}
else {
( undef, undef, $port, $this_protname ) = getservbyname( $service, $this_protname );
next unless defined $port;
}
}
else {
$port = 0;
}
push @ports, [ $this_socktype, eval { scalar getprotobyname( $this_protname ) } || 0, $port ];
}
my @ret;
foreach my $addr ( @addrs ) {
foreach my $portspec ( @ports ) {
my ( $socktype, $protocol, $port ) = @$portspec;
push @ret, {
family => $family,
socktype => $socktype,
protocol => $protocol,
addr => Socket::pack_sockaddr_in( $port, $addr ),
canonname => undef,
};
}
}
# Only supply canonname for the first result
if( defined $canonname ) {
$ret[0]->{canonname} = $canonname;
}
return ( fake_makeerr( 0 ), @ret );
}
sub fake_getnameinfo
{
my ( $addr, $flags, $xflags ) = @_;
my ( $port, $inetaddr );
eval { ( $port, $inetaddr ) = Socket::unpack_sockaddr_in( $addr ) }
or return fake_makeerr( EAI_FAMILY() );
my $family = Socket::AF_INET();
$flags ||= 0;
my $flag_numerichost = $flags & NI_NUMERICHOST(); $flags &= ~NI_NUMERICHOST();
my $flag_numericserv = $flags & NI_NUMERICSERV(); $flags &= ~NI_NUMERICSERV();
my $flag_nofqdn = $flags & NI_NOFQDN(); $flags &= ~NI_NOFQDN();
my $flag_namereqd = $flags & NI_NAMEREQD(); $flags &= ~NI_NAMEREQD();
my $flag_dgram = $flags & NI_DGRAM() ; $flags &= ~NI_DGRAM();
$flags & (NI_IDN()|NI_IDN_ALLOW_UNASSIGNED()|NI_IDN_USE_STD3_ASCII_RULES()) and
croak "Socket::getnameinfo() does not support IDN";
$flags == 0 or return fake_makeerr( EAI_BADFLAGS() );
$xflags ||= 0;
my $node;
if( $xflags & NIx_NOHOST ) {
$node = undef;
}
elsif( $flag_numerichost ) {
$node = Socket::inet_ntoa( $inetaddr );
}
else {
$node = gethostbyaddr( $inetaddr, $family );
if( !defined $node ) {
return fake_makeerr( EAI_NONAME() ) if $flag_namereqd;
$node = Socket::inet_ntoa( $inetaddr );
}
elsif( $flag_nofqdn ) {
my ( $shortname ) = split m/\./, $node;
my ( $fqdn ) = gethostbyname $shortname;
$node = $shortname if defined $fqdn and $fqdn eq $node;
}
}
my $service;
if( $xflags & NIx_NOSERV ) {
$service = undef;
}
elsif( $flag_numericserv ) {
$service = "$port";
}
else {
my $protname = $flag_dgram ? "udp" : "";
$service = getservbyport( $port, $protname );
if( !defined $service ) {
$service = "$port";
}
}
return ( fake_makeerr( 0 ), $node, $service );
}
1;

View File

@@ -0,0 +1,91 @@
package Symbol;
BEGIN { require 5.005; }
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
@EXPORT_OK = qw(delete_package geniosym);
$VERSION = '1.08';
my $genpkg = "Symbol::";
my $genseq = 0;
my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
#
# Note that we never _copy_ the glob; we just make a ref to it.
# If we did copy it, then SVf_FAKE would be set on the copy, and
# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work.
#
sub gensym () {
my $name = "GEN" . $genseq++;
my $ref = \*{$genpkg . $name};
delete $$genpkg{$name};
$ref;
}
sub geniosym () {
my $sym = gensym();
# force the IO slot to be filled
select(select $sym);
*$sym{IO};
}
sub ungensym ($) {}
sub qualify ($;$) {
my ($name) = @_;
if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
my $pkg;
# Global names: special character, "^xyz", or other.
if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
# RGS 2001-11-05 : translate leading ^X to control-char
$name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
$pkg = "main";
}
else {
$pkg = (@_ > 1) ? $_[1] : caller;
}
$name = $pkg . "::" . $name;
}
$name;
}
sub qualify_to_ref ($;$) {
return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
}
#
# of Safe.pm lineage
#
sub delete_package ($) {
my $pkg = shift;
# expand to full symbol table name if needed
unless ($pkg =~ /^main::.*::$/) {
$pkg = "main$pkg" if $pkg =~ /^::/;
$pkg = "main::$pkg" unless $pkg =~ /^main::/;
$pkg .= '::' unless $pkg =~ /::$/;
}
my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
my $stem_symtab = *{$stem}{HASH};
return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
# free all the symbols in the package
my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
foreach my $name (keys %$leaf_symtab) {
undef *{$pkg . $name};
}
# delete the symbol table
%$leaf_symtab = ();
delete $stem_symtab->{$leaf};
}
1;

View File

@@ -0,0 +1,166 @@
package Text::ParseWords;
use strict;
require 5.006;
our $VERSION = "3.30";
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(shellwords quotewords nested_quotewords parse_line);
our @EXPORT_OK = qw(old_shellwords);
our $PERL_SINGLE_QUOTE;
sub shellwords {
my (@lines) = @_;
my @allwords;
foreach my $line (@lines) {
$line =~ s/^\s+//;
my @words = parse_line('\s+', 0, $line);
pop @words if (@words and !defined $words[-1]);
return() unless (@words || !length($line));
push(@allwords, @words);
}
return(@allwords);
}
sub quotewords {
my($delim, $keep, @lines) = @_;
my($line, @words, @allwords);
foreach $line (@lines) {
@words = parse_line($delim, $keep, $line);
return() unless (@words || !length($line));
push(@allwords, @words);
}
return(@allwords);
}
sub nested_quotewords {
my($delim, $keep, @lines) = @_;
my($i, @allwords);
for ($i = 0; $i < @lines; $i++) {
@{$allwords[$i]} = parse_line($delim, $keep, $lines[$i]);
return() unless (@{$allwords[$i]} || !length($lines[$i]));
}
return(@allwords);
}
sub parse_line {
my($delimiter, $keep, $line) = @_;
my($word, @pieces);
no warnings 'uninitialized'; # we will be testing undef strings
while (length($line)) {
# This pattern is optimised to be stack conservative on older perls.
# Do not refactor without being careful and testing it on very long strings.
# See Perl bug #42980 for an example of a stack busting input.
$line =~ s/^
(?:
# double quoted string
(") # $quote
((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted
| # --OR--
# singe quoted string
(') # $quote
((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted
| # --OR--
# unquoted string
( # $unquoted
(?:\\.|[^\\"'])*?
)
# followed by
( # $delim
\Z(?!\n) # EOL
| # --OR--
(?-x:$delimiter) # delimiter
| # --OR--
(?!^)(?=["']) # a quote
)
)//xs or return; # extended layout
my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6);
return() unless( defined($quote) || length($unquoted) || length($delim));
if ($keep) {
$quoted = "$quote$quoted$quote";
}
else {
$unquoted =~ s/\\(.)/$1/sg;
if (defined $quote) {
$quoted =~ s/\\(.)/$1/sg if ($quote eq '"');
$quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'");
}
}
$word .= substr($line, 0, 0); # leave results tainted
$word .= defined $quote ? $quoted : $unquoted;
if (length($delim)) {
push(@pieces, $word);
push(@pieces, $delim) if ($keep eq 'delimiters');
undef $word;
}
if (!length($line)) {
push(@pieces, $word);
}
}
return(@pieces);
}
sub old_shellwords {
# Usage:
# use ParseWords;
# @words = old_shellwords($line);
# or
# @words = old_shellwords(@lines);
# or
# @words = old_shellwords(); # defaults to $_ (and clobbers it)
no warnings 'uninitialized'; # we will be testing undef strings
local *_ = \join('', @_) if @_;
my (@words, $snippet);
s/\A\s+//;
while ($_ ne '') {
my $field = substr($_, 0, 0); # leave results tainted
for (;;) {
if (s/\A"(([^"\\]|\\.)*)"//s) {
($snippet = $1) =~ s#\\(.)#$1#sg;
}
elsif (/\A"/) {
require Carp;
Carp::carp("Unmatched double quote: $_");
return();
}
elsif (s/\A'(([^'\\]|\\.)*)'//s) {
($snippet = $1) =~ s#\\(.)#$1#sg;
}
elsif (/\A'/) {
require Carp;
Carp::carp("Unmatched single quote: $_");
return();
}
elsif (s/\A\\(.?)//s) {
$snippet = $1;
}
elsif (s/\A([^\s\\'"]+)//) {
$snippet = $1;
}
else {
s/\A\s+//;
last;
}
$field .= $snippet;
}
push(@words, $field);
}
return @words;
}
1;
__END__

View File

@@ -0,0 +1,100 @@
package Text::Tabs;
require Exporter;
@ISA = (Exporter);
@EXPORT = qw(expand unexpand $tabstop);
use vars qw($VERSION $SUBVERSION $tabstop $debug);
$VERSION = 2013.0523;
$SUBVERSION = 'modern';
use strict;
use 5.010_000;
BEGIN {
$tabstop = 8;
$debug = 0;
}
my $CHUNK = qr/\X/;
sub _xlen (_) { scalar(() = $_[0] =~ /$CHUNK/g) }
sub _xpos (_) { _xlen( substr( $_[0], 0, pos($_[0]) ) ) }
sub expand {
my @l;
my $pad;
for ( @_ ) {
my $s = '';
for (split(/^/m, $_, -1)) {
my $offs = 0;
s{\t}{
# this works on both 5.10 and 5.11
$pad = $tabstop - (_xlen(${^PREMATCH}) + $offs) % $tabstop;
# this works on 5.11, but fails on 5.10
#XXX# $pad = $tabstop - (_xpos() + $offs) % $tabstop;
$offs += $pad - 1;
" " x $pad;
}peg;
$s .= $_;
}
push(@l, $s);
}
return @l if wantarray;
return $l[0];
}
sub unexpand
{
my (@l) = @_;
my @e;
my $x;
my $line;
my @lines;
my $lastbit;
my $ts_as_space = " " x $tabstop;
for $x (@l) {
@lines = split("\n", $x, -1);
for $line (@lines) {
$line = expand($line);
@e = split(/(${CHUNK}{$tabstop})/,$line,-1);
$lastbit = pop(@e);
$lastbit = ''
unless defined $lastbit;
$lastbit = "\t"
if $lastbit eq $ts_as_space;
for $_ (@e) {
if ($debug) {
my $x = $_;
$x =~ s/\t/^I\t/gs;
print "sub on '$x'\n";
}
s/ +$/\t/;
}
$line = join('',@e, $lastbit);
}
$x = join("\n", @lines);
}
return @l if wantarray;
return $l[0];
}
1;
__END__
sub expand
{
my (@l) = @_;
for $_ (@l) {
1 while s/(^|\n)([^\t\n]*)(\t+)/
$1. $2 . (" " x
($tabstop * length($3)
- (length($2) % $tabstop)))
/sex;
}
return @l if wantarray;
return $l[0];
}

View File

@@ -0,0 +1,132 @@
package Text::Wrap;
use warnings::register;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(wrap fill);
@EXPORT_OK = qw($columns $break $huge);
$VERSION = 2013.0523;
$SUBVERSION = 'modern';
use 5.010_000;
use vars qw($VERSION $SUBVERSION $columns $debug $break $huge $unexpand $tabstop $separator $separator2);
use strict;
BEGIN {
$columns = 76; # <= screen width
$debug = 0;
$break = '(?=\s)\X';
$huge = 'wrap'; # alternatively: 'die' or 'overflow'
$unexpand = 1;
$tabstop = 8;
$separator = "\n";
$separator2 = undef;
}
my $CHUNK = qr/\X/;
sub _xlen(_) { scalar(() = $_[0] =~ /$CHUNK/g) }
sub _xpos(_) { _xlen( substr( $_[0], 0, pos($_[0]) ) ) }
use Text::Tabs qw(expand unexpand);
sub wrap
{
my ($ip, $xp, @t) = @_;
local($Text::Tabs::tabstop) = $tabstop;
my $r = "";
my $tail = pop(@t);
my $t = expand(join("", (map { /\s+\z/ ? ( $_ ) : ($_, ' ') } @t), $tail));
my $lead = $ip;
my $nll = $columns - _xlen(expand($xp)) - 1;
if ($nll <= 0 && $xp ne '') {
my $nc = _xlen(expand($xp)) + 2;
warnings::warnif "Increasing \$Text::Wrap::columns from $columns to $nc to accommodate length of subsequent tab";
$columns = $nc;
$nll = 1;
}
my $ll = $columns - _xlen(expand($ip)) - 1;
$ll = 0 if $ll < 0;
my $nl = "";
my $remainder = "";
use re 'taint';
pos($t) = 0;
while ($t !~ /\G(?:$break)*\Z/gc) {
if ($t =~ /\G((?:(?=[^\n])\X){0,$ll})($break|\n+|\z)/xmgc) {
$r .= $unexpand
? unexpand($nl . $lead . $1)
: $nl . $lead . $1;
$remainder = $2;
} elsif ($huge eq 'wrap' && $t =~ /\G((?:(?=[^\n])\X){$ll})/gc) {
$r .= $unexpand
? unexpand($nl . $lead . $1)
: $nl . $lead . $1;
$remainder = defined($separator2) ? $separator2 : $separator;
} elsif ($huge eq 'overflow' && $t =~ /\G((?:(?=[^\n])\X)*?)($break|\n+|\z)/xmgc) {
$r .= $unexpand
? unexpand($nl . $lead . $1)
: $nl . $lead . $1;
$remainder = $2;
} elsif ($huge eq 'die') {
die "couldn't wrap '$t'";
} elsif ($columns < 2) {
warnings::warnif "Increasing \$Text::Wrap::columns from $columns to 2";
$columns = 2;
return ($ip, $xp, @t);
} else {
die "This shouldn't happen";
}
$lead = $xp;
$ll = $nll;
$nl = defined($separator2)
? ($remainder eq "\n"
? "\n"
: $separator2)
: $separator;
}
$r .= $remainder;
print "-----------$r---------\n" if $debug;
print "Finish up with '$lead'\n" if $debug;
my($opos) = pos($t);
$r .= $lead . substr($t, pos($t), length($t) - pos($t))
if pos($t) ne length($t);
print "-----------$r---------\n" if $debug;;
return $r;
}
sub fill
{
my ($ip, $xp, @raw) = @_;
my @para;
my $pp;
for $pp (split(/\n\s+/, join("\n",@raw))) {
$pp =~ s/\s+/ /g;
my $x = wrap($ip, $xp, $pp);
push(@para, $x);
}
# if paragraph_indent is the same as line_indent,
# separate paragraphs with blank lines
my $ps = ($ip eq $xp) ? "\n\n" : "\n";
return join ($ps, @para);
}
1;
__END__

View File

@@ -0,0 +1,85 @@
package Tie::Hash;
our $VERSION = '1.05';
use Carp;
use warnings::register;
sub new {
my $pkg = shift;
$pkg->TIEHASH(@_);
}
# Grandfather "new"
sub TIEHASH {
my $pkg = shift;
my $pkg_new = $pkg -> can ('new');
if ($pkg_new and $pkg ne __PACKAGE__) {
my $my_new = __PACKAGE__ -> can ('new');
if ($pkg_new == $my_new) {
#
# Prevent recursion
#
croak "$pkg must define either a TIEHASH() or a new() method";
}
warnings::warnif ("WARNING: calling ${pkg}->new since " .
"${pkg}->TIEHASH is missing");
$pkg -> new (@_);
}
else {
croak "$pkg doesn't define a TIEHASH method";
}
}
sub EXISTS {
my $pkg = ref $_[0];
croak "$pkg doesn't define an EXISTS method";
}
sub CLEAR {
my $self = shift;
my $key = $self->FIRSTKEY(@_);
my @keys;
while (defined $key) {
push @keys, $key;
$key = $self->NEXTKEY(@_, $key);
}
foreach $key (@keys) {
$self->DELETE(@_, $key);
}
}
# The Tie::StdHash package implements standard perl hash behaviour.
# It exists to act as a base class for classes which only wish to
# alter some parts of their behaviour.
package Tie::StdHash;
# @ISA = qw(Tie::Hash); # would inherit new() only
sub TIEHASH { bless {}, $_[0] }
sub STORE { $_[0]->{$_[1]} = $_[2] }
sub FETCH { $_[0]->{$_[1]} }
sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY { each %{$_[0]} }
sub EXISTS { exists $_[0]->{$_[1]} }
sub DELETE { delete $_[0]->{$_[1]} }
sub CLEAR { %{$_[0]} = () }
sub SCALAR { scalar %{$_[0]} }
package Tie::ExtraHash;
sub TIEHASH { my $p = shift; bless [{}, @_], $p }
sub STORE { $_[0][0]{$_[1]} = $_[2] }
sub FETCH { $_[0][0]{$_[1]} }
sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
sub NEXTKEY { each %{$_[0][0]} }
sub EXISTS { exists $_[0][0]->{$_[1]} }
sub DELETE { delete $_[0][0]->{$_[1]} }
sub CLEAR { %{$_[0][0]} = () }
sub SCALAR { scalar %{$_[0][0]} }
1;

View File

@@ -0,0 +1,125 @@
# Generated from XSLoader_pm.PL (resolved %Config::Config value)
# This file is unique for every OS
package XSLoader;
$VERSION = "0.27";
#use strict;
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;
my ($caller, $modlibname) = caller();
my $module = $caller;
if (@_) {
$module = $_[0];
} else {
$_[0] = $module;
}
# work with static linking too
my $boots = "$module\::bootstrap";
goto &$boots if defined &$boots;
goto \&XSLoader::bootstrap_inherit unless $module and defined &dl_load_file;
my @modparts = split(/::/,$module);
my $modfname = $modparts[-1];
my $modpname = join('/',@modparts);
my $c = () = split(/::/,$caller,-1);
$modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
# Does this look like a relative path?
if ($modlibname !~ m{^/}) {
# Someone may have a #line directive that changes the file name, or
# may be calling XSLoader::load from inside a string eval. We cer-
# tainly do not want to go loading some code that is not in @INC,
# as it could be untrusted.
#
# We could just fall back to DynaLoader here, but then the rest of
# this function would go untested in the perl core, since all @INC
# paths are relative during testing. That would be a time bomb
# waiting to happen, since bugs could be introduced into the code.
#
# So look through @INC to see if $modlibname is in it. A rela-
# tive $modlibname is not a common occurrence, so this block is
# not hot code.
FOUND: {
for (@INC) {
if ($_ eq $modlibname) {
last FOUND;
}
}
# Not found. Fall back to DynaLoader.
goto \&XSLoader::bootstrap_inherit;
}
}
my $file = "$modlibname/auto/$modpname/$modfname.so";
# 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
if (-s $bs) { # only read file if it's not empty
# print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
eval { local @INC = ('.'); do $bs; };
warn "$bs: $@\n" if $@;
goto \&XSLoader::bootstrap_inherit;
}
goto \&XSLoader::bootstrap_inherit if not -f $file;
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
$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($boots, $boot_symbol_ref, $file);
# See comment block above
push(@DynaLoader::dl_shared_objects, $file); # record files loaded
return &$xs(@_);
}
sub bootstrap_inherit {
require DynaLoader;
goto \&DynaLoader::bootstrap_inherit;
}
1;
__END__

View File

@@ -0,0 +1,120 @@
package attributes;
our $VERSION = 0.29;
@EXPORT_OK = qw(get reftype);
@EXPORT = ();
%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]);
use strict;
sub croak {
require Carp;
goto &Carp::croak;
}
sub carp {
require Carp;
goto &Carp::carp;
}
my %deprecated;
$deprecated{CODE} = qr/\A-?(locked)\z/;
$deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR}
= qr/\A-?(unique)\z/;
my %msg = (
lvalue => 'lvalue attribute applied to already-defined subroutine',
-lvalue => 'lvalue attribute removed from already-defined subroutine',
const => 'Useless use of attribute "const"',
);
sub _modify_attrs_and_deprecate {
my $svtype = shift;
# Now that we've removed handling of locked from the XS code, we need to
# remove it here, else it ends up in @badattrs. (If we do the deprecation in
# XS, we can't control the warning based on *our* caller's lexical settings,
# and the warned line is in this package)
grep {
$deprecated{$svtype} && /$deprecated{$svtype}/ ? do {
require warnings;
warnings::warnif('deprecated', "Attribute \"$1\" is deprecated, " .
"and will disappear in Perl 5.28");
0;
} : $svtype eq 'CODE' && exists $msg{$_} ? do {
require warnings;
warnings::warnif(
'misc',
$msg{$_}
);
0;
} : 1
} _modify_attrs(@_);
}
sub import {
@_ > 2 && ref $_[2] or do {
require Exporter;
goto &Exporter::import;
};
my (undef,$home_stash,$svref,@attrs) = @_;
my $svtype = uc reftype($svref);
my $pkgmeth;
$pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES")
if defined $home_stash && $home_stash ne '';
my @badattrs;
if ($pkgmeth) {
my @pkgattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs);
@badattrs = $pkgmeth->($home_stash, $svref, @pkgattrs);
if (!@badattrs && @pkgattrs) {
require warnings;
return unless warnings::enabled('reserved');
@pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs;
if (@pkgattrs) {
for my $attr (@pkgattrs) {
$attr =~ s/\(.+\z//s;
}
my $s = ((@pkgattrs == 1) ? '' : 's');
carp "$svtype package attribute$s " .
"may clash with future reserved word$s: " .
join(' : ' , @pkgattrs);
}
}
}
else {
@badattrs = _modify_attrs_and_deprecate($svtype, $svref, @attrs);
}
if (@badattrs) {
croak "Invalid $svtype attribute" .
(( @badattrs == 1 ) ? '' : 's') .
": " .
join(' : ', @badattrs);
}
}
sub get ($) {
@_ == 1 && ref $_[0] or
croak 'Usage: '.__PACKAGE__.'::get $ref';
my $svref = shift;
my $svtype = uc reftype($svref);
my $stash = _guess_stash($svref);
$stash = caller unless defined $stash;
my $pkgmeth;
$pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES")
if defined $stash && $stash ne '';
return $pkgmeth ?
(_fetch_attrs($svref), $pkgmeth->($stash, $svref)) :
(_fetch_attrs($svref))
;
}
sub require_version { goto &UNIVERSAL::VERSION }
require XSLoader;
XSLoader::load();
1;
__END__
#The POD goes here

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

243
common/perl-base/base.pm Normal file
View File

@@ -0,0 +1,243 @@
use 5.008;
package base;
use strict 'vars';
use vars qw($VERSION);
$VERSION = '2.26';
$VERSION =~ tr/_//d;
# simplest way to avoid indexing of the package: no package statement
sub base::__inc::unhook { @INC = grep !(ref eq 'CODE' && $_ == $_[0]), @INC }
# instance is blessed array of coderefs to be removed from @INC at scope exit
sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} }
# constant.pm is slow
sub SUCCESS () { 1 }
sub PUBLIC () { 2**0 }
sub PRIVATE () { 2**1 }
sub INHERITED () { 2**2 }
sub PROTECTED () { 2**3 }
my $Fattr = \%fields::attr;
sub has_fields {
my($base) = shift;
my $fglob = ${"$base\::"}{FIELDS};
return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 );
}
sub has_attr {
my($proto) = shift;
my($class) = ref $proto || $proto;
return exists $Fattr->{$class};
}
sub get_attr {
$Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
return $Fattr->{$_[0]};
}
if ($] < 5.009) {
*get_fields = sub {
# Shut up a possible typo warning.
() = \%{$_[0].'::FIELDS'};
my $f = \%{$_[0].'::FIELDS'};
# should be centralized in fields? perhaps
# fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
# is used here anyway, it doesn't matter.
bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
return $f;
}
}
else {
*get_fields = sub {
# Shut up a possible typo warning.
() = \%{$_[0].'::FIELDS'};
return \%{$_[0].'::FIELDS'};
}
}
if ($] < 5.008) {
*_module_to_filename = sub {
(my $fn = $_[0]) =~ s!::!/!g;
$fn .= '.pm';
return $fn;
}
}
else {
*_module_to_filename = sub {
(my $fn = $_[0]) =~ s!::!/!g;
$fn .= '.pm';
utf8::encode($fn);
return $fn;
}
}
sub import {
my $class = shift;
return SUCCESS unless @_;
# List of base classes from which we will inherit %FIELDS.
my $fields_base;
my $inheritor = caller(0);
my @bases;
foreach my $base (@_) {
if ( $inheritor eq $base ) {
warn "Class '$inheritor' tried to inherit from itself\n";
}
next if grep $_->isa($base), ($inheritor, @bases);
# Following blocks help isolate $SIG{__DIE__} and @INC changes
{
my $sigdie;
{
local $SIG{__DIE__};
my $fn = _module_to_filename($base);
my $dot_hidden;
eval {
my $guard;
if ($INC[-1] eq '.' && %{"$base\::"}) {
# So: the package already exists => this an optional load
# And: there is a dot at the end of @INC => we want to hide it
# However: we only want to hide it during our *own* require()
# (i.e. without affecting nested require()s).
# So we add a hook to @INC whose job is to hide the dot, but which
# first checks checks the callstack depth, because within nested
# require()s the callstack is deeper.
# Since CORE::GLOBAL::require makes it unknowable in advance what
# the exact relevant callstack depth will be, we have to record it
# inside a hook. So we put another hook just for that at the front
# of @INC, where it's guaranteed to run -- immediately.
# The dot-hiding hook does its job by sitting directly in front of
# the dot and removing itself from @INC when reached. This causes
# the dot to move up one index in @INC, causing the loop inside
# pp_require() to skip it.
# Loaded coded may disturb this precise arrangement, but that's OK
# because the hook is inert by that time. It is only active during
# the top-level require(), when @INC is in our control. The only
# possible gotcha is if other hooks already in @INC modify @INC in
# some way during that initial require().
# Note that this jiggery hookery works just fine recursively: if
# a module loaded via base.pm uses base.pm itself, there will be
# one pair of hooks in @INC per base::import call frame, but the
# pairs from different nestings do not interfere with each other.
my $lvl;
unshift @INC, sub { return if defined $lvl; 1 while defined caller ++$lvl; () };
splice @INC, -1, 0, sub { return if defined caller $lvl; ++$dot_hidden, &base::__inc::unhook; () };
$guard = bless [ @INC[0,-2] ], 'base::__inc::scope_guard';
}
require $fn
};
if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) {
require Carp;
Carp::croak(<<ERROR);
Base class package "$base" is not empty but "$fn[0]" exists in the current directory.
To help avoid security issues, base.pm now refuses to load optional modules
from the current working directory when it is the last entry in \@INC.
If your software worked on previous versions of Perl, the best solution
is to use FindBin to detect the path properly and to add that path to
\@INC. As a last resort, you can re-enable looking in the current working
directory by adding "use lib '.'" to your code.
ERROR
}
# Only ignore "Can't locate" errors from our eval require.
# Other fatal errors (syntax etc) must be reported.
#
# changing the check here is fragile - if the check
# here isn't catching every error you want, you should
# probably be using parent.pm, which doesn't try to
# guess whether require is needed or failed,
# see [perl #118561]
die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s
|| $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/;
unless (%{"$base\::"}) {
require Carp;
local $" = " ";
Carp::croak(<<ERROR);
Base class package "$base" is empty.
(Perhaps you need to 'use' the module which defines that package first,
or make that module available in \@INC (\@INC contains: @INC).
ERROR
}
$sigdie = $SIG{__DIE__} || undef;
}
# Make sure a global $SIG{__DIE__} makes it out of the localization.
$SIG{__DIE__} = $sigdie if defined $sigdie;
}
push @bases, $base;
if ( has_fields($base) || has_attr($base) ) {
# No multiple fields inheritance *suck*
if ($fields_base) {
require Carp;
Carp::croak("Can't multiply inherit fields");
} else {
$fields_base = $base;
}
}
}
# Save this until the end so it's all or nothing if the above loop croaks.
push @{"$inheritor\::ISA"}, @bases;
if( defined $fields_base ) {
inherit_fields($inheritor, $fields_base);
}
}
sub inherit_fields {
my($derived, $base) = @_;
return SUCCESS unless $base;
my $battr = get_attr($base);
my $dattr = get_attr($derived);
my $dfields = get_fields($derived);
my $bfields = get_fields($base);
$dattr->[0] = @$battr;
if( keys %$dfields ) {
warn <<"END";
$derived is inheriting from $base but already has its own fields!
This will cause problems. Be sure you use base BEFORE declaring fields.
END
}
# Iterate through the base's fields adding all the non-private
# ones to the derived class. Hang on to the original attribute
# (Public, Private, etc...) and add Inherited.
# This is all too complicated to do efficiently with add_fields().
while (my($k,$v) = each %$bfields) {
my $fno;
if ($fno = $dfields->{$k} and $fno != $v) {
require Carp;
Carp::croak ("Inherited fields can't override existing fields");
}
if( $battr->[$v] & PRIVATE ) {
$dattr->[$v] = PRIVATE | INHERITED;
}
else {
$dattr->[$v] = INHERITED | $battr->[$v];
$dfields->{$k} = $v;
}
}
foreach my $idx (1..$#{$battr}) {
next if defined $dattr->[$idx];
$dattr->[$idx] = $battr->[$idx] & INHERITED;
}
}
1;
__END__

31
common/perl-base/bytes.pm Normal file
View File

@@ -0,0 +1,31 @@
package bytes;
our $VERSION = '1.05';
$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__

View File

@@ -0,0 +1,40 @@
package bytes;
sub length (_) {
BEGIN { bytes::import() }
return CORE::length($_[0]);
}
sub substr ($$;$$) {
BEGIN { bytes::import() }
return
@_ == 2 ? CORE::substr($_[0], $_[1]) :
@_ == 3 ? CORE::substr($_[0], $_[1], $_[2]) :
CORE::substr($_[0], $_[1], $_[2], $_[3]) ;
}
sub ord (_) {
BEGIN { bytes::import() }
return CORE::ord($_[0]);
}
sub chr (_) {
BEGIN { bytes::import() }
return CORE::chr($_[0]);
}
sub index ($$;$) {
BEGIN { bytes::import() }
return
@_ == 2 ? CORE::index($_[0], $_[1]) :
CORE::index($_[0], $_[1], $_[2]) ;
}
sub rindex ($$;$) {
BEGIN { bytes::import() }
return
@_ == 2 ? CORE::rindex($_[0], $_[1]) :
CORE::rindex($_[0], $_[1], $_[2]) ;
}
1;

View File

@@ -0,0 +1,205 @@
package constant;
use 5.008;
use strict;
use warnings::register;
our $VERSION = '1.33';
our %declared;
#=======================================================================
# Some names are evil choices.
my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
$keywords{UNITCHECK}++ if $] > 5.009;
my %forced_into_main = map +($_, 1),
qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
my %forbidden = (%keywords, %forced_into_main);
my $normal_constant_name = qr/^_?[^\W_0-9]\w*\z/;
my $tolerable = qr/^[A-Za-z_]\w*\z/;
my $boolean = qr/^[01]?\z/;
BEGIN {
# We'd like to do use constant _CAN_PCS => $] > 5.009002
# but that's a bit tricky before we load the constant module :-)
# By doing this, we save several run time checks for *every* call
# to import.
my $const = $] > 5.009002;
my $downgrade = $] < 5.015004; # && $] >= 5.008
my $constarray = exists &_make_const;
if ($const) {
Internals::SvREADONLY($const, 1);
Internals::SvREADONLY($downgrade, 1);
$constant::{_CAN_PCS} = \$const;
$constant::{_DOWNGRADE} = \$downgrade;
$constant::{_CAN_PCS_FOR_ARRAY} = \$constarray;
}
else {
no strict 'refs';
*{"_CAN_PCS"} = sub () {$const};
*{"_DOWNGRADE"} = sub () { $downgrade };
*{"_CAN_PCS_FOR_ARRAY"} = sub () { $constarray };
}
}
#=======================================================================
# import() - import symbols into user's namespace
#
# What we actually do is define a function in the caller's namespace
# which returns the value. The function we create will normally
# be inlined as a constant, thereby avoiding further sub calling
# overhead.
#=======================================================================
sub import {
my $class = shift;
return unless @_; # Ignore 'use constant;'
my $constants;
my $multiple = ref $_[0];
my $caller = caller;
my $flush_mro;
my $symtab;
if (_CAN_PCS) {
no strict 'refs';
$symtab = \%{$caller . '::'};
};
if ( $multiple ) {
if (ref $_[0] ne 'HASH') {
require Carp;
Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
}
$constants = shift;
} else {
unless (defined $_[0]) {
require Carp;
Carp::croak("Can't use undef as constant name");
}
$constants->{+shift} = undef;
}
foreach my $name ( keys %$constants ) {
my $pkg;
my $symtab = $symtab;
my $orig_name = $name;
if ($name =~ s/(.*)(?:::|')(?=.)//s) {
$pkg = $1;
if (_CAN_PCS && $pkg ne $caller) {
no strict 'refs';
$symtab = \%{$pkg . '::'};
}
}
else {
$pkg = $caller;
}
# Normal constant name
if ($name =~ $normal_constant_name and !$forbidden{$name}) {
# Everything is okay
# Name forced into main, but we're not in main. Fatal.
} elsif ($forced_into_main{$name} and $pkg ne 'main') {
require Carp;
Carp::croak("Constant name '$name' is forced into main::");
# Starts with double underscore. Fatal.
} elsif ($name =~ /^__/) {
require Carp;
Carp::croak("Constant name '$name' begins with '__'");
# Maybe the name is tolerable
} elsif ($name =~ $tolerable) {
# Then we'll warn only if you've asked for warnings
if (warnings::enabled()) {
if ($keywords{$name}) {
warnings::warn("Constant name '$name' is a Perl keyword");
} elsif ($forced_into_main{$name}) {
warnings::warn("Constant name '$name' is " .
"forced into package main::");
}
}
# Looks like a boolean
# use constant FRED == fred;
} elsif ($name =~ $boolean) {
require Carp;
if (@_) {
Carp::croak("Constant name '$name' is invalid");
} else {
Carp::croak("Constant name looks like boolean value");
}
} else {
# Must have bad characters
require Carp;
Carp::croak("Constant name '$name' has invalid characters");
}
{
no strict 'refs';
my $full_name = "${pkg}::$name";
$declared{$full_name}++;
if ($multiple || @_ == 1) {
my $scalar = $multiple ? $constants->{$orig_name} : $_[0];
if (_DOWNGRADE) { # for 5.8 to 5.14
# Work around perl bug #31991: Sub names (actually glob
# names in general) ignore the UTF8 flag. So we have to
# turn it off to get the "right" symbol table entry.
utf8::is_utf8 $name and utf8::encode $name;
}
# The constant serves to optimise this entire block out on
# 5.8 and earlier.
if (_CAN_PCS) {
# Use a reference as a proxy for a constant subroutine.
# If this is not a glob yet, it saves space. If it is
# a glob, we must still create it this way to get the
# right internal flags set, as constants are distinct
# from subroutines created with sub(){...}.
# The check in Perl_ck_rvconst knows that inlinable
# constants from cv_const_sv are read only. So we have to:
Internals::SvREADONLY($scalar, 1);
if (!exists $symtab->{$name}) {
$symtab->{$name} = \$scalar;
++$flush_mro->{$pkg};
}
else {
local $constant::{_dummy} = \$scalar;
*$full_name = \&{"_dummy"};
}
} else {
*$full_name = sub () { $scalar };
}
} elsif (@_) {
my @list = @_;
if (_CAN_PCS_FOR_ARRAY) {
_make_const($list[$_]) for 0..$#list;
_make_const(@list);
if (!exists $symtab->{$name}) {
$symtab->{$name} = \@list;
$flush_mro->{$pkg}++;
}
else {
local $constant::{_dummy} = \@list;
*$full_name = \&{"_dummy"};
}
}
else { *$full_name = sub () { @list }; }
} else {
*$full_name = sub () { };
}
}
}
# Flush the cache exactly once if we make any direct symbol table changes.
if (_CAN_PCS && $flush_mro) {
mro::method_changed_in($_) for keys %$flush_mro;
}
}
1;
__END__

152
common/perl-base/feature.pm Normal file
View File

@@ -0,0 +1,152 @@
# -*- buffer-read-only: t -*-
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is built by regen/feature.pl.
# Any changes made here will be lost!
package feature;
our $VERSION = '1.47';
our %feature = (
fc => 'feature_fc',
say => 'feature_say',
state => 'feature_state',
switch => 'feature_switch',
bitwise => 'feature_bitwise',
evalbytes => 'feature_evalbytes',
array_base => 'feature_arybase',
signatures => 'feature_signatures',
current_sub => 'feature___SUB__',
refaliasing => 'feature_refaliasing',
postderef_qq => 'feature_postderef_qq',
unicode_eval => 'feature_unieval',
declared_refs => 'feature_myref',
unicode_strings => 'feature_unicode',
);
our %feature_bundle = (
"5.10" => [qw(array_base say state switch)],
"5.11" => [qw(array_base say state switch unicode_strings)],
"5.15" => [qw(current_sub evalbytes fc say state switch unicode_eval unicode_strings)],
"5.23" => [qw(current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)],
"all" => [qw(array_base bitwise current_sub declared_refs evalbytes fc postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)],
"default" => [qw(array_base)],
);
$feature_bundle{"5.12"} = $feature_bundle{"5.11"};
$feature_bundle{"5.13"} = $feature_bundle{"5.11"};
$feature_bundle{"5.14"} = $feature_bundle{"5.11"};
$feature_bundle{"5.16"} = $feature_bundle{"5.15"};
$feature_bundle{"5.17"} = $feature_bundle{"5.15"};
$feature_bundle{"5.18"} = $feature_bundle{"5.15"};
$feature_bundle{"5.19"} = $feature_bundle{"5.15"};
$feature_bundle{"5.20"} = $feature_bundle{"5.15"};
$feature_bundle{"5.21"} = $feature_bundle{"5.15"};
$feature_bundle{"5.22"} = $feature_bundle{"5.15"};
$feature_bundle{"5.24"} = $feature_bundle{"5.23"};
$feature_bundle{"5.25"} = $feature_bundle{"5.23"};
$feature_bundle{"5.26"} = $feature_bundle{"5.23"};
$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
my %noops = (
postderef => 1,
lexical_subs => 1,
);
our $hint_shift = 26;
our $hint_mask = 0x1c000000;
our @hint_bundles = qw( default 5.10 5.11 5.15 5.23 );
# This gets set (for now) in $^H as well as in %^H,
# for runtime speed of the uc/lc/ucfirst/lcfirst functions.
# See HINT_UNI_8_BIT in perl.h.
our $hint_uni8bit = 0x00000800;
# TODO:
# - think about versioned features (use feature switch => 2)
sub import {
shift;
if (!@_) {
croak("No features specified");
}
__common(1, @_);
}
sub unimport {
shift;
# A bare C<no feature> should reset to the default bundle
if (!@_) {
$^H &= ~($hint_uni8bit|$hint_mask);
return;
}
__common(0, @_);
}
sub __common {
my $import = shift;
my $bundle_number = $^H & $hint_mask;
my $features = $bundle_number != $hint_mask
&& $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]};
if ($features) {
# Features are enabled implicitly via bundle hints.
# Delete any keys that may be left over from last time.
delete @^H{ values(%feature) };
$^H |= $hint_mask;
for (@$features) {
$^H{$feature{$_}} = 1;
$^H |= $hint_uni8bit if $_ eq 'unicode_strings';
}
}
while (@_) {
my $name = shift;
if (substr($name, 0, 1) eq ":") {
my $v = substr($name, 1);
if (!exists $feature_bundle{$v}) {
$v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
if (!exists $feature_bundle{$v}) {
unknown_feature_bundle(substr($name, 1));
}
}
unshift @_, @{$feature_bundle{$v}};
next;
}
if (!exists $feature{$name}) {
if (exists $noops{$name}) {
next;
}
unknown_feature($name);
}
if ($import) {
$^H{$feature{$name}} = 1;
$^H |= $hint_uni8bit if $name eq 'unicode_strings';
} else {
delete $^H{$feature{$name}};
$^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
}
}
}
sub unknown_feature {
my $feature = shift;
croak(sprintf('Feature "%s" is not supported by Perl %vd',
$feature, $^V));
}
sub unknown_feature_bundle {
my $feature = shift;
croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
$feature, $^V));
}
sub croak {
require Carp;
Carp::croak(@_);
}
1;
# ex: set ro:

179
common/perl-base/fields.pm Normal file
View File

@@ -0,0 +1,179 @@
use 5.008;
package fields;
require 5.005;
use strict;
no strict 'refs';
unless( eval q{require warnings::register; warnings::register->import; 1} ) {
*warnings::warnif = sub {
require Carp;
Carp::carp(@_);
}
}
use vars qw(%attr $VERSION);
$VERSION = '2.23';
$VERSION =~ tr/_//d;
# constant.pm is slow
sub PUBLIC () { 2**0 }
sub PRIVATE () { 2**1 }
sub INHERITED () { 2**2 }
sub PROTECTED () { 2**3 }
# The %attr hash holds the attributes of the currently assigned fields
# per class. The hash is indexed by class names and the hash value is
# an array reference. The first element in the array is the lowest field
# number not belonging to a base class. The remaining elements' indices
# are the field numbers. The values are integer bit masks, or undef
# in the case of base class private fields (which occupy a slot but are
# otherwise irrelevant to the class).
sub import {
my $class = shift;
return unless @_;
my $package = caller(0);
# avoid possible typo warnings
%{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
my $fields = \%{"$package\::FIELDS"};
my $fattr = ($attr{$package} ||= [1]);
my $next = @$fattr;
# Quiet pseudo-hash deprecation warning for uses of fields::new.
bless \%{"$package\::FIELDS"}, 'pseudohash';
if ($next > $fattr->[0]
and ($fields->{$_[0]} || 0) >= $fattr->[0])
{
# There are already fields not belonging to base classes.
# Looks like a possible module reload...
$next = $fattr->[0];
}
foreach my $f (@_) {
my $fno = $fields->{$f};
# Allow the module to be reloaded so long as field positions
# have not changed.
if ($fno and $fno != $next) {
require Carp;
if ($fno < $fattr->[0]) {
if ($] < 5.006001) {
warn("Hides field '$f' in base class") if $^W;
} else {
warnings::warnif("Hides field '$f' in base class") ;
}
} else {
Carp::croak("Field name '$f' already in use");
}
}
$fields->{$f} = $next;
$fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC;
$next += 1;
}
if (@$fattr > $next) {
# Well, we gave them the benefit of the doubt by guessing the
# module was reloaded, but they appear to be declaring fields
# in more than one place. We can't be sure (without some extra
# bookkeeping) that the rest of the fields will be declared or
# have the same positions, so punt.
require Carp;
Carp::croak ("Reloaded module must declare all fields at once");
}
}
sub inherit {
require base;
goto &base::inherit_fields;
}
sub _dump # sometimes useful for debugging
{
for my $pkg (sort keys %attr) {
print "\n$pkg";
if (@{"$pkg\::ISA"}) {
print " (", join(", ", @{"$pkg\::ISA"}), ")";
}
print "\n";
my $fields = \%{"$pkg\::FIELDS"};
for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
my $no = $fields->{$f};
print " $no: $f";
my $fattr = $attr{$pkg}[$no];
if (defined $fattr) {
my @a;
push(@a, "public") if $fattr & PUBLIC;
push(@a, "private") if $fattr & PRIVATE;
push(@a, "inherited") if $fattr & INHERITED;
print "\t(", join(", ", @a), ")";
}
print "\n";
}
}
}
if ($] < 5.009) {
*new = sub {
my $class = shift;
$class = ref $class if ref $class;
return bless [\%{$class . "::FIELDS"}], $class;
}
} else {
*new = sub {
my $class = shift;
$class = ref $class if ref $class;
require Hash::Util;
my $self = bless {}, $class;
# The lock_keys() prototype won't work since we require Hash::Util :(
&Hash::Util::lock_keys(\%$self, _accessible_keys($class));
return $self;
}
}
sub _accessible_keys {
my ($class) = @_;
return (
keys %{$class.'::FIELDS'},
map(_accessible_keys($_), @{$class.'::ISA'}),
);
}
sub phash {
die "Pseudo-hashes have been removed from Perl" if $] >= 5.009;
my $h;
my $v;
if (@_) {
if (ref $_[0] eq 'ARRAY') {
my $a = shift;
@$h{@$a} = 1 .. @$a;
if (@_) {
$v = shift;
unless (! @_ and ref $v eq 'ARRAY') {
require Carp;
Carp::croak ("Expected at most two array refs\n");
}
}
}
else {
if (@_ % 2) {
require Carp;
Carp::croak ("Odd number of elements initializing pseudo-hash\n");
}
my $i = 0;
@$h{grep ++$i % 2, @_} = 1 .. @_ / 2;
$i = 0;
$v = [grep $i++ % 2, @_];
}
}
else {
$h = {};
$v = [];
}
[ $h, @$v ];
}
1;
__END__

View File

@@ -0,0 +1,15 @@
package integer;
our $VERSION = '1.01';
$integer::hint_bits = 0x1;
sub import {
$^H |= $integer::hint_bits;
}
sub unimport {
$^H &= ~$integer::hint_bits;
}
1;

85
common/perl-base/lib.pm Normal file
View File

@@ -0,0 +1,85 @@
package lib;
# THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL.
# ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD.
use Config;
use strict;
my $archname = $Config{archname};
my $version = $Config{version};
my @inc_version_list = reverse split / /, $Config{inc_version_list};
our @ORIG_INC = @INC; # take a handy copy of 'original' value
our $VERSION = '0.64';
sub import {
shift;
my %names;
foreach (reverse @_) {
my $path = $_; # we'll be modifying it, so break the alias
if ($path eq '') {
require Carp;
Carp::carp("Empty compile time value given to use lib");
}
if ($path !~ /\.par$/i && -e $path && ! -d _) {
require Carp;
Carp::carp("Parameter to use lib must be directory, not file");
}
unshift(@INC, $path);
# Add any previous version directories we found at configure time
foreach my $incver (@inc_version_list)
{
my $dir = "$path/$incver";
unshift(@INC, $dir) if -d $dir;
}
# Put a corresponding archlib directory in front of $path if it
# looks like $path has an archlib directory below it.
my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
= _get_dirs($path);
unshift(@INC, $arch_dir) if -d $arch_auto_dir;
unshift(@INC, $version_dir) if -d $version_dir;
unshift(@INC, $version_arch_dir) if -d $version_arch_dir;
}
# remove trailing duplicates
@INC = grep { ++$names{$_} == 1 } @INC;
return;
}
sub unimport {
shift;
my %names;
foreach my $path (@_) {
my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
= _get_dirs($path);
++$names{$path};
++$names{$arch_dir} if -d $arch_auto_dir;
++$names{$version_dir} if -d $version_dir;
++$names{$version_arch_dir} if -d $version_arch_dir;
}
# Remove ALL instances of each named directory.
@INC = grep { !exists $names{$_} } @INC;
return;
}
sub _get_dirs {
my($dir) = @_;
my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
$arch_auto_dir = "$dir/$archname/auto";
$arch_dir = "$dir/$archname";
$version_dir = "$dir/$version";
$version_arch_dir = "$dir/$version/$archname";
return($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
}
1;
__END__

102
common/perl-base/locale.pm Normal file
View File

@@ -0,0 +1,102 @@
package locale;
our $VERSION = '1.09';
use Config;
$Carp::Internal{ (__PACKAGE__) } = 1;
# A separate bit is used for each of the two forms of the pragma, to save
# having to look at %^H for the normal case of a plain 'use locale' without an
# argument.
$locale::hint_bits = 0x4;
$locale::partial_hint_bits = 0x10; # If pragma has an argument
# The pseudo-category :characters consists of 2 real ones; but it also is
# given its own number, -1, because in the complement form it also has the
# side effect of "use feature 'unicode_strings'"
sub import {
shift; # should be 'locale'; not checked
$^H{locale} = 0 unless defined $^H{locale};
if (! @_) { # If no parameter, use the plain form that changes all categories
$^H |= $locale::hint_bits;
}
else {
my @categories = ( qw(:ctype :collate :messages
:numeric :monetary :time) );
for (my $i = 0; $i < @_; $i++) {
my $arg = $_[$i];
$complement = $arg =~ s/ : ( ! | not_ ) /:/x;
if (! grep { $arg eq $_ } @categories, ":characters") {
require Carp;
Carp::croak("Unknown parameter '$_[$i]' to 'use locale'");
}
if ($complement) {
if ($i != 0 || $i < @_ - 1) {
require Carp;
Carp::croak("Only one argument to 'use locale' allowed"
. "if is $complement");
}
if ($arg eq ':characters') {
push @_, grep { $_ ne ':ctype' && $_ ne ':collate' }
@categories;
# We add 1 to the category number; This category number
# is -1
$^H{locale} |= (1 << 0);
}
else {
push @_, grep { $_ ne $arg } @categories;
}
next;
}
elsif ($arg eq ':characters') {
push @_, ':ctype', ':collate';
next;
}
$^H |= $locale::partial_hint_bits;
# This form of the pragma overrides the other
$^H &= ~$locale::hint_bits;
$arg =~ s/^://;
eval { require POSIX; import POSIX 'locale_h'; };
# Map our names to the ones defined by POSIX
my $LC = "LC_" . uc($arg);
my $bit = eval "&POSIX::$LC";
if (defined $bit) { # XXX Should we warn that this category isn't
# supported on this platform, or make it
# always be the C locale?
# Verify our assumption.
if (! ($bit >= 0 && $bit < 31)) {
require Carp;
Carp::croak("Cannot have ':$arg' parameter to 'use locale'"
. " on this platform. Use the 'perlbug' utility"
. " to report this problem, or send email to"
. " 'perlbug\@perl.org'. $LC=$bit");
}
# 1 is added so that the pseudo-category :characters, which is
# -1, comes out 0.
$^H{locale} |= 1 << ($bit + 1);
}
}
}
}
sub unimport {
$^H &= ~($locale::hint_bits|$locale::partial_hint_bits);
$^H{locale} = 0;
}
1;

View File

@@ -0,0 +1,181 @@
package overload;
our $VERSION = '1.28';
%ops = (
with_assign => "+ - * / % ** << >> x .",
assign => "+= -= *= /= %= **= <<= >>= x= .=",
num_comparison => "< <= > >= == !=",
'3way_comparison' => "<=> cmp",
str_comparison => "lt le gt ge eq ne",
binary => '& &= | |= ^ ^= &. &.= |. |.= ^. ^.=',
unary => "neg ! ~ ~.",
mutators => '++ --',
func => "atan2 cos sin exp abs log sqrt int",
conversion => 'bool "" 0+ qr',
iterators => '<>',
filetest => "-X",
dereferencing => '${} @{} %{} &{} *{}',
matching => '~~',
special => 'nomethod fallback =',
);
my %ops_seen;
@ops_seen{ map split(/ /), values %ops } = ();
sub nil {}
sub OVERLOAD {
$package = shift;
my %arg = @_;
my $sub;
*{$package . "::(("} = \&nil; # Make it findable via fetchmethod.
for (keys %arg) {
if ($_ eq 'fallback') {
for my $sym (*{$package . "::()"}) {
*$sym = \&nil; # Make it findable via fetchmethod.
$$sym = $arg{$_};
}
} else {
warnings::warnif("overload arg '$_' is invalid")
unless exists $ops_seen{$_};
$sub = $arg{$_};
if (not ref $sub) {
$ {$package . "::(" . $_} = $sub;
$sub = \&nil;
}
#print STDERR "Setting '$ {'package'}::\cO$_' to \\&'$sub'.\n";
*{$package . "::(" . $_} = \&{ $sub };
}
}
}
sub import {
$package = (caller())[0];
# *{$package . "::OVERLOAD"} = \&OVERLOAD;
shift;
$package->overload::OVERLOAD(@_);
}
sub unimport {
$package = (caller())[0];
shift;
*{$package . "::(("} = \&nil;
for (@_) {
warnings::warnif("overload arg '$_' is invalid")
unless exists $ops_seen{$_};
delete $ {$package . "::"}{$_ eq 'fallback' ? '()' : "(" .$_};
}
}
sub Overloaded {
my $package = shift;
$package = ref $package if ref $package;
mycan ($package, '()') || mycan ($package, '((');
}
sub ov_method {
my $globref = shift;
return undef unless $globref;
my $sub = \&{*$globref};
no overloading;
return $sub if $sub != \&nil;
return shift->can($ {*$globref});
}
sub OverloadedStringify {
my $package = shift;
$package = ref $package if ref $package;
#$package->can('(""')
ov_method mycan($package, '(""'), $package
or ov_method mycan($package, '(0+'), $package
or ov_method mycan($package, '(bool'), $package
or ov_method mycan($package, '(nomethod'), $package;
}
sub Method {
my $package = shift;
if(ref $package) {
local $@;
local $!;
require Scalar::Util;
$package = Scalar::Util::blessed($package);
return undef if !defined $package;
}
#my $meth = $package->can('(' . shift);
ov_method mycan($package, '(' . shift), $package;
#return $meth if $meth ne \&nil;
#return $ {*{$meth}};
}
sub AddrRef {
no overloading;
"$_[0]";
}
*StrVal = *AddrRef;
sub mycan { # Real can would leave stubs.
my ($package, $meth) = @_;
local $@;
local $!;
require mro;
my $mro = mro::get_linear_isa($package);
foreach my $p (@$mro) {
my $fqmeth = $p . q{::} . $meth;
return \*{$fqmeth} if defined &{$fqmeth};
}
return undef;
}
%constants = (
'integer' => 0x1000, # HINT_NEW_INTEGER
'float' => 0x2000, # HINT_NEW_FLOAT
'binary' => 0x4000, # HINT_NEW_BINARY
'q' => 0x8000, # HINT_NEW_STRING
'qr' => 0x10000, # HINT_NEW_RE
);
use warnings::register;
sub constant {
# Arguments: what, sub
while (@_) {
if (@_ == 1) {
warnings::warnif ("Odd number of arguments for overload::constant");
last;
}
elsif (!exists $constants {$_ [0]}) {
warnings::warnif ("'$_[0]' is not an overloadable type");
}
elsif (!ref $_ [1] || "$_[1]" !~ /(^|=)CODE\(0x[0-9a-f]+\)$/) {
# Can't use C<ref $_[1] eq "CODE"> above as code references can be
# blessed, and C<ref> would return the package the ref is blessed into.
if (warnings::enabled) {
$_ [1] = "undef" unless defined $_ [1];
warnings::warn ("'$_[1]' is not a code reference");
}
}
else {
$^H{$_[0]} = $_[1];
$^H |= $constants{$_[0]};
}
shift, shift;
}
}
sub remove_constant {
# Arguments: what, sub
while (@_) {
delete $^H{$_[0]};
$^H &= ~ $constants{$_[0]};
shift, shift;
}
}
1;
__END__

View File

@@ -0,0 +1,53 @@
package overloading;
use warnings;
our $VERSION = '0.02';
my $HINT_NO_AMAGIC = 0x01000000; # see perl.h
require 5.010001;
sub _ops_to_nums {
require overload::numbers;
map { exists $overload::numbers::names{"($_"}
? $overload::numbers::names{"($_"}
: do { require Carp; Carp::croak("'$_' is not a valid overload") }
} @_;
}
sub import {
my ( $class, @ops ) = @_;
if ( @ops ) {
if ( $^H{overloading} ) {
vec($^H{overloading} , $_, 1) = 0 for _ops_to_nums(@ops);
}
if ( $^H{overloading} !~ /[^\0]/ ) {
delete $^H{overloading};
$^H &= ~$HINT_NO_AMAGIC;
}
} else {
delete $^H{overloading};
$^H &= ~$HINT_NO_AMAGIC;
}
}
sub unimport {
my ( $class, @ops ) = @_;
if ( exists $^H{overloading} or not $^H & $HINT_NO_AMAGIC ) {
if ( @ops ) {
vec($^H{overloading} ||= '', $_, 1) = 1 for _ops_to_nums(@ops);
} else {
delete $^H{overloading};
}
}
$^H |= $HINT_NO_AMAGIC;
}
1;
__END__

View File

@@ -0,0 +1,29 @@
package parent;
use strict;
use vars qw($VERSION);
$VERSION = '0.236';
sub import {
my $class = shift;
my $inheritor = caller(0);
if ( @_ and $_[0] eq '-norequire' ) {
shift @_;
} else {
for ( my @filename = @_ ) {
s{::|'}{/}g;
require "$_.pm"; # dies if the file is not found
}
}
{
no strict 'refs';
push @{"$inheritor\::ISA"}, @_; # dies if a loop is detected
};
};
1;
__END__

287
common/perl-base/re.pm Normal file
View File

@@ -0,0 +1,287 @@
package re;
# pragma for controlling the regexp engine
use strict;
use warnings;
our $VERSION = "0.34";
our @ISA = qw(Exporter);
our @EXPORT_OK = ('regmust',
qw(is_regexp regexp_pattern
regname regnames regnames_count));
our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
my %bitmask = (
taint => 0x00100000, # HINT_RE_TAINT
eval => 0x00200000, # HINT_RE_EVAL
);
my $flags_hint = 0x02000000; # HINT_RE_FLAGS
my $PMMOD_SHIFT = 0;
my %reflags = (
m => 1 << ($PMMOD_SHIFT + 0),
s => 1 << ($PMMOD_SHIFT + 1),
i => 1 << ($PMMOD_SHIFT + 2),
x => 1 << ($PMMOD_SHIFT + 3),
xx => 1 << ($PMMOD_SHIFT + 4),
n => 1 << ($PMMOD_SHIFT + 5),
p => 1 << ($PMMOD_SHIFT + 6),
strict => 1 << ($PMMOD_SHIFT + 10),
# special cases:
d => 0,
l => 1,
u => 2,
a => 3,
aa => 4,
);
sub setcolor {
eval { # Ignore errors
require Term::Cap;
my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
my @props = split /,/, $props;
my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
$colors =~ s/\0//g;
$ENV{PERL_RE_COLORS} = $colors;
};
if ($@) {
$ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t';
}
}
my %flags = (
COMPILE => 0x0000FF,
PARSE => 0x000001,
OPTIMISE => 0x000002,
TRIEC => 0x000004,
DUMP => 0x000008,
FLAGS => 0x000010,
TEST => 0x000020,
EXECUTE => 0x00FF00,
INTUIT => 0x000100,
MATCH => 0x000200,
TRIEE => 0x000400,
EXTRA => 0xFF0000,
TRIEM => 0x010000,
OFFSETS => 0x020000,
OFFSETSDBG => 0x040000,
STATE => 0x080000,
OPTIMISEM => 0x100000,
STACK => 0x280000,
BUFFERS => 0x400000,
GPOS => 0x800000,
);
$flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS});
$flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
$flags{Extra} = $flags{EXECUTE} | $flags{COMPILE} | $flags{GPOS};
$flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE};
$flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE};
$flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};
if (defined &DynaLoader::boot_DynaLoader) {
require XSLoader;
XSLoader::load();
}
# else we're miniperl
# We need to work for miniperl, because the XS toolchain uses Text::Wrap, which
# uses re 'taint'.
sub _load_unload {
my ($on)= @_;
if ($on) {
# We call install() every time, as if we didn't, we wouldn't
# "see" any changes to the color environment var since
# the last time it was called.
# install() returns an integer, which if casted properly
# in C resolves to a structure containing the regexp
# hooks. Setting it to a random integer will guarantee
# segfaults.
$^H{regcomp} = install();
} else {
delete $^H{regcomp};
}
}
sub bits {
my $on = shift;
my $bits = 0;
my $turning_all_off = ! @_ && ! $on;
if ($turning_all_off) {
# Pretend were called with certain parameters, which are best dealt
# with that way.
push @_, keys %bitmask; # taint and eval
push @_, 'strict';
}
# Process each subpragma parameter
ARG:
foreach my $idx (0..$#_){
my $s=$_[$idx];
if ($s eq 'Debug' or $s eq 'Debugcolor') {
setcolor() if $s =~/color/i;
${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS};
for my $idx ($idx+1..$#_) {
if ($flags{$_[$idx]}) {
if ($on) {
${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]};
} else {
${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]};
}
} else {
require Carp;
Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ",
join(", ",sort keys %flags ) );
}
}
_load_unload($on ? 1 : ${^RE_DEBUG_FLAGS});
last;
} elsif ($s eq 'debug' or $s eq 'debugcolor') {
setcolor() if $s =~/color/i;
_load_unload($on);
last;
} elsif (exists $bitmask{$s}) {
$bits |= $bitmask{$s};
} elsif ($EXPORT_OK{$s}) {
require Exporter;
re->export_to_level(2, 're', $s);
} elsif ($s eq 'strict') {
if ($on) {
$^H{reflags} |= $reflags{$s};
warnings::warnif('experimental::re_strict',
"\"use re 'strict'\" is experimental");
# Turn on warnings if not already done.
if (! warnings::enabled('regexp')) {
require warnings;
warnings->import('regexp');
$^H{re_strict} = 1;
}
}
else {
$^H{reflags} &= ~$reflags{$s} if $^H{reflags};
# Turn off warnings if we turned them on.
warnings->unimport('regexp') if $^H{re_strict};
}
if ($^H{reflags}) {
$^H |= $flags_hint;
}
else {
$^H &= ~$flags_hint;
}
} elsif ($s =~ s/^\///) {
my $reflags = $^H{reflags} || 0;
my $seen_charset;
my $x_count = 0;
while ($s =~ m/( . )/gx) {
local $_ = $1;
if (/[adul]/) {
# The 'a' may be repeated; hide this from the rest of the
# code by counting and getting rid of all of them, then
# changing to 'aa' if there is a repeat.
if ($_ eq 'a') {
my $sav_pos = pos $s;
my $a_count = $s =~ s/a//g;
pos $s = $sav_pos - 1; # -1 because got rid of the 'a'
if ($a_count > 2) {
require Carp;
Carp::carp(
qq 'The "a" flag may only appear a maximum of twice'
);
}
elsif ($a_count == 2) {
$_ = 'aa';
}
}
if ($on) {
if ($seen_charset) {
require Carp;
if ($seen_charset ne $_) {
Carp::carp(
qq 'The "$seen_charset" and "$_" flags '
.qq 'are exclusive'
);
}
else {
Carp::carp(
qq 'The "$seen_charset" flag may not appear '
.qq 'twice'
);
}
}
$^H{reflags_charset} = $reflags{$_};
$seen_charset = $_;
}
else {
delete $^H{reflags_charset}
if defined $^H{reflags_charset}
&& $^H{reflags_charset} == $reflags{$_};
}
} elsif (exists $reflags{$_}) {
if ($_ eq 'x') {
$x_count++;
if ($x_count > 2) {
require Carp;
Carp::carp(
qq 'The "x" flag may only appear a maximum of twice'
);
}
elsif ($x_count == 2) {
$_ = 'xx'; # First time through got the /x
}
}
$on
? $reflags |= $reflags{$_}
: ($reflags &= ~$reflags{$_});
} else {
require Carp;
Carp::carp(
qq'Unknown regular expression flag "$_"'
);
next ARG;
}
}
($^H{reflags} = $reflags or defined $^H{reflags_charset})
? $^H |= $flags_hint
: ($^H &= ~$flags_hint);
} else {
require Carp;
Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask),
")");
}
}
if ($turning_all_off) {
_load_unload(0);
$^H{reflags} = 0;
$^H{reflags_charset} = 0;
$^H &= ~$flags_hint;
}
$bits;
}
sub import {
shift;
$^H |= bits(1, @_);
}
sub unimport {
shift;
$^H &= ~ bits(0, @_);
}
1;
__END__

184
common/perl-base/strict.pm Normal file
View File

@@ -0,0 +1,184 @@
package strict;
$strict::VERSION = "1.11";
my ( %bitmask, %explicit_bitmask );
BEGIN {
# Verify that we're called correctly so that strictures will work.
# Can't use Carp, since Carp uses us!
# see also warnings.pm.
die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2]
if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' )
&& __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' );
%bitmask = (
refs => 0x00000002,
subs => 0x00000200,
vars => 0x00000400,
);
%explicit_bitmask = (
refs => 0x00000020,
subs => 0x00000040,
vars => 0x00000080,
);
my $bits = 0;
$bits |= $_ for values %bitmask;
my $inline_all_bits = $bits;
*all_bits = sub () { $inline_all_bits };
$bits = 0;
$bits |= $_ for values %explicit_bitmask;
my $inline_all_explicit_bits = $bits;
*all_explicit_bits = sub () { $inline_all_explicit_bits };
}
sub bits {
my $bits = 0;
my @wrong;
foreach my $s (@_) {
if (exists $bitmask{$s}) {
$^H |= $explicit_bitmask{$s};
$bits |= $bitmask{$s};
}
else {
push @wrong, $s;
}
}
if (@wrong) {
require Carp;
Carp::croak("Unknown 'strict' tag(s) '@wrong'");
}
$bits;
}
sub import {
shift;
$^H |= @_ ? &bits : all_bits | all_explicit_bits;
}
sub unimport {
shift;
if (@_) {
$^H &= ~&bits;
}
else {
$^H &= ~all_bits;
$^H |= all_explicit_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
The C<strict> pragma disables certain Perl expressions that could behave
unexpectedly or are difficult to debug, turning them into errors. The
effect of this pragma is limited to the current file or scope block.
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 was
neither explicitly declared (using any of C<my>, C<our>, C<state>, or C<use
vars>) nor fully qualified. (Because this is to avoid variable suicide
problems and subtle dynamic scoping issues, a merely C<local> variable isn't
good enough.) See L<perlfunc/my>, L<perlfunc/our>, L<perlfunc/state>,
L<perlfunc/local>, and L<vars>.
use strict 'vars';
$X::foo = 1; # ok, fully qualified
my $foo = 10; # ok, my() var
local $baz = 9; # blows up, $baz not declared before
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"; # 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) '...'
As of version 1.04 (Perl 5.10), strict verifies that it is used as
"strict" to avoid the dreaded Strict trap on case insensitive file
systems.
=cut

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,648 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToBc'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToBc'}{'missing'} = 'L';
return <<'END';
0 8 BN
9 S
A B
B S
C WS
D B
E 1B BN
1C 1E B
1F S
20 WS
21 22 ON
23 25 ET
26 2A ON
2B ES
2C CS
2D ES
2E 2F CS
30 39 EN
3A CS
3B 40 ON
5B 60 ON
7B 7E ON
7F 84 BN
85 B
86 9F BN
A0 CS
A1 ON
A2 A5 ET
A6 A9 ON
AB AC ON
AD BN
AE AF ON
B0 B1 ET
B2 B3 EN
B4 ON
B6 B8 ON
B9 EN
BB BF ON
D7 ON
F7 ON
2B9 2BA ON
2C2 2CF ON
2D2 2DF ON
2E5 2ED ON
2EF 2FF ON
300 36F NSM
374 375 ON
37E ON
384 385 ON
387 ON
3F6 ON
483 489 NSM
58A ON
58D 58E ON
58F ET
590 R
591 5BD NSM
5BE R
5BF NSM
5C0 R
5C1 5C2 NSM
5C3 R
5C4 5C5 NSM
5C6 R
5C7 NSM
5C8 5FF R
600 605 AN
606 607 ON
608 AL
609 60A ET
60B AL
60C CS
60D AL
60E 60F ON
610 61A NSM
61B 64A AL
64B 65F NSM
660 669 AN
66A ET
66B 66C AN
66D 66F AL
670 NSM
671 6D5 AL
6D6 6DC NSM
6DD AN
6DE ON
6DF 6E4 NSM
6E5 6E6 AL
6E7 6E8 NSM
6E9 ON
6EA 6ED NSM
6EE 6EF AL
6F0 6F9 EN
6FA 710 AL
711 NSM
712 72F AL
730 74A NSM
74B 7A5 AL
7A6 7B0 NSM
7B1 7BF AL
7C0 7EA R
7EB 7F3 NSM
7F4 7F5 R
7F6 7F9 ON
7FA 815 R
816 819 NSM
81A R
81B 823 NSM
824 R
825 827 NSM
828 R
829 82D NSM
82E 858 R
859 85B NSM
85C 89F R
8A0 8D3 AL
8D4 8E1 NSM
8E2 AN
8E3 902 NSM
93A NSM
93C NSM
941 948 NSM
94D NSM
951 957 NSM
962 963 NSM
981 NSM
9BC NSM
9C1 9C4 NSM
9CD NSM
9E2 9E3 NSM
9F2 9F3 ET
9FB ET
A01 A02 NSM
A3C NSM
A41 A42 NSM
A47 A48 NSM
A4B A4D NSM
A51 NSM
A70 A71 NSM
A75 NSM
A81 A82 NSM
ABC NSM
AC1 AC5 NSM
AC7 AC8 NSM
ACD NSM
AE2 AE3 NSM
AF1 ET
B01 NSM
B3C NSM
B3F NSM
B41 B44 NSM
B4D NSM
B56 NSM
B62 B63 NSM
B82 NSM
BC0 NSM
BCD NSM
BF3 BF8 ON
BF9 ET
BFA ON
C00 NSM
C3E C40 NSM
C46 C48 NSM
C4A C4D NSM
C55 C56 NSM
C62 C63 NSM
C78 C7E ON
C81 NSM
CBC NSM
CCC CCD NSM
CE2 CE3 NSM
D01 NSM
D41 D44 NSM
D4D NSM
D62 D63 NSM
DCA NSM
DD2 DD4 NSM
DD6 NSM
E31 NSM
E34 E3A NSM
E3F ET
E47 E4E NSM
EB1 NSM
EB4 EB9 NSM
EBB EBC NSM
EC8 ECD NSM
F18 F19 NSM
F35 NSM
F37 NSM
F39 NSM
F3A F3D ON
F71 F7E NSM
F80 F84 NSM
F86 F87 NSM
F8D F97 NSM
F99 FBC NSM
FC6 NSM
102D 1030 NSM
1032 1037 NSM
1039 103A NSM
103D 103E NSM
1058 1059 NSM
105E 1060 NSM
1071 1074 NSM
1082 NSM
1085 1086 NSM
108D NSM
109D NSM
135D 135F NSM
1390 1399 ON
1400 ON
1680 WS
169B 169C ON
1712 1714 NSM
1732 1734 NSM
1752 1753 NSM
1772 1773 NSM
17B4 17B5 NSM
17B7 17BD NSM
17C6 NSM
17C9 17D3 NSM
17DB ET
17DD NSM
17F0 17F9 ON
1800 180A ON
180B 180D NSM
180E BN
1885 1886 NSM
18A9 NSM
1920 1922 NSM
1927 1928 NSM
1932 NSM
1939 193B NSM
1940 ON
1944 1945 ON
19DE 19FF ON
1A17 1A18 NSM
1A1B NSM
1A56 NSM
1A58 1A5E NSM
1A60 NSM
1A62 NSM
1A65 1A6C NSM
1A73 1A7C NSM
1A7F NSM
1AB0 1ABE NSM
1B00 1B03 NSM
1B34 NSM
1B36 1B3A NSM
1B3C NSM
1B42 NSM
1B6B 1B73 NSM
1B80 1B81 NSM
1BA2 1BA5 NSM
1BA8 1BA9 NSM
1BAB 1BAD NSM
1BE6 NSM
1BE8 1BE9 NSM
1BED NSM
1BEF 1BF1 NSM
1C2C 1C33 NSM
1C36 1C37 NSM
1CD0 1CD2 NSM
1CD4 1CE0 NSM
1CE2 1CE8 NSM
1CED NSM
1CF4 NSM
1CF8 1CF9 NSM
1DC0 1DF5 NSM
1DFB 1DFF NSM
1FBD ON
1FBF 1FC1 ON
1FCD 1FCF ON
1FDD 1FDF ON
1FED 1FEF ON
1FFD 1FFE ON
2000 200A WS
200B 200D BN
200F R
2010 2027 ON
2028 WS
2029 B
202A LRE
202B RLE
202C PDF
202D LRO
202E RLO
202F CS
2030 2034 ET
2035 2043 ON
2044 CS
2045 205E ON
205F WS
2060 2065 BN
2066 LRI
2067 RLI
2068 FSI
2069 PDI
206A 206F BN
2070 EN
2074 2079 EN
207A 207B ES
207C 207E ON
2080 2089 EN
208A 208B ES
208C 208E ON
20A0 20CF ET
20D0 20F0 NSM
2100 2101 ON
2103 2106 ON
2108 2109 ON
2114 ON
2116 2118 ON
211E 2123 ON
2125 ON
2127 ON
2129 ON
212E ET
213A 213B ON
2140 2144 ON
214A 214D ON
2150 215F ON
2189 218B ON
2190 2211 ON
2212 ES
2213 ET
2214 2335 ON
237B 2394 ON
2396 23FE ON
2400 2426 ON
2440 244A ON
2460 2487 ON
2488 249B EN
24EA 26AB ON
26AD 27FF ON
2900 2B73 ON
2B76 2B95 ON
2B98 2BB9 ON
2BBD 2BC8 ON
2BCA 2BD1 ON
2BEC 2BEF ON
2CE5 2CEA ON
2CEF 2CF1 NSM
2CF9 2CFF ON
2D7F NSM
2DE0 2DFF NSM
2E00 2E44 ON
2E80 2E99 ON
2E9B 2EF3 ON
2F00 2FD5 ON
2FF0 2FFB ON
3000 WS
3001 3004 ON
3008 3020 ON
302A 302D NSM
3030 ON
3036 3037 ON
303D 303F ON
3099 309A NSM
309B 309C ON
30A0 ON
30FB ON
31C0 31E3 ON
321D 321E ON
3250 325F ON
327C 327E ON
32B1 32BF ON
32CC 32CF ON
3377 337A ON
33DE 33DF ON
33FF ON
4DC0 4DFF ON
A490 A4C6 ON
A60D A60F ON
A66F A672 NSM
A673 ON
A674 A67D NSM
A67E A67F ON
A69E A69F NSM
A6F0 A6F1 NSM
A700 A721 ON
A788 ON
A802 NSM
A806 NSM
A80B NSM
A825 A826 NSM
A828 A82B ON
A838 A839 ET
A874 A877 ON
A8C4 A8C5 NSM
A8E0 A8F1 NSM
A926 A92D NSM
A947 A951 NSM
A980 A982 NSM
A9B3 NSM
A9B6 A9B9 NSM
A9BC NSM
A9E5 NSM
AA29 AA2E NSM
AA31 AA32 NSM
AA35 AA36 NSM
AA43 NSM
AA4C NSM
AA7C NSM
AAB0 NSM
AAB2 AAB4 NSM
AAB7 AAB8 NSM
AABE AABF NSM
AAC1 NSM
AAEC AAED NSM
AAF6 NSM
ABE5 NSM
ABE8 NSM
ABED NSM
FB1D R
FB1E NSM
FB1F FB28 R
FB29 ES
FB2A FB4F R
FB50 FD3D AL
FD3E FD3F ON
FD40 FDCF AL
FDD0 FDEF BN
FDF0 FDFC AL
FDFD ON
FDFE FDFF AL
FE00 FE0F NSM
FE10 FE19 ON
FE20 FE2F NSM
FE30 FE4F ON
FE50 CS
FE51 ON
FE52 CS
FE54 ON
FE55 CS
FE56 FE5E ON
FE5F ET
FE60 FE61 ON
FE62 FE63 ES
FE64 FE66 ON
FE68 ON
FE69 FE6A ET
FE6B ON
FE70 FEFE AL
FEFF BN
FF01 FF02 ON
FF03 FF05 ET
FF06 FF0A ON
FF0B ES
FF0C CS
FF0D ES
FF0E FF0F CS
FF10 FF19 EN
FF1A CS
FF1B FF20 ON
FF3B FF40 ON
FF5B FF65 ON
FFE0 FFE1 ET
FFE2 FFE4 ON
FFE5 FFE6 ET
FFE8 FFEE ON
FFF0 FFF8 BN
FFF9 FFFD ON
FFFE FFFF BN
10101 ON
10140 1018C ON
10190 1019B ON
101A0 ON
101FD NSM
102E0 NSM
102E1 102FB EN
10376 1037A NSM
10800 1091E R
1091F ON
10920 10A00 R
10A01 10A03 NSM
10A04 R
10A05 10A06 NSM
10A07 10A0B R
10A0C 10A0F NSM
10A10 10A37 R
10A38 10A3A NSM
10A3B 10A3E R
10A3F NSM
10A40 10AE4 R
10AE5 10AE6 NSM
10AE7 10B38 R
10B39 10B3F ON
10B40 10E5F R
10E60 10E7E AN
10E7F 10FFF R
11001 NSM
11038 11046 NSM
11052 11065 ON
1107F 11081 NSM
110B3 110B6 NSM
110B9 110BA NSM
11100 11102 NSM
11127 1112B NSM
1112D 11134 NSM
11173 NSM
11180 11181 NSM
111B6 111BE NSM
111CA 111CC NSM
1122F 11231 NSM
11234 NSM
11236 11237 NSM
1123E NSM
112DF NSM
112E3 112EA NSM
11300 11301 NSM
1133C NSM
11340 NSM
11366 1136C NSM
11370 11374 NSM
11438 1143F NSM
11442 11444 NSM
11446 NSM
114B3 114B8 NSM
114BA NSM
114BF 114C0 NSM
114C2 114C3 NSM
115B2 115B5 NSM
115BC 115BD NSM
115BF 115C0 NSM
115DC 115DD NSM
11633 1163A NSM
1163D NSM
1163F 11640 NSM
11660 1166C ON
116AB NSM
116AD NSM
116B0 116B5 NSM
116B7 NSM
1171D 1171F NSM
11722 11725 NSM
11727 1172B NSM
11C30 11C36 NSM
11C38 11C3D NSM
11C92 11CA7 NSM
11CAA 11CB0 NSM
11CB2 11CB3 NSM
11CB5 11CB6 NSM
16AF0 16AF4 NSM
16B30 16B36 NSM
16F8F 16F92 NSM
1BC9D 1BC9E NSM
1BCA0 1BCA3 BN
1D167 1D169 NSM
1D173 1D17A BN
1D17B 1D182 NSM
1D185 1D18B NSM
1D1AA 1D1AD NSM
1D200 1D241 ON
1D242 1D244 NSM
1D245 ON
1D300 1D356 ON
1D6DB ON
1D715 ON
1D74F ON
1D789 ON
1D7C3 ON
1D7CE 1D7FF EN
1DA00 1DA36 NSM
1DA3B 1DA6C NSM
1DA75 NSM
1DA84 NSM
1DA9B 1DA9F NSM
1DAA1 1DAAF NSM
1E000 1E006 NSM
1E008 1E018 NSM
1E01B 1E021 NSM
1E023 1E024 NSM
1E026 1E02A NSM
1E800 1E8CF R
1E8D0 1E8D6 NSM
1E8D7 1E943 R
1E944 1E94A NSM
1E94B 1EDFF R
1EE00 1EEEF AL
1EEF0 1EEF1 ON
1EEF2 1EEFF AL
1EF00 1EFFF R
1F000 1F02B ON
1F030 1F093 ON
1F0A0 1F0AE ON
1F0B1 1F0BF ON
1F0C1 1F0CF ON
1F0D1 1F0F5 ON
1F100 1F10A EN
1F10B 1F10C ON
1F16A 1F16B ON
1F300 1F6D2 ON
1F6E0 1F6EC ON
1F6F0 1F6F6 ON
1F700 1F773 ON
1F780 1F7D4 ON
1F800 1F80B ON
1F810 1F847 ON
1F850 1F859 ON
1F860 1F887 ON
1F890 1F8AD ON
1F910 1F91E ON
1F920 1F927 ON
1F930 ON
1F933 1F93E ON
1F940 1F94B ON
1F950 1F95E ON
1F980 1F991 ON
1F9C0 ON
1FFFE 1FFFF BN
2FFFE 2FFFF BN
3FFFE 3FFFF BN
4FFFE 4FFFF BN
5FFFE 5FFFF BN
6FFFE 6FFFF BN
7FFFE 7FFFF BN
8FFFE 8FFFF BN
9FFFE 9FFFF BN
AFFFE AFFFF BN
BFFFE BFFFF BN
CFFFE CFFFF BN
DFFFE E00FF BN
E0100 E01EF NSM
E01F0 E0FFF BN
EFFFE EFFFF BN
FFFFE FFFFF BN
10FFFE 10FFFF BN
END

View File

@@ -0,0 +1,388 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! IT IS DEPRECATED TO USE THIS FILE !!!!!!!
# This file is for internal use by core Perl only. It is retained for
# backwards compatibility with applications that may have come to rely on it,
# but its format and even its name or existence are subject to change without
# notice in a future Perl version. Don't use it directly. Instead, its
# contents are now retrievable through a stable API in the Unicode::UCD
# module: Unicode::UCD::prop_invmap('Bidi_Mirroring_Glyph') (Values for individual
# code points can be retrieved via Unicode::UCD::charprop());
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToBmg'}{'format'} = 'x'; # non-negative hex whole number; a code point
$utf8::SwashInfo{'ToBmg'}{'missing'} = ''; # code point maps to the null string
return <<'END';
0028 0029
0029 0028
003C 003E
003E 003C
005B 005D
005D 005B
007B 007D
007D 007B
00AB 00BB
00BB 00AB
0F3A 0F3B
0F3B 0F3A
0F3C 0F3D
0F3D 0F3C
169B 169C
169C 169B
2039 203A
203A 2039
2045 2046
2046 2045
207D 207E
207E 207D
208D 208E
208E 208D
2208 220B
2209 220C
220A 220D
220B 2208
220C 2209
220D 220A
2215 29F5
223C 223D
223D 223C
2243 22CD
2252 2253
2253 2252
2254 2255
2255 2254
2264 2265
2265 2264
2266 2267
2267 2266
2268 2269
2269 2268
226A 226B
226B 226A
226E 226F
226F 226E
2270 2271
2271 2270
2272 2273
2273 2272
2274 2275
2275 2274
2276 2277
2277 2276
2278 2279
2279 2278
227A 227B
227B 227A
227C 227D
227D 227C
227E 227F
227F 227E
2280 2281
2281 2280
2282 2283
2283 2282
2284 2285
2285 2284
2286 2287
2287 2286
2288 2289
2289 2288
228A 228B
228B 228A
228F 2290
2290 228F
2291 2292
2292 2291
2298 29B8
22A2 22A3
22A3 22A2
22A6 2ADE
22A8 2AE4
22A9 2AE3
22AB 2AE5
22B0 22B1
22B1 22B0
22B2 22B3
22B3 22B2
22B4 22B5
22B5 22B4
22B6 22B7
22B7 22B6
22C9 22CA
22CA 22C9
22CB 22CC
22CC 22CB
22CD 2243
22D0 22D1
22D1 22D0
22D6 22D7
22D7 22D6
22D8 22D9
22D9 22D8
22DA 22DB
22DB 22DA
22DC 22DD
22DD 22DC
22DE 22DF
22DF 22DE
22E0 22E1
22E1 22E0
22E2 22E3
22E3 22E2
22E4 22E5
22E5 22E4
22E6 22E7
22E7 22E6
22E8 22E9
22E9 22E8
22EA 22EB
22EB 22EA
22EC 22ED
22ED 22EC
22F0 22F1
22F1 22F0
22F2 22FA
22F3 22FB
22F4 22FC
22F6 22FD
22F7 22FE
22FA 22F2
22FB 22F3
22FC 22F4
22FD 22F6
22FE 22F7
2308 2309
2309 2308
230A 230B
230B 230A
2329 232A
232A 2329
2768 2769
2769 2768
276A 276B
276B 276A
276C 276D
276D 276C
276E 276F
276F 276E
2770 2771
2771 2770
2772 2773
2773 2772
2774 2775
2775 2774
27C3 27C4
27C4 27C3
27C5 27C6
27C6 27C5
27C8 27C9
27C9 27C8
27CB 27CD
27CD 27CB
27D5 27D6
27D6 27D5
27DD 27DE
27DE 27DD
27E2 27E3
27E3 27E2
27E4 27E5
27E5 27E4
27E6 27E7
27E7 27E6
27E8 27E9
27E9 27E8
27EA 27EB
27EB 27EA
27EC 27ED
27ED 27EC
27EE 27EF
27EF 27EE
2983 2984
2984 2983
2985 2986
2986 2985
2987 2988
2988 2987
2989 298A
298A 2989
298B 298C
298C 298B
298D 2990
298E 298F
298F 298E
2990 298D
2991 2992
2992 2991
2993 2994
2994 2993
2995 2996
2996 2995
2997 2998
2998 2997
29B8 2298
29C0 29C1
29C1 29C0
29C4 29C5
29C5 29C4
29CF 29D0
29D0 29CF
29D1 29D2
29D2 29D1
29D4 29D5
29D5 29D4
29D8 29D9
29D9 29D8
29DA 29DB
29DB 29DA
29F5 2215
29F8 29F9
29F9 29F8
29FC 29FD
29FD 29FC
2A2B 2A2C
2A2C 2A2B
2A2D 2A2E
2A2E 2A2D
2A34 2A35
2A35 2A34
2A3C 2A3D
2A3D 2A3C
2A64 2A65
2A65 2A64
2A79 2A7A
2A7A 2A79
2A7D 2A7E
2A7E 2A7D
2A7F 2A80
2A80 2A7F
2A81 2A82
2A82 2A81
2A83 2A84
2A84 2A83
2A8B 2A8C
2A8C 2A8B
2A91 2A92
2A92 2A91
2A93 2A94
2A94 2A93
2A95 2A96
2A96 2A95
2A97 2A98
2A98 2A97
2A99 2A9A
2A9A 2A99
2A9B 2A9C
2A9C 2A9B
2AA1 2AA2
2AA2 2AA1
2AA6 2AA7
2AA7 2AA6
2AA8 2AA9
2AA9 2AA8
2AAA 2AAB
2AAB 2AAA
2AAC 2AAD
2AAD 2AAC
2AAF 2AB0
2AB0 2AAF
2AB3 2AB4
2AB4 2AB3
2ABB 2ABC
2ABC 2ABB
2ABD 2ABE
2ABE 2ABD
2ABF 2AC0
2AC0 2ABF
2AC1 2AC2
2AC2 2AC1
2AC3 2AC4
2AC4 2AC3
2AC5 2AC6
2AC6 2AC5
2ACD 2ACE
2ACE 2ACD
2ACF 2AD0
2AD0 2ACF
2AD1 2AD2
2AD2 2AD1
2AD3 2AD4
2AD4 2AD3
2AD5 2AD6
2AD6 2AD5
2ADE 22A6
2AE3 22A9
2AE4 22A8
2AE5 22AB
2AEC 2AED
2AED 2AEC
2AF7 2AF8
2AF8 2AF7
2AF9 2AFA
2AFA 2AF9
2E02 2E03
2E03 2E02
2E04 2E05
2E05 2E04
2E09 2E0A
2E0A 2E09
2E0C 2E0D
2E0D 2E0C
2E1C 2E1D
2E1D 2E1C
2E20 2E21
2E21 2E20
2E22 2E23
2E23 2E22
2E24 2E25
2E25 2E24
2E26 2E27
2E27 2E26
2E28 2E29
2E29 2E28
3008 3009
3009 3008
300A 300B
300B 300A
300C 300D
300D 300C
300E 300F
300F 300E
3010 3011
3011 3010
3014 3015
3015 3014
3016 3017
3017 3016
3018 3019
3019 3018
301A 301B
301B 301A
FE59 FE5A
FE5A FE59
FE5B FE5C
FE5C FE5B
FE5D FE5E
FE5E FE5D
FE64 FE65
FE65 FE64
FF08 FF09
FF09 FF08
FF1C FF1E
FF1E FF1C
FF3B FF3D
FF3D FF3B
FF5B FF5D
FF5D FF5B
FF5F FF60
FF60 FF5F
FF62 FF63
FF63 FF62
END

View File

@@ -0,0 +1,140 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToBpb'}{'format'} = 'x'; # non-negative hex whole number; a code point
$utf8::SwashInfo{'ToBpb'}{'missing'} = ''; # code point maps to the null string
return <<'END';
28 0029
29 0028
5B 005D
5D 005B
7B 007D
7D 007B
F3A 0F3B
F3B 0F3A
F3C 0F3D
F3D 0F3C
169B 169C
169C 169B
2045 2046
2046 2045
207D 207E
207E 207D
208D 208E
208E 208D
2308 2309
2309 2308
230A 230B
230B 230A
2329 232A
232A 2329
2768 2769
2769 2768
276A 276B
276B 276A
276C 276D
276D 276C
276E 276F
276F 276E
2770 2771
2771 2770
2772 2773
2773 2772
2774 2775
2775 2774
27C5 27C6
27C6 27C5
27E6 27E7
27E7 27E6
27E8 27E9
27E9 27E8
27EA 27EB
27EB 27EA
27EC 27ED
27ED 27EC
27EE 27EF
27EF 27EE
2983 2984
2984 2983
2985 2986
2986 2985
2987 2988
2988 2987
2989 298A
298A 2989
298B 298C
298C 298B
298D 2990
298E 298F
298F 298E
2990 298D
2991 2992
2992 2991
2993 2994
2994 2993
2995 2996
2996 2995
2997 2998
2998 2997
29D8 29D9
29D9 29D8
29DA 29DB
29DB 29DA
29FC 29FD
29FD 29FC
2E22 2E23
2E23 2E22
2E24 2E25
2E25 2E24
2E26 2E27
2E27 2E26
2E28 2E29
2E29 2E28
3008 3009
3009 3008
300A 300B
300B 300A
300C 300D
300D 300C
300E 300F
300F 300E
3010 3011
3011 3010
3014 3015
3015 3014
3016 3017
3017 3016
3018 3019
3019 3018
301A 301B
301B 301A
FE59 FE5A
FE5A FE59
FE5B FE5C
FE5C FE5B
FE5D FE5E
FE5E FE5D
FF08 FF09
FF09 FF08
FF3B FF3D
FF3D FF3B
FF5B FF5D
FF5D FF5B
FF5F FF60
FF60 FF5F
FF62 FF63
FF63 FF62
END

View File

@@ -0,0 +1,140 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToBpt'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToBpt'}{'missing'} = 'n';
return <<'END';
28 o
29 c
5B o
5D c
7B o
7D c
F3A o
F3B c
F3C o
F3D c
169B o
169C c
2045 o
2046 c
207D o
207E c
208D o
208E c
2308 o
2309 c
230A o
230B c
2329 o
232A c
2768 o
2769 c
276A o
276B c
276C o
276D c
276E o
276F c
2770 o
2771 c
2772 o
2773 c
2774 o
2775 c
27C5 o
27C6 c
27E6 o
27E7 c
27E8 o
27E9 c
27EA o
27EB c
27EC o
27ED c
27EE o
27EF c
2983 o
2984 c
2985 o
2986 c
2987 o
2988 c
2989 o
298A c
298B o
298C c
298D o
298E c
298F o
2990 c
2991 o
2992 c
2993 o
2994 c
2995 o
2996 c
2997 o
2998 c
29D8 o
29D9 c
29DA o
29DB c
29FC o
29FD c
2E22 o
2E23 c
2E24 o
2E25 c
2E26 o
2E27 c
2E28 o
2E29 c
3008 o
3009 c
300A o
300B c
300C o
300D c
300E o
300F c
3010 o
3011 c
3014 o
3015 c
3016 o
3017 c
3018 o
3019 c
301A o
301B c
FE59 o
FE5A c
FE5B o
FE5C c
FE5D o
FE5E c
FF08 o
FF09 c
FF3B o
FF3D c
FF5B o
FF5D c
FF5F o
FF60 c
FF62 o
FF63 c
END

View File

@@ -0,0 +1,804 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The mappings in the non-hash portion of this file must be modified to get the
# correct values by adding the code point ordinal number to each one that is
# numeric.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToCf'}{'format'} = 'ax'; # mapped value in hex; some entries need adjustment
$utf8::SwashInfo{'ToCf'}{'specials_name'} = 'utf8::ToSpecCf'; # Name of hash of special mappings
$utf8::SwashInfo{'ToCf'}{'missing'} = '0'; # code point maps to itself
# Some code points require special handling because their mappings are each to
# multiple code points. These do not appear in the main body, but are defined
# in the hash below.
# Each key is the string of N bytes that together make up the UTF-8 encoding
# for the code point. (i.e. the same as looking at the code point's UTF-8
# under "use bytes"). Each value is the UTF-8 of the translation, for speed.
%utf8::ToSpecCf = (
"\xC3\x9F" => "\x{0073}\x{0073}", # U+00DF => 0073 0073
"\xC4\xB0" => "\x{0069}\x{0307}", # U+0130 => 0069 0307
"\xC5\x89" => "\x{02BC}\x{006E}", # U+0149 => 02BC 006E
"\xC7\xB0" => "\x{006A}\x{030C}", # U+01F0 => 006A 030C
"\xCE\x90" => "\x{03B9}\x{0308}\x{0301}", # U+0390 => 03B9 0308 0301
"\xCE\xB0" => "\x{03C5}\x{0308}\x{0301}", # U+03B0 => 03C5 0308 0301
"\xD6\x87" => "\x{0565}\x{0582}", # U+0587 => 0565 0582
"\xE1\xBA\x96" => "\x{0068}\x{0331}", # U+1E96 => 0068 0331
"\xE1\xBA\x97" => "\x{0074}\x{0308}", # U+1E97 => 0074 0308
"\xE1\xBA\x98" => "\x{0077}\x{030A}", # U+1E98 => 0077 030A
"\xE1\xBA\x99" => "\x{0079}\x{030A}", # U+1E99 => 0079 030A
"\xE1\xBA\x9A" => "\x{0061}\x{02BE}", # U+1E9A => 0061 02BE
"\xE1\xBA\x9E" => "\x{0073}\x{0073}", # U+1E9E => 0073 0073
"\xE1\xBD\x90" => "\x{03C5}\x{0313}", # U+1F50 => 03C5 0313
"\xE1\xBD\x92" => "\x{03C5}\x{0313}\x{0300}", # U+1F52 => 03C5 0313 0300
"\xE1\xBD\x94" => "\x{03C5}\x{0313}\x{0301}", # U+1F54 => 03C5 0313 0301
"\xE1\xBD\x96" => "\x{03C5}\x{0313}\x{0342}", # U+1F56 => 03C5 0313 0342
"\xE1\xBE\x80" => "\x{1F00}\x{03B9}", # U+1F80 => 1F00 03B9
"\xE1\xBE\x81" => "\x{1F01}\x{03B9}", # U+1F81 => 1F01 03B9
"\xE1\xBE\x82" => "\x{1F02}\x{03B9}", # U+1F82 => 1F02 03B9
"\xE1\xBE\x83" => "\x{1F03}\x{03B9}", # U+1F83 => 1F03 03B9
"\xE1\xBE\x84" => "\x{1F04}\x{03B9}", # U+1F84 => 1F04 03B9
"\xE1\xBE\x85" => "\x{1F05}\x{03B9}", # U+1F85 => 1F05 03B9
"\xE1\xBE\x86" => "\x{1F06}\x{03B9}", # U+1F86 => 1F06 03B9
"\xE1\xBE\x87" => "\x{1F07}\x{03B9}", # U+1F87 => 1F07 03B9
"\xE1\xBE\x88" => "\x{1F00}\x{03B9}", # U+1F88 => 1F00 03B9
"\xE1\xBE\x89" => "\x{1F01}\x{03B9}", # U+1F89 => 1F01 03B9
"\xE1\xBE\x8A" => "\x{1F02}\x{03B9}", # U+1F8A => 1F02 03B9
"\xE1\xBE\x8B" => "\x{1F03}\x{03B9}", # U+1F8B => 1F03 03B9
"\xE1\xBE\x8C" => "\x{1F04}\x{03B9}", # U+1F8C => 1F04 03B9
"\xE1\xBE\x8D" => "\x{1F05}\x{03B9}", # U+1F8D => 1F05 03B9
"\xE1\xBE\x8E" => "\x{1F06}\x{03B9}", # U+1F8E => 1F06 03B9
"\xE1\xBE\x8F" => "\x{1F07}\x{03B9}", # U+1F8F => 1F07 03B9
"\xE1\xBE\x90" => "\x{1F20}\x{03B9}", # U+1F90 => 1F20 03B9
"\xE1\xBE\x91" => "\x{1F21}\x{03B9}", # U+1F91 => 1F21 03B9
"\xE1\xBE\x92" => "\x{1F22}\x{03B9}", # U+1F92 => 1F22 03B9
"\xE1\xBE\x93" => "\x{1F23}\x{03B9}", # U+1F93 => 1F23 03B9
"\xE1\xBE\x94" => "\x{1F24}\x{03B9}", # U+1F94 => 1F24 03B9
"\xE1\xBE\x95" => "\x{1F25}\x{03B9}", # U+1F95 => 1F25 03B9
"\xE1\xBE\x96" => "\x{1F26}\x{03B9}", # U+1F96 => 1F26 03B9
"\xE1\xBE\x97" => "\x{1F27}\x{03B9}", # U+1F97 => 1F27 03B9
"\xE1\xBE\x98" => "\x{1F20}\x{03B9}", # U+1F98 => 1F20 03B9
"\xE1\xBE\x99" => "\x{1F21}\x{03B9}", # U+1F99 => 1F21 03B9
"\xE1\xBE\x9A" => "\x{1F22}\x{03B9}", # U+1F9A => 1F22 03B9
"\xE1\xBE\x9B" => "\x{1F23}\x{03B9}", # U+1F9B => 1F23 03B9
"\xE1\xBE\x9C" => "\x{1F24}\x{03B9}", # U+1F9C => 1F24 03B9
"\xE1\xBE\x9D" => "\x{1F25}\x{03B9}", # U+1F9D => 1F25 03B9
"\xE1\xBE\x9E" => "\x{1F26}\x{03B9}", # U+1F9E => 1F26 03B9
"\xE1\xBE\x9F" => "\x{1F27}\x{03B9}", # U+1F9F => 1F27 03B9
"\xE1\xBE\xA0" => "\x{1F60}\x{03B9}", # U+1FA0 => 1F60 03B9
"\xE1\xBE\xA1" => "\x{1F61}\x{03B9}", # U+1FA1 => 1F61 03B9
"\xE1\xBE\xA2" => "\x{1F62}\x{03B9}", # U+1FA2 => 1F62 03B9
"\xE1\xBE\xA3" => "\x{1F63}\x{03B9}", # U+1FA3 => 1F63 03B9
"\xE1\xBE\xA4" => "\x{1F64}\x{03B9}", # U+1FA4 => 1F64 03B9
"\xE1\xBE\xA5" => "\x{1F65}\x{03B9}", # U+1FA5 => 1F65 03B9
"\xE1\xBE\xA6" => "\x{1F66}\x{03B9}", # U+1FA6 => 1F66 03B9
"\xE1\xBE\xA7" => "\x{1F67}\x{03B9}", # U+1FA7 => 1F67 03B9
"\xE1\xBE\xA8" => "\x{1F60}\x{03B9}", # U+1FA8 => 1F60 03B9
"\xE1\xBE\xA9" => "\x{1F61}\x{03B9}", # U+1FA9 => 1F61 03B9
"\xE1\xBE\xAA" => "\x{1F62}\x{03B9}", # U+1FAA => 1F62 03B9
"\xE1\xBE\xAB" => "\x{1F63}\x{03B9}", # U+1FAB => 1F63 03B9
"\xE1\xBE\xAC" => "\x{1F64}\x{03B9}", # U+1FAC => 1F64 03B9
"\xE1\xBE\xAD" => "\x{1F65}\x{03B9}", # U+1FAD => 1F65 03B9
"\xE1\xBE\xAE" => "\x{1F66}\x{03B9}", # U+1FAE => 1F66 03B9
"\xE1\xBE\xAF" => "\x{1F67}\x{03B9}", # U+1FAF => 1F67 03B9
"\xE1\xBE\xB2" => "\x{1F70}\x{03B9}", # U+1FB2 => 1F70 03B9
"\xE1\xBE\xB3" => "\x{03B1}\x{03B9}", # U+1FB3 => 03B1 03B9
"\xE1\xBE\xB4" => "\x{03AC}\x{03B9}", # U+1FB4 => 03AC 03B9
"\xE1\xBE\xB6" => "\x{03B1}\x{0342}", # U+1FB6 => 03B1 0342
"\xE1\xBE\xB7" => "\x{03B1}\x{0342}\x{03B9}", # U+1FB7 => 03B1 0342 03B9
"\xE1\xBE\xBC" => "\x{03B1}\x{03B9}", # U+1FBC => 03B1 03B9
"\xE1\xBF\x82" => "\x{1F74}\x{03B9}", # U+1FC2 => 1F74 03B9
"\xE1\xBF\x83" => "\x{03B7}\x{03B9}", # U+1FC3 => 03B7 03B9
"\xE1\xBF\x84" => "\x{03AE}\x{03B9}", # U+1FC4 => 03AE 03B9
"\xE1\xBF\x86" => "\x{03B7}\x{0342}", # U+1FC6 => 03B7 0342
"\xE1\xBF\x87" => "\x{03B7}\x{0342}\x{03B9}", # U+1FC7 => 03B7 0342 03B9
"\xE1\xBF\x8C" => "\x{03B7}\x{03B9}", # U+1FCC => 03B7 03B9
"\xE1\xBF\x92" => "\x{03B9}\x{0308}\x{0300}", # U+1FD2 => 03B9 0308 0300
"\xE1\xBF\x93" => "\x{03B9}\x{0308}\x{0301}", # U+1FD3 => 03B9 0308 0301
"\xE1\xBF\x96" => "\x{03B9}\x{0342}", # U+1FD6 => 03B9 0342
"\xE1\xBF\x97" => "\x{03B9}\x{0308}\x{0342}", # U+1FD7 => 03B9 0308 0342
"\xE1\xBF\xA2" => "\x{03C5}\x{0308}\x{0300}", # U+1FE2 => 03C5 0308 0300
"\xE1\xBF\xA3" => "\x{03C5}\x{0308}\x{0301}", # U+1FE3 => 03C5 0308 0301
"\xE1\xBF\xA4" => "\x{03C1}\x{0313}", # U+1FE4 => 03C1 0313
"\xE1\xBF\xA6" => "\x{03C5}\x{0342}", # U+1FE6 => 03C5 0342
"\xE1\xBF\xA7" => "\x{03C5}\x{0308}\x{0342}", # U+1FE7 => 03C5 0308 0342
"\xE1\xBF\xB2" => "\x{1F7C}\x{03B9}", # U+1FF2 => 1F7C 03B9
"\xE1\xBF\xB3" => "\x{03C9}\x{03B9}", # U+1FF3 => 03C9 03B9
"\xE1\xBF\xB4" => "\x{03CE}\x{03B9}", # U+1FF4 => 03CE 03B9
"\xE1\xBF\xB6" => "\x{03C9}\x{0342}", # U+1FF6 => 03C9 0342
"\xE1\xBF\xB7" => "\x{03C9}\x{0342}\x{03B9}", # U+1FF7 => 03C9 0342 03B9
"\xE1\xBF\xBC" => "\x{03C9}\x{03B9}", # U+1FFC => 03C9 03B9
"\xEF\xAC\x80" => "\x{0066}\x{0066}", # U+FB00 => 0066 0066
"\xEF\xAC\x81" => "\x{0066}\x{0069}", # U+FB01 => 0066 0069
"\xEF\xAC\x82" => "\x{0066}\x{006C}", # U+FB02 => 0066 006C
"\xEF\xAC\x83" => "\x{0066}\x{0066}\x{0069}", # U+FB03 => 0066 0066 0069
"\xEF\xAC\x84" => "\x{0066}\x{0066}\x{006C}", # U+FB04 => 0066 0066 006C
"\xEF\xAC\x85" => "\x{0073}\x{0074}", # U+FB05 => 0073 0074
"\xEF\xAC\x86" => "\x{0073}\x{0074}", # U+FB06 => 0073 0074
"\xEF\xAC\x93" => "\x{0574}\x{0576}", # U+FB13 => 0574 0576
"\xEF\xAC\x94" => "\x{0574}\x{0565}", # U+FB14 => 0574 0565
"\xEF\xAC\x95" => "\x{0574}\x{056B}", # U+FB15 => 0574 056B
"\xEF\xAC\x96" => "\x{057E}\x{0576}", # U+FB16 => 057E 0576
"\xEF\xAC\x97" => "\x{0574}\x{056D}", # U+FB17 => 0574 056D
);
return <<'END';
41 5A 61
B5 3BC
C0 D6 E0
D8 DE F8
100 101
102 103
104 105
106 107
108 109
10A 10B
10C 10D
10E 10F
110 111
112 113
114 115
116 117
118 119
11A 11B
11C 11D
11E 11F
120 121
122 123
124 125
126 127
128 129
12A 12B
12C 12D
12E 12F
132 133
134 135
136 137
139 13A
13B 13C
13D 13E
13F 140
141 142
143 144
145 146
147 148
14A 14B
14C 14D
14E 14F
150 151
152 153
154 155
156 157
158 159
15A 15B
15C 15D
15E 15F
160 161
162 163
164 165
166 167
168 169
16A 16B
16C 16D
16E 16F
170 171
172 173
174 175
176 177
178 FF
179 17A
17B 17C
17D 17E
17F 73
181 253
182 183
184 185
186 254
187 188
189 18A 256
18B 18C
18E 1DD
18F 259
190 25B
191 192
193 260
194 263
196 269
197 268
198 199
19C 26F
19D 272
19F 275
1A0 1A1
1A2 1A3
1A4 1A5
1A6 280
1A7 1A8
1A9 283
1AC 1AD
1AE 288
1AF 1B0
1B1 1B2 28A
1B3 1B4
1B5 1B6
1B7 292
1B8 1B9
1BC 1BD
1C4 1C6
1C5 1C6
1C7 1C9
1C8 1C9
1CA 1CC
1CB 1CC
1CD 1CE
1CF 1D0
1D1 1D2
1D3 1D4
1D5 1D6
1D7 1D8
1D9 1DA
1DB 1DC
1DE 1DF
1E0 1E1
1E2 1E3
1E4 1E5
1E6 1E7
1E8 1E9
1EA 1EB
1EC 1ED
1EE 1EF
1F1 1F3
1F2 1F3
1F4 1F5
1F6 195
1F7 1BF
1F8 1F9
1FA 1FB
1FC 1FD
1FE 1FF
200 201
202 203
204 205
206 207
208 209
20A 20B
20C 20D
20E 20F
210 211
212 213
214 215
216 217
218 219
21A 21B
21C 21D
21E 21F
220 19E
222 223
224 225
226 227
228 229
22A 22B
22C 22D
22E 22F
230 231
232 233
23A 2C65
23B 23C
23D 19A
23E 2C66
241 242
243 180
244 289
245 28C
246 247
248 249
24A 24B
24C 24D
24E 24F
345 3B9
370 371
372 373
376 377
37F 3F3
386 3AC
388 38A 3AD
38C 3CC
38E 38F 3CD
391 3A1 3B1
3A3 3AB 3C3
3C2 3C3
3CF 3D7
3D0 3B2
3D1 3B8
3D5 3C6
3D6 3C0
3D8 3D9
3DA 3DB
3DC 3DD
3DE 3DF
3E0 3E1
3E2 3E3
3E4 3E5
3E6 3E7
3E8 3E9
3EA 3EB
3EC 3ED
3EE 3EF
3F0 3BA
3F1 3C1
3F4 3B8
3F5 3B5
3F7 3F8
3F9 3F2
3FA 3FB
3FD 3FF 37B
400 40F 450
410 42F 430
460 461
462 463
464 465
466 467
468 469
46A 46B
46C 46D
46E 46F
470 471
472 473
474 475
476 477
478 479
47A 47B
47C 47D
47E 47F
480 481
48A 48B
48C 48D
48E 48F
490 491
492 493
494 495
496 497
498 499
49A 49B
49C 49D
49E 49F
4A0 4A1
4A2 4A3
4A4 4A5
4A6 4A7
4A8 4A9
4AA 4AB
4AC 4AD
4AE 4AF
4B0 4B1
4B2 4B3
4B4 4B5
4B6 4B7
4B8 4B9
4BA 4BB
4BC 4BD
4BE 4BF
4C0 4CF
4C1 4C2
4C3 4C4
4C5 4C6
4C7 4C8
4C9 4CA
4CB 4CC
4CD 4CE
4D0 4D1
4D2 4D3
4D4 4D5
4D6 4D7
4D8 4D9
4DA 4DB
4DC 4DD
4DE 4DF
4E0 4E1
4E2 4E3
4E4 4E5
4E6 4E7
4E8 4E9
4EA 4EB
4EC 4ED
4EE 4EF
4F0 4F1
4F2 4F3
4F4 4F5
4F6 4F7
4F8 4F9
4FA 4FB
4FC 4FD
4FE 4FF
500 501
502 503
504 505
506 507
508 509
50A 50B
50C 50D
50E 50F
510 511
512 513
514 515
516 517
518 519
51A 51B
51C 51D
51E 51F
520 521
522 523
524 525
526 527
528 529
52A 52B
52C 52D
52E 52F
531 556 561
10A0 10C5 2D00
10C7 2D27
10CD 2D2D
13F8 13FD 13F0
1C80 432
1C81 434
1C82 43E
1C83 1C84 441
1C85 442
1C86 44A
1C87 463
1C88 A64B
1E00 1E01
1E02 1E03
1E04 1E05
1E06 1E07
1E08 1E09
1E0A 1E0B
1E0C 1E0D
1E0E 1E0F
1E10 1E11
1E12 1E13
1E14 1E15
1E16 1E17
1E18 1E19
1E1A 1E1B
1E1C 1E1D
1E1E 1E1F
1E20 1E21
1E22 1E23
1E24 1E25
1E26 1E27
1E28 1E29
1E2A 1E2B
1E2C 1E2D
1E2E 1E2F
1E30 1E31
1E32 1E33
1E34 1E35
1E36 1E37
1E38 1E39
1E3A 1E3B
1E3C 1E3D
1E3E 1E3F
1E40 1E41
1E42 1E43
1E44 1E45
1E46 1E47
1E48 1E49
1E4A 1E4B
1E4C 1E4D
1E4E 1E4F
1E50 1E51
1E52 1E53
1E54 1E55
1E56 1E57
1E58 1E59
1E5A 1E5B
1E5C 1E5D
1E5E 1E5F
1E60 1E61
1E62 1E63
1E64 1E65
1E66 1E67
1E68 1E69
1E6A 1E6B
1E6C 1E6D
1E6E 1E6F
1E70 1E71
1E72 1E73
1E74 1E75
1E76 1E77
1E78 1E79
1E7A 1E7B
1E7C 1E7D
1E7E 1E7F
1E80 1E81
1E82 1E83
1E84 1E85
1E86 1E87
1E88 1E89
1E8A 1E8B
1E8C 1E8D
1E8E 1E8F
1E90 1E91
1E92 1E93
1E94 1E95
1E9B 1E61
1E9E DF
1EA0 1EA1
1EA2 1EA3
1EA4 1EA5
1EA6 1EA7
1EA8 1EA9
1EAA 1EAB
1EAC 1EAD
1EAE 1EAF
1EB0 1EB1
1EB2 1EB3
1EB4 1EB5
1EB6 1EB7
1EB8 1EB9
1EBA 1EBB
1EBC 1EBD
1EBE 1EBF
1EC0 1EC1
1EC2 1EC3
1EC4 1EC5
1EC6 1EC7
1EC8 1EC9
1ECA 1ECB
1ECC 1ECD
1ECE 1ECF
1ED0 1ED1
1ED2 1ED3
1ED4 1ED5
1ED6 1ED7
1ED8 1ED9
1EDA 1EDB
1EDC 1EDD
1EDE 1EDF
1EE0 1EE1
1EE2 1EE3
1EE4 1EE5
1EE6 1EE7
1EE8 1EE9
1EEA 1EEB
1EEC 1EED
1EEE 1EEF
1EF0 1EF1
1EF2 1EF3
1EF4 1EF5
1EF6 1EF7
1EF8 1EF9
1EFA 1EFB
1EFC 1EFD
1EFE 1EFF
1F08 1F0F 1F00
1F18 1F1D 1F10
1F28 1F2F 1F20
1F38 1F3F 1F30
1F48 1F4D 1F40
1F59 1F51
1F5B 1F53
1F5D 1F55
1F5F 1F57
1F68 1F6F 1F60
1F88 1F8F 1F80
1F98 1F9F 1F90
1FA8 1FAF 1FA0
1FB8 1FB9 1FB0
1FBA 1FBB 1F70
1FBC 1FB3
1FBE 3B9
1FC8 1FCB 1F72
1FCC 1FC3
1FD8 1FD9 1FD0
1FDA 1FDB 1F76
1FE8 1FE9 1FE0
1FEA 1FEB 1F7A
1FEC 1FE5
1FF8 1FF9 1F78
1FFA 1FFB 1F7C
1FFC 1FF3
2126 3C9
212A 6B
212B E5
2132 214E
2160 216F 2170
2183 2184
24B6 24CF 24D0
2C00 2C2E 2C30
2C60 2C61
2C62 26B
2C63 1D7D
2C64 27D
2C67 2C68
2C69 2C6A
2C6B 2C6C
2C6D 251
2C6E 271
2C6F 250
2C70 252
2C72 2C73
2C75 2C76
2C7E 2C7F 23F
2C80 2C81
2C82 2C83
2C84 2C85
2C86 2C87
2C88 2C89
2C8A 2C8B
2C8C 2C8D
2C8E 2C8F
2C90 2C91
2C92 2C93
2C94 2C95
2C96 2C97
2C98 2C99
2C9A 2C9B
2C9C 2C9D
2C9E 2C9F
2CA0 2CA1
2CA2 2CA3
2CA4 2CA5
2CA6 2CA7
2CA8 2CA9
2CAA 2CAB
2CAC 2CAD
2CAE 2CAF
2CB0 2CB1
2CB2 2CB3
2CB4 2CB5
2CB6 2CB7
2CB8 2CB9
2CBA 2CBB
2CBC 2CBD
2CBE 2CBF
2CC0 2CC1
2CC2 2CC3
2CC4 2CC5
2CC6 2CC7
2CC8 2CC9
2CCA 2CCB
2CCC 2CCD
2CCE 2CCF
2CD0 2CD1
2CD2 2CD3
2CD4 2CD5
2CD6 2CD7
2CD8 2CD9
2CDA 2CDB
2CDC 2CDD
2CDE 2CDF
2CE0 2CE1
2CE2 2CE3
2CEB 2CEC
2CED 2CEE
2CF2 2CF3
A640 A641
A642 A643
A644 A645
A646 A647
A648 A649
A64A A64B
A64C A64D
A64E A64F
A650 A651
A652 A653
A654 A655
A656 A657
A658 A659
A65A A65B
A65C A65D
A65E A65F
A660 A661
A662 A663
A664 A665
A666 A667
A668 A669
A66A A66B
A66C A66D
A680 A681
A682 A683
A684 A685
A686 A687
A688 A689
A68A A68B
A68C A68D
A68E A68F
A690 A691
A692 A693
A694 A695
A696 A697
A698 A699
A69A A69B
A722 A723
A724 A725
A726 A727
A728 A729
A72A A72B
A72C A72D
A72E A72F
A732 A733
A734 A735
A736 A737
A738 A739
A73A A73B
A73C A73D
A73E A73F
A740 A741
A742 A743
A744 A745
A746 A747
A748 A749
A74A A74B
A74C A74D
A74E A74F
A750 A751
A752 A753
A754 A755
A756 A757
A758 A759
A75A A75B
A75C A75D
A75E A75F
A760 A761
A762 A763
A764 A765
A766 A767
A768 A769
A76A A76B
A76C A76D
A76E A76F
A779 A77A
A77B A77C
A77D 1D79
A77E A77F
A780 A781
A782 A783
A784 A785
A786 A787
A78B A78C
A78D 265
A790 A791
A792 A793
A796 A797
A798 A799
A79A A79B
A79C A79D
A79E A79F
A7A0 A7A1
A7A2 A7A3
A7A4 A7A5
A7A6 A7A7
A7A8 A7A9
A7AA 266
A7AB 25C
A7AC 261
A7AD 26C
A7AE 26A
A7B0 29E
A7B1 287
A7B2 29D
A7B3 AB53
A7B4 A7B5
A7B6 A7B7
AB70 ABBF 13A0
FF21 FF3A FF41
10400 10427 10428
104B0 104D3 104D8
10C80 10CB2 10CC0
118A0 118BF 118C0
1E900 1E921 1E922
END

View File

@@ -0,0 +1,604 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! IT IS DEPRECATED TO USE THIS FILE !!!!!!!
# This file is for internal use by core Perl only. It is retained for
# backwards compatibility with applications that may have come to rely on it,
# but its format and even its name or existence are subject to change without
# notice in a future Perl version. Don't use it directly. Instead, its
# contents are now retrievable through a stable API in the Unicode::UCD
# module: Unicode::UCD::prop_invmap('Perl_Decimal_Digit') (Values for individual
# code points can be retrieved via Unicode::UCD::charprop());
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToDigit'}{'format'} = 'd'; # single decimal digit
$utf8::SwashInfo{'ToDigit'}{'missing'} = ''; # code point maps to the null string
return <<'END';
0030 0
0031 1
0032 2
0033 3
0034 4
0035 5
0036 6
0037 7
0038 8
0039 9
0660 0
0661 1
0662 2
0663 3
0664 4
0665 5
0666 6
0667 7
0668 8
0669 9
06F0 0
06F1 1
06F2 2
06F3 3
06F4 4
06F5 5
06F6 6
06F7 7
06F8 8
06F9 9
07C0 0
07C1 1
07C2 2
07C3 3
07C4 4
07C5 5
07C6 6
07C7 7
07C8 8
07C9 9
0966 0
0967 1
0968 2
0969 3
096A 4
096B 5
096C 6
096D 7
096E 8
096F 9
09E6 0
09E7 1
09E8 2
09E9 3
09EA 4
09EB 5
09EC 6
09ED 7
09EE 8
09EF 9
0A66 0
0A67 1
0A68 2
0A69 3
0A6A 4
0A6B 5
0A6C 6
0A6D 7
0A6E 8
0A6F 9
0AE6 0
0AE7 1
0AE8 2
0AE9 3
0AEA 4
0AEB 5
0AEC 6
0AED 7
0AEE 8
0AEF 9
0B66 0
0B67 1
0B68 2
0B69 3
0B6A 4
0B6B 5
0B6C 6
0B6D 7
0B6E 8
0B6F 9
0BE6 0
0BE7 1
0BE8 2
0BE9 3
0BEA 4
0BEB 5
0BEC 6
0BED 7
0BEE 8
0BEF 9
0C66 0
0C67 1
0C68 2
0C69 3
0C6A 4
0C6B 5
0C6C 6
0C6D 7
0C6E 8
0C6F 9
0CE6 0
0CE7 1
0CE8 2
0CE9 3
0CEA 4
0CEB 5
0CEC 6
0CED 7
0CEE 8
0CEF 9
0D66 0
0D67 1
0D68 2
0D69 3
0D6A 4
0D6B 5
0D6C 6
0D6D 7
0D6E 8
0D6F 9
0DE6 0
0DE7 1
0DE8 2
0DE9 3
0DEA 4
0DEB 5
0DEC 6
0DED 7
0DEE 8
0DEF 9
0E50 0
0E51 1
0E52 2
0E53 3
0E54 4
0E55 5
0E56 6
0E57 7
0E58 8
0E59 9
0ED0 0
0ED1 1
0ED2 2
0ED3 3
0ED4 4
0ED5 5
0ED6 6
0ED7 7
0ED8 8
0ED9 9
0F20 0
0F21 1
0F22 2
0F23 3
0F24 4
0F25 5
0F26 6
0F27 7
0F28 8
0F29 9
1040 0
1041 1
1042 2
1043 3
1044 4
1045 5
1046 6
1047 7
1048 8
1049 9
1090 0
1091 1
1092 2
1093 3
1094 4
1095 5
1096 6
1097 7
1098 8
1099 9
17E0 0
17E1 1
17E2 2
17E3 3
17E4 4
17E5 5
17E6 6
17E7 7
17E8 8
17E9 9
1810 0
1811 1
1812 2
1813 3
1814 4
1815 5
1816 6
1817 7
1818 8
1819 9
1946 0
1947 1
1948 2
1949 3
194A 4
194B 5
194C 6
194D 7
194E 8
194F 9
19D0 0
19D1 1
19D2 2
19D3 3
19D4 4
19D5 5
19D6 6
19D7 7
19D8 8
19D9 9
1A80 0
1A81 1
1A82 2
1A83 3
1A84 4
1A85 5
1A86 6
1A87 7
1A88 8
1A89 9
1A90 0
1A91 1
1A92 2
1A93 3
1A94 4
1A95 5
1A96 6
1A97 7
1A98 8
1A99 9
1B50 0
1B51 1
1B52 2
1B53 3
1B54 4
1B55 5
1B56 6
1B57 7
1B58 8
1B59 9
1BB0 0
1BB1 1
1BB2 2
1BB3 3
1BB4 4
1BB5 5
1BB6 6
1BB7 7
1BB8 8
1BB9 9
1C40 0
1C41 1
1C42 2
1C43 3
1C44 4
1C45 5
1C46 6
1C47 7
1C48 8
1C49 9
1C50 0
1C51 1
1C52 2
1C53 3
1C54 4
1C55 5
1C56 6
1C57 7
1C58 8
1C59 9
A620 0
A621 1
A622 2
A623 3
A624 4
A625 5
A626 6
A627 7
A628 8
A629 9
A8D0 0
A8D1 1
A8D2 2
A8D3 3
A8D4 4
A8D5 5
A8D6 6
A8D7 7
A8D8 8
A8D9 9
A900 0
A901 1
A902 2
A903 3
A904 4
A905 5
A906 6
A907 7
A908 8
A909 9
A9D0 0
A9D1 1
A9D2 2
A9D3 3
A9D4 4
A9D5 5
A9D6 6
A9D7 7
A9D8 8
A9D9 9
A9F0 0
A9F1 1
A9F2 2
A9F3 3
A9F4 4
A9F5 5
A9F6 6
A9F7 7
A9F8 8
A9F9 9
AA50 0
AA51 1
AA52 2
AA53 3
AA54 4
AA55 5
AA56 6
AA57 7
AA58 8
AA59 9
ABF0 0
ABF1 1
ABF2 2
ABF3 3
ABF4 4
ABF5 5
ABF6 6
ABF7 7
ABF8 8
ABF9 9
FF10 0
FF11 1
FF12 2
FF13 3
FF14 4
FF15 5
FF16 6
FF17 7
FF18 8
FF19 9
104A0 0
104A1 1
104A2 2
104A3 3
104A4 4
104A5 5
104A6 6
104A7 7
104A8 8
104A9 9
11066 0
11067 1
11068 2
11069 3
1106A 4
1106B 5
1106C 6
1106D 7
1106E 8
1106F 9
110F0 0
110F1 1
110F2 2
110F3 3
110F4 4
110F5 5
110F6 6
110F7 7
110F8 8
110F9 9
11136 0
11137 1
11138 2
11139 3
1113A 4
1113B 5
1113C 6
1113D 7
1113E 8
1113F 9
111D0 0
111D1 1
111D2 2
111D3 3
111D4 4
111D5 5
111D6 6
111D7 7
111D8 8
111D9 9
112F0 0
112F1 1
112F2 2
112F3 3
112F4 4
112F5 5
112F6 6
112F7 7
112F8 8
112F9 9
11450 0
11451 1
11452 2
11453 3
11454 4
11455 5
11456 6
11457 7
11458 8
11459 9
114D0 0
114D1 1
114D2 2
114D3 3
114D4 4
114D5 5
114D6 6
114D7 7
114D8 8
114D9 9
11650 0
11651 1
11652 2
11653 3
11654 4
11655 5
11656 6
11657 7
11658 8
11659 9
116C0 0
116C1 1
116C2 2
116C3 3
116C4 4
116C5 5
116C6 6
116C7 7
116C8 8
116C9 9
11730 0
11731 1
11732 2
11733 3
11734 4
11735 5
11736 6
11737 7
11738 8
11739 9
118E0 0
118E1 1
118E2 2
118E3 3
118E4 4
118E5 5
118E6 6
118E7 7
118E8 8
118E9 9
11C50 0
11C51 1
11C52 2
11C53 3
11C54 4
11C55 5
11C56 6
11C57 7
11C58 8
11C59 9
16A60 0
16A61 1
16A62 2
16A63 3
16A64 4
16A65 5
16A66 6
16A67 7
16A68 8
16A69 9
16B50 0
16B51 1
16B52 2
16B53 3
16B54 4
16B55 5
16B56 6
16B57 7
16B58 8
16B59 9
1D7CE 0
1D7CF 1
1D7D0 2
1D7D1 3
1D7D2 4
1D7D3 5
1D7D4 6
1D7D5 7
1D7D6 8
1D7D7 9
1D7D8 0
1D7D9 1
1D7DA 2
1D7DB 3
1D7DC 4
1D7DD 5
1D7DE 6
1D7DF 7
1D7E0 8
1D7E1 9
1D7E2 0
1D7E3 1
1D7E4 2
1D7E5 3
1D7E6 4
1D7E7 5
1D7E8 6
1D7E9 7
1D7EA 8
1D7EB 9
1D7EC 0
1D7ED 1
1D7EE 2
1D7EF 3
1D7F0 4
1D7F1 5
1D7F2 6
1D7F3 7
1D7F4 8
1D7F5 9
1D7F6 0
1D7F7 1
1D7F8 2
1D7F9 3
1D7FA 4
1D7FB 5
1D7FC 6
1D7FD 7
1D7FE 8
1D7FF 9
1E950 0
1E951 1
1E952 2
1E953 3
1E954 4
1E955 5
1E956 6
1E957 7
1E958 8
1E959 9
END

View File

@@ -0,0 +1,320 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToEa'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToEa'}{'missing'} = 'Neutral';
return <<'END';
20 7E Na
A1 A
A2 A3 Na
A4 A
A5 A6 Na
A7 A8 A
AA A
AC Na
AD AE A
AF Na
B0 B4 A
B6 BA A
BC BF A
C6 A
D0 A
D7 D8 A
DE E1 A
E6 A
E8 EA A
EC ED A
F0 A
F2 F3 A
F7 FA A
FC A
FE A
101 A
111 A
113 A
11B A
126 127 A
12B A
131 133 A
138 A
13F 142 A
144 A
148 14B A
14D A
152 153 A
166 167 A
16B A
1CE A
1D0 A
1D2 A
1D4 A
1D6 A
1D8 A
1DA A
1DC A
251 A
261 A
2C4 A
2C7 A
2C9 2CB A
2CD A
2D0 A
2D8 2DB A
2DD A
2DF A
300 36F A
391 3A1 A
3A3 3A9 A
3B1 3C1 A
3C3 3C9 A
401 A
410 44F A
451 A
1100 115F W
2010 A
2013 2016 A
2018 2019 A
201C 201D A
2020 2022 A
2024 2027 A
2030 A
2032 2033 A
2035 A
203B A
203E A
2074 A
207F A
2081 2084 A
20A9 H
20AC A
2103 A
2105 A
2109 A
2113 A
2116 A
2121 2122 A
2126 A
212B A
2153 2154 A
215B 215E A
2160 216B A
2170 2179 A
2189 A
2190 2199 A
21B8 21B9 A
21D2 A
21D4 A
21E7 A
2200 A
2202 2203 A
2207 2208 A
220B A
220F A
2211 A
2215 A
221A A
221D 2220 A
2223 A
2225 A
2227 222C A
222E A
2234 2237 A
223C 223D A
2248 A
224C A
2252 A
2260 2261 A
2264 2267 A
226A 226B A
226E 226F A
2282 2283 A
2286 2287 A
2295 A
2299 A
22A5 A
22BF A
2312 A
231A 231B W
2329 232A W
23E9 23EC W
23F0 W
23F3 W
2460 24E9 A
24EB 254B A
2550 2573 A
2580 258F A
2592 2595 A
25A0 25A1 A
25A3 25A9 A
25B2 25B3 A
25B6 25B7 A
25BC 25BD A
25C0 25C1 A
25C6 25C8 A
25CB A
25CE 25D1 A
25E2 25E5 A
25EF A
25FD 25FE W
2605 2606 A
2609 A
260E 260F A
2614 2615 W
261C A
261E A
2640 A
2642 A
2648 2653 W
2660 2661 A
2663 2665 A
2667 266A A
266C 266D A
266F A
267F W
2693 W
269E 269F A
26A1 W
26AA 26AB W
26BD 26BE W
26BF A
26C4 26C5 W
26C6 26CD A
26CE W
26CF 26D3 A
26D4 W
26D5 26E1 A
26E3 A
26E8 26E9 A
26EA W
26EB 26F1 A
26F2 26F3 W
26F4 A
26F5 W
26F6 26F9 A
26FA W
26FB 26FC A
26FD W
26FE 26FF A
2705 W
270A 270B W
2728 W
273D A
274C W
274E W
2753 2755 W
2757 W
2776 277F A
2795 2797 W
27B0 W
27BF W
27E6 27ED Na
2985 2986 Na
2B1B 2B1C W
2B50 W
2B55 W
2B56 2B59 A
2E80 2E99 W
2E9B 2EF3 W
2F00 2FD5 W
2FF0 2FFB W
3000 F
3001 303E W
3041 3096 W
3099 30FF W
3105 312D W
3131 318E W
3190 31BA W
31C0 31E3 W
31F0 321E W
3220 3247 W
3248 324F A
3250 32FE W
3300 4DBF W
4E00 A48C W
A490 A4C6 W
A960 A97C W
AC00 D7A3 W
E000 F8FF A
F900 FAFF W
FE00 FE0F A
FE10 FE19 W
FE30 FE52 W
FE54 FE66 W
FE68 FE6B W
FF01 FF60 F
FF61 FFBE H
FFC2 FFC7 H
FFCA FFCF H
FFD2 FFD7 H
FFDA FFDC H
FFE0 FFE6 F
FFE8 FFEE H
FFFD A
16FE0 W
17000 187EC W
18800 18AF2 W
1B000 1B001 W
1F004 W
1F0CF W
1F100 1F10A A
1F110 1F12D A
1F130 1F169 A
1F170 1F18D A
1F18E W
1F18F 1F190 A
1F191 1F19A W
1F19B 1F1AC A
1F200 1F202 W
1F210 1F23B W
1F240 1F248 W
1F250 1F251 W
1F300 1F320 W
1F32D 1F335 W
1F337 1F37C W
1F37E 1F393 W
1F3A0 1F3CA W
1F3CF 1F3D3 W
1F3E0 1F3F0 W
1F3F4 W
1F3F8 1F43E W
1F440 W
1F442 1F4FC W
1F4FF 1F53D W
1F54B 1F54E W
1F550 1F567 W
1F57A W
1F595 1F596 W
1F5A4 W
1F5FB 1F64F W
1F680 1F6C5 W
1F6CC W
1F6D0 1F6D2 W
1F6EB 1F6EC W
1F6F4 1F6F6 W
1F910 1F91E W
1F920 1F927 W
1F930 W
1F933 1F93E W
1F940 1F94B W
1F950 1F95E W
1F980 1F991 W
1F9C0 W
20000 2FFFD W
30000 3FFFD W
E0100 E01EF A
F0000 FFFFD A
100000 10FFFD A
END

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,824 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToHst'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToHst'}{'missing'} = 'NA';
return <<'END';
1100 115F L
1160 11A7 V
11A8 11FF T
A960 A97C L
AC00 LV
AC01 AC1B LVT
AC1C LV
AC1D AC37 LVT
AC38 LV
AC39 AC53 LVT
AC54 LV
AC55 AC6F LVT
AC70 LV
AC71 AC8B LVT
AC8C LV
AC8D ACA7 LVT
ACA8 LV
ACA9 ACC3 LVT
ACC4 LV
ACC5 ACDF LVT
ACE0 LV
ACE1 ACFB LVT
ACFC LV
ACFD AD17 LVT
AD18 LV
AD19 AD33 LVT
AD34 LV
AD35 AD4F LVT
AD50 LV
AD51 AD6B LVT
AD6C LV
AD6D AD87 LVT
AD88 LV
AD89 ADA3 LVT
ADA4 LV
ADA5 ADBF LVT
ADC0 LV
ADC1 ADDB LVT
ADDC LV
ADDD ADF7 LVT
ADF8 LV
ADF9 AE13 LVT
AE14 LV
AE15 AE2F LVT
AE30 LV
AE31 AE4B LVT
AE4C LV
AE4D AE67 LVT
AE68 LV
AE69 AE83 LVT
AE84 LV
AE85 AE9F LVT
AEA0 LV
AEA1 AEBB LVT
AEBC LV
AEBD AED7 LVT
AED8 LV
AED9 AEF3 LVT
AEF4 LV
AEF5 AF0F LVT
AF10 LV
AF11 AF2B LVT
AF2C LV
AF2D AF47 LVT
AF48 LV
AF49 AF63 LVT
AF64 LV
AF65 AF7F LVT
AF80 LV
AF81 AF9B LVT
AF9C LV
AF9D AFB7 LVT
AFB8 LV
AFB9 AFD3 LVT
AFD4 LV
AFD5 AFEF LVT
AFF0 LV
AFF1 B00B LVT
B00C LV
B00D B027 LVT
B028 LV
B029 B043 LVT
B044 LV
B045 B05F LVT
B060 LV
B061 B07B LVT
B07C LV
B07D B097 LVT
B098 LV
B099 B0B3 LVT
B0B4 LV
B0B5 B0CF LVT
B0D0 LV
B0D1 B0EB LVT
B0EC LV
B0ED B107 LVT
B108 LV
B109 B123 LVT
B124 LV
B125 B13F LVT
B140 LV
B141 B15B LVT
B15C LV
B15D B177 LVT
B178 LV
B179 B193 LVT
B194 LV
B195 B1AF LVT
B1B0 LV
B1B1 B1CB LVT
B1CC LV
B1CD B1E7 LVT
B1E8 LV
B1E9 B203 LVT
B204 LV
B205 B21F LVT
B220 LV
B221 B23B LVT
B23C LV
B23D B257 LVT
B258 LV
B259 B273 LVT
B274 LV
B275 B28F LVT
B290 LV
B291 B2AB LVT
B2AC LV
B2AD B2C7 LVT
B2C8 LV
B2C9 B2E3 LVT
B2E4 LV
B2E5 B2FF LVT
B300 LV
B301 B31B LVT
B31C LV
B31D B337 LVT
B338 LV
B339 B353 LVT
B354 LV
B355 B36F LVT
B370 LV
B371 B38B LVT
B38C LV
B38D B3A7 LVT
B3A8 LV
B3A9 B3C3 LVT
B3C4 LV
B3C5 B3DF LVT
B3E0 LV
B3E1 B3FB LVT
B3FC LV
B3FD B417 LVT
B418 LV
B419 B433 LVT
B434 LV
B435 B44F LVT
B450 LV
B451 B46B LVT
B46C LV
B46D B487 LVT
B488 LV
B489 B4A3 LVT
B4A4 LV
B4A5 B4BF LVT
B4C0 LV
B4C1 B4DB LVT
B4DC LV
B4DD B4F7 LVT
B4F8 LV
B4F9 B513 LVT
B514 LV
B515 B52F LVT
B530 LV
B531 B54B LVT
B54C LV
B54D B567 LVT
B568 LV
B569 B583 LVT
B584 LV
B585 B59F LVT
B5A0 LV
B5A1 B5BB LVT
B5BC LV
B5BD B5D7 LVT
B5D8 LV
B5D9 B5F3 LVT
B5F4 LV
B5F5 B60F LVT
B610 LV
B611 B62B LVT
B62C LV
B62D B647 LVT
B648 LV
B649 B663 LVT
B664 LV
B665 B67F LVT
B680 LV
B681 B69B LVT
B69C LV
B69D B6B7 LVT
B6B8 LV
B6B9 B6D3 LVT
B6D4 LV
B6D5 B6EF LVT
B6F0 LV
B6F1 B70B LVT
B70C LV
B70D B727 LVT
B728 LV
B729 B743 LVT
B744 LV
B745 B75F LVT
B760 LV
B761 B77B LVT
B77C LV
B77D B797 LVT
B798 LV
B799 B7B3 LVT
B7B4 LV
B7B5 B7CF LVT
B7D0 LV
B7D1 B7EB LVT
B7EC LV
B7ED B807 LVT
B808 LV
B809 B823 LVT
B824 LV
B825 B83F LVT
B840 LV
B841 B85B LVT
B85C LV
B85D B877 LVT
B878 LV
B879 B893 LVT
B894 LV
B895 B8AF LVT
B8B0 LV
B8B1 B8CB LVT
B8CC LV
B8CD B8E7 LVT
B8E8 LV
B8E9 B903 LVT
B904 LV
B905 B91F LVT
B920 LV
B921 B93B LVT
B93C LV
B93D B957 LVT
B958 LV
B959 B973 LVT
B974 LV
B975 B98F LVT
B990 LV
B991 B9AB LVT
B9AC LV
B9AD B9C7 LVT
B9C8 LV
B9C9 B9E3 LVT
B9E4 LV
B9E5 B9FF LVT
BA00 LV
BA01 BA1B LVT
BA1C LV
BA1D BA37 LVT
BA38 LV
BA39 BA53 LVT
BA54 LV
BA55 BA6F LVT
BA70 LV
BA71 BA8B LVT
BA8C LV
BA8D BAA7 LVT
BAA8 LV
BAA9 BAC3 LVT
BAC4 LV
BAC5 BADF LVT
BAE0 LV
BAE1 BAFB LVT
BAFC LV
BAFD BB17 LVT
BB18 LV
BB19 BB33 LVT
BB34 LV
BB35 BB4F LVT
BB50 LV
BB51 BB6B LVT
BB6C LV
BB6D BB87 LVT
BB88 LV
BB89 BBA3 LVT
BBA4 LV
BBA5 BBBF LVT
BBC0 LV
BBC1 BBDB LVT
BBDC LV
BBDD BBF7 LVT
BBF8 LV
BBF9 BC13 LVT
BC14 LV
BC15 BC2F LVT
BC30 LV
BC31 BC4B LVT
BC4C LV
BC4D BC67 LVT
BC68 LV
BC69 BC83 LVT
BC84 LV
BC85 BC9F LVT
BCA0 LV
BCA1 BCBB LVT
BCBC LV
BCBD BCD7 LVT
BCD8 LV
BCD9 BCF3 LVT
BCF4 LV
BCF5 BD0F LVT
BD10 LV
BD11 BD2B LVT
BD2C LV
BD2D BD47 LVT
BD48 LV
BD49 BD63 LVT
BD64 LV
BD65 BD7F LVT
BD80 LV
BD81 BD9B LVT
BD9C LV
BD9D BDB7 LVT
BDB8 LV
BDB9 BDD3 LVT
BDD4 LV
BDD5 BDEF LVT
BDF0 LV
BDF1 BE0B LVT
BE0C LV
BE0D BE27 LVT
BE28 LV
BE29 BE43 LVT
BE44 LV
BE45 BE5F LVT
BE60 LV
BE61 BE7B LVT
BE7C LV
BE7D BE97 LVT
BE98 LV
BE99 BEB3 LVT
BEB4 LV
BEB5 BECF LVT
BED0 LV
BED1 BEEB LVT
BEEC LV
BEED BF07 LVT
BF08 LV
BF09 BF23 LVT
BF24 LV
BF25 BF3F LVT
BF40 LV
BF41 BF5B LVT
BF5C LV
BF5D BF77 LVT
BF78 LV
BF79 BF93 LVT
BF94 LV
BF95 BFAF LVT
BFB0 LV
BFB1 BFCB LVT
BFCC LV
BFCD BFE7 LVT
BFE8 LV
BFE9 C003 LVT
C004 LV
C005 C01F LVT
C020 LV
C021 C03B LVT
C03C LV
C03D C057 LVT
C058 LV
C059 C073 LVT
C074 LV
C075 C08F LVT
C090 LV
C091 C0AB LVT
C0AC LV
C0AD C0C7 LVT
C0C8 LV
C0C9 C0E3 LVT
C0E4 LV
C0E5 C0FF LVT
C100 LV
C101 C11B LVT
C11C LV
C11D C137 LVT
C138 LV
C139 C153 LVT
C154 LV
C155 C16F LVT
C170 LV
C171 C18B LVT
C18C LV
C18D C1A7 LVT
C1A8 LV
C1A9 C1C3 LVT
C1C4 LV
C1C5 C1DF LVT
C1E0 LV
C1E1 C1FB LVT
C1FC LV
C1FD C217 LVT
C218 LV
C219 C233 LVT
C234 LV
C235 C24F LVT
C250 LV
C251 C26B LVT
C26C LV
C26D C287 LVT
C288 LV
C289 C2A3 LVT
C2A4 LV
C2A5 C2BF LVT
C2C0 LV
C2C1 C2DB LVT
C2DC LV
C2DD C2F7 LVT
C2F8 LV
C2F9 C313 LVT
C314 LV
C315 C32F LVT
C330 LV
C331 C34B LVT
C34C LV
C34D C367 LVT
C368 LV
C369 C383 LVT
C384 LV
C385 C39F LVT
C3A0 LV
C3A1 C3BB LVT
C3BC LV
C3BD C3D7 LVT
C3D8 LV
C3D9 C3F3 LVT
C3F4 LV
C3F5 C40F LVT
C410 LV
C411 C42B LVT
C42C LV
C42D C447 LVT
C448 LV
C449 C463 LVT
C464 LV
C465 C47F LVT
C480 LV
C481 C49B LVT
C49C LV
C49D C4B7 LVT
C4B8 LV
C4B9 C4D3 LVT
C4D4 LV
C4D5 C4EF LVT
C4F0 LV
C4F1 C50B LVT
C50C LV
C50D C527 LVT
C528 LV
C529 C543 LVT
C544 LV
C545 C55F LVT
C560 LV
C561 C57B LVT
C57C LV
C57D C597 LVT
C598 LV
C599 C5B3 LVT
C5B4 LV
C5B5 C5CF LVT
C5D0 LV
C5D1 C5EB LVT
C5EC LV
C5ED C607 LVT
C608 LV
C609 C623 LVT
C624 LV
C625 C63F LVT
C640 LV
C641 C65B LVT
C65C LV
C65D C677 LVT
C678 LV
C679 C693 LVT
C694 LV
C695 C6AF LVT
C6B0 LV
C6B1 C6CB LVT
C6CC LV
C6CD C6E7 LVT
C6E8 LV
C6E9 C703 LVT
C704 LV
C705 C71F LVT
C720 LV
C721 C73B LVT
C73C LV
C73D C757 LVT
C758 LV
C759 C773 LVT
C774 LV
C775 C78F LVT
C790 LV
C791 C7AB LVT
C7AC LV
C7AD C7C7 LVT
C7C8 LV
C7C9 C7E3 LVT
C7E4 LV
C7E5 C7FF LVT
C800 LV
C801 C81B LVT
C81C LV
C81D C837 LVT
C838 LV
C839 C853 LVT
C854 LV
C855 C86F LVT
C870 LV
C871 C88B LVT
C88C LV
C88D C8A7 LVT
C8A8 LV
C8A9 C8C3 LVT
C8C4 LV
C8C5 C8DF LVT
C8E0 LV
C8E1 C8FB LVT
C8FC LV
C8FD C917 LVT
C918 LV
C919 C933 LVT
C934 LV
C935 C94F LVT
C950 LV
C951 C96B LVT
C96C LV
C96D C987 LVT
C988 LV
C989 C9A3 LVT
C9A4 LV
C9A5 C9BF LVT
C9C0 LV
C9C1 C9DB LVT
C9DC LV
C9DD C9F7 LVT
C9F8 LV
C9F9 CA13 LVT
CA14 LV
CA15 CA2F LVT
CA30 LV
CA31 CA4B LVT
CA4C LV
CA4D CA67 LVT
CA68 LV
CA69 CA83 LVT
CA84 LV
CA85 CA9F LVT
CAA0 LV
CAA1 CABB LVT
CABC LV
CABD CAD7 LVT
CAD8 LV
CAD9 CAF3 LVT
CAF4 LV
CAF5 CB0F LVT
CB10 LV
CB11 CB2B LVT
CB2C LV
CB2D CB47 LVT
CB48 LV
CB49 CB63 LVT
CB64 LV
CB65 CB7F LVT
CB80 LV
CB81 CB9B LVT
CB9C LV
CB9D CBB7 LVT
CBB8 LV
CBB9 CBD3 LVT
CBD4 LV
CBD5 CBEF LVT
CBF0 LV
CBF1 CC0B LVT
CC0C LV
CC0D CC27 LVT
CC28 LV
CC29 CC43 LVT
CC44 LV
CC45 CC5F LVT
CC60 LV
CC61 CC7B LVT
CC7C LV
CC7D CC97 LVT
CC98 LV
CC99 CCB3 LVT
CCB4 LV
CCB5 CCCF LVT
CCD0 LV
CCD1 CCEB LVT
CCEC LV
CCED CD07 LVT
CD08 LV
CD09 CD23 LVT
CD24 LV
CD25 CD3F LVT
CD40 LV
CD41 CD5B LVT
CD5C LV
CD5D CD77 LVT
CD78 LV
CD79 CD93 LVT
CD94 LV
CD95 CDAF LVT
CDB0 LV
CDB1 CDCB LVT
CDCC LV
CDCD CDE7 LVT
CDE8 LV
CDE9 CE03 LVT
CE04 LV
CE05 CE1F LVT
CE20 LV
CE21 CE3B LVT
CE3C LV
CE3D CE57 LVT
CE58 LV
CE59 CE73 LVT
CE74 LV
CE75 CE8F LVT
CE90 LV
CE91 CEAB LVT
CEAC LV
CEAD CEC7 LVT
CEC8 LV
CEC9 CEE3 LVT
CEE4 LV
CEE5 CEFF LVT
CF00 LV
CF01 CF1B LVT
CF1C LV
CF1D CF37 LVT
CF38 LV
CF39 CF53 LVT
CF54 LV
CF55 CF6F LVT
CF70 LV
CF71 CF8B LVT
CF8C LV
CF8D CFA7 LVT
CFA8 LV
CFA9 CFC3 LVT
CFC4 LV
CFC5 CFDF LVT
CFE0 LV
CFE1 CFFB LVT
CFFC LV
CFFD D017 LVT
D018 LV
D019 D033 LVT
D034 LV
D035 D04F LVT
D050 LV
D051 D06B LVT
D06C LV
D06D D087 LVT
D088 LV
D089 D0A3 LVT
D0A4 LV
D0A5 D0BF LVT
D0C0 LV
D0C1 D0DB LVT
D0DC LV
D0DD D0F7 LVT
D0F8 LV
D0F9 D113 LVT
D114 LV
D115 D12F LVT
D130 LV
D131 D14B LVT
D14C LV
D14D D167 LVT
D168 LV
D169 D183 LVT
D184 LV
D185 D19F LVT
D1A0 LV
D1A1 D1BB LVT
D1BC LV
D1BD D1D7 LVT
D1D8 LV
D1D9 D1F3 LVT
D1F4 LV
D1F5 D20F LVT
D210 LV
D211 D22B LVT
D22C LV
D22D D247 LVT
D248 LV
D249 D263 LVT
D264 LV
D265 D27F LVT
D280 LV
D281 D29B LVT
D29C LV
D29D D2B7 LVT
D2B8 LV
D2B9 D2D3 LVT
D2D4 LV
D2D5 D2EF LVT
D2F0 LV
D2F1 D30B LVT
D30C LV
D30D D327 LVT
D328 LV
D329 D343 LVT
D344 LV
D345 D35F LVT
D360 LV
D361 D37B LVT
D37C LV
D37D D397 LVT
D398 LV
D399 D3B3 LVT
D3B4 LV
D3B5 D3CF LVT
D3D0 LV
D3D1 D3EB LVT
D3EC LV
D3ED D407 LVT
D408 LV
D409 D423 LVT
D424 LV
D425 D43F LVT
D440 LV
D441 D45B LVT
D45C LV
D45D D477 LVT
D478 LV
D479 D493 LVT
D494 LV
D495 D4AF LVT
D4B0 LV
D4B1 D4CB LVT
D4CC LV
D4CD D4E7 LVT
D4E8 LV
D4E9 D503 LVT
D504 LV
D505 D51F LVT
D520 LV
D521 D53B LVT
D53C LV
D53D D557 LVT
D558 LV
D559 D573 LVT
D574 LV
D575 D58F LVT
D590 LV
D591 D5AB LVT
D5AC LV
D5AD D5C7 LVT
D5C8 LV
D5C9 D5E3 LVT
D5E4 LV
D5E5 D5FF LVT
D600 LV
D601 D61B LVT
D61C LV
D61D D637 LVT
D638 LV
D639 D653 LVT
D654 LV
D655 D66F LVT
D670 LV
D671 D68B LVT
D68C LV
D68D D6A7 LVT
D6A8 LV
D6A9 D6C3 LVT
D6C4 LV
D6C5 D6DF LVT
D6E0 LV
D6E1 D6FB LVT
D6FC LV
D6FD D717 LVT
D718 LV
D719 D733 LVT
D734 LV
D735 D74F LVT
D750 LV
D751 D76B LVT
D76C LV
D76D D787 LVT
D788 LV
D789 D7A3 LVT
D7B0 D7C6 V
D7CB D7FB T
END

View File

@@ -0,0 +1,539 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToInPC'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToInPC'}{'missing'} = 'NA';
return <<'END';
900 902 Top
903 Right
93A Top
93B Right
93C Bottom
93E Right
93F Left
940 Right
941 944 Bottom
945 948 Top
949 94C Right
94D Bottom
94E Left
94F Right
951 Top
952 Bottom
953 955 Top
956 957 Bottom
962 963 Bottom
981 Top
982 983 Right
9BC Bottom
9BE Right
9BF Left
9C0 Right
9C1 9C4 Bottom
9C7 9C8 Left
9CB 9CC Left_And_Right
9CD Bottom
9D7 Right
9E2 9E3 Bottom
A01 A02 Top
A03 Right
A3C Bottom
A3E Right
A3F Left
A40 Right
A41 A42 Bottom
A47 A48 Top
A4B A4C Top
A4D Bottom
A70 A71 Top
A75 Bottom
A81 A82 Top
A83 Right
ABC Bottom
ABE Right
ABF Left
AC0 Right
AC1 AC4 Bottom
AC5 Top
AC7 AC8 Top
AC9 Top_And_Right
ACB ACC Right
ACD Bottom
AE2 AE3 Bottom
B01 Top
B02 B03 Right
B3C Bottom
B3E Right
B3F Top
B40 Right
B41 B44 Bottom
B47 Left
B48 Top_And_Left
B4B Left_And_Right
B4C Top_And_Left_And_Right
B4D Bottom
B56 Top
B57 Top_And_Right
B62 B63 Bottom
B82 Top
BBE BBF Right
BC0 Top
BC1 BC2 Right
BC6 BC8 Left
BCA BCC Left_And_Right
BCD Top
BD7 Right
C00 Top
C01 C03 Right
C3E C40 Top
C41 C44 Right
C46 C47 Top
C48 Top_And_Bottom
C4A C4D Top
C55 Top
C56 Bottom
C62 C63 Bottom
C81 Top
C82 C83 Right
CBC Bottom
CBE Right
CBF Top
CC0 Top_And_Right
CC1 CC4 Right
CC6 Top
CC7 CC8 Top_And_Right
CCA CCB Top_And_Right
CCC CCD Top
CD5 CD6 Right
CE2 CE3 Bottom
D01 Top
D02 D03 Right
D3E D42 Right
D43 D44 Bottom
D46 D48 Left
D4A D4C Left_And_Right
D4D Top
D57 Right
D62 D63 Bottom
D82 D83 Right
DCA Top
DCF DD1 Right
DD2 DD3 Top
DD4 Bottom
DD6 Bottom
DD8 Right
DD9 Left
DDA Top_And_Left
DDB Left
DDC Left_And_Right
DDD Top_And_Left_And_Right
DDE Left_And_Right
DDF Right
DF2 DF3 Right
E30 Right
E31 Top
E32 E33 Right
E34 E37 Top
E38 E3A Bottom
E40 E44 Visual_Order_Left
E45 Right
E47 E4E Top
EB0 Right
EB1 Top
EB2 EB3 Right
EB4 EB7 Top
EB8 EB9 Bottom
EBB Top
EBC Bottom
EC0 EC4 Visual_Order_Left
EC8 ECD Top
F18 F19 Bottom
F35 Bottom
F37 Bottom
F39 Top
F3E Right
F3F Left
F71 Bottom
F72 Top
F73 Top_And_Bottom
F74 F75 Bottom
F76 F79 Top_And_Bottom
F7A F7E Top
F7F Right
F80 Top
F81 Top_And_Bottom
F82 F83 Top
F84 Bottom
F86 F87 Top
F8D F97 Bottom
F99 FBC Bottom
FC6 Bottom
102B 102C Right
102D 102E Top
102F 1030 Bottom
1031 Left
1032 1036 Top
1037 Bottom
1038 Right
103A Top
103B Right
103D 103E Bottom
1056 1057 Right
1058 1059 Bottom
105E 1060 Bottom
1062 1064 Right
1067 106D Right
1071 1074 Top
1082 Bottom
1083 Right
1084 Left
1085 1086 Top
1087 108C Right
108D Bottom
108F Right
109A 109C Right
109D Top
1712 Top
1713 1714 Bottom
1732 Top
1733 1734 Bottom
1752 Top
1753 Bottom
1772 Top
1773 Bottom
17B6 Right
17B7 17BA Top
17BB 17BD Bottom
17BE Top_And_Left
17BF Top_And_Left_And_Right
17C0 Left_And_Right
17C1 17C3 Left
17C4 17C5 Left_And_Right
17C6 Top
17C7 17C8 Right
17C9 17D1 Top
17D3 Top
17DD Top
1920 1921 Top
1922 Bottom
1923 1924 Right
1925 1926 Top_And_Right
1927 1928 Top
1929 192B Right
1930 1931 Right
1932 Bottom
1933 1938 Right
1939 Bottom
193A Top
193B Bottom
19B0 19B4 Right
19B5 19B7 Visual_Order_Left
19B8 19B9 Right
19BA Visual_Order_Left
19BB 19C0 Right
19C8 19C9 Right
1A17 Top
1A18 Bottom
1A19 Left
1A1A Right
1A1B Top
1A55 Left
1A56 Bottom
1A57 Right
1A58 1A5A Top
1A5B 1A5E Bottom
1A61 Right
1A62 Top
1A63 1A64 Right
1A65 1A68 Top
1A69 1A6A Bottom
1A6B Top
1A6C Bottom
1A6D Right
1A6E 1A72 Left
1A73 1A7C Top
1A7F Bottom
1B00 1B03 Top
1B04 Right
1B34 Top
1B35 Right
1B36 1B37 Top
1B38 1B3A Bottom
1B3B Bottom_And_Right
1B3C Top_And_Bottom
1B3D Top_And_Bottom_And_Right
1B3E 1B3F Left
1B40 1B41 Left_And_Right
1B42 Top
1B43 Top_And_Right
1B44 Right
1B6B Top
1B6C Bottom
1B6D 1B73 Top
1B80 1B81 Top
1B82 Right
1BA1 Right
1BA2 1BA3 Bottom
1BA4 Top
1BA5 Bottom
1BA6 Left
1BA7 Right
1BA8 1BA9 Top
1BAA Right
1BAC 1BAD Bottom
1BE6 Top
1BE7 Right
1BE8 1BE9 Top
1BEA 1BEC Right
1BED Top
1BEE Right
1BEF 1BF1 Top
1BF2 1BF3 Right
1C24 1C26 Right
1C27 1C28 Left
1C29 Top_And_Left
1C2A 1C2B Right
1C2C Bottom
1C2D 1C33 Top
1C34 1C35 Left
1C36 Top
1C37 Bottom
1CD0 1CD2 Top
1CD4 Overstruck
1CD5 1CD9 Bottom
1CDA 1CDB Top
1CDC 1CDF Bottom
1CE0 Top
1CE1 Right
1CE2 1CE8 Overstruck
1CED Bottom
1CF4 Top
1DFB Top
A806 Top
A80B Top
A823 A824 Right
A825 Bottom
A826 Top
A827 Right
A880 A881 Right
A8B4 A8C3 Right
A8C4 Bottom
A8C5 Top
A8E0 A8F1 Top
A92B A92D Bottom
A947 A949 Bottom
A94A Top
A94B A94E Bottom
A94F A951 Top
A952 A953 Right
A980 A982 Top
A983 Right
A9B3 Top
A9B4 A9B5 Right
A9B6 A9B7 Top
A9B8 A9B9 Bottom
A9BA A9BB Left
A9BC Top
A9BD A9BF Right
A9C0 Bottom_And_Right
A9E5 Top
AA29 AA2C Top
AA2D Bottom
AA2E Top
AA2F AA30 Left
AA31 Top
AA32 Bottom
AA33 Right
AA34 Left
AA35 AA36 Bottom
AA43 Top
AA4C Top
AA4D Right
AA7B Right
AA7C Top
AA7D Right
AAB0 Top
AAB1 Right
AAB2 AAB3 Top
AAB4 Bottom
AAB5 AAB6 Visual_Order_Left
AAB7 AAB8 Top
AAB9 Visual_Order_Left
AABA Right
AABB AABC Visual_Order_Left
AABD Right
AABE AABF Top
AAC1 Top
AAEB Left
AAEC Bottom
AAED Top
AAEE Left
AAEF Right
AAF5 Right
ABE3 ABE4 Right
ABE5 Top
ABE6 ABE7 Right
ABE8 Bottom
ABE9 ABEA Right
ABEC Right
ABED Bottom
10A01 Overstruck
10A02 10A03 Bottom
10A05 Top
10A06 Overstruck
10A0C 10A0E Bottom
10A0F Top
10A38 Top
10A39 10A3A Bottom
11000 Right
11001 Top
11002 Right
11038 1103B Top
1103C 11041 Bottom
11042 11046 Top
11080 11081 Top
11082 Right
110B0 Right
110B1 Left
110B2 Right
110B3 110B4 Bottom
110B5 110B6 Top
110B7 110B8 Right
110B9 110BA Bottom
11100 11102 Top
11127 11129 Top
1112A 1112B Bottom
1112C Left
1112D Top
1112E 1112F Top_And_Bottom
11130 Top
11131 11132 Bottom
11134 Top
11173 Bottom
11180 11181 Top
11182 Right
111B3 Right
111B4 Left
111B5 Right
111B6 111BB Bottom
111BC 111BE Top
111BF Top_And_Right
111C0 Right
111CB Top
111CC Bottom
1122C 1122E Right
1122F Bottom
11230 11231 Top
11232 11233 Top_And_Right
11234 Top
11235 Right
11236 11237 Top
1123E Top
112DF Top
112E0 Right
112E1 Left
112E2 Right
112E3 112E4 Bottom
112E5 112E8 Top
112E9 112EA Bottom
11301 Top
11302 11303 Right
1133E 1133F Right
11340 Top
11341 11344 Right
11347 11348 Left
1134B 1134C Left_And_Right
1134D Right
11357 Right
11362 11363 Right
11366 1136C Top
11370 11374 Top
11435 Right
11436 Left
11437 Right
11438 1143D Bottom
1143E 1143F Top
11440 11441 Right
11442 Bottom
11443 11444 Top
11445 Right
11446 Bottom
114B0 Right
114B1 Left
114B2 Right
114B3 114B8 Bottom
114B9 Left
114BA Top
114BB Top_And_Left
114BC Left_And_Right
114BD Right
114BE Left_And_Right
114BF 114C0 Top
114C1 Right
114C2 114C3 Bottom
115AF Right
115B0 Left
115B1 Right
115B2 115B5 Bottom
115B8 Left
115B9 Top_And_Left
115BA Left_And_Right
115BB Top_And_Left_And_Right
115BC 115BD Top
115BE Right
115BF 115C0 Bottom
115DC 115DD Bottom
11630 11632 Right
11633 11638 Bottom
11639 1163A Top
1163B 1163C Right
1163D Top
1163E Right
1163F Bottom
11640 Top
116AB Top
116AC Right
116AD Top
116AE Left
116AF Right
116B0 116B1 Bottom
116B2 116B5 Top
116B6 Right
116B7 Bottom
1171D Bottom
1171F Top
11720 11721 Right
11722 11723 Top
11724 11725 Bottom
11726 Left
11727 Top
11728 Bottom
11729 1172B Top
11C2F Right
11C30 11C31 Top
11C32 11C36 Bottom
11C38 11C3D Top
11C3E Right
11C3F Bottom
11C92 11CA7 Bottom
11CA9 Right
11CAA 11CB0 Bottom
11CB1 Left
11CB2 Bottom
11CB3 Top
11CB4 Right
11CB5 11CB6 Top
END

View File

@@ -0,0 +1,655 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToInSC'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToInSC'}{'missing'} = 'Other';
return <<'END';
2D Consonant_Placeholder
30 39 Number
A0 Consonant_Placeholder
B2 B3 Syllable_Modifier
D7 Consonant_Placeholder
900 902 Bindu
903 Visarga
904 914 Vowel_Independent
915 939 Consonant
93A 93B Vowel_Dependent
93C Nukta
93D Avagraha
93E 94C Vowel_Dependent
94D Virama
94E 94F Vowel_Dependent
951 952 Cantillation_Mark
955 957 Vowel_Dependent
958 95F Consonant
960 961 Vowel_Independent
962 963 Vowel_Dependent
966 96F Number
972 977 Vowel_Independent
978 97F Consonant
981 982 Bindu
983 Visarga
985 98C Vowel_Independent
98F 990 Vowel_Independent
993 994 Vowel_Independent
995 9A8 Consonant
9AA 9B0 Consonant
9B2 Consonant
9B6 9B9 Consonant
9BC Nukta
9BD Avagraha
9BE 9C4 Vowel_Dependent
9C7 9C8 Vowel_Dependent
9CB 9CC Vowel_Dependent
9CD Virama
9CE Consonant_Dead
9D7 Vowel_Dependent
9DC 9DD Consonant
9DF Consonant
9E0 9E1 Vowel_Independent
9E2 9E3 Vowel_Dependent
9E6 9EF Number
9F0 9F1 Consonant
A01 A02 Bindu
A03 Visarga
A05 A0A Vowel_Independent
A0F A10 Vowel_Independent
A13 A14 Vowel_Independent
A15 A28 Consonant
A2A A30 Consonant
A32 A33 Consonant
A35 A36 Consonant
A38 A39 Consonant
A3C Nukta
A3E A42 Vowel_Dependent
A47 A48 Vowel_Dependent
A4B A4C Vowel_Dependent
A4D Virama
A59 A5C Consonant
A5E Consonant
A66 A6F Number
A70 Bindu
A71 Gemination_Mark
A72 A73 Consonant_Placeholder
A75 Consonant_Medial
A81 A82 Bindu
A83 Visarga
A85 A8D Vowel_Independent
A8F A91 Vowel_Independent
A93 A94 Vowel_Independent
A95 AA8 Consonant
AAA AB0 Consonant
AB2 AB3 Consonant
AB5 AB9 Consonant
ABC Nukta
ABD Avagraha
ABE AC5 Vowel_Dependent
AC7 AC9 Vowel_Dependent
ACB ACC Vowel_Dependent
ACD Virama
AE0 AE1 Vowel_Independent
AE2 AE3 Vowel_Dependent
AE6 AEF Number
AF9 Consonant
B01 B02 Bindu
B03 Visarga
B05 B0C Vowel_Independent
B0F B10 Vowel_Independent
B13 B14 Vowel_Independent
B15 B28 Consonant
B2A B30 Consonant
B32 B33 Consonant
B35 B39 Consonant
B3C Nukta
B3D Avagraha
B3E B44 Vowel_Dependent
B47 B48 Vowel_Dependent
B4B B4C Vowel_Dependent
B4D Virama
B56 B57 Vowel_Dependent
B5C B5D Consonant
B5F Consonant
B60 B61 Vowel_Independent
B62 B63 Vowel_Dependent
B66 B6F Number
B71 Consonant
B82 Bindu
B83 Modifying_Letter
B85 B8A Vowel_Independent
B8E B90 Vowel_Independent
B92 B94 Vowel_Independent
B95 Consonant
B99 B9A Consonant
B9C Consonant
B9E B9F Consonant
BA3 BA4 Consonant
BA8 BAA Consonant
BAE BB9 Consonant
BBE BC2 Vowel_Dependent
BC6 BC8 Vowel_Dependent
BCA BCC Vowel_Dependent
BCD Virama
BD7 Vowel_Dependent
BE6 BEF Number
C00 C02 Bindu
C03 Visarga
C05 C0C Vowel_Independent
C0E C10 Vowel_Independent
C12 C14 Vowel_Independent
C15 C28 Consonant
C2A C39 Consonant
C3D Avagraha
C3E C44 Vowel_Dependent
C46 C48 Vowel_Dependent
C4A C4C Vowel_Dependent
C4D Virama
C55 C56 Vowel_Dependent
C58 C5A Consonant
C60 C61 Vowel_Independent
C62 C63 Vowel_Dependent
C66 C6F Number
C81 C82 Bindu
C83 Visarga
C85 C8C Vowel_Independent
C8E C90 Vowel_Independent
C92 C94 Vowel_Independent
C95 CA8 Consonant
CAA CB3 Consonant
CB5 CB9 Consonant
CBC Nukta
CBD Avagraha
CBE CC4 Vowel_Dependent
CC6 CC8 Vowel_Dependent
CCA CCC Vowel_Dependent
CCD Virama
CD5 CD6 Vowel_Dependent
CDE Consonant
CE0 CE1 Vowel_Independent
CE2 CE3 Vowel_Dependent
CE6 CEF Number
CF1 CF2 Consonant_With_Stacker
D01 D02 Bindu
D03 Visarga
D05 D0C Vowel_Independent
D0E D10 Vowel_Independent
D12 D14 Vowel_Independent
D15 D3A Consonant
D3D Avagraha
D3E D44 Vowel_Dependent
D46 D48 Vowel_Dependent
D4A D4C Vowel_Dependent
D4D Virama
D4E Consonant_Preceding_Repha
D54 D56 Consonant_Dead
D57 Vowel_Dependent
D5F D61 Vowel_Independent
D62 D63 Vowel_Dependent
D66 D6F Number
D7A D7F Consonant_Dead
D82 Bindu
D83 Visarga
D85 D96 Vowel_Independent
D9A DB1 Consonant
DB3 DBB Consonant
DBD Consonant
DC0 DC6 Consonant
DCA Virama
DCF DD4 Vowel_Dependent
DD6 Vowel_Dependent
DD8 DDF Vowel_Dependent
DE6 DEF Number
DF2 DF3 Vowel_Dependent
E01 E2E Consonant
E30 E39 Vowel_Dependent
E3A Pure_Killer
E40 E45 Vowel_Dependent
E47 Vowel_Dependent
E48 E4B Tone_Mark
E4C Consonant_Killer
E4D Bindu
E4E Pure_Killer
E50 E59 Number
E81 E82 Consonant
E84 Consonant
E87 E88 Consonant
E8A Consonant
E8D Consonant
E94 E97 Consonant
E99 E9F Consonant
EA1 EA3 Consonant
EA5 Consonant
EA7 Consonant
EAA EAB Consonant
EAD EAE Consonant
EB0 EB9 Vowel_Dependent
EBB Vowel_Dependent
EBC EBD Consonant_Medial
EC0 EC4 Vowel_Dependent
EC8 ECB Tone_Mark
ECD Bindu
ED0 ED9 Number
EDC EDF Consonant
F20 F33 Number
F35 Syllable_Modifier
F37 Syllable_Modifier
F39 Nukta
F40 F47 Consonant
F49 F6C Consonant
F71 F7D Vowel_Dependent
F7E Bindu
F7F Visarga
F80 F81 Vowel_Dependent
F82 F83 Bindu
F84 Pure_Killer
F85 Avagraha
F88 F8C Consonant_Head_Letter
F8D F97 Consonant_Subjoined
F99 FBC Consonant_Subjoined
FC6 Syllable_Modifier
1000 1020 Consonant
1021 102A Vowel_Independent
102B 1035 Vowel_Dependent
1036 Bindu
1037 Tone_Mark
1038 Visarga
1039 Invisible_Stacker
103A Pure_Killer
103B 103E Consonant_Medial
103F Consonant
1040 1049 Number
104E Consonant_Placeholder
1050 1051 Consonant
1052 1055 Vowel_Independent
1056 1059 Vowel_Dependent
105A 105D Consonant
105E 1060 Consonant_Medial
1061 Consonant
1062 Vowel_Dependent
1063 1064 Tone_Mark
1065 1066 Consonant
1067 1068 Vowel_Dependent
1069 106D Tone_Mark
106E 1070 Consonant
1071 1074 Vowel_Dependent
1075 1081 Consonant
1082 Consonant_Medial
1083 1086 Vowel_Dependent
1087 108D Tone_Mark
108E Consonant
108F Tone_Mark
1090 1099 Number
109A 109B Tone_Mark
109C 109D Vowel_Dependent
1700 1702 Vowel_Independent
1703 170C Consonant
170E 1711 Consonant
1712 1713 Vowel_Dependent
1714 Pure_Killer
1720 1722 Vowel_Independent
1723 1731 Consonant
1732 1733 Vowel_Dependent
1734 Pure_Killer
1740 1742 Vowel_Independent
1743 1751 Consonant
1752 1753 Vowel_Dependent
1760 1762 Vowel_Independent
1763 176C Consonant
176E 1770 Consonant
1772 1773 Vowel_Dependent
1780 17A2 Consonant
17A3 17B3 Vowel_Independent
17B6 17C5 Vowel_Dependent
17C6 Bindu
17C7 Visarga
17C8 Vowel_Dependent
17C9 17CA Register_Shifter
17CB Syllable_Modifier
17CC Consonant_Succeeding_Repha
17CD Consonant_Killer
17CE 17D0 Syllable_Modifier
17D1 Pure_Killer
17D2 Invisible_Stacker
17D3 Syllable_Modifier
17DC Avagraha
17DD Syllable_Modifier
17E0 17E9 Number
1900 Consonant_Placeholder
1901 191E Consonant
1920 1928 Vowel_Dependent
1929 192B Consonant_Subjoined
1930 1931 Consonant_Final
1932 Bindu
1933 1939 Consonant_Final
193A Vowel_Dependent
193B Syllable_Modifier
1946 194F Number
1950 1962 Consonant
1963 196D Vowel
1970 1974 Tone_Letter
1980 19AB Consonant
19B0 19C0 Vowel_Dependent
19C1 19C7 Consonant_Final
19C8 19C9 Tone_Mark
19D0 19D9 Number
1A00 1A16 Consonant
1A17 1A1B Vowel_Dependent
1A20 1A4C Consonant
1A4D 1A52 Vowel_Independent
1A53 1A54 Consonant
1A55 1A56 Consonant_Medial
1A57 1A5E Consonant_Final
1A60 Invisible_Stacker
1A61 1A74 Vowel_Dependent
1A75 1A79 Tone_Mark
1A7A 1A7C Syllable_Modifier
1A7F Syllable_Modifier
1A80 1A89 Number
1A90 1A99 Number
1B00 1B02 Bindu
1B03 Consonant_Succeeding_Repha
1B04 Visarga
1B05 1B12 Vowel_Independent
1B13 1B33 Consonant
1B34 Nukta
1B35 1B43 Vowel_Dependent
1B44 Virama
1B45 1B4B Consonant
1B50 1B59 Number
1B80 Bindu
1B81 Consonant_Succeeding_Repha
1B82 Visarga
1B83 1B89 Vowel_Independent
1B8A 1BA0 Consonant
1BA1 1BA3 Consonant_Subjoined
1BA4 1BA9 Vowel_Dependent
1BAA Pure_Killer
1BAB Invisible_Stacker
1BAC 1BAD Consonant_Subjoined
1BAE 1BAF Consonant
1BB0 1BB9 Number
1BBA Avagraha
1BBB 1BBD Consonant
1BBE 1BBF Consonant_Final
1BC0 1BE3 Consonant
1BE4 1BE5 Vowel_Independent
1BE6 Nukta
1BE7 1BEF Vowel_Dependent
1BF0 1BF1 Consonant_Final
1BF2 1BF3 Pure_Killer
1C00 1C23 Consonant
1C24 1C25 Consonant_Subjoined
1C26 1C2C Vowel_Dependent
1C2D 1C33 Consonant_Final
1C34 1C35 Bindu
1C36 Syllable_Modifier
1C37 Nukta
1C40 1C49 Number
1C4D 1C4F Consonant
1CD0 1CD2 Cantillation_Mark
1CD4 1CE1 Cantillation_Mark
1CF2 1CF3 Visarga
1CF4 Cantillation_Mark
1CF8 1CF9 Cantillation_Mark
1DFB Syllable_Modifier
200C Non_Joiner
200D Joiner
2010 2014 Consonant_Placeholder
2074 Syllable_Modifier
2082 2084 Syllable_Modifier
25CC Consonant_Placeholder
A800 A801 Vowel_Independent
A803 A805 Vowel_Independent
A806 Pure_Killer
A807 A80A Consonant
A80B Bindu
A80C A822 Consonant
A823 A827 Vowel_Dependent
A840 A85D Consonant
A85E A861 Vowel
A862 A865 Consonant
A866 Vowel
A867 A868 Consonant_Subjoined
A869 A870 Consonant
A871 Consonant_Subjoined
A872 Consonant
A873 Bindu
A880 Bindu
A881 Visarga
A882 A891 Vowel_Independent
A892 A8B3 Consonant
A8B4 Consonant_Final
A8B5 A8C3 Vowel_Dependent
A8C4 Virama
A8C5 Bindu
A8D0 A8D9 Number
A8E0 A8F1 Cantillation_Mark
A900 A909 Number
A90A A921 Consonant
A922 A92A Vowel
A92B A92D Tone_Mark
A930 A946 Consonant
A947 A94E Vowel_Dependent
A94F A952 Consonant_Final
A953 Pure_Killer
A980 A981 Bindu
A982 Consonant_Succeeding_Repha
A983 Visarga
A984 A988 Vowel_Independent
A989 A98B Consonant
A98C A98E Vowel_Independent
A98F A9B2 Consonant
A9B3 Nukta
A9B4 A9BC Vowel_Dependent
A9BD Consonant_Subjoined
A9BE A9BF Consonant_Medial
A9C0 Virama
A9D0 A9D9 Number
A9E0 A9E4 Consonant
A9E5 Vowel_Dependent
A9E7 A9EF Consonant
A9F0 A9F9 Number
A9FA A9FE Consonant
AA00 AA05 Vowel_Independent
AA06 AA28 Consonant
AA29 AA32 Vowel_Dependent
AA33 AA36 Consonant_Medial
AA40 AA4D Consonant_Final
AA50 AA59 Number
AA60 AA6F Consonant
AA71 AA73 Consonant
AA74 AA76 Consonant_Placeholder
AA7A Consonant
AA7B AA7D Tone_Mark
AA7E AAAF Consonant
AAB0 AABE Vowel_Dependent
AABF Tone_Mark
AAC0 Tone_Letter
AAC1 Tone_Mark
AAC2 Tone_Letter
AAE0 AAE1 Vowel_Independent
AAE2 AAEA Consonant
AAEB AAEF Vowel_Dependent
AAF5 Visarga
AAF6 Invisible_Stacker
ABC0 ABCD Consonant
ABCE ABCF Vowel_Independent
ABD0 Consonant
ABD1 Vowel_Independent
ABD2 ABDA Consonant
ABDB ABE2 Consonant_Final
ABE3 ABEA Vowel_Dependent
ABEC Tone_Mark
ABED Pure_Killer
ABF0 ABF9 Number
10A00 Consonant
10A01 10A03 Vowel_Dependent
10A05 10A06 Vowel_Dependent
10A0C 10A0D Vowel_Dependent
10A0E Bindu
10A0F Visarga
10A10 10A13 Consonant
10A15 10A17 Consonant
10A19 10A33 Consonant
10A38 10A3A Nukta
10A3F Invisible_Stacker
10A40 10A47 Number
11000 11001 Bindu
11002 Visarga
11003 11004 Consonant_With_Stacker
11005 11012 Vowel_Independent
11013 11037 Consonant
11038 11045 Vowel_Dependent
11046 Virama
11052 11065 Brahmi_Joining_Number
11066 1106F Number
1107F Number_Joiner
11080 11081 Bindu
11082 Visarga
11083 1108C Vowel_Independent
1108D 110AF Consonant
110B0 110B8 Vowel_Dependent
110B9 Virama
110BA Nukta
11100 11101 Bindu
11102 Visarga
11103 11106 Vowel_Independent
11107 11126 Consonant
11127 11132 Vowel_Dependent
11133 Invisible_Stacker
11134 Pure_Killer
11136 1113F Number
11150 11154 Vowel
11155 11172 Consonant
11173 Nukta
11180 11181 Bindu
11182 Visarga
11183 11190 Vowel_Independent
11191 111B2 Consonant
111B3 111BF Vowel_Dependent
111C0 Virama
111C1 Avagraha
111C2 111C3 Consonant_Prefixed
111CA Nukta
111CB 111CC Vowel_Dependent
111D0 111D9 Number
111E1 111F4 Number
11200 11207 Vowel_Independent
11208 11211 Consonant
11213 1122B Consonant
1122C 11233 Vowel_Dependent
11234 Bindu
11235 Virama
11236 Nukta
11237 Gemination_Mark
1123E Cantillation_Mark
11280 11283 Vowel_Independent
11284 11286 Consonant
11288 Consonant
1128A 1128D Consonant
1128F 1129D Consonant
1129F 112A8 Consonant
112B0 112B9 Vowel_Independent
112BA 112DE Consonant
112DF Bindu
112E0 112E8 Vowel_Dependent
112E9 Nukta
112EA Pure_Killer
112F0 112F9 Number
11300 11302 Bindu
11303 Visarga
11305 1130C Vowel_Independent
1130F 11310 Vowel_Independent
11313 11314 Vowel_Independent
11315 11328 Consonant
1132A 11330 Consonant
11332 11333 Consonant
11335 11339 Consonant
1133C Nukta
1133D Avagraha
1133E 11344 Vowel_Dependent
11347 11348 Vowel_Dependent
1134B 1134C Vowel_Dependent
1134D Virama
11357 Vowel_Dependent
11360 11361 Vowel_Independent
11362 11363 Vowel_Dependent
11366 1136C Cantillation_Mark
11370 11374 Cantillation_Mark
11400 1140D Vowel_Independent
1140E 11434 Consonant
11435 11441 Vowel_Dependent
11442 Virama
11443 11444 Bindu
11445 Visarga
11446 Nukta
11447 Avagraha
11450 11459 Number
11481 1148E Vowel_Independent
1148F 114AF Consonant
114B0 114BE Vowel_Dependent
114BF 114C0 Bindu
114C1 Visarga
114C2 Virama
114C3 Nukta
114C4 Avagraha
114D0 114D9 Number
11580 1158D Vowel_Independent
1158E 115AE Consonant
115AF 115B5 Vowel_Dependent
115B8 115BB Vowel_Dependent
115BC 115BD Bindu
115BE Visarga
115BF Virama
115C0 Nukta
115D8 115DB Vowel_Independent
115DC 115DD Vowel_Dependent
11600 1160D Vowel_Independent
1160E 1162F Consonant
11630 1163C Vowel_Dependent
1163D Bindu
1163E Visarga
1163F Virama
11640 Vowel_Dependent
11650 11659 Number
11680 11689 Vowel_Independent
1168A 116AA Consonant
116AB Bindu
116AC Visarga
116AD 116B5 Vowel_Dependent
116B6 Virama
116B7 Nukta
116C0 116C9 Number
11700 11719 Consonant
1171D 1171F Consonant_Medial
11720 1172A Vowel_Dependent
1172B Pure_Killer
11730 1173B Number
11C00 11C08 Vowel_Independent
11C0A 11C0D Vowel_Independent
11C0E 11C2E Consonant
11C2F 11C36 Vowel_Dependent
11C38 11C3B Vowel_Dependent
11C3C 11C3D Bindu
11C3E Visarga
11C3F Virama
11C40 Avagraha
11C50 11C6C Number
11C72 11C8F Consonant
11C92 11CA7 Consonant_Subjoined
11CA9 11CAF Consonant_Subjoined
11CB0 11CB4 Vowel_Dependent
11CB5 11CB6 Bindu
END

View File

@@ -0,0 +1,20 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToIsc'}{'format'} = 'd'; # single decimal digit
$utf8::SwashInfo{'ToIsc'}{'missing'} = ''; # code point maps to the null string
return <<'END';
END

View File

@@ -0,0 +1,197 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToJg'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToJg'}{'missing'} = 'No_Joining_Group';
return <<'END';
620 Yeh
622 623 Alef
624 Waw
625 Alef
626 Yeh
627 Alef
628 Beh
629 Teh_Marbuta
62A 62B Beh
62C 62E Hah
62F 630 Dal
631 632 Reh
633 634 Seen
635 636 Sad
637 638 Tah
639 63A Ain
63B 63C Gaf
63D 63F Farsi_Yeh
641 Feh
642 Qaf
643 Kaf
644 Lam
645 Meem
646 Noon
647 Heh
648 Waw
649 64A Yeh
66E Beh
66F Qaf
671 673 Alef
675 Alef
676 677 Waw
678 Yeh
679 680 Beh
681 687 Hah
688 690 Dal
691 699 Reh
69A 69C Seen
69D 69E Sad
69F Tah
6A0 Ain
6A1 6A6 Feh
6A7 6A8 Qaf
6A9 Gaf
6AA Swash_Kaf
6AB Gaf
6AC 6AE Kaf
6AF 6B4 Gaf
6B5 6B8 Lam
6B9 6BC Noon
6BD Nya
6BE Knotted_Heh
6BF Hah
6C0 Teh_Marbuta
6C1 6C2 Heh_Goal
6C3 Teh_Marbuta_Goal
6C4 6CB Waw
6CC Farsi_Yeh
6CD Yeh_With_Tail
6CE Farsi_Yeh
6CF Waw
6D0 6D1 Yeh
6D2 6D3 Yeh_Barree
6D5 Teh_Marbuta
6EE Dal
6EF Reh
6FA Seen
6FB Sad
6FC Ain
6FF Knotted_Heh
710 Alaph
712 Beth
713 714 Gamal
715 716 Dalath_Rish
717 He
718 Syriac_Waw
719 Zain
71A Heth
71B 71C Teth
71D Yudh
71E Yudh_He
71F Kaph
720 Lamadh
721 Mim
722 Nun
723 Semkath
724 Final_Semkath
725 E
726 Pe
727 Reversed_Pe
728 Sadhe
729 Qaph
72A Dalath_Rish
72B Shin
72C Taw
72D Beth
72E Gamal
72F Dalath_Rish
74D Zhain
74E Khaph
74F Fe
750 756 Beh
757 758 Hah
759 75A Dal
75B Reh
75C Seen
75D 75F Ain
760 761 Feh
762 764 Gaf
765 766 Meem
767 769 Noon
76A Lam
76B 76C Reh
76D Seen
76E 76F Hah
770 Seen
771 Reh
772 Hah
773 774 Alef
775 776 Farsi_Yeh
777 Yeh
778 779 Waw
77A 77B Burushaski_Yeh_Barree
77C Hah
77D 77E Seen
77F Kaf
8A0 8A1 Beh
8A2 Hah
8A3 Tah
8A4 Feh
8A5 Qaf
8A6 Lam
8A7 Meem
8A8 8A9 Yeh
8AA Reh
8AB Waw
8AC Rohingya_Yeh
8AE Dal
8AF Sad
8B0 Gaf
8B1 Straight_Waw
8B2 Reh
8B3 Ain
8B4 Kaf
8B6 8B8 Beh
8B9 Reh
8BA Yeh
8BB African_Feh
8BC African_Qaf
8BD African_Noon
10AC0 Manichaean_Aleph
10AC1 10AC2 Manichaean_Beth
10AC3 10AC4 Manichaean_Gimel
10AC5 Manichaean_Daleth
10AC7 Manichaean_Waw
10AC9 10ACA Manichaean_Zayin
10ACD Manichaean_Heth
10ACE Manichaean_Teth
10ACF Manichaean_Yodh
10AD0 10AD2 Manichaean_Kaph
10AD3 Manichaean_Lamedh
10AD4 Manichaean_Dhamedh
10AD5 Manichaean_Thamedh
10AD6 Manichaean_Mem
10AD7 Manichaean_Nun
10AD8 Manichaean_Samekh
10AD9 10ADA Manichaean_Ayin
10ADB 10ADC Manichaean_Pe
10ADD Manichaean_Sadhe
10ADE 10AE0 Manichaean_Qoph
10AE1 Manichaean_Resh
10AE4 Manichaean_Taw
10AEB Manichaean_One
10AEC Manichaean_Five
10AED Manichaean_Ten
10AEE Manichaean_Twenty
10AEF Manichaean_Hundred
END

View File

@@ -0,0 +1,431 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToJt'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToJt'}{'missing'} = 'Non_Joining';
return <<'END';
AD T
300 36F T
483 489 T
591 5BD T
5BF T
5C1 5C2 T
5C4 5C5 T
5C7 T
610 61A T
61C T
620 D
622 625 R
626 D
627 R
628 D
629 R
62A 62E D
62F 632 R
633 63F D
640 C
641 647 D
648 R
649 64A D
64B 65F T
66E 66F D
670 T
671 673 R
675 677 R
678 687 D
688 699 R
69A 6BF D
6C0 R
6C1 6C2 D
6C3 6CB R
6CC D
6CD R
6CE D
6CF R
6D0 6D1 D
6D2 6D3 R
6D5 R
6D6 6DC T
6DF 6E4 T
6E7 6E8 T
6EA 6ED T
6EE 6EF R
6FA 6FC D
6FF D
70F T
710 R
711 T
712 714 D
715 719 R
71A 71D D
71E R
71F 727 D
728 R
729 D
72A R
72B D
72C R
72D 72E D
72F R
730 74A T
74D R
74E 758 D
759 75B R
75C 76A D
76B 76C R
76D 770 D
771 R
772 D
773 774 R
775 777 D
778 779 R
77A 77F D
7A6 7B0 T
7CA 7EA D
7EB 7F3 T
7FA C
816 819 T
81B 823 T
825 827 T
829 82D T
840 R
841 845 D
846 847 R
848 D
849 R
84A 853 D
854 R
855 D
859 85B T
8A0 8A9 D
8AA 8AC R
8AE R
8AF 8B0 D
8B1 8B2 R
8B3 8B4 D
8B6 8B8 D
8B9 R
8BA 8BD D
8D4 8E1 T
8E3 902 T
93A T
93C T
941 948 T
94D T
951 957 T
962 963 T
981 T
9BC T
9C1 9C4 T
9CD T
9E2 9E3 T
A01 A02 T
A3C T
A41 A42 T
A47 A48 T
A4B A4D T
A51 T
A70 A71 T
A75 T
A81 A82 T
ABC T
AC1 AC5 T
AC7 AC8 T
ACD T
AE2 AE3 T
B01 T
B3C T
B3F T
B41 B44 T
B4D T
B56 T
B62 B63 T
B82 T
BC0 T
BCD T
C00 T
C3E C40 T
C46 C48 T
C4A C4D T
C55 C56 T
C62 C63 T
C81 T
CBC T
CBF T
CC6 T
CCC CCD T
CE2 CE3 T
D01 T
D41 D44 T
D4D T
D62 D63 T
DCA T
DD2 DD4 T
DD6 T
E31 T
E34 E3A T
E47 E4E T
EB1 T
EB4 EB9 T
EBB EBC T
EC8 ECD T
F18 F19 T
F35 T
F37 T
F39 T
F71 F7E T
F80 F84 T
F86 F87 T
F8D F97 T
F99 FBC T
FC6 T
102D 1030 T
1032 1037 T
1039 103A T
103D 103E T
1058 1059 T
105E 1060 T
1071 1074 T
1082 T
1085 1086 T
108D T
109D T
135D 135F T
1712 1714 T
1732 1734 T
1752 1753 T
1772 1773 T
17B4 17B5 T
17B7 17BD T
17C6 T
17C9 17D3 T
17DD T
1807 D
180A C
180B 180D T
1820 1877 D
1885 1886 T
1887 18A8 D
18A9 T
18AA D
1920 1922 T
1927 1928 T
1932 T
1939 193B T
1A17 1A18 T
1A1B T
1A56 T
1A58 1A5E T
1A60 T
1A62 T
1A65 1A6C T
1A73 1A7C T
1A7F T
1AB0 1ABE T
1B00 1B03 T
1B34 T
1B36 1B3A T
1B3C T
1B42 T
1B6B 1B73 T
1B80 1B81 T
1BA2 1BA5 T
1BA8 1BA9 T
1BAB 1BAD T
1BE6 T
1BE8 1BE9 T
1BED T
1BEF 1BF1 T
1C2C 1C33 T
1C36 1C37 T
1CD0 1CD2 T
1CD4 1CE0 T
1CE2 1CE8 T
1CED T
1CF4 T
1CF8 1CF9 T
1DC0 1DF5 T
1DFB 1DFF T
200B T
200D C
200E 200F T
202A 202E T
2060 2064 T
206A 206F T
20D0 20F0 T
2CEF 2CF1 T
2D7F T
2DE0 2DFF T
302A 302D T
3099 309A T
A66F A672 T
A674 A67D T
A69E A69F T
A6F0 A6F1 T
A802 T
A806 T
A80B T
A825 A826 T
A840 A871 D
A872 L
A8C4 A8C5 T
A8E0 A8F1 T
A926 A92D T
A947 A951 T
A980 A982 T
A9B3 T
A9B6 A9B9 T
A9BC T
A9E5 T
AA29 AA2E T
AA31 AA32 T
AA35 AA36 T
AA43 T
AA4C T
AA7C T
AAB0 T
AAB2 AAB4 T
AAB7 AAB8 T
AABE AABF T
AAC1 T
AAEC AAED T
AAF6 T
ABE5 T
ABE8 T
ABED T
FB1E T
FE00 FE0F T
FE20 FE2F T
FEFF T
FFF9 FFFB T
101FD T
102E0 T
10376 1037A T
10A01 10A03 T
10A05 10A06 T
10A0C 10A0F T
10A38 10A3A T
10A3F T
10AC0 10AC4 D
10AC5 R
10AC7 R
10AC9 10ACA R
10ACD L
10ACE 10AD2 R
10AD3 10AD6 D
10AD7 L
10AD8 10ADC D
10ADD R
10ADE 10AE0 D
10AE1 R
10AE4 R
10AE5 10AE6 T
10AEB 10AEE D
10AEF R
10B80 D
10B81 R
10B82 D
10B83 10B85 R
10B86 10B88 D
10B89 R
10B8A 10B8B D
10B8C R
10B8D D
10B8E 10B8F R
10B90 D
10B91 R
10BA9 10BAC R
10BAD 10BAE D
11001 T
11038 11046 T
1107F 11081 T
110B3 110B6 T
110B9 110BA T
110BD T
11100 11102 T
11127 1112B T
1112D 11134 T
11173 T
11180 11181 T
111B6 111BE T
111CA 111CC T
1122F 11231 T
11234 T
11236 11237 T
1123E T
112DF T
112E3 112EA T
11300 11301 T
1133C T
11340 T
11366 1136C T
11370 11374 T
11438 1143F T
11442 11444 T
11446 T
114B3 114B8 T
114BA T
114BF 114C0 T
114C2 114C3 T
115B2 115B5 T
115BC 115BD T
115BF 115C0 T
115DC 115DD T
11633 1163A T
1163D T
1163F 11640 T
116AB T
116AD T
116B0 116B5 T
116B7 T
1171D 1171F T
11722 11725 T
11727 1172B T
11C30 11C36 T
11C38 11C3D T
11C3F T
11C92 11CA7 T
11CAA 11CB0 T
11CB2 11CB3 T
11CB5 11CB6 T
16AF0 16AF4 T
16B30 16B36 T
16F8F 16F92 T
1BC9D 1BC9E T
1BCA0 1BCA3 T
1D167 1D169 T
1D173 1D182 T
1D185 1D18B T
1D1AA 1D1AD T
1D242 1D244 T
1DA00 1DA36 T
1DA3B 1DA6C T
1DA75 T
1DA84 T
1DA9B 1DA9F T
1DAA1 1DAAF T
1E000 1E006 T
1E008 1E018 T
1E01B 1E021 T
1E023 1E024 T
1E026 1E02A T
1E8D0 1E8D6 T
1E900 1E943 D
1E944 1E94A T
E0001 T
E0020 E007F T
E0100 E01EF T
END

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,681 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The mappings in the non-hash portion of this file must be modified to get the
# correct values by adding the code point ordinal number to each one that is
# numeric.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToLc'}{'format'} = 'ax'; # mapped value in hex; some entries need adjustment
$utf8::SwashInfo{'ToLc'}{'specials_name'} = 'utf8::ToSpecLc'; # Name of hash of special mappings
$utf8::SwashInfo{'ToLc'}{'missing'} = '0'; # code point maps to itself
# Some code points require special handling because their mappings are each to
# multiple code points. These do not appear in the main body, but are defined
# in the hash below.
# Each key is the string of N bytes that together make up the UTF-8 encoding
# for the code point. (i.e. the same as looking at the code point's UTF-8
# under "use bytes"). Each value is the UTF-8 of the translation, for speed.
%utf8::ToSpecLc = (
"\xC4\xB0" => "\x{0069}\x{0307}", # U+0130 => 0069 0307
);
return <<'END';
41 5A 61
C0 D6 E0
D8 DE F8
100 101
102 103
104 105
106 107
108 109
10A 10B
10C 10D
10E 10F
110 111
112 113
114 115
116 117
118 119
11A 11B
11C 11D
11E 11F
120 121
122 123
124 125
126 127
128 129
12A 12B
12C 12D
12E 12F
130 69
132 133
134 135
136 137
139 13A
13B 13C
13D 13E
13F 140
141 142
143 144
145 146
147 148
14A 14B
14C 14D
14E 14F
150 151
152 153
154 155
156 157
158 159
15A 15B
15C 15D
15E 15F
160 161
162 163
164 165
166 167
168 169
16A 16B
16C 16D
16E 16F
170 171
172 173
174 175
176 177
178 FF
179 17A
17B 17C
17D 17E
181 253
182 183
184 185
186 254
187 188
189 18A 256
18B 18C
18E 1DD
18F 259
190 25B
191 192
193 260
194 263
196 269
197 268
198 199
19C 26F
19D 272
19F 275
1A0 1A1
1A2 1A3
1A4 1A5
1A6 280
1A7 1A8
1A9 283
1AC 1AD
1AE 288
1AF 1B0
1B1 1B2 28A
1B3 1B4
1B5 1B6
1B7 292
1B8 1B9
1BC 1BD
1C4 1C6
1C5 1C6
1C7 1C9
1C8 1C9
1CA 1CC
1CB 1CC
1CD 1CE
1CF 1D0
1D1 1D2
1D3 1D4
1D5 1D6
1D7 1D8
1D9 1DA
1DB 1DC
1DE 1DF
1E0 1E1
1E2 1E3
1E4 1E5
1E6 1E7
1E8 1E9
1EA 1EB
1EC 1ED
1EE 1EF
1F1 1F3
1F2 1F3
1F4 1F5
1F6 195
1F7 1BF
1F8 1F9
1FA 1FB
1FC 1FD
1FE 1FF
200 201
202 203
204 205
206 207
208 209
20A 20B
20C 20D
20E 20F
210 211
212 213
214 215
216 217
218 219
21A 21B
21C 21D
21E 21F
220 19E
222 223
224 225
226 227
228 229
22A 22B
22C 22D
22E 22F
230 231
232 233
23A 2C65
23B 23C
23D 19A
23E 2C66
241 242
243 180
244 289
245 28C
246 247
248 249
24A 24B
24C 24D
24E 24F
370 371
372 373
376 377
37F 3F3
386 3AC
388 38A 3AD
38C 3CC
38E 38F 3CD
391 3A1 3B1
3A3 3AB 3C3
3CF 3D7
3D8 3D9
3DA 3DB
3DC 3DD
3DE 3DF
3E0 3E1
3E2 3E3
3E4 3E5
3E6 3E7
3E8 3E9
3EA 3EB
3EC 3ED
3EE 3EF
3F4 3B8
3F7 3F8
3F9 3F2
3FA 3FB
3FD 3FF 37B
400 40F 450
410 42F 430
460 461
462 463
464 465
466 467
468 469
46A 46B
46C 46D
46E 46F
470 471
472 473
474 475
476 477
478 479
47A 47B
47C 47D
47E 47F
480 481
48A 48B
48C 48D
48E 48F
490 491
492 493
494 495
496 497
498 499
49A 49B
49C 49D
49E 49F
4A0 4A1
4A2 4A3
4A4 4A5
4A6 4A7
4A8 4A9
4AA 4AB
4AC 4AD
4AE 4AF
4B0 4B1
4B2 4B3
4B4 4B5
4B6 4B7
4B8 4B9
4BA 4BB
4BC 4BD
4BE 4BF
4C0 4CF
4C1 4C2
4C3 4C4
4C5 4C6
4C7 4C8
4C9 4CA
4CB 4CC
4CD 4CE
4D0 4D1
4D2 4D3
4D4 4D5
4D6 4D7
4D8 4D9
4DA 4DB
4DC 4DD
4DE 4DF
4E0 4E1
4E2 4E3
4E4 4E5
4E6 4E7
4E8 4E9
4EA 4EB
4EC 4ED
4EE 4EF
4F0 4F1
4F2 4F3
4F4 4F5
4F6 4F7
4F8 4F9
4FA 4FB
4FC 4FD
4FE 4FF
500 501
502 503
504 505
506 507
508 509
50A 50B
50C 50D
50E 50F
510 511
512 513
514 515
516 517
518 519
51A 51B
51C 51D
51E 51F
520 521
522 523
524 525
526 527
528 529
52A 52B
52C 52D
52E 52F
531 556 561
10A0 10C5 2D00
10C7 2D27
10CD 2D2D
13A0 13EF AB70
13F0 13F5 13F8
1E00 1E01
1E02 1E03
1E04 1E05
1E06 1E07
1E08 1E09
1E0A 1E0B
1E0C 1E0D
1E0E 1E0F
1E10 1E11
1E12 1E13
1E14 1E15
1E16 1E17
1E18 1E19
1E1A 1E1B
1E1C 1E1D
1E1E 1E1F
1E20 1E21
1E22 1E23
1E24 1E25
1E26 1E27
1E28 1E29
1E2A 1E2B
1E2C 1E2D
1E2E 1E2F
1E30 1E31
1E32 1E33
1E34 1E35
1E36 1E37
1E38 1E39
1E3A 1E3B
1E3C 1E3D
1E3E 1E3F
1E40 1E41
1E42 1E43
1E44 1E45
1E46 1E47
1E48 1E49
1E4A 1E4B
1E4C 1E4D
1E4E 1E4F
1E50 1E51
1E52 1E53
1E54 1E55
1E56 1E57
1E58 1E59
1E5A 1E5B
1E5C 1E5D
1E5E 1E5F
1E60 1E61
1E62 1E63
1E64 1E65
1E66 1E67
1E68 1E69
1E6A 1E6B
1E6C 1E6D
1E6E 1E6F
1E70 1E71
1E72 1E73
1E74 1E75
1E76 1E77
1E78 1E79
1E7A 1E7B
1E7C 1E7D
1E7E 1E7F
1E80 1E81
1E82 1E83
1E84 1E85
1E86 1E87
1E88 1E89
1E8A 1E8B
1E8C 1E8D
1E8E 1E8F
1E90 1E91
1E92 1E93
1E94 1E95
1E9E DF
1EA0 1EA1
1EA2 1EA3
1EA4 1EA5
1EA6 1EA7
1EA8 1EA9
1EAA 1EAB
1EAC 1EAD
1EAE 1EAF
1EB0 1EB1
1EB2 1EB3
1EB4 1EB5
1EB6 1EB7
1EB8 1EB9
1EBA 1EBB
1EBC 1EBD
1EBE 1EBF
1EC0 1EC1
1EC2 1EC3
1EC4 1EC5
1EC6 1EC7
1EC8 1EC9
1ECA 1ECB
1ECC 1ECD
1ECE 1ECF
1ED0 1ED1
1ED2 1ED3
1ED4 1ED5
1ED6 1ED7
1ED8 1ED9
1EDA 1EDB
1EDC 1EDD
1EDE 1EDF
1EE0 1EE1
1EE2 1EE3
1EE4 1EE5
1EE6 1EE7
1EE8 1EE9
1EEA 1EEB
1EEC 1EED
1EEE 1EEF
1EF0 1EF1
1EF2 1EF3
1EF4 1EF5
1EF6 1EF7
1EF8 1EF9
1EFA 1EFB
1EFC 1EFD
1EFE 1EFF
1F08 1F0F 1F00
1F18 1F1D 1F10
1F28 1F2F 1F20
1F38 1F3F 1F30
1F48 1F4D 1F40
1F59 1F51
1F5B 1F53
1F5D 1F55
1F5F 1F57
1F68 1F6F 1F60
1F88 1F8F 1F80
1F98 1F9F 1F90
1FA8 1FAF 1FA0
1FB8 1FB9 1FB0
1FBA 1FBB 1F70
1FBC 1FB3
1FC8 1FCB 1F72
1FCC 1FC3
1FD8 1FD9 1FD0
1FDA 1FDB 1F76
1FE8 1FE9 1FE0
1FEA 1FEB 1F7A
1FEC 1FE5
1FF8 1FF9 1F78
1FFA 1FFB 1F7C
1FFC 1FF3
2126 3C9
212A 6B
212B E5
2132 214E
2160 216F 2170
2183 2184
24B6 24CF 24D0
2C00 2C2E 2C30
2C60 2C61
2C62 26B
2C63 1D7D
2C64 27D
2C67 2C68
2C69 2C6A
2C6B 2C6C
2C6D 251
2C6E 271
2C6F 250
2C70 252
2C72 2C73
2C75 2C76
2C7E 2C7F 23F
2C80 2C81
2C82 2C83
2C84 2C85
2C86 2C87
2C88 2C89
2C8A 2C8B
2C8C 2C8D
2C8E 2C8F
2C90 2C91
2C92 2C93
2C94 2C95
2C96 2C97
2C98 2C99
2C9A 2C9B
2C9C 2C9D
2C9E 2C9F
2CA0 2CA1
2CA2 2CA3
2CA4 2CA5
2CA6 2CA7
2CA8 2CA9
2CAA 2CAB
2CAC 2CAD
2CAE 2CAF
2CB0 2CB1
2CB2 2CB3
2CB4 2CB5
2CB6 2CB7
2CB8 2CB9
2CBA 2CBB
2CBC 2CBD
2CBE 2CBF
2CC0 2CC1
2CC2 2CC3
2CC4 2CC5
2CC6 2CC7
2CC8 2CC9
2CCA 2CCB
2CCC 2CCD
2CCE 2CCF
2CD0 2CD1
2CD2 2CD3
2CD4 2CD5
2CD6 2CD7
2CD8 2CD9
2CDA 2CDB
2CDC 2CDD
2CDE 2CDF
2CE0 2CE1
2CE2 2CE3
2CEB 2CEC
2CED 2CEE
2CF2 2CF3
A640 A641
A642 A643
A644 A645
A646 A647
A648 A649
A64A A64B
A64C A64D
A64E A64F
A650 A651
A652 A653
A654 A655
A656 A657
A658 A659
A65A A65B
A65C A65D
A65E A65F
A660 A661
A662 A663
A664 A665
A666 A667
A668 A669
A66A A66B
A66C A66D
A680 A681
A682 A683
A684 A685
A686 A687
A688 A689
A68A A68B
A68C A68D
A68E A68F
A690 A691
A692 A693
A694 A695
A696 A697
A698 A699
A69A A69B
A722 A723
A724 A725
A726 A727
A728 A729
A72A A72B
A72C A72D
A72E A72F
A732 A733
A734 A735
A736 A737
A738 A739
A73A A73B
A73C A73D
A73E A73F
A740 A741
A742 A743
A744 A745
A746 A747
A748 A749
A74A A74B
A74C A74D
A74E A74F
A750 A751
A752 A753
A754 A755
A756 A757
A758 A759
A75A A75B
A75C A75D
A75E A75F
A760 A761
A762 A763
A764 A765
A766 A767
A768 A769
A76A A76B
A76C A76D
A76E A76F
A779 A77A
A77B A77C
A77D 1D79
A77E A77F
A780 A781
A782 A783
A784 A785
A786 A787
A78B A78C
A78D 265
A790 A791
A792 A793
A796 A797
A798 A799
A79A A79B
A79C A79D
A79E A79F
A7A0 A7A1
A7A2 A7A3
A7A4 A7A5
A7A6 A7A7
A7A8 A7A9
A7AA 266
A7AB 25C
A7AC 261
A7AD 26C
A7AE 26A
A7B0 29E
A7B1 287
A7B2 29D
A7B3 AB53
A7B4 A7B5
A7B6 A7B7
FF21 FF3A FF41
10400 10427 10428
104B0 104D3 104D8
10C80 10CB2 10CC0
118A0 118BF 118C0
1E900 1E921 1E922
END

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,134 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToNFCQC'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToNFCQC'}{'missing'} = 'Yes';
return <<'END';
300 304 M
306 30C M
30F M
311 M
313 314 M
31B M
323 328 M
32D 32E M
330 331 M
338 M
340 341 N
342 M
343 344 N
345 M
374 N
37E N
387 N
653 655 M
93C M
958 95F N
9BE M
9D7 M
9DC 9DD N
9DF N
A33 N
A36 N
A59 A5B N
A5E N
B3E M
B56 B57 M
B5C B5D N
BBE M
BD7 M
C56 M
CC2 M
CD5 CD6 M
D3E M
D57 M
DCA M
DCF M
DDF M
F43 N
F4D N
F52 N
F57 N
F5C N
F69 N
F73 N
F75 F76 N
F78 N
F81 N
F93 N
F9D N
FA2 N
FA7 N
FAC N
FB9 N
102E M
1161 1175 M
11A8 11C2 M
1B35 M
1F71 N
1F73 N
1F75 N
1F77 N
1F79 N
1F7B N
1F7D N
1FBB N
1FBE N
1FC9 N
1FCB N
1FD3 N
1FDB N
1FE3 N
1FEB N
1FEE 1FEF N
1FF9 N
1FFB N
1FFD N
2000 2001 N
2126 N
212A 212B N
2329 232A N
2ADC N
3099 309A M
F900 FA0D N
FA10 N
FA12 N
FA15 FA1E N
FA20 N
FA22 N
FA25 FA26 N
FA2A FA6D N
FA70 FAD9 N
FB1D N
FB1F N
FB2A FB36 N
FB38 FB3C N
FB3E N
FB40 FB41 N
FB43 FB44 N
FB46 FB4E N
110BA M
11127 M
1133E M
11357 M
114B0 M
114BA M
114BD M
115AF M
1D15E 1D164 N
1D1BB 1D1C0 N
2F800 2FA1D N
END

View File

@@ -0,0 +1,251 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToNFDQC'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToNFDQC'}{'missing'} = 'Yes';
return <<'END';
C0 C5 N
C7 CF N
D1 D6 N
D9 DD N
E0 E5 N
E7 EF N
F1 F6 N
F9 FD N
FF 10F N
112 125 N
128 130 N
134 137 N
139 13E N
143 148 N
14C 151 N
154 165 N
168 17E N
1A0 1A1 N
1AF 1B0 N
1CD 1DC N
1DE 1E3 N
1E6 1F0 N
1F4 1F5 N
1F8 21B N
21E 21F N
226 233 N
340 341 N
343 344 N
374 N
37E N
385 38A N
38C N
38E 390 N
3AA 3B0 N
3CA 3CE N
3D3 3D4 N
400 401 N
403 N
407 N
40C 40E N
419 N
439 N
450 451 N
453 N
457 N
45C 45E N
476 477 N
4C1 4C2 N
4D0 4D3 N
4D6 4D7 N
4DA 4DF N
4E2 4E7 N
4EA 4F5 N
4F8 4F9 N
622 626 N
6C0 N
6C2 N
6D3 N
929 N
931 N
934 N
958 95F N
9CB 9CC N
9DC 9DD N
9DF N
A33 N
A36 N
A59 A5B N
A5E N
B48 N
B4B B4C N
B5C B5D N
B94 N
BCA BCC N
C48 N
CC0 N
CC7 CC8 N
CCA CCB N
D4A D4C N
DDA N
DDC DDE N
F43 N
F4D N
F52 N
F57 N
F5C N
F69 N
F73 N
F75 F76 N
F78 N
F81 N
F93 N
F9D N
FA2 N
FA7 N
FAC N
FB9 N
1026 N
1B06 N
1B08 N
1B0A N
1B0C N
1B0E N
1B12 N
1B3B N
1B3D N
1B40 1B41 N
1B43 N
1E00 1E99 N
1E9B N
1EA0 1EF9 N
1F00 1F15 N
1F18 1F1D N
1F20 1F45 N
1F48 1F4D N
1F50 1F57 N
1F59 N
1F5B N
1F5D N
1F5F 1F7D N
1F80 1FB4 N
1FB6 1FBC N
1FBE N
1FC1 1FC4 N
1FC6 1FD3 N
1FD6 1FDB N
1FDD 1FEF N
1FF2 1FF4 N
1FF6 1FFD N
2000 2001 N
2126 N
212A 212B N
219A 219B N
21AE N
21CD 21CF N
2204 N
2209 N
220C N
2224 N
2226 N
2241 N
2244 N
2247 N
2249 N
2260 N
2262 N
226D 2271 N
2274 2275 N
2278 2279 N
2280 2281 N
2284 2285 N
2288 2289 N
22AC 22AF N
22E0 22E3 N
22EA 22ED N
2329 232A N
2ADC N
304C N
304E N
3050 N
3052 N
3054 N
3056 N
3058 N
305A N
305C N
305E N
3060 N
3062 N
3065 N
3067 N
3069 N
3070 3071 N
3073 3074 N
3076 3077 N
3079 307A N
307C 307D N
3094 N
309E N
30AC N
30AE N
30B0 N
30B2 N
30B4 N
30B6 N
30B8 N
30BA N
30BC N
30BE N
30C0 N
30C2 N
30C5 N
30C7 N
30C9 N
30D0 30D1 N
30D3 30D4 N
30D6 30D7 N
30D9 30DA N
30DC 30DD N
30F4 N
30F7 30FA N
30FE N
AC00 D7A3 N
F900 FA0D N
FA10 N
FA12 N
FA15 FA1E N
FA20 N
FA22 N
FA25 FA26 N
FA2A FA6D N
FA70 FAD9 N
FB1D N
FB1F N
FB2A FB36 N
FB38 FB3C N
FB3E N
FB40 FB41 N
FB43 FB44 N
FB46 FB4E N
1109A N
1109C N
110AB N
1112E 1112F N
1134B 1134C N
114BB 114BC N
114BE N
115BA 115BB N
1D15E 1D164 N
1D1BB 1D1C0 N
2F800 2FA1D N
END

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,310 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToNFKCQC'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToNFKCQC'}{'missing'} = 'Yes';
return <<'END';
A0 N
A8 N
AA N
AF N
B2 B5 N
B8 BA N
BC BE N
132 133 N
13F 140 N
149 N
17F N
1C4 1CC N
1F1 1F3 N
2B0 2B8 N
2D8 2DD N
2E0 2E4 N
300 304 M
306 30C M
30F M
311 M
313 314 M
31B M
323 328 M
32D 32E M
330 331 M
338 M
340 341 N
342 M
343 344 N
345 M
374 N
37A N
37E N
384 385 N
387 N
3D0 3D6 N
3F0 3F2 N
3F4 3F5 N
3F9 N
587 N
653 655 M
675 678 N
93C M
958 95F N
9BE M
9D7 M
9DC 9DD N
9DF N
A33 N
A36 N
A59 A5B N
A5E N
B3E M
B56 B57 M
B5C B5D N
BBE M
BD7 M
C56 M
CC2 M
CD5 CD6 M
D3E M
D57 M
DCA M
DCF M
DDF M
E33 N
EB3 N
EDC EDD N
F0C N
F43 N
F4D N
F52 N
F57 N
F5C N
F69 N
F73 N
F75 F79 N
F81 N
F93 N
F9D N
FA2 N
FA7 N
FAC N
FB9 N
102E M
10FC N
1161 1175 M
11A8 11C2 M
1B35 M
1D2C 1D2E N
1D30 1D3A N
1D3C 1D4D N
1D4F 1D6A N
1D78 N
1D9B 1DBF N
1E9A 1E9B N
1F71 N
1F73 N
1F75 N
1F77 N
1F79 N
1F7B N
1F7D N
1FBB N
1FBD 1FC1 N
1FC9 N
1FCB N
1FCD 1FCF N
1FD3 N
1FDB N
1FDD 1FDF N
1FE3 N
1FEB N
1FED 1FEF N
1FF9 N
1FFB N
1FFD 1FFE N
2000 200A N
2011 N
2017 N
2024 2026 N
202F N
2033 2034 N
2036 2037 N
203C N
203E N
2047 2049 N
2057 N
205F N
2070 2071 N
2074 208E N
2090 209C N
20A8 N
2100 2103 N
2105 2107 N
2109 2113 N
2115 2116 N
2119 211D N
2120 2122 N
2124 N
2126 N
2128 N
212A 212D N
212F 2131 N
2133 2139 N
213B 2140 N
2145 2149 N
2150 217F N
2189 N
222C 222D N
222F 2230 N
2329 232A N
2460 24EA N
2A0C N
2A74 2A76 N
2ADC N
2C7C 2C7D N
2D6F N
2E9F N
2EF3 N
2F00 2FD5 N
3000 N
3036 N
3038 303A N
3099 309A M
309B 309C N
309F N
30FF N
3131 318E N
3192 319F N
3200 321E N
3220 3247 N
3250 327E N
3280 32FE N
3300 33FF N
A69C A69D N
A770 N
A7F8 A7F9 N
AB5C AB5F N
F900 FA0D N
FA10 N
FA12 N
FA15 FA1E N
FA20 N
FA22 N
FA25 FA26 N
FA2A FA6D N
FA70 FAD9 N
FB00 FB06 N
FB13 FB17 N
FB1D N
FB1F FB36 N
FB38 FB3C N
FB3E N
FB40 FB41 N
FB43 FB44 N
FB46 FBB1 N
FBD3 FD3D N
FD50 FD8F N
FD92 FDC7 N
FDF0 FDFC N
FE10 FE19 N
FE30 FE44 N
FE47 FE52 N
FE54 FE66 N
FE68 FE6B N
FE70 FE72 N
FE74 N
FE76 FEFC N
FF01 FFBE N
FFC2 FFC7 N
FFCA FFCF N
FFD2 FFD7 N
FFDA FFDC N
FFE0 FFE6 N
FFE8 FFEE N
110BA M
11127 M
1133E M
11357 M
114B0 M
114BA M
114BD M
115AF M
1D15E 1D164 N
1D1BB 1D1C0 N
1D400 1D454 N
1D456 1D49C N
1D49E 1D49F N
1D4A2 N
1D4A5 1D4A6 N
1D4A9 1D4AC N
1D4AE 1D4B9 N
1D4BB N
1D4BD 1D4C3 N
1D4C5 1D505 N
1D507 1D50A N
1D50D 1D514 N
1D516 1D51C N
1D51E 1D539 N
1D53B 1D53E N
1D540 1D544 N
1D546 N
1D54A 1D550 N
1D552 1D6A5 N
1D6A8 1D7CB N
1D7CE 1D7FF N
1EE00 1EE03 N
1EE05 1EE1F N
1EE21 1EE22 N
1EE24 N
1EE27 N
1EE29 1EE32 N
1EE34 1EE37 N
1EE39 N
1EE3B N
1EE42 N
1EE47 N
1EE49 N
1EE4B N
1EE4D 1EE4F N
1EE51 1EE52 N
1EE54 N
1EE57 N
1EE59 N
1EE5B N
1EE5D N
1EE5F N
1EE61 1EE62 N
1EE64 N
1EE67 1EE6A N
1EE6C 1EE72 N
1EE74 1EE77 N
1EE79 1EE7C N
1EE7E N
1EE80 1EE89 N
1EE8B 1EE9B N
1EEA1 1EEA3 N
1EEA5 1EEA9 N
1EEAB 1EEBB N
1F100 1F10A N
1F110 1F12E N
1F130 1F14F N
1F16A 1F16B N
1F190 N
1F200 1F202 N
1F210 1F23B N
1F240 1F248 N
1F250 1F251 N
2F800 2FA1D N
END

View File

@@ -0,0 +1,410 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToNFKDQC'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToNFKDQC'}{'missing'} = 'Yes';
return <<'END';
A0 N
A8 N
AA N
AF N
B2 B5 N
B8 BA N
BC BE N
C0 C5 N
C7 CF N
D1 D6 N
D9 DD N
E0 E5 N
E7 EF N
F1 F6 N
F9 FD N
FF 10F N
112 125 N
128 130 N
132 137 N
139 140 N
143 149 N
14C 151 N
154 165 N
168 17F N
1A0 1A1 N
1AF 1B0 N
1C4 1DC N
1DE 1E3 N
1E6 1F5 N
1F8 21B N
21E 21F N
226 233 N
2B0 2B8 N
2D8 2DD N
2E0 2E4 N
340 341 N
343 344 N
374 N
37A N
37E N
384 38A N
38C N
38E 390 N
3AA 3B0 N
3CA 3CE N
3D0 3D6 N
3F0 3F2 N
3F4 3F5 N
3F9 N
400 401 N
403 N
407 N
40C 40E N
419 N
439 N
450 451 N
453 N
457 N
45C 45E N
476 477 N
4C1 4C2 N
4D0 4D3 N
4D6 4D7 N
4DA 4DF N
4E2 4E7 N
4EA 4F5 N
4F8 4F9 N
587 N
622 626 N
675 678 N
6C0 N
6C2 N
6D3 N
929 N
931 N
934 N
958 95F N
9CB 9CC N
9DC 9DD N
9DF N
A33 N
A36 N
A59 A5B N
A5E N
B48 N
B4B B4C N
B5C B5D N
B94 N
BCA BCC N
C48 N
CC0 N
CC7 CC8 N
CCA CCB N
D4A D4C N
DDA N
DDC DDE N
E33 N
EB3 N
EDC EDD N
F0C N
F43 N
F4D N
F52 N
F57 N
F5C N
F69 N
F73 N
F75 F79 N
F81 N
F93 N
F9D N
FA2 N
FA7 N
FAC N
FB9 N
1026 N
10FC N
1B06 N
1B08 N
1B0A N
1B0C N
1B0E N
1B12 N
1B3B N
1B3D N
1B40 1B41 N
1B43 N
1D2C 1D2E N
1D30 1D3A N
1D3C 1D4D N
1D4F 1D6A N
1D78 N
1D9B 1DBF N
1E00 1E9B N
1EA0 1EF9 N
1F00 1F15 N
1F18 1F1D N
1F20 1F45 N
1F48 1F4D N
1F50 1F57 N
1F59 N
1F5B N
1F5D N
1F5F 1F7D N
1F80 1FB4 N
1FB6 1FC4 N
1FC6 1FD3 N
1FD6 1FDB N
1FDD 1FEF N
1FF2 1FF4 N
1FF6 1FFE N
2000 200A N
2011 N
2017 N
2024 2026 N
202F N
2033 2034 N
2036 2037 N
203C N
203E N
2047 2049 N
2057 N
205F N
2070 2071 N
2074 208E N
2090 209C N
20A8 N
2100 2103 N
2105 2107 N
2109 2113 N
2115 2116 N
2119 211D N
2120 2122 N
2124 N
2126 N
2128 N
212A 212D N
212F 2131 N
2133 2139 N
213B 2140 N
2145 2149 N
2150 217F N
2189 N
219A 219B N
21AE N
21CD 21CF N
2204 N
2209 N
220C N
2224 N
2226 N
222C 222D N
222F 2230 N
2241 N
2244 N
2247 N
2249 N
2260 N
2262 N
226D 2271 N
2274 2275 N
2278 2279 N
2280 2281 N
2284 2285 N
2288 2289 N
22AC 22AF N
22E0 22E3 N
22EA 22ED N
2329 232A N
2460 24EA N
2A0C N
2A74 2A76 N
2ADC N
2C7C 2C7D N
2D6F N
2E9F N
2EF3 N
2F00 2FD5 N
3000 N
3036 N
3038 303A N
304C N
304E N
3050 N
3052 N
3054 N
3056 N
3058 N
305A N
305C N
305E N
3060 N
3062 N
3065 N
3067 N
3069 N
3070 3071 N
3073 3074 N
3076 3077 N
3079 307A N
307C 307D N
3094 N
309B 309C N
309E 309F N
30AC N
30AE N
30B0 N
30B2 N
30B4 N
30B6 N
30B8 N
30BA N
30BC N
30BE N
30C0 N
30C2 N
30C5 N
30C7 N
30C9 N
30D0 30D1 N
30D3 30D4 N
30D6 30D7 N
30D9 30DA N
30DC 30DD N
30F4 N
30F7 30FA N
30FE 30FF N
3131 318E N
3192 319F N
3200 321E N
3220 3247 N
3250 327E N
3280 32FE N
3300 33FF N
A69C A69D N
A770 N
A7F8 A7F9 N
AB5C AB5F N
AC00 D7A3 N
F900 FA0D N
FA10 N
FA12 N
FA15 FA1E N
FA20 N
FA22 N
FA25 FA26 N
FA2A FA6D N
FA70 FAD9 N
FB00 FB06 N
FB13 FB17 N
FB1D N
FB1F FB36 N
FB38 FB3C N
FB3E N
FB40 FB41 N
FB43 FB44 N
FB46 FBB1 N
FBD3 FD3D N
FD50 FD8F N
FD92 FDC7 N
FDF0 FDFC N
FE10 FE19 N
FE30 FE44 N
FE47 FE52 N
FE54 FE66 N
FE68 FE6B N
FE70 FE72 N
FE74 N
FE76 FEFC N
FF01 FFBE N
FFC2 FFC7 N
FFCA FFCF N
FFD2 FFD7 N
FFDA FFDC N
FFE0 FFE6 N
FFE8 FFEE N
1109A N
1109C N
110AB N
1112E 1112F N
1134B 1134C N
114BB 114BC N
114BE N
115BA 115BB N
1D15E 1D164 N
1D1BB 1D1C0 N
1D400 1D454 N
1D456 1D49C N
1D49E 1D49F N
1D4A2 N
1D4A5 1D4A6 N
1D4A9 1D4AC N
1D4AE 1D4B9 N
1D4BB N
1D4BD 1D4C3 N
1D4C5 1D505 N
1D507 1D50A N
1D50D 1D514 N
1D516 1D51C N
1D51E 1D539 N
1D53B 1D53E N
1D540 1D544 N
1D546 N
1D54A 1D550 N
1D552 1D6A5 N
1D6A8 1D7CB N
1D7CE 1D7FF N
1EE00 1EE03 N
1EE05 1EE1F N
1EE21 1EE22 N
1EE24 N
1EE27 N
1EE29 1EE32 N
1EE34 1EE37 N
1EE39 N
1EE3B N
1EE42 N
1EE47 N
1EE49 N
1EE4B N
1EE4D 1EE4F N
1EE51 1EE52 N
1EE54 N
1EE57 N
1EE59 N
1EE5B N
1EE5D N
1EE5F N
1EE61 1EE62 N
1EE64 N
1EE67 1EE6A N
1EE6C 1EE72 N
1EE74 1EE77 N
1EE79 1EE7C N
1EE7E N
1EE80 1EE89 N
1EE8B 1EE9B N
1EEA1 1EEA3 N
1EEA5 1EEA9 N
1EEAB 1EEBB N
1F100 1F10A N
1F110 1F12E N
1F130 1F14F N
1F16A 1F16B N
1F190 N
1F200 1F202 N
1F210 1F23B N
1F240 1F248 N
1F250 1F251 N
2F800 2FA1D N
END

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,479 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToNameAlias'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToNameAlias'}{'missing'} = ''; # code point maps to the null string
return <<'END';
0 NULL: control
0 NUL: abbreviation
1 START OF HEADING: control
1 SOH: abbreviation
2 START OF TEXT: control
2 STX: abbreviation
3 END OF TEXT: control
3 ETX: abbreviation
4 END OF TRANSMISSION: control
4 EOT: abbreviation
5 ENQUIRY: control
5 ENQ: abbreviation
6 ACKNOWLEDGE: control
6 ACK: abbreviation
7 ALERT: control
7 BEL: abbreviation
8 BACKSPACE: control
8 BS: abbreviation
9 CHARACTER TABULATION: control
9 HORIZONTAL TABULATION: control
9 HT: abbreviation
9 TAB: abbreviation
A LINE FEED: control
A NEW LINE: control
A END OF LINE: control
A LF: abbreviation
A NL: abbreviation
A EOL: abbreviation
B LINE TABULATION: control
B VERTICAL TABULATION: control
B VT: abbreviation
C FORM FEED: control
C FF: abbreviation
D CARRIAGE RETURN: control
D CR: abbreviation
E SHIFT OUT: control
E LOCKING-SHIFT ONE: control
E SO: abbreviation
F SHIFT IN: control
F LOCKING-SHIFT ZERO: control
F SI: abbreviation
10 DATA LINK ESCAPE: control
10 DLE: abbreviation
11 DEVICE CONTROL ONE: control
11 DC1: abbreviation
12 DEVICE CONTROL TWO: control
12 DC2: abbreviation
13 DEVICE CONTROL THREE: control
13 DC3: abbreviation
14 DEVICE CONTROL FOUR: control
14 DC4: abbreviation
15 NEGATIVE ACKNOWLEDGE: control
15 NAK: abbreviation
16 SYNCHRONOUS IDLE: control
16 SYN: abbreviation
17 END OF TRANSMISSION BLOCK: control
17 ETB: abbreviation
18 CANCEL: control
18 CAN: abbreviation
19 END OF MEDIUM: control
19 EOM: abbreviation
1A SUBSTITUTE: control
1A SUB: abbreviation
1B ESCAPE: control
1B ESC: abbreviation
1C INFORMATION SEPARATOR FOUR: control
1C FILE SEPARATOR: control
1C FS: abbreviation
1D INFORMATION SEPARATOR THREE: control
1D GROUP SEPARATOR: control
1D GS: abbreviation
1E INFORMATION SEPARATOR TWO: control
1E RECORD SEPARATOR: control
1E RS: abbreviation
1F INFORMATION SEPARATOR ONE: control
1F UNIT SEPARATOR: control
1F US: abbreviation
20 SP: abbreviation
7F DELETE: control
7F DEL: abbreviation
80 PADDING CHARACTER: figment
80 PAD: abbreviation
81 HIGH OCTET PRESET: figment
81 HOP: abbreviation
82 BREAK PERMITTED HERE: control
82 BPH: abbreviation
83 NO BREAK HERE: control
83 NBH: abbreviation
84 INDEX: control
84 IND: abbreviation
85 NEXT LINE: control
85 NEL: abbreviation
86 START OF SELECTED AREA: control
86 SSA: abbreviation
87 END OF SELECTED AREA: control
87 ESA: abbreviation
88 CHARACTER TABULATION SET: control
88 HORIZONTAL TABULATION SET: control
88 HTS: abbreviation
89 CHARACTER TABULATION WITH JUSTIFICATION: control
89 HORIZONTAL TABULATION WITH JUSTIFICATION: control
89 HTJ: abbreviation
8A LINE TABULATION SET: control
8A VERTICAL TABULATION SET: control
8A VTS: abbreviation
8B PARTIAL LINE FORWARD: control
8B PARTIAL LINE DOWN: control
8B PLD: abbreviation
8C PARTIAL LINE BACKWARD: control
8C PARTIAL LINE UP: control
8C PLU: abbreviation
8D REVERSE LINE FEED: control
8D REVERSE INDEX: control
8D RI: abbreviation
8E SINGLE SHIFT TWO: control
8E SINGLE-SHIFT-2: control
8E SS2: abbreviation
8F SINGLE SHIFT THREE: control
8F SINGLE-SHIFT-3: control
8F SS3: abbreviation
90 DEVICE CONTROL STRING: control
90 DCS: abbreviation
91 PRIVATE USE ONE: control
91 PRIVATE USE-1: control
91 PU1: abbreviation
92 PRIVATE USE TWO: control
92 PRIVATE USE-2: control
92 PU2: abbreviation
93 SET TRANSMIT STATE: control
93 STS: abbreviation
94 CANCEL CHARACTER: control
94 CCH: abbreviation
95 MESSAGE WAITING: control
95 MW: abbreviation
96 START OF GUARDED AREA: control
96 START OF PROTECTED AREA: control
96 SPA: abbreviation
97 END OF GUARDED AREA: control
97 END OF PROTECTED AREA: control
97 EPA: abbreviation
98 START OF STRING: control
98 SOS: abbreviation
99 SINGLE GRAPHIC CHARACTER INTRODUCER: figment
99 SGC: abbreviation
9A SINGLE CHARACTER INTRODUCER: control
9A SCI: abbreviation
9B CONTROL SEQUENCE INTRODUCER: control
9B CSI: abbreviation
9C STRING TERMINATOR: control
9C ST: abbreviation
9D OPERATING SYSTEM COMMAND: control
9D OSC: abbreviation
9E PRIVACY MESSAGE: control
9E PM: abbreviation
9F APPLICATION PROGRAM COMMAND: control
9F APC: abbreviation
A0 NBSP: abbreviation
AD SHY: abbreviation
1A2 LATIN CAPITAL LETTER GHA: correction
1A3 LATIN SMALL LETTER GHA: correction
34F CGJ: abbreviation
61C ALM: abbreviation
709 SYRIAC SUBLINEAR COLON SKEWED LEFT: correction
CDE KANNADA LETTER LLLA: correction
E9D LAO LETTER FO FON: correction
E9F LAO LETTER FO FAY: correction
EA3 LAO LETTER RO: correction
EA5 LAO LETTER LO: correction
FD0 TIBETAN MARK BKA- SHOG GI MGO RGYAN: correction
180B FVS1: abbreviation
180C FVS2: abbreviation
180D FVS3: abbreviation
180E MVS: abbreviation
200B ZWSP: abbreviation
200C ZWNJ: abbreviation
200D ZWJ: abbreviation
200E LRM: abbreviation
200F RLM: abbreviation
202A LRE: abbreviation
202B RLE: abbreviation
202C PDF: abbreviation
202D LRO: abbreviation
202E RLO: abbreviation
202F NNBSP: abbreviation
205F MMSP: abbreviation
2060 WJ: abbreviation
2066 LRI: abbreviation
2067 RLI: abbreviation
2068 FSI: abbreviation
2069 PDI: abbreviation
2118 WEIERSTRASS ELLIPTIC FUNCTION: correction
2448 MICR ON US SYMBOL: correction
2449 MICR DASH SYMBOL: correction
2B7A LEFTWARDS TRIANGLE-HEADED ARROW WITH DOUBLE VERTICAL STROKE: correction
2B7C RIGHTWARDS TRIANGLE-HEADED ARROW WITH DOUBLE VERTICAL STROKE: correction
A015 YI SYLLABLE ITERATION MARK: correction
FE00 VS1: abbreviation
FE01 VS2: abbreviation
FE02 VS3: abbreviation
FE03 VS4: abbreviation
FE04 VS5: abbreviation
FE05 VS6: abbreviation
FE06 VS7: abbreviation
FE07 VS8: abbreviation
FE08 VS9: abbreviation
FE09 VS10: abbreviation
FE0A VS11: abbreviation
FE0B VS12: abbreviation
FE0C VS13: abbreviation
FE0D VS14: abbreviation
FE0E VS15: abbreviation
FE0F VS16: abbreviation
FE18 PRESENTATION FORM FOR VERTICAL RIGHT WHITE LENTICULAR BRACKET: correction
FEFF BYTE ORDER MARK: alternate
FEFF BOM: abbreviation
FEFF ZWNBSP: abbreviation
122D4 CUNEIFORM SIGN NU11 TENU: correction
122D5 CUNEIFORM SIGN NU11 OVER NU11 BUR OVER BUR: correction
1D0C5 BYZANTINE MUSICAL SYMBOL FTHORA SKLIRON CHROMA VASIS: correction
E0100 VS17: abbreviation
E0101 VS18: abbreviation
E0102 VS19: abbreviation
E0103 VS20: abbreviation
E0104 VS21: abbreviation
E0105 VS22: abbreviation
E0106 VS23: abbreviation
E0107 VS24: abbreviation
E0108 VS25: abbreviation
E0109 VS26: abbreviation
E010A VS27: abbreviation
E010B VS28: abbreviation
E010C VS29: abbreviation
E010D VS30: abbreviation
E010E VS31: abbreviation
E010F VS32: abbreviation
E0110 VS33: abbreviation
E0111 VS34: abbreviation
E0112 VS35: abbreviation
E0113 VS36: abbreviation
E0114 VS37: abbreviation
E0115 VS38: abbreviation
E0116 VS39: abbreviation
E0117 VS40: abbreviation
E0118 VS41: abbreviation
E0119 VS42: abbreviation
E011A VS43: abbreviation
E011B VS44: abbreviation
E011C VS45: abbreviation
E011D VS46: abbreviation
E011E VS47: abbreviation
E011F VS48: abbreviation
E0120 VS49: abbreviation
E0121 VS50: abbreviation
E0122 VS51: abbreviation
E0123 VS52: abbreviation
E0124 VS53: abbreviation
E0125 VS54: abbreviation
E0126 VS55: abbreviation
E0127 VS56: abbreviation
E0128 VS57: abbreviation
E0129 VS58: abbreviation
E012A VS59: abbreviation
E012B VS60: abbreviation
E012C VS61: abbreviation
E012D VS62: abbreviation
E012E VS63: abbreviation
E012F VS64: abbreviation
E0130 VS65: abbreviation
E0131 VS66: abbreviation
E0132 VS67: abbreviation
E0133 VS68: abbreviation
E0134 VS69: abbreviation
E0135 VS70: abbreviation
E0136 VS71: abbreviation
E0137 VS72: abbreviation
E0138 VS73: abbreviation
E0139 VS74: abbreviation
E013A VS75: abbreviation
E013B VS76: abbreviation
E013C VS77: abbreviation
E013D VS78: abbreviation
E013E VS79: abbreviation
E013F VS80: abbreviation
E0140 VS81: abbreviation
E0141 VS82: abbreviation
E0142 VS83: abbreviation
E0143 VS84: abbreviation
E0144 VS85: abbreviation
E0145 VS86: abbreviation
E0146 VS87: abbreviation
E0147 VS88: abbreviation
E0148 VS89: abbreviation
E0149 VS90: abbreviation
E014A VS91: abbreviation
E014B VS92: abbreviation
E014C VS93: abbreviation
E014D VS94: abbreviation
E014E VS95: abbreviation
E014F VS96: abbreviation
E0150 VS97: abbreviation
E0151 VS98: abbreviation
E0152 VS99: abbreviation
E0153 VS100: abbreviation
E0154 VS101: abbreviation
E0155 VS102: abbreviation
E0156 VS103: abbreviation
E0157 VS104: abbreviation
E0158 VS105: abbreviation
E0159 VS106: abbreviation
E015A VS107: abbreviation
E015B VS108: abbreviation
E015C VS109: abbreviation
E015D VS110: abbreviation
E015E VS111: abbreviation
E015F VS112: abbreviation
E0160 VS113: abbreviation
E0161 VS114: abbreviation
E0162 VS115: abbreviation
E0163 VS116: abbreviation
E0164 VS117: abbreviation
E0165 VS118: abbreviation
E0166 VS119: abbreviation
E0167 VS120: abbreviation
E0168 VS121: abbreviation
E0169 VS122: abbreviation
E016A VS123: abbreviation
E016B VS124: abbreviation
E016C VS125: abbreviation
E016D VS126: abbreviation
E016E VS127: abbreviation
E016F VS128: abbreviation
E0170 VS129: abbreviation
E0171 VS130: abbreviation
E0172 VS131: abbreviation
E0173 VS132: abbreviation
E0174 VS133: abbreviation
E0175 VS134: abbreviation
E0176 VS135: abbreviation
E0177 VS136: abbreviation
E0178 VS137: abbreviation
E0179 VS138: abbreviation
E017A VS139: abbreviation
E017B VS140: abbreviation
E017C VS141: abbreviation
E017D VS142: abbreviation
E017E VS143: abbreviation
E017F VS144: abbreviation
E0180 VS145: abbreviation
E0181 VS146: abbreviation
E0182 VS147: abbreviation
E0183 VS148: abbreviation
E0184 VS149: abbreviation
E0185 VS150: abbreviation
E0186 VS151: abbreviation
E0187 VS152: abbreviation
E0188 VS153: abbreviation
E0189 VS154: abbreviation
E018A VS155: abbreviation
E018B VS156: abbreviation
E018C VS157: abbreviation
E018D VS158: abbreviation
E018E VS159: abbreviation
E018F VS160: abbreviation
E0190 VS161: abbreviation
E0191 VS162: abbreviation
E0192 VS163: abbreviation
E0193 VS164: abbreviation
E0194 VS165: abbreviation
E0195 VS166: abbreviation
E0196 VS167: abbreviation
E0197 VS168: abbreviation
E0198 VS169: abbreviation
E0199 VS170: abbreviation
E019A VS171: abbreviation
E019B VS172: abbreviation
E019C VS173: abbreviation
E019D VS174: abbreviation
E019E VS175: abbreviation
E019F VS176: abbreviation
E01A0 VS177: abbreviation
E01A1 VS178: abbreviation
E01A2 VS179: abbreviation
E01A3 VS180: abbreviation
E01A4 VS181: abbreviation
E01A5 VS182: abbreviation
E01A6 VS183: abbreviation
E01A7 VS184: abbreviation
E01A8 VS185: abbreviation
E01A9 VS186: abbreviation
E01AA VS187: abbreviation
E01AB VS188: abbreviation
E01AC VS189: abbreviation
E01AD VS190: abbreviation
E01AE VS191: abbreviation
E01AF VS192: abbreviation
E01B0 VS193: abbreviation
E01B1 VS194: abbreviation
E01B2 VS195: abbreviation
E01B3 VS196: abbreviation
E01B4 VS197: abbreviation
E01B5 VS198: abbreviation
E01B6 VS199: abbreviation
E01B7 VS200: abbreviation
E01B8 VS201: abbreviation
E01B9 VS202: abbreviation
E01BA VS203: abbreviation
E01BB VS204: abbreviation
E01BC VS205: abbreviation
E01BD VS206: abbreviation
E01BE VS207: abbreviation
E01BF VS208: abbreviation
E01C0 VS209: abbreviation
E01C1 VS210: abbreviation
E01C2 VS211: abbreviation
E01C3 VS212: abbreviation
E01C4 VS213: abbreviation
E01C5 VS214: abbreviation
E01C6 VS215: abbreviation
E01C7 VS216: abbreviation
E01C8 VS217: abbreviation
E01C9 VS218: abbreviation
E01CA VS219: abbreviation
E01CB VS220: abbreviation
E01CC VS221: abbreviation
E01CD VS222: abbreviation
E01CE VS223: abbreviation
E01CF VS224: abbreviation
E01D0 VS225: abbreviation
E01D1 VS226: abbreviation
E01D2 VS227: abbreviation
E01D3 VS228: abbreviation
E01D4 VS229: abbreviation
E01D5 VS230: abbreviation
E01D6 VS231: abbreviation
E01D7 VS232: abbreviation
E01D8 VS233: abbreviation
E01D9 VS234: abbreviation
E01DA VS235: abbreviation
E01DB VS236: abbreviation
E01DC VS237: abbreviation
E01DD VS238: abbreviation
E01DE VS239: abbreviation
E01DF VS240: abbreviation
E01E0 VS241: abbreviation
E01E1 VS242: abbreviation
E01E2 VS243: abbreviation
E01E3 VS244: abbreviation
E01E4 VS245: abbreviation
E01E5 VS246: abbreviation
E01E6 VS247: abbreviation
E01E7 VS248: abbreviation
E01E8 VS249: abbreviation
E01E9 VS250: abbreviation
E01EA VS251: abbreviation
E01EB VS252: abbreviation
E01EC VS253: abbreviation
E01ED VS254: abbreviation
E01EE VS255: abbreviation
E01EF VS256: abbreviation
END

View File

@@ -0,0 +1,234 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToNt'}{'format'} = 's'; # string
$utf8::SwashInfo{'ToNt'}{'missing'} = 'None';
return <<'END';
30 39 Decimal
B2 B3 Digit
B9 Digit
BC BE Numeric
660 669 Decimal
6F0 6F9 Decimal
7C0 7C9 Decimal
966 96F Decimal
9E6 9EF Decimal
9F4 9F9 Numeric
A66 A6F Decimal
AE6 AEF Decimal
B66 B6F Decimal
B72 B77 Numeric
BE6 BEF Decimal
BF0 BF2 Numeric
C66 C6F Decimal
C78 C7E Numeric
CE6 CEF Decimal
D58 D5E Numeric
D66 D6F Decimal
D70 D78 Numeric
DE6 DEF Decimal
E50 E59 Decimal
ED0 ED9 Decimal
F20 F29 Decimal
F2A F33 Numeric
1040 1049 Decimal
1090 1099 Decimal
1369 1371 Digit
1372 137C Numeric
16EE 16F0 Numeric
17E0 17E9 Decimal
17F0 17F9 Numeric
1810 1819 Decimal
1946 194F Decimal
19D0 19D9 Decimal
19DA Digit
1A80 1A89 Decimal
1A90 1A99 Decimal
1B50 1B59 Decimal
1BB0 1BB9 Decimal
1C40 1C49 Decimal
1C50 1C59 Decimal
2070 Digit
2074 2079 Digit
2080 2089 Digit
2150 2182 Numeric
2185 2189 Numeric
2460 2468 Digit
2469 2473 Numeric
2474 247C Digit
247D 2487 Numeric
2488 2490 Digit
2491 249B Numeric
24EA Digit
24EB 24F4 Numeric
24F5 24FD Digit
24FE Numeric
24FF Digit
2776 277E Digit
277F Numeric
2780 2788 Digit
2789 Numeric
278A 2792 Digit
2793 Numeric
2CFD Numeric
3007 Numeric
3021 3029 Numeric
3038 303A Numeric
3192 3195 Numeric
3220 3229 Numeric
3248 324F Numeric
3251 325F Numeric
3280 3289 Numeric
32B1 32BF Numeric
3405 Numeric
3483 Numeric
382A Numeric
3B4D Numeric
4E00 Numeric
4E03 Numeric
4E07 Numeric
4E09 Numeric
4E5D Numeric
4E8C Numeric
4E94 Numeric
4E96 Numeric
4EBF 4EC0 Numeric
4EDF Numeric
4EE8 Numeric
4F0D Numeric
4F70 Numeric
5104 Numeric
5146 Numeric
5169 Numeric
516B Numeric
516D Numeric
5341 Numeric
5343 5345 Numeric
534C Numeric
53C1 53C4 Numeric
56DB Numeric
58F1 Numeric
58F9 Numeric
5E7A Numeric
5EFE 5EFF Numeric
5F0C 5F0E Numeric
5F10 Numeric
62FE Numeric
634C Numeric
67D2 Numeric
6F06 Numeric
7396 Numeric
767E Numeric
8086 Numeric
842C Numeric
8CAE Numeric
8CB3 Numeric
8D30 Numeric
9621 Numeric
9646 Numeric
964C Numeric
9678 Numeric
96F6 Numeric
A620 A629 Decimal
A6E6 A6EF Numeric
A830 A835 Numeric
A8D0 A8D9 Decimal
A900 A909 Decimal
A9D0 A9D9 Decimal
A9F0 A9F9 Decimal
AA50 AA59 Decimal
ABF0 ABF9 Decimal
F96B Numeric
F973 Numeric
F978 Numeric
F9B2 Numeric
F9D1 Numeric
F9D3 Numeric
F9FD Numeric
FF10 FF19 Decimal
10107 10133 Numeric
10140 10178 Numeric
1018A 1018B Numeric
102E1 102FB Numeric
10320 10323 Numeric
10341 Numeric
1034A Numeric
103D1 103D5 Numeric
104A0 104A9 Decimal
10858 1085F Numeric
10879 1087F Numeric
108A7 108AF Numeric
108FB 108FF Numeric
10916 1091B Numeric
109BC 109BD Numeric
109C0 109CF Numeric
109D2 109FF Numeric
10A40 10A43 Digit
10A44 10A47 Numeric
10A7D 10A7E Numeric
10A9D 10A9F Numeric
10AEB 10AEF Numeric
10B58 10B5F Numeric
10B78 10B7F Numeric
10BA9 10BAF Numeric
10CFA 10CFF Numeric
10E60 10E68 Digit
10E69 10E7E Numeric
11052 1105A Digit
1105B 11065 Numeric
11066 1106F Decimal
110F0 110F9 Decimal
11136 1113F Decimal
111D0 111D9 Decimal
111E1 111F4 Numeric
112F0 112F9 Decimal
11450 11459 Decimal
114D0 114D9 Decimal
11650 11659 Decimal
116C0 116C9 Decimal
11730 11739 Decimal
1173A 1173B Numeric
118E0 118E9 Decimal
118EA 118F2 Numeric
11C50 11C59 Decimal
11C5A 11C6C Numeric
12400 1246E Numeric
16A60 16A69 Decimal
16B50 16B59 Decimal
16B5B 16B61 Numeric
1D360 1D371 Numeric
1D7CE 1D7FF Decimal
1E8C7 1E8CF Numeric
1E950 1E959 Decimal
1F100 1F10A Digit
1F10B 1F10C Numeric
20001 Numeric
20064 Numeric
200E2 Numeric
20121 Numeric
2092A Numeric
20983 Numeric
2098C Numeric
2099C Numeric
20AEA Numeric
20AFD Numeric
20B19 Numeric
22390 Numeric
22998 Numeric
23B1B Numeric
2626D Numeric
2F890 Numeric
END

View File

@@ -0,0 +1,660 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The mappings must be modified to get the correct values by adding the code
# point ordinal number to each one that is numeric.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToNv'}{'format'} = 'a'; # some entries need adjustment
$utf8::SwashInfo{'ToNv'}{'missing'} = 'NaN';
return <<'END';
30 39 0
B2 B3 2
B9 1
BC 1/4
BD 1/2
BE 3/4
660 669 0
6F0 6F9 0
7C0 7C9 0
966 96F 0
9E6 9EF 0
9F4 1/16
9F5 1/8
9F6 3/16
9F7 1/4
9F8 3/4
9F9 16
A66 A6F 0
AE6 AEF 0
B66 B6F 0
B72 1/4
B73 1/2
B74 3/4
B75 1/16
B76 1/8
B77 3/16
BE6 BF0 0
BF1 100
BF2 1000
C66 C6F 0
C78 C7B 0
C7C C7E 1
CE6 CEF 0
D58 1/160
D59 1/40
D5A 3/80
D5B 1/20
D5C 1/10
D5D 3/20
D5E 1/5
D66 D70 0
D71 100
D72 1000
D73 1/4
D74 1/2
D75 3/4
D76 1/16
D77 1/8
D78 3/16
DE6 DEF 0
E50 E59 0
ED0 ED9 0
F20 F29 0
F2A 1/2
F2B 3/2
F2C 5/2
F2D 7/2
F2E 9/2
F2F 11/2
F30 13/2
F31 15/2
F32 17/2
F33 -1/2
1040 1049 0
1090 1099 0
1369 1372 1
1373 20
1374 30
1375 40
1376 50
1377 60
1378 70
1379 80
137A 90
137B 100
137C 10000
16EE 16F0 17
17E0 17E9 0
17F0 17F9 0
1810 1819 0
1946 194F 0
19D0 19D9 0
19DA 1
1A80 1A89 0
1A90 1A99 0
1B50 1B59 0
1BB0 1BB9 0
1C40 1C49 0
1C50 1C59 0
2070 0
2074 2079 4
2080 2089 0
2150 1/7
2151 1/9
2152 1/10
2153 1/3
2154 2/3
2155 1/5
2156 2/5
2157 3/5
2158 4/5
2159 1/6
215A 5/6
215B 1/8
215C 3/8
215D 5/8
215E 7/8
215F 1
2160 216B 1
216C 50
216D 100
216E 500
216F 1000
2170 217B 1
217C 50
217D 100
217E 500
217F 1000
2180 1000
2181 5000
2182 10000
2185 6
2186 50
2187 50000
2188 100000
2189 0
2460 2473 1
2474 2487 1
2488 249B 1
24EA 0
24EB 24F4 11
24F5 24FE 1
24FF 0
2776 277F 1
2780 2789 1
278A 2793 1
2CFD 1/2
3007 0
3021 3029 1
3038 10
3039 20
303A 30
3192 3195 1
3220 3229 1
3248 10
3249 20
324A 30
324B 40
324C 50
324D 60
324E 70
324F 80
3251 325F 21
3280 3289 1
32B1 32BF 36
3405 5
3483 2
382A 5
3B4D 7
4E00 1
4E03 7
4E07 10000
4E09 3
4E5D 9
4E8C 2
4E94 5
4E96 4
4EBF 100000000
4EC0 10
4EDF 1000
4EE8 3
4F0D 5
4F70 100
5104 100000000
5146 1000000000000
5169 2
516B 8
516D 6
5341 10
5343 1000
5344 20
5345 30
534C 40
53C1 3
53C2 3
53C3 3
53C4 3
56DB 4
58F1 1
58F9 1
5E7A 1
5EFE 9
5EFF 20
5F0C 5F0E 1
5F10 2
62FE 10
634C 8
67D2 7
6F06 7
7396 9
767E 100
8086 4
842C 10000
8CAE 2
8CB3 2
8D30 2
9621 1000
9646 6
964C 100
9678 6
96F6 0
A620 A629 0
A6E6 A6EE 1
A6EF 0
A830 1/4
A831 1/2
A832 3/4
A833 1/16
A834 1/8
A835 3/16
A8D0 A8D9 0
A900 A909 0
A9D0 A9D9 0
A9F0 A9F9 0
AA50 AA59 0
ABF0 ABF9 0
F96B 3
F973 10
F978 2
F9B2 0
F9D1 6
F9D3 6
F9FD 10
FF10 FF19 0
10107 10110 1
10111 20
10112 30
10113 40
10114 50
10115 60
10116 70
10117 80
10118 90
10119 100
1011A 200
1011B 300
1011C 400
1011D 500
1011E 600
1011F 700
10120 800
10121 900
10122 1000
10123 2000
10124 3000
10125 4000
10126 5000
10127 6000
10128 7000
10129 8000
1012A 9000
1012B 10000
1012C 20000
1012D 30000
1012E 40000
1012F 50000
10130 60000
10131 70000
10132 80000
10133 90000
10140 1/4
10141 1/2
10142 1
10143 5
10144 50
10145 500
10146 5000
10147 50000
10148 5
10149 10
1014A 50
1014B 100
1014C 500
1014D 1000
1014E 5000
1014F 5
10150 10
10151 50
10152 100
10153 500
10154 1000
10155 10000
10156 50000
10157 10
10158 1
10159 1
1015A 1015B 1
1015C 2
1015D 2
1015E 2
1015F 5
10160 10
10161 10
10162 10
10163 10
10164 10
10165 30
10166 50
10167 50
10168 50
10169 50
1016A 100
1016B 300
1016C 500
1016D 500
1016E 500
1016F 500
10170 500
10171 1000
10172 5000
10173 5
10174 50
10175 1/2
10176 1/2
10177 2/3
10178 3/4
1018A 0
1018B 1/4
102E1 102EA 1
102EB 20
102EC 30
102ED 40
102EE 50
102EF 60
102F0 70
102F1 80
102F2 90
102F3 100
102F4 200
102F5 300
102F6 400
102F7 500
102F8 600
102F9 700
102FA 800
102FB 900
10320 1
10321 5
10322 10
10323 50
10341 90
1034A 900
103D1 103D2 1
103D3 10
103D4 20
103D5 100
104A0 104A9 0
10858 1085A 1
1085B 10
1085C 20
1085D 100
1085E 1000
1085F 10000
10879 1087D 1
1087E 10
1087F 20
108A7 108AA 1
108AB 108AC 4
108AD 10
108AE 20
108AF 100
108FB 1
108FC 5
108FD 10
108FE 20
108FF 100
10916 1
10917 10
10918 20
10919 100
1091A 1091B 2
109BC 11/12
109BD 1/2
109C0 109C9 1
109CA 20
109CB 30
109CC 40
109CD 50
109CE 60
109CF 70
109D2 100
109D3 200
109D4 300
109D5 400
109D6 500
109D7 600
109D8 700
109D9 800
109DA 900
109DB 1000
109DC 2000
109DD 3000
109DE 4000
109DF 5000
109E0 6000
109E1 7000
109E2 8000
109E3 9000
109E4 10000
109E5 20000
109E6 30000
109E7 40000
109E8 50000
109E9 60000
109EA 70000
109EB 80000
109EC 90000
109ED 100000
109EE 200000
109EF 300000
109F0 400000
109F1 500000
109F2 600000
109F3 700000
109F4 800000
109F5 900000
109F6 1/12
109F7 1/6
109F8 1/4
109F9 1/3
109FA 5/12
109FB 1/2
109FC 7/12
109FD 2/3
109FE 3/4
109FF 5/6
10A40 10A43 1
10A44 10
10A45 20
10A46 100
10A47 1000
10A7D 1
10A7E 50
10A9D 1
10A9E 10
10A9F 20
10AEB 1
10AEC 5
10AED 10
10AEE 20
10AEF 100
10B58 10B5B 1
10B5C 10
10B5D 20
10B5E 100
10B5F 1000
10B78 10B7B 1
10B7C 10
10B7D 20
10B7E 100
10B7F 1000
10BA9 10BAC 1
10BAD 10
10BAE 20
10BAF 100
10CFA 1
10CFB 5
10CFC 10
10CFD 50
10CFE 100
10CFF 1000
10E60 10E69 1
10E6A 20
10E6B 30
10E6C 40
10E6D 50
10E6E 60
10E6F 70
10E70 80
10E71 90
10E72 100
10E73 200
10E74 300
10E75 400
10E76 500
10E77 600
10E78 700
10E79 800
10E7A 900
10E7B 1/2
10E7C 1/4
10E7D 1/3
10E7E 2/3
11052 1105B 1
1105C 20
1105D 30
1105E 40
1105F 50
11060 60
11061 70
11062 80
11063 90
11064 100
11065 1000
11066 1106F 0
110F0 110F9 0
11136 1113F 0
111D0 111D9 0
111E1 111EA 1
111EB 20
111EC 30
111ED 40
111EE 50
111EF 60
111F0 70
111F1 80
111F2 90
111F3 100
111F4 1000
112F0 112F9 0
11450 11459 0
114D0 114D9 0
11650 11659 0
116C0 116C9 0
11730 1173A 0
1173B 20
118E0 118EA 0
118EB 20
118EC 30
118ED 40
118EE 50
118EF 60
118F0 70
118F1 80
118F2 90
11C50 11C59 0
11C5A 11C63 1
11C64 20
11C65 30
11C66 40
11C67 50
11C68 60
11C69 70
11C6A 80
11C6B 90
11C6C 100
12400 12407 2
12408 1240E 3
1240F 12414 4
12415 1241D 1
1241E 12422 1
12423 12424 2
12425 1242B 3
1242C 1242E 1
1242F 12431 3
12432 216000
12433 432000
12434 12436 1
12437 12439 3
1243A 3
1243B 1243C 3
1243D 4
1243E 4
1243F 4
12440 12441 6
12442 7
12443 12444 7
12445 12446 8
12447 9
12448 9
12449 9
1244A 1244E 2
1244F 12452 1
12453 12454 4
12455 5
12456 12457 2
12458 12459 1
1245A 1/3
1245B 2/3
1245C 5/6
1245D 1/3
1245E 2/3
1245F 1/8
12460 1/4
12461 1/6
12462 1/4
12463 1/4
12464 1/2
12465 1/3
12466 2/3
12467 40
12468 50
12469 1246E 4
16A60 16A69 0
16B50 16B59 0
16B5B 10
16B5C 100
16B5D 10000
16B5E 1000000
16B5F 100000000
16B60 10000000000
16B61 1000000000000
1D360 1D369 1
1D36A 20
1D36B 30
1D36C 40
1D36D 50
1D36E 60
1D36F 70
1D370 80
1D371 90
1D7CE 1D7D7 0
1D7D8 1D7E1 0
1D7E2 1D7EB 0
1D7EC 1D7F5 0
1D7F6 1D7FF 0
1E8C7 1E8CF 1
1E950 1E959 0
1F100 0
1F101 1F10A 0
1F10B 0
1F10C 0
20001 7
20064 4
200E2 4
20121 5
2092A 1
20983 30
2098C 40
2099C 40
20AEA 6
20AFD 3
20B19 3
22390 2
22998 3
23B1B 3
2626D 4
2F890 9
END

View File

@@ -0,0 +1,80 @@
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is machine-generated by lib/unicore/mktables from the Unicode
# database, Version 9.0.0. Any changes made here will be lost!
# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
# This file is for internal use by core Perl only. The format and even the
# name or existence of this file are subject to change without notice. Don't
# use it directly. Use Unicode::UCD to access the Unicode character data
# base.
# The mappings must be modified to get the correct values by adding the code
# point ordinal number to each one that is numeric.
# The name this swash is to be known by, with the format of the mappings in
# the main body of the table, and what all code points missing from this file
# map to.
$utf8::SwashInfo{'ToPerlDecimalDigit'}{'format'} = 'a'; # some entries need adjustment
$utf8::SwashInfo{'ToPerlDecimalDigit'}{'missing'} = ''; # code point maps to the null string
return <<'END';
30 39 0
660 669 0
6F0 6F9 0
7C0 7C9 0
966 96F 0
9E6 9EF 0
A66 A6F 0
AE6 AEF 0
B66 B6F 0
BE6 BEF 0
C66 C6F 0
CE6 CEF 0
D66 D6F 0
DE6 DEF 0
E50 E59 0
ED0 ED9 0
F20 F29 0
1040 1049 0
1090 1099 0
17E0 17E9 0
1810 1819 0
1946 194F 0
19D0 19D9 0
1A80 1A89 0
1A90 1A99 0
1B50 1B59 0
1BB0 1BB9 0
1C40 1C49 0
1C50 1C59 0
A620 A629 0
A8D0 A8D9 0
A900 A909 0
A9D0 A9D9 0
A9F0 A9F9 0
AA50 AA59 0
ABF0 ABF9 0
FF10 FF19 0
104A0 104A9 0
11066 1106F 0
110F0 110F9 0
11136 1113F 0
111D0 111D9 0
112F0 112F9 0
11450 11459 0
114D0 114D9 0
11650 11659 0
116C0 116C9 0
11730 11739 0
118E0 118E9 0
11C50 11C59 0
16A60 16A69 0
16B50 16B59 0
1D7CE 1D7D7 0
1D7D8 1D7E1 0
1D7E2 1D7EB 0
1D7EC 1D7F5 0
1D7F6 1D7FF 0
1E950 1E959 0
END

Some files were not shown because too many files have changed in this diff Show More