CosmicRage/VIPMudCosmicRageScripts
5
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

made the pack completely portable and wrote relevent bat files to go with it

Browse Source
This commit is contained in:
Draqoken
2025-04-09 17:04:56 +03:00
parent 5e77d7e9cf
commit 5e4144c3c0
7417 changed files with 2181044 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

96
gitportable/usr/share/perl5/core_perl/AnyDBM_File.pm Normal file
View File

@@ -0,0 +1,96 @@
package AnyDBM_File;
use warnings;
use strict;
use 5.006_001;
our $VERSION = '1.01';
our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA;
my $mod;
for $mod (@ISA) {
if (eval "require $mod") {
@ISA = ($mod); # if we leave @ISA alone, warnings abound
return 1;
}
}
die "No DBM package was successfully found or installed";
__END__
=head1 NAME
AnyDBM_File - provide framework for multiple DBMs
NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations
=head1 SYNOPSIS
use AnyDBM_File;
=head1 DESCRIPTION
This module is a "pure virtual base class"--it has nothing of its own.
It's just there to inherit from one of the various DBM packages. It
prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See
L<DB_File>), GDBM, SDBM (which is always there--it comes with Perl), and
finally ODBM. This way old programs that used to use NDBM via dbmopen()
can still do so, but new ones can reorder @ISA:
BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
use AnyDBM_File;
Having multiple DBM implementations makes it trivial to copy database formats:
use Fcntl; use NDBM_File; use DB_File;
tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR;
tie %oldhash, 'NDBM_File', $old_filename, 1, 0;
%newhash = %oldhash;
=head2 DBM Comparisons
Here's a partial table of features the different packages offer:
odbm ndbm sdbm gdbm bsd-db
---- ---- ---- ---- ------
Linkage comes w/ perl yes yes yes yes yes
Src comes w/ perl no no yes no no
Comes w/ many unix os yes yes[0] no no no
Builds ok on !unix ? ? yes yes ?
Code Size ? ? small big big
Database Size ? ? small big? ok[1]
Speed ? ? slow ok fast
FTPable no no yes yes yes
Easy to build N/A N/A yes yes ok[2]
Size limits 1k 4k 1k[3] none none
Byte-order independent no no no no yes
Licensing restrictions ? ? no yes no
=over 4
=item [0]
on mixed universe machines, may be in the bsd compat library,
which is often shunned.
=item [1]
Can be trimmed if you compile for one access method.
=item [2]
See L<DB_File>.
Requires symbolic links.
=item [3]
By default, but can be redefined.
=back
=head1 SEE ALSO
dbm(3), ndbm(3), DB_File(3), L<perldbmfilter>
=cut

1719
gitportable/usr/share/perl5/core_perl/App/Cpan.pm Normal file
View File

File diff suppressed because it is too large Load Diff

829
gitportable/usr/share/perl5/core_perl/App/Prove.pm Normal file
View File

@@ -0,0 +1,829 @@
package App::Prove;
use strict;
use warnings;
use TAP::Harness::Env;
use Text::ParseWords qw(shellwords);
use File::Spec;
use Getopt::Long;
use App::Prove::State;
use Carp;
use base 'TAP::Object';
=head1 NAME
App::Prove - Implements the C<prove> command.
=head1 VERSION
Version 3.44
=cut
our $VERSION = '3.44';
=head1 DESCRIPTION
L<Test::Harness> provides a command, C<prove>, which runs a TAP based
test suite and prints a report. The C<prove> command is a minimal
wrapper around an instance of this module.
=head1 SYNOPSIS
use App::Prove;
my $app = App::Prove->new;
$app->process_args(@ARGV);
$app->run;
=cut
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant IS_VMS => $^O eq 'VMS';
use constant IS_UNIXY => !( IS_VMS || IS_WIN32 );
use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
use constant PLUGINS => 'App::Prove::Plugin';
my @ATTR;
BEGIN {
@ATTR = qw(
archive argv blib show_count color directives exec failures comments
formatter harness includes modules plugins jobs lib merge parse quiet
really_quiet recurse backwards shuffle taint_fail taint_warn timer
verbose warnings_fail warnings_warn show_help show_man show_version
state_class test_args state dry extensions ignore_exit rules state_manager
normalize sources tapversion trap
statefile
);
__PACKAGE__->mk_methods(@ATTR);
}
=head1 METHODS
=head2 Class Methods
=head3 C<new>
Create a new C<App::Prove>. Optionally a hash ref of attribute
initializers may be passed.
=cut
# new() implementation supplied by TAP::Object
sub _initialize {
my $self = shift;
my $args = shift || {};
my @is_array = qw(
argv rc_opts includes modules state plugins rules sources
);
# setup defaults:
for my $key (@is_array) {
$self->{$key} = [];
}
for my $attr (@ATTR) {
if ( exists $args->{$attr} ) {
# TODO: Some validation here
$self->{$attr} = $args->{$attr};
}
}
$self->state_class('App::Prove::State');
return $self;
}
=head3 C<state_class>
Getter/setter for the name of the class used for maintaining state. This
class should either subclass from C<App::Prove::State> or provide an identical
interface.
=head3 C<state_manager>
Getter/setter for the instance of the C<state_class>.
=cut
=head3 C<add_rc_file>
$prove->add_rc_file('myproj/.proverc');
Called before C<process_args> to prepend the contents of an rc file to
the options.
=cut
sub add_rc_file {
my ( $self, $rc_file ) = @_;
local *RC;
open RC, "<$rc_file" or croak "Can't read $rc_file ($!)";
while ( defined( my $line = <RC> ) ) {
push @{ $self->{rc_opts} },
grep { defined and not /^#/ }
$line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg;
}
close RC;
}
=head3 C<process_args>
$prove->process_args(@args);
Processes the command-line arguments. Attributes will be set
appropriately. Any filenames may be found in the C<argv> attribute.
Dies on invalid arguments.
=cut
sub process_args {
my $self = shift;
my @rc = RC_FILE;
unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
# Preprocess meta-args.
my @args;
while ( defined( my $arg = shift ) ) {
if ( $arg eq '--norc' ) {
@rc = ();
}
elsif ( $arg eq '--rc' ) {
defined( my $rc = shift )
or croak "Missing argument to --rc";
push @rc, $rc;
}
elsif ( $arg =~ m{^--rc=(.+)$} ) {
push @rc, $1;
}
else {
push @args, $arg;
}
}
# Everything after the arisdottle '::' gets passed as args to
# test programs.
if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
my @test_args = splice @args, $stop_at;
shift @test_args;
$self->{test_args} = \@test_args;
}
# Grab options from RC files
$self->add_rc_file($_) for grep -f, @rc;
unshift @args, @{ $self->{rc_opts} };
if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
die "Long options should be written with two dashes: ",
join( ', ', @bad ), "\n";
}
# And finally...
{
local @ARGV = @args;
Getopt::Long::Configure(qw(no_ignore_case bundling pass_through));
# Don't add coderefs to GetOptions
GetOptions(
'v|verbose' => \$self->{verbose},
'f|failures' => \$self->{failures},
'o|comments' => \$self->{comments},
'l|lib' => \$self->{lib},
'b|blib' => \$self->{blib},
's|shuffle' => \$self->{shuffle},
'color!' => \$self->{color},
'colour!' => \$self->{color},
'count!' => \$self->{show_count},
'c' => \$self->{color},
'D|dry' => \$self->{dry},
'ext=s@' => sub {
my ( $opt, $val ) = @_;
# Workaround for Getopt::Long 2.25 handling of
# multivalue options
push @{ $self->{extensions} ||= [] }, $val;
},
'harness=s' => \$self->{harness},
'ignore-exit' => \$self->{ignore_exit},
'source=s@' => $self->{sources},
'formatter=s' => \$self->{formatter},
'r|recurse' => \$self->{recurse},
'reverse' => \$self->{backwards},
'p|parse' => \$self->{parse},
'q|quiet' => \$self->{quiet},
'Q|QUIET' => \$self->{really_quiet},
'e|exec=s' => \$self->{exec},
'm|merge' => \$self->{merge},
'I=s@' => $self->{includes},
'M=s@' => $self->{modules},
'P=s@' => $self->{plugins},
'state=s@' => $self->{state},
'statefile=s' => \$self->{statefile},
'directives' => \$self->{directives},
'h|help|?' => \$self->{show_help},
'H|man' => \$self->{show_man},
'V|version' => \$self->{show_version},
'a|archive=s' => \$self->{archive},
'j|jobs=i' => \$self->{jobs},
'timer' => \$self->{timer},
'T' => \$self->{taint_fail},
't' => \$self->{taint_warn},
'W' => \$self->{warnings_fail},
'w' => \$self->{warnings_warn},
'normalize' => \$self->{normalize},
'rules=s@' => $self->{rules},
'tapversion=s' => \$self->{tapversion},
'trap' => \$self->{trap},
) or croak('Unable to continue');
# Stash the remainder of argv for later
$self->{argv} = [@ARGV];
}
return;
}
sub _first_pos {
my $want = shift;
for ( 0 .. $#_ ) {
return $_ if $_[$_] eq $want;
}
return;
}
sub _help {
my ( $self, $verbosity ) = @_;
eval('use Pod::Usage 1.12 ()');
if ( my $err = $@ ) {
die 'Please install Pod::Usage for the --help option '
. '(or try `perldoc prove`.)'
. "\n ($@)";
}
Pod::Usage::pod2usage( { -verbose => $verbosity } );
return;
}
sub _color_default {
my $self = shift;
return -t STDOUT && !$ENV{HARNESS_NOTTY};
}
sub _get_args {
my $self = shift;
my %args;
$args{trap} = 1 if $self->trap;
if ( defined $self->color ? $self->color : $self->_color_default ) {
$args{color} = 1;
}
if ( !defined $self->show_count ) {
$args{show_count} = 1;
}
else {
$args{show_count} = $self->show_count;
}
if ( $self->archive ) {
$self->require_harness( archive => 'TAP::Harness::Archive' );
$args{archive} = $self->archive;
}
if ( my $jobs = $self->jobs ) {
$args{jobs} = $jobs;
}
if ( my $harness_opt = $self->harness ) {
$self->require_harness( harness => $harness_opt );
}
if ( my $formatter = $self->formatter ) {
$args{formatter_class} = $formatter;
}
for my $handler ( @{ $self->sources } ) {
my ( $name, $config ) = $self->_parse_source($handler);
$args{sources}->{$name} = $config;
}
if ( $self->ignore_exit ) {
$args{ignore_exit} = 1;
}
if ( $self->taint_fail && $self->taint_warn ) {
die '-t and -T are mutually exclusive';
}
if ( $self->warnings_fail && $self->warnings_warn ) {
die '-w and -W are mutually exclusive';
}
for my $a (qw( lib switches )) {
my $method = "_get_$a";
my $val = $self->$method();
$args{$a} = $val if defined $val;
}
# Handle verbose, quiet, really_quiet flags
my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
my @verb_adj = map { $self->$_() ? $verb_map{$_} : () }
keys %verb_map;
die "Only one of verbose, quiet or really_quiet should be specified\n"
if @verb_adj > 1;
$args{verbosity} = shift @verb_adj if @verb_adj;
for my $a (qw( merge failures comments timer directives normalize )) {
$args{$a} = 1 if $self->$a();
}
$args{errors} = 1 if $self->parse;
# defined but zero-length exec runs test files as binaries
$args{exec} = [ split( /\s+/, $self->exec ) ]
if ( defined( $self->exec ) );
$args{version} = $self->tapversion if defined( $self->tapversion );
if ( defined( my $test_args = $self->test_args ) ) {
$args{test_args} = $test_args;
}
if ( @{ $self->rules } ) {
my @rules;
for ( @{ $self->rules } ) {
if (/^par=(.*)/) {
push @rules, $1;
}
elsif (/^seq=(.*)/) {
push @rules, { seq => $1 };
}
}
$args{rules} = { par => [@rules] };
}
$args{harness_class} = $self->{harness_class} if $self->{harness_class};
return \%args;
}
sub _find_module {
my ( $self, $class, @search ) = @_;
croak "Bad module name $class"
unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
for my $pfx (@search) {
my $name = join( '::', $pfx, $class );
eval "require $name";
return $name unless $@;
}
eval "require $class";
return $class unless $@;
return;
}
sub _load_extension {
my ( $self, $name, @search ) = @_;
my @args = ();
if ( $name =~ /^(.*?)=(.*)/ ) {
$name = $1;
@args = split( /,/, $2 );
}
if ( my $class = $self->_find_module( $name, @search ) ) {
$class->import(@args);
if ( $class->can('load') ) {
$class->load( { app_prove => $self, args => [@args] } );
}
}
else {
croak "Can't load module $name";
}
}
sub _load_extensions {
my ( $self, $ext, @search ) = @_;
$self->_load_extension( $_, @search ) for @$ext;
}
sub _parse_source {
my ( $self, $handler ) = @_;
# Load any options.
( my $opt_name = lc $handler ) =~ s/::/-/g;
local @ARGV = @{ $self->{argv} };
my %config;
Getopt::Long::GetOptions(
"$opt_name-option=s%" => sub {
my ( $name, $k, $v ) = @_;
if ( $v =~ /(?<!\\)=/ ) {
# It's a hash option.
croak "Option $name must be consistently used as a hash"
if exists $config{$k} && ref $config{$k} ne 'HASH';
$config{$k} ||= {};
my ( $hk, $hv ) = split /(?<!\\)=/, $v, 2;
$config{$k}{$hk} = $hv;
}
else {
$v =~ s/\\=/=/g;
if ( exists $config{$k} ) {
$config{$k} = [ $config{$k} ]
unless ref $config{$k} eq 'ARRAY';
push @{ $config{$k} } => $v;
}
else {
$config{$k} = $v;
}
}
}
);
$self->{argv} = \@ARGV;
return ( $handler, \%config );
}
=head3 C<run>
Perform whatever actions the command line args specified. The C<prove>
command line tool consists of the following code:
use App::Prove;
my $app = App::Prove->new;
$app->process_args(@ARGV);
exit( $app->run ? 0 : 1 ); # if you need the exit code
=cut
sub run {
my $self = shift;
unless ( $self->state_manager ) {
$self->state_manager(
$self->state_class->new( { store => $self->statefile || STATE_FILE } ) );
}
if ( $self->show_help ) {
$self->_help(1);
}
elsif ( $self->show_man ) {
$self->_help(2);
}
elsif ( $self->show_version ) {
$self->print_version;
}
elsif ( $self->dry ) {
print "$_\n" for $self->_get_tests;
}
else {
$self->_load_extensions( $self->modules );
$self->_load_extensions( $self->plugins, PLUGINS );
local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
return $self->_runtests( $self->_get_args, $self->_get_tests );
}
return 1;
}
sub _get_tests {
my $self = shift;
my $state = $self->state_manager;
my $ext = $self->extensions;
$state->extensions($ext) if defined $ext;
if ( defined( my $state_switch = $self->state ) ) {
$state->apply_switch(@$state_switch);
}
my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
$self->_shuffle(@tests) if $self->shuffle;
@tests = reverse @tests if $self->backwards;
return @tests;
}
sub _runtests {
my ( $self, $args, @tests ) = @_;
my $harness = TAP::Harness::Env->create($args);
my $state = $self->state_manager;
$harness->callback(
after_test => sub {
$state->observe_test(@_);
}
);
$harness->callback(
after_runtests => sub {
$state->commit(@_);
}
);
my $aggregator = $harness->runtests(@tests);
return !$aggregator->has_errors;
}
sub _get_switches {
my $self = shift;
my @switches;
# notes that -T or -t must be at the front of the switches!
if ( $self->taint_fail ) {
push @switches, '-T';
}
elsif ( $self->taint_warn ) {
push @switches, '-t';
}
if ( $self->warnings_fail ) {
push @switches, '-W';
}
elsif ( $self->warnings_warn ) {
push @switches, '-w';
}
return @switches ? \@switches : ();
}
sub _get_lib {
my $self = shift;
my @libs;
if ( $self->lib ) {
push @libs, 'lib';
}
if ( $self->blib ) {
push @libs, 'blib/lib', 'blib/arch';
}
if ( @{ $self->includes } ) {
push @libs, @{ $self->includes };
}
#24926
@libs = map { File::Spec->rel2abs($_) } @libs;
# Huh?
return @libs ? \@libs : ();
}
sub _shuffle {
my $self = shift;
# Fisher-Yates shuffle
my $i = @_;
while ($i) {
my $j = rand $i--;
@_[ $i, $j ] = @_[ $j, $i ];
}
return;
}
=head3 C<require_harness>
Load a harness replacement class.
$prove->require_harness($for => $class_name);
=cut
sub require_harness {
my ( $self, $for, $class ) = @_;
my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
# Emulate Perl's -MModule=arg1,arg2 behaviour
$class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
eval("use $class;");
die "$class_name is required to use the --$for feature: $@" if $@;
$self->{harness_class} = $class_name;
return;
}
=head3 C<print_version>
Display the version numbers of the loaded L<TAP::Harness> and the
current Perl.
=cut
sub print_version {
my $self = shift;
require TAP::Harness;
printf(
"TAP::Harness v%s and Perl v%vd\n",
$TAP::Harness::VERSION, $^V
);
return;
}
1;
# vim:ts=4:sw=4:et:sta
__END__
=head2 Attributes
After command line parsing the following attributes reflect the values
of the corresponding command line switches. They may be altered before
calling C<run>.
=over
=item C<archive>
=item C<argv>
=item C<backwards>
=item C<blib>
=item C<color>
=item C<directives>
=item C<dry>
=item C<exec>
=item C<extensions>
=item C<failures>
=item C<comments>
=item C<formatter>
=item C<harness>
=item C<ignore_exit>
=item C<includes>
=item C<jobs>
=item C<lib>
=item C<merge>
=item C<modules>
=item C<parse>
=item C<plugins>
=item C<quiet>
=item C<really_quiet>
=item C<recurse>
=item C<rules>
=item C<show_count>
=item C<show_help>
=item C<show_man>
=item C<show_version>
=item C<shuffle>
=item C<state>
=item C<state_class>
=item C<taint_fail>
=item C<taint_warn>
=item C<test_args>
=item C<timer>
=item C<verbose>
=item C<warnings_fail>
=item C<warnings_warn>
=item C<tapversion>
=item C<trap>
=back
=head1 PLUGINS
C<App::Prove> provides support for 3rd-party plugins. These are currently
loaded at run-time, I<after> arguments have been parsed (so you can not
change the way arguments are processed, sorry), typically with the
C<< -PI<plugin> >> switch, eg:
prove -PMyPlugin
This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
You can pass an argument to your plugin by appending an C<=> after the plugin
name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas:
prove -PMyPlugin=foo,bar,baz
These are passed in to your plugin's C<load()> class method (if it has one),
along with a reference to the C<App::Prove> object that is invoking your plugin:
sub load {
my ($class, $p) = @_;
my @args = @{ $p->{args} };
# @args will contain ( 'foo', 'bar', 'baz' )
$p->{app_prove}->do_something;
...
}
Note that the user's arguments are also passed to your plugin's C<import()>
function as a list, eg:
sub import {
my ($class, @args) = @_;
# @args will contain ( 'foo', 'bar', 'baz' )
...
}
This is for backwards compatibility, and may be deprecated in the future.
=head2 Sample Plugin
Here's a sample plugin, for your reference:
package App::Prove::Plugin::Foo;
# Sample plugin, try running with:
# prove -PFoo=bar -r -j3
# prove -PFoo -Q
# prove -PFoo=bar,My::Formatter
use strict;
use warnings;
sub load {
my ($class, $p) = @_;
my @args = @{ $p->{args} };
my $app = $p->{app_prove};
print "loading plugin: $class, args: ", join(', ', @args ), "\n";
# turn on verbosity
$app->verbose( 1 );
# set the formatter?
$app->formatter( $args[1] ) if @args > 1;
# print some of App::Prove's state:
for my $attr (qw( jobs quiet really_quiet recurse verbose )) {
my $val = $app->$attr;
$val = 'undef' unless defined( $val );
print "$attr: $val\n";
}
return 1;
}
1;
=head1 SEE ALSO
L<prove>, L<TAP::Harness>
=cut

548
gitportable/usr/share/perl5/core_perl/App/Prove/State.pm Normal file
View File

@@ -0,0 +1,548 @@
package App::Prove::State;
use strict;
use warnings;
use File::Find;
use File::Spec;
use Carp;
use App::Prove::State::Result;
use TAP::Parser::YAMLish::Reader ();
use TAP::Parser::YAMLish::Writer ();
use base 'TAP::Base';
BEGIN {
__PACKAGE__->mk_methods('result_class');
}
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant NEED_GLOB => IS_WIN32;
=head1 NAME
App::Prove::State - State storage for the C<prove> command.
=head1 VERSION
Version 3.44
=cut
our $VERSION = '3.44';
=head1 DESCRIPTION
The C<prove> command supports a C<--state> option that instructs it to
store persistent state across runs. This module implements that state
and the operations that may be performed on it.
=head1 SYNOPSIS
# Re-run failed tests
$ prove --state=failed,save -rbv
=cut
=head1 METHODS
=head2 Class Methods
=head3 C<new>
Accepts a hashref with the following key/value pairs:
=over 4
=item * C<store>
The filename of the data store holding the data that App::Prove::State reads.
=item * C<extensions> (optional)
The test name extensions. Defaults to C<.t>.
=item * C<result_class> (optional)
The name of the C<result_class>. Defaults to C<App::Prove::State::Result>.
=back
=cut
# override TAP::Base::new:
sub new {
my $class = shift;
my %args = %{ shift || {} };
my $self = bless {
select => [],
seq => 1,
store => delete $args{store},
extensions => ( delete $args{extensions} || ['.t'] ),
result_class =>
( delete $args{result_class} || 'App::Prove::State::Result' ),
}, $class;
$self->{_} = $self->result_class->new(
{ tests => {},
generation => 1,
}
);
my $store = $self->{store};
$self->load($store)
if defined $store && -f $store;
return $self;
}
=head2 C<result_class>
Getter/setter for the name of the class used for tracking test results. This
class should either subclass from C<App::Prove::State::Result> or provide an
identical interface.
=cut
=head2 C<extensions>
Get or set the list of extensions that files must have in order to be
considered tests. Defaults to ['.t'].
=cut
sub extensions {
my $self = shift;
$self->{extensions} = shift if @_;
return $self->{extensions};
}
=head2 C<results>
Get the results of the last test run. Returns a C<result_class()> instance.
=cut
sub results {
my $self = shift;
$self->{_} || $self->result_class->new;
}
=head2 C<commit>
Save the test results. Should be called after all tests have run.
=cut
sub commit {
my $self = shift;
if ( $self->{should_save} ) {
$self->save;
}
}
=head2 Instance Methods
=head3 C<apply_switch>
$self->apply_switch('failed,save');
Apply a list of switch options to the state, updating the internal
object state as a result. Nothing is returned.
Diagnostics:
- "Illegal state option: %s"
=over
=item C<last>
Run in the same order as last time
=item C<failed>
Run only the failed tests from last time
=item C<passed>
Run only the passed tests from last time
=item C<all>
Run all tests in normal order
=item C<hot>
Run the tests that most recently failed first
=item C<todo>
Run the tests ordered by number of todos.
=item C<slow>
Run the tests in slowest to fastest order.
=item C<fast>
Run test tests in fastest to slowest order.
=item C<new>
Run the tests in newest to oldest order.
=item C<old>
Run the tests in oldest to newest order.
=item C<save>
Save the state on exit.
=back
=cut
sub apply_switch {
my $self = shift;
my @opts = @_;
my $last_gen = $self->results->generation - 1;
my $last_run_time = $self->results->last_run_time;
my $now = $self->get_time;
my @switches = map { split /,/ } @opts;
my %handler = (
last => sub {
$self->_select(
limit => shift,
where => sub { $_->generation >= $last_gen },
order => sub { $_->sequence }
);
},
failed => sub {
$self->_select(
limit => shift,
where => sub { $_->result != 0 },
order => sub { -$_->result }
);
},
passed => sub {
$self->_select(
limit => shift,
where => sub { $_->result == 0 }
);
},
all => sub {
$self->_select( limit => shift );
},
todo => sub {
$self->_select(
limit => shift,
where => sub { $_->num_todo != 0 },
order => sub { -$_->num_todo; }
);
},
hot => sub {
$self->_select(
limit => shift,
where => sub { defined $_->last_fail_time },
order => sub { $now - $_->last_fail_time }
);
},
slow => sub {
$self->_select(
limit => shift,
order => sub { -$_->elapsed }
);
},
fast => sub {
$self->_select(
limit => shift,
order => sub { $_->elapsed }
);
},
new => sub {
$self->_select(
limit => shift,
order => sub { -$_->mtime }
);
},
old => sub {
$self->_select(
limit => shift,
order => sub { $_->mtime }
);
},
fresh => sub {
$self->_select(
limit => shift,
where => sub { $_->mtime >= $last_run_time }
);
},
save => sub {
$self->{should_save}++;
},
adrian => sub {
unshift @switches, qw( hot all save );
},
);
while ( defined( my $ele = shift @switches ) ) {
my ( $opt, $arg )
= ( $ele =~ /^([^:]+):(.*)/ )
? ( $1, $2 )
: ( $ele, undef );
my $code = $handler{$opt}
|| croak "Illegal state option: $opt";
$code->($arg);
}
return;
}
sub _select {
my ( $self, %spec ) = @_;
push @{ $self->{select} }, \%spec;
}
=head3 C<get_tests>
Given a list of args get the names of tests that should run
=cut
sub get_tests {
my $self = shift;
my $recurse = shift;
my @argv = @_;
my %seen;
my @selected = $self->_query;
unless ( @argv || @{ $self->{select} } ) {
@argv = $recurse ? '.' : 't';
croak qq{No tests named and '@argv' directory not found}
unless -d $argv[0];
}
push @selected, $self->_get_raw_tests( $recurse, @argv ) if @argv;
return grep { !$seen{$_}++ } @selected;
}
sub _query {
my $self = shift;
if ( my @sel = @{ $self->{select} } ) {
warn "No saved state, selection will be empty\n"
unless $self->results->num_tests;
return map { $self->_query_clause($_) } @sel;
}
return;
}
sub _query_clause {
my ( $self, $clause ) = @_;
my @got;
my $results = $self->results;
my $where = $clause->{where} || sub {1};
# Select
for my $name ( $results->test_names ) {
next unless -f $name;
local $_ = $results->test($name);
push @got, $name if $where->();
}
# Sort
if ( my $order = $clause->{order} ) {
@got = map { $_->[0] }
sort {
( defined $b->[1] <=> defined $a->[1] )
|| ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
} map {
[ $_,
do { local $_ = $results->test($_); $order->() }
]
} @got;
}
if ( my $limit = $clause->{limit} ) {
@got = splice @got, 0, $limit if @got > $limit;
}
return @got;
}
sub _get_raw_tests {
my $self = shift;
my $recurse = shift;
my @argv = @_;
my @tests;
# Do globbing on Win32.
if (NEED_GLOB) {
eval "use File::Glob::Windows"; # [49732]
@argv = map { glob "$_" } @argv;
}
my $extensions = $self->{extensions};
for my $arg (@argv) {
if ( '-' eq $arg ) {
push @argv => <STDIN>;
chomp(@argv);
next;
}
push @tests,
sort -d $arg
? $recurse
? $self->_expand_dir_recursive( $arg, $extensions )
: map { glob( File::Spec->catfile( $arg, "*$_" ) ) }
@{$extensions}
: $arg;
}
return @tests;
}
sub _expand_dir_recursive {
my ( $self, $dir, $extensions ) = @_;
my @tests;
my $ext_string = join( '|', map {quotemeta} @{$extensions} );
find(
{ follow => 1, #21938
follow_skip => 2,
wanted => sub {
-f
&& /(?:$ext_string)$/
&& push @tests => $File::Find::name;
}
},
$dir
);
return @tests;
}
=head3 C<observe_test>
Store the results of a test.
=cut
# Store:
# last fail time
# last pass time
# last run time
# most recent result
# most recent todos
# total failures
# total passes
# state generation
# parser
sub observe_test {
my ( $self, $test_info, $parser ) = @_;
my $name = $test_info->[0];
my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
my $todo = scalar( $parser->todo );
my $start_time = $parser->start_time;
my $end_time = $parser->end_time,
my $test = $self->results->test($name);
$test->sequence( $self->{seq}++ );
$test->generation( $self->results->generation );
$test->run_time($end_time);
$test->result($fail);
$test->num_todo($todo);
$test->elapsed( $end_time - $start_time );
$test->parser($parser);
if ($fail) {
$test->total_failures( $test->total_failures + 1 );
$test->last_fail_time($end_time);
}
else {
$test->total_passes( $test->total_passes + 1 );
$test->last_pass_time($end_time);
}
}
=head3 C<save>
Write the state to a file.
=cut
sub save {
my ($self) = @_;
my $store = $self->{store} or return;
$self->results->last_run_time( $self->get_time );
my $writer = TAP::Parser::YAMLish::Writer->new;
local *FH;
open FH, ">$store" or croak "Can't write $store ($!)";
$writer->write( $self->results->raw, \*FH );
close FH;
}
=head3 C<load>
Load the state from a file
=cut
sub load {
my ( $self, $name ) = @_;
my $reader = TAP::Parser::YAMLish::Reader->new;
local *FH;
open FH, "<$name" or croak "Can't read $name ($!)";
# XXX this is temporary
$self->{_} = $self->result_class->new(
$reader->read(
sub {
my $line = <FH>;
defined $line && chomp $line;
return $line;
}
)
);
# $writer->write( $self->{tests} || {}, \*FH );
close FH;
$self->_regen_seq;
$self->_prune_and_stamp;
$self->results->generation( $self->results->generation + 1 );
}
sub _prune_and_stamp {
my $self = shift;
my $results = $self->results;
my @tests = $self->results->tests;
for my $test (@tests) {
my $name = $test->name;
if ( my @stat = stat $name ) {
$test->mtime( $stat[9] );
}
else {
$results->remove($name);
}
}
}
sub _regen_seq {
my $self = shift;
for my $test ( $self->results->tests ) {
$self->{seq} = $test->sequence + 1
if defined $test->sequence && $test->sequence >= $self->{seq};
}
}
1;

233
gitportable/usr/share/perl5/core_perl/App/Prove/State/Result.pm Normal file
View File

@@ -0,0 +1,233 @@
package App::Prove::State::Result;
use strict;
use warnings;
use Carp 'croak';
use App::Prove::State::Result::Test;
use constant STATE_VERSION => 1;
=head1 NAME
App::Prove::State::Result - Individual test suite results.
=head1 VERSION
Version 3.44
=cut
our $VERSION = '3.44';
=head1 DESCRIPTION
The C<prove> command supports a C<--state> option that instructs it to
store persistent state across runs. This module encapsulates the results for a
single test suite run.
=head1 SYNOPSIS
# Re-run failed tests
$ prove --state=failed,save -rbv
=cut
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my $result = App::Prove::State::Result->new({
generation => $generation,
tests => \%tests,
});
Returns a new C<App::Prove::State::Result> instance.
=cut
sub new {
my ( $class, $arg_for ) = @_;
$arg_for ||= {};
my %instance_data = %$arg_for; # shallow copy
$instance_data{version} = $class->state_version;
my $tests = delete $instance_data{tests} || {};
my $self = bless \%instance_data => $class;
$self->_initialize($tests);
return $self;
}
sub _initialize {
my ( $self, $tests ) = @_;
my %tests;
while ( my ( $name, $test ) = each %$tests ) {
$tests{$name} = $self->test_class->new(
{ %$test,
name => $name
}
);
}
$self->tests( \%tests );
return $self;
}
=head2 C<state_version>
Returns the current version of state storage.
=cut
sub state_version {STATE_VERSION}
=head2 C<test_class>
Returns the name of the class used for tracking individual tests. This class
should either subclass from C<App::Prove::State::Result::Test> or provide an
identical interface.
=cut
sub test_class {
return 'App::Prove::State::Result::Test';
}
my %methods = (
generation => { method => 'generation', default => 0 },
last_run_time => { method => 'last_run_time', default => undef },
);
while ( my ( $key, $description ) = each %methods ) {
my $default = $description->{default};
no strict 'refs';
*{ $description->{method} } = sub {
my $self = shift;
if (@_) {
$self->{$key} = shift;
return $self;
}
return $self->{$key} || $default;
};
}
=head3 C<generation>
Getter/setter for the "generation" of the test suite run. The first
generation is 1 (one) and subsequent generations are 2, 3, etc.
=head3 C<last_run_time>
Getter/setter for the time of the test suite run.
=head3 C<tests>
Returns the tests for a given generation. This is a hashref or a hash,
depending on context called. The keys to the hash are the individual
test names and the value is a hashref with various interesting values.
Each k/v pair might resemble something like this:
't/foo.t' => {
elapsed => '0.0428488254547119',
gen => '7',
last_pass_time => '1219328376.07815',
last_result => '0',
last_run_time => '1219328376.07815',
last_todo => '0',
mtime => '1191708862',
seq => '192',
total_passes => '6',
}
=cut
sub tests {
my $self = shift;
if (@_) {
$self->{tests} = shift;
return $self;
}
my %tests = %{ $self->{tests} };
my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
return wantarray ? @tests : \@tests;
}
=head3 C<test>
my $test = $result->test('t/customer/create.t');
Returns an individual C<App::Prove::State::Result::Test> instance for the
given test name (usually the filename). Will return a new
C<App::Prove::State::Result::Test> instance if the name is not found.
=cut
sub test {
my ( $self, $name ) = @_;
croak("test() requires a test name") unless defined $name;
my $tests = $self->{tests} ||= {};
if ( my $test = $tests->{$name} ) {
return $test;
}
else {
my $test = $self->test_class->new( { name => $name } );
$self->{tests}->{$name} = $test;
return $test;
}
}
=head3 C<test_names>
Returns an list of test names, sorted by run order.
=cut
sub test_names {
my $self = shift;
return map { $_->name } $self->tests;
}
=head3 C<remove>
$result->remove($test_name); # remove the test
my $test = $result->test($test_name); # fatal error
Removes a given test from results. This is a no-op if the test name is not
found.
=cut
sub remove {
my ( $self, $name ) = @_;
delete $self->{tests}->{$name};
return $self;
}
=head3 C<num_tests>
Returns the number of tests for a given test suite result.
=cut
sub num_tests { keys %{ shift->{tests} } }
=head3 C<raw>
Returns a hashref of raw results, suitable for serialization by YAML.
=cut
sub raw {
my $self = shift;
my %raw = %$self;
my %tests;
for my $test ( $self->tests ) {
$tests{ $test->name } = $test->raw;
}
$raw{tests} = \%tests;
return \%raw;
}
1;

152
gitportable/usr/share/perl5/core_perl/App/Prove/State/Result/Test.pm Normal file
View File

@@ -0,0 +1,152 @@
package App::Prove::State::Result::Test;
use strict;
use warnings;
=head1 NAME
App::Prove::State::Result::Test - Individual test results.
=head1 VERSION
Version 3.44
=cut
our $VERSION = '3.44';
=head1 DESCRIPTION
The C<prove> command supports a C<--state> option that instructs it to
store persistent state across runs. This module encapsulates the results for a
single test.
=head1 SYNOPSIS
# Re-run failed tests
$ prove --state=failed,save -rbv
=cut
my %methods = (
name => { method => 'name' },
elapsed => { method => 'elapsed', default => 0 },
gen => { method => 'generation', default => 1 },
last_pass_time => { method => 'last_pass_time', default => undef },
last_fail_time => { method => 'last_fail_time', default => undef },
last_result => { method => 'result', default => 0 },
last_run_time => { method => 'run_time', default => undef },
last_todo => { method => 'num_todo', default => 0 },
mtime => { method => 'mtime', default => undef },
seq => { method => 'sequence', default => 1 },
total_passes => { method => 'total_passes', default => 0 },
total_failures => { method => 'total_failures', default => 0 },
parser => { method => 'parser' },
);
while ( my ( $key, $description ) = each %methods ) {
my $default = $description->{default};
no strict 'refs';
*{ $description->{method} } = sub {
my $self = shift;
if (@_) {
$self->{$key} = shift;
return $self;
}
return $self->{$key} || $default;
};
}
=head1 METHODS
=head2 Class Methods
=head3 C<new>
=cut
sub new {
my ( $class, $arg_for ) = @_;
$arg_for ||= {};
bless $arg_for => $class;
}
=head2 Instance Methods
=head3 C<name>
The name of the test. Usually a filename.
=head3 C<elapsed>
The total elapsed times the test took to run, in seconds from the epoch..
=head3 C<generation>
The number for the "generation" of the test run. The first generation is 1
(one) and subsequent generations are 2, 3, etc.
=head3 C<last_pass_time>
The last time the test program passed, in seconds from the epoch.
Returns C<undef> if the program has never passed.
=head3 C<last_fail_time>
The last time the test suite failed, in seconds from the epoch.
Returns C<undef> if the program has never failed.
=head3 C<mtime>
Returns the mtime of the test, in seconds from the epoch.
=head3 C<raw>
Returns a hashref of raw test data, suitable for serialization by YAML.
=head3 C<result>
Currently, whether or not the test suite passed with no 'problems' (such as
TODO passed).
=head3 C<run_time>
The total time it took for the test to run, in seconds. If C<Time::HiRes> is
available, it will have finer granularity.
=head3 C<num_todo>
The number of tests with TODO directives.
=head3 C<sequence>
The order in which this test was run for the given test suite result.
=head3 C<total_passes>
The number of times the test has passed.
=head3 C<total_failures>
The number of times the test has failed.
=head3 C<parser>
The underlying parser object. This is useful if you need the full
information for the test program.
=cut
sub raw {
my $self = shift;
my %raw = %$self;
# this is backwards-compatibility hack and is not guaranteed.
delete $raw{name};
delete $raw{parser};
return \%raw;
}
1;

2437
gitportable/usr/share/perl5/core_perl/Archive/Tar.pm Normal file
View File

File diff suppressed because it is too large Load Diff

127
gitportable/usr/share/perl5/core_perl/Archive/Tar/Constant.pm Normal file
View File

@@ -0,0 +1,127 @@
package Archive::Tar::Constant;
use strict;
use warnings;
use vars qw[$VERSION @ISA @EXPORT];
BEGIN {
require Exporter;
$VERSION = '2.40';
@ISA = qw[Exporter];
require Time::Local if $^O eq "MacOS";
}
@EXPORT = Archive::Tar::Constant->_list_consts( __PACKAGE__ );
use constant FILE => 0;
use constant HARDLINK => 1;
use constant SYMLINK => 2;
use constant CHARDEV => 3;
use constant BLOCKDEV => 4;
use constant DIR => 5;
use constant FIFO => 6;
use constant SOCKET => 8;
use constant UNKNOWN => 9;
use constant LONGLINK => 'L';
use constant LABEL => 'V';
use constant BUFFER => 4096;
use constant HEAD => 512;
use constant BLOCK => 512;
use constant COMPRESS_GZIP => 9;
use constant COMPRESS_BZIP => 'bzip2';
use constant COMPRESS_XZ => 'xz';
use constant BLOCK_SIZE => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK };
use constant TAR_PAD => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) };
use constant TAR_END => "\0" x BLOCK;
use constant READ_ONLY => sub { shift() ? 'rb' : 'r' };
use constant WRITE_ONLY => sub { $_[0] ? 'wb' . shift : 'w' };
use constant MODE_READ => sub { $_[0] =~ /^r/ ? 1 : 0 };
# Pointless assignment to make -w shut up
my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); };
my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); };
use constant UNAME => sub { $getpwuid || scalar getpwuid( shift() ) || '' };
use constant GNAME => sub { $getgrgid || scalar getgrgid( shift() ) || '' };
use constant UID => $>;
use constant GID => (split ' ', $) )[0];
use constant MODE => do { 0666 & (0777 & ~umask) };
use constant STRIP_MODE => sub { shift() & 0777 };
use constant CHECK_SUM => " ";
use constant UNPACK => 'a100 a8 a8 a8 a12 a12 a8 a1 a100 A6 a2 a32 a32 a8 a8 a155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb)
use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12';
use constant NAME_LENGTH => 100;
use constant PREFIX_LENGTH => 155;
use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,1970) : 0;
use constant MAGIC => "ustar";
use constant TAR_VERSION => "00";
use constant LONGLINK_NAME => '././@LongLink';
use constant PAX_HEADER => 'pax_global_header';
### allow ZLIB to be turned off using ENV: DEBUG only
use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and
eval { require IO::Zlib };
$ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1
};
### allow BZIP to be turned off using ENV: DEBUG only
use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and
eval { require IO::Uncompress::Bunzip2;
require IO::Compress::Bzip2; };
$ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1
};
### allow XZ to be turned off using ENV: DEBUG only
use constant XZ => do { !$ENV{'PERL5_AT_NO_XZ'} and
eval { require IO::Compress::Xz;
require IO::Uncompress::UnXz; };
$ENV{'PERL5_AT_NO_XZ'} || $@ ? 0 : 1
};
use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/;
# ASCII: B Z h 0 9
use constant BZIP_MAGIC_NUM => qr/^\x42\x5A\x68[\x30-\x39]/;
use constant XZ_MAGIC_NUM => qr/^\xFD\x37\x7A\x58\x5A\x00/;
use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") };
use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS');
use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS');
use constant ON_VMS => $^O eq 'VMS';
sub _list_consts {
my $class = shift;
my $pkg = shift;
return unless defined $pkg; # some joker might use '0' as a pkg...
my @rv;
{ no strict 'refs';
my $stash = $pkg . '::';
for my $name (sort keys %$stash ) {
### is it a subentry?
my $sub = $pkg->can( $name );
next unless defined $sub;
next unless defined prototype($sub) and
not length prototype($sub);
push @rv, $name;
}
}
return sort @rv;
}
1;

716
gitportable/usr/share/perl5/core_perl/Archive/Tar/File.pm Normal file
View File

@@ -0,0 +1,716 @@
package Archive::Tar::File;
use strict;
use Carp ();
use IO::File;
use File::Spec::Unix ();
use File::Spec ();
use File::Basename ();
use Archive::Tar::Constant;
use vars qw[@ISA $VERSION];
#@ISA = qw[Archive::Tar];
$VERSION = '2.40';
### set value to 1 to oct() it during the unpack ###
my $tmpl = [
name => 0, # string A100
mode => 1, # octal A8
uid => 1, # octal A8
gid => 1, # octal A8
size => 0, # octal # cdrake - not *always* octal.. A12
mtime => 1, # octal A12
chksum => 1, # octal A8
type => 0, # character A1
linkname => 0, # string A100
magic => 0, # string A6
version => 0, # 2 bytes A2
uname => 0, # string A32
gname => 0, # string A32
devmajor => 1, # octal A8
devminor => 1, # octal A8
prefix => 0, # A155 x 12
### end UNPACK items ###
raw => 0, # the raw data chunk
data => 0, # the data associated with the file --
# This might be very memory intensive
];
### install get/set accessors for this object.
for ( my $i=0; $i<scalar @$tmpl ; $i+=2 ) {
my $key = $tmpl->[$i];
no strict 'refs';
*{__PACKAGE__."::$key"} = sub {
my $self = shift;
$self->{$key} = $_[0] if @_;
### just in case the key is not there or undef or something ###
{ local $^W = 0;
return $self->{$key};
}
}
}
=head1 NAME
Archive::Tar::File - a subclass for in-memory extracted file from Archive::Tar
=head1 SYNOPSIS
my @items = $tar->get_files;
print $_->name, ' ', $_->size, "\n" for @items;
print $object->get_content;
$object->replace_content('new content');
$object->rename( 'new/full/path/to/file.c' );
=head1 DESCRIPTION
Archive::Tar::Files provides a neat little object layer for in-memory
extracted files. It's mostly used internally in Archive::Tar to tidy
up the code, but there's no reason users shouldn't use this API as
well.
=head2 Accessors
A lot of the methods in this package are accessors to the various
fields in the tar header:
=over 4
=item name
The file's name
=item mode
The file's mode
=item uid
The user id owning the file
=item gid
The group id owning the file
=item size
File size in bytes
=item mtime
Modification time. Adjusted to mac-time on MacOS if required
=item chksum
Checksum field for the tar header
=item type
File type -- numeric, but comparable to exported constants -- see
Archive::Tar's documentation
=item linkname
If the file is a symlink, the file it's pointing to
=item magic
Tar magic string -- not useful for most users
=item version
Tar version string -- not useful for most users
=item uname
The user name that owns the file
=item gname
The group name that owns the file
=item devmajor
Device major number in case of a special file
=item devminor
Device minor number in case of a special file
=item prefix
Any directory to prefix to the extraction path, if any
=item raw
Raw tar header -- not useful for most users
=back
=head1 Methods
=head2 Archive::Tar::File->new( file => $path )
Returns a new Archive::Tar::File object from an existing file.
Returns undef on failure.
=head2 Archive::Tar::File->new( data => $path, $data, $opt )
Returns a new Archive::Tar::File object from data.
C<$path> defines the file name (which need not exist), C<$data> the
file contents, and C<$opt> is a reference to a hash of attributes
which may be used to override the default attributes (fields in the
tar header), which are described above in the Accessors section.
Returns undef on failure.
=head2 Archive::Tar::File->new( chunk => $chunk )
Returns a new Archive::Tar::File object from a raw 512-byte tar
archive chunk.
Returns undef on failure.
=cut
sub new {
my $class = shift;
my $what = shift;
my $obj = ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) :
($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) :
($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) :
undef;
return $obj;
}
### copies the data, creates a clone ###
sub clone {
my $self = shift;
return bless { %$self }, ref $self;
}
sub _new_from_chunk {
my $class = shift;
my $chunk = shift or return; # 512 bytes of tar header
my %hash = @_;
### filter any arguments on defined-ness of values.
### this allows overriding from what the tar-header is saying
### about this tar-entry. Particularly useful for @LongLink files
my %args = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;
### makes it start at 0 actually... :) ###
my $i = -1;
my %entry = map {
my ($s,$v)=($tmpl->[++$i],$tmpl->[++$i]); # cdrake
($_)=($_=~/^([^\0]*)/) unless($s eq 'size'); # cdrake
$s=> $v ? oct $_ : $_ # cdrake
# $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ # removed by cdrake - mucks up binary sizes >8gb
} unpack( UNPACK, $chunk ); # cdrake
# } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); # old - replaced now by cdrake
if(substr($entry{'size'}, 0, 1) eq "\x80") { # binary size extension for files >8gigs (> octal 77777777777777) # cdrake
my @sz=unpack("aCSNN",$entry{'size'}); $entry{'size'}=$sz[4]+(2**32)*$sz[3]+$sz[2]*(2**64); # Use the low 80 bits (should use the upper 15 as well, but as at year 2011, that seems unlikely to ever be needed - the numbers are just too big...) # cdrake
} else { # cdrake
($entry{'size'})=($entry{'size'}=~/^([^\0]*)/); $entry{'size'}=oct $entry{'size'}; # cdrake
} # cdrake
my $obj = bless { %entry, %args }, $class;
### magic is a filetype string.. it should have something like 'ustar' or
### something similar... if the chunk is garbage, skip it
return unless $obj->magic !~ /\W/;
### store the original chunk ###
$obj->raw( $chunk );
$obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) );
$obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) );
return $obj;
}
sub _new_from_file {
my $class = shift;
my $path = shift;
### path has to at least exist
return unless defined $path;
my $type = __PACKAGE__->_filetype($path);
my $data = '';
READ: {
unless ($type == DIR ) {
my $fh = IO::File->new;
unless( $fh->open($path) ) {
### dangling symlinks are fine, stop reading but continue
### creating the object
last READ if $type == SYMLINK;
### otherwise, return from this function --
### anything that's *not* a symlink should be
### resolvable
return;
}
### binmode needed to read files properly on win32 ###
binmode $fh;
$data = do { local $/; <$fh> };
close $fh;
}
}
my @items = qw[mode uid gid size mtime];
my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9];
if (ON_VMS) {
### VMS has two UID modes, traditional and POSIX. Normally POSIX is
### not used. We currently do not have an easy way to see if we are in
### POSIX mode. In traditional mode, the UID is actually the VMS UIC.
### The VMS UIC has the upper 16 bits is the GID, which in many cases
### the VMS UIC will be larger than 209715, the largest that TAR can
### handle. So for now, assume it is traditional if the UID is larger
### than 0x10000.
if ($hash{uid} > 0x10000) {
$hash{uid} = $hash{uid} & 0xFFFF;
}
### The file length from stat() is the physical length of the file
### However the amount of data read in may be more for some file types.
### Fixed length files are read past the logical EOF to end of the block
### containing. Other file types get expanded on read because record
### delimiters are added.
my $data_len = length $data;
$hash{size} = $data_len if $hash{size} < $data_len;
}
### you *must* set size == 0 on symlinks, or the next entry will be
### though of as the contents of the symlink, which is wrong.
### this fixes bug #7937
$hash{size} = 0 if ($type == DIR or $type == SYMLINK);
$hash{mtime} -= TIME_OFFSET;
### strip the high bits off the mode, which we don't need to store
$hash{mode} = STRIP_MODE->( $hash{mode} );
### probably requires some file path munging here ... ###
### name and prefix are set later
my $obj = {
%hash,
name => '',
chksum => CHECK_SUM,
type => $type,
linkname => ($type == SYMLINK and CAN_READLINK)
? readlink $path
: '',
magic => MAGIC,
version => TAR_VERSION,
uname => UNAME->( $hash{uid} ),
gname => GNAME->( $hash{gid} ),
devmajor => 0, # not handled
devminor => 0, # not handled
prefix => '',
data => $data,
};
bless $obj, $class;
### fix up the prefix and file from the path
my($prefix,$file) = $obj->_prefix_and_file( $path );
$obj->prefix( $prefix );
$obj->name( $file );
return $obj;
}
sub _new_from_data {
my $class = shift;
my $path = shift; return unless defined $path;
my $data = shift; return unless defined $data;
my $opt = shift;
my $obj = {
data => $data,
name => '',
mode => MODE,
uid => UID,
gid => GID,
size => length $data,
mtime => time - TIME_OFFSET,
chksum => CHECK_SUM,
type => FILE,
linkname => '',
magic => MAGIC,
version => TAR_VERSION,
uname => UNAME->( UID ),
gname => GNAME->( GID ),
devminor => 0,
devmajor => 0,
prefix => '',
};
### overwrite with user options, if provided ###
if( $opt and ref $opt eq 'HASH' ) {
for my $key ( keys %$opt ) {
### don't write bogus options ###
next unless exists $obj->{$key};
$obj->{$key} = $opt->{$key};
}
}
bless $obj, $class;
### fix up the prefix and file from the path
my($prefix,$file) = $obj->_prefix_and_file( $path );
$obj->prefix( $prefix );
$obj->name( $file );
return $obj;
}
sub _prefix_and_file {
my $self = shift;
my $path = shift;
my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir );
my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) );
### if it's a directory, then $file might be empty
$file = pop @dirs if $self->is_dir and not length $file;
### splitting ../ gives you the relative path in native syntax
### Remove the root (000000) directory
### The volume from splitpath will also be in native syntax
if (ON_VMS) {
map { $_ = '..' if $_ eq '-'; $_ = '' if $_ eq '000000' } @dirs;
if (length($vol)) {
$vol = VMS::Filespec::unixify($vol);
unshift @dirs, $vol;
}
}
my $prefix = File::Spec::Unix->catdir(@dirs);
return( $prefix, $file );
}
sub _filetype {
my $self = shift;
my $file = shift;
return unless defined $file;
return SYMLINK if (-l $file); # Symlink
return FILE if (-f _); # Plain file
return DIR if (-d _); # Directory
return FIFO if (-p _); # Named pipe
return SOCKET if (-S _); # Socket
return BLOCKDEV if (-b _); # Block special
return CHARDEV if (-c _); # Character special
### shouldn't happen, this is when making archives, not reading ###
return LONGLINK if ( $file eq LONGLINK_NAME );
return UNKNOWN; # Something else (like what?)
}
### this method 'downgrades' a file to plain file -- this is used for
### symlinks when FOLLOW_SYMLINKS is true.
sub _downgrade_to_plainfile {
my $entry = shift;
$entry->type( FILE );
$entry->mode( MODE );
$entry->linkname('');
return 1;
}
=head2 $bool = $file->extract( [ $alternative_name ] )
Extract this object, optionally to an alternative name.
See C<< Archive::Tar->extract_file >> for details.
Returns true on success and false on failure.
=cut
sub extract {
my $self = shift;
local $Carp::CarpLevel += 1;
### avoid circular use, so only require;
require Archive::Tar;
return Archive::Tar->_extract_file( $self, @_ );
}
=head2 $path = $file->full_path
Returns the full path from the tar header; this is basically a
concatenation of the C<prefix> and C<name> fields.
=cut
sub full_path {
my $self = shift;
### if prefix field is empty
return $self->name unless defined $self->prefix and length $self->prefix;
### or otherwise, catfile'd
return File::Spec::Unix->catfile( $self->prefix, $self->name );
}
=head2 $bool = $file->validate
Done by Archive::Tar internally when reading the tar file:
validate the header against the checksum to ensure integer tar file.
Returns true on success, false on failure
=cut
sub validate {
my $self = shift;
my $raw = $self->raw;
### don't know why this one is different from the one we /write/ ###
substr ($raw, 148, 8) = " ";
### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar
### like GNU tar does. See here for details:
### http://www.gnu.org/software/tar/manual/tar.html#SEC139
### so we do both a signed AND unsigned validate. if one succeeds, that's
### good enough
return ( (unpack ("%16C*", $raw) == $self->chksum)
or (unpack ("%16c*", $raw) == $self->chksum)) ? 1 : 0;
}
=head2 $bool = $file->has_content
Returns a boolean to indicate whether the current object has content.
Some special files like directories and so on never will have any
content. This method is mainly to make sure you don't get warnings
for using uninitialized values when looking at an object's content.
=cut
sub has_content {
my $self = shift;
return defined $self->data() && length $self->data() ? 1 : 0;
}
=head2 $content = $file->get_content
Returns the current content for the in-memory file
=cut
sub get_content {
my $self = shift;
$self->data( );
}
=head2 $cref = $file->get_content_by_ref
Returns the current content for the in-memory file as a scalar
reference. Normal users won't need this, but it will save memory if
you are dealing with very large data files in your tar archive, since
it will pass the contents by reference, rather than make a copy of it
first.
=cut
sub get_content_by_ref {
my $self = shift;
return \$self->{data};
}
=head2 $bool = $file->replace_content( $content )
Replace the current content of the file with the new content. This
only affects the in-memory archive, not the on-disk version until
you write it.
Returns true on success, false on failure.
=cut
sub replace_content {
my $self = shift;
my $data = shift || '';
$self->data( $data );
$self->size( length $data );
return 1;
}
=head2 $bool = $file->rename( $new_name )
Rename the current file to $new_name.
Note that you must specify a Unix path for $new_name, since per tar
standard, all files in the archive must be Unix paths.
Returns true on success and false on failure.
=cut
sub rename {
my $self = shift;
my $path = shift;
return unless defined $path;
my ($prefix,$file) = $self->_prefix_and_file( $path );
$self->name( $file );
$self->prefix( $prefix );
return 1;
}
=head2 $bool = $file->chmod $mode)
Change mode of $file to $mode. The mode can be a string or a number
which is interpreted as octal whether or not a leading 0 is given.
Returns true on success and false on failure.
=cut
sub chmod {
my $self = shift;
my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/;
$self->{mode} = oct($mode);
return 1;
}
=head2 $bool = $file->chown( $user [, $group])
Change owner of $file to $user. If a $group is given that is changed
as well. You can also pass a single parameter with a colon separating the
use and group as in 'root:wheel'.
Returns true on success and false on failure.
=cut
sub chown {
my $self = shift;
my $uname = shift;
return unless defined $uname;
my $gname;
if (-1 != index($uname, ':')) {
($uname, $gname) = split(/:/, $uname);
} else {
$gname = shift if @_ > 0;
}
$self->uname( $uname );
$self->gname( $gname ) if $gname;
return 1;
}
=head1 Convenience methods
To quickly check the type of a C<Archive::Tar::File> object, you can
use the following methods:
=over 4
=item $file->is_file
Returns true if the file is of type C<file>
=item $file->is_dir
Returns true if the file is of type C<dir>
=item $file->is_hardlink
Returns true if the file is of type C<hardlink>
=item $file->is_symlink
Returns true if the file is of type C<symlink>
=item $file->is_chardev
Returns true if the file is of type C<chardev>
=item $file->is_blockdev
Returns true if the file is of type C<blockdev>
=item $file->is_fifo
Returns true if the file is of type C<fifo>
=item $file->is_socket
Returns true if the file is of type C<socket>
=item $file->is_longlink
Returns true if the file is of type C<LongLink>.
Should not happen after a successful C<read>.
=item $file->is_label
Returns true if the file is of type C<Label>.
Should not happen after a successful C<read>.
=item $file->is_unknown
Returns true if the file type is C<unknown>
=back
=cut
#stupid perl5.5.3 needs to warn if it's not numeric
sub is_file { local $^W; FILE == $_[0]->type }
sub is_dir { local $^W; DIR == $_[0]->type }
sub is_hardlink { local $^W; HARDLINK == $_[0]->type }
sub is_symlink { local $^W; SYMLINK == $_[0]->type }
sub is_chardev { local $^W; CHARDEV == $_[0]->type }
sub is_blockdev { local $^W; BLOCKDEV == $_[0]->type }
sub is_fifo { local $^W; FIFO == $_[0]->type }
sub is_socket { local $^W; SOCKET == $_[0]->type }
sub is_unknown { local $^W; UNKNOWN == $_[0]->type }
sub is_longlink { local $^W; LONGLINK eq $_[0]->type }
sub is_label { local $^W; LABEL eq $_[0]->type }
1;

987
gitportable/usr/share/perl5/core_perl/Attribute/Handlers.pm Normal file
View File

@@ -0,0 +1,987 @@
package Attribute::Handlers;
use 5.006;
use Carp;
use warnings;
use strict;
our $AUTOLOAD;
our $VERSION = '1.03'; # remember to update version in POD!
# $DB::single=1;
my $debug= $ENV{DEBUG_ATTRIBUTE_HANDLERS} || 0;
my %symcache;
sub findsym {
my ($pkg, $ref, $type) = @_;
return $symcache{$pkg,$ref} if $symcache{$pkg,$ref};
$type ||= ref($ref);
no strict 'refs';
my $symtab = \%{$pkg."::"};
for ( keys %$symtab ) { for my $sym ( $$symtab{$_} ) {
if (ref $sym && $sym == $ref) {
return $symcache{$pkg,$ref} = \*{"$pkg:\:$_"};
}
use strict;
next unless ref ( \$sym ) eq 'GLOB';
return $symcache{$pkg,$ref} = \$sym
if *{$sym}{$type} && *{$sym}{$type} == $ref;
}}
}
my %validtype = (
VAR => [qw[SCALAR ARRAY HASH]],
ANY => [qw[SCALAR ARRAY HASH CODE]],
"" => [qw[SCALAR ARRAY HASH CODE]],
SCALAR => [qw[SCALAR]],
ARRAY => [qw[ARRAY]],
HASH => [qw[HASH]],
CODE => [qw[CODE]],
);
my %lastattr;
my @declarations;
my %raw;
my %phase;
my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%');
my $global_phase = 0;
my %global_phases = (
BEGIN => 0,
CHECK => 1,
INIT => 2,
END => 3,
);
my @global_phases = qw(BEGIN CHECK INIT END);
sub _usage_AH_ {
croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}";
}
my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i;
sub import {
my $class = shift @_;
return unless $class eq "Attribute::Handlers";
while (@_) {
my $cmd = shift;
if ($cmd =~ /^autotie((?:ref)?)$/) {
my $tiedata = ($1 ? '$ref, ' : '') . '@$data';
my $mapping = shift;
_usage_AH_ $class unless ref($mapping) eq 'HASH';
while (my($attr, $tieclass) = each %$mapping) {
$tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is;
my $args = $3||'()';
_usage_AH_ $class unless $attr =~ $qual_id
&& $tieclass =~ $qual_id
&& eval "use base q\0$tieclass\0; 1";
if ($tieclass->isa('Exporter')) {
local $Exporter::ExportLevel = 2;
$tieclass->import(eval $args);
}
my $code = qq{
: ATTR(VAR) {
my (\$ref, \$data) = \@_[2,4];
my \$was_arrayref = ref \$data eq 'ARRAY';
\$data = [ \$data ] unless \$was_arrayref;
my \$type = ref(\$ref)||"value (".(\$ref||"<undef>").")";
(\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata
:(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata
:(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata
: die "Can't autotie a \$type\n"
}
};
if ($attr =~ /\A__CALLER__::/) {
no strict 'refs';
my $add_import = caller;
my $next = defined &{ $add_import . '::import' } && \&{ $add_import . '::import' };
*{ $add_import . '::import' } = sub {
my $caller = caller;
my $full_attr = $attr;
$full_attr =~ s/__CALLER__/$caller/;
eval qq{ sub $full_attr $code 1; }
or die "Internal error: $@";
goto &$next
if $next;
my $uni = defined &UNIVERSAL::import && \&UNIVERSAL::import;
for my $isa (@{ $add_import . '::ISA' }) {
if (my $import = $isa->can('import')) {
goto &$import
if $import != $uni;
}
}
goto &$uni
if $uni;
};
}
else {
$attr = caller()."::".$attr unless $attr =~ /::/;
eval qq{ sub $attr $code 1; }
or die "Internal error: $@";
}
}
}
else {
croak "Can't understand $_";
}
}
}
# On older perls, code attribute handlers run before the sub gets placed
# in its package. Since the :ATTR handlers need to know the name of the
# sub they're applied to, the name lookup (via findsym) needs to be
# delayed: we do it immediately before we might need to find attribute
# handlers from their name. However, on newer perls (which fix some
# problems relating to attribute application), a sub gets placed in its
# package before its attributes are processed. In this case, the
# delayed name lookup might be too late, because the sub we're looking
# for might have already been replaced. So we need to detect which way
# round this perl does things, and time the name lookup accordingly.
BEGIN {
my $delayed;
sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES {
$delayed = \&Attribute::Handlers::_TEST_::t != $_[1];
return ();
}
sub Attribute::Handlers::_TEST_::t :T { }
*_delayed_name_resolution = sub() { $delayed };
undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES;
undef &Attribute::Handlers::_TEST_::t;
}
sub _resolve_lastattr {
return unless $lastattr{ref};
my $sym = findsym @lastattr{'pkg','ref'}
or die "Internal error: $lastattr{pkg} symbol went missing";
my $name = *{$sym}{NAME};
warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n"
if $^W and $name !~ /[A-Z]/;
foreach ( @{$validtype{$lastattr{type}}} ) {
no strict 'refs';
*{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref};
}
%lastattr = ();
}
sub AUTOLOAD {
return if $AUTOLOAD =~ /::DESTROY$/;
my ($class) = $AUTOLOAD =~ m/(.*)::/g;
$AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or
croak "Can't locate class method '$AUTOLOAD' via package '$class'";
croak "Attribute handler '$2' doesn't handle $1 attributes";
}
my $builtin = $] ge '5.027000'
? qr/lvalue|method|shared/
: qr/lvalue|method|locked|shared|unique/;
sub _gen_handler_AH_() {
return sub {
_resolve_lastattr if _delayed_name_resolution;
my ($pkg, $ref, @attrs) = @_;
my (undef, $filename, $linenum) = caller 2;
foreach (@attrs) {
my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
if ($attr eq 'ATTR') {
no strict 'refs';
$data ||= "ANY";
$raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//;
$phase{$ref}{BEGIN} = 1
if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//;
$phase{$ref}{INIT} = 1
if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//;
$phase{$ref}{END} = 1
if $data =~ s/\s*,?\s*(END)\s*,?\s*//;
$phase{$ref}{CHECK} = 1
if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*//
|| ! keys %{$phase{$ref}};
# Added for cleanup to not pollute next call.
(%lastattr = ()),
croak "Can't have two ATTR specifiers on one subroutine"
if keys %lastattr;
croak "Bad attribute type: ATTR($data)"
unless $validtype{$data};
%lastattr=(pkg=>$pkg,ref=>$ref,type=>$data);
_resolve_lastattr unless _delayed_name_resolution;
}
else {
my $type = ref $ref;
my $handler = $pkg->can("_ATTR_${type}_${attr}");
next unless $handler;
my $decl = [$pkg, $ref, $attr, $data,
$raw{$handler}, $phase{$handler}, $filename, $linenum];
foreach my $gphase (@global_phases) {
_apply_handler_AH_($decl,$gphase)
if $global_phases{$gphase} <= $global_phase;
}
if ($global_phase != 0) {
# if _gen_handler_AH_ is being called after
# CHECK it's for a lexical, so make sure
# it didn't want to run anything later
local $Carp::CarpLevel = 2;
carp "Won't be able to apply END handler"
if $phase{$handler}{END};
}
else {
push @declarations, $decl
}
}
$_ = undef;
}
return grep {defined && !/$builtin/} @attrs;
}
}
{
no strict 'refs';
*{"Attribute::Handlers::UNIVERSAL::MODIFY_${_}_ATTRIBUTES"} =
_gen_handler_AH_ foreach @{$validtype{ANY}};
}
push @UNIVERSAL::ISA, 'Attribute::Handlers::UNIVERSAL'
unless grep /^Attribute::Handlers::UNIVERSAL$/, @UNIVERSAL::ISA;
sub _apply_handler_AH_ {
my ($declaration, $phase) = @_;
my ($pkg, $ref, $attr, $data, $raw, $handlerphase, $filename, $linenum) = @$declaration;
return unless $handlerphase->{$phase};
print STDERR "Handling $attr on $ref in $phase with [$data]\n"
if $debug;
my $type = ref $ref;
my $handler = "_ATTR_${type}_${attr}";
my $sym = findsym($pkg, $ref);
$sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL';
no warnings;
if (!$raw && defined($data)) {
if ($data ne '') {
# keeping the minimum amount of code inside the eval string
# makes debugging perl internals issues with this logic easier.
my $code= "package $pkg; my \$ref= [$data]; \$data= \$ref; 1";
print STDERR "Evaling: '$code'\n"
if $debug;
local $SIG{__WARN__} = sub{ die };
no strict;
no warnings;
# Note in production we do not need to use the return value from
# the eval or even consult $@ after the eval - if the evaled code
# compiles and runs successfully then it will update $data with
# the compiled form, if it fails then $data stays unchanged. The
# return value and $@ are only used for debugging purposes.
# IOW we could just replace the following with eval($code);
eval($code) or do {
print STDERR "Eval failed: $@"
if $debug;
};
}
else { $data = undef }
}
# now call the handler with the $data decoded (maybe)
$pkg->$handler($sym,
(ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref),
$attr,
$data,
$phase,
$filename,
$linenum,
);
return 1;
}
{
no warnings 'void';
CHECK {
$global_phase++;
_resolve_lastattr if _delayed_name_resolution;
foreach my $decl (@declarations) {
_apply_handler_AH_($decl, 'CHECK');
}
}
INIT {
$global_phase++;
foreach my $decl (@declarations) {
_apply_handler_AH_($decl, 'INIT');
}
}
}
END {
$global_phase++;
foreach my $decl (@declarations) {
_apply_handler_AH_($decl, 'END');
}
}
1;
__END__
=head1 NAME
Attribute::Handlers - Simpler definition of attribute handlers
=head1 VERSION
This document describes version 1.03 of Attribute::Handlers.
=head1 SYNOPSIS
package MyClass;
require 5.006;
use Attribute::Handlers;
no warnings 'redefine';
sub Good : ATTR(SCALAR) {
my ($package, $symbol, $referent, $attr, $data) = @_;
# Invoked for any scalar variable with a :Good attribute,
# provided the variable was declared in MyClass (or
# a derived class) or typed to MyClass.
# Do whatever to $referent here (executed in CHECK phase).
...
}
sub Bad : ATTR(SCALAR) {
# Invoked for any scalar variable with a :Bad attribute,
# provided the variable was declared in MyClass (or
# a derived class) or typed to MyClass.
...
}
sub Good : ATTR(ARRAY) {
# Invoked for any array variable with a :Good attribute,
# provided the variable was declared in MyClass (or
# a derived class) or typed to MyClass.
...
}
sub Good : ATTR(HASH) {
# Invoked for any hash variable with a :Good attribute,
# provided the variable was declared in MyClass (or
# a derived class) or typed to MyClass.
...
}
sub Ugly : ATTR(CODE) {
# Invoked for any subroutine declared in MyClass (or a
# derived class) with an :Ugly attribute.
...
}
sub Omni : ATTR {
# Invoked for any scalar, array, hash, or subroutine
# with an :Omni attribute, provided the variable or
# subroutine was declared in MyClass (or a derived class)
# or the variable was typed to MyClass.
# Use ref($_[2]) to determine what kind of referent it was.
...
}
use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
my $next : Cycle(['A'..'Z']);
=head1 DESCRIPTION
This module, when inherited by a package, allows that package's class to
define attribute handler subroutines for specific attributes. Variables
and subroutines subsequently defined in that package, or in packages
derived from that package may be given attributes with the same names as
the attribute handler subroutines, which will then be called in one of
the compilation phases (i.e. in a C<BEGIN>, C<CHECK>, C<INIT>, or C<END>
block). (C<UNITCHECK> blocks don't correspond to a global compilation
phase, so they can't be specified here.)
To create a handler, define it as a subroutine with the same name as
the desired attribute, and declare the subroutine itself with the
attribute C<:ATTR>. For example:
package LoudDecl;
use Attribute::Handlers;
sub Loud :ATTR {
my ($package, $symbol, $referent, $attr, $data, $phase,
$filename, $linenum) = @_;
print STDERR
ref($referent), " ",
*{$symbol}{NAME}, " ",
"($referent) ", "was just declared ",
"and ascribed the ${attr} attribute ",
"with data ($data)\n",
"in phase $phase\n",
"in file $filename at line $linenum\n";
}
This creates a handler for the attribute C<:Loud> in the class LoudDecl.
Thereafter, any subroutine declared with a C<:Loud> attribute in the class
LoudDecl:
package LoudDecl;
sub foo: Loud {...}
causes the above handler to be invoked, and passed:
=over
=item [0]
the name of the package into which it was declared;
=item [1]
a reference to the symbol table entry (typeglob) containing the subroutine;
=item [2]
a reference to the subroutine;
=item [3]
the name of the attribute;
=item [4]
any data associated with that attribute;
=item [5]
the name of the phase in which the handler is being invoked;
=item [6]
the filename in which the handler is being invoked;
=item [7]
the line number in this file.
=back
Likewise, declaring any variables with the C<:Loud> attribute within the
package:
package LoudDecl;
my $foo :Loud;
my @foo :Loud;
my %foo :Loud;
will cause the handler to be called with a similar argument list (except,
of course, that C<$_[2]> will be a reference to the variable).
The package name argument will typically be the name of the class into
which the subroutine was declared, but it may also be the name of a derived
class (since handlers are inherited).
If a lexical variable is given an attribute, there is no symbol table to
which it belongs, so the symbol table argument (C<$_[1]>) is set to the
string C<'LEXICAL'> in that case. Likewise, ascribing an attribute to
an anonymous subroutine results in a symbol table argument of C<'ANON'>.
The data argument passes in the value (if any) associated with the
attribute. For example, if C<&foo> had been declared:
sub foo :Loud("turn it up to 11, man!") {...}
then a reference to an array containing the string
C<"turn it up to 11, man!"> would be passed as the last argument.
Attribute::Handlers makes strenuous efforts to convert
the data argument (C<$_[4]>) to a usable form before passing it to
the handler (but see L<"Non-interpretive attribute handlers">).
If those efforts succeed, the interpreted data is passed in an array
reference; if they fail, the raw data is passed as a string.
For example, all of these:
sub foo :Loud(till=>ears=>are=>bleeding) {...}
sub foo :Loud(qw/till ears are bleeding/) {...}
sub foo :Loud(qw/till, ears, are, bleeding/) {...}
sub foo :Loud(till,ears,are,bleeding) {...}
causes it to pass C<['till','ears','are','bleeding']> as the handler's
data argument. While:
sub foo :Loud(['till','ears','are','bleeding']) {...}
causes it to pass C<[ ['till','ears','are','bleeding'] ]>; the array
reference specified in the data being passed inside the standard
array reference indicating successful interpretation.
However, if the data can't be parsed as valid Perl, then
it is passed as an uninterpreted string. For example:
sub foo :Loud(my,ears,are,bleeding) {...}
sub foo :Loud(qw/my ears are bleeding) {...}
cause the strings C<'my,ears,are,bleeding'> and
C<'qw/my ears are bleeding'> respectively to be passed as the
data argument.
If no value is associated with the attribute, C<undef> is passed.
=head2 Typed lexicals
Regardless of the package in which it is declared, if a lexical variable is
ascribed an attribute, the handler that is invoked is the one belonging to
the package to which it is typed. For example, the following declarations:
package OtherClass;
my LoudDecl $loudobj : Loud;
my LoudDecl @loudobjs : Loud;
my LoudDecl %loudobjex : Loud;
causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
defines a handler for C<:Loud> attributes).
=head2 Type-specific attribute handlers
If an attribute handler is declared and the C<:ATTR> specifier is
given the name of a built-in type (C<SCALAR>, C<ARRAY>, C<HASH>, or C<CODE>),
the handler is only applied to declarations of that type. For example,
the following definition:
package LoudDecl;
sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
creates an attribute handler that applies only to scalars:
package Painful;
use base LoudDecl;
my $metal : RealLoud; # invokes &LoudDecl::RealLoud
my @metal : RealLoud; # error: unknown attribute
my %metal : RealLoud; # error: unknown attribute
sub metal : RealLoud {...} # error: unknown attribute
You can, of course, declare separate handlers for these types as well
(but you'll need to specify C<no warnings 'redefine'> to do it quietly):
package LoudDecl;
use Attribute::Handlers;
no warnings 'redefine';
sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
You can also explicitly indicate that a single handler is meant to be
used for all types of referents like so:
package LoudDecl;
use Attribute::Handlers;
sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
(I.e. C<ATTR(ANY)> is a synonym for C<:ATTR>).
=head2 Non-interpretive attribute handlers
Occasionally the strenuous efforts Attribute::Handlers makes to convert
the data argument (C<$_[4]>) to a usable form before passing it to
the handler get in the way.
You can turn off that eagerness-to-help by declaring
an attribute handler with the keyword C<RAWDATA>. For example:
sub Raw : ATTR(RAWDATA) {...}
sub Nekkid : ATTR(SCALAR,RAWDATA) {...}
sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
Then the handler makes absolutely no attempt to interpret the data it
receives and simply passes it as a string:
my $power : Raw(1..100); # handlers receives "1..100"
=head2 Phase-specific attribute handlers
By default, attribute handlers are called at the end of the compilation
phase (in a C<CHECK> block). This seems to be optimal in most cases because
most things that can be defined are defined by that point but nothing has
been executed.
However, it is possible to set up attribute handlers that are called at
other points in the program's compilation or execution, by explicitly
stating the phase (or phases) in which you wish the attribute handler to
be called. For example:
sub Early :ATTR(SCALAR,BEGIN) {...}
sub Normal :ATTR(SCALAR,CHECK) {...}
sub Late :ATTR(SCALAR,INIT) {...}
sub Final :ATTR(SCALAR,END) {...}
sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
As the last example indicates, a handler may be set up to be (re)called in
two or more phases. The phase name is passed as the handler's final argument.
Note that attribute handlers that are scheduled for the C<BEGIN> phase
are handled as soon as the attribute is detected (i.e. before any
subsequently defined C<BEGIN> blocks are executed).
=head2 Attributes as C<tie> interfaces
Attributes make an excellent and intuitive interface through which to tie
variables. For example:
use Attribute::Handlers;
use Tie::Cycle;
sub UNIVERSAL::Cycle : ATTR(SCALAR) {
my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
$data = [ $data ] unless ref $data eq 'ARRAY';
tie $$referent, 'Tie::Cycle', $data;
}
# and thereafter...
package main;
my $next : Cycle('A'..'Z'); # $next is now a tied variable
while (<>) {
print $next;
}
Note that, because the C<Cycle> attribute receives its arguments in the
C<$data> variable, if the attribute is given a list of arguments, C<$data>
will consist of a single array reference; otherwise, it will consist of the
single argument directly. Since Tie::Cycle requires its cycling values to
be passed as an array reference, this means that we need to wrap
non-array-reference arguments in an array constructor:
$data = [ $data ] unless ref $data eq 'ARRAY';
Typically, however, things are the other way around: the tieable class expects
its arguments as a flattened list, so the attribute looks like:
sub UNIVERSAL::Cycle : ATTR(SCALAR) {
my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
my @data = ref $data eq 'ARRAY' ? @$data : $data;
tie $$referent, 'Tie::Whatever', @data;
}
This software pattern is so widely applicable that Attribute::Handlers
provides a way to automate it: specifying C<'autotie'> in the
C<use Attribute::Handlers> statement. So, the cycling example,
could also be written:
use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
# and thereafter...
package main;
my $next : Cycle(['A'..'Z']); # $next is now a tied variable
while (<>) {
print $next;
}
Note that we now have to pass the cycling values as an array reference,
since the C<autotie> mechanism passes C<tie> a list of arguments as a list
(as in the Tie::Whatever example), I<not> as an array reference (as in
the original Tie::Cycle example at the start of this section).
The argument after C<'autotie'> is a reference to a hash in which each key is
the name of an attribute to be created, and each value is the class to which
variables ascribed that attribute should be tied.
Note that there is no longer any need to import the Tie::Cycle module --
Attribute::Handlers takes care of that automagically. You can even pass
arguments to the module's C<import> subroutine, by appending them to the
class name. For example:
use Attribute::Handlers
autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
If the attribute name is unqualified, the attribute is installed in the
current package. Otherwise it is installed in the qualifier's package:
package Here;
use Attribute::Handlers autotie => {
Other::Good => Tie::SecureHash, # tie attr installed in Other::
Bad => Tie::Taxes, # tie attr installed in Here::
UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
};
Autoties are most commonly used in the module to which they actually tie,
and need to export their attributes to any module that calls them. To
facilitate this, Attribute::Handlers recognizes a special "pseudo-class" --
C<__CALLER__>, which may be specified as the qualifier of an attribute:
package Tie::Me::Kangaroo::Down::Sport;
use Attribute::Handlers autotie =>
{ '__CALLER__::Roo' => __PACKAGE__ };
This causes Attribute::Handlers to define the C<Roo> attribute in the package
that imports the Tie::Me::Kangaroo::Down::Sport module.
Note that it is important to quote the __CALLER__::Roo identifier because
a bug in perl 5.8 will refuse to parse it and cause an unknown error.
=head3 Passing the tied object to C<tie>
Occasionally it is important to pass a reference to the object being tied
to the TIESCALAR, TIEHASH, etc. that ties it.
The C<autotie> mechanism supports this too. The following code:
use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
my $var : Selfish(@args);
has the same effect as:
tie my $var, 'Tie::Selfish', @args;
But when C<"autotieref"> is used instead of C<"autotie">:
use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
my $var : Selfish(@args);
the effect is to pass the C<tie> call an extra reference to the variable
being tied:
tie my $var, 'Tie::Selfish', \$var, @args;
=head1 EXAMPLES
If the class shown in L</SYNOPSIS> were placed in the MyClass.pm
module, then the following code:
package main;
use MyClass;
my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
package SomeOtherClass;
use base MyClass;
sub tent { 'acle' }
sub fn :Ugly(sister) :Omni('po',tent()) {...}
my @arr :Good :Omni(s/cie/nt/);
my %hsh :Good(q/bye/) :Omni(q/bus/);
would cause the following handlers to be invoked:
# my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
MyClass::Good:ATTR(SCALAR)( 'MyClass', # class
'LEXICAL', # no typeglob
\$slr, # referent
'Good', # attr name
undef # no attr data
'CHECK', # compiler phase
);
MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class
'LEXICAL', # no typeglob
\$slr, # referent
'Bad', # attr name
0 # eval'd attr data
'CHECK', # compiler phase
);
MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class
'LEXICAL', # no typeglob
\$slr, # referent
'Omni', # attr name
'-vorous' # eval'd attr data
'CHECK', # compiler phase
);
# sub fn :Ugly(sister) :Omni('po',tent()) {...}
MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class
\*SomeOtherClass::fn, # typeglob
\&SomeOtherClass::fn, # referent
'Ugly', # attr name
'sister' # eval'd attr data
'CHECK', # compiler phase
);
MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class
\*SomeOtherClass::fn, # typeglob
\&SomeOtherClass::fn, # referent
'Omni', # attr name
['po','acle'] # eval'd attr data
'CHECK', # compiler phase
);
# my @arr :Good :Omni(s/cie/nt/);
MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class
'LEXICAL', # no typeglob
\@arr, # referent
'Good', # attr name
undef # no attr data
'CHECK', # compiler phase
);
MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class
'LEXICAL', # no typeglob
\@arr, # referent
'Omni', # attr name
"" # eval'd attr data
'CHECK', # compiler phase
);
# my %hsh :Good(q/bye) :Omni(q/bus/);
MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class
'LEXICAL', # no typeglob
\%hsh, # referent
'Good', # attr name
'q/bye' # raw attr data
'CHECK', # compiler phase
);
MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class
'LEXICAL', # no typeglob
\%hsh, # referent
'Omni', # attr name
'bus' # eval'd attr data
'CHECK', # compiler phase
);
Installing handlers into UNIVERSAL, makes them...err..universal.
For example:
package Descriptions;
use Attribute::Handlers;
my %name;
sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
sub UNIVERSAL::Name :ATTR {
$name{$_[2]} = $_[4];
}
sub UNIVERSAL::Purpose :ATTR {
print STDERR "Purpose of ", &name, " is $_[4]\n";
}
sub UNIVERSAL::Unit :ATTR {
print STDERR &name, " measured in $_[4]\n";
}
Let's you write:
use Descriptions;
my $capacity : Name(capacity)
: Purpose(to store max storage capacity for files)
: Unit(Gb);
package Other;
sub foo : Purpose(to foo all data before barring it) { }
# etc.
=head1 UTILITY FUNCTIONS
This module offers a single utility function, C<findsym()>.
=over 4
=item findsym
my $symbol = Attribute::Handlers::findsym($package, $referent);
The function looks in the symbol table of C<$package> for the typeglob for
C<$referent>, which is a reference to a variable or subroutine (SCALAR, ARRAY,
HASH, or CODE). If it finds the typeglob, it returns it. Otherwise, it returns
undef. Note that C<findsym> memoizes the typeglobs it has previously
successfully found, so subsequent calls with the same arguments should be
much faster.
=back
=head1 DIAGNOSTICS
=over
=item C<Bad attribute type: ATTR(%s)>
An attribute handler was specified with an C<:ATTR(I<ref_type>)>, but the
type of referent it was defined to handle wasn't one of the five permitted:
C<SCALAR>, C<ARRAY>, C<HASH>, C<CODE>, or C<ANY>.
=item C<Attribute handler %s doesn't handle %s attributes>
A handler for attributes of the specified name I<was> defined, but not
for the specified type of declaration. Typically encountered when trying
to apply a C<VAR> attribute handler to a subroutine, or a C<SCALAR>
attribute handler to some other type of variable.
=item C<Declaration of %s attribute in package %s may clash with future reserved word>
A handler for an attributes with an all-lowercase name was declared. An
attribute with an all-lowercase name might have a meaning to Perl
itself some day, even though most don't yet. Use a mixed-case attribute
name, instead.
=item C<Can't have two ATTR specifiers on one subroutine>
You just can't, okay?
Instead, put all the specifications together with commas between them
in a single C<ATTR(I<specification>)>.
=item C<Can't autotie a %s>
You can only declare autoties for types C<"SCALAR">, C<"ARRAY">, and
C<"HASH">. They're the only things (apart from typeglobs -- which are
not declarable) that Perl can tie.
=item C<Internal error: %s symbol went missing>
Something is rotten in the state of the program. An attributed
subroutine ceased to exist between the point it was declared and the point
at which its attribute handler(s) would have been called.
=item C<Won't be able to apply END handler>
You have defined an END handler for an attribute that is being applied
to a lexical variable. Since the variable may not be available during END
this won't happen.
=back
=head1 AUTHOR
Damian Conway (damian@conway.org). The maintainer of this module is now Rafael
Garcia-Suarez (rgarciasuarez@gmail.com).
Maintainer of the CPAN release is Steffen Mueller (smueller@cpan.org).
Contact him with technical difficulties with respect to the packaging of the
CPAN module.
=head1 BUGS
There are undoubtedly serious bugs lurking somewhere in code this funky :-)
Bug reports and other feedback are most welcome.
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2001-2014, Damian Conway. All Rights Reserved.
This module is free software. It may be used, redistributed
and/or modified under the same terms as Perl itself.

453
gitportable/usr/share/perl5/core_perl/AutoLoader.pm Normal file
View File

@@ -0,0 +1,453 @@
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__
=head1 NAME
AutoLoader - load subroutines only on demand
=head1 SYNOPSIS
package Foo;
use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
package Bar;
use AutoLoader; # don't import AUTOLOAD, define our own
sub AUTOLOAD {
...
$AutoLoader::AUTOLOAD = "...";
goto &AutoLoader::AUTOLOAD;
}
=head1 DESCRIPTION
The B<AutoLoader> module works with the B<AutoSplit> module and the
C<__END__> token to defer the loading of some subroutines until they are
used rather than loading them all at once.
To use B<AutoLoader>, the author of a module has to place the
definitions of subroutines to be autoloaded after an C<__END__> token.
(See L<perldata>.) The B<AutoSplit> module can then be run manually to
extract the definitions into individual files F<auto/funcname.al>.
B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
subroutine in is called in a client module of B<AutoLoader>,
B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
file with a name related to the location of the file from which the
client module was read. As an example, if F<POSIX.pm> is located in
F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
the C<.al> file has the same name as the subroutine, sans package. If
such a file exists, AUTOLOAD will read and evaluate it,
thus (presumably) defining the needed subroutine. AUTOLOAD will then
C<goto> the newly defined subroutine.
Once this process completes for a given function, it is defined, so
future calls to the subroutine will bypass the AUTOLOAD mechanism.
=head2 Subroutine Stubs
In order for object method lookup and/or prototype checking to operate
correctly even when methods have not yet been defined it is necessary to
"forward declare" each subroutine (as in C<sub NAME;>). See
L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
stubs", which are place holders with no code.
The AutoSplit and B<AutoLoader> modules automate the creation of forward
declarations. The AutoSplit module creates an 'index' file containing
forward declarations of all the AutoSplit subroutines. When the
AutoLoader module is 'use'd it loads these declarations into its callers
package.
Because of this mechanism it is important that B<AutoLoader> is always
C<use>d and not C<require>d.
=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
explicitly import it:
use AutoLoader 'AUTOLOAD';
=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
They typically need to check for some special cases (such as constants)
and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
Instead, they should define their own AUTOLOAD subroutines along these
lines:
use AutoLoader;
use Carp;
sub AUTOLOAD {
my $sub = $AUTOLOAD;
(my $constname = $sub) =~ s/.*:://;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
if ($! =~ /Invalid/ || $!{EINVAL}) {
$AutoLoader::AUTOLOAD = $sub;
goto &AutoLoader::AUTOLOAD;
}
else {
croak "Your vendor has not defined constant $constname";
}
}
*$sub = sub { $val }; # same as: eval "sub $sub { $val }";
goto &$sub;
}
If any module's own AUTOLOAD subroutine has no need to fallback to the
AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
subroutines), then that module should not use B<AutoLoader> at all.
=head2 Package Lexicals
Package lexicals declared with C<my> in the main block of a package
using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
the fact that the given scope ends at the C<__END__> marker. A module
using such variables as package globals will not work properly under the
B<AutoLoader>.
The C<vars> pragma (see L<perlmod/"vars">) may be used in such
situations as an alternative to explicitly qualifying all globals with
the package namespace. Variables pre-declared with this pragma will be
visible to any autoloaded routines (but will not be invisible outside
the package, unfortunately).
=head2 Not Using AutoLoader
You can stop using AutoLoader by simply
no AutoLoader;
=head2 B<AutoLoader> vs. B<SelfLoader>
The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
loading of subroutines.
B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
While this avoids the use of a hierarchy of disk files and the
associated open/close for each routine loaded, B<SelfLoader> suffers a
startup speed disadvantage in the one-time parsing of the lines after
C<__DATA__>, after which routines are cached. B<SelfLoader> can also
handle multiple packages in a file.
B<AutoLoader> only reads code as it is requested, and in many cases
should be faster, but requires a mechanism like B<AutoSplit> be used to
create the individual files. L<ExtUtils::MakeMaker> will invoke
B<AutoSplit> automatically if B<AutoLoader> is used in a module source
file.
=head2 Forcing AutoLoader to Load a Function
Sometimes, it can be necessary or useful to make sure that a certain
function is fully loaded by AutoLoader. This is the case, for example,
when you need to wrap a function to inject debugging code. It is also
helpful to force early loading of code before forking to make use of
copy-on-write as much as possible.
Starting with AutoLoader 5.73, you can call the
C<AutoLoader::autoload_sub> function with the fully-qualified name of
the function to load from its F<.al> file. The behaviour is exactly
the same as if you called the function, triggering the regular
C<AUTOLOAD> mechanism, but it does not actually execute the
autoloaded function.
=head1 CAVEATS
AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
old modules which use B<AutoLoader> should be changed to the new calling
style. Typically this just means changing a require to a use, adding
the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
from C<@ISA>.
On systems with restrictions on file name length, the file corresponding
to a subroutine may have a shorter name that the routine itself. This
can lead to conflicting file names. The I<AutoSplit> package warns of
these potential conflicts when used to split a module.
AutoLoader may fail to find the autosplit files (or even find the wrong
ones) in cases where C<@INC> contains relative paths, B<and> the program
does C<chdir>.
=head1 SEE ALSO
L<SelfLoader> - an autoloader that doesn't use external files.
=head1 AUTHOR
C<AutoLoader> is maintained by the perl5-porters. Please direct
any questions to the canonical mailing list. Anything that
is applicable to the CPAN release can be sent to its maintainer,
though.
Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
=head1 COPYRIGHT AND LICENSE
This package has been part of the perl core since the first release
of perl5. It has been released separately to CPAN so older installations
can benefit from bug fixes.
This package has the same copyright and license as the perl core:
Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
2011, 2012, 2013
by Larry Wall and others
All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the terms of either:
a) the GNU General Public License as published by the Free
Software Foundation; either version 1, or (at your option) any
later version, or
b) the "Artistic License" which comes with this Kit.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
the GNU General Public License or the Artistic License for more details.
You should have received a copy of the Artistic License with this
Kit, in the file named "Artistic". If not, I'll be glad to provide one.
You should also have received a copy of the GNU General Public License
along with this program in the file named "Copying". If not, write to the
Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
MA 02110-1301, USA or visit their web page on the internet at
http://www.gnu.org/copyleft/gpl.html.
For those of you that choose to use the GNU General Public License,
my interpretation of the GNU General Public License is that no Perl
script falls under the terms of the GPL unless you explicitly put
said script under the terms of the GPL yourself. Furthermore, any
object code linked with perl does not automatically fall under the
terms of the GPL, provided such object code only adds definitions
of subroutines and variables, and does not otherwise impair the
resulting interpreter from executing any standard Perl script. I
consider linking in C subroutines in this manner to be the moral
equivalent of defining subroutines in the Perl language itself. You
may sell such an object file as proprietary provided that you provide
or offer to provide the Perl source, as specified by the GNU General
Public License. (This is merely an alternate way of specifying input
to the program.) You may also sell a binary produced by the dumping of
a running Perl script that belongs to you, provided that you provide or
offer to provide the Perl source as specified by the GPL. (The
fact that a Perl interpreter and your code are in the same binary file
is, in this case, a form of mere aggregation.) This is my interpretation
of the GPL. If you still have concerns or difficulties understanding
my intent, feel free to contact me. Of course, the Artistic License
spells all this out for your protection, so you may prefer to use that.
=cut

592
gitportable/usr/share/perl5/core_perl/AutoSplit.pm Normal file
View File

@@ -0,0 +1,592 @@
package AutoSplit;
use Exporter ();
use Config qw(%Config);
use File::Basename ();
use File::Path qw(mkpath);
use File::Spec::Functions qw(curdir catfile catdir);
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
$CheckForAutoloader, $CheckModTime);
$VERSION = "1.06";
@ISA = qw(Exporter);
@EXPORT = qw(&autosplit &autosplit_lib_modules);
@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
=head1 NAME
AutoSplit - split a package for autoloading
=head1 SYNOPSIS
autosplit($file, $dir, $keep, $check, $modtime);
autosplit_lib_modules(@modules);
=head1 DESCRIPTION
This function will split up your program into files that the AutoLoader
module can handle. It is used by both the standard perl libraries and by
the MakeMaker utility, to automatically configure libraries for autoloading.
The C<autosplit> interface splits the specified file into a hierarchy
rooted at the directory C<$dir>. It creates directories as needed to reflect
class hierarchy, and creates the file F<autosplit.ix>. This file acts as
both forward declaration of all package routines, and as timestamp for the
last update of the hierarchy.
The remaining three arguments to C<autosplit> govern other options to
the autosplitter.
=over 2
=item $keep
If the third argument, I<$keep>, is false, then any
pre-existing C<*.al> files in the autoload directory are removed if
they are no longer part of the module (obsoleted functions).
$keep defaults to 0.
=item $check
The
fourth argument, I<$check>, instructs C<autosplit> to check the module
currently being split to ensure that it includes a C<use>
specification for the AutoLoader module, and skips the module if
AutoLoader is not detected.
$check defaults to 1.
=item $modtime
Lastly, the I<$modtime> argument specifies
that C<autosplit> is to check the modification time of the module
against that of the C<autosplit.ix> file, and only split the module if
it is newer.
$modtime defaults to 1.
=back
Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
with:
perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
Defined as a Make macro, it is invoked with file and directory arguments;
C<autosplit> will split the specified file into the specified directory and
delete obsolete C<.al> files, after checking first that the module does use
the AutoLoader, and ensuring that the module is not already currently split
in its current form (the modtime test).
The C<autosplit_lib_modules> form is used in the building of perl. It takes
as input a list of files (modules) that are assumed to reside in a directory
B<lib> relative to the current directory. Each file is sent to the
autosplitter one at a time, to be split into the directory B<lib/auto>.
In both usages of the autosplitter, only subroutines defined following the
perl I<__END__> token are split out into separate files. Some
routines may be placed prior to this marker to force their immediate loading
and parsing.
=head2 Multiple packages
As of version 1.01 of the AutoSplit module it is possible to have
multiple packages within a single file. Both of the following cases
are supported:
package NAME;
__END__
sub AAA { ... }
package NAME::option1;
sub BBB { ... }
package NAME::option2;
sub BBB { ... }
package NAME;
__END__
sub AAA { ... }
sub NAME::option1::BBB { ... }
sub NAME::option2::BBB { ... }
=head1 DIAGNOSTICS
C<AutoSplit> will inform the user if it is necessary to create the
top-level directory specified in the invocation. It is preferred that
the script or installation process that invokes C<AutoSplit> have
created the full directory path ahead of time. This warning may
indicate that the module is being split into an incorrect path.
C<AutoSplit> will warn the user of all subroutines whose name causes
potential file naming conflicts on machines with drastically limited
(8 characters or less) file name length. Since the subroutine name is
used as the file name, these warnings can aid in portability to such
systems.
Warnings are issued and the file skipped if C<AutoSplit> cannot locate
either the I<__END__> marker or a "package Name;"-style specification.
C<AutoSplit> will also emit general diagnostics for inability to
create directories or files.
=head1 AUTHOR
C<AutoSplit> is maintained by the perl5-porters. Please direct
any questions to the canonical mailing list. Anything that
is applicable to the CPAN release can be sent to its maintainer,
though.
Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
=head1 COPYRIGHT AND LICENSE
This package has been part of the perl core since the first release
of perl5. It has been released separately to CPAN so older installations
can benefit from bug fixes.
This package has the same copyright and license as the perl core:
Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
by Larry Wall and others
All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the terms of either:
a) the GNU General Public License as published by the Free
Software Foundation; either version 1, or (at your option) any
later version, or
b) the "Artistic License" which comes with this Kit.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
the GNU General Public License or the Artistic License for more details.
You should have received a copy of the Artistic License with this
Kit, in the file named "Artistic". If not, I'll be glad to provide one.
You should also have received a copy of the GNU General Public License
along with this program in the file named "Copying". If not, write to the
Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
02111-1307, USA or visit their web page on the internet at
http://www.gnu.org/copyleft/gpl.html.
For those of you that choose to use the GNU General Public License,
my interpretation of the GNU General Public License is that no Perl
script falls under the terms of the GPL unless you explicitly put
said script under the terms of the GPL yourself. Furthermore, any
object code linked with perl does not automatically fall under the
terms of the GPL, provided such object code only adds definitions
of subroutines and variables, and does not otherwise impair the
resulting interpreter from executing any standard Perl script. I
consider linking in C subroutines in this manner to be the moral
equivalent of defining subroutines in the Perl language itself. You
may sell such an object file as proprietary provided that you provide
or offer to provide the Perl source, as specified by the GNU General
Public License. (This is merely an alternate way of specifying input
to the program.) You may also sell a binary produced by the dumping of
a running Perl script that belongs to you, provided that you provide or
offer to provide the Perl source as specified by the GPL. (The
fact that a Perl interpreter and your code are in the same binary file
is, in this case, a form of mere aggregation.) This is my interpretation
of the GPL. If you still have concerns or difficulties understanding
my intent, feel free to contact me. Of course, the Artistic License
spells all this out for your protection, so you may prefer to use that.
=cut
# for portability warn about names longer than $maxlen
$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3
$Verbose = 1; # 0=none, 1=minimal, 2=list .al files
$Keep = 0;
$CheckForAutoloader = 1;
$CheckModTime = 1;
my $IndexFile = "autosplit.ix"; # file also serves as timestamp
my $maxflen = 255;
$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
if (defined (&Dos::UseLFN)) {
$maxflen = Dos::UseLFN() ? 255 : 11;
}
my $Is_VMS = ($^O eq 'VMS');
# allow checking for valid ': attrlist' attachments.
# extra jugglery required to support both 5.8 and 5.9/5.10 features
# (support for 5.8 required for cross-compiling environments)
my $attr_list =
$] >= 5.009005 ?
eval <<'__QR__'
qr{
\s* : \s*
(?:
# one attribute
(?> # no backtrack
(?! \d) \w+
(?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
)
(?: \s* : \s* | \s+ (?! :) )
)*
}x
__QR__
:
do {
# In pre-5.9.5 world we have to do dirty tricks.
# (we use 'our' rather than 'my' here, due to the rather complex and buggy
# behaviour of lexicals with qr// and (??{$lex}) )
our $trick1; # yes, cannot our and assign at the same time.
$trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x;
our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
qr{ \s* : \s* (?: $trick2 )* }x;
};
sub autosplit{
my($file, $autodir, $keep, $ckal, $ckmt) = @_;
# $file - the perl source file to be split (after __END__)
# $autodir - the ".../auto" dir below which to write split subs
# Handle optional flags:
$keep = $Keep unless defined $keep;
$ckal = $CheckForAutoloader unless defined $ckal;
$ckmt = $CheckModTime unless defined $ckmt;
autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
}
sub carp{
require Carp;
goto &Carp::carp;
}
# This function is used during perl building/installation
# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
sub autosplit_lib_modules {
my(@modules) = @_; # list of Module names
local $_; # Avoid clobber.
while (defined($_ = shift @modules)) {
while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
$_ = catfile($1, $2);
}
s|\\|/|g; # bug in ksh OS/2
s#^lib/##s; # incase specified as lib/*.pm
my($lib) = catfile(curdir(), "lib");
if ($Is_VMS) { # may need to convert VMS-style filespecs
$lib =~ s#^\[\]#.\/#;
}
s#^$lib\W+##s; # incase specified as ./lib/*.pm
if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
my ($dir,$name) = (/(.*])(.*)/s);
$dir =~ s/.*lib[\.\]]//s;
$dir =~ s#[\.\]]#/#g;
$_ = $dir . $name;
}
autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
$Keep, $CheckForAutoloader, $CheckModTime);
}
0;
}
# private functions
my $self_mod_time = (stat __FILE__)[9];
sub autosplit_file {
my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
= @_;
my(@outfiles);
local($_);
local($/) = "\n";
# where to write output files
$autodir ||= catfile(curdir(), "lib", "auto");
if ($Is_VMS) {
($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
$filename = VMS::Filespec::unixify($filename); # may have dirs
}
unless (-d $autodir){
mkpath($autodir,0,0755);
# We should never need to create the auto dir
# here. installperl (or similar) should have done
# it. Expecting it to exist is a valuable sanity check against
# autosplitting into some random directory by mistake.
print "Warning: AutoSplit had to create top-level " .
"$autodir unexpectedly.\n";
}
# allow just a package name to be used
$filename .= ".pm" unless ($filename =~ m/\.pm\z/);
open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
my($pm_mod_time) = (stat($filename))[9];
my($autoloader_seen) = 0;
my($in_pod) = 0;
my($def_package,$last_package,$this_package,$fnr);
while (<$in>) {
# Skip pod text.
$fnr++;
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/);
next if /^\s*#/;
# record last package name seen
$def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
last if /^__END__/;
}
if ($check_for_autoloader && !$autoloader_seen){
print "AutoSplit skipped $filename: no AutoLoader used\n"
if ($Verbose>=2);
return 0;
}
$_ or die "Can't find __END__ in $filename\n";
$def_package or die "Can't find 'package Name;' in $filename\n";
my($modpname) = _modpname($def_package);
# this _has_ to match so we have a reasonable timestamp file
die "Package $def_package ($modpname.pm) does not ".
"match filename $filename"
unless ($filename =~ m/\Q$modpname.pm\E$/ or
($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
$Is_VMS && $filename =~ m/$modpname.pm/i);
my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
if ($check_mod_time){
my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
if ($al_ts_time >= $pm_mod_time and
$al_ts_time >= $self_mod_time){
print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
if ($Verbose >= 2);
return undef; # one undef, not a list
}
}
my($modnamedir) = catdir($autodir, $modpname);
print "AutoSplitting $filename ($modnamedir)\n"
if $Verbose;
unless (-d $modnamedir){
mkpath($modnamedir,0,0777);
}
# We must try to deal with some SVR3 systems with a limit of 14
# characters for file names. Sadly we *cannot* simply truncate all
# file names to 14 characters on these systems because we *must*
# create filenames which exactly match the names used by AutoLoader.pm.
# This is a problem because some systems silently truncate the file
# names while others treat long file names as an error.
my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames
my(@subnames, $subname, %proto, %package);
my @cache = ();
my $caching = 1;
$last_package = '';
my $out;
while (<$in>) {
$fnr++;
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/);
# the following (tempting) old coding gives big troubles if a
# cut is forgotten at EOF:
# next if /^=\w/ .. /^=cut/;
if (/^package\s+([\w:]+)\s*;/) {
$this_package = $def_package = $1;
}
if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
print $out "# end of $last_package\::$subname\n1;\n"
if $last_package;
$subname = $1;
my $proto = $2 || '';
if ($subname =~ s/(.*):://){
$this_package = $1;
} else {
$this_package = $def_package;
}
my $fq_subname = "$this_package\::$subname";
$package{$fq_subname} = $this_package;
$proto{$fq_subname} = $proto;
push(@subnames, $fq_subname);
my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
$modpname = _modpname($this_package);
my($modnamedir) = catdir($autodir, $modpname);
mkpath($modnamedir,0,0777);
my($lpath) = catfile($modnamedir, "$lname.al");
my($spath) = catfile($modnamedir, "$sname.al");
my $path;
if (!$Is83 and open($out, ">$lpath")){
$path=$lpath;
print " writing $lpath\n" if ($Verbose>=2);
} else {
open($out, ">$spath") or die "Can't create $spath: $!\n";
$path=$spath;
print " writing $spath (with truncated name)\n"
if ($Verbose>=1);
}
push(@outfiles, $path);
my $lineno = $fnr - @cache;
print $out <<EOT;
# NOTE: Derived from $filename.
# Changes made here will be lost when autosplit is run again.
# See AutoSplit.pm.
package $this_package;
#line $lineno "$filename (autosplit into $path)"
EOT
print $out @cache;
@cache = ();
$caching = 0;
}
if($caching) {
push(@cache, $_) if @cache || /\S/;
} else {
print $out $_;
}
if(/^\}/) {
if($caching) {
print $out @cache;
@cache = ();
}
print $out "\n";
$caching = 1;
}
$last_package = $this_package if defined $this_package;
}
if ($subname) {
print $out @cache,"1;\n# end of $last_package\::$subname\n";
close($out);
}
close($in);
if (!$keep){ # don't keep any obsolete *.al files in the directory
my(%outfiles);
# @outfiles{@outfiles} = @outfiles;
# perl downcases all filenames on VMS (which upcases all filenames) so
# we'd better downcase the sub name list too, or subs with upper case
# letters in them will get their .al files deleted right after they're
# created. (The mixed case sub name won't match the all-lowercase
# filename, and so be cleaned up as a scrap file)
if ($Is_VMS or $Is83) {
%outfiles = map {lc($_) => lc($_) } @outfiles;
} else {
@outfiles{@outfiles} = @outfiles;
}
my(%outdirs,@outdirs);
for (@outfiles) {
$outdirs{File::Basename::dirname($_)}||=1;
}
for my $dir (keys %outdirs) {
opendir(my $outdir,$dir);
foreach (sort readdir($outdir)){
next unless /\.al\z/;
my($file) = catfile($dir, $_);
$file = lc $file if $Is83 or $Is_VMS;
next if $outfiles{$file};
print " deleting $file\n" if ($Verbose>=2);
my($deleted,$thistime); # catch all versions on VMS
do { $deleted += ($thistime = unlink $file) } while ($thistime);
carp ("Unable to delete $file: $!") unless $deleted;
}
closedir($outdir);
}
}
open(my $ts,">$al_idx_file") or
carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
print $ts "# Index created by AutoSplit for $filename\n";
print $ts "# (file acts as timestamp)\n";
$last_package = '';
for my $fqs (@subnames) {
my($subname) = $fqs;
$subname =~ s/.*:://;
print $ts "package $package{$fqs};\n"
unless $last_package eq $package{$fqs};
print $ts "sub $subname $proto{$fqs};\n";
$last_package = $package{$fqs};
}
print $ts "1;\n";
close($ts);
_check_unique($filename, $Maxlen, 1, @outfiles);
@outfiles;
}
sub _modpname ($) {
my($package) = @_;
my $modpname = $package;
if ($^O eq 'MSWin32') {
$modpname =~ s#::#\\#g;
} else {
my @modpnames = ();
while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
push @modpnames, $1;
$modpname = $2;
}
$modpname = catfile(@modpnames, $modpname);
}
if ($Is_VMS) {
$modpname = VMS::Filespec::unixify($modpname); # may have dirs
}
$modpname;
}
sub _check_unique {
my($filename, $maxlen, $warn, @outfiles) = @_;
my(%notuniq) = ();
my(%shorts) = ();
my(@toolong) = grep(
length(File::Basename::basename($_))
> $maxlen,
@outfiles
);
foreach (@toolong){
my($dir) = File::Basename::dirname($_);
my($file) = File::Basename::basename($_);
my($trunc) = substr($file,0,$maxlen);
$notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
$shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
"$shorts{$dir}{$trunc}, $file" : $file;
}
if (%notuniq && $warn){
print "$filename: some names are not unique when " .
"truncated to $maxlen characters:\n";
foreach my $dir (sort keys %notuniq){
print " directory $dir:\n";
foreach my $trunc (sort keys %{$notuniq{$dir}}) {
print " $shorts{$dir}{$trunc} truncate to $trunc\n";
}
}
}
}
1;
__END__
# test functions so AutoSplit.pm can be applied to itself:
sub test1 ($) { "test 1\n"; }
sub test2 ($$) { "test 2\n"; }
sub test3 ($$$) { "test 3\n"; }
sub testtesttesttest4_1 { "test 4\n"; }
sub testtesttesttest4_2 { "duplicate test 4\n"; }
sub Just::Another::test5 { "another test 5\n"; }
sub test6 { return join ":", __FILE__,__LINE__; }
package Yet::Another::AutoSplit;
sub testtesttesttest4_1 ($) { "another test 4\n"; }
sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
package Yet::More::Attributes;
sub test_a1 ($) : locked :locked { 1; }
sub test_a2 : locked { 1; }

7266
gitportable/usr/share/perl5/core_perl/B/Deparse.pm Normal file
View File

File diff suppressed because it is too large Load Diff

934
gitportable/usr/share/perl5/core_perl/B/Op_private.pm Normal file
View File

@@ -0,0 +1,934 @@
# -*- mode: Perl; buffer-read-only: t -*-
#
# lib/B/Op_private.pm
#
# Copyright (C) 2014 by Larry Wall and others
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
#
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
# This file is built by regen/opcode.pl from data in
# regen/op_private and pod embedded in regen/opcode.pl.
# Any changes made here will be lost!
=head1 NAME
B::Op_private - OP op_private flag definitions
=head1 SYNOPSIS
use B::Op_private;
# flag details for bit 7 of OP_AELEM's op_private:
my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO
my $value = $B::Op_private::defines{$name}; # 128
my $label = $B::Op_private::labels{$name}; # LVINTRO
# the bit field at bits 5..6 of OP_AELEM's op_private:
my $bf = $B::Op_private::bits{aelem}{6};
my $mask = $bf->{bitmask}; # etc
=head1 DESCRIPTION
This module provides four global hashes:
%B::Op_private::bits
%B::Op_private::defines
%B::Op_private::labels
%B::Op_private::ops_using
which contain information about the per-op meanings of the bits in the
op_private field.
=head2 C<%bits>
This is indexed by op name and then bit number (0..7). For single bit flags,
it returns the name of the define (if any) for that bit:
$B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO';
For bit fields, it returns a hash ref containing details about the field.
The same reference will be returned for all bit positions that make
up the bit field; so for example these both return the same hash ref:
$bitfield = $B::Op_private::bits{aelem}{5};
$bitfield = $B::Op_private::bits{aelem}{6};
The general format of this hash ref is
{
# The bit range and mask; these are always present.
bitmin => 5,
bitmax => 6,
bitmask => 0x60,
# (The remaining keys are optional)
# The names of any defines that were requested:
mask_def => 'OPpFOO_MASK',
baseshift_def => 'OPpFOO_SHIFT',
bitcount_def => 'OPpFOO_BITS',
# If present, Concise etc will display the value with a 'FOO='
# prefix. If it equals '-', then Concise will treat the bit
# field as raw bits and not try to interpret it.
label => 'FOO',
# If present, specifies the names of some defines and the
# display labels that are used to assign meaning to particu-
# lar integer values within the bit field; e.g. 3 is dis-
# played as 'C'.
enum => [ qw(
1 OPpFOO_A A
2 OPpFOO_B B
3 OPpFOO_C C
)],
};
=head2 C<%defines>
This gives the value of every C<OPp> define, e.g.
$B::Op_private::defines{OPpLVAL_INTRO} == 128;
=head2 C<%labels>
This gives the short display label for each define, as used by C<B::Concise>
and C<perl -Dx>, e.g.
$B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO';
If the label equals '-', then Concise will treat the bit as a raw bit and
not try to display it symbolically.
=head2 C<%ops_using>
For each define, this gives a reference to an array of op names that use
the flag.
@ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} };
=cut
package B::Op_private;
our %bits;
our $VERSION = "5.038002";
$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
$bits{$_}{2} = 'OPpENTERSUB_HASTARG' for qw(entersub rv2cv);
$bits{$_}{6} = 'OPpFLIP_LINENUM' for qw(flip flop);
$bits{$_}{1} = 'OPpFT_ACCESS' for qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite);
$bits{$_}{4} = 'OPpFT_AFTER_t' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
$bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
$bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero);
$bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv);
$bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate);
$bits{$_}{6} = 'OPpINDEX_BOOLNEG' for qw(index rindex);
$bits{$_}{1} = 'OPpITER_REVERSED' for qw(enteriter iter);
$bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop);
$bits{$_}{6} = 'OPpLVAL_DEFER' for qw(aelem helem multideref);
$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete emptyavhv enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multiconcat multideref padav padhv padrange padsv padsv_store pushmark refassign rv2av rv2gv rv2hv rv2sv split undef);
$bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref refassign);
$bits{$_}{3} = 'OPpLVREF_ITER' for qw(lvref refassign);
$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr values vec);
$bits{$_}{4} = 'OPpMAYBE_TRUEBOOL' for qw(blessed padhv ref rv2hv);
$bits{$_}{7} = 'OPpOFFBYONE' for qw(caller runcv wantarray);
$bits{$_}{5} = 'OPpOPEN_IN_CRLF' for qw(backtick open);
$bits{$_}{4} = 'OPpOPEN_IN_RAW' for qw(backtick open);
$bits{$_}{7} = 'OPpOPEN_OUT_CRLF' for qw(backtick open);
$bits{$_}{6} = 'OPpOPEN_OUT_RAW' for qw(backtick open);
$bits{$_}{6} = 'OPpOUR_INTRO' for qw(enteriter gvsv rv2av rv2hv rv2sv split);
$bits{$_}{6} = 'OPpPAD_STATE' for qw(emptyavhv lvavref lvref padav padhv padsv padsv_store pushmark refassign undef);
$bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo);
$bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite);
$bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv);
$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 ceil chdir chmod chomp chown chr chroot concat cos crypt divide emptyavhv exec exp flock floor getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand refaddr reftype rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time undef unlink unshift utime wait waitpid);
$bits{$_}{0} = 'OPpTRANS_CAN_FORCE_UTF8' for qw(trans transr);
$bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr);
$bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr);
$bits{$_}{6} = 'OPpTRANS_GROWS' for qw(trans transr);
$bits{$_}{2} = 'OPpTRANS_IDENTICAL' for qw(trans transr);
$bits{$_}{3} = 'OPpTRANS_SQUASH' for qw(trans transr);
$bits{$_}{1} = 'OPpTRANS_USE_SVOP' for qw(trans transr);
$bits{$_}{5} = 'OPpTRUEBOOL' for qw(blessed grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst);
$bits{$_}{2} = 'OPpUSEINT' for qw(bit_and bit_or bit_xor complement left_shift nbit_and nbit_or nbit_xor ncomplement right_shift sbit_and sbit_or sbit_xor);
my @bf = (
{
label => '-',
mask_def => 'OPpARG1_MASK',
bitmin => 0,
bitmax => 0,
bitmask => 1,
},
{
label => '-',
mask_def => 'OPpARG2_MASK',
bitmin => 0,
bitmax => 1,
bitmask => 3,
},
{
label => 'offset',
mask_def => 'OPpAVHVSWITCH_MASK',
bitmin => 0,
bitmax => 1,
bitmask => 3,
},
{
label => '-',
mask_def => 'OPpARG3_MASK',
bitmin => 0,
bitmax => 2,
bitmask => 7,
},
{
label => '-',
mask_def => 'OPpARG4_MASK',
bitmin => 0,
bitmax => 3,
bitmask => 15,
},
{
label => 'range',
mask_def => 'OPpPADRANGE_COUNTMASK',
bitcount_def => 'OPpPADRANGE_COUNTSHIFT',
bitmin => 0,
bitmax => 6,
bitmask => 127,
},
{
label => 'key',
bitmin => 0,
bitmax => 7,
bitmask => 255,
},
{
mask_def => 'OPpARGELEM_MASK',
bitmin => 1,
bitmax => 2,
bitmask => 6,
enum => [
0, 'OPpARGELEM_SV', 'SV',
1, 'OPpARGELEM_AV', 'AV',
2, 'OPpARGELEM_HV', 'HV',
],
},
{
mask_def => 'OPpDEREF',
bitmin => 4,
bitmax => 5,
bitmask => 48,
enum => [
1, 'OPpDEREF_AV', 'DREFAV',
2, 'OPpDEREF_HV', 'DREFHV',
3, 'OPpDEREF_SV', 'DREFSV',
],
},
{
mask_def => 'OPpLVREF_TYPE',
bitmin => 4,
bitmax => 5,
bitmask => 48,
enum => [
0, 'OPpLVREF_SV', 'SV',
1, 'OPpLVREF_AV', 'AV',
2, 'OPpLVREF_HV', 'HV',
3, 'OPpLVREF_CV', 'CV',
],
},
);
@{$bits{aassign}}{6,5,4,2,1,0} = ('OPpASSIGN_COMMON_SCALAR', 'OPpASSIGN_COMMON_RC1', 'OPpASSIGN_COMMON_AGG', 'OPpASSIGN_TRUEBOOL', $bf[1], $bf[1]);
$bits{abs}{0} = $bf[0];
@{$bits{accept}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{add}}{1,0} = ($bf[1], $bf[1]);
$bits{aeach}{0} = $bf[0];
@{$bits{aelem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
@{$bits{aelemfastlex_store}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
$bits{akeys}{0} = $bf[0];
$bits{alarm}{0} = $bf[0];
$bits{and}{0} = $bf[0];
$bits{andassign}{0} = $bf[0];
$bits{anonconst}{0} = $bf[0];
@{$bits{anonhash}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{anonlist}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{argcheck}{0} = $bf[0];
@{$bits{argdefelem}}{7,6,0} = ('OPpARG_IF_UNDEF', 'OPpARG_IF_FALSE', $bf[0]);
@{$bits{argelem}}{2,1,0} = ($bf[7], $bf[7], $bf[0]);
@{$bits{atan2}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{av2arylen}{0} = $bf[0];
$bits{avalues}{0} = $bf[0];
@{$bits{avhvswitch}}{1,0} = ($bf[2], $bf[2]);
$bits{backtick}{0} = $bf[0];
@{$bits{bind}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{binmode}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{bless}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{blessed}{0} = $bf[0];
@{$bits{caller}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{catch}{0} = $bf[0];
$bits{ceil}{0} = $bf[0];
@{$bits{chdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{chmod}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{chomp}{0} = $bf[0];
$bits{chop}{0} = $bf[0];
@{$bits{chown}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{chr}{0} = $bf[0];
$bits{chroot}{0} = $bf[0];
@{$bits{close}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{closedir}{0} = $bf[0];
$bits{cmpchain_and}{0} = $bf[0];
$bits{cmpchain_dup}{0} = $bf[0];
@{$bits{concat}}{6,1,0} = ('OPpCONCAT_NESTED', $bf[1], $bf[1]);
$bits{cond_expr}{0} = $bf[0];
@{$bits{connect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{const}}{6,4,3,2,1} = ('OPpCONST_BARE', 'OPpCONST_ENTERED', 'OPpCONST_STRICT', 'OPpCONST_SHORTCIRCUIT', 'OPpCONST_NOVER');
@{$bits{coreargs}}{7,6,1,0} = ('OPpCOREARGS_PUSHMARK', 'OPpCOREARGS_SCALARMOD', 'OPpCOREARGS_DEREF2', 'OPpCOREARGS_DEREF1');
$bits{cos}{0} = $bf[0];
@{$bits{crypt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{dbmclose}{0} = $bf[0];
@{$bits{dbmopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{defined}{0} = $bf[0];
@{$bits{delete}}{6,5,0} = ('OPpSLICE', 'OPpKVSLICE', $bf[0]);
@{$bits{die}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{divide}}{1,0} = ($bf[1], $bf[1]);
$bits{dofile}{0} = $bf[0];
$bits{dor}{0} = $bf[0];
$bits{dorassign}{0} = $bf[0];
$bits{dump}{0} = $bf[0];
$bits{each}{0} = $bf[0];
@{$bits{emptyavhv}}{5,3,2,1,0} = ('OPpEMPTYAVHV_IS_HV', $bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{entereval}}{6,5,4,3,2,1,0} = ('OPpEVAL_EVALSV', 'OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]);
$bits{entergiven}{0} = $bf[0];
$bits{enteriter}{3} = 'OPpITER_DEF';
@{$bits{entersub}}{5,4,0} = ($bf[8], $bf[8], 'OPpENTERSUB_INARGS');
$bits{entertry}{0} = $bf[0];
$bits{entertrycatch}{0} = $bf[0];
$bits{enterwhen}{0} = $bf[0];
@{$bits{enterwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{eof}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{eq}}{1,0} = ($bf[1], $bf[1]);
@{$bits{exec}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{exists}}{6,0} = ('OPpEXISTS_SUB', $bf[0]);
@{$bits{exit}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{exp}{0} = $bf[0];
$bits{fc}{0} = $bf[0];
@{$bits{fcntl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{fileno}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{flip}{0} = $bf[0];
@{$bits{flock}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{floor}{0} = $bf[0];
$bits{flop}{0} = $bf[0];
@{$bits{formline}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{ftatime}{0} = $bf[0];
$bits{ftbinary}{0} = $bf[0];
$bits{ftblk}{0} = $bf[0];
$bits{ftchr}{0} = $bf[0];
$bits{ftctime}{0} = $bf[0];
$bits{ftdir}{0} = $bf[0];
$bits{fteexec}{0} = $bf[0];
$bits{fteowned}{0} = $bf[0];
$bits{fteread}{0} = $bf[0];
$bits{ftewrite}{0} = $bf[0];
$bits{ftfile}{0} = $bf[0];
$bits{ftis}{0} = $bf[0];
$bits{ftlink}{0} = $bf[0];
$bits{ftmtime}{0} = $bf[0];
$bits{ftpipe}{0} = $bf[0];
$bits{ftrexec}{0} = $bf[0];
$bits{ftrowned}{0} = $bf[0];
$bits{ftrread}{0} = $bf[0];
$bits{ftrwrite}{0} = $bf[0];
$bits{ftsgid}{0} = $bf[0];
$bits{ftsize}{0} = $bf[0];
$bits{ftsock}{0} = $bf[0];
$bits{ftsuid}{0} = $bf[0];
$bits{ftsvtx}{0} = $bf[0];
$bits{fttext}{0} = $bf[0];
$bits{fttty}{0} = $bf[0];
$bits{ftzero}{0} = $bf[0];
@{$bits{ge}}{1,0} = ($bf[1], $bf[1]);
@{$bits{gelem}}{1,0} = ($bf[1], $bf[1]);
@{$bits{getc}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{getpeername}{0} = $bf[0];
@{$bits{getpgrp}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{getpriority}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{getsockname}{0} = $bf[0];
$bits{ggrgid}{0} = $bf[0];
$bits{ggrnam}{0} = $bf[0];
@{$bits{ghbyaddr}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{ghbyname}{0} = $bf[0];
@{$bits{glob}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{gmtime}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{gnbyaddr}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{gnbyname}{0} = $bf[0];
$bits{goto}{0} = $bf[0];
$bits{gpbyname}{0} = $bf[0];
@{$bits{gpbynumber}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{gpwnam}{0} = $bf[0];
$bits{gpwuid}{0} = $bf[0];
$bits{grepstart}{0} = $bf[0];
$bits{grepwhile}{0} = $bf[0];
@{$bits{gsbyname}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{gsbyport}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{gsockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{gt}}{1,0} = ($bf[1], $bf[1]);
$bits{gv}{5} = 'OPpEARLY_CV';
@{$bits{helem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
@{$bits{helemexistsor}}{7,0} = ('OPpHELEMEXISTSOR_DELETE', $bf[0]);
$bits{hex}{0} = $bf[0];
@{$bits{i_add}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_eq}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_ge}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_gt}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_le}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_lt}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_modulo}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_multiply}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_ncmp}}{1,0} = ($bf[1], $bf[1]);
@{$bits{i_ne}}{1,0} = ($bf[1], $bf[1]);
$bits{i_negate}{0} = $bf[0];
$bits{i_postdec}{0} = $bf[0];
$bits{i_postinc}{0} = $bf[0];
$bits{i_predec}{0} = $bf[0];
$bits{i_preinc}{0} = $bf[0];
@{$bits{i_subtract}}{1,0} = ($bf[1], $bf[1]);
@{$bits{index}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{initfield}}{2,1,0} = ('OPpINITFIELD_HV', 'OPpINITFIELD_AV', $bf[0]);
$bits{int}{0} = $bf[0];
@{$bits{ioctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{is_bool}{0} = $bf[0];
$bits{is_tainted}{0} = $bf[0];
$bits{is_weak}{0} = $bf[0];
@{$bits{isa}}{1,0} = ($bf[1], $bf[1]);
@{$bits{join}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{keys}{0} = $bf[0];
@{$bits{kill}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{last}{0} = $bf[0];
$bits{lc}{0} = $bf[0];
$bits{lcfirst}{0} = $bf[0];
@{$bits{le}}{1,0} = ($bf[1], $bf[1]);
$bits{leaveeval}{0} = $bf[0];
$bits{leavegiven}{0} = $bf[0];
@{$bits{leaveloop}}{1,0} = ($bf[1], $bf[1]);
$bits{leavesub}{0} = $bf[0];
$bits{leavesublv}{0} = $bf[0];
$bits{leavewhen}{0} = $bf[0];
$bits{leavewrite}{0} = $bf[0];
$bits{length}{0} = $bf[0];
@{$bits{link}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{list}{6} = 'OPpLIST_GUESSED';
@{$bits{listen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{localtime}{0} = $bf[0];
$bits{lock}{0} = $bf[0];
$bits{log}{0} = $bf[0];
@{$bits{lslice}}{1,0} = ($bf[1], $bf[1]);
$bits{lstat}{0} = $bf[0];
@{$bits{lt}}{1,0} = ($bf[1], $bf[1]);
$bits{lvavref}{0} = $bf[0];
@{$bits{lvref}}{5,4,0} = ($bf[9], $bf[9], $bf[0]);
$bits{mapstart}{0} = $bf[0];
$bits{mapwhile}{0} = $bf[0];
$bits{method}{0} = $bf[0];
$bits{method_named}{0} = $bf[0];
$bits{method_redir}{0} = $bf[0];
$bits{method_redir_super}{0} = $bf[0];
$bits{method_super}{0} = $bf[0];
@{$bits{methstart}}{7,0} = ('OPpINITFIELDS', $bf[0]);
@{$bits{mkdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{modulo}}{1,0} = ($bf[1], $bf[1]);
@{$bits{msgctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{msgget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{msgrcv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{msgsnd}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{multiconcat}}{6,5,3,0} = ('OPpMULTICONCAT_APPEND', 'OPpMULTICONCAT_FAKE', 'OPpMULTICONCAT_STRINGIFY', $bf[0]);
@{$bits{multideref}}{5,4,0} = ('OPpMULTIDEREF_DELETE', 'OPpMULTIDEREF_EXISTS', $bf[0]);
@{$bits{multiply}}{1,0} = ($bf[1], $bf[1]);
@{$bits{ncmp}}{1,0} = ($bf[1], $bf[1]);
@{$bits{ne}}{1,0} = ($bf[1], $bf[1]);
$bits{negate}{0} = $bf[0];
$bits{next}{0} = $bf[0];
$bits{not}{0} = $bf[0];
$bits{oct}{0} = $bf[0];
$bits{once}{0} = $bf[0];
@{$bits{open}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{open_dir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{or}{0} = $bf[0];
$bits{orassign}{0} = $bf[0];
$bits{ord}{0} = $bf[0];
@{$bits{pack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{padhv}{0} = 'OPpPADHV_ISKEYS';
@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
@{$bits{padsv}}{5,4} = ($bf[8], $bf[8]);
$bits{padsv_store}{0} = $bf[0];
@{$bits{pipe_op}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{pop}{0} = $bf[0];
$bits{pos}{0} = $bf[0];
$bits{postdec}{0} = $bf[0];
$bits{postinc}{0} = $bf[0];
@{$bits{pow}}{1,0} = ($bf[1], $bf[1]);
$bits{predec}{0} = $bf[0];
$bits{preinc}{0} = $bf[0];
$bits{prototype}{0} = $bf[0];
@{$bits{push}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{pushdefer}}{7,0} = ('OPpDEFER_FINALLY', $bf[0]);
$bits{quotemeta}{0} = $bf[0];
@{$bits{rand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{range}{0} = $bf[0];
@{$bits{read}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{readdir}{0} = $bf[0];
$bits{readline}{0} = $bf[0];
$bits{readlink}{0} = $bf[0];
@{$bits{recv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{redo}{0} = $bf[0];
$bits{ref}{0} = $bf[0];
$bits{refaddr}{0} = $bf[0];
@{$bits{refassign}}{5,4,1,0} = ($bf[9], $bf[9], $bf[1], $bf[1]);
$bits{refgen}{0} = $bf[0];
$bits{reftype}{0} = $bf[0];
$bits{regcmaybe}{0} = $bf[0];
$bits{regcomp}{0} = $bf[0];
$bits{regcreset}{0} = $bf[0];
@{$bits{rename}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{repeat}}{6,1,0} = ('OPpREPEAT_DOLIST', $bf[1], $bf[1]);
$bits{require}{0} = $bf[0];
@{$bits{reset}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{reverse}}{3,0} = ('OPpREVERSE_INPLACE', $bf[0]);
$bits{rewinddir}{0} = $bf[0];
@{$bits{rindex}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{rmdir}{0} = $bf[0];
$bits{rv2av}{0} = $bf[0];
@{$bits{rv2cv}}{7,5,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]);
@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[8], $bf[8], 'OPpDONT_INIT_GV', $bf[0]);
$bits{rv2hv}{0} = 'OPpRV2HV_ISKEYS';
@{$bits{rv2sv}}{5,4,0} = ($bf[8], $bf[8], $bf[0]);
@{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]);
$bits{scalar}{0} = $bf[0];
$bits{schomp}{0} = $bf[0];
$bits{schop}{0} = $bf[0];
@{$bits{scmp}}{1,0} = ($bf[1], $bf[1]);
$bits{scomplement}{0} = $bf[0];
@{$bits{seek}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{seekdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{select}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{semctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{semget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{semop}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{send}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{seq}}{1,0} = ($bf[1], $bf[1]);
@{$bits{setpgrp}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{setpriority}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sge}}{1,0} = ($bf[1], $bf[1]);
@{$bits{sgt}}{1,0} = ($bf[1], $bf[1]);
$bits{shift}{0} = $bf[0];
@{$bits{shmctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{shmget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{shmread}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{shmwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{shostent}{0} = $bf[0];
@{$bits{shutdown}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{sin}{0} = $bf[0];
@{$bits{sle}}{1,0} = ($bf[1], $bf[1]);
@{$bits{sleep}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{slt}}{1,0} = ($bf[1], $bf[1]);
@{$bits{smartmatch}}{1,0} = ($bf[1], $bf[1]);
@{$bits{sne}}{1,0} = ($bf[1], $bf[1]);
$bits{snetent}{0} = $bf[0];
@{$bits{socket}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sockpair}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sort}}{4,3,2,1,0} = ('OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC');
@{$bits{splice}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{split}}{4,3,2} = ('OPpSPLIT_ASSIGN', 'OPpSPLIT_LEX', 'OPpSPLIT_IMPLIM');
@{$bits{sprintf}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{sprotoent}{0} = $bf[0];
$bits{sqrt}{0} = $bf[0];
@{$bits{srand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{srefgen}{0} = $bf[0];
@{$bits{sselect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{sservent}{0} = $bf[0];
@{$bits{ssockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{stat}{0} = $bf[0];
@{$bits{stringify}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{study}{0} = $bf[0];
$bits{substcont}{0} = $bf[0];
@{$bits{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[3], $bf[3], $bf[3]);
@{$bits{subtract}}{1,0} = ($bf[1], $bf[1]);
@{$bits{symlink}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{syscall}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sysopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sysread}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{sysseek}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{system}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{syswrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{tell}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{telldir}{0} = $bf[0];
@{$bits{tie}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{tied}{0} = $bf[0];
@{$bits{truncate}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{uc}{0} = $bf[0];
$bits{ucfirst}{0} = $bf[0];
@{$bits{umask}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{undef}}{5,0} = ('OPpUNDEF_KEEP_PV', $bf[0]);
@{$bits{unlink}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{unpack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{unshift}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{untie}{0} = $bf[0];
$bits{unweaken}{0} = $bf[0];
@{$bits{utime}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{values}{0} = $bf[0];
@{$bits{vec}}{1,0} = ($bf[1], $bf[1]);
@{$bits{waitpid}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@{$bits{warn}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
$bits{weaken}{0} = $bf[0];
@{$bits{xor}}{1,0} = ($bf[1], $bf[1]);
our %defines = (
OPpALLOW_FAKE => 64,
OPpARG1_MASK => 1,
OPpARG2_MASK => 3,
OPpARG3_MASK => 7,
OPpARG4_MASK => 15,
OPpARGELEM_AV => 2,
OPpARGELEM_HV => 4,
OPpARGELEM_MASK => 6,
OPpARGELEM_SV => 0,
OPpARG_IF_FALSE => 64,
OPpARG_IF_UNDEF => 128,
OPpASSIGN_BACKWARDS => 64,
OPpASSIGN_COMMON_AGG => 16,
OPpASSIGN_COMMON_RC1 => 32,
OPpASSIGN_COMMON_SCALAR => 64,
OPpASSIGN_CV_TO_GV => 128,
OPpASSIGN_TRUEBOOL => 4,
OPpAVHVSWITCH_MASK => 3,
OPpCONCAT_NESTED => 64,
OPpCONST_BARE => 64,
OPpCONST_ENTERED => 16,
OPpCONST_NOVER => 2,
OPpCONST_SHORTCIRCUIT => 4,
OPpCONST_STRICT => 8,
OPpCOREARGS_DEREF1 => 1,
OPpCOREARGS_DEREF2 => 2,
OPpCOREARGS_PUSHMARK => 128,
OPpCOREARGS_SCALARMOD => 64,
OPpDEFER_FINALLY => 128,
OPpDEREF => 48,
OPpDEREF_AV => 16,
OPpDEREF_HV => 32,
OPpDEREF_SV => 48,
OPpDONT_INIT_GV => 4,
OPpEARLY_CV => 32,
OPpEMPTYAVHV_IS_HV => 32,
OPpENTERSUB_AMPER => 8,
OPpENTERSUB_DB => 64,
OPpENTERSUB_HASTARG => 4,
OPpENTERSUB_INARGS => 1,
OPpENTERSUB_NOPAREN => 128,
OPpEVAL_BYTES => 8,
OPpEVAL_COPHH => 16,
OPpEVAL_EVALSV => 64,
OPpEVAL_HAS_HH => 2,
OPpEVAL_RE_REPARSING => 32,
OPpEVAL_UNICODE => 4,
OPpEXISTS_SUB => 64,
OPpFLIP_LINENUM => 64,
OPpFT_ACCESS => 2,
OPpFT_AFTER_t => 16,
OPpFT_STACKED => 4,
OPpFT_STACKING => 8,
OPpHELEMEXISTSOR_DELETE => 128,
OPpHINT_STRICT_REFS => 2,
OPpHUSH_VMSISH => 32,
OPpINDEX_BOOLNEG => 64,
OPpINITFIELDS => 128,
OPpINITFIELD_AV => 2,
OPpINITFIELD_HV => 4,
OPpITER_DEF => 8,
OPpITER_REVERSED => 2,
OPpKVSLICE => 32,
OPpLIST_GUESSED => 64,
OPpLVALUE => 128,
OPpLVAL_DEFER => 64,
OPpLVAL_INTRO => 128,
OPpLVREF_AV => 16,
OPpLVREF_CV => 48,
OPpLVREF_ELEM => 4,
OPpLVREF_HV => 32,
OPpLVREF_ITER => 8,
OPpLVREF_SV => 0,
OPpLVREF_TYPE => 48,
OPpMAYBE_LVSUB => 8,
OPpMAYBE_TRUEBOOL => 16,
OPpMAY_RETURN_CONSTANT => 32,
OPpMULTICONCAT_APPEND => 64,
OPpMULTICONCAT_FAKE => 32,
OPpMULTICONCAT_STRINGIFY => 8,
OPpMULTIDEREF_DELETE => 32,
OPpMULTIDEREF_EXISTS => 16,
OPpOFFBYONE => 128,
OPpOPEN_IN_CRLF => 32,
OPpOPEN_IN_RAW => 16,
OPpOPEN_OUT_CRLF => 128,
OPpOPEN_OUT_RAW => 64,
OPpOUR_INTRO => 64,
OPpPADHV_ISKEYS => 1,
OPpPADRANGE_COUNTMASK => 127,
OPpPADRANGE_COUNTSHIFT => 7,
OPpPAD_STATE => 64,
OPpPV_IS_UTF8 => 128,
OPpREFCOUNTED => 64,
OPpREPEAT_DOLIST => 64,
OPpREVERSE_INPLACE => 8,
OPpRV2HV_ISKEYS => 1,
OPpSLICE => 64,
OPpSLICEWARNING => 4,
OPpSORT_DESCEND => 16,
OPpSORT_INPLACE => 8,
OPpSORT_INTEGER => 2,
OPpSORT_NUMERIC => 1,
OPpSORT_REVERSE => 4,
OPpSPLIT_ASSIGN => 16,
OPpSPLIT_IMPLIM => 4,
OPpSPLIT_LEX => 8,
OPpSUBSTR_REPL_FIRST => 16,
OPpTARGET_MY => 16,
OPpTRANS_CAN_FORCE_UTF8 => 1,
OPpTRANS_COMPLEMENT => 32,
OPpTRANS_DELETE => 128,
OPpTRANS_GROWS => 64,
OPpTRANS_IDENTICAL => 4,
OPpTRANS_SQUASH => 8,
OPpTRANS_USE_SVOP => 2,
OPpTRUEBOOL => 32,
OPpUNDEF_KEEP_PV => 32,
OPpUSEINT => 4,
);
our %labels = (
OPpALLOW_FAKE => 'FAKE',
OPpARGELEM_AV => 'AV',
OPpARGELEM_HV => 'HV',
OPpARGELEM_SV => 'SV',
OPpARG_IF_FALSE => 'IF_FALSE',
OPpARG_IF_UNDEF => 'IF_UNDEF',
OPpASSIGN_BACKWARDS => 'BKWARD',
OPpASSIGN_COMMON_AGG => 'COM_AGG',
OPpASSIGN_COMMON_RC1 => 'COM_RC1',
OPpASSIGN_COMMON_SCALAR => 'COM_SCALAR',
OPpASSIGN_CV_TO_GV => 'CV2GV',
OPpASSIGN_TRUEBOOL => 'BOOL',
OPpCONCAT_NESTED => 'NESTED',
OPpCONST_BARE => 'BARE',
OPpCONST_ENTERED => 'ENTERED',
OPpCONST_NOVER => 'NOVER',
OPpCONST_SHORTCIRCUIT => 'SHORT',
OPpCONST_STRICT => 'STRICT',
OPpCOREARGS_DEREF1 => 'DEREF1',
OPpCOREARGS_DEREF2 => 'DEREF2',
OPpCOREARGS_PUSHMARK => 'MARK',
OPpCOREARGS_SCALARMOD => '$MOD',
OPpDEFER_FINALLY => 'FINALLY',
OPpDEREF_AV => 'DREFAV',
OPpDEREF_HV => 'DREFHV',
OPpDEREF_SV => 'DREFSV',
OPpDONT_INIT_GV => 'NOINIT',
OPpEARLY_CV => 'EARLYCV',
OPpEMPTYAVHV_IS_HV => 'ANONHASH',
OPpENTERSUB_AMPER => 'AMPER',
OPpENTERSUB_DB => 'DBG',
OPpENTERSUB_HASTARG => 'TARG',
OPpENTERSUB_INARGS => 'INARGS',
OPpENTERSUB_NOPAREN => 'NO()',
OPpEVAL_BYTES => 'BYTES',
OPpEVAL_COPHH => 'COPHH',
OPpEVAL_EVALSV => 'EVALSV',
OPpEVAL_HAS_HH => 'HAS_HH',
OPpEVAL_RE_REPARSING => 'REPARSE',
OPpEVAL_UNICODE => 'UNI',
OPpEXISTS_SUB => 'SUB',
OPpFLIP_LINENUM => 'LINENUM',
OPpFT_ACCESS => 'FTACCESS',
OPpFT_AFTER_t => 'FTAFTERt',
OPpFT_STACKED => 'FTSTACKED',
OPpFT_STACKING => 'FTSTACKING',
OPpHELEMEXISTSOR_DELETE => 'DELETE',
OPpHINT_STRICT_REFS => 'STRICT',
OPpHUSH_VMSISH => 'HUSH',
OPpINDEX_BOOLNEG => 'NEG',
OPpINITFIELDS => 'INITFIELDS',
OPpINITFIELD_AV => 'INITFIELD_AV',
OPpINITFIELD_HV => 'INITFIELD_HV',
OPpITER_DEF => 'DEF',
OPpITER_REVERSED => 'REVERSED',
OPpKVSLICE => 'KVSLICE',
OPpLIST_GUESSED => 'GUESSED',
OPpLVALUE => 'LV',
OPpLVAL_DEFER => 'LVDEFER',
OPpLVAL_INTRO => 'LVINTRO',
OPpLVREF_AV => 'AV',
OPpLVREF_CV => 'CV',
OPpLVREF_ELEM => 'ELEM',
OPpLVREF_HV => 'HV',
OPpLVREF_ITER => 'ITER',
OPpLVREF_SV => 'SV',
OPpMAYBE_LVSUB => 'LVSUB',
OPpMAYBE_TRUEBOOL => 'BOOL?',
OPpMAY_RETURN_CONSTANT => 'CONST',
OPpMULTICONCAT_APPEND => 'APPEND',
OPpMULTICONCAT_FAKE => 'FAKE',
OPpMULTICONCAT_STRINGIFY => 'STRINGIFY',
OPpMULTIDEREF_DELETE => 'DELETE',
OPpMULTIDEREF_EXISTS => 'EXISTS',
OPpOFFBYONE => '+1',
OPpOPEN_IN_CRLF => 'INCR',
OPpOPEN_IN_RAW => 'INBIN',
OPpOPEN_OUT_CRLF => 'OUTCR',
OPpOPEN_OUT_RAW => 'OUTBIN',
OPpOUR_INTRO => 'OURINTR',
OPpPADHV_ISKEYS => 'KEYS',
OPpPAD_STATE => 'STATE',
OPpPV_IS_UTF8 => 'UTF',
OPpREFCOUNTED => 'REFC',
OPpREPEAT_DOLIST => 'DOLIST',
OPpREVERSE_INPLACE => 'INPLACE',
OPpRV2HV_ISKEYS => 'KEYS',
OPpSLICE => 'SLICE',
OPpSLICEWARNING => 'SLICEWARN',
OPpSORT_DESCEND => 'DESC',
OPpSORT_INPLACE => 'INPLACE',
OPpSORT_INTEGER => 'INT',
OPpSORT_NUMERIC => 'NUM',
OPpSORT_REVERSE => 'REV',
OPpSPLIT_ASSIGN => 'ASSIGN',
OPpSPLIT_IMPLIM => 'IMPLIM',
OPpSPLIT_LEX => 'LEX',
OPpSUBSTR_REPL_FIRST => 'REPL1ST',
OPpTARGET_MY => 'TARGMY',
OPpTRANS_CAN_FORCE_UTF8 => 'CAN_FORCE_UTF8',
OPpTRANS_COMPLEMENT => 'COMPL',
OPpTRANS_DELETE => 'DEL',
OPpTRANS_GROWS => 'GROWS',
OPpTRANS_IDENTICAL => 'IDENT',
OPpTRANS_SQUASH => 'SQUASH',
OPpTRANS_USE_SVOP => 'USE_SVOP',
OPpTRUEBOOL => 'BOOL',
OPpUNDEF_KEEP_PV => 'KEEP_PV',
OPpUSEINT => 'USEINT',
);
our %ops_using = (
OPpALLOW_FAKE => [qw(rv2gv)],
OPpARG_IF_FALSE => [qw(argdefelem)],
OPpASSIGN_BACKWARDS => [qw(sassign)],
OPpASSIGN_COMMON_AGG => [qw(aassign)],
OPpCONCAT_NESTED => [qw(concat)],
OPpCONST_BARE => [qw(const)],
OPpCOREARGS_DEREF1 => [qw(coreargs)],
OPpDEFER_FINALLY => [qw(pushdefer)],
OPpEARLY_CV => [qw(gv)],
OPpEMPTYAVHV_IS_HV => [qw(emptyavhv)],
OPpENTERSUB_AMPER => [qw(entersub rv2cv)],
OPpENTERSUB_INARGS => [qw(entersub)],
OPpENTERSUB_NOPAREN => [qw(rv2cv)],
OPpEVAL_BYTES => [qw(entereval)],
OPpEXISTS_SUB => [qw(exists)],
OPpFLIP_LINENUM => [qw(flip flop)],
OPpFT_ACCESS => [qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite)],
OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero)],
OPpHELEMEXISTSOR_DELETE => [qw(helemexistsor)],
OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)],
OPpHUSH_VMSISH => [qw(dbstate nextstate)],
OPpINDEX_BOOLNEG => [qw(index rindex)],
OPpINITFIELDS => [qw(methstart)],
OPpINITFIELD_AV => [qw(initfield)],
OPpITER_DEF => [qw(enteriter)],
OPpITER_REVERSED => [qw(enteriter iter)],
OPpKVSLICE => [qw(delete)],
OPpLIST_GUESSED => [qw(list)],
OPpLVALUE => [qw(leave leaveloop)],
OPpLVAL_DEFER => [qw(aelem helem multideref)],
OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete emptyavhv enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multiconcat multideref padav padhv padrange padsv padsv_store pushmark refassign rv2av rv2gv rv2hv rv2sv split undef)],
OPpLVREF_ELEM => [qw(lvref refassign)],
OPpMAYBE_LVSUB => [qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr values vec)],
OPpMAYBE_TRUEBOOL => [qw(blessed padhv ref rv2hv)],
OPpMULTICONCAT_APPEND => [qw(multiconcat)],
OPpMULTIDEREF_DELETE => [qw(multideref)],
OPpOFFBYONE => [qw(caller runcv wantarray)],
OPpOPEN_IN_CRLF => [qw(backtick open)],
OPpOUR_INTRO => [qw(enteriter gvsv rv2av rv2hv rv2sv split)],
OPpPADHV_ISKEYS => [qw(padhv)],
OPpPAD_STATE => [qw(emptyavhv lvavref lvref padav padhv padsv padsv_store pushmark refassign undef)],
OPpPV_IS_UTF8 => [qw(dump goto last next redo)],
OPpREFCOUNTED => [qw(leave leaveeval leavesub leavesublv leavewrite)],
OPpREPEAT_DOLIST => [qw(repeat)],
OPpREVERSE_INPLACE => [qw(reverse)],
OPpRV2HV_ISKEYS => [qw(rv2hv)],
OPpSLICEWARNING => [qw(aslice hslice padav padhv rv2av rv2hv)],
OPpSORT_DESCEND => [qw(sort)],
OPpSPLIT_ASSIGN => [qw(split)],
OPpSUBSTR_REPL_FIRST => [qw(substr)],
OPpTARGET_MY => [qw(abs add atan2 ceil chdir chmod chomp chown chr chroot concat cos crypt divide emptyavhv exec exp flock floor getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand refaddr reftype rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time undef unlink unshift utime wait waitpid)],
OPpTRANS_CAN_FORCE_UTF8 => [qw(trans transr)],
OPpTRUEBOOL => [qw(blessed grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst)],
OPpUNDEF_KEEP_PV => [qw(undef)],
OPpUSEINT => [qw(bit_and bit_or bit_xor complement left_shift nbit_and nbit_or nbit_xor ncomplement right_shift sbit_and sbit_or sbit_xor)],
);
$ops_using{OPpARG_IF_UNDEF} = $ops_using{OPpARG_IF_FALSE};
$ops_using{OPpASSIGN_COMMON_RC1} = $ops_using{OPpASSIGN_COMMON_AGG};
$ops_using{OPpASSIGN_COMMON_SCALAR} = $ops_using{OPpASSIGN_COMMON_AGG};
$ops_using{OPpASSIGN_CV_TO_GV} = $ops_using{OPpASSIGN_BACKWARDS};
$ops_using{OPpASSIGN_TRUEBOOL} = $ops_using{OPpASSIGN_COMMON_AGG};
$ops_using{OPpCONST_ENTERED} = $ops_using{OPpCONST_BARE};
$ops_using{OPpCONST_NOVER} = $ops_using{OPpCONST_BARE};
$ops_using{OPpCONST_SHORTCIRCUIT} = $ops_using{OPpCONST_BARE};
$ops_using{OPpCONST_STRICT} = $ops_using{OPpCONST_BARE};
$ops_using{OPpCOREARGS_DEREF2} = $ops_using{OPpCOREARGS_DEREF1};
$ops_using{OPpCOREARGS_PUSHMARK} = $ops_using{OPpCOREARGS_DEREF1};
$ops_using{OPpCOREARGS_SCALARMOD} = $ops_using{OPpCOREARGS_DEREF1};
$ops_using{OPpDONT_INIT_GV} = $ops_using{OPpALLOW_FAKE};
$ops_using{OPpENTERSUB_DB} = $ops_using{OPpENTERSUB_AMPER};
$ops_using{OPpENTERSUB_HASTARG} = $ops_using{OPpENTERSUB_AMPER};
$ops_using{OPpEVAL_COPHH} = $ops_using{OPpEVAL_BYTES};
$ops_using{OPpEVAL_EVALSV} = $ops_using{OPpEVAL_BYTES};
$ops_using{OPpEVAL_HAS_HH} = $ops_using{OPpEVAL_BYTES};
$ops_using{OPpEVAL_RE_REPARSING} = $ops_using{OPpEVAL_BYTES};
$ops_using{OPpEVAL_UNICODE} = $ops_using{OPpEVAL_BYTES};
$ops_using{OPpFT_STACKED} = $ops_using{OPpFT_AFTER_t};
$ops_using{OPpFT_STACKING} = $ops_using{OPpFT_AFTER_t};
$ops_using{OPpINITFIELD_HV} = $ops_using{OPpINITFIELD_AV};
$ops_using{OPpLVREF_ITER} = $ops_using{OPpLVREF_ELEM};
$ops_using{OPpMAY_RETURN_CONSTANT} = $ops_using{OPpENTERSUB_NOPAREN};
$ops_using{OPpMULTICONCAT_FAKE} = $ops_using{OPpMULTICONCAT_APPEND};
$ops_using{OPpMULTICONCAT_STRINGIFY} = $ops_using{OPpMULTICONCAT_APPEND};
$ops_using{OPpMULTIDEREF_EXISTS} = $ops_using{OPpMULTIDEREF_DELETE};
$ops_using{OPpOPEN_IN_RAW} = $ops_using{OPpOPEN_IN_CRLF};
$ops_using{OPpOPEN_OUT_CRLF} = $ops_using{OPpOPEN_IN_CRLF};
$ops_using{OPpOPEN_OUT_RAW} = $ops_using{OPpOPEN_IN_CRLF};
$ops_using{OPpSLICE} = $ops_using{OPpKVSLICE};
$ops_using{OPpSORT_INPLACE} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSORT_INTEGER} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSORT_NUMERIC} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSORT_REVERSE} = $ops_using{OPpSORT_DESCEND};
$ops_using{OPpSPLIT_IMPLIM} = $ops_using{OPpSPLIT_ASSIGN};
$ops_using{OPpSPLIT_LEX} = $ops_using{OPpSPLIT_ASSIGN};
$ops_using{OPpTRANS_COMPLEMENT} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
$ops_using{OPpTRANS_DELETE} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
$ops_using{OPpTRANS_GROWS} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
$ops_using{OPpTRANS_IDENTICAL} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
$ops_using{OPpTRANS_SQUASH} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
$ops_using{OPpTRANS_USE_SVOP} = $ops_using{OPpTRANS_CAN_FORCE_UTF8};
# ex: set ro ft=perl:

1123
gitportable/usr/share/perl5/core_perl/Benchmark.pm Normal file
View File

File diff suppressed because it is too large Load Diff

4118
gitportable/usr/share/perl5/core_perl/CPAN.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1072
gitportable/usr/share/perl5/core_perl/Carp.pm Normal file
View File

File diff suppressed because it is too large Load Diff

21
gitportable/usr/share/perl5/core_perl/Carp/Heavy.pm Normal file
View File

@@ -0,0 +1,21 @@
package Carp::Heavy;
use Carp ();
our $VERSION = '1.54';
$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.

637
gitportable/usr/share/perl5/core_perl/Class/Struct.pm Normal file
View File

@@ -0,0 +1,637 @@
package Class::Struct;
## See POD after __END__
use 5.006_001;
use strict;
use warnings::register;
our(@ISA, @EXPORT, $VERSION);
use Carp;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(struct);
$VERSION = '0.68';
my $print = 0;
sub printem {
if (@_) { $print = shift }
else { $print++ }
}
{
package Class::Struct::Tie_ISA;
sub TIEARRAY {
my $class = shift;
return bless [], $class;
}
sub STORE {
my ($self, $index, $value) = @_;
Class::Struct::_subclass_error();
}
sub FETCH {
my ($self, $index) = @_;
$self->[$index];
}
sub FETCHSIZE {
my $self = shift;
return scalar(@$self);
}
sub DESTROY { }
}
sub import {
my $self = shift;
if ( @_ == 0 ) {
$self->export_to_level( 1, $self, @EXPORT );
} elsif ( @_ == 1 ) {
# This is admittedly a little bit silly:
# do we ever export anything else than 'struct'...?
$self->export_to_level( 1, $self, @_ );
} else {
goto &struct;
}
}
sub struct {
# Determine parameter list structure, one of:
# struct( class => [ element-list ])
# struct( class => { element-list })
# struct( element-list )
# Latter form assumes current package name as struct name.
my ($class, @decls);
my $base_type = ref $_[1];
if ( $base_type eq 'HASH' ) {
$class = shift;
@decls = %{shift()};
_usage_error() if @_;
}
elsif ( $base_type eq 'ARRAY' ) {
$class = shift;
@decls = @{shift()};
_usage_error() if @_;
}
else {
$base_type = 'ARRAY';
$class = caller();
@decls = @_;
}
_usage_error() if @decls % 2 == 1;
# Ensure we are not, and will not be, a subclass.
my $isa = do {
no strict 'refs';
\@{$class . '::ISA'};
};
_subclass_error() if @$isa;
tie @$isa, 'Class::Struct::Tie_ISA';
# Create constructor.
croak "function 'new' already defined in package $class"
if do { no strict 'refs'; defined &{$class . "::new"} };
my @methods = ();
my %refs = ();
my %arrays = ();
my %hashes = ();
my %classes = ();
my $got_class = 0;
my $out = '';
$out = "{\n package $class;\n use Carp;\n sub new {\n";
$out .= " my (\$class, \%init) = \@_;\n";
$out .= " \$class = __PACKAGE__ unless \@_;\n";
my $cnt = 0;
my $idx = 0;
my( $cmt, $name, $type, $elem );
if( $base_type eq 'HASH' ){
$out .= " my(\$r) = {};\n";
$cmt = '';
}
elsif( $base_type eq 'ARRAY' ){
$out .= " my(\$r) = [];\n";
}
$out .= " bless \$r, \$class;\n\n";
while( $idx < @decls ){
$name = $decls[$idx];
$type = $decls[$idx+1];
push( @methods, $name );
if( $base_type eq 'HASH' ){
$elem = "{'${class}::$name'}";
}
elsif( $base_type eq 'ARRAY' ){
$elem = "[$cnt]";
++$cnt;
$cmt = " # $name";
}
if( $type =~ /^\*(.)/ ){
$refs{$name}++;
$type = $1;
}
my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :";
if( $type eq '@' ){
$out .= " croak 'Initializer for $name must be array reference'\n";
$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n";
$out .= " \$r->$name( $init [] );$cmt\n";
$arrays{$name}++;
}
elsif( $type eq '%' ){
$out .= " croak 'Initializer for $name must be hash reference'\n";
$out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n";
$out .= " \$r->$name( $init {} );$cmt\n";
$hashes{$name}++;
}
elsif ( $type eq '$') {
$out .= " \$r->$name( $init undef );$cmt\n";
}
elsif( $type =~ /^\w+(?:::\w+)*$/ ){
$out .= " if (defined(\$init{'$name'})) {\n";
$out .= " if (ref \$init{'$name'} eq 'HASH')\n";
$out .= " { \$r->$name( $type->new(\%{\$init{'$name'}}) ) } $cmt\n";
$out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n";
$out .= " { \$r->$name( \$init{'$name'} ) } $cmt\n";
$out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n";
$out .= " }\n";
$classes{$name} = $type;
$got_class = 1;
}
else{
croak "'$type' is not a valid struct element type";
}
$idx += 2;
}
$out .= "\n \$r;\n}\n";
# Create accessor methods.
my( $pre, $pst, $sel );
$cnt = 0;
foreach $name (@methods){
if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
warnings::warnif("function '$name' already defined, overrides struct accessor method");
}
else {
$pre = $pst = $cmt = $sel = '';
if( defined $refs{$name} ){
$pre = "\\(";
$pst = ")";
$cmt = " # returns ref";
}
$out .= " sub $name {$cmt\n my \$r = shift;\n";
if( $base_type eq 'ARRAY' ){
$elem = "[$cnt]";
++$cnt;
}
elsif( $base_type eq 'HASH' ){
$elem = "{'${class}::$name'}";
}
if( defined $arrays{$name} ){
$out .= " my \$i;\n";
$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
$out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n";
$sel = "->[\$i]";
}
elsif( defined $hashes{$name} ){
$out .= " my \$i;\n";
$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
$out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n";
$sel = "->{\$i}";
}
elsif( defined $classes{$name} ){
$out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
}
$out .= " croak 'Too many args to $name' if \@_ > 1;\n";
$out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
$out .= " }\n";
}
}
$out .= "}\n1;\n";
print $out if $print;
my $result = eval $out;
carp $@ if $@;
}
sub _usage_error {
confess "struct usage error";
}
sub _subclass_error {
croak 'struct class cannot be a subclass (@ISA not allowed)';
}
1; # for require
__END__
=head1 NAME
Class::Struct - declare struct-like datatypes as Perl classes
=head1 SYNOPSIS
use Class::Struct;
# declare struct, based on array:
struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]);
# declare struct, based on hash:
struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... });
package CLASS_NAME;
use Class::Struct;
# declare struct, based on array, implicit class name:
struct( ELEMENT_NAME => ELEMENT_TYPE, ... );
# Declare struct at compile time
use Class::Struct CLASS_NAME => [ELEMENT_NAME => ELEMENT_TYPE, ...];
use Class::Struct CLASS_NAME => {ELEMENT_NAME => ELEMENT_TYPE, ...};
# declare struct at compile time, based on array, implicit
# class name:
package CLASS_NAME;
use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ;
package Myobj;
use Class::Struct;
# declare struct with four types of elements:
struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' );
my $obj = Myobj->new; # constructor
# scalar type accessor:
my $element_value = $obj->s; # element value
$obj->s('new value'); # assign to element
# array type accessor:
my $ary_ref = $obj->a; # reference to whole array
my $ary_element_value = $obj->a(2); # array element value
$obj->a(2, 'new value'); # assign to array element
# hash type accessor:
my $hash_ref = $obj->h; # reference to whole hash
my $hash_element_value = $obj->h('x'); # hash element value
$obj->h('x', 'new value'); # assign to hash element
# class type accessor:
my $element_value = $obj->c; # object reference
$obj->c->method(...); # call method of object
$obj->c(new My_Other_Class); # assign a new object
=head1 DESCRIPTION
C<Class::Struct> exports a single function, C<struct>.
Given a list of element names and types, and optionally
a class name, C<struct> creates a Perl 5 class that implements
a "struct-like" data structure.
The new class is given a constructor method, C<new>, for creating
struct objects.
Each element in the struct data has an accessor method, which is
used to assign to the element and to fetch its value. The
default accessor can be overridden by declaring a C<sub> of the
same name in the package. (See Example 2.)
Each element's type can be scalar, array, hash, or class.
=head2 The C<struct()> function
The C<struct> function has three forms of parameter-list.
struct( CLASS_NAME => [ ELEMENT_LIST ]);
struct( CLASS_NAME => { ELEMENT_LIST });
struct( ELEMENT_LIST );
The first and second forms explicitly identify the name of the
class being created. The third form assumes the current package
name as the class name.
An object of a class created by the first and third forms is
based on an array, whereas an object of a class created by the
second form is based on a hash. The array-based forms will be
somewhat faster and smaller; the hash-based forms are more
flexible.
The class created by C<struct> must not be a subclass of another
class other than C<UNIVERSAL>.
It can, however, be used as a superclass for other classes. To facilitate
this, the generated constructor method uses a two-argument blessing.
Furthermore, if the class is hash-based, the key of each element is
prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12).
A function named C<new> must not be explicitly defined in a class
created by C<struct>.
The I<ELEMENT_LIST> has the form
NAME => TYPE, ...
Each name-type pair declares one element of the struct. Each
element name will be defined as an accessor method unless a
method by that name is explicitly defined; in the latter case, a
warning is issued if the warning flag (B<-w>) is set.
=head2 Class Creation at Compile Time
C<Class::Struct> can create your class at compile time. The main reason
for doing this is obvious, so your class acts like every other class in
Perl. Creating your class at compile time will make the order of events
similar to using any other class ( or Perl module ).
There is no significant speed gain between compile time and run time
class creation, there is just a new, more standard order of events.
=head2 Element Types and Accessor Methods
The four element types -- scalar, array, hash, and class -- are
represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name --
optionally preceded by a C<'*'>.
The accessor method provided by C<struct> for an element depends
on the declared type of the element.
=over 4
=item Scalar (C<'$'> or C<'*$'>)
The element is a scalar, and by default is initialized to C<undef>
(but see L</Initializing with new>).
The accessor's argument, if any, is assigned to the element.
If the element type is C<'$'>, the value of the element (after
assignment) is returned. If the element type is C<'*$'>, a reference
to the element is returned.
=item Array (C<'@'> or C<'*@'>)
The element is an array, initialized by default to C<()>.
With no argument, the accessor returns a reference to the
element's whole array (whether or not the element was
specified as C<'@'> or C<'*@'>).
With one or two arguments, the first argument is an index
specifying one element of the array; the second argument, if
present, is assigned to the array element. If the element type
is C<'@'>, the accessor returns the array element value. If the
element type is C<'*@'>, a reference to the array element is
returned.
As a special case, when the accessor is called with an array reference
as the sole argument, this causes an assignment of the whole array element.
The object reference is returned.
=item Hash (C<'%'> or C<'*%'>)
The element is a hash, initialized by default to C<()>.
With no argument, the accessor returns a reference to the
element's whole hash (whether or not the element was
specified as C<'%'> or C<'*%'>).
With one or two arguments, the first argument is a key specifying
one element of the hash; the second argument, if present, is
assigned to the hash element. If the element type is C<'%'>, the
accessor returns the hash element value. If the element type is
C<'*%'>, a reference to the hash element is returned.
As a special case, when the accessor is called with a hash reference
as the sole argument, this causes an assignment of the whole hash element.
The object reference is returned.
=item Class (C<'Class_Name'> or C<'*Class_Name'>)
The element's value must be a reference blessed to the named
class or to one of its subclasses. The element is not initialized
by default.
The accessor's argument, if any, is assigned to the element. The
accessor will C<croak> if this is not an appropriate object
reference.
If the element type does not start with a C<'*'>, the accessor
returns the element value (after assignment). If the element type
starts with a C<'*'>, a reference to the element itself is returned.
=back
=head2 Initializing with C<new>
C<struct> always creates a constructor called C<new>. That constructor
may take a list of initializers for the various elements of the new
struct.
Each initializer is a pair of values: I<element name>C< =E<gt> >I<value>.
The initializer value for a scalar element is just a scalar value. The
initializer for an array element is an array reference. The initializer
for a hash is a hash reference.
The initializer for a class element is an object of the corresponding class,
or of one of it's subclasses, or a reference to a hash containing named
arguments to be passed to the element's constructor.
See Example 3 below for an example of initialization.
=head1 EXAMPLES
=over 4
=item Example 1
Giving a struct element a class type that is also a struct is how
structs are nested. Here, C<Timeval> represents a time (seconds and
microseconds), and C<Rusage> has two elements, each of which is of
type C<Timeval>.
use Class::Struct;
struct( Rusage => {
ru_utime => 'Timeval', # user time used
ru_stime => 'Timeval', # system time used
});
struct( Timeval => [
tv_secs => '$', # seconds
tv_usecs => '$', # microseconds
]);
# create an object:
my $t = Rusage->new(ru_utime=>Timeval->new(),
ru_stime=>Timeval->new());
# $t->ru_utime and $t->ru_stime are objects of type Timeval.
# set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec.
$t->ru_utime->tv_secs(100);
$t->ru_utime->tv_usecs(0);
$t->ru_stime->tv_secs(5);
$t->ru_stime->tv_usecs(0);
=item Example 2
An accessor function can be redefined in order to provide
additional checking of values, etc. Here, we want the C<count>
element always to be nonnegative, so we redefine the C<count>
accessor accordingly.
package MyObj;
use Class::Struct;
# declare the struct
struct ( 'MyObj', { count => '$', stuff => '%' } );
# override the default accessor method for 'count'
sub count {
my $self = shift;
if ( @_ ) {
die 'count must be nonnegative' if $_[0] < 0;
$self->{'MyObj::count'} = shift;
warn "Too many args to count" if @_;
}
return $self->{'MyObj::count'};
}
package main;
$x = new MyObj;
print "\$x->count(5) = ", $x->count(5), "\n";
# prints '$x->count(5) = 5'
print "\$x->count = ", $x->count, "\n";
# prints '$x->count = 5'
print "\$x->count(-5) = ", $x->count(-5), "\n";
# dies due to negative argument!
=item Example 3
The constructor of a generated class can be passed a list
of I<element>=>I<value> pairs, with which to initialize the struct.
If no initializer is specified for a particular element, its default
initialization is performed instead. Initializers for non-existent
elements are silently ignored.
Note that the initializer for a nested class may be specified as
an object of that class, or as a reference to a hash of initializers
that are passed on to the nested struct's constructor.
use Class::Struct;
struct Breed =>
{
name => '$',
cross => '$',
};
struct Cat =>
[
name => '$',
kittens => '@',
markings => '%',
breed => 'Breed',
];
my $cat = Cat->new( name => 'Socks',
kittens => ['Monica', 'Kenneth'],
markings => { socks=>1, blaze=>"white" },
breed => Breed->new(name=>'short-hair', cross=>1),
or: breed => {name=>'short-hair', cross=>1},
);
print "Once a cat called ", $cat->name, "\n";
print "(which was a ", $cat->breed->name, ")\n";
print "had 2 kittens: ", join(' and ', @{$cat->kittens}), "\n";
=back
=head1 Author and Modification History
Modified by Damian Conway, 2001-09-10, v0.62.
Modified implicit construction of nested objects.
Now will also take an object ref instead of requiring a hash ref.
Also default initializes nested object attributes to undef, rather
than calling object constructor without args
Original over-helpfulness was fraught with problems:
* the class's constructor might not be called 'new'
* the class might not have a hash-like-arguments constructor
* the class might not have a no-argument constructor
* "recursive" data structures didn't work well:
package Person;
struct { mother => 'Person', father => 'Person'};
Modified by Casey West, 2000-11-08, v0.59.
Added the ability for compile time class creation.
Modified by Damian Conway, 1999-03-05, v0.58.
Added handling of hash-like arg list to class ctor.
Changed to two-argument blessing in ctor to support
derivation from created classes.
Added classname prefixes to keys in hash-based classes
(refer to "Perl Cookbook", Recipe 13.12 for rationale).
Corrected behaviour of accessors for '*@' and '*%' struct
elements. Package now implements documented behaviour when
returning a reference to an entire hash or array element.
Previously these were returned as a reference to a reference
to the element.
Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02.
members() function removed.
Documentation corrected and extended.
Use of struct() in a subclass prohibited.
User definition of accessor allowed.
Treatment of '*' in element types corrected.
Treatment of classes as element types corrected.
Class name to struct() made optional.
Diagnostic checks added.
Originally C<Class::Template> by Dean Roehrich.
# Template.pm --- struct/member template builder
# 12mar95
# Dean Roehrich
#
# changes/bugs fixed since 28nov94 version:
# - podified
# changes/bugs fixed since 21nov94 version:
# - Fixed examples.
# changes/bugs fixed since 02sep94 version:
# - Moved to Class::Template.
# changes/bugs fixed since 20feb94 version:
# - Updated to be a more proper module.
# - Added "use strict".
# - Bug in build_methods, was using @var when @$var needed.
# - Now using my() rather than local().
#
# Uses perl5 classes to create nested data types.
# This is offered as one implementation of Tom Christiansen's
# "structs.pl" idea.
=cut

1515
gitportable/usr/share/perl5/core_perl/Compress/Zlib.pm Normal file
View File

File diff suppressed because it is too large Load Diff

64
gitportable/usr/share/perl5/core_perl/Config/Extensions.pm Normal file
View File

@@ -0,0 +1,64 @@
package Config::Extensions;
use strict;
our (%Extensions, $VERSION, @ISA, @EXPORT_OK);
use Config;
require Exporter;
$VERSION = '0.03';
@ISA = 'Exporter';
@EXPORT_OK = '%Extensions';
foreach my $type (qw(static dynamic nonxs)) {
foreach (split /\s+/, $Config{$type . '_ext'}) {
s!/!::!g;
$Extensions{$_} = $type;
}
}
1;
__END__
=head1 NAME
Config::Extensions - hash lookup of which core extensions were built.
=head1 SYNOPSIS
use Config::Extensions '%Extensions';
if ($Extensions{PerlIO::via}) {
# This perl has PerlIO::via built
}
=head1 DESCRIPTION
The Config::Extensions module provides a hash C<%Extensions> containing all
the core extensions that were enabled for this perl. The hash is keyed by
extension name, with each entry having one of 3 possible values:
=over 4
=item dynamic
The extension is dynamically linked
=item nonxs
The extension is pure perl, so doesn't need linking to the perl executable
=item static
The extension is statically linked to the perl binary
=back
As all values evaluate to true, a simple C<if> test is good enough to determine
whether an extension is present.
All the data uses to generate the C<%Extensions> hash is already present in
the C<Config> module, but not in such a convenient format to quickly reference.
=head1 AUTHOR
Nicholas Clark <nick@ccl4.org>
=cut

582
gitportable/usr/share/perl5/core_perl/Config/Perl/V.pm Normal file
View File

@@ -0,0 +1,582 @@
package Config::Perl::V;
use strict;
use warnings;
use Config;
use Exporter;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
$VERSION = "0.36";
@ISA = qw( Exporter );
@EXPORT_OK = qw( plv2hash summary myconfig signature );
%EXPORT_TAGS = (
'all' => [ @EXPORT_OK ],
'sig' => [ "signature" ],
);
# Characteristics of this binary (from libperl):
# Compile-time options: DEBUGGING PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP
# USE_64_BIT_INT USE_LARGE_FILES USE_PERLIO
# The list are as the perl binary has stored it in PL_bincompat_options
# search for it in
# perl.c line 1643 S_Internals_V ()
# perl -ne'(/^S_Internals_V/../^}/)&&s/^\s+"( .*)"/$1/ and print' perl.c
# perl.h line 4566 PL_bincompat_options
# perl -ne'(/^\w.*PL_bincompat/../^\w}/)&&s/^\s+"( .*)"/$1/ and print' perl.h
my %BTD = map {( $_ => 0 )} qw(
DEBUGGING
NO_HASH_SEED
NO_MATHOMS
NO_PERL_INTERNAL_RAND_SEED
NO_PERL_RAND_SEED
NO_TAINT_SUPPORT
PERL_BOOL_AS_CHAR
PERL_COPY_ON_WRITE
PERL_DISABLE_PMC
PERL_DONT_CREATE_GVSV
PERL_EXTERNAL_GLOB
PERL_HASH_FUNC_DJB2
PERL_HASH_FUNC_MURMUR3
PERL_HASH_FUNC_ONE_AT_A_TIME
PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
PERL_HASH_FUNC_SDBM
PERL_HASH_FUNC_SIPHASH
PERL_HASH_FUNC_SUPERFAST
PERL_IS_MINIPERL
PERL_MALLOC_WRAP
PERL_MEM_LOG
PERL_MEM_LOG_ENV
PERL_MEM_LOG_ENV_FD
PERL_MEM_LOG_NOIMPL
PERL_MEM_LOG_STDERR
PERL_MEM_LOG_TIMESTAMP
PERL_NEW_COPY_ON_WRITE
PERL_OP_PARENT
PERL_PERTURB_KEYS_DETERMINISTIC
PERL_PERTURB_KEYS_DISABLED
PERL_PERTURB_KEYS_RANDOM
PERL_PRESERVE_IVUV
PERL_RC_STACK
PERL_RELOCATABLE_INCPUSH
PERL_USE_DEVEL
PERL_USE_SAFE_PUTENV
PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES
SILENT_NO_TAINT_SUPPORT
UNLINK_ALL_VERSIONS
USE_ATTRIBUTES_FOR_PERLIO
USE_FAST_STDIO
USE_HASH_SEED_EXPLICIT
USE_LOCALE
USE_LOCALE_CTYPE
USE_NO_REGISTRY
USE_PERL_ATOF
USE_SITECUSTOMIZE
USE_THREAD_SAFE_LOCALE
DEBUG_LEAKING_SCALARS
DEBUG_LEAKING_SCALARS_FORK_DUMP
DECCRTL_SOCKETS
FAKE_THREADS
FCRYPT
HAS_TIMES
HAVE_INTERP_INTERN
MULTIPLICITY
MYMALLOC
NO_HASH_SEED
PERL_DEBUG_READONLY_COW
PERL_DEBUG_READONLY_OPS
PERL_GLOBAL_STRUCT
PERL_GLOBAL_STRUCT_PRIVATE
PERL_HASH_NO_SBOX32
PERL_HASH_USE_SBOX32
PERL_IMPLICIT_CONTEXT
PERL_IMPLICIT_SYS
PERLIO_LAYERS
PERL_MAD
PERL_MICRO
PERL_NEED_APPCTX
PERL_NEED_TIMESBASE
PERL_OLD_COPY_ON_WRITE
PERL_POISON
PERL_SAWAMPERSAND
PERL_TRACK_MEMPOOL
PERL_USES_PL_PIDSTATUS
PL_OP_SLAB_ALLOC
THREADS_HAVE_PIDS
USE_64_BIT_ALL
USE_64_BIT_INT
USE_IEEE
USE_ITHREADS
USE_LARGE_FILES
USE_LOCALE_COLLATE
USE_LOCALE_NUMERIC
USE_LOCALE_TIME
USE_LONG_DOUBLE
USE_PERLIO
USE_QUADMATH
USE_REENTRANT_API
USE_SFIO
USE_SOCKS
VMS_DO_SOCKETS
VMS_SHORTEN_LONG_SYMBOLS
VMS_SYMBOL_CASE_AS_IS
);
# These are all the keys that are
# 1. Always present in %Config - lib/Config.pm #87 tie %Config
# 2. Reported by 'perl -V' (the rest)
my @config_vars = qw(
api_subversion
api_version
api_versionstring
archlibexp
dont_use_nlink
d_readlink
d_symlink
exe_ext
inc_version_list
ldlibpthname
patchlevel
path_sep
perl_patchlevel
privlibexp
scriptdir
sitearchexp
sitelibexp
subversion
usevendorprefix
version
git_commit_id
git_describe
git_branch
git_uncommitted_changes
git_commit_id_title
git_snapshot_date
package revision version_patchlevel_string
osname osvers archname
myuname
config_args
hint useposix d_sigaction
useithreads usemultiplicity
useperlio d_sfio uselargefiles usesocks
use64bitint use64bitall uselongdouble
usemymalloc default_inc_excludes_dot bincompat5005
cc ccflags
optimize
cppflags
ccversion gccversion gccosandvers
intsize longsize ptrsize doublesize byteorder
d_longlong longlongsize d_longdbl longdblsize
ivtype ivsize nvtype nvsize lseektype lseeksize
alignbytes prototype
ld ldflags
libpth
libs
perllibs
libc so useshrplib libperl
gnulibc_version
dlsrc dlext d_dlsymun ccdlflags
cccdlflags lddlflags
);
my %empty_build = (
'osname' => "",
'stamp' => 0,
'options' => { %BTD },
'patches' => [],
);
sub _make_derived {
my $conf = shift;
for ( [ 'lseektype' => "Off_t" ],
[ 'myuname' => "uname" ],
[ 'perl_patchlevel' => "patch" ],
) {
my ($official, $derived) = @{$_};
$conf->{'config'}{$derived} ||= $conf->{'config'}{$official};
$conf->{'config'}{$official} ||= $conf->{'config'}{$derived};
$conf->{'derived'}{$derived} = delete $conf->{'config'}{$derived};
}
if (exists $conf->{'config'}{'version_patchlevel_string'} &&
!exists $conf->{'config'}{'api_version'}) {
my $vps = $conf->{'config'}{'version_patchlevel_string'};
$vps =~ s{\b revision \s+ (\S+) }{}x and
$conf->{'config'}{'revision'} ||= $1;
$vps =~ s{\b version \s+ (\S+) }{}x and
$conf->{'config'}{'api_version'} ||= $1;
$vps =~ s{\b subversion \s+ (\S+) }{}x and
$conf->{'config'}{'subversion'} ||= $1;
$vps =~ s{\b patch \s+ (\S+) }{}x and
$conf->{'config'}{'perl_patchlevel'} ||= $1;
}
($conf->{'config'}{'version_patchlevel_string'} ||= join " ",
map { ($_, $conf->{'config'}{$_} ) }
grep { $conf->{'config'}{$_} }
qw( api_version subversion perl_patchlevel )) =~ s/\bperl_//;
$conf->{'config'}{'perl_patchlevel'} ||= ""; # 0 is not a valid patchlevel
if ($conf->{'config'}{'perl_patchlevel'} =~ m{^git\w*-([^-]+)}i) {
$conf->{'config'}{'git_branch'} ||= $1;
$conf->{'config'}{'git_describe'} ||= $conf->{'config'}{'perl_patchlevel'};
}
$conf->{'config'}{$_} ||= "undef" for grep m{^(?:use|def)} => @config_vars;
$conf;
} # _make_derived
sub plv2hash {
my %config;
my $pv = join "\n" => @_;
if ($pv =~ m{^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)}m) {
$config{'package'} = $1;
my $rev = $2;
$rev =~ s/^ revision \s+ (\S+) \s*//x and $config{'revision'} = $1;
$rev and $config{'version_patchlevel_string'} = $rev;
my ($rel) = $config{'package'} =~ m{perl(\d)};
my ($vers, $subvers) = $rev =~ m{version\s+(\d+)\s+subversion\s+(\d+)};
defined $vers && defined $subvers && defined $rel and
$config{'version'} = "$rel.$vers.$subvers";
}
if ($pv =~ m{^\s+(Snapshot of:)\s+(\S+)}) {
$config{'git_commit_id_title'} = $1;
$config{'git_commit_id'} = $2;
}
# these are always last on line and can have multiple quotation styles
for my $k (qw( ccflags ldflags lddlflags )) {
$pv =~ s{, \s* $k \s*=\s* (.*) \s*$}{}mx or next;
my $v = $1;
$v =~ s/\s*,\s*$//;
$v =~ s/^(['"])(.*)\1$/$2/;
$config{$k} = $v;
}
my %kv;
if ($pv =~ m{\S,? (?:osvers|archname)=}) { # attr is not the first on the line
# up to and including 5.24, a line could have multiple kv pairs
%kv = ($pv =~ m{\b
(\w+) # key
\s*= # assign
( '\s*[^']*?\s*' # quoted value
| \S+[^=]*?\s*\n # unquoted running till end of line
| \S+ # unquoted value
| \s*\n # empty
)
(?:,?\s+|\s*\n)? # optional separator (5.8.x reports did
}gx); # not have a ',' between every kv pair)
}
else {
# as of 5.25, each kv pair is listed on its own line
%kv = ($pv =~ m{^
\s+
(\w+) # key
\s*=\s* # assign
(.*?) # value
\s*,?\s*$
}gmx);
}
while (my ($k, $v) = each %kv) {
$k =~ s{\s+$} {};
$v =~ s{\s*\n\z} {};
$v =~ s{,$} {};
$v =~ m{^'(.*)'$} and $v = $1;
$v =~ s{\s+$} {};
$config{$k} = $v;
}
my $build = { %empty_build };
$pv =~ m{^\s+Compiled at\s+(.*)}m
and $build->{'stamp'} = $1;
$pv =~ m{^\s+Locally applied patches:(?:\s+|\n)(.*?)(?:[\s\n]+Buil[td] under)}ms
and $build->{'patches'} = [ split m{\n+\s*}, $1 ];
$pv =~ m{^\s+Compile-time options:(?:\s+|\n)(.*?)(?:[\s\n]+(?:Locally applied|Buil[td] under))}ms
and map { $build->{'options'}{$_} = 1 } split m{\s+|\n} => $1;
$build->{'osname'} = $config{'osname'};
$pv =~ m{^\s+Built under\s+(.*)}m
and $build->{'osname'} = $1;
$config{'osname'} ||= $build->{'osname'};
return _make_derived ({
'build' => $build,
'environment' => {},
'config' => \%config,
'derived' => {},
'inc' => [],
});
} # plv2hash
sub summary {
my $conf = shift || myconfig ();
ref $conf eq "HASH"
&& exists $conf->{'config'}
&& exists $conf->{'build'}
&& ref $conf->{'config'} eq "HASH"
&& ref $conf->{'build'} eq "HASH" or return;
my %info = map {
exists $conf->{'config'}{$_} ? ( $_ => $conf->{'config'}{$_} ) : () }
qw( archname osname osvers revision patchlevel subversion version
cc ccversion gccversion config_args inc_version_list
d_longdbl d_longlong use64bitall use64bitint useithreads
uselongdouble usemultiplicity usemymalloc useperlio useshrplib
doublesize intsize ivsize nvsize longdblsize longlongsize lseeksize
default_inc_excludes_dot
);
$info{$_}++ for grep { $conf->{'build'}{'options'}{$_} } keys %{$conf->{'build'}{'options'}};
return \%info;
} # summary
sub signature {
my $no_md5 = "0" x 32;
my $conf = summary (shift) or return $no_md5;
eval { require Digest::MD5 };
$@ and return $no_md5;
$conf->{'cc'} =~ s{.*\bccache\s+}{};
$conf->{'cc'} =~ s{.*[/\\]}{};
delete $conf->{'config_args'};
return Digest::MD5::md5_hex (join "\xFF" => map {
"$_=".(defined $conf->{$_} ? $conf->{$_} : "\xFE");
} sort keys %{$conf});
} # signature
sub myconfig {
my $args = shift;
my %args = ref $args eq "HASH" ? %{$args} :
ref $args eq "ARRAY" ? @{$args} : ();
my $build = { %empty_build };
# 5.14.0 and later provide all the information without shelling out
my $stamp = eval { Config::compile_date () };
if (defined $stamp) {
$stamp =~ s/^Compiled at //;
$build->{'osname'} = $^O;
$build->{'stamp'} = $stamp;
$build->{'patches'} = [ Config::local_patches () ];
$build->{'options'}{$_} = 1 for Config::bincompat_options (),
Config::non_bincompat_options ();
}
else {
#y $pv = qx[$^X -e"sub Config::myconfig{};" -V];
my $cnf = plv2hash (qx[$^X -V]);
$build->{$_} = $cnf->{'build'}{$_} for qw( osname stamp patches options );
}
my @KEYS = keys %ENV;
my %env =
map {( $_ => $ENV{$_} )} grep m{^PERL} => @KEYS;
if ($args{'env'}) {
$env{$_} = $ENV{$_} for grep m{$args{'env'}} => @KEYS;
}
my %config = map { $_ => $Config{$_} } @config_vars;
return _make_derived ({
'build' => $build,
'environment' => \%env,
'config' => \%config,
'derived' => {},
'inc' => \@INC,
});
} # myconfig
1;
__END__
=head1 NAME
Config::Perl::V - Structured data retrieval of perl -V output
=head1 SYNOPSIS
use Config::Perl::V;
my $local_config = Config::Perl::V::myconfig ();
print $local_config->{config}{osname};
=head1 DESCRIPTION
=head2 $conf = myconfig ()
This function will collect the data described in L</"The hash structure"> below,
and return that as a hash reference. It optionally accepts an option to
include more entries from %ENV. See L</environment> below.
Note that this will not work on uninstalled perls when called with
C<-I/path/to/uninstalled/perl/lib>, but it works when that path is in
C<$PERL5LIB> or in C<$PERL5OPT>, as paths passed using C<-I> are not
known when the C<-V> information is collected.
=head2 $conf = plv2hash ($text [, ...])
Convert a sole 'perl -V' text block, or list of lines, to a complete
myconfig hash. All unknown entries are defaulted.
=head2 $info = summary ([$conf])
Return an arbitrary selection of the information. If no C<$conf> is
given, C<myconfig ()> is used instead.
=head2 $md5 = signature ([$conf])
Return the MD5 of the info returned by C<summary ()> without the
C<config_args> entry.
If C<Digest::MD5> is not available, it return a string with only C<0>'s.
=head2 The hash structure
The returned hash consists of 4 parts:
=over 4
=item build
This information is extracted from the second block that is emitted by
C<perl -V>, and usually looks something like
Characteristics of this binary (from libperl):
Compile-time options: DEBUGGING USE_64_BIT_INT USE_LARGE_FILES
Locally applied patches:
defined-or
MAINT24637
Built under linux
Compiled at Jun 13 2005 10:44:20
@INC:
/usr/lib/perl5/5.8.7/i686-linux-64int
/usr/lib/perl5/5.8.7
/usr/lib/perl5/site_perl/5.8.7/i686-linux-64int
/usr/lib/perl5/site_perl/5.8.7
/usr/lib/perl5/site_perl
.
or
Characteristics of this binary (from libperl):
Compile-time options: DEBUGGING MULTIPLICITY
PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT
PERL_MALLOC_WRAP PERL_TRACK_MEMPOOL
PERL_USE_SAFE_PUTENV USE_ITHREADS
USE_LARGE_FILES USE_PERLIO
USE_REENTRANT_API
Built under linux
Compiled at Jan 28 2009 15:26:59
This information is not available anywhere else, including C<%Config>,
but it is the information that is only known to the perl binary.
The extracted information is stored in 5 entries in the C<build> hash:
=over 4
=item osname
This is most likely the same as C<$Config{osname}>, and was the name
known when perl was built. It might be different if perl was cross-compiled.
The default for this field, if it cannot be extracted, is to copy
C<$Config{osname}>. The two may be differing in casing (OpenBSD vs openbsd).
=item stamp
This is the time string for which the perl binary was compiled. The default
value is 0.
=item options
This is a hash with all the known defines as keys. The value is either 0,
which means unknown or unset, or 1, which means defined.
=item derived
As some variables are reported by a different name in the output of C<perl -V>
than their actual name in C<%Config>, I decided to leave the C<config> entry
as close to reality as possible, and put in the entries that might have been
guessed by the printed output in a separate block.
=item patches
This is a list of optionally locally applied patches. Default is an empty list.
=back
=item environment
By default this hash is only filled with the environment variables
out of %ENV that start with C<PERL>, but you can pass the C<env> option
to myconfig to get more
my $conf = Config::Perl::V::myconfig ({ env => qr/^ORACLE/ });
my $conf = Config::Perl::V::myconfig ([ env => qr/^ORACLE/ ]);
=item config
This hash is filled with the variables that C<perl -V> fills its report
with, and it has the same variables that C<Config::myconfig> returns
from C<%Config>.
=item inc
This is the list of default @INC.
=back
=head1 REASONING
This module was written to be able to return the configuration for the
currently used perl as deeply as needed for the CPANTESTERS framework.
Up until now they used the output of myconfig as a single text blob,
and so it was missing the vital binary characteristics of the running
perl and the optional applied patches.
=head1 BUGS
Please feedback what is wrong
=head1 TODO
* Implement retrieval functions/methods
* Documentation
* Error checking
* Tests
=head1 AUTHOR
H.Merijn Brand <h.m.brand@xs4all.nl>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2009-2023 H.Merijn Brand
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

802
gitportable/usr/share/perl5/core_perl/DB.pm Normal file
View File

@@ -0,0 +1,802 @@
#
# Documentation is at the __END__
#
package DB;
# "private" globals
my ($running, $ready, $deep, $usrctxt, $evalarg,
@stack, @saved, @skippkg, @clients);
my $preeval = {};
my $posteval = {};
my $ineval = {};
####
#
# Globals - must be defined at startup so that clients can refer to
# them right after a C<require DB;>
#
####
BEGIN {
# these are hardcoded in perl source (some are magical)
$DB::sub = ''; # name of current subroutine
%DB::sub = (); # "filename:fromline-toline" for every known sub
$DB::single = 0; # single-step flag (set it to 1 to enable stops in BEGIN/use)
$DB::signal = 0; # signal flag (will cause a stop at the next line)
$DB::trace = 0; # are we tracing through subroutine calls?
@DB::args = (); # arguments of current subroutine or @ARGV array
@DB::dbline = (); # list of lines in currently loaded file
%DB::dbline = (); # actions in current file (keyed by line number)
@DB::ret = (); # return value of last sub executed in list context
$DB::ret = ''; # return value of last sub executed in scalar context
# other "public" globals
$DB::package = ''; # current package space
$DB::filename = ''; # current filename
$DB::subname = ''; # currently executing sub (fully qualified name)
$DB::lineno = ''; # current line number
$DB::VERSION = $DB::VERSION = '1.08';
# initialize private globals to avoid warnings
$running = 1; # are we running, or are we stopped?
@stack = (0);
@clients = ();
$deep = 1000;
$ready = 0;
@saved = ();
@skippkg = ();
$usrctxt = '';
$evalarg = '';
}
####
# entry point for all subroutine calls
#
sub sub {
push(@stack, $DB::single);
$DB::single &= 1;
$DB::single |= 4 if $#stack == $deep;
if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) {
&$DB::sub;
$DB::single |= pop(@stack);
$DB::ret = undef;
}
elsif (wantarray) {
@DB::ret = &$DB::sub;
$DB::single |= pop(@stack);
@DB::ret;
}
else {
$DB::ret = &$DB::sub;
$DB::single |= pop(@stack);
$DB::ret;
}
}
####
# this is called by perl for every statement
#
sub DB {
return unless $ready;
&save;
($DB::package, $DB::filename, $DB::lineno) = caller;
return if @skippkg and grep { $_ eq $DB::package } @skippkg;
$usrctxt = "package $DB::package;"; # this won't let them modify, alas
local(*DB::dbline) = "::_<$DB::filename";
my ($stop, $action);
if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) {
if ($stop eq '1') {
$DB::signal |= 1;
}
else {
$stop = 0 unless $stop; # avoid un_init warning
$evalarg = "\$DB::signal |= do { $stop; }"; &eval;
$DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/; # clear any temp breakpt
}
}
if ($DB::single || $DB::trace || $DB::signal) {
$DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #';
DB->loadfile($DB::filename, $DB::lineno);
}
$evalarg = $action, &eval if $action;
if ($DB::single || $DB::signal) {
_outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4;
$DB::single = 0;
$DB::signal = 0;
$running = 0;
&eval if ($evalarg = DB->prestop);
my $c;
for $c (@clients) {
# perform any client-specific prestop actions
&eval if ($evalarg = $c->cprestop);
# Now sit in an event loop until something sets $running
do {
$c->idle; # call client event loop; must not block
if ($running == 2) { # client wants something eval-ed
&eval if ($evalarg = $c->evalcode);
$running = 0;
}
} until $running;
# perform any client-specific poststop actions
&eval if ($evalarg = $c->cpoststop);
}
&eval if ($evalarg = DB->poststop);
}
($@, $!, $,, $/, $\, $^W) = @saved;
();
}
####
# this takes its argument via $evalarg to preserve current @_
#
sub eval {
($@, $!, $,, $/, $\, $^W) = @saved;
eval "$usrctxt $evalarg; &DB::save";
_outputall($@) if $@;
}
###############################################################################
# no compile-time subroutine call allowed before this point #
###############################################################################
use strict; # this can run only after DB() and sub() are defined
sub save {
@saved = ($@, $!, $,, $/, $\, $^W);
$, = ""; $/ = "\n"; $\ = ""; $^W = 0;
}
sub catch {
for (@clients) { $_->awaken; }
$DB::signal = 1;
$ready = 1;
}
####
#
# Client callable (read inheritable) methods defined after this point
#
####
sub register {
my $s = shift;
$s = _clientname($s) if ref($s);
push @clients, $s;
}
sub done {
my $s = shift;
$s = _clientname($s) if ref($s);
@clients = grep {$_ ne $s} @clients;
$s->cleanup;
# $running = 3 unless @clients;
exit(0) unless @clients;
}
sub _clientname {
my $name = shift;
"$name" =~ /^(.+)=[A-Z]+\(.+\)$/;
return $1;
}
sub next {
my $s = shift;
$DB::single = 2;
$running = 1;
}
sub step {
my $s = shift;
$DB::single = 1;
$running = 1;
}
sub cont {
my $s = shift;
my $i = shift;
$s->set_tbreak($i) if $i;
for ($i = 0; $i <= $#stack;) {
$stack[$i++] &= ~1;
}
$DB::single = 0;
$running = 1;
}
####
# XXX caller must experimentally determine $i (since it depends
# on how many client call frames are between this call and the DB call).
# Such is life.
#
sub ret {
my $s = shift;
my $i = shift; # how many levels to get to DB sub
$i = 0 unless defined $i;
$stack[$#stack-$i] |= 1;
$DB::single = 0;
$running = 1;
}
####
# XXX caller must experimentally determine $start (since it depends
# on how many client call frames are between this call and the DB call).
# Such is life.
#
sub backtrace {
my $self = shift;
my $start = shift;
my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i);
$start = 1 unless $start;
for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
@a = @DB::args;
for (@a) {
s/'/\\'/g;
s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
require 'meta_notation.pm';
$_ = _meta_notation($_) if /[[:^print:]]/a;
}
$w = $w ? '@ = ' : '$ = ';
$a = $h ? '(' . join(', ', @a) . ')' : '';
$e =~ s/\n\s*\;\s*\Z// if $e;
$e =~ s/[\\\']/\\$1/g if $e;
if ($r) {
$s = "require '$e'";
} elsif (defined $r) {
$s = "eval '$e'";
} elsif ($s eq '(eval)') {
$s = "eval {...}";
}
$f = "file '$f'" unless $f eq '-e';
push @ret, "$w&$s$a from $f line $l";
last if $DB::signal;
}
return @ret;
}
sub _outputall {
my $c;
for $c (@clients) {
$c->output(@_);
}
}
sub trace_toggle {
my $s = shift;
$DB::trace = !$DB::trace;
}
####
# without args: returns all defined subroutine names
# with subname args: returns a listref [file, start, end]
#
sub subs {
my $s = shift;
if (@_) {
my(@ret) = ();
while (@_) {
my $name = shift;
push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/]
if exists $DB::sub{$name};
}
return @ret;
}
return keys %DB::sub;
}
####
# first argument is a filename whose subs will be returned
# if a filename is not supplied, all subs in the current
# filename are returned.
#
sub filesubs {
my $s = shift;
my $fname = shift;
$fname = $DB::filename unless $fname;
return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub;
}
####
# returns a list of all filenames that DB knows about
#
sub files {
my $s = shift;
my(@f) = grep(m|^_<|, keys %main::);
return map { substr($_,2) } @f;
}
####
# returns reference to an array holding the lines in currently
# loaded file
#
sub lines {
my $s = shift;
return \@DB::dbline;
}
####
# loadfile($file, $line)
#
sub loadfile {
my $s = shift;
my($file, $line) = @_;
if (!defined $main::{'_<' . $file}) {
my $try;
if (($try) = grep(m|^_<.*$file|, keys %main::)) {
$file = substr($try,2);
}
}
if (defined($main::{'_<' . $file})) {
my $c;
# _outputall("Loading file $file..");
*DB::dbline = "::_<$file";
$DB::filename = $file;
for $c (@clients) {
# print "2 ", $file, '|', $line, "\n";
$c->showfile($file, $line);
}
return $file;
}
return undef;
}
sub lineevents {
my $s = shift;
my $fname = shift;
my(%ret) = ();
my $i;
$fname = $DB::filename unless $fname;
local(*DB::dbline) = "::_<$fname";
for ($i = 1; $i <= $#DB::dbline; $i++) {
$ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})]
if defined $DB::dbline{$i};
}
return %ret;
}
sub set_break {
my $s = shift;
my $i = shift;
my $cond = shift;
$i ||= $DB::lineno;
$cond ||= '1';
$i = _find_subline($i) if ($i =~ /\D/);
$s->output("Subroutine not found.\n") unless $i;
if ($i) {
if ($DB::dbline[$i] == 0) {
$s->output("Line $i not breakable.\n");
}
else {
$DB::dbline{$i} =~ s/^[^\0]*/$cond/;
}
}
}
sub set_tbreak {
my $s = shift;
my $i = shift;
$i = _find_subline($i) if ($i =~ /\D/);
$s->output("Subroutine not found.\n") unless $i;
if ($i) {
if ($DB::dbline[$i] == 0) {
$s->output("Line $i not breakable.\n");
}
else {
$DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
}
}
}
sub _find_subline {
my $name = shift;
$name =~ s/\'/::/;
$name = "${DB::package}\:\:" . $name if $name !~ /::/;
$name = "main" . $name if substr($name,0,2) eq "::";
my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/);
if ($from) {
local *DB::dbline = "::_<$fname";
++$from while $DB::dbline[$from] == 0 && $from < $to;
return $from;
}
return undef;
}
sub clr_breaks {
my $s = shift;
my $i;
if (@_) {
while (@_) {
$i = shift;
$i = _find_subline($i) if ($i =~ /\D/);
$s->output("Subroutine not found.\n") unless $i;
if (defined $DB::dbline{$i}) {
$DB::dbline{$i} =~ s/^[^\0]+//;
if ($DB::dbline{$i} =~ s/^\0?$//) {
delete $DB::dbline{$i};
}
}
}
}
else {
for ($i = 1; $i <= $#DB::dbline ; $i++) {
if (defined $DB::dbline{$i}) {
$DB::dbline{$i} =~ s/^[^\0]+//;
if ($DB::dbline{$i} =~ s/^\0?$//) {
delete $DB::dbline{$i};
}
}
}
}
}
sub set_action {
my $s = shift;
my $i = shift;
my $act = shift;
$i = _find_subline($i) if ($i =~ /\D/);
$s->output("Subroutine not found.\n") unless $i;
if ($i) {
if ($DB::dbline[$i] == 0) {
$s->output("Line $i not actionable.\n");
}
else {
$DB::dbline{$i} =~ s/\0[^\0]*//;
$DB::dbline{$i} .= "\0" . $act;
}
}
}
sub clr_actions {
my $s = shift;
my $i;
if (@_) {
while (@_) {
my $i = shift;
$i = _find_subline($i) if ($i =~ /\D/);
$s->output("Subroutine not found.\n") unless $i;
if ($i && $DB::dbline[$i] != 0) {
$DB::dbline{$i} =~ s/\0[^\0]*//;
delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
}
}
}
else {
for ($i = 1; $i <= $#DB::dbline ; $i++) {
if (defined $DB::dbline{$i}) {
$DB::dbline{$i} =~ s/\0[^\0]*//;
delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//;
}
}
}
}
sub prestop {
my ($client, $val) = @_;
return defined($val) ? $preeval->{$client} = $val : $preeval->{$client};
}
sub poststop {
my ($client, $val) = @_;
return defined($val) ? $posteval->{$client} = $val : $posteval->{$client};
}
#
# "pure virtual" methods
#
# client-specific pre/post-stop actions.
sub cprestop {}
sub cpoststop {}
# client complete startup
sub awaken {}
sub skippkg {
my $s = shift;
push @skippkg, @_ if @_;
}
sub evalcode {
my ($client, $val) = @_;
if (defined $val) {
$running = 2; # hand over to DB() to evaluate in its context
$ineval->{$client} = $val;
}
return $ineval->{$client};
}
sub ready {
my $s = shift;
return $ready = 1;
}
# stubs
sub init {}
sub stop {}
sub idle {}
sub cleanup {}
sub output {}
#
# client init
#
for (@clients) { $_->init }
$SIG{'INT'} = \&DB::catch;
# disable this if stepping through END blocks is desired
# (looks scary and deconstructivist with Swat)
END { $ready = 0 }
1;
__END__
=head1 NAME
DB - programmatic interface to the Perl debugging API
=head1 SYNOPSIS
package CLIENT;
use DB;
@ISA = qw(DB);
# these (inherited) methods can be called by the client
CLIENT->register() # register a client package name
CLIENT->done() # de-register from the debugging API
CLIENT->skippkg('hide::hide') # ask DB not to stop in this package
CLIENT->cont([WHERE]) # run some more (until BREAK or
# another breakpointt)
CLIENT->step() # single step
CLIENT->next() # step over
CLIENT->ret() # return from current subroutine
CLIENT->backtrace() # return the call stack description
CLIENT->ready() # call when client setup is done
CLIENT->trace_toggle() # toggle subroutine call trace mode
CLIENT->subs([SUBS]) # return subroutine information
CLIENT->files() # return list of all files known to DB
CLIENT->lines() # return lines in currently loaded file
CLIENT->loadfile(FILE,LINE) # load a file and let other clients know
CLIENT->lineevents() # return info on lines with actions
CLIENT->set_break([WHERE],[COND])
CLIENT->set_tbreak([WHERE])
CLIENT->clr_breaks([LIST])
CLIENT->set_action(WHERE,ACTION)
CLIENT->clr_actions([LIST])
CLIENT->evalcode(STRING) # eval STRING in executing code's context
CLIENT->prestop([STRING]) # execute in code context before stopping
CLIENT->poststop([STRING])# execute in code context before resuming
# These methods will be called at the appropriate times.
# Stub versions provided do nothing.
# None of these can block.
CLIENT->init() # called when debug API inits itself
CLIENT->stop(FILE,LINE) # when execution stops
CLIENT->idle() # while stopped (can be a client event loop)
CLIENT->cleanup() # just before exit
CLIENT->output(LIST) # called to print any output that
# the API must show
=head1 DESCRIPTION
Perl debug information is frequently required not just by debuggers,
but also by modules that need some "special" information to do their
job properly, like profilers.
This module abstracts and provides all of the hooks into Perl internal
debugging functionality, so that various implementations of Perl debuggers
(or packages that want to simply get at the "privileged" debugging data)
can all benefit from the development of this common code. Currently used
by Swat, the perl/Tk GUI debugger.
Note that multiple "front-ends" can latch into this debugging API
simultaneously. This is intended to facilitate things like
debugging with a command line and GUI at the same time, debugging
debuggers etc. [Sounds nice, but this needs some serious support -- GSAR]
In particular, this API does B<not> provide the following functions:
=over 4
=item *
data display
=item *
command processing
=item *
command alias management
=item *
user interface (tty or graphical)
=back
These are intended to be services performed by the clients of this API.
This module attempts to be squeaky clean w.r.t C<use strict;> and when
warnings are enabled.
=head2 Global Variables
The following "public" global names can be read by clients of this API.
Beware that these should be considered "readonly".
=over 8
=item $DB::sub
Name of current executing subroutine.
=item %DB::sub
The keys of this hash are the names of all the known subroutines. Each value
is an encoded string that has the sprintf(3) format
C<("%s:%d-%d", filename, fromline, toline)>.
=item $DB::single
Single-step flag. Will be true if the API will stop at the next statement.
=item $DB::signal
Signal flag. Will be set to a true value if a signal was caught. Clients may
check for this flag to abort time-consuming operations.
=item $DB::trace
This flag is set to true if the API is tracing through subroutine calls.
=item @DB::args
Contains the arguments of current subroutine, or the C<@ARGV> array if in the
toplevel context.
=item @DB::dbline
List of lines in currently loaded file.
=item %DB::dbline
Actions in current file (keys are line numbers). The values are strings that
have the sprintf(3) format C<("%s\000%s", breakcondition, actioncode)>.
=item $DB::package
Package namespace of currently executing code.
=item $DB::filename
Currently loaded filename.
=item $DB::subname
Fully qualified name of currently executing subroutine.
=item $DB::lineno
Line number that will be executed next.
=back
=head2 API Methods
The following are methods in the DB base class. A client must
access these methods by inheritance (*not* by calling them directly),
since the API keeps track of clients through the inheritance
mechanism.
=over 8
=item CLIENT->register()
register a client object/package
=item CLIENT->evalcode(STRING)
eval STRING in executing code context
=item CLIENT->skippkg('D::hide')
ask DB not to stop in these packages
=item CLIENT->run()
run some more (until a breakpt is reached)
=item CLIENT->step()
single step
=item CLIENT->next()
step over
=item CLIENT->done()
de-register from the debugging API
=back
=head2 Client Callback Methods
The following "virtual" methods can be defined by the client. They will
be called by the API at appropriate points. Note that unless specified
otherwise, the debug API only defines empty, non-functional default versions
of these methods.
=over 8
=item CLIENT->init()
Called after debug API inits itself.
=item CLIENT->prestop([STRING])
Usually inherited from DB package. If no arguments are passed,
returns the prestop action string.
=item CLIENT->stop()
Called when execution stops (w/ args file, line).
=item CLIENT->idle()
Called while stopped (can be a client event loop).
=item CLIENT->poststop([STRING])
Usually inherited from DB package. If no arguments are passed,
returns the poststop action string.
=item CLIENT->evalcode(STRING)
Usually inherited from DB package. Ask for a STRING to be C<eval>-ed
in executing code context.
=item CLIENT->cleanup()
Called just before exit.
=item CLIENT->output(LIST)
Called when API must show a message (warnings, errors etc.).
=back
=head1 BUGS
The interface defined by this module is missing some of the later additions
to perl's debugging functionality. As such, this interface should be considered
highly experimental and subject to change.
=head1 AUTHOR
Gurusamy Sarathy gsar@activestate.com
This code heavily adapted from an early version of perl5db.pl attributable
to Larry Wall and the Perl Porters.
=cut

601
gitportable/usr/share/perl5/core_perl/DBM_Filter.pm Normal file
View File

@@ -0,0 +1,601 @@
package DBM_Filter ;
use strict;
use warnings;
our $VERSION = '0.06';
package Tie::Hash ;
use strict;
use warnings;
use Carp;
our %LayerStack = ();
our %origDESTROY = ();
our %Filters = map { $_, undef } qw(
Fetch_Key
Fetch_Value
Store_Key
Store_Value
);
our %Options = map { $_, 1 } qw(
fetch
store
);
#sub Filter_Enable
#{
#}
#
#sub Filter_Disable
#{
#}
sub Filtered
{
my $this = shift;
return defined $LayerStack{$this} ;
}
sub Filter_Pop
{
my $this = shift;
my $stack = $LayerStack{$this} || return undef ;
my $filter = pop @{ $stack };
# remove the filter hooks if this is the last filter to pop
if ( @{ $stack } == 0 ) {
$this->filter_store_key ( undef );
$this->filter_store_value( undef );
$this->filter_fetch_key ( undef );
$this->filter_fetch_value( undef );
delete $LayerStack{$this};
}
return $filter;
}
sub Filter_Key_Push
{
&_do_Filter_Push;
}
sub Filter_Value_Push
{
&_do_Filter_Push;
}
sub Filter_Push
{
&_do_Filter_Push;
}
sub _do_Filter_Push
{
my $this = shift;
my %callbacks = ();
my $caller = (caller(1))[3];
$caller =~ s/^.*:://;
croak "$caller: no parameters present" unless @_ ;
if ( ! $Options{lc $_[0]} ) {
my $class = shift;
my @params = @_;
# if $class already contains "::", don't prefix "DBM_Filter::"
$class = "DBM_Filter::$class" unless $class =~ /::/;
no strict 'refs';
# does the "DBM_Filter::$class" exist?
if ( ! %{ "${class}::"} ) {
# Nope, so try to load it.
eval " require $class ; " ;
croak "$caller: Cannot Load DBM Filter '$class': $@" if $@;
}
my $fetch = *{ "${class}::Fetch" }{CODE};
my $store = *{ "${class}::Store" }{CODE};
my $filter = *{ "${class}::Filter" }{CODE};
use strict 'refs';
my $count = defined($filter) + defined($store) + defined($fetch) ;
if ( $count == 0 )
{ croak "$caller: No methods (Filter, Fetch or Store) found in class '$class'" }
elsif ( $count == 1 && ! defined $filter) {
my $need = defined($fetch) ? 'Store' : 'Fetch';
croak "$caller: Missing method '$need' in class '$class'" ;
}
elsif ( $count >= 2 && defined $filter)
{ croak "$caller: Can't mix Filter with Store and Fetch in class '$class'" }
if (defined $filter) {
my $callbacks = &{ $filter }(@params);
croak "$caller: '${class}::Filter' did not return a hash reference"
unless ref $callbacks && ref $callbacks eq 'HASH';
%callbacks = %{ $callbacks } ;
}
else {
$callbacks{Fetch} = $fetch;
$callbacks{Store} = $store;
}
}
else {
croak "$caller: not even params" unless @_ % 2 == 0;
%callbacks = @_;
}
my %filters = %Filters ;
my @got = ();
while (my ($k, $v) = each %callbacks )
{
my $key = $k;
$k = lc $k;
if ($k eq 'fetch') {
push @got, 'Fetch';
if ($caller eq 'Filter_Push')
{ $filters{Fetch_Key} = $filters{Fetch_Value} = $v }
elsif ($caller eq 'Filter_Key_Push')
{ $filters{Fetch_Key} = $v }
elsif ($caller eq 'Filter_Value_Push')
{ $filters{Fetch_Value} = $v }
}
elsif ($k eq 'store') {
push @got, 'Store';
if ($caller eq 'Filter_Push')
{ $filters{Store_Key} = $filters{Store_Value} = $v }
elsif ($caller eq 'Filter_Key_Push')
{ $filters{Store_Key} = $v }
elsif ($caller eq 'Filter_Value_Push')
{ $filters{Store_Value} = $v }
}
else
{ croak "$caller: Unknown key '$key'" }
croak "$caller: value associated with key '$key' is not a code reference"
unless ref $v && ref $v eq 'CODE';
}
if ( @got != 2 ) {
push @got, 'neither' if @got == 0 ;
croak "$caller: expected both Store & Fetch - got @got";
}
# remember the class
push @{ $LayerStack{$this} }, \%filters ;
my $str_this = "$this" ; # Avoid a closure with $this in the subs below
$this->filter_store_key ( sub { store_hook($str_this, 'Store_Key') });
$this->filter_store_value( sub { store_hook($str_this, 'Store_Value') });
$this->filter_fetch_key ( sub { fetch_hook($str_this, 'Fetch_Key') });
$this->filter_fetch_value( sub { fetch_hook($str_this, 'Fetch_Value') });
# Hijack the callers DESTROY method
$this =~ /^(.*)=/;
my $type = $1 ;
no strict 'refs';
if ( *{ "${type}::DESTROY" }{CODE} ne \&MyDESTROY )
{
$origDESTROY{$type} = *{ "${type}::DESTROY" }{CODE};
no warnings 'redefine';
*{ "${type}::DESTROY" } = \&MyDESTROY ;
}
}
sub store_hook
{
my $this = shift ;
my $type = shift ;
foreach my $layer (@{ $LayerStack{$this} })
{
&{ $layer->{$type} }() if defined $layer->{$type} ;
}
}
sub fetch_hook
{
my $this = shift ;
my $type = shift ;
foreach my $layer (reverse @{ $LayerStack{$this} })
{
&{ $layer->{$type} }() if defined $layer->{$type} ;
}
}
sub MyDESTROY
{
my $this = shift ;
delete $LayerStack{$this} ;
# call real DESTROY
$this =~ /^(.*)=/;
&{ $origDESTROY{$1} }($this);
}
1;
__END__
=head1 NAME
DBM_Filter -- Filter DBM keys/values
=head1 SYNOPSIS
use DBM_Filter ;
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, or ODBM_File
$db = tie %hash, ...
$db->Filter_Push(Fetch => sub {...},
Store => sub {...});
$db->Filter_Push('my_filter1');
$db->Filter_Push('my_filter2', params...);
$db->Filter_Key_Push(...) ;
$db->Filter_Value_Push(...) ;
$db->Filter_Pop();
$db->Filtered();
package DBM_Filter::my_filter1;
sub Store { ... }
sub Fetch { ... }
1;
package DBM_Filter::my_filter2;
sub Filter
{
my @opts = @_;
...
return (
sub Store { ... },
sub Fetch { ... } );
}
1;
=head1 DESCRIPTION
This module provides an interface that allows filters to be applied
to tied Hashes associated with DBM files. It builds on the DBM Filter
hooks that are present in all the *DB*_File modules included with the
standard Perl source distribution from version 5.6.1 onwards. In addition
to the *DB*_File modules distributed with Perl, the BerkeleyDB module,
available on CPAN, supports the DBM Filter hooks. See L<perldbmfilter>
for more details on the DBM Filter hooks.
=head1 What is a DBM Filter?
A DBM Filter allows the keys and/or values in a tied hash to be modified
by some user-defined code just before it is written to the DBM file and
just after it is read back from the DBM file. For example, this snippet
of code
$some_hash{"abc"} = 42;
could potentially trigger two filters, one for the writing of the key
"abc" and another for writing the value 42. Similarly, this snippet
my ($key, $value) = each %some_hash
will trigger two filters, one for the reading of the key and one for
the reading of the value.
Like the existing DBM Filter functionality, this module arranges for the
C<$_> variable to be populated with the key or value that a filter will
check. This usually means that most DBM filters tend to be very short.
=head2 So what's new?
The main enhancements over the standard DBM Filter hooks are:
=over 4
=item *
A cleaner interface.
=item *
The ability to easily apply multiple filters to a single DBM file.
=item *
The ability to create "canned" filters. These allow commonly used filters
to be packaged into a stand-alone module.
=back
=head1 METHODS
This module will arrange for the following methods to be available via
the object returned from the C<tie> call.
=head2 $db->Filter_Push() / $db->Filter_Key_Push() / $db->Filter_Value_Push()
Add a filter to filter stack for the database, C<$db>. The three formats
vary only in whether they apply to the DBM key, the DBM value or both.
=over 5
=item Filter_Push
The filter is applied to I<both> keys and values.
=item Filter_Key_Push
The filter is applied to the key I<only>.
=item Filter_Value_Push
The filter is applied to the value I<only>.
=back
=head2 $db->Filter_Pop()
Removes the last filter that was applied to the DBM file associated with
C<$db>, if present.
=head2 $db->Filtered()
Returns TRUE if there are any filters applied to the DBM associated
with C<$db>. Otherwise returns FALSE.
=head1 Writing a Filter
Filters can be created in two main ways
=head2 Immediate Filters
An immediate filter allows you to specify the filter code to be used
at the point where the filter is applied to a dbm. In this mode the
Filter_*_Push methods expects to receive exactly two parameters.
my $db = tie %hash, 'SDBM_File', ...
$db->Filter_Push( Store => sub { },
Fetch => sub { });
The code reference associated with C<Store> will be called before any
key/value is written to the database and the code reference associated
with C<Fetch> will be called after any key/value is read from the
database.
For example, here is a sample filter that adds a trailing NULL character
to all strings before they are written to the DBM file, and removes the
trailing NULL when they are read from the DBM file
my $db = tie %hash, 'SDBM_File', ...
$db->Filter_Push( Store => sub { $_ .= "\x00" ; },
Fetch => sub { s/\x00$// ; });
Points to note:
=over 5
=item 1.
Both the Store and Fetch filters manipulate C<$_>.
=back
=head2 Canned Filters
Immediate filters are useful for one-off situations. For more generic
problems it can be useful to package the filter up in its own module.
The usage is for a canned filter is:
$db->Filter_Push("name", params)
where
=over 5
=item "name"
is the name of the module to load. If the string specified does not
contain the package separator characters "::", it is assumed to refer to
the full module name "DBM_Filter::name". This means that the full names
for canned filters, "null" and "utf8", included with this module are:
DBM_Filter::null
DBM_Filter::utf8
=item params
any optional parameters that need to be sent to the filter. See the
encode filter for an example of a module that uses parameters.
=back
The module that implements the canned filter can take one of two
forms. Here is a template for the first
package DBM_Filter::null ;
use strict;
use warnings;
sub Store
{
# store code here
}
sub Fetch
{
# fetch code here
}
1;
Notes:
=over 5
=item 1.
The package name uses the C<DBM_Filter::> prefix.
=item 2.
The module I<must> have both a Store and a Fetch method. If only one is
present, or neither are present, a fatal error will be thrown.
=back
The second form allows the filter to hold state information using a
closure, thus:
package DBM_Filter::encoding ;
use strict;
use warnings;
sub Filter
{
my @params = @_ ;
...
return {
Store => sub { $_ = $encoding->encode($_) },
Fetch => sub { $_ = $encoding->decode($_) }
} ;
}
1;
In this instance the "Store" and "Fetch" methods are encapsulated inside a
"Filter" method.
=head1 Filters Included
A number of canned filers are provided with this module. They cover a
number of the main areas that filters are needed when interfacing with
DBM files. They also act as templates for your own filters.
The filter included are:
=over 5
=item * utf8
This module will ensure that all data written to the DBM will be encoded
in UTF-8.
This module needs the Encode module.
=item * encode
Allows you to choose the character encoding will be store in the DBM file.
=item * compress
This filter will compress all data before it is written to the database
and uncompressed it on reading.
This module needs Compress::Zlib.
=item * int32
This module is used when interoperating with a C/C++ application that
uses a C int as either the key and/or value in the DBM file.
=item * null
This module ensures that all data written to the DBM file is null
terminated. This is useful when you have a perl script that needs
to interoperate with a DBM file that a C program also uses. A fairly
common issue is for the C application to include the terminating null
in a string when it writes to the DBM file. This filter will ensure that
all data written to the DBM file can be read by the C application.
=back
=head1 NOTES
=head2 Maintain Round Trip Integrity
When writing a DBM filter it is I<very> important to ensure that it is
possible to retrieve all data that you have written when the DBM filter
is in place. In practice, this means that whatever transformation is
applied to the data in the Store method, the I<exact> inverse operation
should be applied in the Fetch method.
If you don't provide an exact inverse transformation, you will find that
code like this will not behave as you expect.
while (my ($k, $v) = each %hash)
{
...
}
Depending on the transformation, you will find that one or more of the
following will happen
=over 5
=item 1
The loop will never terminate.
=item 2
Too few records will be retrieved.
=item 3
Too many will be retrieved.
=item 4
The loop will do the right thing for a while, but it will unexpectedly fail.
=back
=head2 Don't mix filtered & non-filtered data in the same database file.
This is just a restatement of the previous section. Unless you are
completely certain you know what you are doing, avoid mixing filtered &
non-filtered data.
=head1 EXAMPLE
Say you need to interoperate with a legacy C application that stores
keys as C ints and the values and null terminated UTF-8 strings. Here
is how you would set that up
my $db = tie %hash, 'SDBM_File', ...
$db->Filter_Key_Push('int32') ;
$db->Filter_Value_Push('utf8');
$db->Filter_Value_Push('null');
=head1 SEE ALSO
<DB_File>, L<GDBM_File>, L<NDBM_File>, L<ODBM_File>, L<SDBM_File>, L<perldbmfilter>
=head1 AUTHOR
Paul Marquess <pmqs@cpan.org>

53
gitportable/usr/share/perl5/core_perl/DBM_Filter/compress.pm Normal file
View File

@@ -0,0 +1,53 @@
package DBM_Filter::compress ;
use strict;
use warnings;
use Carp;
our $VERSION = '0.03';
BEGIN
{
eval { require Compress::Zlib; Compress::Zlib->import() };
croak "Compress::Zlib module not found.\n"
if $@;
}
sub Store { $_ = compress($_) }
sub Fetch { $_ = uncompress($_) }
1;
__END__
=head1 NAME
DBM_Filter::compress - filter for DBM_Filter
=head1 SYNOPSIS
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, ODBM_File
use DBM_Filter ;
$db = tie %hash, ...
$db->Filter_Push('compress');
=head1 DESCRIPTION
This DBM filter will compress all data before it is written to the database
and uncompressed it on reading.
A fatal error will be thrown if the Compress::Zlib module is not
available.
=head1 SEE ALSO
L<DBM_Filter>, L<perldbmfilter>, L<Compress::Zlib>
=head1 AUTHOR
Paul Marquess pmqs@cpan.org

86
gitportable/usr/share/perl5/core_perl/DBM_Filter/encode.pm Normal file
View File

@@ -0,0 +1,86 @@
package DBM_Filter::encode ;
use strict;
use warnings;
use Carp;
our $VERSION = '0.03';
BEGIN
{
eval { require Encode; };
croak "Encode module not found.\n"
if $@;
}
sub Filter
{
my $encoding_name = shift || "utf8";
my $encoding = Encode::find_encoding($encoding_name) ;
croak "Encoding '$encoding_name' is not available"
unless $encoding;
return {
Store => sub {
$_ = $encoding->encode($_)
if defined $_ ;
},
Fetch => sub {
$_ = $encoding->decode($_)
if defined $_ ;
}
} ;
}
1;
__END__
=head1 NAME
DBM_Filter::encode - filter for DBM_Filter
=head1 SYNOPSIS
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, ODBM_File
use DBM_Filter ;
$db = tie %hash, ...
$db->Filter_Push('encode' => 'iso-8859-16');
=head1 DESCRIPTION
This DBM filter allows you to choose the character encoding will be
store in the DBM file. The usage is
$db->Filter_Push('encode' => ENCODING);
where "ENCODING" must be a valid encoding name that the Encode module
recognises.
A fatal error will be thrown if:
=over 5
=item 1
The Encode module is not available.
=item 2
The encoding requested is not supported by the Encode module.
=back
=head1 SEE ALSO
L<DBM_Filter>, L<perldbmfilter>, L<Encode>
=head1 AUTHOR
Paul Marquess pmqs@cpan.org

50
gitportable/usr/share/perl5/core_perl/DBM_Filter/int32.pm Normal file
View File

@@ -0,0 +1,50 @@
package DBM_Filter::int32 ;
use strict;
use warnings;
our $VERSION = '0.03';
# todo get Filter to figure endian.
sub Store
{
$_ = 0 if ! defined $_ || $_ eq "" ;
$_ = pack("i", $_);
}
sub Fetch
{
no warnings 'uninitialized';
$_ = unpack("i", $_);
}
1;
__END__
=head1 NAME
DBM_Filter::int32 - filter for DBM_Filter
=head1 SYNOPSIS
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, or ODBM_File
use DBM_Filter ;
$db = tie %hash, ...
$db->Filter_Push('int32');
=head1 DESCRIPTION
This DBM filter is used when interoperating with a C/C++ application
that uses a C int as either the key and/or value in the DBM file.
=head1 SEE ALSO
L<DBM_Filter>, L<perldbmfilter>
=head1 AUTHOR
Paul Marquess pmqs@cpan.org

52
gitportable/usr/share/perl5/core_perl/DBM_Filter/null.pm Normal file
View File

@@ -0,0 +1,52 @@
package DBM_Filter::null ;
use strict;
use warnings;
our $VERSION = '0.03';
sub Store
{
no warnings 'uninitialized';
$_ .= "\x00" ;
}
sub Fetch
{
no warnings 'uninitialized';
s/\x00$// ;
}
1;
__END__
=head1 NAME
DBM_Filter::null - filter for DBM_Filter
=head1 SYNOPSIS
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, or ODBM_File
use DBM_Filter ;
$db = tie %hash, ...
$db->Filter_Push('null');
=head1 DESCRIPTION
This filter ensures that all data written to the DBM file is null
terminated. This is useful when you have a perl script that needs
to interoperate with a DBM file that a C program also uses. A fairly
common issue is for the C application to include the terminating null
in a string when it writes to the DBM file. This filter will ensure that
all data written to the DBM file can be read by the C application.
=head1 SEE ALSO
L<DBM_Filter>, L<perldbmfilter>
=head1 AUTHOR
Paul Marquess pmqs@cpan.org

51
gitportable/usr/share/perl5/core_perl/DBM_Filter/utf8.pm Normal file
View File

@@ -0,0 +1,51 @@
package DBM_Filter::utf8 ;
use strict;
use warnings;
use Carp;
our $VERSION = '0.03';
BEGIN
{
eval { require Encode; };
croak "Encode module not found.\n"
if $@;
}
sub Store { $_ = Encode::encode_utf8($_) if defined $_ }
sub Fetch { $_ = Encode::decode_utf8($_) if defined $_ }
1;
__END__
=head1 NAME
DBM_Filter::utf8 - filter for DBM_Filter
=head1 SYNOPSIS
use SDBM_File; # or DB_File, GDBM_File, NDBM_File, or ODBM_File
use DBM_Filter;
$db = tie %hash, ...
$db->Filter_Push('utf8');
=head1 DESCRIPTION
This Filter will ensure that all data written to the DBM will be encoded
in UTF-8.
This module uses the Encode module.
=head1 SEE ALSO
L<DBM_Filter>, L<perldbmfilter>, L<Encode>
=head1 AUTHOR
Paul Marquess pmqs@cpan.org

152
gitportable/usr/share/perl5/core_perl/Devel/SelfStubber.pm Normal file
View File

@@ -0,0 +1,152 @@
package Devel::SelfStubber;
use File::Spec;
require SelfLoader;
@ISA = qw(SelfLoader);
@EXPORT = 'AUTOLOAD';
$JUST_STUBS = 1;
$VERSION = 1.06;
sub Version {$VERSION}
# Use as
# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub(MODULE_NAME,LIB)'
# (LIB defaults to '.') e.g.
# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub('Math::BigInt')'
# would print out stubs needed if you added a __DATA__ before the subs.
# Setting $Devel::SelfStubber::JUST_STUBS to 0 will print out the whole
# module with the stubs entered just before the __DATA__
sub _add_to_cache {
my($self,$fullname,$pack,$lines, $prototype) = @_;
push(@DATA,@{$lines});
if($fullname){push(@STUBS,"sub $fullname $prototype;\n")}; # stubs
'1;';
}
sub _package_defined {
my($self,$line) = @_;
push(@DATA,$line);
}
sub stub {
my($self,$module,$lib) = @_;
my($line,$end_data,$fh,$mod_file,$found_selfloader);
$lib ||= File::Spec->curdir();
($mod_file = $module) =~ s,::,/,g;
$mod_file =~ tr|/|:| if $^O eq 'MacOS';
$mod_file = File::Spec->catfile($lib, "$mod_file.pm");
$fh = "${module}::DATA";
my (@BEFORE_DATA, @AFTER_DATA, @AFTER_END);
@DATA = @STUBS = ();
open($fh,'<',$mod_file) || die "Unable to open $mod_file";
local $/ = "\n";
while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) {
push(@BEFORE_DATA,$line);
$line =~ /use\s+SelfLoader/ && $found_selfloader++;
}
(defined ($line) && $line =~ m/^__DATA__/)
|| die "$mod_file doesn't contain a __DATA__ token";
$found_selfloader ||
print 'die "\'use SelfLoader;\' statement NOT FOUND!!\n"',"\n";
if ($JUST_STUBS) {
$self->_load_stubs($module);
} else {
$self->_load_stubs($module, \@AFTER_END);
}
if ( fileno($fh) ) {
$end_data = 1;
while(defined($line = <$fh>)) {
push(@AFTER_DATA,$line);
}
}
close($fh);
unless ($JUST_STUBS) {
print @BEFORE_DATA;
}
print @STUBS;
unless ($JUST_STUBS) {
print "1;\n__DATA__\n",@DATA;
if($end_data) { print "__END__ DATA\n",@AFTER_DATA; }
if(@AFTER_END) { print "__END__\n",@AFTER_END; }
}
}
1;
__END__
=head1 NAME
Devel::SelfStubber - generate stubs for a SelfLoading module
=head1 SYNOPSIS
To generate just the stubs:
use Devel::SelfStubber;
Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');
or to generate the whole module with stubs inserted correctly
use Devel::SelfStubber;
$Devel::SelfStubber::JUST_STUBS=0;
Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');
MODULENAME is the Perl module name, e.g. Devel::SelfStubber,
NOT 'Devel/SelfStubber' or 'Devel/SelfStubber.pm'.
MY_LIB_DIR defaults to '.' if not present.
=head1 DESCRIPTION
Devel::SelfStubber prints the stubs you need to put in the module
before the __DATA__ token (or you can get it to print the entire
module with stubs correctly placed). The stubs ensure that if
a method is called, it will get loaded. They are needed specifically
for inherited autoloaded methods.
This is best explained using the following example:
Assume four classes, A,B,C & D.
A is the root class, B is a subclass of A, C is a subclass of B,
and D is another subclass of A.
A
/ \
B D
/
C
If D calls an autoloaded method 'foo' which is defined in class A,
then the method is loaded into class A, then executed. If C then
calls method 'foo', and that method was reimplemented in class
B, but set to be autoloaded, then the lookup mechanism never gets to
the AUTOLOAD mechanism in B because it first finds the method
already loaded in A, and so erroneously uses that. If the method
foo had been stubbed in B, then the lookup mechanism would have
found the stub, and correctly loaded and used the sub from B.
So, for classes and subclasses to have inheritance correctly
work with autoloading, you need to ensure stubs are loaded.
The SelfLoader can load stubs automatically at module initialization
with the statement 'SelfLoader-E<gt>load_stubs()';, but you may wish to
avoid having the stub loading overhead associated with your
initialization (though note that the SelfLoader::load_stubs method
will be called sooner or later - at latest when the first sub
is being autoloaded). In this case, you can put the sub stubs
before the __DATA__ token. This can be done manually, but this
module allows automatic generation of the stubs.
By default it just prints the stubs, but you can set the
global $Devel::SelfStubber::JUST_STUBS to 0 and it will
print out the entire module with the stubs positioned correctly.
At the very least, this is useful to see what the SelfLoader
thinks are stubs - in order to ensure future versions of the
SelfStubber remain in step with the SelfLoader, the
SelfStubber actually uses the SelfLoader to determine which
stubs are needed.
=cut

334
gitportable/usr/share/perl5/core_perl/Digest.pm Normal file
View File

@@ -0,0 +1,334 @@
package Digest;
use strict;
use warnings;
our $VERSION = "1.20";
our %MMAP = (
"SHA-1" => [ [ "Digest::SHA", 1 ], "Digest::SHA1", [ "Digest::SHA2", 1 ] ],
"SHA-224" => [ [ "Digest::SHA", 224 ] ],
"SHA-256" => [ [ "Digest::SHA", 256 ], [ "Digest::SHA2", 256 ] ],
"SHA-384" => [ [ "Digest::SHA", 384 ], [ "Digest::SHA2", 384 ] ],
"SHA-512" => [ [ "Digest::SHA", 512 ], [ "Digest::SHA2", 512 ] ],
"SHA3-224" => [ [ "Digest::SHA3", 224 ] ],
"SHA3-256" => [ [ "Digest::SHA3", 256 ] ],
"SHA3-384" => [ [ "Digest::SHA3", 384 ] ],
"SHA3-512" => [ [ "Digest::SHA3", 512 ] ],
"HMAC-MD5" => "Digest::HMAC_MD5",
"HMAC-SHA-1" => "Digest::HMAC_SHA1",
"CRC-16" => [ [ "Digest::CRC", type => "crc16" ] ],
"CRC-32" => [ [ "Digest::CRC", type => "crc32" ] ],
"CRC-CCITT" => [ [ "Digest::CRC", type => "crcccitt" ] ],
"RIPEMD-160" => "Crypt::RIPEMD160",
);
sub new {
shift; # class ignored
my $algorithm = shift;
my $impl = $MMAP{$algorithm} || do {
$algorithm =~ s/\W+//g;
"Digest::$algorithm";
};
$impl = [$impl] unless ref($impl);
local $@; # don't clobber it for our caller
my $err;
for (@$impl) {
my $class = $_;
my @args;
( $class, @args ) = @$class if ref($class);
no strict 'refs';
unless ( exists ${"$class\::"}{"VERSION"} ) {
my $pm_file = $class . ".pm";
$pm_file =~ s{::}{/}g;
eval {
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
require $pm_file
};
if ($@) {
$err ||= $@;
next;
}
}
return $class->new( @args, @_ );
}
die $err;
}
our $AUTOLOAD;
sub AUTOLOAD {
my $class = shift;
my $algorithm = substr( $AUTOLOAD, rindex( $AUTOLOAD, '::' ) + 2 );
$class->new( $algorithm, @_ );
}
1;
__END__
=head1 NAME
Digest - Modules that calculate message digests
=head1 SYNOPSIS
$md5 = Digest->new("MD5");
$sha1 = Digest->new("SHA-1");
$sha256 = Digest->new("SHA-256");
$sha384 = Digest->new("SHA-384");
$sha512 = Digest->new("SHA-512");
$hmac = Digest->HMAC_MD5($key);
=head1 DESCRIPTION
The C<Digest::> modules calculate digests, also called "fingerprints"
or "hashes", of some data, called a message. The digest is (usually)
some small/fixed size string. The actual size of the digest depend of
the algorithm used. The message is simply a sequence of arbitrary
bytes or bits.
An important property of the digest algorithms is that the digest is
I<likely> to change if the message change in some way. Another
property is that digest functions are one-way functions, that is it
should be I<hard> to find a message that correspond to some given
digest. Algorithms differ in how "likely" and how "hard", as well as
how efficient they are to compute.
Note that the properties of the algorithms change over time, as the
algorithms are analyzed and machines grow faster. If your application
for instance depends on it being "impossible" to generate the same
digest for a different message it is wise to make it easy to plug in
stronger algorithms as the one used grow weaker. Using the interface
documented here should make it easy to change algorithms later.
All C<Digest::> modules provide the same programming interface. A
functional interface for simple use, as well as an object oriented
interface that can handle messages of arbitrary length and which can
read files directly.
The digest can be delivered in three formats:
=over 8
=item I<binary>
This is the most compact form, but it is not well suited for printing
or embedding in places that can't handle arbitrary data.
=item I<hex>
A twice as long string of lowercase hexadecimal digits.
=item I<base64>
A string of portable printable characters. This is the base64 encoded
representation of the digest with any trailing padding removed. The
string will be about 30% longer than the binary version.
L<MIME::Base64> tells you more about this encoding.
=back
The functional interface is simply importable functions with the same
name as the algorithm. The functions take the message as argument and
return the digest. Example:
use Digest::MD5 qw(md5);
$digest = md5($message);
There are also versions of the functions with "_hex" or "_base64"
appended to the name, which returns the digest in the indicated form.
=head1 OO INTERFACE
The following methods are available for all C<Digest::> modules:
=over 4
=item $ctx = Digest->XXX($arg,...)
=item $ctx = Digest->new(XXX => $arg,...)
=item $ctx = Digest::XXX->new($arg,...)
The constructor returns some object that encapsulate the state of the
message-digest algorithm. You can add data to the object and finally
ask for the digest. The "XXX" should of course be replaced by the proper
name of the digest algorithm you want to use.
The two first forms are simply syntactic sugar which automatically
load the right module on first use. The second form allow you to use
algorithm names which contains letters which are not legal perl
identifiers, e.g. "SHA-1". If no implementation for the given algorithm
can be found, then an exception is raised.
To know what arguments (if any) the constructor takes (the C<$args,...> above)
consult the docs for the specific digest implementation.
If new() is called as an instance method (i.e. $ctx->new) it will just
reset the state the object to the state of a newly created object. No
new object is created in this case, and the return value is the
reference to the object (i.e. $ctx).
=item $other_ctx = $ctx->clone
The clone method creates a copy of the digest state object and returns
a reference to the copy.
=item $ctx->reset
This is just an alias for $ctx->new.
=item $ctx->add( $data )
=item $ctx->add( $chunk1, $chunk2, ... )
The string value of the $data provided as argument is appended to the
message we calculate the digest for. The return value is the $ctx
object itself.
If more arguments are provided then they are all appended to the
message, thus all these lines will have the same effect on the state
of the $ctx object:
$ctx->add("a"); $ctx->add("b"); $ctx->add("c");
$ctx->add("a")->add("b")->add("c");
$ctx->add("a", "b", "c");
$ctx->add("abc");
Most algorithms are only defined for strings of bytes and this method
might therefore croak if the provided arguments contain chars with
ordinal number above 255.
=item $ctx->addfile( $io_handle )
The $io_handle is read until EOF and the content is appended to the
message we calculate the digest for. The return value is the $ctx
object itself.
The addfile() method will croak() if it fails reading data for some
reason. If it croaks it is unpredictable what the state of the $ctx
object will be in. The addfile() method might have been able to read
the file partially before it failed. It is probably wise to discard
or reset the $ctx object if this occurs.
In most cases you want to make sure that the $io_handle is in
"binmode" before you pass it as argument to the addfile() method.
=item $ctx->add_bits( $data, $nbits )
=item $ctx->add_bits( $bitstring )
The add_bits() method is an alternative to add() that allow partial
bytes to be appended to the message. Most users can just ignore
this method since typical applications involve only whole-byte data.
The two argument form of add_bits() will add the first $nbits bits
from $data. For the last potentially partial byte only the high order
C<< $nbits % 8 >> bits are used. If $nbits is greater than C<<
length($data) * 8 >>, then this method would do the same as C<<
$ctx->add($data) >>.
The one argument form of add_bits() takes a $bitstring of "1" and "0"
chars as argument. It's a shorthand for C<< $ctx->add_bits(pack("B*",
$bitstring), length($bitstring)) >>.
The return value is the $ctx object itself.
This example shows two calls that should have the same effect:
$ctx->add_bits("111100001010");
$ctx->add_bits("\xF0\xA0", 12);
Most digest algorithms are byte based and for these it is not possible
to add bits that are not a multiple of 8, and the add_bits() method
will croak if you try.
=item $ctx->digest
Return the binary digest for the message.
Note that the C<digest> operation is effectively a destructive,
read-once operation. Once it has been performed, the $ctx object is
automatically C<reset> and can be used to calculate another digest
value. Call $ctx->clone->digest if you want to calculate the digest
without resetting the digest state.
=item $ctx->hexdigest
Same as $ctx->digest, but will return the digest in hexadecimal form.
=item $ctx->b64digest
Same as $ctx->digest, but will return the digest as a base64 encoded
string without padding.
=item $ctx->base64_padded_digest
Same as $ctx->digest, but will return the digest as a base64 encoded
string.
=back
=head1 Digest speed
This table should give some indication on the relative speed of
different algorithms. It is sorted by throughput based on a benchmark
done with of some implementations of this API:
Algorithm Size Implementation MB/s
MD4 128 Digest::MD4 v1.3 165.0
MD5 128 Digest::MD5 v2.33 98.8
SHA-256 256 Digest::SHA2 v1.1.0 66.7
SHA-1 160 Digest::SHA v4.3.1 58.9
SHA-1 160 Digest::SHA1 v2.10 48.8
SHA-256 256 Digest::SHA v4.3.1 41.3
Haval-256 256 Digest::Haval256 v1.0.4 39.8
SHA-384 384 Digest::SHA2 v1.1.0 19.6
SHA-512 512 Digest::SHA2 v1.1.0 19.3
SHA-384 384 Digest::SHA v4.3.1 19.2
SHA-512 512 Digest::SHA v4.3.1 19.2
Whirlpool 512 Digest::Whirlpool v1.0.2 13.0
MD2 128 Digest::MD2 v2.03 9.5
Adler-32 32 Digest::Adler32 v0.03 1.3
CRC-16 16 Digest::CRC v0.05 1.1
CRC-32 32 Digest::CRC v0.05 1.1
MD5 128 Digest::Perl::MD5 v1.5 1.0
CRC-CCITT 16 Digest::CRC v0.05 0.8
These numbers was achieved Apr 2004 with ActivePerl-5.8.3 running
under Linux on a P4 2.8 GHz CPU. The last 5 entries differ by being
pure perl implementations of the algorithms, which explains why they
are so slow.
=head1 SEE ALSO
L<Digest::Adler32>, L<Digest::CRC>, L<Digest::Haval256>,
L<Digest::HMAC>, L<Digest::MD2>, L<Digest::MD4>, L<Digest::MD5>,
L<Digest::SHA>, L<Digest::SHA1>, L<Digest::SHA2>, L<Digest::Whirlpool>
New digest implementations should consider subclassing from L<Digest::base>.
L<MIME::Base64>
http://en.wikipedia.org/wiki/Cryptographic_hash_function
=head1 AUTHOR
Gisle Aas <gisle@aas.no>
The C<Digest::> interface is based on the interface originally
developed by Neil Winton for his C<MD5> module.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
Copyright 1998-2006 Gisle Aas.
Copyright 1995,1996 Neil Winton.
=cut

106
gitportable/usr/share/perl5/core_perl/Digest/base.pm Normal file
View File

@@ -0,0 +1,106 @@
package Digest::base;
use strict;
use warnings;
our $VERSION = "1.20";
# subclass is supposed to implement at least these
sub new;
sub clone;
sub add;
sub digest;
sub reset {
my $self = shift;
$self->new(@_); # ugly
}
sub addfile {
my ( $self, $handle ) = @_;
my $n;
my $buf = "";
while ( ( $n = read( $handle, $buf, 4 * 1024 ) ) ) {
$self->add($buf);
}
unless ( defined $n ) {
require Carp;
Carp::croak("Read failed: $!");
}
$self;
}
sub add_bits {
my $self = shift;
my $bits;
my $nbits;
if ( @_ == 1 ) {
my $arg = shift;
$bits = pack( "B*", $arg );
$nbits = length($arg);
}
else {
( $bits, $nbits ) = @_;
}
if ( ( $nbits % 8 ) != 0 ) {
require Carp;
Carp::croak("Number of bits must be multiple of 8 for this algorithm");
}
return $self->add( substr( $bits, 0, $nbits / 8 ) );
}
sub hexdigest {
my $self = shift;
return unpack( "H*", $self->digest(@_) );
}
sub b64digest {
my $self = shift;
my $b64 = $self->base64_padded_digest;
$b64 =~ s/=+$//;
return $b64;
}
sub base64_padded_digest {
my $self = shift;
require MIME::Base64;
return MIME::Base64::encode( $self->digest(@_), "" );
}
1;
__END__
=head1 NAME
Digest::base - Digest base class
=head1 SYNOPSIS
package Digest::Foo;
use base 'Digest::base';
=head1 DESCRIPTION
The C<Digest::base> class provide implementations of the methods
C<addfile> and C<add_bits> in terms of C<add>, and of the methods
C<hexdigest> and C<b64digest> in terms of C<digest>.
Digest implementations might want to inherit from this class to get
this implementations of the alternative I<add> and I<digest> methods.
A minimal subclass needs to implement the following methods by itself:
new
clone
add
digest
The arguments and expected behaviour of these methods are described in
L<Digest>.
=head1 SEE ALSO
L<Digest>

83
gitportable/usr/share/perl5/core_perl/Digest/file.pm Normal file
View File

@@ -0,0 +1,83 @@
package Digest::file;
use strict;
use warnings;
use Exporter ();
use Carp qw(croak);
use Digest ();
our $VERSION = "1.20";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(digest_file_ctx digest_file digest_file_hex digest_file_base64);
sub digest_file_ctx {
my $file = shift;
croak("No digest algorithm specified") unless @_;
open( my $fh, "<", $file ) || croak("Can't open '$file': $!");
binmode($fh);
my $ctx = Digest->new(@_);
$ctx->addfile($fh);
close($fh);
return $ctx;
}
sub digest_file {
digest_file_ctx(@_)->digest;
}
sub digest_file_hex {
digest_file_ctx(@_)->hexdigest;
}
sub digest_file_base64 {
digest_file_ctx(@_)->b64digest;
}
1;
__END__
=head1 NAME
Digest::file - Calculate digests of files
=head1 SYNOPSIS
# Poor mans "md5sum" command
use Digest::file qw(digest_file_hex);
for (@ARGV) {
print digest_file_hex($_, "MD5"), " $_\n";
}
=head1 DESCRIPTION
This module provide 3 convenience functions to calculate the digest
of files. The following functions are provided:
=over
=item digest_file( $file, $algorithm, [$arg,...] )
This function will calculate and return the binary digest of the bytes
of the given file. The function will croak if it fails to open or
read the file.
The $algorithm is a string like "MD2", "MD5", "SHA-1", "SHA-512".
Additional arguments are passed to the constructor for the
implementation of the given algorithm.
=item digest_file_hex( $file, $algorithm, [$arg,...] )
Same as digest_file(), but return the digest in hex form.
=item digest_file_base64( $file, $algorithm, [$arg,...] )
Same as digest_file(), but return the digest as a base64 encoded
string.
=back
=head1 SEE ALSO
L<Digest>

89
gitportable/usr/share/perl5/core_perl/DirHandle.pm Normal file
View File

@@ -0,0 +1,89 @@
package DirHandle;
our $VERSION = '1.05';
=head1 NAME
DirHandle - (obsolete) supply object methods for directory handles
=head1 SYNOPSIS
# recommended approach since Perl 5.6: do not use DirHandle
if (opendir my $d, '.') {
while (readdir $d) { something($_); }
rewind $d;
while (readdir $d) { something_else($_); }
}
# how you would use this module if you were going to
use DirHandle;
if (my $d = DirHandle->new(".")) {
while (defined($_ = $d->read)) { something($_); }
$d->rewind;
while (defined($_ = $d->read)) { something_else($_); }
}
=head1 DESCRIPTION
B<There is no reason to use this module nowadays.>
The C<DirHandle> method provide an alternative interface to the
opendir(), closedir(), readdir(), and rewinddir() functions.
Up to Perl 5.5, opendir() could not autovivify a directory handle from
C<undef>, so using a lexical handle required using a function from L<Symbol>
to create an anonymous glob, which took a separate step.
C<DirHandle> encapsulates this, which allowed cleaner code than opendir().
Since Perl 5.6, opendir() alone has been all you need for lexical handles.
=cut
require 5.000;
use Carp;
use Symbol;
sub new {
@_ >= 1 && @_ <= 2 or croak 'usage: DirHandle->new( [DIRNAME] )';
my $class = shift;
my $dh = gensym;
if (@_) {
DirHandle::open($dh, $_[0])
or return undef;
}
bless $dh, $class;
}
sub DESTROY {
my ($dh) = @_;
# Don't warn about already being closed as it may have been closed
# correctly, or maybe never opened at all.
local($., $@, $!, $^E, $?);
no warnings 'io';
closedir($dh);
}
sub open {
@_ == 2 or croak 'usage: $dh->open(DIRNAME)';
my ($dh, $dirname) = @_;
opendir($dh, $dirname);
}
sub close {
@_ == 1 or croak 'usage: $dh->close()';
my ($dh) = @_;
closedir($dh);
}
sub read {
@_ == 1 or croak 'usage: $dh->read()';
my ($dh) = @_;
readdir($dh);
}
sub rewind {
@_ == 1 or croak 'usage: $dh->rewind()';
my ($dh) = @_;
rewinddir($dh);
}
1;

675
gitportable/usr/share/perl5/core_perl/Dumpvalue.pm Normal file
View File

@@ -0,0 +1,675 @@
use 5.006_001; # for (defined ref) and $#$v and our
package Dumpvalue;
use strict;
use warnings;
our $VERSION = '1.21';
our(%address, $stab, @stab, %stab, %subs);
sub ASCII { return ord('A') == 65; }
# This module will give incorrect results for some inputs on EBCDIC platforms
# before v5.8
*to_native = ($] lt "5.008")
? sub { return shift }
: sub { return utf8::unicode_to_native(shift) };
my $APC = chr to_native(0x9F);
my $backslash_c_question = (ASCII) ? '\177' : $APC;
# documentation nits, handle complex data structures better by chromatic
# translate control chars to ^X - Randal Schwartz
# Modifications to print types by Peter Gordon v1.0
# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
# Won't dump symbol tables and contents of debugged files by default
# (IZ) changes for objectification:
# c) quote() renamed to method set_quote();
# d) unctrlSet() renamed to method set_unctrl();
# f) Compiles with 'use strict', but in two places no strict refs is needed:
# maybe more problems are waiting...
my %defaults = (
globPrint => 0,
printUndef => 1,
tick => "auto",
unctrl => 'quote',
subdump => 1,
dumpReused => 0,
bareStringify => 1,
hashDepth => '',
arrayDepth => '',
dumpDBFiles => '',
dumpPackages => '',
quoteHighBit => '',
usageOnly => '',
compactDump => '',
veryCompact => '',
stopDbSignal => '',
);
sub new {
my $class = shift;
my %opt = (%defaults, @_);
bless \%opt, $class;
}
sub set {
my $self = shift;
my %opt = @_;
@$self{keys %opt} = values %opt;
}
sub get {
my $self = shift;
wantarray ? @$self{@_} : $$self{pop @_};
}
sub dumpValue {
my $self = shift;
die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
local %address;
local $^W=0;
(print "undef\n"), return unless defined $_[0];
(print $self->stringify($_[0]), "\n"), return unless ref $_[0];
$self->unwrap($_[0],0);
}
sub dumpValues {
my $self = shift;
local %address;
local $^W=0;
(print "undef\n"), return if (@_ == 1 and not defined $_[0]);
$self->unwrap(\@_,0);
}
# This one is good for variable names:
sub unctrl {
local($_) = @_;
return \$_ if ref \$_ eq "GLOB";
s/([\000-\037])/'^' . chr(to_native(ord($1)^64))/eg;
s/ $backslash_c_question /^?/xg;
$_;
}
sub stringify {
my $self = shift;
local $_ = shift;
my $noticks = shift;
my $tick = $self->{tick};
return 'undef' unless defined $_ or not $self->{printUndef};
$_ = '' if not defined $_;
return $_ . "" if ref \$_ eq 'GLOB';
{ no strict 'refs';
$_ = &{'overload::StrVal'}($_)
if $self->{bareStringify} and ref $_
and %overload:: and defined &{'overload::StrVal'};
}
if ($tick eq 'auto') {
if (/[^[:^cntrl:]\n]/) { # All ASCII controls but \n get '"'
$tick = '"';
} else {
$tick = "'";
}
}
if ($tick eq "'") {
s/([\'\\])/\\$1/g;
} elsif ($self->{unctrl} eq 'unctrl') {
s/([\"\\])/\\$1/g ;
$_ = &unctrl($_);
s/([[:^ascii:]])/'\\0x'.sprintf('%2X',ord($1))/eg
if $self->{quoteHighBit};
} elsif ($self->{unctrl} eq 'quote') {
s/([\"\\\$\@])/\\$1/g if $tick eq '"';
s/\e/\\e/g;
s/([\000-\037$backslash_c_question])/'\\c'._escaped_ord($1)/eg;
}
s/([[:^ascii:]])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
($noticks || /^\d+(\.\d*)?\Z/)
? $_
: $tick . $_ . $tick;
}
# Ensure a resulting \ is escaped to be \\
sub _escaped_ord {
my $chr = shift;
if ($chr eq $backslash_c_question) {
$chr = '?';
}
else {
$chr = chr(to_native(ord($chr)^64));
$chr =~ s{\\}{\\\\}g;
}
return $chr;
}
sub DumpElem {
my ($self, $v) = (shift, shift);
my $short = $self->stringify($v, ref $v);
my $shortmore = '';
if ($self->{veryCompact} && ref $v
&& (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
my $depth = $#$v;
($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1)
if $self->{arrayDepth} and $depth >= $self->{arrayDepth};
my @a = map $self->stringify($_), @$v[0..$depth];
print "0..$#{$v} @a$shortmore\n";
} elsif ($self->{veryCompact} && ref $v
&& (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
my @a = sort keys %$v;
my $depth = $#a;
($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
if $self->{hashDepth} and $depth >= $self->{hashDepth};
my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
@a[0..$depth];
local $" = ', ';
print "@b$shortmore\n";
} else {
print "$short\n";
$self->unwrap($v,shift);
}
}
sub unwrap {
my $self = shift;
return if $DB::signal and $self->{stopDbSignal};
my ($v) = shift ;
my ($s) = shift || 0; # extra no of spaces
my $sp;
my (%v,@v,$address,$short,$fileno);
$sp = " " x $s ;
$s += 3 ;
# Check for reused addresses
if (ref $v) {
my $val = $v;
{ no strict 'refs';
$val = &{'overload::StrVal'}($v)
if %overload:: and defined &{'overload::StrVal'};
}
($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
if (!$self->{dumpReused} && defined $address) {
$address{$address}++ ;
if ( $address{$address} > 1 ) {
print "${sp}-> REUSED_ADDRESS\n" ;
return ;
}
}
} elsif (ref \$v eq 'GLOB') {
$address = "$v" . ""; # To avoid a bug with globs
$address{$address}++ ;
if ( $address{$address} > 1 ) {
print "${sp}*DUMPED_GLOB*\n" ;
return ;
}
}
if (ref $v eq 'Regexp') {
my $re = "$v";
$re =~ s,/,\\/,g;
print "$sp-> qr/$re/\n";
return;
}
if ( UNIVERSAL::isa($v, 'HASH') ) {
my @sortKeys = sort keys(%$v) ;
my $more;
my $tHashDepth = $#sortKeys ;
$tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
unless $self->{hashDepth} eq '' ;
$more = "....\n" if $tHashDepth < $#sortKeys ;
my $shortmore = "";
$shortmore = ", ..." if $tHashDepth < $#sortKeys ;
$#sortKeys = $tHashDepth ;
if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
$short = $sp;
my @keys;
for (@sortKeys) {
push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
}
$short .= join ', ', @keys;
$short .= $shortmore;
(print "$short\n"), return if length $short <= $self->{compactDump};
}
for my $key (@sortKeys) {
return if $DB::signal and $self->{stopDbSignal};
my $value = $ {$v}{$key} ;
print $sp, $self->stringify($key), " => ";
$self->DumpElem($value, $s);
}
print "$sp empty hash\n" unless @sortKeys;
print "$sp$more" if defined $more ;
} elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
my $tArrayDepth = $#{$v} ;
my $more ;
$tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
unless $self->{arrayDepth} eq '' ;
$more = "....\n" if $tArrayDepth < $#{$v} ;
my $shortmore = "";
$shortmore = " ..." if $tArrayDepth < $#{$v} ;
if ($self->{compactDump} && !grep(ref $_, @{$v})) {
if ($#$v >= 0) {
$short = $sp . "0..$#{$v} " .
join(" ",
map {defined $v->[$_] ? $self->stringify($v->[$_]) : "empty"} (0..$tArrayDepth)
) . "$shortmore";
} else {
$short = $sp . "empty array";
}
(print "$short\n"), return if length $short <= $self->{compactDump};
}
for my $num (0 .. $tArrayDepth) {
return if $DB::signal and $self->{stopDbSignal};
print "$sp$num ";
if (defined $v->[$num]) {
$self->DumpElem($v->[$num], $s);
} else {
print "empty slot\n";
}
}
print "$sp empty array\n" unless @$v;
print "$sp$more" if defined $more ;
} elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
print "$sp-> ";
$self->DumpElem($$v, $s);
} elsif ( UNIVERSAL::isa($v, 'CODE') ) {
print "$sp-> ";
$self->dumpsub(0, $v);
} elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
print "$sp-> ",$self->stringify($$v,1),"\n";
if ($self->{globPrint}) {
$s += 3;
$self->dumpglob('', $s, "{$$v}", $$v, 1);
} elsif (defined ($fileno = fileno($v))) {
print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
}
} elsif (ref \$v eq 'GLOB') {
if ($self->{globPrint}) {
$self->dumpglob('', $s, "{$v}", $v, 1);
} elsif (defined ($fileno = fileno(\$v))) {
print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
}
}
}
sub matchvar {
$_[0] eq $_[1] or
($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
}
sub compactDump {
my $self = shift;
$self->{compactDump} = shift if @_;
$self->{compactDump} = 6*80-1
if $self->{compactDump} and $self->{compactDump} < 2;
$self->{compactDump};
}
sub veryCompact {
my $self = shift;
$self->{veryCompact} = shift if @_;
$self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
$self->{veryCompact};
}
sub set_unctrl {
my $self = shift;
if (@_) {
my $in = shift;
if ($in eq 'unctrl' or $in eq 'quote') {
$self->{unctrl} = $in;
} else {
print "Unknown value for 'unctrl'.\n";
}
}
$self->{unctrl};
}
sub set_quote {
my $self = shift;
if (@_ and $_[0] eq '"') {
$self->{tick} = '"';
$self->{unctrl} = 'quote';
} elsif (@_ and $_[0] eq 'auto') {
$self->{tick} = 'auto';
$self->{unctrl} = 'quote';
} elsif (@_) { # Need to set
$self->{tick} = "'";
$self->{unctrl} = 'unctrl';
}
$self->{tick};
}
sub dumpglob {
my $self = shift;
return if $DB::signal and $self->{stopDbSignal};
my ($package, $off, $key, $val, $all) = @_;
local(*stab) = $val;
my $fileno;
if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
print( (' ' x $off) . "\$", &unctrl($key), " = " );
$self->DumpElem($stab, 3+$off);
}
if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
print( (' ' x $off) . "\@$key = (\n" );
$self->unwrap(\@stab,3+$off) ;
print( (' ' x $off) . ")\n" );
}
if ($key ne "main::" && $key ne "DB::" && %stab
&& ($self->{dumpPackages} or $key !~ /::$/)
&& ($key !~ /^_</ or $self->{dumpDBFiles})
&& !($package eq "Dumpvalue" and $key eq "stab")) {
print( (' ' x $off) . "\%$key = (\n" );
$self->unwrap(\%stab,3+$off) ;
print( (' ' x $off) . ")\n" );
}
if (defined ($fileno = fileno(*stab))) {
print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
}
if ($all) {
if (defined &stab) {
$self->dumpsub($off, $key);
}
}
}
sub CvGV_name {
my $self = shift;
my $in = shift;
return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken...
$in = \&$in; # Hard reference...
eval {require Devel::Peek; 1} or return;
my $gv = Devel::Peek::CvGV($in) or return;
*$gv{PACKAGE} . '::' . *$gv{NAME};
}
sub dumpsub {
my $self = shift;
my ($off,$sub) = @_;
$off ||= 0;
my $ini = $sub;
my $s;
$sub = $1 if $sub =~ /^\{\*(.*)\}$/;
my $subref = defined $1 ? \&$sub : \&$ini;
my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
|| (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
|| ($self->{subdump} && ($s = $self->findsubs("$subref"))
&& $DB::sub{$s});
$s = $sub unless defined $s;
$place = '???' unless defined $place;
print( (' ' x $off) . "&$s in $place\n" );
}
sub findsubs {
my $self = shift;
return undef unless %DB::sub;
my ($addr, $name, $loc);
while (($name, $loc) = each %DB::sub) {
$addr = \&$name;
$subs{"$addr"} = $name;
}
$self->{subdump} = 0;
$subs{ shift() };
}
sub dumpvars {
my $self = shift;
my ($package,@vars) = @_;
local(%address,$^W);
$package .= "::" unless $package =~ /::$/;
*stab = *main::;
while ($package =~ /(\w+?::)/g) {
*stab = defined ${stab}{$1} ? ${stab}{$1} : '';
}
$self->{TotalStrings} = 0;
$self->{Strings} = 0;
$self->{CompleteTotal} = 0;
for my $k (keys %stab) {
my ($key,$val) = ($k, $stab{$k});
return if $DB::signal and $self->{stopDbSignal};
next if @vars && !grep( matchvar($key, $_), @vars );
if ($self->{usageOnly}) {
$self->globUsage(\$val, $key)
if ($package ne 'Dumpvalue' or $key ne 'stab')
and ref(\$val) eq 'GLOB';
} else {
$self->dumpglob($package, 0,$key, $val);
}
}
if ($self->{usageOnly}) {
print <<EOP;
String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
EOP
$self->{CompleteTotal} += $self->{TotalStrings};
print <<EOP;
Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
EOP
}
}
sub scalarUsage {
my $self = shift;
my $size;
if (UNIVERSAL::isa($_[0], 'ARRAY')) {
$size = $self->arrayUsage($_[0]);
} elsif (UNIVERSAL::isa($_[0], 'HASH')) {
$size = $self->hashUsage($_[0]);
} elsif (!ref($_[0])) {
$size = length($_[0]);
}
$self->{TotalStrings} += $size;
$self->{Strings}++;
$size;
}
sub arrayUsage { # array ref, name
my $self = shift;
my $size = 0;
map {$size += $self->scalarUsage($_)} @{$_[0]};
my $len = @{$_[0]};
print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
if defined $_[1];
$self->{CompleteTotal} += $size;
$size;
}
sub hashUsage { # hash ref, name
my $self = shift;
my @keys = keys %{$_[0]};
my @values = values %{$_[0]};
my $keys = $self->arrayUsage(\@keys);
my $values = $self->arrayUsage(\@values);
my $len = @keys;
my $total = $keys + $values;
print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
" (keys: $keys; values: $values; total: $total bytes)\n"
if defined $_[1];
$total;
}
sub globUsage { # glob ref, name
my $self = shift;
local *stab = *{$_[0]};
my $total = 0;
$total += $self->scalarUsage($stab) if defined $stab;
$total += $self->arrayUsage(\@stab, $_[1]) if @stab;
$total += $self->hashUsage(\%stab, $_[1])
if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
#and !($package eq "Dumpvalue" and $key eq "stab"));
$total;
}
1;
=head1 NAME
Dumpvalue - provides screen dump of Perl data.
=head1 SYNOPSIS
use Dumpvalue;
my $dumper = Dumpvalue->new;
$dumper->set(globPrint => 1);
$dumper->dumpValue(\*::);
$dumper->dumpvars('main');
my $dump = $dumper->stringify($some_value);
=head1 DESCRIPTION
=head2 Creation
A new dumper is created by a call
$d = Dumpvalue->new(option1 => value1, option2 => value2)
Recognized options:
=over 4
=item C<arrayDepth>, C<hashDepth>
Print only first N elements of arrays and hashes. If false, prints all the
elements.
=item C<compactDump>, C<veryCompact>
Change style of array and hash dump. If true, short array
may be printed on one line.
=item C<globPrint>
Whether to print contents of globs.
=item C<dumpDBFiles>
Dump arrays holding contents of debugged files.
=item C<dumpPackages>
Dump symbol tables of packages.
=item C<dumpReused>
Dump contents of "reused" addresses.
=item C<tick>, C<quoteHighBit>, C<printUndef>
Change style of string dump. Default value of C<tick> is C<auto>, one
can enable either double-quotish dump, or single-quotish by setting it
to C<"> or C<'>. By default, characters with high bit set are printed
I<as is>. If C<quoteHighBit> is set, they will be quoted.
=item C<usageOnly>
rudimentary per-package memory usage dump. If set,
C<dumpvars> calculates total size of strings in variables in the package.
=item unctrl
Changes the style of printout of strings. Possible values are
C<unctrl> and C<quote>.
=item subdump
Whether to try to find the subroutine name given the reference.
=item bareStringify
Whether to write the non-overloaded form of the stringify-overloaded objects.
=item quoteHighBit
Whether to print chars with high bit set in binary or "as is".
=item stopDbSignal
Whether to abort printing if debugger signal flag is raised.
=back
Later in the life of the object the methods may be queries with get()
method and set() method (which accept multiple arguments).
=head2 Methods
=over 4
=item dumpValue
$dumper->dumpValue($value);
$dumper->dumpValue([$value1, $value2]);
Prints a dump to the currently selected filehandle.
=item dumpValues
$dumper->dumpValues($value1, $value2);
Same as C<< $dumper->dumpValue([$value1, $value2]); >>.
=item stringify
my $dump = $dumper->stringify($value [,$noticks] );
Returns the dump of a single scalar without printing. If the second
argument is true, the return value does not contain enclosing ticks.
Does not handle data structures.
=item dumpvars
$dumper->dumpvars('my_package');
$dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
The optional arguments are considered as literal strings unless they
start with C<~> or C<!>, in which case they are interpreted as regular
expressions (possibly negated).
The second example prints entries with names C<foo>, and also entries
with names which ends on C<bar>, or are shorter than 5 chars.
=item set_quote
$d->set_quote('"');
Sets C<tick> and C<unctrl> options to suitable values for printout with the
given quote char. Possible values are C<auto>, C<'> and C<">.
=item set_unctrl
$d->set_unctrl('unctrl');
Sets C<unctrl> option with checking for an invalid argument.
Possible values are C<unctrl> and C<quote>.
=item compactDump
$d->compactDump(1);
Sets C<compactDump> option. If the value is 1, sets to a reasonable
big number.
=item veryCompact
$d->veryCompact(1);
Sets C<compactDump> and C<veryCompact> options simultaneously.
=item set
$d->set(option1 => value1, option2 => value2);
=item get
@values = $d->get('option1', 'option2');
=back
=cut

7
gitportable/usr/share/perl5/core_perl/Encode/Changes.e2x Normal file
View File

@@ -0,0 +1,7 @@
#
# $Id: Changes.e2x,v 2.0 2004/05/16 20:55:15 dankogai Exp $
# Revision history for Perl extension Encode::$_Name_.
#
0.01 $_Now_
Autogenerated by enc2xs version $_Version_.

13
gitportable/usr/share/perl5/core_perl/Encode/ConfigLocal_PM.e2x Normal file
View File

@@ -0,0 +1,13 @@
#
# Local demand-load module list
#
# You should not edit this file by hand! use "enc2xs -C"
#
package Encode::ConfigLocal;
our $VERSION = $_LocalVer_;
use strict;
$_ModLines_
1;

190
gitportable/usr/share/perl5/core_perl/Encode/Makefile_PL.e2x Normal file
View File

@@ -0,0 +1,190 @@
#
# This file is auto-generated by:
# enc2xs version $_Version_
# $_Now_
#
use 5.7.2;
use strict;
use ExtUtils::MakeMaker;
use Config;
# Please edit the following to the taste!
my $name = '$_Name_';
my %tables = (
$_Name__t => [ $_TableFiles_ ],
);
#### DO NOT EDIT BEYOND THIS POINT!
require File::Spec;
my ($enc2xs, $encode_h) = ();
my @path_ext = ('');
@path_ext = split(';', $ENV{PATHEXT}) if $^O eq 'MSWin32';
PATHLOOP:
for my $d (@Config{qw/bin sitebin vendorbin/},
(split /$Config{path_sep}/o, $ENV{PATH})){
for my $f (qw/enc2xs enc2xs5.7.3/){
my $path = File::Spec->catfile($d, $f);
for my $ext (@path_ext) {
my $bin = "$path$ext";
-r "$bin" and $enc2xs = $bin and last PATHLOOP;
}
}
}
$enc2xs or die "enc2xs not found!";
print "enc2xs is $enc2xs\n";
my %encode_h = ();
for my $d (@INC){
my $dir = File::Spec->catfile($d, "Encode");
my $file = File::Spec->catfile($dir, "encode.h");
-f $file and $encode_h{$dir} = -M $file;
}
%encode_h or die "encode.h not found!";
# find the latest one
($encode_h) = sort {$encode_h{$b} <=> $encode_h{$a}} keys %encode_h;
print "encode.h is at $encode_h\n";
WriteMakefile(
INC => "-I$encode_h",
#### END_OF_HEADER -- DO NOT EDIT THIS LINE BY HAND! ####
NAME => 'Encode::'.$name,
VERSION_FROM => "$name.pm",
OBJECT => '$(O_FILES)',
'dist' => {
COMPRESS => 'gzip -9f',
SUFFIX => 'gz',
DIST_DEFAULT => 'all tardist',
},
MAN3PODS => {},
PREREQ_PM => {
'Encode' => "1.41",
},
# OS 390 winges about line numbers > 64K ???
XSOPT => '-nolinenumbers',
);
package MY;
sub post_initialize
{
my ($self) = @_;
my %o;
my $x = $self->{'OBJ_EXT'};
# Add the table O_FILES
foreach my $e (keys %tables)
{
$o{$e.$x} = 1;
}
$o{"$name$x"} = 1;
$self->{'O_FILES'} = [sort keys %o];
my @files = ("$name.xs");
$self->{'C'} = ["$name.c"];
# The next two lines to make MacPerl Happy -- dankogai via pudge
$self->{SOURCE} .= " $name.c"
if $^O eq 'MacOS' && $self->{SOURCE} !~ /\b$name\.c\b/;
# $self->{'H'} = [$self->catfile($self->updir,'encode.h')];
my %xs;
foreach my $table (sort keys %tables) {
push (@{$self->{'C'}},"$table.c");
# Do NOT add $table.h etc. to H_FILES unless we own up as to how they
# get built.
foreach my $ext (qw($(OBJ_EXT) .c .h .exh .fnm)) {
push (@files,$table.$ext);
}
}
$self->{'XS'} = { "$name.xs" => "$name.c" };
$self->{'clean'}{'FILES'} .= join(' ',@files);
open(XS,">$name.xs") || die "Cannot open $name.xs:$!";
print XS <<'END';
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include "encode.h"
END
foreach my $table (sort keys %tables) {
print XS qq[#include "${table}.h"\n];
}
print XS <<"END";
static void
Encode_XSEncoding(pTHX_ encode_t *enc)
{
dSP;
HV *stash = gv_stashpv("Encode::XS", TRUE);
SV *iv = newSViv(PTR2IV(enc));
SV *sv = sv_bless(newRV_noinc(iv),stash);
int i = 0;
/* with the SvLEN() == 0 hack, PVX won't be freed. We cast away name's
constness, in the hope that perl won't mess with it. */
assert(SvTYPE(iv) >= SVt_PV); assert(SvLEN(iv) == 0);
SvFLAGS(iv) |= SVp_POK;
SvPVX(iv) = (char*) enc->name[0];
PUSHMARK(sp);
XPUSHs(sv);
while (enc->name[i])
{
const char *name = enc->name[i++];
XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
}
PUTBACK;
call_pv("Encode::define_encoding",G_DISCARD);
SvREFCNT_dec(sv);
}
MODULE = Encode::$name PACKAGE = Encode::$name
PROTOTYPES: DISABLE
BOOT:
{
END
foreach my $table (sort keys %tables) {
print XS qq[#include "${table}.exh"\n];
}
print XS "}\n";
close(XS);
return "# Built $name.xs\n\n";
}
sub postamble
{
my $self = shift;
my $dir = "."; # $self->catdir('Encode');
my $str = "# $name\$(OBJ_EXT) depends on .h and .exh files not .c files - but all written by enc2xs\n";
$str .= "$name.c : $name.xs ";
foreach my $table (sort keys %tables)
{
$str .= " $table.c";
}
$str .= "\n\n";
$str .= "$name\$(OBJ_EXT) : $name.c\n\n";
foreach my $table (sort keys %tables)
{
my $numlines = 1;
my $lengthsofar = length($str);
my $continuator = '';
$str .= "$table.c : Makefile.PL";
foreach my $file (@{$tables{$table}})
{
$str .= $continuator.' '.$self->catfile($dir,$file);
if ( length($str)-$lengthsofar > 128*$numlines )
{
$continuator .= " \\\n\t";
$numlines++;
} else {
$continuator = '';
}
}
my $plib = $self->{PERL_CORE} ? '"-I$(PERL_LIB)"' : '';
my $ucopts = '-"Q"';
$str .=
qq{\n\t\$(PERL) $plib $enc2xs $ucopts -o \$\@ -f $table.fnm\n\n};
open (FILELIST, ">$table.fnm")
|| die "Could not open $table.fnm: $!";
foreach my $file (@{$tables{$table}})
{
print FILELIST $self->catfile($dir,$file) . "\n";
}
close(FILELIST);
}
return $str;
}

31
gitportable/usr/share/perl5/core_perl/Encode/README.e2x Normal file
View File

@@ -0,0 +1,31 @@
Encode::$_Name_ version 0.1
========
NAME
Encode::$_Name_ - <describe encoding>
SYNOPSIS
use Encode::$_Name_;
#<put more words here>
ABSTRACT
<fill this in>
INSTALLATION
To install this module type the following:
perl Makefile.PL
make
make test
make install
DEPENDENCIES
This module requires perl version 5.7.3 or later.
COPYRIGHT AND LICENCE
Copyright (C) 2002 Your Name <your@address.domain>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

23
gitportable/usr/share/perl5/core_perl/Encode/_PM.e2x Normal file
View File

@@ -0,0 +1,23 @@
package Encode::$_Name_;
our $VERSION = "0.01";
use Encode;
use XSLoader;
XSLoader::load(__PACKAGE__,$VERSION);
1;
__END__
=head1 NAME
Encode::$_Name_ - New Encoding
=head1 SYNOPSIS
You got to fill this in!
=head1 SEE ALSO
L<Encode>
=cut

9
gitportable/usr/share/perl5/core_perl/Encode/_T.e2x Normal file
View File

@@ -0,0 +1,9 @@
use strict;
# Adjust the number here!
use Test::More tests => 2;
BEGIN {
use_ok('Encode');
use_ok('Encode::$_Name_');
}
# Add more test here!

237
gitportable/usr/share/perl5/core_perl/English.pm Normal file
View File

@@ -0,0 +1,237 @@
package English;
our $VERSION = '1.11';
require Exporter;
@ISA = qw(Exporter);
=head1 NAME
English - use nice English (or awk) names for ugly punctuation variables
=head1 SYNOPSIS
use English;
use English qw( -no_match_vars ) ; # Avoids regex performance
# penalty in perl 5.18 and
# earlier
...
if ($ERRNO =~ /denied/) { ... }
=head1 DESCRIPTION
This module provides aliases for the built-in variables whose
names no one seems to like to read. Variables with side-effects
which get triggered just by accessing them (like $0) will still
be affected.
For those variables that have an B<awk> version, both long
and short English alternatives are provided. For example,
the C<$/> variable can be referred to either $RS or
$INPUT_RECORD_SEPARATOR if you are using the English module.
See L<perlvar> for a complete list of these.
=head1 PERFORMANCE
NOTE: This was fixed in perl 5.20. Mentioning these three variables no
longer makes a speed difference. This section still applies if your code
is to run on perl 5.18 or earlier.
This module can provoke sizeable inefficiencies for regular expressions,
due to unfortunate implementation details. If performance matters in
your application and you don't need $PREMATCH, $MATCH, or $POSTMATCH,
try doing
use English qw( -no_match_vars ) ;
. B<It is especially important to do this in modules to avoid penalizing
all applications which use them.>
=cut
no warnings;
my $globbed_match ;
# Grandfather $NAME import
sub import {
my $this = shift;
my @list = grep { ! /^-no_match_vars$/ } @_ ;
local $Exporter::ExportLevel = 1;
if ( @_ == @list ) {
*EXPORT = \@COMPLETE_EXPORT ;
$globbed_match ||= (
eval q{
*MATCH = *& ;
*PREMATCH = *` ;
*POSTMATCH = *' ;
1 ;
}
|| do {
require Carp ;
Carp::croak("Can't create English for match leftovers: $@") ;
}
) ;
}
else {
*EXPORT = \@MINIMAL_EXPORT ;
}
Exporter::import($this,grep {s/^\$/*/} @list);
}
@MINIMAL_EXPORT = qw(
*ARG
*LAST_PAREN_MATCH
*INPUT_LINE_NUMBER
*NR
*INPUT_RECORD_SEPARATOR
*RS
*OUTPUT_AUTOFLUSH
*OUTPUT_FIELD_SEPARATOR
*OFS
*OUTPUT_RECORD_SEPARATOR
*ORS
*LIST_SEPARATOR
*SUBSCRIPT_SEPARATOR
*SUBSEP
*FORMAT_PAGE_NUMBER
*FORMAT_LINES_PER_PAGE
*FORMAT_LINES_LEFT
*FORMAT_NAME
*FORMAT_TOP_NAME
*FORMAT_LINE_BREAK_CHARACTERS
*FORMAT_FORMFEED
*CHILD_ERROR
*OS_ERROR
*ERRNO
*EXTENDED_OS_ERROR
*EVAL_ERROR
*PROCESS_ID
*PID
*REAL_USER_ID
*UID
*EFFECTIVE_USER_ID
*EUID
*REAL_GROUP_ID
*GID
*EFFECTIVE_GROUP_ID
*EGID
*PROGRAM_NAME
*PERL_VERSION
*OLD_PERL_VERSION
*ACCUMULATOR
*COMPILING
*DEBUGGING
*SYSTEM_FD_MAX
*INPLACE_EDIT
*PERLDB
*BASETIME
*WARNING
*EXECUTABLE_NAME
*OSNAME
*LAST_REGEXP_CODE_RESULT
*EXCEPTIONS_BEING_CAUGHT
*LAST_SUBMATCH_RESULT
@LAST_MATCH_START
@LAST_MATCH_END
);
@MATCH_EXPORT = qw(
*MATCH
*PREMATCH
*POSTMATCH
);
@COMPLETE_EXPORT = ( @MINIMAL_EXPORT, @MATCH_EXPORT ) ;
# The ground of all being.
*ARG = *_ ;
# Matching.
*LAST_PAREN_MATCH = *+ ;
*LAST_SUBMATCH_RESULT = *^N ;
*LAST_MATCH_START = *-{ARRAY} ;
*LAST_MATCH_END = *+{ARRAY} ;
# Input.
*INPUT_LINE_NUMBER = *. ;
*NR = *. ;
*INPUT_RECORD_SEPARATOR = */ ;
*RS = */ ;
# Output.
*OUTPUT_AUTOFLUSH = *| ;
*OUTPUT_FIELD_SEPARATOR = *, ;
*OFS = *, ;
*OUTPUT_RECORD_SEPARATOR = *\ ;
*ORS = *\ ;
# Interpolation "constants".
*LIST_SEPARATOR = *" ;
*SUBSCRIPT_SEPARATOR = *; ;
*SUBSEP = *; ;
# Formats
*FORMAT_PAGE_NUMBER = *% ;
*FORMAT_LINES_PER_PAGE = *= ;
*FORMAT_LINES_LEFT = *-{SCALAR} ;
*FORMAT_NAME = *~ ;
*FORMAT_TOP_NAME = *^ ;
*FORMAT_LINE_BREAK_CHARACTERS = *: ;
*FORMAT_FORMFEED = *^L ;
# Error status.
*CHILD_ERROR = *? ;
*OS_ERROR = *! ;
*ERRNO = *! ;
*OS_ERROR = *! ;
*ERRNO = *! ;
*EXTENDED_OS_ERROR = *^E ;
*EVAL_ERROR = *@ ;
# Process info.
*PROCESS_ID = *$ ;
*PID = *$ ;
*REAL_USER_ID = *< ;
*UID = *< ;
*EFFECTIVE_USER_ID = *> ;
*EUID = *> ;
*REAL_GROUP_ID = *( ;
*GID = *( ;
*EFFECTIVE_GROUP_ID = *) ;
*EGID = *) ;
*PROGRAM_NAME = *0 ;
# Internals.
*PERL_VERSION = *^V ;
*OLD_PERL_VERSION = *] ;
*ACCUMULATOR = *^A ;
*COMPILING = *^C ;
*DEBUGGING = *^D ;
*SYSTEM_FD_MAX = *^F ;
*INPLACE_EDIT = *^I ;
*PERLDB = *^P ;
*LAST_REGEXP_CODE_RESULT = *^R ;
*EXCEPTIONS_BEING_CAUGHT = *^S ;
*BASETIME = *^T ;
*WARNING = *^W ;
*EXECUTABLE_NAME = *^X ;
*OSNAME = *^O ;
# Deprecated.
# *ARRAY_BASE = *[ ;
# *OFMT = *# ;
1;

255
gitportable/usr/share/perl5/core_perl/Env.pm Normal file
View File

@@ -0,0 +1,255 @@
package Env;
our $VERSION = '1.06';
=head1 NAME
Env - perl module that imports environment variables as scalars or arrays
=head1 SYNOPSIS
use Env;
use Env qw(PATH HOME TERM);
use Env qw($SHELL @LD_LIBRARY_PATH);
=head1 DESCRIPTION
Perl maintains environment variables in a special hash named C<%ENV>. For
when this access method is inconvenient, the Perl module C<Env> allows
environment variables to be treated as scalar or array variables.
The C<Env::import()> function ties environment variables with suitable
names to global Perl variables with the same names. By default it
ties all existing environment variables (C<keys %ENV>) to scalars. If
the C<import> function receives arguments, it takes them to be a list of
variables to tie; it's okay if they don't yet exist. The scalar type
prefix '$' is inferred for any element of this list not prefixed by '$'
or '@'. Arrays are implemented in terms of C<split> and C<join>, using
C<$Config::Config{path_sep}> as the delimiter.
After an environment variable is tied, merely use it like a normal variable.
You may access its value
@path = split(/:/, $PATH);
print join("\n", @LD_LIBRARY_PATH), "\n";
or modify it
$PATH .= ":/any/path";
push @LD_LIBRARY_PATH, $dir;
however you'd like. Bear in mind, however, that each access to a tied array
variable requires splitting the environment variable's string anew.
The code:
use Env qw(@PATH);
push @PATH, '/any/path';
is almost equivalent to:
use Env qw(PATH);
$PATH .= ":/any/path";
except that if C<$ENV{PATH}> started out empty, the second approach leaves
it with the (odd) value "C<:/any/path>", but the first approach leaves it with
"C</any/path>".
To remove a tied environment variable from
the environment, assign it the undefined value
undef $PATH;
undef @LD_LIBRARY_PATH;
=head1 LIMITATIONS
On VMS systems, arrays tied to environment variables are read-only. Attempting
to change anything will cause a warning.
=head1 AUTHOR
Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt>
and
Gregor N. Purdy E<lt>F<gregor@focusresearch.com>E<gt>
=cut
sub import {
my $callpack = caller(0);
my $pack = shift;
my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
return unless @vars;
@vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars;
eval "package $callpack; use vars qw(" . join(' ', @vars) . ")";
die $@ if $@;
foreach (@vars) {
my ($type, $name) = m/^([\$\@])(.*)$/;
if ($type eq '$') {
tie ${"${callpack}::$name"}, Env, $name;
} else {
if ($^O eq 'VMS') {
tie @{"${callpack}::$name"}, Env::Array::VMS, $name;
} else {
tie @{"${callpack}::$name"}, Env::Array, $name;
}
}
}
}
sub TIESCALAR {
bless \($_[1]);
}
sub FETCH {
my ($self) = @_;
$ENV{$$self};
}
sub STORE {
my ($self, $value) = @_;
if (defined($value)) {
$ENV{$$self} = $value;
} else {
delete $ENV{$$self};
}
}
######################################################################
package Env::Array;
use Config;
use Tie::Array;
@ISA = qw(Tie::Array);
my $sep = $Config::Config{path_sep};
sub TIEARRAY {
bless \($_[1]);
}
sub FETCHSIZE {
my ($self) = @_;
return 1 + scalar(() = $ENV{$$self} =~ /\Q$sep\E/g);
}
sub STORESIZE {
my ($self, $size) = @_;
my @temp = split($sep, $ENV{$$self});
$#temp = $size - 1;
$ENV{$$self} = join($sep, @temp);
}
sub CLEAR {
my ($self) = @_;
$ENV{$$self} = '';
}
sub FETCH {
my ($self, $index) = @_;
return (split($sep, $ENV{$$self}))[$index];
}
sub STORE {
my ($self, $index, $value) = @_;
my @temp = split($sep, $ENV{$$self});
$temp[$index] = $value;
$ENV{$$self} = join($sep, @temp);
return $value;
}
sub EXISTS {
my ($self, $index) = @_;
return $index < $self->FETCHSIZE;
}
sub DELETE {
my ($self, $index) = @_;
my @temp = split($sep, $ENV{$$self});
my $value = splice(@temp, $index, 1, ());
$ENV{$$self} = join($sep, @temp);
return $value;
}
sub PUSH {
my $self = shift;
my @temp = split($sep, $ENV{$$self});
push @temp, @_;
$ENV{$$self} = join($sep, @temp);
return scalar(@temp);
}
sub POP {
my ($self) = @_;
my @temp = split($sep, $ENV{$$self});
my $result = pop @temp;
$ENV{$$self} = join($sep, @temp);
return $result;
}
sub UNSHIFT {
my $self = shift;
my @temp = split($sep, $ENV{$$self});
my $result = unshift @temp, @_;
$ENV{$$self} = join($sep, @temp);
return $result;
}
sub SHIFT {
my ($self) = @_;
my @temp = split($sep, $ENV{$$self});
my $result = shift @temp;
$ENV{$$self} = join($sep, @temp);
return $result;
}
sub SPLICE {
my $self = shift;
my $offset = shift;
my $length = shift;
my @temp = split($sep, $ENV{$$self});
if (wantarray) {
my @result = splice @temp, $offset, $length, @_;
$ENV{$$self} = join($sep, @temp);
return @result;
} else {
my $result = scalar splice @temp, $offset, $length, @_;
$ENV{$$self} = join($sep, @temp);
return $result;
}
}
######################################################################
package Env::Array::VMS;
use Tie::Array;
@ISA = qw(Tie::Array);
sub TIEARRAY {
bless \($_[1]);
}
sub FETCHSIZE {
my ($self) = @_;
my $i = 0;
while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
return $i;
}
sub FETCH {
my ($self, $index) = @_;
return $ENV{$$self . ';' . $index};
}
sub EXISTS {
my ($self, $index) = @_;
return $index < $self->FETCHSIZE;
}
sub DELETE { }
1;

605
gitportable/usr/share/perl5/core_perl/Exporter.pm Normal file
View File

@@ -0,0 +1,605 @@
package Exporter;
use strict;
no strict 'refs';
our $Debug = 0;
our $ExportLevel = 0;
our $Verbose ||= 0;
our $VERSION = '5.77';
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__
=head1 NAME
Exporter - Implements default import method for modules
=head1 SYNOPSIS
In module F<YourModule.pm>:
package YourModule;
use Exporter 'import';
our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
or
package YourModule;
require Exporter;
our @ISA = qw(Exporter); # inherit all of Exporter's methods
our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
or
package YourModule;
use parent 'Exporter'; # inherit all of Exporter's methods
our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
In other files which wish to use C<YourModule>:
use YourModule qw(frobnicate); # import listed symbols
frobnicate ($left, $right) # calls YourModule::frobnicate
Take a look at L</Good Practices> for some variants
you will like to use in modern Perl code.
=head1 DESCRIPTION
The Exporter module implements an C<import> method which allows a module
to export functions and variables to its users' namespaces. Many modules
use Exporter rather than implementing their own C<import> method because
Exporter provides a highly flexible interface, with an implementation optimised
for the common case.
Perl automatically calls the C<import> method when processing a
C<use> statement for a module. Modules and C<use> are documented
in L<perlfunc> and L<perlmod>. Understanding the concept of
modules and how the C<use> statement operates is important to
understanding the Exporter.
=head2 How to Export
The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
symbols that are going to be exported into the users name space by
default, or which they can request to be exported, respectively. The
symbols can represent functions, scalars, arrays, hashes, or typeglobs.
The symbols must be given by full name with the exception that the
ampersand in front of a function is optional, e.g.
our @EXPORT = qw(afunc $scalar @array); # afunc is a function
our @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc
If you are only exporting function names it is recommended to omit the
ampersand, as the implementation is faster this way.
=head2 Selecting What to Export
Do B<not> export method names!
Do B<not> export anything else by default without a good reason!
Exports pollute the namespace of the module user. If you must export
try to use C<@EXPORT_OK> in preference to C<@EXPORT> and avoid short or
common symbol names to reduce the risk of name clashes.
Generally anything not exported is still accessible from outside the
module using the C<YourModule::item_name> (or C<< $blessed_ref->method >>)
syntax. By convention you can use a leading underscore on names to
informally indicate that they are 'internal' and not for public use.
(It is actually possible to get private functions by saying:
my $subref = sub { ... };
$subref->(@args); # Call it as a function
$obj->$subref(@args); # Use it as a method
However if you use them for methods it is up to you to figure out
how to make inheritance work.)
As a general rule, if the module is trying to be object oriented
then export nothing. If it's just a collection of functions then
C<@EXPORT_OK> anything but use C<@EXPORT> with caution. For function and
method names use barewords in preference to names prefixed with
ampersands for the export lists.
Other module design guidelines can be found in L<perlmod>.
=head2 How to Import
In other files which wish to use your module there are three basic ways for
them to load your module and import its symbols:
=over 4
=item C<use YourModule;>
This imports all the symbols from YourModule's C<@EXPORT> into the namespace
of the C<use> statement.
=item C<use YourModule ();>
This causes perl to load your module but does not import any symbols.
=item C<use YourModule qw(...);>
This imports only the symbols listed by the caller into their namespace.
All listed symbols must be in your C<@EXPORT> or C<@EXPORT_OK>, else an error
occurs. The advanced export features of Exporter are accessed like this,
but with list entries that are syntactically distinct from symbol names.
=back
Unless you want to use its advanced features, this is probably all you
need to know to use Exporter.
=head1 Advanced Features
=head2 Specialised Import Lists
If any of the entries in an import list begins with !, : or / then
the list is treated as a series of specifications which either add to
or delete from the list of names to import. They are processed left to
right. Specifications are in the form:
[!]name This name only
[!]:DEFAULT All names in @EXPORT
[!]:tag All names in $EXPORT_TAGS{tag} anonymous array
[!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
A leading ! indicates that matching names should be deleted from the
list of names to import. If the first specification is a deletion it
is treated as though preceded by :DEFAULT. If you just want to import
extra names in addition to the default set you will still need to
include :DEFAULT explicitly.
e.g., F<Module.pm> defines:
our @EXPORT = qw(A1 A2 A3 A4 A5);
our @EXPORT_OK = qw(B1 B2 B3 B4 B5);
our %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
Note that you cannot use tags in @EXPORT or @EXPORT_OK.
Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
An application using Module can say something like:
use Module qw(:DEFAULT :T2 !B3 A3);
Other examples include:
use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
Remember that most patterns (using //) will need to be anchored
with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
specifications are being processed and what is actually being imported
into modules.
=head2 Exporting Without Using Exporter's import Method
Exporter has a special method, 'export_to_level' which is used in situations
where you can't directly call Exporter's
import method. The export_to_level
method looks like:
MyPackage->export_to_level(
$where_to_export, $package, @what_to_export
);
where C<$where_to_export> is an integer telling how far up the calling stack
to export your symbols, and C<@what_to_export> is an array telling what
symbols *to* export (usually this is C<@_>). The C<$package> argument is
currently unused.
For example, suppose that you have a module, A, which already has an
import function:
package A;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw($b);
sub import
{
$A::b = 1; # not a very useful import method
}
and you want to Export symbol C<$A::b> back to the module that called
package A. Since Exporter relies on the import method to work, via
inheritance, as it stands Exporter::import() will never get called.
Instead, say the following:
package A;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw($b);
sub import
{
$A::b = 1;
A->export_to_level(1, @_);
}
This will export the symbols one level 'above' the current package - ie: to
the program or module that used package A.
Note: Be careful not to modify C<@_> at all before you call export_to_level
- or people using your package will get very unexplained results!
=head2 Exporting Without Inheriting from Exporter
By including Exporter in your C<@ISA> you inherit an Exporter's import() method
but you also inherit several other helper methods which you probably don't
want and complicate the inheritance tree. To avoid this you can do:
package YourModule;
use Exporter qw(import);
which will export Exporter's own import() method into YourModule.
Everything will work as before but you won't need to include Exporter in
C<@YourModule::ISA>.
Note: This feature was introduced in version 5.57
of Exporter, released with perl 5.8.3.
=head2 Module Version Checking
The Exporter module will convert an attempt to import a number from a
module into a call to C<< $module_name->VERSION($value) >>. This can
be used to validate that the version of the module being used is
greater than or equal to the required version.
For historical reasons, Exporter supplies a C<require_version> method that
simply delegates to C<VERSION>. Originally, before C<UNIVERSAL::VERSION>
existed, Exporter would call C<require_version>.
Since the C<UNIVERSAL::VERSION> method treats the C<$VERSION> number as
a simple numeric value it will regard version 1.10 as lower than
1.9. For this reason it is strongly recommended that you use numbers
with at least two decimal places, e.g., 1.09.
=head2 Managing Unknown Symbols
In some situations you may want to prevent certain symbols from being
exported. Typically this applies to extensions which have functions
or constants that may not exist on some systems.
The names of any symbols that cannot be exported should be listed
in the C<@EXPORT_FAIL> array.
If a module attempts to import any of these symbols the Exporter
will give the module an opportunity to handle the situation before
generating an error. The Exporter will call an export_fail method
with a list of the failed symbols:
@failed_symbols = $module_name->export_fail(@failed_symbols);
If the C<export_fail> method returns an empty list then no error is
recorded and all the requested symbols are exported. If the returned
list is not empty then an error is generated for each symbol and the
export fails. The Exporter provides a default C<export_fail> method which
simply returns the list unchanged.
Uses for the C<export_fail> method include giving better error messages
for some symbols and performing lazy architectural checks (put more
symbols into C<@EXPORT_FAIL> by default and then take them out if someone
actually tries to use them and an expensive check shows that they are
usable on that platform).
=head2 Tag Handling Utility Functions
Since the symbols listed within C<%EXPORT_TAGS> must also appear in either
C<@EXPORT> or C<@EXPORT_OK>, two utility functions are provided which allow
you to easily add tagged sets of symbols to C<@EXPORT> or C<@EXPORT_OK>:
our %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT
Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK
Any names which are not tags are added to C<@EXPORT> or C<@EXPORT_OK>
unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
names being silently added to C<@EXPORT> or C<@EXPORT_OK>. Future versions
may make this a fatal error.
=head2 Generating Combined Tags
If several symbol categories exist in C<%EXPORT_TAGS>, it's usually
useful to create the utility ":all" to simplify "use" statements.
The simplest way to do this is:
our %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
# add all the other ":class" tags to the ":all" class,
# deleting duplicates
{
my %seen;
push @{$EXPORT_TAGS{all}},
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
}
F<CGI.pm> creates an ":all" tag which contains some (but not really
all) of its categories. That could be done with one small
change:
# add some of the other ":class" tags to the ":all" class,
# deleting duplicates
{
my %seen;
push @{$EXPORT_TAGS{all}},
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}}
foreach qw/html2 html3 netscape form cgi internal/;
}
Note that the tag names in C<%EXPORT_TAGS> don't have the leading ':'.
=head2 C<AUTOLOAD>ed Constants
Many modules make use of C<AUTOLOAD>ing for constant subroutines to
avoid having to compile and waste memory on rarely used values (see
L<perlsub> for details on constant subroutines). Calls to such
constant subroutines are not optimized away at compile time because
they can't be checked at compile time for constancy.
Even if a prototype is available at compile time, the body of the
subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
examine both the C<()> prototype and the body of a subroutine at
compile time to detect that it can safely replace calls to that
subroutine with the constant value.
A workaround for this is to call the constants once in a C<BEGIN> block:
package My ;
use Socket ;
foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
BEGIN { SO_LINGER }
foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
SO_LINGER is encountered later in C<My> package.
If you are writing a package that C<AUTOLOAD>s, consider forcing
an C<AUTOLOAD> for any constants explicitly imported by other packages
or which are usually used when your package is C<use>d.
=head1 Good Practices
=head2 Declaring C<@EXPORT_OK> and Friends
When using C<Exporter> with the standard C<strict> and C<warnings>
pragmas, the C<our> keyword is needed to declare the package
variables C<@EXPORT_OK>, C<@EXPORT>, C<@ISA>, etc.
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(munge frobnicate);
If backward compatibility for Perls B<under> 5.6 is important,
one must write instead a C<use vars> statement.
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(munge frobnicate);
=head2 Playing Safe
There are some caveats with the use of runtime statements
like C<require Exporter> and the assignment to package
variables, which can be very subtle for the unaware programmer.
This may happen for instance with mutually recursive
modules, which are affected by the time the relevant
constructions are executed.
The ideal way to never have to think about that is to use
C<BEGIN> blocks and the simple import method. So the first part
of the L</SYNOPSIS> code could be rewritten as:
package YourModule;
use strict;
use warnings;
use Exporter 'import';
BEGIN {
our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
}
Or if you need to inherit from Exporter:
package YourModule;
use strict;
use warnings;
BEGIN {
require Exporter;
our @ISA = qw(Exporter); # inherit all of Exporter's methods
our @EXPORT_OK = qw(munge frobnicate); # symbols to export on request
}
The C<BEGIN> will assure that the loading of F<Exporter.pm>
and the assignments to C<@ISA> and C<@EXPORT_OK> happen
immediately like C<use>, leaving no room for something to get awry
or just plain wrong.
With respect to loading C<Exporter> and inheriting, there
are alternatives with the use of modules like C<base> and C<parent>.
use base qw(Exporter);
# or
use parent qw(Exporter);
Any of these statements are nice replacements for
C<BEGIN { require Exporter; our @ISA = qw(Exporter); }>
with the same compile-time effect. The basic difference
is that C<base> code interacts with declared C<fields>
while C<parent> is a streamlined version of the older
C<base> code to just establish the IS-A relationship.
For more details, see the documentation and code of
L<base> and L<parent>.
Another thorough remedy to that runtime
vs. compile-time trap is to use L<Exporter::Easy>,
which is a wrapper of Exporter that allows all
boilerplate code at a single gulp in the
use statement.
use Exporter::Easy (
OK => [ qw(munge frobnicate) ],
);
# @ISA setup is automatic
# all assignments happen at compile time
=head2 What Not to Export
You have been warned already in L</Selecting What to Export>
to not export:
=over 4
=item *
method names (because you don't need to
and that's likely to not do what you want),
=item *
anything by default (because you don't want to surprise your users...
badly)
=item *
anything you don't need to (because less is more)
=back
There's one more item to add to this list. Do B<not>
export variable names. Just because C<Exporter> lets you
do that, it does not mean you should.
@EXPORT_OK = qw($svar @avar %hvar); # DON'T!
Exporting variables is not a good idea. They can
change under the hood, provoking horrible
effects at-a-distance that are too hard to track
and to fix. Trust me: they are not worth it.
To provide the capability to set/get class-wide
settings, it is best instead to provide accessors
as subroutines or class methods instead.
=head1 SEE ALSO
C<Exporter> is definitely not the only module with
symbol exporter capabilities. At CPAN, you may find
a bunch of them. Some are lighter. Some
provide improved APIs and features. Pick the one
that fits your needs. The following is
a sample list of such modules.
Exporter::Easy
Exporter::Lite
Exporter::Renaming
Exporter::Tidy
Sub::Exporter / Sub::Installer
Perl6::Export / Perl6::Export::Attrs
=head1 LICENSE
This library is free software. You can redistribute it
and/or modify it under the same terms as Perl itself.
=cut

253
gitportable/usr/share/perl5/core_perl/Exporter/Heavy.pm Normal file
View File

@@ -0,0 +1,253 @@
package Exporter::Heavy;
use strict;
no strict 'refs';
# On one line so MakeMaker will see it.
our $VERSION = '5.77';
=head1 NAME
Exporter::Heavy - Exporter guts
=head1 SYNOPSIS
(internal use only)
=head1 DESCRIPTION
No user-serviceable parts inside.
=cut
#
# 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];
$oops++;
}
}
}
}
if ($oops) {
require Carp;
Carp::croak(join("\n", @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;

1846
gitportable/usr/share/perl5/core_perl/Fatal.pm Normal file
View File

File diff suppressed because it is too large Load Diff

402
gitportable/usr/share/perl5/core_perl/File/Basename.pm Normal file
View File

@@ -0,0 +1,402 @@
=head1 NAME
File::Basename - Parse file paths into directory, filename and suffix.
=head1 SYNOPSIS
use File::Basename;
my ($name, $path, $suffix) = fileparse($fullname, @suffixlist);
my $name = fileparse($fullname, @suffixlist);
my $basename = basename($fullname, @suffixlist);
my $dirname = dirname($fullname);
=head1 DESCRIPTION
These routines allow you to parse file paths into their directory, filename
and suffix.
B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and
quirks, of the shell and C functions of the same name. See each
function's documentation for details. If your concern is just parsing
paths it is safer to use L<File::Spec>'s C<splitpath()> and
C<splitdir()> methods.
It is guaranteed that
# Where $path_separator is / for Unix, \ for Windows, etc...
dirname($path) . $path_separator . basename($path);
is equivalent to the original path for all systems but VMS.
=cut
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.86";
fileparse_set_fstype($^O);
=over 4
=item C<fileparse>
X<fileparse>
my($filename, $dirs, $suffix) = fileparse($path);
my($filename, $dirs, $suffix) = fileparse($path, @suffixes);
my $filename = fileparse($path, @suffixes);
The C<fileparse()> routine divides a file path into its $dirs, $filename
and (optionally) the filename $suffix.
$dirs contains everything up to and including the last
directory separator in the $path including the volume (if applicable).
The remainder of the $path is the $filename.
# On Unix returns ("baz", "/foo/bar/", "")
fileparse("/foo/bar/baz");
# On Windows returns ("baz", 'C:\foo\bar\', "")
fileparse('C:\foo\bar\baz');
# On Unix returns ("", "/foo/bar/baz/", "")
fileparse("/foo/bar/baz/");
If @suffixes are given each element is a pattern (either a string or a
C<qr//>) matched against the end of the $filename. The matching
portion is removed and becomes the $suffix.
# On Unix returns ("baz", "/foo/bar/", ".txt")
fileparse("/foo/bar/baz.txt", qr/\.[^.]*/);
If type is non-Unix (see L</fileparse_set_fstype>) then the pattern
matching for suffix removal is performed case-insensitively, since
those systems are not case-sensitive when opening existing files.
You are guaranteed that C<$dirs . $filename . $suffix> will
denote the same location as the original $path.
=cut
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);
}
=item C<basename>
X<basename> X<filename>
my $filename = basename($path);
my $filename = basename($path, @suffixes);
This function is provided for compatibility with the Unix shell command
C<basename(1)>. It does B<NOT> always return the file name portion of a
path as you might expect. To be safe, if you want the file name portion of
a path use C<fileparse()>.
C<basename()> returns the last level of a filepath even if the last
level is clearly directory. In effect, it is acting like C<pop()> for
paths. This differs from C<fileparse()>'s behaviour.
# Both return "bar"
basename("/foo/bar");
basename("/foo/bar/");
@suffixes work as in C<fileparse()> except all regex metacharacters are
quoted.
# These two function calls are equivalent.
my $filename = basename("/foo/bar/baz.txt", ".txt");
my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/);
Also note that in order to be compatible with the shell command,
C<basename()> does not strip off a suffix if it is identical to the
remaining characters in the filename.
=cut
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;
}
=item C<dirname>
X<dirname>
This function is provided for compatibility with the Unix shell
command C<dirname(1)> and has inherited some of its quirks. In spite of
its name it does B<NOT> always return the directory name as you might
expect. To be safe, if you want the directory name of a path use
C<fileparse()>.
Only on VMS (where there is no ambiguity between the file and directory
portions of a path) and AmigaOS (possibly due to an implementation quirk in
this module) does C<dirname()> work like C<fileparse($path)>, returning just the
$dirs.
# On VMS and AmigaOS
my $dirs = dirname($path);
When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function
which is subtly different from how C<fileparse()> works. It returns all but
the last level of a file path even if the last level is clearly a directory.
In effect, it is not returning the directory portion but simply the path one
level up acting like C<chop()> for file paths.
Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on
its returned path.
# returns /foo/bar. fileparse() would return /foo/bar/
dirname("/foo/bar/baz");
# also returns /foo/bar despite the fact that baz is clearly a
# directory. fileparse() would return /foo/bar/baz/
dirname("/foo/bar/baz/");
# returns '.'. fileparse() would return 'foo/'
dirname("foo/");
Under VMS, if there is no directory information in the $path, then the
current default device and directory is used.
=cut
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;
}
}
=item C<fileparse_set_fstype>
X<filesystem>
my $type = fileparse_set_fstype();
my $previous_type = fileparse_set_fstype($type);
Normally File::Basename will assume a file path type native to your current
operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...).
With this function you can override that assumption.
Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS",
"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility),
"Epoc" and "Unix" (all case-insensitive). If an unrecognized $type is
given "Unix" will be assumed.
If you've selected VMS syntax, and the file specification you pass to
one of these routines contains a "/", they assume you are using Unix
emulation and apply the Unix syntax rules instead, for that function
call only.
=back
=cut
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;
=head1 SEE ALSO
L<dirname(1)>, L<basename(1)>, L<File::Spec>

174
gitportable/usr/share/perl5/core_perl/File/Compare.pm Normal file
View File

@@ -0,0 +1,174 @@
package File::Compare 1.1007;
use v5.12;
use warnings;
use Exporter 'import';
our @EXPORT = qw(compare);
our @EXPORT_OK = qw(cmp compare_text);
our $Too_Big = 1024 * 1024 * 2;
sub croak {
require Carp;
goto &Carp::croak;
}
sub compare {
croak("Usage: compare( file1, file2 [, buffersize]) ")
unless(@_ == 2 || @_ == 3);
my ($from,$to,$size) = @_;
my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0);
my ($fromsize,$closefrom,$closeto);
local (*FROM, *TO);
croak("from undefined") unless (defined $from);
croak("to undefined") unless (defined $to);
if (ref($from) &&
(UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) {
*FROM = *$from;
} elsif (ref(\$from) eq 'GLOB') {
*FROM = $from;
} else {
open(FROM,"<",$from) or goto fail_open1;
unless ($text_mode) {
binmode FROM;
$fromsize = -s FROM;
}
$closefrom = 1;
}
if (ref($to) &&
(UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) {
*TO = *$to;
} elsif (ref(\$to) eq 'GLOB') {
*TO = $to;
} else {
open(TO,"<",$to) or goto fail_open2;
binmode TO unless $text_mode;
$closeto = 1;
}
if (!$text_mode && $closefrom && $closeto) {
# If both are opened files we know they differ if their size differ
goto fail_inner if $fromsize != -s TO;
}
if ($text_mode) {
local $/ = "\n";
my ($fline,$tline);
while (defined($fline = <FROM>)) {
goto fail_inner unless defined($tline = <TO>);
if (ref $size) {
# $size contains ref to comparison function
goto fail_inner if &$size($fline, $tline);
} else {
goto fail_inner if $fline ne $tline;
}
}
goto fail_inner if defined($tline = <TO>);
}
else {
unless (defined($size) && $size > 0) {
$size = $fromsize || -s TO || 0;
$size = 1024 if $size < 512;
$size = $Too_Big if $size > $Too_Big;
}
my ($fr,$tr,$fbuf,$tbuf);
$fbuf = $tbuf = '';
while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) {
goto fail_inner;
}
}
goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0;
}
close(TO) || goto fail_open2 if $closeto;
close(FROM) || goto fail_open1 if $closefrom;
return 0;
# All of these contortions try to preserve error messages...
fail_inner:
close(TO) || goto fail_open2 if $closeto;
close(FROM) || goto fail_open1 if $closefrom;
return 1;
fail_open2:
if ($closefrom) {
my $status = $!;
$! = 0;
close FROM;
$! = $status unless $!;
}
fail_open1:
return -1;
}
sub cmp;
*cmp = \&compare;
sub compare_text {
my ($from,$to,$cmp) = @_;
croak("Usage: compare_text( file1, file2 [, cmp-function])")
unless @_ == 2 || @_ == 3;
croak("Third arg to compare_text() function must be a code reference")
if @_ == 3 && ref($cmp) ne 'CODE';
# Using a negative buffer size puts compare into text_mode too
compare($from, $to, $cmp // -1);
}
1;
__END__
=head1 NAME
File::Compare - Compare files or filehandles
=head1 SYNOPSIS
use File::Compare;
if (compare("file1","file2") == 0) {
print "They're equal\n";
}
=head1 DESCRIPTION
The File::Compare::compare function compares the contents of two
sources, each of which can be a file or a file handle. It is exported
from File::Compare by default.
File::Compare::cmp is a synonym for File::Compare::compare. It is
exported from File::Compare only by request.
File::Compare::compare_text does a line by line comparison of the two
files. It stops as soon as a difference is detected. compare_text()
accepts an optional third argument: This must be a CODE reference to
a line comparison function, which returns 0 when both lines are considered
equal. For example:
compare_text($file1, $file2)
is basically equivalent to
compare_text($file1, $file2, sub {$_[0] ne $_[1]} )
=head1 RETURN
File::Compare::compare and its sibling functions return 0 if the files
are equal, 1 if the files are unequal, or -1 if an error was encountered.
=head1 AUTHOR
File::Compare was written by Nick Ing-Simmons.
Its original documentation was written by Chip Salzenberg.

513
gitportable/usr/share/perl5/core_perl/File/Copy.pm Normal file
View File

@@ -0,0 +1,513 @@
# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This
# source code has been placed in the public domain by the author.
# Please be kind and preserve the documentation.
#
# Additions copyright 1996 by Charles Bailey. Permission is granted
# to distribute the revised code under the same terms as Perl itself.
package File::Copy;
use 5.035007;
use strict;
use warnings; no warnings 'newline';
no warnings 'experimental::builtin';
use builtin 'blessed';
use overload;
use File::Spec;
use Config;
# We want HiRes stat and utime if available
BEGIN { eval q{ use Time::HiRes qw( stat utime ) } };
our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
sub copy;
sub syscopy;
sub cp;
sub mv;
$VERSION = '2.41';
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(copy move);
@EXPORT_OK = qw(cp mv);
$Too_Big = 1024 * 1024 * 2;
sub croak {
require Carp;
goto &Carp::croak;
}
sub carp {
require Carp;
goto &Carp::carp;
}
sub _catname {
my($from, $to) = @_;
if (not defined &basename) {
require File::Basename;
File::Basename->import( 'basename' );
}
return File::Spec->catfile($to, basename($from));
}
# _eq($from, $to) tells whether $from and $to are identical
sub _eq {
my ($from, $to) = map {
blessed($_) && overload::Method($_, q{""})
? "$_"
: $_
} (@_);
return '' if ( (ref $from) xor (ref $to) );
return $from == $to if ref $from;
return $from eq $to;
}
sub copy {
croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
unless(@_ == 2 || @_ == 3);
my $from = shift;
my $to = shift;
my $size;
if (@_) {
$size = shift(@_) + 0;
croak("Bad buffer size for copy: $size\n") unless ($size > 0);
}
my $from_a_handle = (ref($from)
? (ref($from) eq 'GLOB'
|| UNIVERSAL::isa($from, 'GLOB')
|| UNIVERSAL::isa($from, 'IO::Handle'))
: (ref(\$from) eq 'GLOB'));
my $to_a_handle = (ref($to)
? (ref($to) eq 'GLOB'
|| UNIVERSAL::isa($to, 'GLOB')
|| UNIVERSAL::isa($to, 'IO::Handle'))
: (ref(\$to) eq 'GLOB'));
if (_eq($from, $to)) { # works for references, too
carp("'$from' and '$to' are identical (not copied)");
return 0;
}
if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
$to = _catname($from, $to);
}
if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
!($^O eq 'os2')) {
my @fs = stat($from);
if (@fs) {
my @ts = stat($to);
if (@ts && $fs[0] == $ts[0] && $fs[1] eq $ts[1] && !-p $from) {
carp("'$from' and '$to' are identical (not copied)");
return 0;
}
}
}
elsif (_eq($from, $to)) {
carp("'$from' and '$to' are identical (not copied)");
return 0;
}
if (defined &syscopy && !$Syscopy_is_copy
&& !$to_a_handle
&& !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles
&& !($from_a_handle && $^O eq 'MSWin32')
)
{
if ($^O eq 'VMS' && -e $from
&& ! -d $to && ! -d $from) {
# VMS natively inherits path components from the source of a
# copy, but we want the Unixy behavior of inheriting from
# the current working directory. Also, default in a trailing
# dot for null file types.
$to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.');
# Get rid of the old versions to be like UNIX
1 while unlink $to;
}
return syscopy($from, $to) || 0;
}
my $closefrom = 0;
my $closeto = 0;
my ($status, $r, $buf);
local($\) = '';
my $from_h;
if ($from_a_handle) {
$from_h = $from;
} else {
open $from_h, "<", $from or goto fail_open1;
binmode $from_h or die "($!,$^E)";
$closefrom = 1;
}
# Seems most logical to do this here, in case future changes would want to
# make this croak for some reason.
unless (defined $size) {
$size = tied(*$from_h) ? 0 : -s $from_h || 0;
$size = 1024 if ($size < 512);
$size = $Too_Big if ($size > $Too_Big);
}
my $to_h;
if ($to_a_handle) {
$to_h = $to;
} else {
$to_h = \do { local *FH }; # XXX is this line obsolete?
open $to_h, ">", $to or goto fail_open2;
binmode $to_h or die "($!,$^E)";
$closeto = 1;
}
$! = 0;
for (;;) {
my ($r, $w, $t);
defined($r = sysread($from_h, $buf, $size))
or goto fail_inner;
last unless $r;
for ($w = 0; $w < $r; $w += $t) {
$t = syswrite($to_h, $buf, $r - $w, $w)
or goto fail_inner;
}
}
close($to_h) || goto fail_open2 if $closeto;
close($from_h) || goto fail_open1 if $closefrom;
# Use this idiom to avoid uninitialized value warning.
return 1;
# All of these contortions try to preserve error messages...
fail_inner:
if ($closeto) {
$status = $!;
$! = 0;
close $to_h;
$! = $status unless $!;
}
fail_open2:
if ($closefrom) {
$status = $!;
$! = 0;
close $from_h;
$! = $status unless $!;
}
fail_open1:
return 0;
}
sub cp {
my($from,$to) = @_;
my(@fromstat) = stat $from;
my(@tostat) = stat $to;
my $perm;
return 0 unless copy(@_) and @fromstat;
if (@tostat) {
$perm = $tostat[2];
} else {
$perm = $fromstat[2] & ~(umask || 0);
@tostat = stat $to;
}
# Might be more robust to look for S_I* in Fcntl, but we're
# trying to avoid dependence on any XS-containing modules,
# since File::Copy is used during the Perl build.
$perm &= 07777;
if ($perm & 06000) {
croak("Unable to check setuid/setgid permissions for $to: $!")
unless @tostat;
if ($perm & 04000 and # setuid
$fromstat[4] != $tostat[4]) { # owner must match
$perm &= ~06000;
}
if ($perm & 02000 && $> != 0) { # if not root, setgid
my $ok = $fromstat[5] == $tostat[5]; # group must match
if ($ok) { # and we must be in group
$ok = grep { $_ == $fromstat[5] } split /\s+/, $)
}
$perm &= ~06000 unless $ok;
}
}
return 0 unless @tostat;
return 1 if $perm == ($tostat[2] & 07777);
return eval { chmod $perm, $to; } ? 1 : 0;
}
sub _move {
croak("Usage: move(FROM, TO) ") unless @_ == 3;
my($from,$to,$fallback) = @_;
my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
if (-d $to && ! -d $from) {
$to = _catname($from, $to);
}
($tosz1,$tomt1) = (stat($to))[7,9];
$fromsz = -s $from;
if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
# will not rename with overwrite
unlink $to;
}
if ($^O eq 'VMS' && -e $from
&& ! -d $to && ! -d $from) {
# VMS natively inherits path components from the source of a
# copy, but we want the Unixy behavior of inheriting from
# the current working directory. Also, default in a trailing
# dot for null file types.
$to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.');
# Get rid of the old versions to be like UNIX
1 while unlink $to;
}
return 1 if rename $from, $to;
# Did rename return an error even though it succeeded, because $to
# is on a remote NFS file system, and NFS lost the server's ack?
return 1 if defined($fromsz) && !-e $from && # $from disappeared
(($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
((!defined $tosz1) || # not before or
($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed
$tosz2 == $fromsz; # it's all there
($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
{
local $@;
eval {
local $SIG{__DIE__};
$fallback->($from,$to) or die;
my($atime, $mtime) = (stat($from))[8,9];
utime($atime, $mtime, $to);
unlink($from) or die;
};
return 1 unless $@;
}
($sts,$ossts) = ($! + 0, $^E + 0);
($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
($!,$^E) = ($sts,$ossts);
return 0;
}
sub move { _move(@_,\&copy); }
sub mv { _move(@_,\&cp); }
# &syscopy is an XSUB under OS/2
unless (defined &syscopy) {
if ($^O eq 'VMS') {
*syscopy = \&rmscopy;
} elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
# Win32::CopyFile() fill only work if we can load Win32.xs
*syscopy = sub {
return 0 unless @_ == 2;
return Win32::CopyFile(@_, 1);
};
} else {
$Syscopy_is_copy = 1;
*syscopy = \&copy;
}
}
1;
__END__
=head1 NAME
File::Copy - Copy files or filehandles
=head1 SYNOPSIS
use File::Copy;
copy("sourcefile", "destinationfile") or die "Copy failed: $!";
copy("Copy.pm", \*STDOUT);
move("/dev1/sourcefile", "/dev2/destinationfile");
use File::Copy "cp";
my $n = FileHandle->new("/a/file", "r");
cp($n, "x");
=head1 DESCRIPTION
The File::Copy module provides two basic functions, C<copy> and
C<move>, which are useful for getting the contents of a file from
one place to another.
=over 4
=item copy
X<copy> X<cp>
The C<copy> function takes two
parameters: a file to copy from and a file to copy to. Either
argument may be a string, a FileHandle reference or a FileHandle
glob. Obviously, if the first argument is a filehandle of some
sort, it will be read from, and if it is a file I<name> it will
be opened for reading. Likewise, the second argument will be
written to. If the second argument does not exist but the parent
directory does exist, then it will be created. Trying to copy
a file into a non-existent directory is an error.
Trying to copy a file on top of itself is also an error.
C<copy> will not overwrite read-only files.
If the destination (second argument) already exists and is a directory,
and the source (first argument) is not a filehandle, then the source
file will be copied into the directory specified by the destination,
using the same base name as the source file. It's a failure to have a
filehandle as the source when the destination is a directory.
B<Note that passing in
files as handles instead of names may lead to loss of information
on some operating systems; it is recommended that you use file
names whenever possible.> Files are opened in binary mode where
applicable. To get a consistent behaviour when copying from a
filehandle to a file, use C<binmode> on the filehandle.
An optional third parameter can be used to specify the buffer
size used for copying. This is the number of bytes from the
first file, that will be held in memory at any given time, before
being written to the second file. The default buffer size depends
upon the file, but will generally be the whole file (up to 2MB), or
1k for filehandles that do not reference files (eg. sockets).
You may use the syntax C<use File::Copy "cp"> to get at the C<cp>
alias for this function. The syntax is I<exactly> the same. The
behavior is nearly the same as well: as of version 2.15, C<cp> will
preserve the source file's permission bits like the shell utility
C<cp(1)> would do with default options, while C<copy> uses the default
permissions for the target file (which may depend on the process'
C<umask>, file ownership, inherited ACLs, etc.). That is, if the
destination file already exists, C<cp> will leave its permissions
unchanged; otherwise the permissions are taken from the source file
and modified by the C<umask>. If an error occurs in setting
permissions, C<cp> will return 0, regardless of whether the file was
successfully copied.
=item move
X<move> X<mv> X<rename>
The C<move> function also takes two parameters: the current name
and the intended name of the file to be moved. If the destination
already exists and is a directory, and the source is not a
directory, then the source file will be renamed into the directory
specified by the destination.
If possible, move() will simply rename the file. Otherwise, it copies
the file to the new location and deletes the original. If an error occurs
during this copy-and-delete process, you may be left with a (possibly partial)
copy of the file under the destination name.
You may use the C<mv> alias for this function in the same way that
you may use the C<cp> alias for C<copy>.
=item syscopy
X<syscopy>
File::Copy also provides the C<syscopy> routine, which copies the
file specified in the first parameter to the file specified in the
second parameter, preserving OS-specific attributes and file
structure. For Unix systems, this is equivalent to the simple
C<copy> routine, which doesn't preserve OS-specific attributes. For
VMS systems, this calls the C<rmscopy> routine (see below). For OS/2
systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
this calls C<Win32::CopyFile>.
B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
If both arguments to C<copy> are not file handles,
then C<copy> will perform a "system copy" of
the input file to a new output file, in order to preserve file
attributes, indexed file structure, I<etc.> The buffer size
parameter is ignored. If either argument to C<copy> is a
handle to an opened file, then data is copied using Perl
operators, and no effort is made to preserve file attributes
or record structure.
The system copy routine may also be called directly under VMS and OS/2
as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
is the routine that does the actual work for syscopy).
=item rmscopy($from,$to[,$date_flag])
X<rmscopy>
The first and second arguments may be strings, typeglobs, typeglob
references, or objects inheriting from IO::Handle;
they are used in all cases to obtain the
I<filespec> of the input and output files, respectively. The
name and type of the input file are used as defaults for the
output file, if necessary.
A new version of the output file is always created, which
inherits the structure and RMS attributes of the input file,
except for owner and protections (and possibly timestamps;
see below). All data from the input file is copied to the
output file; if either of the first two parameters to C<rmscopy>
is a file handle, its position is unchanged. (Note that this
means a file handle pointing to the output file will be
associated with an old version of that file after C<rmscopy>
returns, not the newly created version.)
The third parameter is an integer flag, which tells C<rmscopy>
how to handle timestamps. If it is E<lt> 0, none of the input file's
timestamps are propagated to the output file. If it is E<gt> 0, then
it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
timestamps other than the revision date are propagated; if bit 1
is set, the revision date is propagated. If the third parameter
to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
if the name or type of the output file was explicitly specified,
then no timestamps are propagated, but if they were taken implicitly
from the input filespec, then all timestamps other than the
revision date are propagated. If this parameter is not supplied,
it defaults to 0.
C<rmscopy> is VMS specific and cannot be exported; it must be
referenced by its full name, e.g.:
File::Copy::rmscopy($from, $to) or die $!;
Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs,
it sets C<$!>, deletes the output file, and returns 0.
=back
=head1 RETURN
All functions return 1 on success, 0 on failure.
$! will be set if an error was encountered.
=head1 NOTES
Before calling copy() or move() on a filehandle, the caller should
close or flush() the file to avoid writes being lost. Note that this
is the case even for move(), because it may actually copy the file,
depending on the OS-specific implementation, and the underlying
filesystem(s).
=head1 AUTHOR
File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
=cut

1738
gitportable/usr/share/perl5/core_perl/File/Fetch.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1123
gitportable/usr/share/perl5/core_perl/File/Find.pm Normal file
View File

File diff suppressed because it is too large Load Diff

679
gitportable/usr/share/perl5/core_perl/File/GlobMapper.pm Normal file
View File

@@ -0,0 +1,679 @@
package File::GlobMapper;
use strict;
use warnings;
use Carp;
our ($CSH_GLOB);
BEGIN
{
if ($] < 5.006)
{
require File::BSDGlob; import File::BSDGlob qw(:glob) ;
$CSH_GLOB = File::BSDGlob::GLOB_CSH() ;
*globber = \&File::BSDGlob::csh_glob;
}
else
{
require File::Glob; import File::Glob qw(:glob) ;
$CSH_GLOB = File::Glob::GLOB_CSH() ;
#*globber = \&File::Glob::bsd_glob;
*globber = \&File::Glob::csh_glob;
}
}
our ($Error);
our ($VERSION, @EXPORT_OK);
$VERSION = '1.001';
@EXPORT_OK = qw( globmap );
our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount);
$noPreBS = '(?<!\\\)' ; # no preceding backslash
$metachars = '.*?[](){}';
$matchMetaRE = '[' . quotemeta($metachars) . ']';
%mapping = (
'*' => '([^/]*)',
'?' => '([^/])',
'.' => '\.',
'[' => '([',
'(' => '(',
')' => ')',
);
%wildCount = map { $_ => 1 } qw/ * ? . { ( [ /;
sub globmap ($$;)
{
my $inputGlob = shift ;
my $outputGlob = shift ;
my $obj = File::GlobMapper->new($inputGlob, $outputGlob, @_)
or croak "globmap: $Error" ;
return $obj->getFileMap();
}
sub new
{
my $class = shift ;
my $inputGlob = shift ;
my $outputGlob = shift ;
# TODO -- flags needs to default to whatever File::Glob does
my $flags = shift || $CSH_GLOB ;
#my $flags = shift ;
$inputGlob =~ s/^\s*\<\s*//;
$inputGlob =~ s/\s*\>\s*$//;
$outputGlob =~ s/^\s*\<\s*//;
$outputGlob =~ s/\s*\>\s*$//;
my %object =
( InputGlob => $inputGlob,
OutputGlob => $outputGlob,
GlobFlags => $flags,
Braces => 0,
WildCount => 0,
Pairs => [],
Sigil => '#',
);
my $self = bless \%object, ref($class) || $class ;
$self->_parseInputGlob()
or return undef ;
$self->_parseOutputGlob()
or return undef ;
my @inputFiles = globber($self->{InputGlob}, $flags) ;
if (GLOB_ERROR)
{
$Error = $!;
return undef ;
}
#if (whatever)
{
my $missing = grep { ! -e $_ } @inputFiles ;
if ($missing)
{
$Error = "$missing input files do not exist";
return undef ;
}
}
$self->{InputFiles} = \@inputFiles ;
$self->_getFiles()
or return undef ;
return $self;
}
sub _retError
{
my $string = shift ;
$Error = "$string in input fileglob" ;
return undef ;
}
sub _unmatched
{
my $delimeter = shift ;
_retError("Unmatched $delimeter");
return undef ;
}
sub _parseBit
{
my $self = shift ;
my $string = shift ;
my $out = '';
my $depth = 0 ;
while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//)
{
$out .= quotemeta($1) ;
$out .= $mapping{$2} if defined $mapping{$2};
++ $self->{WildCount} if $wildCount{$2} ;
if ($2 eq ',')
{
return _unmatched("(")
if $depth ;
$out .= '|';
}
elsif ($2 eq '(')
{
++ $depth ;
}
elsif ($2 eq ')')
{
return _unmatched(")")
if ! $depth ;
-- $depth ;
}
elsif ($2 eq '[')
{
# TODO -- quotemeta & check no '/'
# TODO -- check for \] & other \ within the []
$string =~ s#(.*?\])##
or return _unmatched("[");
$out .= "$1)" ;
}
elsif ($2 eq ']')
{
return _unmatched("]");
}
elsif ($2 eq '{' || $2 eq '}')
{
return _retError("Nested {} not allowed");
}
}
$out .= quotemeta $string;
return _unmatched("(")
if $depth ;
return $out ;
}
sub _parseInputGlob
{
my $self = shift ;
my $string = $self->{InputGlob} ;
my $inGlob = '';
# Multiple concatenated *'s don't make sense
#$string =~ s#\*\*+#*# ;
# TODO -- Allow space to delimit patterns?
#my @strings = split /\s+/, $string ;
#for my $str (@strings)
my $out = '';
my $depth = 0 ;
while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//)
{
$out .= quotemeta($1) ;
$out .= $mapping{$2} if defined $mapping{$2};
++ $self->{WildCount} if $wildCount{$2} ;
if ($2 eq '(')
{
++ $depth ;
}
elsif ($2 eq ')')
{
return _unmatched(")")
if ! $depth ;
-- $depth ;
}
elsif ($2 eq '[')
{
# TODO -- quotemeta & check no '/' or '(' or ')'
# TODO -- check for \] & other \ within the []
$string =~ s#(.*?\])##
or return _unmatched("[");
$out .= "$1)" ;
}
elsif ($2 eq ']')
{
return _unmatched("]");
}
elsif ($2 eq '}')
{
return _unmatched("}");
}
elsif ($2 eq '{')
{
# TODO -- check no '/' within the {}
# TODO -- check for \} & other \ within the {}
my $tmp ;
unless ( $string =~ s/(.*?)$noPreBS\}//)
{
return _unmatched("{");
}
#$string =~ s#(.*?)\}##;
#my $alt = join '|',
# map { quotemeta $_ }
# split "$noPreBS,", $1 ;
my $alt = $self->_parseBit($1);
defined $alt or return 0 ;
$out .= "($alt)" ;
++ $self->{Braces} ;
}
}
return _unmatched("(")
if $depth ;
$out .= quotemeta $string ;
$self->{InputGlob} =~ s/$noPreBS[\(\)]//g;
$self->{InputPattern} = $out ;
#print "# INPUT '$self->{InputGlob}' => '$out'\n";
return 1 ;
}
sub _parseOutputGlob
{
my $self = shift ;
my $string = $self->{OutputGlob} ;
my $maxwild = $self->{WildCount};
if ($self->{GlobFlags} & GLOB_TILDE)
#if (1)
{
$string =~ s{
^ ~ # find a leading tilde
( # save this in $1
[^/] # a non-slash character
* # repeated 0 or more times (0 means me)
)
}{
$1
? (getpwnam($1))[7]
: ( $ENV{HOME} || $ENV{LOGDIR} )
}ex;
}
# max #1 must be == to max no of '*' in input
while ( $string =~ m/#(\d)/g )
{
croak "Max wild is #$maxwild, you tried #$1"
if $1 > $maxwild ;
}
my $noPreBS = '(?<!\\\)' ; # no preceding backslash
#warn "noPreBS = '$noPreBS'\n";
#$string =~ s/${noPreBS}\$(\d)/\${$1}/g;
$string =~ s/${noPreBS}#(\d)/\${$1}/g;
$string =~ s#${noPreBS}\*#\${inFile}#g;
$string = '"' . $string . '"';
#print "OUTPUT '$self->{OutputGlob}' => '$string'\n";
$self->{OutputPattern} = $string ;
return 1 ;
}
sub _getFiles
{
my $self = shift ;
my %outInMapping = ();
my %inFiles = () ;
foreach my $inFile (@{ $self->{InputFiles} })
{
next if $inFiles{$inFile} ++ ;
my $outFile = $inFile ;
if ( $inFile =~ m/$self->{InputPattern}/ )
{
no warnings 'uninitialized';
eval "\$outFile = $self->{OutputPattern};" ;
if (defined $outInMapping{$outFile})
{
$Error = "multiple input files map to one output file";
return undef ;
}
$outInMapping{$outFile} = $inFile;
push @{ $self->{Pairs} }, [$inFile, $outFile];
}
}
return 1 ;
}
sub getFileMap
{
my $self = shift ;
return $self->{Pairs} ;
}
sub getHash
{
my $self = shift ;
return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ;
}
1;
__END__
=head1 NAME
File::GlobMapper - Extend File Glob to Allow Input and Output Files
=head1 SYNOPSIS
use File::GlobMapper qw( globmap );
my $aref = globmap $input => $output
or die $File::GlobMapper::Error ;
my $gm = File::GlobMapper->new( $input => $output )
or die $File::GlobMapper::Error ;
=head1 DESCRIPTION
This module needs Perl5.005 or better.
This module takes the existing C<File::Glob> module as a starting point and
extends it to allow new filenames to be derived from the files matched by
C<File::Glob>.
This can be useful when carrying out batch operations on multiple files that
have both an input filename and output filename and the output file can be
derived from the input filename. Examples of operations where this can be
useful include, file renaming, file copying and file compression.
=head2 Behind The Scenes
To help explain what C<File::GlobMapper> does, consider what code you
would write if you wanted to rename all files in the current directory
that ended in C<.tar.gz> to C<.tgz>. So say these files are in the
current directory
alpha.tar.gz
beta.tar.gz
gamma.tar.gz
and they need renamed to this
alpha.tgz
beta.tgz
gamma.tgz
Below is a possible implementation of a script to carry out the rename
(error cases have been omitted)
foreach my $old ( glob "*.tar.gz" )
{
my $new = $old;
$new =~ s#(.*)\.tar\.gz$#$1.tgz# ;
rename $old => $new
or die "Cannot rename '$old' to '$new': $!\n;
}
Notice that a file glob pattern C<*.tar.gz> was used to match the
C<.tar.gz> files, then a fairly similar regular expression was used in
the substitute to allow the new filename to be created.
Given that the file glob is just a cut-down regular expression and that it
has already done a lot of the hard work in pattern matching the filenames,
wouldn't it be handy to be able to use the patterns in the fileglob to
drive the new filename?
Well, that's I<exactly> what C<File::GlobMapper> does.
Here is same snippet of code rewritten using C<globmap>
for my $pair (globmap '<*.tar.gz>' => '<#1.tgz>' )
{
my ($from, $to) = @$pair;
rename $from => $to
or die "Cannot rename '$old' to '$new': $!\n;
}
So how does it work?
Behind the scenes the C<globmap> function does a combination of a
file glob to match existing filenames followed by a substitute
to create the new filenames.
Notice how both parameters to C<globmap> are strings that are delimited by <>.
This is done to make them look more like file globs - it is just syntactic
sugar, but it can be handy when you want the strings to be visually
distinctive. The enclosing <> are optional, so you don't have to use them - in
fact the first thing globmap will do is remove these delimiters if they are
present.
The first parameter to C<globmap>, C<*.tar.gz>, is an I<Input File Glob>.
Once the enclosing "< ... >" is removed, this is passed (more or
less) unchanged to C<File::Glob> to carry out a file match.
Next the fileglob C<*.tar.gz> is transformed behind the scenes into a
full Perl regular expression, with the additional step of wrapping each
transformed wildcard metacharacter sequence in parenthesis.
In this case the input fileglob C<*.tar.gz> will be transformed into
this Perl regular expression
([^/]*)\.tar\.gz
Wrapping with parenthesis allows the wildcard parts of the Input File
Glob to be referenced by the second parameter to C<globmap>, C<#1.tgz>,
the I<Output File Glob>. This parameter operates just like the replacement
part of a substitute command. The difference is that the C<#1> syntax
is used to reference sub-patterns matched in the input fileglob, rather
than the C<$1> syntax that is used with perl regular expressions. In
this case C<#1> is used to refer to the text matched by the C<*> in the
Input File Glob. This makes it easier to use this module where the
parameters to C<globmap> are typed at the command line.
The final step involves passing each filename matched by the C<*.tar.gz>
file glob through the derived Perl regular expression in turn and
expanding the output fileglob using it.
The end result of all this is a list of pairs of filenames. By default
that is what is returned by C<globmap>. In this example the data structure
returned will look like this
( ['alpha.tar.gz' => 'alpha.tgz'],
['beta.tar.gz' => 'beta.tgz' ],
['gamma.tar.gz' => 'gamma.tgz']
)
Each pair is an array reference with two elements - namely the I<from>
filename, that C<File::Glob> has matched, and a I<to> filename that is
derived from the I<from> filename.
=head2 Limitations
C<File::GlobMapper> has been kept simple deliberately, so it isn't intended to
solve all filename mapping operations. Under the hood C<File::Glob> (or for
older versions of Perl, C<File::BSDGlob>) is used to match the files, so you
will never have the flexibility of full Perl regular expression.
=head2 Input File Glob
The syntax for an Input FileGlob is identical to C<File::Glob>, except
for the following
=over 5
=item 1.
No nested {}
=item 2.
Whitespace does not delimit fileglobs.
=item 3.
The use of parenthesis can be used to capture parts of the input filename.
=item 4.
If an Input glob matches the same file more than once, only the first
will be used.
=back
The syntax
=over 5
=item B<~>
=item B<~user>
=item B<.>
Matches a literal '.'.
Equivalent to the Perl regular expression
\.
=item B<*>
Matches zero or more characters, except '/'. Equivalent to the Perl
regular expression
[^/]*
=item B<?>
Matches zero or one character, except '/'. Equivalent to the Perl
regular expression
[^/]?
=item B<\>
Backslash is used, as usual, to escape the next character.
=item B<[]>
Character class.
=item B<{,}>
Alternation
=item B<()>
Capturing parenthesis that work just like perl
=back
Any other character it taken literally.
=head2 Output File Glob
The Output File Glob is a normal string, with 2 glob-like features.
The first is the '*' metacharacter. This will be replaced by the complete
filename matched by the input file glob. So
*.c *.Z
The second is
Output FileGlobs take the
=over 5
=item "*"
The "*" character will be replaced with the complete input filename.
=item #1
Patterns of the form /#\d/ will be replaced with the
=back
=head2 Returned Data
=head1 EXAMPLES
=head2 A Rename script
Below is a simple "rename" script that uses C<globmap> to determine the
source and destination filenames.
use File::GlobMapper qw(globmap) ;
use File::Copy;
die "rename: Usage rename 'from' 'to'\n"
unless @ARGV == 2 ;
my $fromGlob = shift @ARGV;
my $toGlob = shift @ARGV;
my $pairs = globmap($fromGlob, $toGlob)
or die $File::GlobMapper::Error;
for my $pair (@$pairs)
{
my ($from, $to) = @$pair;
move $from => $to ;
}
Here is an example that renames all c files to cpp.
$ rename '*.c' '#1.cpp'
=head2 A few example globmaps
Below are a few examples of globmaps
To copy all your .c file to a backup directory
'</my/home/*.c>' '</my/backup/#1.c>'
If you want to compress all
'</my/home/*.[ch]>' '<*.gz>'
To uncompress
'</my/home/*.[ch].gz>' '</my/home/#1.#2>'
=head1 SEE ALSO
L<File::Glob|File::Glob>
=head1 AUTHOR
The I<File::GlobMapper> module was written by Paul Marquess, F<pmqs@cpan.org>.
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2005 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

1287
gitportable/usr/share/perl5/core_perl/File/Path.pm Normal file
View File

File diff suppressed because it is too large Load Diff

3721
gitportable/usr/share/perl5/core_perl/File/Temp.pm Normal file
View File

File diff suppressed because it is too large Load Diff

363
gitportable/usr/share/perl5/core_perl/File/stat.pm Normal file
View File

@@ -0,0 +1,363 @@
package File::stat;
use 5.006;
use strict;
use warnings;
use warnings::register;
use Carp;
use constant _IS_CYGWIN => $^O eq "cygwin";
BEGIN { *warnif = \&warnings::warnif }
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
our $VERSION = '1.13';
our @fields;
our ( $st_dev, $st_ino, $st_mode,
$st_nlink, $st_uid, $st_gid,
$st_rdev, $st_size,
$st_atime, $st_mtime, $st_ctime,
$st_blksize, $st_blocks
);
BEGIN {
use Exporter ();
@EXPORT = qw(stat lstat);
@fields = qw( $st_dev $st_ino $st_mode
$st_nlink $st_uid $st_gid
$st_rdev $st_size
$st_atime $st_mtime $st_ctime
$st_blksize $st_blocks
);
@EXPORT_OK = ( @fields, "stat_cando" );
%EXPORT_TAGS = ( FIELDS => [ @fields, @EXPORT ] );
}
use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR);
BEGIN {
# These constants will croak on use if the platform doesn't define
# them. It's important to avoid inflicting that on the user.
no strict 'refs';
for (qw(suid sgid svtx)) {
my $val = eval { &{"Fcntl::S_I\U$_"} };
*{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" };
}
for (qw(SOCK CHR BLK REG DIR LNK)) {
*{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} }
? \&{"Fcntl::S_IS$_"} : sub { "" };
}
# FIFO flag and macro don't quite follow the S_IF/S_IS pattern above
# RT #111638
*{"S_ISFIFO"} = defined &Fcntl::S_IFIFO
? \&Fcntl::S_ISFIFO : sub { "" };
}
# from doio.c
sub _ingroup {
my ($gid, $eff) = @_;
# I am assuming that since VMS doesn't have getgroups(2), $) will
# always only contain a single entry.
$^O eq "VMS" and return $_[0] == $);
my ($egid, @supp) = split " ", $);
my ($rgid) = split " ", $(;
$gid == ($eff ? $egid : $rgid) and return 1;
grep $gid == $_, @supp and return 1;
return "";
}
# VMS uses the Unix version of the routine, even though this is very
# suboptimal. VMS has a permissions structure that doesn't really fit
# into struct stat, and unlike on Win32 the normal -X operators respect
# that, but unfortunately by the time we get here we've already lost the
# information we need. It looks to me as though if we were to preserve
# the st_devnam entry of vmsish.h's fake struct stat (which actually
# holds the filename) it might be possible to do this right, but both
# getting that value out of the struct (perl's stat doesn't return it)
# and interpreting it later would require this module to have an XS
# component (at which point we might as well just call Perl_cando and
# have done with it).
if (grep $^O eq $_, qw/os2 MSWin32/) {
# from doio.c
*cando = sub { ($_[0][2] & $_[1]) ? 1 : "" };
}
else {
# from doio.c
*cando = sub {
my ($s, $mode, $eff) = @_;
my $uid = $eff ? $> : $<;
my ($stmode, $stuid, $stgid) = @$s[2,4,5];
# This code basically assumes that the rwx bits of the mode are
# the 0777 bits, but so does Perl_cando.
if (_IS_CYGWIN ? _ingroup(544, $eff) : ($uid == 0 && $^O ne "VMS")) {
# If we're root on unix
# not testing for executable status => all file tests are true
return 1 if !($mode & 0111);
# testing for executable status =>
# for a file, any x bit will do
# for a directory, always true
return 1 if $stmode & 0111 || S_ISDIR($stmode);
return "";
}
if ($stuid == $uid) {
$stmode & $mode and return 1;
}
elsif (_ingroup($stgid, $eff)) {
$stmode & ($mode >> 3) and return 1;
}
else {
$stmode & ($mode >> 6) and return 1;
}
return "";
};
}
# alias for those who don't like objects
*stat_cando = \&cando;
my %op = (
r => sub { cando($_[0], S_IRUSR, 1) },
w => sub { cando($_[0], S_IWUSR, 1) },
x => sub { cando($_[0], S_IXUSR, 1) },
o => sub { $_[0][4] == $> },
R => sub { cando($_[0], S_IRUSR, 0) },
W => sub { cando($_[0], S_IWUSR, 0) },
X => sub { cando($_[0], S_IXUSR, 0) },
O => sub { $_[0][4] == $< },
e => sub { 1 },
z => sub { $_[0][7] == 0 },
s => sub { $_[0][7] },
f => sub { S_ISREG ($_[0][2]) },
d => sub { S_ISDIR ($_[0][2]) },
l => sub { S_ISLNK ($_[0][2]) },
p => sub { S_ISFIFO($_[0][2]) },
S => sub { S_ISSOCK($_[0][2]) },
b => sub { S_ISBLK ($_[0][2]) },
c => sub { S_ISCHR ($_[0][2]) },
u => sub { _suid($_[0][2]) },
g => sub { _sgid($_[0][2]) },
k => sub { _svtx($_[0][2]) },
M => sub { ($^T - $_[0][9] ) / 86400 },
C => sub { ($^T - $_[0][10]) / 86400 },
A => sub { ($^T - $_[0][8] ) / 86400 },
);
use constant HINT_FILETEST_ACCESS => 0x00400000;
# we need fallback=>1 or stringifying breaks
use overload
fallback => 1,
-X => sub {
my ($s, $op) = @_;
if (index("rwxRWX", $op) >= 0) {
(caller 0)[8] & HINT_FILETEST_ACCESS
and warnif("File::stat ignores use filetest 'access'");
$^O eq "VMS" and warnif("File::stat ignores VMS ACLs");
# It would be nice to have a warning about using -l on a
# non-lstat, but that would require an extra member in the
# object.
}
if ($op{$op}) {
return $op{$op}->($_[0]);
}
else {
croak "-$op is not implemented on a File::stat object";
}
};
# Class::Struct forbids use of @ISA
sub import { goto &Exporter::import }
use Class::Struct qw(struct);
struct 'File::stat' => [
map { $_ => '$' } qw{
dev ino mode nlink uid gid rdev size
atime mtime ctime blksize blocks
}
];
sub populate (@) {
return unless @_;
my $stob = new();
@$stob = (
$st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
$st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks )
= @_;
return $stob;
}
sub lstat ($) { populate(CORE::lstat(shift)) }
sub stat ($) {
my $arg = shift;
my $st = populate(CORE::stat $arg);
return $st if defined $st;
my $fh;
{
local $!;
no strict 'refs';
require Symbol;
$fh = \*{ Symbol::qualify( $arg, caller() )};
return unless defined fileno $fh;
}
return populate(CORE::stat $fh);
}
1;
__END__
=head1 NAME
File::stat - by-name interface to Perl's built-in stat() functions
=head1 SYNOPSIS
use File::stat;
my $st = stat($file) or die "No $file: $!";
if ( ($st->mode & 0111) && ($st->nlink > 1) ) {
print "$file is executable with lotsa links\n";
}
if ( -x $st ) {
print "$file is executable\n";
}
use Fcntl "S_IRUSR";
if ( $st->cando(S_IRUSR, 1) ) {
print "My effective uid can read $file\n";
}
use File::stat qw(:FIELDS);
stat($file) or die "No $file: $!";
if ( ($st_mode & 0111) && ($st_nlink > 1) ) {
print "$file is executable with lotsa links\n";
}
=head1 DESCRIPTION
This module's default exports override the core stat()
and lstat() functions, replacing them with versions that return
"File::stat" objects. This object has methods that
return the similarly named structure field name from the
stat(2) function; namely,
dev,
ino,
mode,
nlink,
uid,
gid,
rdev,
size,
atime,
mtime,
ctime,
blksize,
and
blocks.
As of version 1.02 (provided with perl 5.12) the object provides C<"-X">
overloading, so you can call filetest operators (C<-f>, C<-x>, and so
on) on it. It also provides a C<< ->cando >> method, called like
$st->cando( ACCESS, EFFECTIVE )
where I<ACCESS> is one of C<S_IRUSR>, C<S_IWUSR> or C<S_IXUSR> from the
L<Fcntl|Fcntl> module, and I<EFFECTIVE> indicates whether to use
effective (true) or real (false) ids. The method interprets the C<mode>,
C<uid> and C<gid> fields, and returns whether or not the current process
would be allowed the specified access.
If you don't want to use the objects, you may import the C<< ->cando >>
method into your namespace as a regular function called C<stat_cando>.
This takes an arrayref containing the return values of C<stat> or
C<lstat> as its first argument, and interprets it for you.
You may also import all the structure fields directly into your namespace
as regular variables using the :FIELDS import tag. (Note that this still
overrides your stat() and lstat() functions.) Access these fields as
variables named with a preceding C<st_> in front their method names.
Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
the fields.
To access this functionality without the core overrides,
pass the C<use> an empty import list, and then access
function functions with their full qualified names.
On the other hand, the built-ins are still available
via the C<CORE::> pseudo-package.
=head1 BUGS
As of Perl 5.8.0 after using this module you cannot use the implicit
C<$_> or the special filehandle C<_> with stat() or lstat(), trying
to do so leads into strange errors. The workaround is for C<$_> to
be explicit
my $stat_obj = stat $_;
and for C<_> to explicitly populate the object using the unexported
and undocumented populate() function with CORE::stat():
my $stat_obj = File::stat::populate(CORE::stat(_));
=head1 ERRORS
=over 4
=item -%s is not implemented on a File::stat object
The filetest operators C<-t>, C<-T> and C<-B> are not implemented, as
they require more information than just a stat buffer.
=back
=head1 WARNINGS
These can all be disabled with
no warnings "File::stat";
=over 4
=item File::stat ignores use filetest 'access'
You have tried to use one of the C<-rwxRWX> filetests with C<use
filetest 'access'> in effect. C<File::stat> will ignore the pragma, and
just use the information in the C<mode> member as usual.
=item File::stat ignores VMS ACLs
VMS systems have a permissions structure that cannot be completely
represented in a stat buffer, and unlike on other systems the builtin
filetest operators respect this. The C<File::stat> overloads, however,
do not, since the information required is not available.
=back
=head1 NOTE
While this class is currently implemented using the Class::Struct
module to build a struct-like class, you shouldn't rely upon this.
=head1 AUTHOR
Tom Christiansen

188
gitportable/usr/share/perl5/core_perl/FileCache.pm Normal file
View File

@@ -0,0 +1,188 @@
package FileCache;
our $VERSION = '1.10';
=head1 NAME
FileCache - keep more files open than the system permits
=head1 SYNOPSIS
no strict 'refs';
use FileCache;
# or
use FileCache maxopen => 16;
cacheout $mode, $path;
# or
cacheout $path;
print $path @data;
$fh = cacheout $mode, $path;
# or
$fh = cacheout $path;
print $fh @data;
=head1 DESCRIPTION
The C<cacheout> function will make sure that there's a filehandle open
for reading or writing available as the pathname you give it. It
automatically closes and re-opens files if you exceed your system's
maximum number of file descriptors, or the suggested maximum I<maxopen>.
=over
=item cacheout EXPR
The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
on it's first use, and appending (C<<< '>>' >>>) thereafter.
Returns EXPR on success for convenience. You may neglect the
return value and manipulate EXPR as the filehandle directly if you prefer.
=item cacheout MODE, EXPR
The 2-argument form of cacheout will use the supplied mode for the initial
and subsequent openings. Most valid modes for 3-argument C<open> are supported
namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
C< '|-' > and C< '-|' >
To pass supplemental arguments to a program opened with C< '|-' > or C< '-|' >
append them to the command string as you would system EXPR.
Returns EXPR on success for convenience. You may neglect the
return value and manipulate EXPR as the filehandle directly if you prefer.
=back
=head1 CAVEATS
While it is permissible to C<close> a FileCache managed file,
do not do so if you are calling C<FileCache::cacheout> from a package other
than which it was imported, or with another module which overrides C<close>.
If you must, use C<FileCache::cacheout_close>.
Although FileCache can be used with piped opens ('-|' or '|-') doing so is
strongly discouraged. If FileCache finds it necessary to close and then reopen
a pipe, the command at the far end of the pipe will be reexecuted - the results
of performing IO on FileCache'd pipes is unlikely to be what you expect. The
ability to use FileCache on pipes may be removed in a future release.
FileCache does not store the current file offset if it finds it necessary to
close a file. When the file is reopened, the offset will be as specified by the
original C<open> file mode. This could be construed to be a bug.
The module functionality relies on symbolic references, so things will break
under 'use strict' unless 'no strict "refs"' is also specified.
=head1 BUGS
F<sys/param.h> lies with its C<NOFILE> define on some systems,
so you may have to set I<maxopen> yourself.
=cut
require 5.006;
use Carp;
use strict;
no strict 'refs';
# These are not C<my> for legacy reasons.
# Previous versions requested the user set $cacheout_maxopen by hand.
# Some authors fiddled with %saw to overcome the clobber on initial open.
our %saw;
our $cacheout_maxopen = 16;
use parent 'Exporter';
our @EXPORT = qw[cacheout cacheout_close];
my %isopen;
my $cacheout_seq = 0;
sub import {
my ($pkg,%args) = @_;
# Use Exporter. %args are for us, not Exporter.
# Make sure to up export_to_level, or we will import into ourselves,
# rather than our calling package;
__PACKAGE__->export_to_level(1);
Exporter::import( $pkg );
# Truth is okay here because setting maxopen to 0 would be bad
return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
# XXX This code is crazy. Why is it a one element foreach loop?
# Why is it using $param both as a filename and filehandle?
foreach my $param ( '/usr/include/sys/param.h' ){
if (open($param, '<', $param)) {
local ($_, $.);
while (<$param>) {
if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
$cacheout_maxopen = $1 - 4;
close($param);
last;
}
}
close $param;
}
}
$cacheout_maxopen ||= 16;
}
# Open in their package.
sub cacheout_open {
return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
}
# Close in their package.
sub cacheout_close {
# Short-circuit in case the filehandle disappeared
my $pkg = caller($_[1]||0);
defined fileno(*{$pkg . '::' . $_[0]}) &&
CORE::close(*{$pkg . '::' . $_[0]});
delete $isopen{$_[0]};
}
# But only this sub name is visible to them.
sub cacheout {
my($mode, $file, $class, $ret, $ref, $narg);
croak "Not enough arguments for cacheout" unless $narg = scalar @_;
croak "Too many arguments for cacheout" if $narg > 2;
($mode, $file) = @_;
($file, $mode) = ($mode, $file) if $narg == 1;
croak "Invalid mode for cacheout" if $mode &&
( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
# Mode changed?
if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[1] ){
&cacheout_close($file, 1);
}
if( $isopen{$file}) {
$ret = $file;
$isopen{$file}->[0]++;
}
else{
if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
$cacheout_seq = 0;
$isopen{$_}->[0] = $cacheout_seq++ for
splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
&cacheout_close($_, 1) for @lru;
}
unless( $ref ){
$mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
}
#XXX should we just return the value from cacheout_open, no croak?
$ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
$isopen{$file} = [++$cacheout_seq, $mode];
}
return $ret;
}
1;

262
gitportable/usr/share/perl5/core_perl/FileHandle.pm Normal file
View File

@@ -0,0 +1,262 @@
package FileHandle;
use 5.006;
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
$VERSION = "2.05";
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__
=head1 NAME
FileHandle - supply object methods for filehandles
=head1 SYNOPSIS
use FileHandle;
my $fh = FileHandle->new;
if ($fh->open("< file")) {
print <$fh>;
$fh->close;
}
my $fh = FileHandle->new("> FOO");
if (defined $fh) {
print $fh "bar\n";
$fh->close;
}
my $fh = FileHandle->new("file", "r");
if (defined $fh) {
print <$fh>;
undef $fh; # automatically closes the file
}
my $fh = FileHandle->new("file", O_WRONLY|O_APPEND);
if (defined $fh) {
print $fh "corge\n";
undef $fh; # automatically closes the file
}
my $pos = $fh->getpos;
$fh->setpos($pos);
$fh->setvbuf(my $buffer_var, _IOLBF, 1024);
my ($readfh, $writefh) = FileHandle::pipe;
autoflush STDOUT 1;
=head1 DESCRIPTION
NOTE: This class is now a front-end to the IO::* classes.
C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
newly created symbol (see the L<Symbol> package). If it receives any
parameters, they are passed to C<FileHandle::open>; if the open fails,
the C<FileHandle> object is destroyed. Otherwise, it is returned to
the caller.
C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
It requires two parameters, which are passed to C<FileHandle::fdopen>;
if the fdopen fails, the C<FileHandle> object is destroyed.
Otherwise, it is returned to the caller.
C<FileHandle::open> accepts one parameter or two. With one parameter,
it is just a front end for the built-in C<open> function. With two
parameters, the first parameter is a filename that may include
whitespace or other special characters, and the second parameter is
the open mode, optionally followed by a file permission value.
If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.)
or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
Perl C<open> operator.
If C<FileHandle::open> is given a numeric mode, it passes that mode
and the optional permissions value to the Perl C<sysopen> operator.
For convenience, C<FileHandle::import> tries to import the O_XXX
constants from the Fcntl module. If dynamic loading is not available,
this may fail, but the rest of FileHandle will still work.
C<FileHandle::fdopen> is like C<open> except that its first parameter
is not a filename but rather a file handle name, a FileHandle object,
or a file descriptor number.
If the C functions fgetpos() and fsetpos() are available, then
C<FileHandle::getpos> returns an opaque value that represents the
current position of the FileHandle, and C<FileHandle::setpos> uses
that value to return to a previously visited position.
If the C function setvbuf() is available, then C<FileHandle::setvbuf>
sets the buffering policy for the FileHandle. The calling sequence
for the Perl function is the same as its C counterpart, including the
macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
parameter specifies a scalar variable to use as a buffer. WARNING: A
variable used as a buffer by C<FileHandle::setvbuf> must not be
modified in any way until the FileHandle is closed or until
C<FileHandle::setvbuf> is called again, or memory corruption may
result!
See L<perlfunc> for complete descriptions of each of the following
supported C<FileHandle> methods, which are just front ends for the
corresponding built-in functions:
close
fileno
getc
gets
eof
clearerr
seek
tell
See L<perlvar> for complete descriptions of each of the following
supported C<FileHandle> methods:
autoflush
output_field_separator
output_record_separator
input_record_separator
input_line_number
format_page_number
format_lines_per_page
format_lines_left
format_name
format_top_name
format_line_break_characters
format_formfeed
Furthermore, for doing normal I/O you might need these:
=over 4
=item $fh->print
See L<perlfunc/print>.
=item $fh->printf
See L<perlfunc/printf>.
=item $fh->getline
This works like <$fh> described in L<perlop/"I/O Operators">
except that it's more readable and can be safely called in a
list context but still returns just one line.
=item $fh->getlines
This works like <$fh> when called in a list context to
read all the remaining lines in a file, except that it's more readable.
It will also croak() if accidentally called in a scalar context.
=back
There are many other functions available since FileHandle is descended
from IO::File, IO::Seekable, and IO::Handle. Please see those
respective pages for documentation on more functions.
=head1 SEE ALSO
The B<IO> extension,
L<perlfunc>,
L<perlop/"I/O Operators">.
=cut

805
gitportable/usr/share/perl5/core_perl/Filter/Simple.pm Normal file
View File

@@ -0,0 +1,805 @@
package Filter::Simple;
use Text::Balanced ':ALL';
our $VERSION = '0.96';
use Filter::Util::Call;
use Carp;
our @EXPORT = qw( FILTER FILTER_ONLY );
sub import {
if (@_>1) { shift; goto &FILTER }
else { *{caller()."::$_"} = \&$_ foreach @EXPORT }
}
sub fail {
croak "FILTER_ONLY: ", @_;
}
my $exql = sub {
my @bits = extract_quotelike $_[0], qr//;
return unless $bits[0];
return \@bits;
};
my $ncws = qr/\s+/;
my $comment = qr/(?<![\$\@%])#.*/;
my $ws = qr/(?:$ncws|$comment)+/;
my $id = qr/\b(?!([ysm]|q[rqxw]?|tr)\b)\w+/;
my $EOP = qr/\n\n|\Z/;
my $CUT = qr/\n=cut.*$EOP/;
my $pod_or_DATA = qr/
^=(?:head[1-4]|item) .*? $CUT
| ^=pod .*? $CUT
| ^=for .*? $CUT
| ^=begin .*? $CUT
| ^__(DATA|END)__\r?\n.*
/smx;
my $variable = qr{
[\$*\@%]\s*
\{\s*(?!::)(?:\d+|[][&`'#+*./|,";%=~:?!\@<>()-]|\^[A-Z]?)\}
| (?:\$#?|[*\@\%]|\\&)\$*\s*
(?: \{\s*(?:\^(?=[A-Z_]))?(?:\w|::|'\w)*\s*\}
| (?:\^(?=[A-Z_]))?(?:\w|::|'\w)*
| (?=\{) # ${ block }
)
)
| \$\s*(?!::)(?:\d+|[][&`'#+*./|,";%=~:?!\@<>()-]|\^[A-Z]?)
}x;
my %extractor_for = (
quotelike => [ $ws, $variable, $id, { MATCH => \&extract_quotelike } ],
regex => [ $ws, $pod_or_DATA, $id, $exql ],
string => [ $ws, $pod_or_DATA, $id, $exql ],
code => [ $ws, { DONT_MATCH => $pod_or_DATA }, $variable,
$id, { DONT_MATCH => \&extract_quotelike } ],
code_no_comments
=> [ { DONT_MATCH => $comment },
$ncws, { DONT_MATCH => $pod_or_DATA }, $variable,
$id, { DONT_MATCH => \&extract_quotelike } ],
executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ],
executable_no_comments
=> [ { DONT_MATCH => $comment },
$ncws, { DONT_MATCH => $pod_or_DATA } ],
all => [ { MATCH => qr/(?s:.*)/ } ],
);
my %selector_for = (
all => sub { my ($t)=@_; sub{ $_=$$_; $t->(@_); $_} },
executable=> sub { my ($t)=@_; sub{ref() ? $_=$$_ : $t->(@_); $_} },
executable_no_comments=> sub { my ($t)=@_; sub{ref() ? $_=$$_ : $t->(@_); $_} },
quotelike => sub { my ($t)=@_; sub{ref() && do{$_=$$_; $t->(@_)}; $_} },
regex => sub { my ($t)=@_;
sub{ref() or return $_;
my ($ql,undef,$pre,$op,$ld,$pat) = @$_;
return $_->[0] unless $op =~ /^(qr|m|s)/
|| !$op && ($ld eq '/' || $ld eq '?');
$_ = $pat;
$t->(@_);
$ql =~ s/^(\s*\Q$op\E\s*\Q$ld\E)\Q$pat\E/$1$_/;
return "$pre$ql";
};
},
string => sub { my ($t)=@_;
sub{ref() or return $_;
local *args = \@_;
my ($pre,$op,$ld1,$str1,$rd1,$ld2,$str2,$rd2,$flg) = @{$_}[2..10];
return $_->[0] if $op =~ /^(qr|m)/
|| !$op && ($ld1 eq '/' || $ld1 eq '?');
if (!$op || $op eq 'tr' || $op eq 'y') {
local *_ = \$str1;
$t->(@args);
}
if ($op =~ /^(tr|y|s)/) {
local *_ = \$str2;
$t->(@args);
}
my $result = "$pre$op$ld1$str1$rd1";
$result .= $ld2 if $ld1 =~ m/[[({<]/; #])}>
$result .= "$str2$rd2$flg";
return $result;
};
},
);
sub gen_std_filter_for {
my ($type, $transform) = @_;
return sub {
my $instr;
local @components;
for (extract_multiple($_,$extractor_for{$type})) {
if (ref()) { push @components, $_; $instr=0 }
elsif ($instr) { $components[-1] .= $_ }
else { push @components, $_; $instr=1 }
}
if ($type =~ /^code/) {
my $count = 0;
local $placeholder = qr/\Q$;\E(.{4})\Q$;\E/s;
my $extractor = qr/\Q$;\E(.{4})\Q$;\E/s;
$_ = join "",
map { ref $_ ? $;.pack('N',$count++).$; : $_ }
@components;
@components = grep { ref $_ } @components;
$transform->(@_);
s/$extractor/${$components[unpack('N',$1)]}/g;
}
else {
my $selector = $selector_for{$type}->($transform);
$_ = join "", map $selector->(@_), @components;
}
}
};
sub FILTER (&;$) {
my $caller = caller;
my ($filter, $terminator) = @_;
no warnings 'redefine';
*{"${caller}::import"} = gen_filter_import($caller,$filter,$terminator);
*{"${caller}::unimport"} = gen_filter_unimport($caller);
}
sub FILTER_ONLY {
my $caller = caller;
while (@_ > 1) {
my ($what, $how) = splice(@_, 0, 2);
fail "Unknown selector: $what"
unless exists $extractor_for{$what};
fail "Filter for $what is not a subroutine reference"
unless ref $how eq 'CODE';
push @transforms, gen_std_filter_for($what,$how);
}
my $terminator = shift;
my $multitransform = sub {
foreach my $transform ( @transforms ) {
$transform->(@_);
}
};
no warnings 'redefine';
*{"${caller}::import"} =
gen_filter_import($caller,$multitransform,$terminator);
*{"${caller}::unimport"} = gen_filter_unimport($caller);
}
my $ows = qr/(?:[ \t]+|#[^\n]*)*/;
sub gen_filter_import {
my ($class, $filter, $terminator) = @_;
my %terminator;
my $prev_import = *{$class."::import"}{CODE};
return sub {
my ($imported_class, @args) = @_;
my $def_terminator =
qr/^(?:\s*no\s+$imported_class\s*;$ows|__(?:END|DATA)__)\r?$/;
if (!defined $terminator) {
$terminator{terminator} = $def_terminator;
}
elsif (!ref $terminator || ref $terminator eq 'Regexp') {
$terminator{terminator} = $terminator;
}
elsif (ref $terminator ne 'HASH') {
croak "Terminator must be specified as scalar or hash ref"
}
elsif (!exists $terminator->{terminator}) {
$terminator{terminator} = $def_terminator;
}
filter_add(
sub {
my ($status, $lastline);
my $count = 0;
my $data = "";
while ($status = filter_read()) {
return $status if $status < 0;
if ($terminator{terminator} &&
m/$terminator{terminator}/) {
$lastline = $_;
$count++;
last;
}
$data .= $_;
$count++;
$_ = "";
}
return $count if not $count;
$_ = $data;
$filter->($imported_class, @args) unless $status < 0;
if (defined $lastline) {
if (defined $terminator{becomes}) {
$_ .= $terminator{becomes};
}
elsif ($lastline =~ $def_terminator) {
$_ .= $lastline;
}
}
return $count;
}
);
if ($prev_import) {
goto &$prev_import;
}
elsif ($class->isa('Exporter')) {
$class->export_to_level(1,@_);
}
}
}
sub gen_filter_unimport {
my ($class) = @_;
return sub {
filter_del();
goto &$prev_unimport if $prev_unimport;
}
}
1;
__END__
=head1 NAME
Filter::Simple - Simplified source filtering
=head1 SYNOPSIS
# in MyFilter.pm:
package MyFilter;
use Filter::Simple;
FILTER { ... };
# or just:
#
# use Filter::Simple sub { ... };
# in user's code:
use MyFilter;
# this code is filtered
no MyFilter;
# this code is not
=head1 DESCRIPTION
=head2 The Problem
Source filtering is an immensely powerful feature of recent versions of Perl.
It allows one to extend the language itself (e.g. the Switch module), to
simplify the language (e.g. Language::Pythonesque), or to completely recast the
language (e.g. Lingua::Romana::Perligata). Effectively, it allows one to use
the full power of Perl as its own, recursively applied, macro language.
The excellent Filter::Util::Call module (by Paul Marquess) provides a
usable Perl interface to source filtering, but it is often too powerful
and not nearly as simple as it could be.
To use the module it is necessary to do the following:
=over 4
=item 1.
Download, build, and install the Filter::Util::Call module.
(If you have Perl 5.7.1 or later, this is already done for you.)
=item 2.
Set up a module that does a C<use Filter::Util::Call>.
=item 3.
Within that module, create an C<import> subroutine.
=item 4.
Within the C<import> subroutine do a call to C<filter_add>, passing
it either a subroutine reference.
=item 5.
Within the subroutine reference, call C<filter_read> or C<filter_read_exact>
to "prime" $_ with source code data from the source file that will
C<use> your module. Check the status value returned to see if any
source code was actually read in.
=item 6.
Process the contents of $_ to change the source code in the desired manner.
=item 7.
Return the status value.
=item 8.
If the act of unimporting your module (via a C<no>) should cause source
code filtering to cease, create an C<unimport> subroutine, and have it call
C<filter_del>. Make sure that the call to C<filter_read> or
C<filter_read_exact> in step 5 will not accidentally read past the
C<no>. Effectively this limits source code filters to line-by-line
operation, unless the C<import> subroutine does some fancy
pre-pre-parsing of the source code it's filtering.
=back
For example, here is a minimal source code filter in a module named
BANG.pm. It simply converts every occurrence of the sequence C<BANG\s+BANG>
to the sequence C<die 'BANG' if $BANG> in any piece of code following a
C<use BANG;> statement (until the next C<no BANG;> statement, if any):
package BANG;
use Filter::Util::Call ;
sub import {
filter_add( sub {
my $caller = caller;
my ($status, $no_seen, $data);
while ($status = filter_read()) {
if (/^\s*no\s+$caller\s*;\s*?$/) {
$no_seen=1;
last;
}
$data .= $_;
$_ = "";
}
$_ = $data;
s/BANG\s+BANG/die 'BANG' if \$BANG/g
unless $status < 0;
$_ .= "no $class;\n" if $no_seen;
return 1;
})
}
sub unimport {
filter_del();
}
1 ;
This level of sophistication puts filtering out of the reach of
many programmers.
=head2 A Solution
The Filter::Simple module provides a simplified interface to
Filter::Util::Call; one that is sufficient for most common cases.
Instead of the above process, with Filter::Simple the task of setting up
a source code filter is reduced to:
=over 4
=item 1.
Download and install the Filter::Simple module.
(If you have Perl 5.7.1 or later, this is already done for you.)
=item 2.
Set up a module that does a C<use Filter::Simple> and then
calls C<FILTER { ... }>.
=item 3.
Within the anonymous subroutine or block that is passed to
C<FILTER>, process the contents of $_ to change the source code in
the desired manner.
=back
In other words, the previous example, would become:
package BANG;
use Filter::Simple;
FILTER {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
};
1 ;
Note that the source code is passed as a single string, so any regex that
uses C<^> or C<$> to detect line boundaries will need the C</m> flag.
=head2 Disabling or changing <no> behaviour
By default, the installed filter only filters up to a line consisting of one of
the three standard source "terminators":
no ModuleName; # optional comment
or:
__END__
or:
__DATA__
but this can be altered by passing a second argument to C<use Filter::Simple>
or C<FILTER> (just remember: there's I<no> comma after the initial block when
you use C<FILTER>).
That second argument may be either a C<qr>'d regular expression (which is then
used to match the terminator line), or a defined false value (which indicates
that no terminator line should be looked for), or a reference to a hash
(in which case the terminator is the value associated with the key
C<'terminator'>.
For example, to cause the previous filter to filter only up to a line of the
form:
GNAB esu;
you would write:
package BANG;
use Filter::Simple;
FILTER {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
}
qr/^\s*GNAB\s+esu\s*;\s*?$/;
or:
FILTER {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
}
{ terminator => qr/^\s*GNAB\s+esu\s*;\s*?$/ };
and to prevent the filter's being turned off in any way:
package BANG;
use Filter::Simple;
FILTER {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
}
""; # or: 0
or:
FILTER {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
}
{ terminator => "" };
B<Note that, no matter what you set the terminator pattern to,
the actual terminator itself I<must> be contained on a single source line.>
=head2 All-in-one interface
Separating the loading of Filter::Simple:
use Filter::Simple;
from the setting up of the filtering:
FILTER { ... };
is useful because it allows other code (typically parser support code
or caching variables) to be defined before the filter is invoked.
However, there is often no need for such a separation.
In those cases, it is easier to just append the filtering subroutine and
any terminator specification directly to the C<use> statement that loads
Filter::Simple, like so:
use Filter::Simple sub {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
};
This is exactly the same as:
use Filter::Simple;
BEGIN {
Filter::Simple::FILTER {
s/BANG\s+BANG/die 'BANG' if \$BANG/g;
};
}
except that the C<FILTER> subroutine is not exported by Filter::Simple.
=head2 Filtering only specific components of source code
One of the problems with a filter like:
use Filter::Simple;
FILTER { s/BANG\s+BANG/die 'BANG' if \$BANG/g };
is that it indiscriminately applies the specified transformation to
the entire text of your source program. So something like:
warn 'BANG BANG, YOU'RE DEAD';
BANG BANG;
will become:
warn 'die 'BANG' if $BANG, YOU'RE DEAD';
die 'BANG' if $BANG;
It is very common when filtering source to only want to apply the filter
to the non-character-string parts of the code, or alternatively to I<only>
the character strings.
Filter::Simple supports this type of filtering by automatically
exporting the C<FILTER_ONLY> subroutine.
C<FILTER_ONLY> takes a sequence of specifiers that install separate
(and possibly multiple) filters that act on only parts of the source code.
For example:
use Filter::Simple;
FILTER_ONLY
code => sub { s/BANG\s+BANG/die 'BANG' if \$BANG/g },
quotelike => sub { s/BANG\s+BANG/CHITTY CHITTY/g };
The C<"code"> subroutine will only be used to filter parts of the source
code that are not quotelikes, POD, or C<__DATA__>. The C<quotelike>
subroutine only filters Perl quotelikes (including here documents).
The full list of alternatives is:
=over
=item C<"code">
Filters only those sections of the source code that are not quotelikes, POD, or
C<__DATA__>.
=item C<"code_no_comments">
Filters only those sections of the source code that are not quotelikes, POD,
comments, or C<__DATA__>.
=item C<"executable">
Filters only those sections of the source code that are not POD or C<__DATA__>.
=item C<"executable_no_comments">
Filters only those sections of the source code that are not POD, comments, or C<__DATA__>.
=item C<"quotelike">
Filters only Perl quotelikes (as interpreted by
C<&Text::Balanced::extract_quotelike>).
=item C<"string">
Filters only the string literal parts of a Perl quotelike (i.e. the
contents of a string literal, either half of a C<tr///>, the second
half of an C<s///>).
=item C<"regex">
Filters only the pattern literal parts of a Perl quotelike (i.e. the
contents of a C<qr//> or an C<m//>, the first half of an C<s///>).
=item C<"all">
Filters everything. Identical in effect to C<FILTER>.
=back
Except for C<< FILTER_ONLY code => sub {...} >>, each of
the component filters is called repeatedly, once for each component
found in the source code.
Note that you can also apply two or more of the same type of filter in
a single C<FILTER_ONLY>. For example, here's a simple
macro-preprocessor that is only applied within regexes,
with a final debugging pass that prints the resulting source code:
use Regexp::Common;
FILTER_ONLY
regex => sub { s/!\[/[^/g },
regex => sub { s/%d/$RE{num}{int}/g },
regex => sub { s/%f/$RE{num}{real}/g },
all => sub { print if $::DEBUG };
=head2 Filtering only the code parts of source code
Most source code ceases to be grammatically correct when it is broken up
into the pieces between string literals and regexes. So the C<'code'>
and C<'code_no_comments'> component filter behave slightly differently
from the other partial filters described in the previous section.
Rather than calling the specified processor on each individual piece of
code (i.e. on the bits between quotelikes), the C<'code...'> partial
filters operate on the entire source code, but with the quotelike bits
(and, in the case of C<'code_no_comments'>, the comments) "blanked out".
That is, a C<'code...'> filter I<replaces> each quoted string, quotelike,
regex, POD, and __DATA__ section with a placeholder. The
delimiters of this placeholder are the contents of the C<$;> variable
at the time the filter is applied (normally C<"\034">). The remaining
four bytes are a unique identifier for the component being replaced.
This approach makes it comparatively easy to write code preprocessors
without worrying about the form or contents of strings, regexes, etc.
For convenience, during a C<'code...'> filtering operation, Filter::Simple
provides a package variable (C<$Filter::Simple::placeholder>) that
contains a pre-compiled regex that matches any placeholder...and
captures the identifier within the placeholder. Placeholders can be
moved and re-ordered within the source code as needed.
In addition, a second package variable (C<@Filter::Simple::components>)
contains a list of the various pieces of C<$_>, as they were originally split
up to allow placeholders to be inserted.
Once the filtering has been applied, the original strings, regexes, POD,
etc. are re-inserted into the code, by replacing each placeholder with
the corresponding original component (from C<@components>). Note that
this means that the C<@components> variable must be treated with extreme
care within the filter. The C<@components> array stores the "back-
translations" of each placeholder inserted into C<$_>, as well as the
interstitial source code between placeholders. If the placeholder
backtranslations are altered in C<@components>, they will be similarly
changed when the placeholders are removed from C<$_> after the filter
is complete.
For example, the following filter detects concatenated pairs of
strings/quotelikes and reverses the order in which they are
concatenated:
package DemoRevCat;
use Filter::Simple;
FILTER_ONLY code => sub {
my $ph = $Filter::Simple::placeholder;
s{ ($ph) \s* [.] \s* ($ph) }{ $2.$1 }gx
};
Thus, the following code:
use DemoRevCat;
my $str = "abc" . q(def);
print "$str\n";
would become:
my $str = q(def)."abc";
print "$str\n";
and hence print:
defabc
=head2 Using Filter::Simple with an explicit C<import> subroutine
Filter::Simple generates a special C<import> subroutine for
your module (see L<"How it works">) which would normally replace any
C<import> subroutine you might have explicitly declared.
However, Filter::Simple is smart enough to notice your existing
C<import> and Do The Right Thing with it.
That is, if you explicitly define an C<import> subroutine in a package
that's using Filter::Simple, that C<import> subroutine will still
be invoked immediately after any filter you install.
The only thing you have to remember is that the C<import> subroutine
I<must> be declared I<before> the filter is installed. If you use C<FILTER>
to install the filter:
package Filter::TurnItUpTo11;
use Filter::Simple;
FILTER { s/(\w+)/\U$1/ };
that will almost never be a problem, but if you install a filtering
subroutine by passing it directly to the C<use Filter::Simple>
statement:
package Filter::TurnItUpTo11;
use Filter::Simple sub{ s/(\w+)/\U$1/ };
then you must make sure that your C<import> subroutine appears before
that C<use> statement.
=head2 Using Filter::Simple and Exporter together
Likewise, Filter::Simple is also smart enough
to Do The Right Thing if you use Exporter:
package Switch;
use base Exporter;
use Filter::Simple;
@EXPORT = qw(switch case);
@EXPORT_OK = qw(given when);
FILTER { $_ = magic_Perl_filter($_) }
Immediately after the filter has been applied to the source,
Filter::Simple will pass control to Exporter, so it can do its magic too.
Of course, here too, Filter::Simple has to know you're using Exporter
before it applies the filter. That's almost never a problem, but if you're
nervous about it, you can guarantee that things will work correctly by
ensuring that your C<use base Exporter> always precedes your
C<use Filter::Simple>.
=head2 How it works
The Filter::Simple module exports into the package that calls C<FILTER>
(or C<use>s it directly) -- such as package "BANG" in the above example --
two automagically constructed
subroutines -- C<import> and C<unimport> -- which take care of all the
nasty details.
In addition, the generated C<import> subroutine passes its own argument
list to the filtering subroutine, so the BANG.pm filter could easily
be made parametric:
package BANG;
use Filter::Simple;
FILTER {
my ($die_msg, $var_name) = @_;
s/BANG\s+BANG/die '$die_msg' if \${$var_name}/g;
};
# and in some user code:
use BANG "BOOM", "BAM"; # "BANG BANG" becomes: die 'BOOM' if $BAM
The specified filtering subroutine is called every time a C<use BANG> is
encountered, and passed all the source code following that call, up to
either the next C<no BANG;> (or whatever terminator you've set) or the
end of the source file, whichever occurs first. By default, any C<no
BANG;> call must appear by itself on a separate line, or it is ignored.
=head1 AUTHOR
Damian Conway
=head1 CONTACT
Filter::Simple is now maintained by the Perl5-Porters.
Please submit bug via the C<perlbug> tool that comes with your perl.
For usage instructions, read C<perldoc perlbug> or possibly C<man perlbug>.
For mostly anything else, please contact E<lt>perl5-porters@perl.orgE<gt>.
Maintainer of the CPAN release is Steffen Mueller E<lt>smueller@cpan.orgE<gt>.
Contact him with technical difficulties with respect to the packaging of the
CPAN module.
Praise of the module, flowers, and presents still go to the author,
Damian Conway E<lt>damian@conway.orgE<gt>.
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2000-2014, Damian Conway. All Rights Reserved.
This module is free software. It may be used, redistributed
and/or modified under the same terms as Perl itself.

171
gitportable/usr/share/perl5/core_perl/FindBin.pm Normal file
View File

@@ -0,0 +1,171 @@
# FindBin.pm
#
# Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
=head1 NAME
FindBin - Locate directory of original perl script
=head1 SYNOPSIS
use FindBin;
use lib "$FindBin::Bin/../lib";
or
use FindBin qw($Bin);
use lib "$Bin/../lib";
=head1 DESCRIPTION
Locates the full path to the script bin directory to allow the use
of paths relative to the bin directory.
This allows a user to setup a directory tree for some software with
directories C<< <root>/bin >> and C<< <root>/lib >>, and then the above
example will allow the use of modules in the lib directory without knowing
where the software tree is installed.
If perl is invoked using the B<-e> option or the perl script is read from
C<STDIN> then FindBin sets both C<$Bin> and C<$RealBin> to the current
directory.
=head1 EXPORTABLE VARIABLES
$Bin - path to bin directory from where script was invoked
$Script - basename of script from which perl was invoked
$RealBin - $Bin with all links resolved
$RealScript - $Script with all links resolved
=head1 KNOWN ISSUES
If there are two modules using C<FindBin> from different directories
under the same interpreter, this won't work. Since C<FindBin> uses a
C<BEGIN> block, it'll be executed only once, and only the first caller
will get it right. This is a problem under mod_perl and other persistent
Perl environments, where you shouldn't use this module. Which also means
that you should avoid using C<FindBin> in modules that you plan to put
on CPAN. To make sure that C<FindBin> will work is to call the C<again>
function:
use FindBin;
FindBin::again(); # or FindBin->again;
In former versions of FindBin there was no C<again> function. The
workaround was to force the C<BEGIN> block to be executed again:
delete $INC{'FindBin.pm'};
require FindBin;
=head1 AUTHORS
FindBin is supported as part of the core perl distribution. Please submit bug
reports at L<https://github.com/Perl/perl5/issues>.
Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt>
=head1 COPYRIGHT
Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
package FindBin;
use strict;
use warnings;
use Carp;
require Exporter;
use Cwd qw(getcwd cwd abs_path);
use File::Basename;
use File::Spec;
our ($Bin, $Script, $RealBin, $RealScript, $Dir, $RealDir);
our @EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir);
our %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]);
our @ISA = qw(Exporter);
our $VERSION = "1.53";
# needed for VMS-specific filename translation
if( $^O eq 'VMS' ) {
require VMS::Filespec;
VMS::Filespec->import;
}
sub cwd2 {
my $cwd = getcwd();
# getcwd might fail if it hasn't access to the current directory.
# try harder.
defined $cwd or $cwd = cwd();
$cwd;
}
sub init
{
*Dir = \$Bin;
*RealDir = \$RealBin;
if($0 eq '-e' || $0 eq '-')
{
# perl invoked with -e or script is on C<STDIN>
$Script = $RealScript = $0;
$Bin = $RealBin = cwd2();
$Bin = VMS::Filespec::unixify($Bin) if $^O eq 'VMS';
}
else
{
my $script = $0;
if ($^O eq 'VMS')
{
($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*[\]>\/]+)(.*)/s;
# C<use disk:[dev]/lib> isn't going to work, so unixify first
($Bin = VMS::Filespec::unixify($Bin)) =~ s/\/\z//;
($RealBin,$RealScript) = ($Bin,$Script);
}
else
{
croak("Cannot find current script '$0'") unless(-f $script);
# Ensure $script contains the complete path in case we C<chdir>
$script = File::Spec->catfile(cwd2(), $script)
unless File::Spec->file_name_is_absolute($script);
($Script,$Bin) = fileparse($script);
# Resolve $script if it is a link
while(1)
{
my $linktext = readlink($script);
($RealScript,$RealBin) = fileparse($script);
last unless defined $linktext;
$script = (File::Spec->file_name_is_absolute($linktext))
? $linktext
: File::Spec->catfile($RealBin, $linktext);
}
# Get absolute paths to directories
if ($Bin) {
my $BinOld = $Bin;
$Bin = abs_path($Bin);
defined $Bin or $Bin = File::Spec->canonpath($BinOld);
}
$RealBin = abs_path($RealBin) if($RealBin);
}
}
}
BEGIN { init }
*again = \&init;
1; # Keep require happy

2825
gitportable/usr/share/perl5/core_perl/Getopt/Long.pm Normal file
View File

File diff suppressed because it is too large Load Diff

312
gitportable/usr/share/perl5/core_perl/Getopt/Std.pm Normal file
View File

@@ -0,0 +1,312 @@
package Getopt::Std;
use strict;
use warnings;
require Exporter;
=head1 NAME
Getopt::Std - Process single-character switches with switch clustering
=head1 SYNOPSIS
use Getopt::Std;
getopts('oif:'); # -o & -i are boolean flags, -f takes an argument
# Sets $opt_* as a side effect.
getopts('oif:', \%opts); # options as above. Values in %opts
getopt('oDI'); # -o, -D & -I take arg.
# Sets $opt_* as a side effect.
getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts
=head1 DESCRIPTION
The C<getopts()> function processes single-character switches with switch
clustering. Pass one argument which is a string containing all switches to be
recognized. For each switch found, if an argument is expected and provided,
C<getopts()> sets C<$opt_x> (where C<x> is the switch name) to the value of
the argument. If an argument is expected but none is provided, C<$opt_x> is
set to an undefined value. If a switch does not take an argument, C<$opt_x>
is set to C<1>.
Switches which take an argument don't care whether there is a space between
the switch and the argument. If unspecified switches are found on the
command-line, the user will be warned that an unknown option was given.
The C<getopts()> function returns true unless an invalid option was found.
The C<getopt()> function is similar, but its argument is a string containing
all switches that take an argument. If no argument is provided for a switch,
say, C<y>, the corresponding C<$opt_y> will be set to an undefined value.
Unspecified switches are silently accepted. Use of C<getopt()> is not
recommended.
Note that, if your code is running under the recommended C<use strict
vars> pragma, you will need to declare these package variables
with C<our>:
our($opt_x, $opt_y);
For those of you who don't like additional global variables being created,
C<getopt()> and C<getopts()> will also accept a hash reference as an optional
second argument. Hash keys will be C<x> (where C<x> is the switch name) with
key values the value of the argument or C<1> if no argument is specified.
To allow programs to process arguments that look like switches, but aren't,
both functions will stop processing switches when they see the argument
C<-->. The C<--> will be removed from @ARGV.
=head1 C<--help> and C<--version>
If C<-> is not a recognized switch letter, getopts() supports arguments
C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or
C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
the output file handle, the name of option-processing package, its version,
and the switches string. If the subroutines are not defined, an attempt is
made to generate intelligent messages; for best results, define $main::VERSION.
If embedded documentation (in pod format, see L<perlpod>) is detected
in the script, C<--help> will also show how to access the documentation.
Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
isn't true (the default is false), then the messages are printed on STDERR,
and the processing continues after the messages are printed. This being
the opposite of the standard-conforming behaviour, it is strongly recommended
to set $Getopt::Std::STANDARD_HELP_VERSION to true.
One can change the output file handle of the messages by setting
$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help>
(without the C<Usage:> line) and C<--version> by calling functions help_mess()
and version_mess() with the switches string as an argument.
=cut
our @ISA = qw(Exporter);
our @EXPORT = qw(getopt getopts);
our $VERSION = '1.13';
# uncomment the next line to disable 1.03-backward compatibility paranoia
# $STANDARD_HELP_VERSION = 1;
# Process single-character switches with switch clustering. Pass one argument
# which is a string containing all switches that take an argument. For each
# switch found, sets $opt_x (where x is the switch name) to the value of the
# argument, or 1 if no argument. Switches which take an argument don't care
# whether there is a space between the switch and the argument.
# Usage:
# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
sub getopt (;$$) {
my ($argumentative, $hash) = @_;
$argumentative = '' if !defined $argumentative;
my ($first,$rest);
local $_;
local @EXPORT;
while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
($first,$rest) = ($1,$2);
if (/^--$/) { # early exit if --
shift @ARGV;
last;
}
if (index($argumentative,$first) >= 0) {
if ($rest ne '') {
shift(@ARGV);
}
else {
shift(@ARGV);
$rest = shift(@ARGV);
}
if (ref $hash) {
$$hash{$first} = $rest;
}
else {
no strict 'refs';
${"opt_$first"} = $rest;
push( @EXPORT, "\$opt_$first" );
}
}
else {
if (ref $hash) {
$$hash{$first} = 1;
}
else {
no strict 'refs';
${"opt_$first"} = 1;
push( @EXPORT, "\$opt_$first" );
}
if ($rest ne '') {
$ARGV[0] = "-$rest";
}
else {
shift(@ARGV);
}
}
}
unless (ref $hash) {
local $Exporter::ExportLevel = 1;
import Getopt::Std;
}
}
our ($OUTPUT_HELP_VERSION, $STANDARD_HELP_VERSION);
sub output_h () {
return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
return \*STDOUT if $STANDARD_HELP_VERSION;
return \*STDERR;
}
sub try_exit () {
exit 0 if $STANDARD_HELP_VERSION;
my $p = __PACKAGE__;
print {output_h()} <<EOM;
[Now continuing due to backward compatibility and excessive paranoia.
See 'perldoc $p' about \$$p\::STANDARD_HELP_VERSION.]
EOM
}
sub version_mess ($;$) {
my $args = shift;
my $h = output_h;
if (@_ and defined &main::VERSION_MESSAGE) {
main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
} else {
my $v = $main::VERSION;
$v = '[unknown]' unless defined $v;
my $myv = $VERSION;
$myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
my $perlv = $];
$perlv = sprintf "%vd", $^V if $] >= 5.006;
print $h <<EOH;
$0 version $v calling Getopt::Std::getopts (version $myv),
running under Perl version $perlv.
EOH
}
}
sub help_mess ($;$) {
my $args = shift;
my $h = output_h;
if (@_ and defined &main::HELP_MESSAGE) {
main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
} else {
my (@witharg) = ($args =~ /(\S)\s*:/g);
my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
my ($help, $arg) = ('', '');
if (@witharg) {
$help .= "\n\tWith arguments: -" . join " -", @witharg;
$arg = "\nSpace is not required between options and their arguments.";
}
if (@rest) {
$help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
}
my ($scr) = ($0 =~ m,([^/\\]+)$,);
print $h <<EOH if @_; # Let the script override this
Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
EOH
print $h <<EOH;
The following single-character options are accepted:$help
Options may be merged together. -- stops processing of options.$arg
EOH
my $has_pod;
if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
and open my $script, '<', $0 ) {
while (<$script>) {
$has_pod = 1, last if /^=(pod|head1)/;
}
}
print $h <<EOH if $has_pod;
For more details run
perldoc -F $0
EOH
}
}
# Usage:
# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
# # side effect.
sub getopts ($;$) {
my ($argumentative, $hash) = @_;
my (@args,$first,$rest,$exit);
my $errs = 0;
local $_;
local @EXPORT;
@args = split( / */, $argumentative );
while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
($first,$rest) = ($1,$2);
if (/^--$/) { # early exit if --
shift @ARGV;
last;
}
my $pos = index($argumentative,$first);
if ($pos >= 0) {
if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
shift(@ARGV);
if ($rest eq '') {
++$errs unless @ARGV;
$rest = shift(@ARGV);
}
if (ref $hash) {
$$hash{$first} = $rest;
}
else {
no strict 'refs';
${"opt_$first"} = $rest;
push( @EXPORT, "\$opt_$first" );
}
}
else {
if (ref $hash) {
$$hash{$first} = 1;
}
else {
no strict 'refs';
${"opt_$first"} = 1;
push( @EXPORT, "\$opt_$first" );
}
if ($rest eq '') {
shift(@ARGV);
}
else {
$ARGV[0] = "-$rest";
}
}
}
else {
if ($first eq '-' and $rest eq 'help') {
version_mess($argumentative, 'main');
help_mess($argumentative, 'main');
try_exit();
shift(@ARGV);
next;
} elsif ($first eq '-' and $rest eq 'version') {
version_mess($argumentative, 'main');
try_exit();
shift(@ARGV);
next;
}
warn "Unknown option: $first\n";
++$errs;
if ($rest ne '') {
$ARGV[0] = "-$rest";
}
else {
shift(@ARGV);
}
}
}
unless (ref $hash) {
local $Exporter::ExportLevel = 1;
import Getopt::Std;
}
$errs == 0;
}
1;

2575
gitportable/usr/share/perl5/core_perl/HTTP/Tiny.pm Normal file
View File

File diff suppressed because it is too large Load Diff

196
gitportable/usr/share/perl5/core_perl/I18N/Collate.pm Normal file
View File

@@ -0,0 +1,196 @@
package I18N::Collate;
use strict;
our $VERSION = '1.02';
=head1 NAME
I18N::Collate - compare 8-bit scalar data according to the current locale
=head1 SYNOPSIS
use I18N::Collate;
setlocale(LC_COLLATE, 'locale-of-your-choice');
$s1 = I18N::Collate->new("scalar_data_1");
$s2 = I18N::Collate->new("scalar_data_2");
=head1 DESCRIPTION
***
WARNING: starting from the Perl version 5.003_06
the I18N::Collate interface for comparing 8-bit scalar data
according to the current locale
HAS BEEN DEPRECATED
That is, please do not use it anymore for any new applications
and please migrate the old applications away from it because its
functionality was integrated into the Perl core language in the
release 5.003_06.
See the perllocale manual page for further information.
***
This module provides you with objects that will collate
according to your national character set, provided that the
POSIX setlocale() function is supported on your system.
You can compare $s1 and $s2 above with
$s1 le $s2
to extract the data itself, you'll need a dereference: $$s1
This module uses POSIX::setlocale(). The basic collation conversion is
done by strxfrm() which terminates at NUL characters being a decent C
routine. collate_xfrm() handles embedded NUL characters gracefully.
The available locales depend on your operating system; try whether
C<locale -a> shows them or man pages for "locale" or "nlsinfo" or the
direct approach C<ls /usr/lib/nls/loc> or C<ls /usr/lib/nls> or
C<ls /usr/lib/locale>. Not all the locales that your vendor supports
are necessarily installed: please consult your operating system's
documentation and possibly your local system administration. The
locale names are probably something like C<xx_XX.(ISO)?8859-N> or
C<xx_XX.(ISO)?8859N>, for example C<fr_CH.ISO8859-1> is the Swiss (CH)
variant of French (fr), ISO Latin (8859) 1 (-1) which is the Western
European character set.
=cut
# I18N::Collate.pm
#
# Author: Jarkko Hietaniemi <F<jhi@iki.fi>>
# Helsinki University of Technology, Finland
#
# Acks: Guy Decoux <F<decoux@moulon.inra.fr>> understood
# overloading magic much deeper than I and told
# how to cut the size of this code by more than half.
# (my first version did overload all of lt gt eq le ge cmp)
#
# Purpose: compare 8-bit scalar data according to the current locale
#
# Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm()
#
# Exports: setlocale 1)
# collate_xfrm 2)
#
# Overloads: cmp # 3)
#
# Usage: use I18N::Collate;
# setlocale(LC_COLLATE, 'locale-of-your-choice'); # 4)
# $s1 = I18N::Collate->("scalar_data_1");
# $s2 = I18N::Collate->("scalar_data_2");
#
# now you can compare $s1 and $s2: $s1 le $s2
# to extract the data itself, you need to deref: $$s1
#
# Notes:
# 1) this uses POSIX::setlocale
# 2) the basic collation conversion is done by strxfrm() which
# terminates at NUL characters being a decent C routine.
# collate_xfrm handles embedded NUL characters gracefully.
# 3) due to cmp and overload magic, lt le eq ge gt work also
# 4) the available locales depend on your operating system;
# try whether "locale -a" shows them or man pages for
# "locale" or "nlsinfo" work or the more direct
# approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls".
# Not all the locales that your vendor supports
# are necessarily installed: please consult your
# operating system's documentation.
# The locale names are probably something like
# 'xx_XX.(ISO)?8859-N' or 'xx_XX.(ISO)?8859N',
# for example 'fr_CH.ISO8859-1' is the Swiss (CH)
# variant of French (fr), ISO Latin (8859) 1 (-1)
# which is the Western European character set.
#
# Updated: 19961005
#
# ---
use POSIX qw(strxfrm LC_COLLATE);
use warnings::register;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(collate_xfrm setlocale LC_COLLATE);
our @EXPORT_OK = qw();
use overload qw(
fallback 1
cmp collate_cmp
);
our($LOCALE, $C);
our $please_use_I18N_Collate_even_if_deprecated = 0;
sub new {
my $new = $_[1];
if (warnings::enabled() && $] >= 5.003_06) {
unless ($please_use_I18N_Collate_even_if_deprecated) {
warnings::warn <<___EOD___;
***
WARNING: starting from the Perl version 5.003_06
the I18N::Collate interface for comparing 8-bit scalar data
according to the current locale
HAS BEEN DEPRECATED
That is, please do not use it anymore for any new applications
and please migrate the old applications away from it because its
functionality was integrated into the Perl core language in the
release 5.003_06.
See the perllocale manual page for further information.
***
___EOD___
$please_use_I18N_Collate_even_if_deprecated++;
}
}
bless \$new;
}
sub setlocale {
my ($category, $locale) = @_[0,1];
POSIX::setlocale($category, $locale) if (defined $category);
# the current $LOCALE
$LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || '';
}
sub C {
my $s = ${$_[0]};
$C->{$LOCALE}->{$s} = collate_xfrm($s)
unless (defined $C->{$LOCALE}->{$s}); # cache when met
$C->{$LOCALE}->{$s};
}
sub collate_xfrm {
my $s = $_[0];
my $x = '';
for (split(/(\000+)/, $s)) {
$x .= (/^\000/) ? $_ : strxfrm("$_\000");
}
$x;
}
sub collate_cmp {
&C($_[0]) cmp &C($_[1]);
}
# init $LOCALE
&I18N::Collate::setlocale();
1; # keep require happy

887
gitportable/usr/share/perl5/core_perl/I18N/LangTags.pm Normal file
View File

@@ -0,0 +1,887 @@
# Time-stamp: "2004-10-06 23:26:33 ADT"
# Sean M. Burke <sburke@cpan.org>
require 5.000;
package I18N::LangTags;
use strict;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw();
our @EXPORT_OK = qw(is_language_tag same_language_tag
extract_language_tags super_languages
similarity_language_tag is_dialect_of
locale2language_tag alternate_language_tags
encode_language_tag panic_languages
implicate_supers
implicate_supers_strictly
);
our %EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
our $VERSION = "0.45";
our %Panic;
sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function
=head1 NAME
I18N::LangTags - functions for dealing with RFC3066-style language tags
=head1 SYNOPSIS
use I18N::LangTags();
...or specify whichever of those functions you want to import, like so:
use I18N::LangTags qw(implicate_supers similarity_language_tag);
All the exportable functions are listed below -- you're free to import
only some, or none at all. By default, none are imported. If you
say:
use I18N::LangTags qw(:ALL)
...then all are exported. (This saves you from having to use
something less obvious like C<use I18N::LangTags qw(/./)>.)
If you don't import any of these functions, assume a C<&I18N::LangTags::>
in front of all the function names in the following examples.
=head1 DESCRIPTION
Language tags are a formalism, described in RFC 3066 (obsoleting
1766), for declaring what language form (language and possibly
dialect) a given chunk of information is in.
This library provides functions for common tasks involving language
tags as they are needed in a variety of protocols and applications.
Please see the "See Also" references for a thorough explanation
of how to correctly use language tags.
=over
=cut
###########################################################################
=item * the function is_language_tag($lang1)
Returns true iff $lang1 is a formally valid language tag.
is_language_tag("fr") is TRUE
is_language_tag("x-jicarilla") is FALSE
(Subtags can be 8 chars long at most -- 'jicarilla' is 9)
is_language_tag("sgn-US") is TRUE
(That's American Sign Language)
is_language_tag("i-Klikitat") is TRUE
(True without regard to the fact noone has actually
registered Klikitat -- it's a formally valid tag)
is_language_tag("fr-patois") is TRUE
(Formally valid -- altho descriptively weak!)
is_language_tag("Spanish") is FALSE
is_language_tag("french-patois") is FALSE
(No good -- first subtag has to match
/^([xXiI]|[a-zA-Z]{2,3})$/ -- see RFC3066)
is_language_tag("x-borg-prot2532") is TRUE
(Yes, subtags can contain digits, as of RFC3066)
=cut
sub is_language_tag {
## Changes in the language tagging standards may have to be reflected here.
my($tag) = lc($_[0]);
return 0 if $tag eq "i" or $tag eq "x";
# Bad degenerate cases that the following
# regexp would erroneously let pass
return $tag =~
/^(?: # First subtag
[xi] | [a-z]{2,3}
)
(?: # Subtags thereafter
- # separator
[a-z0-9]{1,8} # subtag
)*
$/xs ? 1 : 0;
}
###########################################################################
=item * the function extract_language_tags($whatever)
Returns a list of whatever looks like formally valid language tags
in $whatever. Not very smart, so don't get too creative with
what you want to feed it.
extract_language_tags("fr, fr-ca, i-mingo")
returns: ('fr', 'fr-ca', 'i-mingo')
extract_language_tags("It's like this: I'm in fr -- French!")
returns: ('It', 'in', 'fr')
(So don't just feed it any old thing.)
The output is untainted. If you don't know what tainting is,
don't worry about it.
=cut
sub extract_language_tags {
## Changes in the language tagging standards may have to be reflected here.
my($text) =
$_[0] =~ m/(.+)/ # to make for an untainted result
? $1 : ''
;
return grep(!m/^[ixIX]$/s, # 'i' and 'x' aren't good tags
$text =~
m/
\b
(?: # First subtag
[iIxX] | [a-zA-Z]{2,3}
)
(?: # Subtags thereafter
- # separator
[a-zA-Z0-9]{1,8} # subtag
)*
\b
/xsg
);
}
###########################################################################
=item * the function same_language_tag($lang1, $lang2)
Returns true iff $lang1 and $lang2 are acceptable variant tags
representing the same language-form.
same_language_tag('x-kadara', 'i-kadara') is TRUE
(The x/i- alternation doesn't matter)
same_language_tag('X-KADARA', 'i-kadara') is TRUE
(...and neither does case)
same_language_tag('en', 'en-US') is FALSE
(all-English is not the SAME as US English)
same_language_tag('x-kadara', 'x-kadar') is FALSE
(these are totally unrelated tags)
same_language_tag('no-bok', 'nb') is TRUE
(no-bok is a legacy tag for nb (Norwegian Bokmal))
C<same_language_tag> works by just seeing whether
C<encode_language_tag($lang1)> is the same as
C<encode_language_tag($lang2)>.
(Yes, I know this function is named a bit oddly. Call it historic
reasons.)
=cut
sub same_language_tag {
my $el1 = &encode_language_tag($_[0]);
return 0 unless defined $el1;
# this avoids the problem of
# encode_language_tag($lang1) eq and encode_language_tag($lang2)
# being true if $lang1 and $lang2 are both undef
return $el1 eq &encode_language_tag($_[1]) ? 1 : 0;
}
###########################################################################
=item * the function similarity_language_tag($lang1, $lang2)
Returns an integer representing the degree of similarity between
tags $lang1 and $lang2 (the order of which does not matter), where
similarity is the number of common elements on the left,
without regard to case and to x/i- alternation.
similarity_language_tag('fr', 'fr-ca') is 1
(one element in common)
similarity_language_tag('fr-ca', 'fr-FR') is 1
(one element in common)
similarity_language_tag('fr-CA-joual',
'fr-CA-PEI') is 2
similarity_language_tag('fr-CA-joual', 'fr-CA') is 2
(two elements in common)
similarity_language_tag('x-kadara', 'i-kadara') is 1
(x/i- doesn't matter)
similarity_language_tag('en', 'x-kadar') is 0
similarity_language_tag('x-kadara', 'x-kadar') is 0
(unrelated tags -- no similarity)
similarity_language_tag('i-cree-syllabic',
'i-cherokee-syllabic') is 0
(no B<leftmost> elements in common!)
=cut
sub similarity_language_tag {
my $lang1 = &encode_language_tag($_[0]);
my $lang2 = &encode_language_tag($_[1]);
# And encode_language_tag takes care of the whole
# no-nyn==nn, i-hakka==zh-hakka, etc, things
# NB: (i-sil-...)? (i-sgn-...)?
return undef if !defined($lang1) and !defined($lang2);
return 0 if !defined($lang1) or !defined($lang2);
my @l1_subtags = split('-', $lang1);
my @l2_subtags = split('-', $lang2);
my $similarity = 0;
while(@l1_subtags and @l2_subtags) {
if(shift(@l1_subtags) eq shift(@l2_subtags)) {
++$similarity;
} else {
last;
}
}
return $similarity;
}
###########################################################################
=item * the function is_dialect_of($lang1, $lang2)
Returns true iff language tag $lang1 represents a subform of
language tag $lang2.
B<Get the order right! It doesn't work the other way around!>
is_dialect_of('en-US', 'en') is TRUE
(American English IS a dialect of all-English)
is_dialect_of('fr-CA-joual', 'fr-CA') is TRUE
is_dialect_of('fr-CA-joual', 'fr') is TRUE
(Joual is a dialect of (a dialect of) French)
is_dialect_of('en', 'en-US') is FALSE
(all-English is a NOT dialect of American English)
is_dialect_of('fr', 'en-CA') is FALSE
is_dialect_of('en', 'en' ) is TRUE
is_dialect_of('en-US', 'en-US') is TRUE
(B<Note:> these are degenerate cases)
is_dialect_of('i-mingo-tom', 'x-Mingo') is TRUE
(the x/i thing doesn't matter, nor does case)
is_dialect_of('nn', 'no') is TRUE
(because 'nn' (New Norse) is aliased to 'no-nyn',
as a special legacy case, and 'no-nyn' is a
subform of 'no' (Norwegian))
=cut
sub is_dialect_of {
my $lang1 = &encode_language_tag($_[0]);
my $lang2 = &encode_language_tag($_[1]);
return undef if !defined($lang1) and !defined($lang2);
return 0 if !defined($lang1) or !defined($lang2);
return 1 if $lang1 eq $lang2;
return 0 if length($lang1) < length($lang2);
$lang1 .= '-';
$lang2 .= '-';
return
(substr($lang1, 0, length($lang2)) eq $lang2) ? 1 : 0;
}
###########################################################################
=item * the function super_languages($lang1)
Returns a list of language tags that are superordinate tags to $lang1
-- it gets this by removing subtags from the end of $lang1 until
nothing (or just "i" or "x") is left.
super_languages("fr-CA-joual") is ("fr-CA", "fr")
super_languages("en-AU") is ("en")
super_languages("en") is empty-list, ()
super_languages("i-cherokee") is empty-list, ()
...not ("i"), which would be illegal as well as pointless.
If $lang1 is not a valid language tag, returns empty-list in
a list context, undef in a scalar context.
A notable and rather unavoidable problem with this method:
"x-mingo-tom" has an "x" because the whole tag isn't an
IANA-registered tag -- but super_languages('x-mingo-tom') is
('x-mingo') -- which isn't really right, since 'i-mingo' is
registered. But this module has no way of knowing that. (But note
that same_language_tag('x-mingo', 'i-mingo') is TRUE.)
More importantly, you assume I<at your peril> that superordinates of
$lang1 are mutually intelligible with $lang1. Consider this
carefully.
=cut
sub super_languages {
my $lang1 = $_[0];
return() unless defined($lang1) && &is_language_tag($lang1);
# a hack for those annoying new (2001) tags:
$lang1 =~ s/^nb\b/no-bok/i; # yes, backwards
$lang1 =~ s/^nn\b/no-nyn/i; # yes, backwards
$lang1 =~ s/^[ix](-hakka\b)/zh$1/i; # goes the right way
# i-hakka-bork-bjork-bjark => zh-hakka-bork-bjork-bjark
my @l1_subtags = split('-', $lang1);
## Changes in the language tagging standards may have to be reflected here.
# NB: (i-sil-...)?
my @supers = ();
foreach my $bit (@l1_subtags) {
push @supers,
scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit;
}
pop @supers if @supers;
shift @supers if @supers && $supers[0] =~ m<^[iIxX]$>s;
return reverse @supers;
}
###########################################################################
=item * the function locale2language_tag($locale_identifier)
This takes a locale name (like "en", "en_US", or "en_US.ISO8859-1")
and maps it to a language tag. If it's not mappable (as with,
notably, "C" and "POSIX"), this returns empty-list in a list context,
or undef in a scalar context.
locale2language_tag("en") is "en"
locale2language_tag("en_US") is "en-US"
locale2language_tag("en_US.ISO8859-1") is "en-US"
locale2language_tag("C") is undef or ()
locale2language_tag("POSIX") is undef or ()
locale2language_tag("POSIX") is undef or ()
I'm not totally sure that locale names map satisfactorily to language
tags. Think REAL hard about how you use this. YOU HAVE BEEN WARNED.
The output is untainted. If you don't know what tainting is,
don't worry about it.
=cut
sub locale2language_tag {
my $lang =
$_[0] =~ m/(.+)/ # to make for an untainted result
? $1 : ''
;
return $lang if &is_language_tag($lang); # like "en"
$lang =~ tr<_><->; # "en_US" -> en-US
$lang =~ s<(?:[\.\@][-_a-zA-Z0-9]+)+$><>s; # "en_US.ISO8859-1" -> en-US
# it_IT.utf8@euro => it-IT
return $lang if &is_language_tag($lang);
return;
}
###########################################################################
=item * the function encode_language_tag($lang1)
This function, if given a language tag, returns an encoding of it such
that:
* tags representing different languages never get the same encoding.
* tags representing the same language always get the same encoding.
* an encoding of a formally valid language tag always is a string
value that is defined, has length, and is true if considered as a
boolean.
Note that the encoding itself is B<not> a formally valid language tag.
Note also that you cannot, currently, go from an encoding back to a
language tag that it's an encoding of.
Note also that you B<must> consider the encoded value as atomic; i.e.,
you should not consider it as anything but an opaque, unanalysable
string value. (The internals of the encoding method may change in
future versions, as the language tagging standard changes over time.)
C<encode_language_tag> returns undef if given anything other than a
formally valid language tag.
The reason C<encode_language_tag> exists is because different language
tags may represent the same language; this is normally treatable with
C<same_language_tag>, but consider this situation:
You have a data file that expresses greetings in different languages.
Its format is "[language tag]=[how to say 'Hello']", like:
en-US=Hiho
fr=Bonjour
i-mingo=Hau'
And suppose you write a program that reads that file and then runs as
a daemon, answering client requests that specify a language tag and
then expect the string that says how to greet in that language. So an
interaction looks like:
greeting-client asks: fr
greeting-server answers: Bonjour
So far so good. But suppose the way you're implementing this is:
my %greetings;
die unless open(IN, "<", "in.dat");
while(<IN>) {
chomp;
next unless /^([^=]+)=(.+)/s;
my($lang, $expr) = ($1, $2);
$greetings{$lang} = $expr;
}
close(IN);
at which point %greetings has the contents:
"en-US" => "Hiho"
"fr" => "Bonjour"
"i-mingo" => "Hau'"
And suppose then that you answer client requests for language $wanted
by just looking up $greetings{$wanted}.
If the client asks for "fr", that will look up successfully in
%greetings, to the value "Bonjour". And if the client asks for
"i-mingo", that will look up successfully in %greetings, to the value
"Hau'".
But if the client asks for "i-Mingo" or "x-mingo", or "Fr", then the
lookup in %greetings fails. That's the Wrong Thing.
You could instead do lookups on $wanted with:
use I18N::LangTags qw(same_language_tag);
my $response = '';
foreach my $l2 (keys %greetings) {
if(same_language_tag($wanted, $l2)) {
$response = $greetings{$l2};
last;
}
}
But that's rather inefficient. A better way to do it is to start your
program with:
use I18N::LangTags qw(encode_language_tag);
my %greetings;
die unless open(IN, "<", "in.dat");
while(<IN>) {
chomp;
next unless /^([^=]+)=(.+)/s;
my($lang, $expr) = ($1, $2);
$greetings{
encode_language_tag($lang)
} = $expr;
}
close(IN);
and then just answer client requests for language $wanted by just
looking up
$greetings{encode_language_tag($wanted)}
And that does the Right Thing.
=cut
sub encode_language_tag {
# Only similarity_language_tag() is allowed to analyse encodings!
## Changes in the language tagging standards may have to be reflected here.
my($tag) = $_[0] || return undef;
return undef unless &is_language_tag($tag);
# For the moment, these legacy variances are few enough that
# we can just handle them here with regexps.
$tag =~ s/^iw\b/he/i; # Hebrew
$tag =~ s/^in\b/id/i; # Indonesian
$tag =~ s/^cre\b/cr/i; # Cree
$tag =~ s/^jw\b/jv/i; # Javanese
$tag =~ s/^[ix]-lux\b/lb/i; # Luxemburger
$tag =~ s/^[ix]-navajo\b/nv/i; # Navajo
$tag =~ s/^ji\b/yi/i; # Yiddish
# SMB 2003 -- Hm. There's a bunch of new XXX->YY variances now,
# but maybe they're all so obscure I can ignore them. "Obscure"
# meaning either that the language is obscure, and/or that the
# XXX form was extant so briefly that it's unlikely it was ever
# used. I hope.
#
# These go FROM the simplex to complex form, to get
# similarity-comparison right. And that's okay, since
# similarity_language_tag is the only thing that
# analyzes our output.
$tag =~ s/^[ix]-hakka\b/zh-hakka/i; # Hakka
$tag =~ s/^nb\b/no-bok/i; # BACKWARDS for Bokmal
$tag =~ s/^nn\b/no-nyn/i; # BACKWARDS for Nynorsk
$tag =~ s/^[xiXI]-//s;
# Just lop off any leading "x/i-"
return "~" . uc($tag);
}
#--------------------------------------------------------------------------
=item * the function alternate_language_tags($lang1)
This function, if given a language tag, returns all language tags that
are alternate forms of this language tag. (I.e., tags which refer to
the same language.) This is meant to handle legacy tags caused by
the minor changes in language tag standards over the years; and
the x-/i- alternation is also dealt with.
Note that this function does I<not> try to equate new (and never-used,
and unusable)
ISO639-2 three-letter tags to old (and still in use) ISO639-1
two-letter equivalents -- like "ara" -> "ar" -- because
"ara" has I<never> been in use as an Internet language tag,
and RFC 3066 stipulates that it never should be, since a shorter
tag ("ar") exists.
Examples:
alternate_language_tags('no-bok') is ('nb')
alternate_language_tags('nb') is ('no-bok')
alternate_language_tags('he') is ('iw')
alternate_language_tags('iw') is ('he')
alternate_language_tags('i-hakka') is ('zh-hakka', 'x-hakka')
alternate_language_tags('zh-hakka') is ('i-hakka', 'x-hakka')
alternate_language_tags('en') is ()
alternate_language_tags('x-mingo-tom') is ('i-mingo-tom')
alternate_language_tags('x-klikitat') is ('i-klikitat')
alternate_language_tags('i-klikitat') is ('x-klikitat')
This function returns empty-list if given anything other than a formally
valid language tag.
=cut
my %alt = qw( i x x i I X X I );
sub alternate_language_tags {
my $tag = $_[0];
return() unless &is_language_tag($tag);
my @em; # push 'em real goood!
# For the moment, these legacy variances are few enough that
# we can just handle them here with regexps.
if( $tag =~ m/^[ix]-hakka\b(.*)/i) {push @em, "zh-hakka$1";
} elsif($tag =~ m/^zh-hakka\b(.*)/i) { push @em, "x-hakka$1", "i-hakka$1";
} elsif($tag =~ m/^he\b(.*)/i) { push @em, "iw$1";
} elsif($tag =~ m/^iw\b(.*)/i) { push @em, "he$1";
} elsif($tag =~ m/^in\b(.*)/i) { push @em, "id$1";
} elsif($tag =~ m/^id\b(.*)/i) { push @em, "in$1";
} elsif($tag =~ m/^[ix]-lux\b(.*)/i) { push @em, "lb$1";
} elsif($tag =~ m/^lb\b(.*)/i) { push @em, "i-lux$1", "x-lux$1";
} elsif($tag =~ m/^[ix]-navajo\b(.*)/i) { push @em, "nv$1";
} elsif($tag =~ m/^nv\b(.*)/i) { push @em, "i-navajo$1", "x-navajo$1";
} elsif($tag =~ m/^yi\b(.*)/i) { push @em, "ji$1";
} elsif($tag =~ m/^ji\b(.*)/i) { push @em, "yi$1";
} elsif($tag =~ m/^nb\b(.*)/i) { push @em, "no-bok$1";
} elsif($tag =~ m/^no-bok\b(.*)/i) { push @em, "nb$1";
} elsif($tag =~ m/^nn\b(.*)/i) { push @em, "no-nyn$1";
} elsif($tag =~ m/^no-nyn\b(.*)/i) { push @em, "nn$1";
}
push @em, $alt{$1} . $2 if $tag =~ /^([XIxi])(-.+)/;
return @em;
}
###########################################################################
{
# Init %Panic...
my @panic = ( # MUST all be lowercase!
# Only large ("national") languages make it in this list.
# If you, as a user, are so bizarre that the /only/ language
# you claim to accept is Galician, then no, we won't do you
# the favor of providing Catalan as a panic-fallback for
# you. Because if I start trying to add "little languages" in
# here, I'll just go crazy.
# Scandinavian lgs. All based on opinion and hearsay.
'sv' => [qw(nb no da nn)],
'da' => [qw(nb no sv nn)], # I guess
[qw(no nn nb)], [qw(no nn nb sv da)],
'is' => [qw(da sv no nb nn)],
'fo' => [qw(da is no nb nn sv)], # I guess
# I think this is about the extent of tolerable intelligibility
# among large modern Romance languages.
'pt' => [qw(es ca it fr)], # Portuguese, Spanish, Catalan, Italian, French
'ca' => [qw(es pt it fr)],
'es' => [qw(ca it fr pt)],
'it' => [qw(es fr ca pt)],
'fr' => [qw(es it ca pt)],
# Also assume that speakers of the main Indian languages prefer
# to read/hear Hindi over English
[qw(
as bn gu kn ks kok ml mni mr ne or pa sa sd te ta ur
)] => 'hi',
# Assamese, Bengali, Gujarati, [Hindi,] Kannada (Kanarese), Kashmiri,
# Konkani, Malayalam, Meithei (Manipuri), Marathi, Nepali, Oriya,
# Punjabi, Sanskrit, Sindhi, Telugu, Tamil, and Urdu.
'hi' => [qw(bn pa as or)],
# I welcome finer data for the other Indian languages.
# E.g., what should Oriya's list be, besides just Hindi?
# And the panic languages for English is, of course, nil!
# My guesses at Slavic intelligibility:
([qw(ru be uk)]) x 2, # Russian, Belarusian, Ukrainian
([qw(sr hr bs)]) x 2, # Serbian, Croatian, Bosnian
'cs' => 'sk', 'sk' => 'cs', # Czech + Slovak
'ms' => 'id', 'id' => 'ms', # Malay + Indonesian
'et' => 'fi', 'fi' => 'et', # Estonian + Finnish
#?? 'lo' => 'th', 'th' => 'lo', # Lao + Thai
);
my($k,$v);
while(@panic) {
($k,$v) = splice(@panic,0,2);
foreach my $k (ref($k) ? @$k : $k) {
foreach my $v (ref($v) ? @$v : $v) {
push @{$Panic{$k} ||= []}, $v unless $k eq $v;
}
}
}
}
=item * the function @langs = panic_languages(@accept_languages)
This function takes a list of 0 or more language
tags that constitute a given user's Accept-Language list, and
returns a list of tags for I<other> (non-super)
languages that are probably acceptable to the user, to be
used I<if all else fails>.
For example, if a user accepts only 'ca' (Catalan) and
'es' (Spanish), and the documents/interfaces you have
available are just in German, Italian, and Chinese, then
the user will most likely want the Italian one (and not
the Chinese or German one!), instead of getting
nothing. So C<panic_languages('ca', 'es')> returns
a list containing 'it' (Italian).
English ('en') is I<always> in the return list, but
whether it's at the very end or not depends
on the input languages. This function works by consulting
an internal table that stipulates what common
languages are "close" to each other.
A useful construct you might consider using is:
@fallbacks = super_languages(@accept_languages);
push @fallbacks, panic_languages(
@accept_languages, @fallbacks,
);
=cut
sub panic_languages {
# When in panic or in doubt, run in circles, scream, and shout!
my(@out, %seen);
foreach my $t (@_) {
next unless $t;
next if $seen{$t}++; # so we don't return it or hit it again
# push @out, super_languages($t); # nah, keep that separate
push @out, @{ $Panic{lc $t} || next };
}
return grep !$seen{$_}++, @out, 'en';
}
#---------------------------------------------------------------------------
#---------------------------------------------------------------------------
=item * the function implicate_supers( ...languages... )
This takes a list of strings (which are presumed to be language-tags;
strings that aren't, are ignored); and after each one, this function
inserts super-ordinate forms that don't already appear in the list.
The original list, plus these insertions, is returned.
In other words, it takes this:
pt-br de-DE en-US fr pt-br-janeiro
and returns this:
pt-br pt de-DE de en-US en fr pt-br-janeiro
This function is most useful in the idiom
implicate_supers( I18N::LangTags::Detect::detect() );
(See L<I18N::LangTags::Detect>.)
=item * the function implicate_supers_strictly( ...languages... )
This works like C<implicate_supers> except that the implicated
forms are added to the end of the return list.
In other words, implicate_supers_strictly takes a list of strings
(which are presumed to be language-tags; strings that aren't, are
ignored) and after the whole given list, it inserts the super-ordinate forms
of all given tags, minus any tags that already appear in the input list.
In other words, it takes this:
pt-br de-DE en-US fr pt-br-janeiro
and returns this:
pt-br de-DE en-US fr pt-br-janeiro pt de en
The reason this function has "_strictly" in its name is that when
you're processing an Accept-Language list according to the RFCs, if
you interpret the RFCs quite strictly, then you would use
implicate_supers_strictly, but for normal use (i.e., common-sense use,
as far as I'm concerned) you'd use implicate_supers.
=cut
sub implicate_supers {
my @languages = grep is_language_tag($_), @_;
my %seen_encoded;
foreach my $lang (@languages) {
$seen_encoded{ I18N::LangTags::encode_language_tag($lang) } = 1
}
my(@output_languages);
foreach my $lang (@languages) {
push @output_languages, $lang;
foreach my $s ( I18N::LangTags::super_languages($lang) ) {
# Note that super_languages returns the longest first.
last if $seen_encoded{ I18N::LangTags::encode_language_tag($s) };
push @output_languages, $s;
}
}
return uniq( @output_languages );
}
sub implicate_supers_strictly {
my @tags = grep is_language_tag($_), @_;
return uniq( @_, map super_languages($_), @_ );
}
###########################################################################
1;
__END__
=back
=head1 ABOUT LOWERCASING
I've considered making all the above functions that output language
tags return all those tags strictly in lowercase. Having all your
language tags in lowercase does make some things easier. But you
might as well just lowercase as you like, or call
C<encode_language_tag($lang1)> where appropriate.
=head1 ABOUT UNICODE PLAINTEXT LANGUAGE TAGS
In some future version of I18N::LangTags, I plan to include support
for RFC2482-style language tags -- which are basically just normal
language tags with their ASCII characters shifted into Plane 14.
=head1 SEE ALSO
* L<I18N::LangTags::List|I18N::LangTags::List>
* RFC 3066, C<L<http://www.ietf.org/rfc/rfc3066.txt>>, "Tags for the
Identification of Languages". (Obsoletes RFC 1766)
* RFC 2277, C<L<http://www.ietf.org/rfc/rfc2277.txt>>, "IETF Policy on
Character Sets and Languages".
* RFC 2231, C<L<http://www.ietf.org/rfc/rfc2231.txt>>, "MIME Parameter
Value and Encoded Word Extensions: Character Sets, Languages, and
Continuations".
* RFC 2482, C<L<http://www.ietf.org/rfc/rfc2482.txt>>,
"Language Tagging in Unicode Plain Text".
* Locale::Codes, in
C<L<http://www.perl.com/CPAN/modules/by-module/Locale/>>
* ISO 639-2, "Codes for the representation of names of languages",
including two-letter and three-letter codes,
C<L<http://www.loc.gov/standards/iso639-2/php/code_list.php>>
* The IANA list of registered languages (hopefully up-to-date),
C<L<http://www.iana.org/assignments/language-tags>>
=head1 COPYRIGHT
Copyright (c) 1998+ Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
The programs and documentation in this dist are distributed in
the hope that they will be useful, but without any warranty; without
even the implied warranty of merchantability or fitness for a
particular purpose.
=head1 AUTHOR
Sean M. Burke C<sburke@cpan.org>
=cut

242
gitportable/usr/share/perl5/core_perl/I18N/LangTags/Detect.pm Normal file
View File

@@ -0,0 +1,242 @@
# Time-stamp: "2004-06-20 21:47:55 ADT"
require 5;
package I18N::LangTags::Detect;
use strict;
our ( $MATCH_SUPERS, $USING_LANGUAGE_TAGS,
$USE_LITERALS, $MATCH_SUPERS_TIGHTLY);
BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
# define the constant 'DEBUG' at compile-time
our $VERSION = "1.08";
our @ISA = ();
use I18N::LangTags qw(alternate_language_tags locale2language_tag);
sub _uniq { my %seen; return grep(!($seen{$_}++), @_); }
sub _normalize {
my(@languages) =
map lc($_),
grep $_,
map {; $_, alternate_language_tags($_) } @_;
return _uniq(@languages) if wantarray;
return $languages[0];
}
#---------------------------------------------------------------------------
# The extent of our functional interface:
sub detect () { return __PACKAGE__->ambient_langprefs; }
#===========================================================================
sub ambient_langprefs { # always returns things untainted
my $base_class = $_[0];
return $base_class->http_accept_langs
if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI
# it's off in its own routine because it's complicated
# Not running as a CGI: try to puzzle out from the environment
my @languages;
foreach my $envname (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) {
next unless $ENV{$envname};
DEBUG and print "Noting \$$envname: $ENV{$envname}\n";
push @languages,
map locale2language_tag($_),
# if it's a lg tag, fine, pass thru (untainted)
# if it's a locale ID, try converting to a lg tag (untainted),
# otherwise nix it.
split m/[,:]/,
$ENV{$envname}
;
last; # first one wins
}
if($ENV{'IGNORE_WIN32_LOCALE'}) {
# no-op
} elsif(&_try_use('Win32::Locale')) {
# If we have that module installed...
push @languages, Win32::Locale::get_language() || ''
if defined &Win32::Locale::get_language;
}
return _normalize @languages;
}
#---------------------------------------------------------------------------
sub http_accept_langs {
# Deal with HTTP "Accept-Language:" stuff. Hassle.
# This code is more lenient than RFC 3282, which you must read.
# Hm. Should I just move this into I18N::LangTags at some point?
no integer;
my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
# (always ends up untainting)
return() unless defined $in and length $in;
$in =~ s/\([^\)]*\)//g; # nix just about any comment
if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
# Very common case: just one language tag
return _normalize $1;
} elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
# Common case these days: just "foo, bar, baz"
return _normalize( $in =~ m/([a-zA-Z][-a-zA-Z]+)/g );
}
# Else it's complicated...
$in =~ s/\s+//g; # Yes, we can just do without the WS!
my @in = $in =~ m/([^,]+)/g;
my %pref;
my $q;
foreach my $tag (@in) {
next unless $tag =~
m/^([a-zA-Z][-a-zA-Z]+)
(?:
;q=
(
\d* # a bit too broad of a RE, but so what.
(?:
\.\d+
)?
)
)?
$
/sx
;
$q = (defined $2 and length $2) ? $2 : 1;
#print "$1 with q=$q\n";
push @{ $pref{$q} }, lc $1;
}
return _normalize(
# Read off %pref, in descending key order...
map @{$pref{$_}},
sort {$b <=> $a}
keys %pref
);
}
#===========================================================================
my %tried = ();
# memoization of whether we've used this module, or found it unusable.
sub _try_use { # Basically a wrapper around "require Modulename"
# "Many men have tried..." "They tried and failed?" "They tried and died."
return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
my $module = $_[0]; # ASSUME sane module name!
{ no strict 'refs';
no warnings 'once';
return($tried{$module} = 1)
if %{$module . "::Lexicon"} or @{$module . "::ISA"};
# weird case: we never use'd it, but there it is!
}
print " About to use $module ...\n" if DEBUG;
{
local $SIG{'__DIE__'};
local @INC = @INC;
pop @INC if $INC[-1] eq '.';
eval "require $module"; # used to be "use $module", but no point in that.
}
if($@) {
print "Error using $module \: $@\n" if DEBUG > 1;
return $tried{$module} = 0;
} else {
print " OK, $module is used\n" if DEBUG;
return $tried{$module} = 1;
}
}
#---------------------------------------------------------------------------
1;
__END__
=head1 NAME
I18N::LangTags::Detect - detect the user's language preferences
=head1 SYNOPSIS
use I18N::LangTags::Detect;
my @user_wants = I18N::LangTags::Detect::detect();
=head1 DESCRIPTION
It is a common problem to want to detect what language(s) the user would
prefer output in.
=head1 FUNCTIONS
This module defines one public function,
C<I18N::LangTags::Detect::detect()>. This function is not exported
(nor is even exportable), and it takes no parameters.
In scalar context, the function returns the most preferred language
tag (or undef if no preference was seen).
In list context (which is usually what you want),
the function returns a
(possibly empty) list of language tags representing (best first) what
languages the user apparently would accept output in. You will
probably want to pass the output of this through
C<I18N::LangTags::implicate_supers_tightly(...)>
or
C<I18N::LangTags::implicate_supers(...)>, like so:
my @languages =
I18N::LangTags::implicate_supers_tightly(
I18N::LangTags::Detect::detect()
);
=head1 ENVIRONMENT
This module looks at several environment variables:
REQUEST_METHOD, HTTP_ACCEPT_LANGUAGE,
LANGUAGE, LC_ALL, LC_MESSAGES, and LANG.
It will also use the L<Win32::Locale> module, if it's installed
and IGNORE_WIN32_LOCALE is not set to a true value in the
environment.
=head1 SEE ALSO
L<I18N::LangTags>, L<Win32::Locale>, L<Locale::Maketext>.
(This module's core code started out as a routine in Locale::Maketext;
but I moved it here once I realized it was more generally useful.)
=head1 COPYRIGHT
Copyright (c) 1998-2004 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
The programs and documentation in this dist are distributed in
the hope that they will be useful, but without any warranty; without
even the implied warranty of merchantability or fitness for a
particular purpose.
=head1 AUTHOR
Sean M. Burke C<sburke@cpan.org>
=cut
# a tip: Put a bit of chopped up pickled ginger in your salad. It's tasty!

1779
gitportable/usr/share/perl5/core_perl/I18N/LangTags/List.pm Normal file
View File

File diff suppressed because it is too large Load Diff

153
gitportable/usr/share/perl5/core_perl/IO/Compress/Adapter/Bzip2.pm Normal file
View File

@@ -0,0 +1,153 @@
package IO::Compress::Adapter::Bzip2 ;
use strict;
use warnings;
use bytes;
use IO::Compress::Base::Common 2.204 qw(:Status);
use Compress::Raw::Bzip2 2.204 ;
our ($VERSION);
$VERSION = '2.204';
sub mkCompObject
{
my $BlockSize100K = shift ;
my $WorkFactor = shift ;
my $Verbosity = shift ;
$BlockSize100K = 1 if ! defined $BlockSize100K ;
$WorkFactor = 0 if ! defined $WorkFactor ;
$Verbosity = 0 if ! defined $Verbosity ;
my ($def, $status) = Compress::Raw::Bzip2->new(1, $BlockSize100K,
$WorkFactor, $Verbosity);
return (undef, "Could not create Deflate object: $status", $status)
if $status != BZ_OK ;
return bless {'Def' => $def,
'Error' => '',
'ErrorNo' => 0,
} ;
}
sub compr
{
my $self = shift ;
my $def = $self->{Def};
my $status = $def->bzdeflate($_[0], $_[1]) ;
$self->{ErrorNo} = $status;
if ($status != BZ_RUN_OK)
{
$self->{Error} = "Deflate Error: $status";
return STATUS_ERROR;
}
return STATUS_OK;
}
sub flush
{
my $self = shift ;
my $def = $self->{Def};
my $status = $def->bzflush($_[0]);
$self->{ErrorNo} = $status;
if ($status != BZ_RUN_OK)
{
$self->{Error} = "Deflate Error: $status";
return STATUS_ERROR;
}
return STATUS_OK;
}
sub close
{
my $self = shift ;
my $def = $self->{Def};
my $status = $def->bzclose($_[0]);
$self->{ErrorNo} = $status;
if ($status != BZ_STREAM_END)
{
$self->{Error} = "Deflate Error: $status";
return STATUS_ERROR;
}
return STATUS_OK;
}
sub reset
{
my $self = shift ;
my $outer = $self->{Outer};
my ($def, $status) = Compress::Raw::Bzip2->new();
$self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ;
if ($status != BZ_OK)
{
$self->{Error} = "Cannot create Deflate object: $status";
return STATUS_ERROR;
}
$self->{Def} = $def;
return STATUS_OK;
}
sub compressedBytes
{
my $self = shift ;
$self->{Def}->compressedBytes();
}
sub uncompressedBytes
{
my $self = shift ;
$self->{Def}->uncompressedBytes();
}
#sub total_out
#{
# my $self = shift ;
# 0;
#}
#
#sub total_in
#{
# my $self = shift ;
# $self->{Def}->total_in();
#}
#
#sub crc32
#{
# my $self = shift ;
# $self->{Def}->crc32();
#}
#
#sub adler32
#{
# my $self = shift ;
# $self->{Def}->adler32();
#}
1;
__END__

192
gitportable/usr/share/perl5/core_perl/IO/Compress/Adapter/Deflate.pm Normal file
View File

@@ -0,0 +1,192 @@
package IO::Compress::Adapter::Deflate ;
use strict;
use warnings;
use bytes;
use IO::Compress::Base::Common 2.204 qw(:Status);
use Compress::Raw::Zlib 2.204 qw( !crc32 !adler32 ) ;
require Exporter;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, @EXPORT, %DEFLATE_CONSTANTS);
$VERSION = '2.204';
@ISA = qw(Exporter);
@EXPORT_OK = @Compress::Raw::Zlib::DEFLATE_CONSTANTS;
%EXPORT_TAGS = %Compress::Raw::Zlib::DEFLATE_CONSTANTS;
@EXPORT = @EXPORT_OK;
%DEFLATE_CONSTANTS = %EXPORT_TAGS ;
sub mkCompObject
{
my $crc32 = shift ;
my $adler32 = shift ;
my $level = shift ;
my $strategy = shift ;
my ($def, $status) = Compress::Raw::Zlib::Deflate->new(
-AppendOutput => 1,
-CRC32 => $crc32,
-ADLER32 => $adler32,
-Level => $level,
-Strategy => $strategy,
-WindowBits => - MAX_WBITS);
return (undef, "Cannot create Deflate object: $status", $status)
if $status != Z_OK;
return bless {'Def' => $def,
'Error' => '',
} ;
}
sub mkCompObject1
{
my $crc32 = shift ;
my $adler32 = shift ;
my $level = shift ;
my $strategy = shift ;
my ($def, $status) = Compress::Raw::Zlib::Deflate->new(
-AppendOutput => 1,
-CRC32 => $crc32,
-ADLER32 => $adler32,
-Level => $level,
-Strategy => $strategy,
-WindowBits => MAX_WBITS);
return (undef, "Cannot create Deflate object: $status", $status)
if $status != Z_OK;
return bless {'Def' => $def,
'Error' => '',
} ;
}
sub compr
{
my $self = shift ;
my $def = $self->{Def};
my $status = $def->deflate($_[0], $_[1]) ;
$self->{ErrorNo} = $status;
if ($status != Z_OK)
{
$self->{Error} = "Deflate Error: $status";
return STATUS_ERROR;
}
return STATUS_OK;
}
sub flush
{
my $self = shift ;
my $def = $self->{Def};
my $opt = $_[1] || Z_FINISH;
my $status = $def->flush($_[0], $opt);
$self->{ErrorNo} = $status;
if ($status != Z_OK)
{
$self->{Error} = "Deflate Error: $status";
return STATUS_ERROR;
}
return STATUS_OK;
}
sub close
{
my $self = shift ;
my $def = $self->{Def};
$def->flush($_[0], Z_FINISH)
if defined $def ;
}
sub reset
{
my $self = shift ;
my $def = $self->{Def};
my $status = $def->deflateReset() ;
$self->{ErrorNo} = $status;
if ($status != Z_OK)
{
$self->{Error} = "Deflate Error: $status";
return STATUS_ERROR;
}
return STATUS_OK;
}
sub deflateParams
{
my $self = shift ;
my $def = $self->{Def};
my $status = $def->deflateParams(@_);
$self->{ErrorNo} = $status;
if ($status != Z_OK)
{
$self->{Error} = "deflateParams Error: $status";
return STATUS_ERROR;
}
return STATUS_OK;
}
#sub total_out
#{
# my $self = shift ;
# $self->{Def}->total_out();
#}
#
#sub total_in
#{
# my $self = shift ;
# $self->{Def}->total_in();
#}
sub compressedBytes
{
my $self = shift ;
$self->{Def}->compressedBytes();
}
sub uncompressedBytes
{
my $self = shift ;
$self->{Def}->uncompressedBytes();
}
sub crc32
{
my $self = shift ;
$self->{Def}->crc32();
}
sub adler32
{
my $self = shift ;
$self->{Def}->adler32();
}
1;
__END__

100
gitportable/usr/share/perl5/core_perl/IO/Compress/Adapter/Identity.pm Normal file
View File

@@ -0,0 +1,100 @@
package IO::Compress::Adapter::Identity ;
use strict;
use warnings;
use bytes;
use IO::Compress::Base::Common 2.204 qw(:Status);
our ($VERSION);
$VERSION = '2.204';
sub mkCompObject
{
my $level = shift ;
my $strategy = shift ;
return bless {
'CompSize' => 0,
'UnCompSize' => 0,
'Error' => '',
'ErrorNo' => 0,
} ;
}
sub compr
{
my $self = shift ;
if (defined ${ $_[0] } && length ${ $_[0] }) {
$self->{CompSize} += length ${ $_[0] } ;
$self->{UnCompSize} = $self->{CompSize} ;
if ( ref $_[1] )
{ ${ $_[1] } .= ${ $_[0] } }
else
{ $_[1] .= ${ $_[0] } }
}
return STATUS_OK ;
}
sub flush
{
my $self = shift ;
return STATUS_OK;
}
sub close
{
my $self = shift ;
return STATUS_OK;
}
sub reset
{
my $self = shift ;
$self->{CompSize} = 0;
$self->{UnCompSize} = 0;
return STATUS_OK;
}
sub deflateParams
{
my $self = shift ;
return STATUS_OK;
}
#sub total_out
#{
# my $self = shift ;
# return $self->{UnCompSize} ;
#}
#
#sub total_in
#{
# my $self = shift ;
# return $self->{UnCompSize} ;
#}
sub compressedBytes
{
my $self = shift ;
return $self->{UnCompSize} ;
}
sub uncompressedBytes
{
my $self = shift ;
return $self->{UnCompSize} ;
}
1;
__END__

1057
gitportable/usr/share/perl5/core_perl/IO/Compress/Base.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1053
gitportable/usr/share/perl5/core_perl/IO/Compress/Base/Common.pm Normal file
View File

File diff suppressed because it is too large Load Diff

824
gitportable/usr/share/perl5/core_perl/IO/Compress/Bzip2.pm Normal file
View File

@@ -0,0 +1,824 @@
package IO::Compress::Bzip2 ;
use strict ;
use warnings;
use bytes;
require Exporter ;
use IO::Compress::Base 2.204 ;
use IO::Compress::Base::Common 2.204 qw();
use IO::Compress::Adapter::Bzip2 2.204 ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error);
$VERSION = '2.204';
$Bzip2Error = '';
@ISA = qw(IO::Compress::Base Exporter);
@EXPORT_OK = qw( $Bzip2Error bzip2 ) ;
%EXPORT_TAGS = %IO::Compress::Base::EXPORT_TAGS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');
sub new
{
my $class = shift ;
my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$Bzip2Error);
return $obj->_create(undef, @_);
}
sub bzip2
{
my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$Bzip2Error);
$obj->_def(@_);
}
sub mkHeader
{
my $self = shift ;
return '';
}
sub getExtraParams
{
my $self = shift ;
use IO::Compress::Base::Common 2.204 qw(:Parse);
return (
'blocksize100k' => [IO::Compress::Base::Common::Parse_unsigned, 1],
'workfactor' => [IO::Compress::Base::Common::Parse_unsigned, 0],
'verbosity' => [IO::Compress::Base::Common::Parse_boolean, 0],
);
}
sub ckParams
{
my $self = shift ;
my $got = shift;
# check that BlockSize100K is a number between 1 & 9
if ($got->parsed('blocksize100k')) {
my $value = $got->getValue('blocksize100k');
return $self->saveErrorString(undef, "Parameter 'BlockSize100K' not between 1 and 9, got $value")
unless defined $value && $value >= 1 && $value <= 9;
}
# check that WorkFactor between 0 & 250
if ($got->parsed('workfactor')) {
my $value = $got->getValue('workfactor');
return $self->saveErrorString(undef, "Parameter 'WorkFactor' not between 0 and 250, got $value")
unless $value >= 0 && $value <= 250;
}
return 1 ;
}
sub mkComp
{
my $self = shift ;
my $got = shift ;
my $BlockSize100K = $got->getValue('blocksize100k');
my $WorkFactor = $got->getValue('workfactor');
my $Verbosity = $got->getValue('verbosity');
my ($obj, $errstr, $errno) = IO::Compress::Adapter::Bzip2::mkCompObject(
$BlockSize100K, $WorkFactor,
$Verbosity);
return $self->saveErrorString(undef, $errstr, $errno)
if ! defined $obj;
return $obj;
}
sub mkTrailer
{
my $self = shift ;
return '';
}
sub mkFinalTrailer
{
return '';
}
#sub newHeader
#{
# my $self = shift ;
# return '';
#}
sub getInverseClass
{
return ('IO::Uncompress::Bunzip2');
}
sub getFileInfo
{
my $self = shift ;
my $params = shift;
my $file = shift ;
}
1;
__END__
=head1 NAME
IO::Compress::Bzip2 - Write bzip2 files/buffers
=head1 SYNOPSIS
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
my $status = bzip2 $input => $output [,OPTS]
or die "bzip2 failed: $Bzip2Error\n";
my $z = IO::Compress::Bzip2->new( $output [,OPTS] )
or die "bzip2 failed: $Bzip2Error\n";
$z->print($string);
$z->printf($format, $string);
$z->write($string);
$z->syswrite($string [, $length, $offset]);
$z->flush();
$z->tell();
$z->eof();
$z->seek($position, $whence);
$z->binmode();
$z->fileno();
$z->opened();
$z->autoflush();
$z->input_line_number();
$z->newStream( [OPTS] );
$z->close() ;
$Bzip2Error ;
# IO::File mode
print $z $string;
printf $z $format, $string;
tell $z
eof $z
seek $z, $position, $whence
binmode $z
fileno $z
close $z ;
=head1 DESCRIPTION
This module provides a Perl interface that allows writing bzip2
compressed data to files or buffer.
For reading bzip2 files/buffers, see the companion module
L<IO::Uncompress::Bunzip2|IO::Uncompress::Bunzip2>.
=head1 Functional Interface
A top-level function, C<bzip2>, is provided to carry out
"one-shot" compression between buffers and/or files. For finer
control over the compression process, see the L</"OO Interface">
section.
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
bzip2 $input_filename_or_reference => $output_filename_or_reference [,OPTS]
or die "bzip2 failed: $Bzip2Error\n";
The functional interface needs Perl5.005 or better.
=head2 bzip2 $input_filename_or_reference => $output_filename_or_reference [, OPTS]
C<bzip2> expects at least two parameters,
C<$input_filename_or_reference> and C<$output_filename_or_reference>
and zero or more optional parameters (see L</Optional Parameters>)
=head3 The C<$input_filename_or_reference> parameter
The parameter, C<$input_filename_or_reference>, is used to define the
source of the uncompressed data.
It can take one of the following forms:
=over 5
=item A filename
If the C<$input_filename_or_reference> parameter is a simple scalar, it is
assumed to be a filename. This file will be opened for reading and the
input data will be read from it.
=item A filehandle
If the C<$input_filename_or_reference> parameter is a filehandle, the input
data will be read from it. The string '-' can be used as an alias for
standard input.
=item A scalar reference
If C<$input_filename_or_reference> is a scalar reference, the input data
will be read from C<$$input_filename_or_reference>.
=item An array reference
If C<$input_filename_or_reference> is an array reference, each element in
the array must be a filename.
The input data will be read from each file in turn.
The complete array will be walked to ensure that it only
contains valid filenames before any data is compressed.
=item An Input FileGlob string
If C<$input_filename_or_reference> is a string that is delimited by the
characters "<" and ">" C<bzip2> will assume that it is an
I<input fileglob string>. The input is the list of files that match the
fileglob.
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
If the C<$input_filename_or_reference> parameter is any other type,
C<undef> will be returned.
=head3 The C<$output_filename_or_reference> parameter
The parameter C<$output_filename_or_reference> is used to control the
destination of the compressed data. This parameter can take one of
these forms.
=over 5
=item A filename
If the C<$output_filename_or_reference> parameter is a simple scalar, it is
assumed to be a filename. This file will be opened for writing and the
compressed data will be written to it.
=item A filehandle
If the C<$output_filename_or_reference> parameter is a filehandle, the
compressed data will be written to it. The string '-' can be used as
an alias for standard output.
=item A scalar reference
If C<$output_filename_or_reference> is a scalar reference, the
compressed data will be stored in C<$$output_filename_or_reference>.
=item An Array Reference
If C<$output_filename_or_reference> is an array reference,
the compressed data will be pushed onto the array.
=item An Output FileGlob
If C<$output_filename_or_reference> is a string that is delimited by the
characters "<" and ">" C<bzip2> will assume that it is an
I<output fileglob string>. The output is the list of files that match the
fileglob.
When C<$output_filename_or_reference> is an fileglob string,
C<$input_filename_or_reference> must also be a fileglob string. Anything
else is an error.
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
If the C<$output_filename_or_reference> parameter is any other type,
C<undef> will be returned.
=head2 Notes
When C<$input_filename_or_reference> maps to multiple files/buffers and
C<$output_filename_or_reference> is a single
file/buffer the input files/buffers will be stored
in C<$output_filename_or_reference> as a concatenated series of compressed data streams.
=head2 Optional Parameters
The optional parameters for the one-shot function C<bzip2>
are (for the most part) identical to those used with the OO interface defined in the
L</"Constructor Options"> section. The exceptions are listed below
=over 5
=item C<< AutoClose => 0|1 >>
This option applies to any input or output data streams to
C<bzip2> that are filehandles.
If C<AutoClose> is specified, and the value is true, it will result in all
input and/or output filehandles being closed once C<bzip2> has
completed.
This parameter defaults to 0.
=item C<< BinModeIn => 0|1 >>
This option is now a no-op. All files will be read in binmode.
=item C<< Append => 0|1 >>
The behaviour of this option is dependent on the type of output data
stream.
=over 5
=item * A Buffer
If C<Append> is enabled, all compressed data will be append to the end of
the output buffer. Otherwise the output buffer will be cleared before any
compressed data is written to it.
=item * A Filename
If C<Append> is enabled, the file will be opened in append mode. Otherwise
the contents of the file, if any, will be truncated before any compressed
data is written to it.
=item * A Filehandle
If C<Append> is enabled, the filehandle will be positioned to the end of
the file via a call to C<seek> before any compressed data is
written to it. Otherwise the file pointer will not be moved.
=back
When C<Append> is specified, and set to true, it will I<append> all compressed
data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any compressed data. If the output is a filename, it will be opened for
appending. If the output is a buffer, all compressed data will be
appended to the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
When the output is a filename, it will truncate the contents of the file
before writing any compressed data. If the output is a filehandle
its position will not be changed. If the output is a buffer, it will be
wiped before any compressed data is output.
Defaults to 0.
=back
=head2 Examples
Here are a few example that show the capabilities of the module.
=head3 Streaming
This very simple command line example demonstrates the streaming capabilities of the module.
The code reads data from STDIN, compresses it, and writes the compressed data to STDOUT.
$ echo hello world | perl -MIO::Compress::Bzip2=bzip2 -e 'bzip2 \*STDIN => \*STDOUT' >output.bz2
The special filename "-" can be used as a standin for both C<\*STDIN> and C<\*STDOUT>,
so the above can be rewritten as
$ echo hello world | perl -MIO::Compress::Bzip2=bzip2 -e 'bzip2 "-" => "-"' >output.bz2
=head3 Compressing a file from the filesystem
To read the contents of the file C<file1.txt> and write the compressed
data to the file C<file1.txt.bz2>.
use strict ;
use warnings ;
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
my $input = "file1.txt";
bzip2 $input => "$input.bz2"
or die "bzip2 failed: $Bzip2Error\n";
=head3 Reading from a Filehandle and writing to an in-memory buffer
To read from an existing Perl filehandle, C<$input>, and write the
compressed data to a buffer, C<$buffer>.
use strict ;
use warnings ;
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
use IO::File ;
my $input = IO::File->new( "<file1.txt" )
or die "Cannot open 'file1.txt': $!\n" ;
my $buffer ;
bzip2 $input => \$buffer
or die "bzip2 failed: $Bzip2Error\n";
=head3 Compressing multiple files
To compress all files in the directory "/my/home" that match "*.txt"
and store the compressed data in the same directory
use strict ;
use warnings ;
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
bzip2 '</my/home/*.txt>' => '<*.bz2>'
or die "bzip2 failed: $Bzip2Error\n";
and if you want to compress each file one at a time, this will do the trick
use strict ;
use warnings ;
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
for my $input ( glob "/my/home/*.txt" )
{
my $output = "$input.bz2" ;
bzip2 $input => $output
or die "Error compressing '$input': $Bzip2Error\n";
}
=head1 OO Interface
=head2 Constructor
The format of the constructor for C<IO::Compress::Bzip2> is shown below
my $z = IO::Compress::Bzip2->new( $output [,OPTS] )
or die "IO::Compress::Bzip2 failed: $Bzip2Error\n";
It returns an C<IO::Compress::Bzip2> object on success and undef on failure.
The variable C<$Bzip2Error> will contain an error message on failure.
If you are running Perl 5.005 or better the object, C<$z>, returned from
IO::Compress::Bzip2 can be used exactly like an L<IO::File|IO::File> filehandle.
This means that all normal output file operations can be carried out
with C<$z>.
For example, to write to a compressed file/buffer you can use either of
these forms
$z->print("hello world\n");
print $z "hello world\n";
The mandatory parameter C<$output> is used to control the destination
of the compressed data. This parameter can take one of these forms.
=over 5
=item A filename
If the C<$output> parameter is a simple scalar, it is assumed to be a
filename. This file will be opened for writing and the compressed data
will be written to it.
=item A filehandle
If the C<$output> parameter is a filehandle, the compressed data will be
written to it.
The string '-' can be used as an alias for standard output.
=item A scalar reference
If C<$output> is a scalar reference, the compressed data will be stored
in C<$$output>.
=back
If the C<$output> parameter is any other type, C<IO::Compress::Bzip2>::new will
return undef.
=head2 Constructor Options
C<OPTS> is any combination of zero or more the following options:
=over 5
=item C<< AutoClose => 0|1 >>
This option is only valid when the C<$output> parameter is a filehandle. If
specified, and the value is true, it will result in the C<$output> being
closed once either the C<close> method is called or the C<IO::Compress::Bzip2>
object is destroyed.
This parameter defaults to 0.
=item C<< Append => 0|1 >>
Opens C<$output> in append mode.
The behaviour of this option is dependent on the type of C<$output>.
=over 5
=item * A Buffer
If C<$output> is a buffer and C<Append> is enabled, all compressed data
will be append to the end of C<$output>. Otherwise C<$output> will be
cleared before any data is written to it.
=item * A Filename
If C<$output> is a filename and C<Append> is enabled, the file will be
opened in append mode. Otherwise the contents of the file, if any, will be
truncated before any compressed data is written to it.
=item * A Filehandle
If C<$output> is a filehandle, the file pointer will be positioned to the
end of the file via a call to C<seek> before any compressed data is written
to it. Otherwise the file pointer will not be moved.
=back
This parameter defaults to 0.
=item C<< BlockSize100K => number >>
Specify the number of 100K blocks bzip2 uses during compression.
Valid values are from 1 to 9, where 9 is best compression.
The default is 1.
=item C<< WorkFactor => number >>
Specifies how much effort bzip2 should take before resorting to a slower
fallback compression algorithm.
Valid values range from 0 to 250, where 0 means use the default value 30.
The default is 0.
=item C<< Strict => 0|1 >>
This is a placeholder option.
=back
=head2 Examples
TODO
=head1 Methods
=head2 print
Usage is
$z->print($data)
print $z $data
Compresses and outputs the contents of the C<$data> parameter. This
has the same behaviour as the C<print> built-in.
Returns true if successful.
=head2 printf
Usage is
$z->printf($format, $data)
printf $z $format, $data
Compresses and outputs the contents of the C<$data> parameter.
Returns true if successful.
=head2 syswrite
Usage is
$z->syswrite $data
$z->syswrite $data, $length
$z->syswrite $data, $length, $offset
Compresses and outputs the contents of the C<$data> parameter.
Returns the number of uncompressed bytes written, or C<undef> if
unsuccessful.
=head2 write
Usage is
$z->write $data
$z->write $data, $length
$z->write $data, $length, $offset
Compresses and outputs the contents of the C<$data> parameter.
Returns the number of uncompressed bytes written, or C<undef> if
unsuccessful.
=head2 flush
Usage is
$z->flush;
Flushes any pending compressed data to the output file/buffer.
TODO
Returns true on success.
=head2 tell
Usage is
$z->tell()
tell $z
Returns the uncompressed file offset.
=head2 eof
Usage is
$z->eof();
eof($z);
Returns true if the C<close> method has been called.
=head2 seek
$z->seek($position, $whence);
seek($z, $position, $whence);
Provides a sub-set of the C<seek> functionality, with the restriction
that it is only legal to seek forward in the output file/buffer.
It is a fatal error to attempt to seek backward.
Empty parts of the file/buffer will have NULL (0x00) bytes written to them.
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
SEEK_CUR or SEEK_END.
Returns 1 on success, 0 on failure.
=head2 binmode
Usage is
$z->binmode
binmode $z ;
This is a noop provided for completeness.
=head2 opened
$z->opened()
Returns true if the object currently refers to a opened file/buffer.
=head2 autoflush
my $prev = $z->autoflush()
my $prev = $z->autoflush(EXPR)
If the C<$z> object is associated with a file or a filehandle, this method
returns the current autoflush setting for the underlying filehandle. If
C<EXPR> is present, and is non-zero, it will enable flushing after every
write/print operation.
If C<$z> is associated with a buffer, this method has no effect and always
returns C<undef>.
B<Note> that the special variable C<$|> B<cannot> be used to set or
retrieve the autoflush setting.
=head2 input_line_number
$z->input_line_number()
$z->input_line_number(EXPR)
This method always returns C<undef> when compressing.
=head2 fileno
$z->fileno()
fileno($z)
If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
If the C<$z> object is associated with a buffer, this method will return
C<undef>.
=head2 close
$z->close() ;
close $z ;
Flushes any pending compressed data and then closes the output file/buffer.
For most versions of Perl this method will be automatically invoked if
the IO::Compress::Bzip2 object is destroyed (either explicitly or by the
variable with the reference to the object going out of scope). The
exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
these cases, the C<close> method will be called automatically, but
not until global destruction of all live objects when the program is
terminating.
Therefore, if you want your scripts to be able to run on all versions
of Perl, you should call C<close> explicitly and not rely on automatic
closing.
Returns true on success, otherwise 0.
If the C<AutoClose> option has been enabled when the IO::Compress::Bzip2
object was created, and the object is associated with a file, the
underlying file will also be closed.
=head2 newStream([OPTS])
Usage is
$z->newStream( [OPTS] )
Closes the current compressed data stream and starts a new one.
OPTS consists of any of the options that are available when creating
the C<$z> object.
See the L</"Constructor Options"> section for more details.
=head1 Importing
No symbolic constants are required by IO::Compress::Bzip2 at present.
=over 5
=item :all
Imports C<bzip2> and C<$Bzip2Error>.
Same as doing this
use IO::Compress::Bzip2 qw(bzip2 $Bzip2Error) ;
=back
=head1 EXAMPLES
=head2 Apache::GZip Revisited
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
=head2 Working with Net::FTP
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
=head1 SUPPORT
General feedback/questions/bug reports should be sent to
L<https://github.com/pmqs/IO-Compress/issues> (preferred) or
L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>.
=head1 SEE ALSO
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
L<IO::Compress::FAQ|IO::Compress::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
L<IO::Zlib|IO::Zlib>
The primary site for the bzip2 program is L<https://sourceware.org/bzip2/>.
See the module L<Compress::Bzip2|Compress::Bzip2>
=head1 AUTHOR
This module was written by Paul Marquess, C<pmqs@cpan.org>.
=head1 MODIFICATION HISTORY
See the Changes file.
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2005-2023 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

898
gitportable/usr/share/perl5/core_perl/IO/Compress/Deflate.pm Normal file
View File

@@ -0,0 +1,898 @@
package IO::Compress::Deflate ;
require 5.006 ;
use strict ;
use warnings;
use bytes;
require Exporter ;
use IO::Compress::RawDeflate 2.204 ();
use IO::Compress::Adapter::Deflate 2.204 ;
use IO::Compress::Zlib::Constants 2.204 ;
use IO::Compress::Base::Common 2.204 qw();
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $DeflateError);
$VERSION = '2.204';
$DeflateError = '';
@ISA = qw(IO::Compress::RawDeflate Exporter);
@EXPORT_OK = qw( $DeflateError deflate ) ;
%EXPORT_TAGS = %IO::Compress::RawDeflate::DEFLATE_CONSTANTS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
Exporter::export_ok_tags('all');
sub new
{
my $class = shift ;
my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$DeflateError);
return $obj->_create(undef, @_);
}
sub deflate
{
my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$DeflateError);
return $obj->_def(@_);
}
sub mkComp
{
my $self = shift ;
my $got = shift ;
my ($obj, $errstr, $errno) = IO::Compress::Adapter::Deflate::mkCompObject1(
$got->getValue('crc32'),
$got->getValue('adler32'),
$got->getValue('level'),
$got->getValue('strategy')
);
return $self->saveErrorString(undef, $errstr, $errno)
if ! defined $obj;
return $obj;
}
sub mkHeader
{
my $self = shift ;
return '';
}
sub mkTrailer
{
my $self = shift ;
return '';
}
sub mkFinalTrailer
{
return '';
}
sub getExtraParams
{
my $self = shift ;
return $self->getZlibParams(),
}
sub getInverseClass
{
no warnings 'once';
return ('IO::Uncompress::Inflate',
\$IO::Uncompress::Inflate::InflateError);
}
sub getFileInfo
{
my $self = shift ;
my $params = shift;
my $file = shift ;
}
1;
__END__
=head1 NAME
IO::Compress::Deflate - Write RFC 1950 files/buffers
=head1 SYNOPSIS
use IO::Compress::Deflate qw(deflate $DeflateError) ;
my $status = deflate $input => $output [,OPTS]
or die "deflate failed: $DeflateError\n";
my $z = IO::Compress::Deflate->new( $output [,OPTS] )
or die "deflate failed: $DeflateError\n";
$z->print($string);
$z->printf($format, $string);
$z->write($string);
$z->syswrite($string [, $length, $offset]);
$z->flush();
$z->tell();
$z->eof();
$z->seek($position, $whence);
$z->binmode();
$z->fileno();
$z->opened();
$z->autoflush();
$z->input_line_number();
$z->newStream( [OPTS] );
$z->deflateParams();
$z->close() ;
$DeflateError ;
# IO::File mode
print $z $string;
printf $z $format, $string;
tell $z
eof $z
seek $z, $position, $whence
binmode $z
fileno $z
close $z ;
=head1 DESCRIPTION
This module provides a Perl interface that allows writing compressed
data to files or buffer as defined in RFC 1950.
For reading RFC 1950 files/buffers, see the companion module
L<IO::Uncompress::Inflate|IO::Uncompress::Inflate>.
=head1 Functional Interface
A top-level function, C<deflate>, is provided to carry out
"one-shot" compression between buffers and/or files. For finer
control over the compression process, see the L</"OO Interface">
section.
use IO::Compress::Deflate qw(deflate $DeflateError) ;
deflate $input_filename_or_reference => $output_filename_or_reference [,OPTS]
or die "deflate failed: $DeflateError\n";
The functional interface needs Perl5.005 or better.
=head2 deflate $input_filename_or_reference => $output_filename_or_reference [, OPTS]
C<deflate> expects at least two parameters,
C<$input_filename_or_reference> and C<$output_filename_or_reference>
and zero or more optional parameters (see L</Optional Parameters>)
=head3 The C<$input_filename_or_reference> parameter
The parameter, C<$input_filename_or_reference>, is used to define the
source of the uncompressed data.
It can take one of the following forms:
=over 5
=item A filename
If the C<$input_filename_or_reference> parameter is a simple scalar, it is
assumed to be a filename. This file will be opened for reading and the
input data will be read from it.
=item A filehandle
If the C<$input_filename_or_reference> parameter is a filehandle, the input
data will be read from it. The string '-' can be used as an alias for
standard input.
=item A scalar reference
If C<$input_filename_or_reference> is a scalar reference, the input data
will be read from C<$$input_filename_or_reference>.
=item An array reference
If C<$input_filename_or_reference> is an array reference, each element in
the array must be a filename.
The input data will be read from each file in turn.
The complete array will be walked to ensure that it only
contains valid filenames before any data is compressed.
=item An Input FileGlob string
If C<$input_filename_or_reference> is a string that is delimited by the
characters "<" and ">" C<deflate> will assume that it is an
I<input fileglob string>. The input is the list of files that match the
fileglob.
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
If the C<$input_filename_or_reference> parameter is any other type,
C<undef> will be returned.
=head3 The C<$output_filename_or_reference> parameter
The parameter C<$output_filename_or_reference> is used to control the
destination of the compressed data. This parameter can take one of
these forms.
=over 5
=item A filename
If the C<$output_filename_or_reference> parameter is a simple scalar, it is
assumed to be a filename. This file will be opened for writing and the
compressed data will be written to it.
=item A filehandle
If the C<$output_filename_or_reference> parameter is a filehandle, the
compressed data will be written to it. The string '-' can be used as
an alias for standard output.
=item A scalar reference
If C<$output_filename_or_reference> is a scalar reference, the
compressed data will be stored in C<$$output_filename_or_reference>.
=item An Array Reference
If C<$output_filename_or_reference> is an array reference,
the compressed data will be pushed onto the array.
=item An Output FileGlob
If C<$output_filename_or_reference> is a string that is delimited by the
characters "<" and ">" C<deflate> will assume that it is an
I<output fileglob string>. The output is the list of files that match the
fileglob.
When C<$output_filename_or_reference> is an fileglob string,
C<$input_filename_or_reference> must also be a fileglob string. Anything
else is an error.
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
If the C<$output_filename_or_reference> parameter is any other type,
C<undef> will be returned.
=head2 Notes
When C<$input_filename_or_reference> maps to multiple files/buffers and
C<$output_filename_or_reference> is a single
file/buffer the input files/buffers will be stored
in C<$output_filename_or_reference> as a concatenated series of compressed data streams.
=head2 Optional Parameters
The optional parameters for the one-shot function C<deflate>
are (for the most part) identical to those used with the OO interface defined in the
L</"Constructor Options"> section. The exceptions are listed below
=over 5
=item C<< AutoClose => 0|1 >>
This option applies to any input or output data streams to
C<deflate> that are filehandles.
If C<AutoClose> is specified, and the value is true, it will result in all
input and/or output filehandles being closed once C<deflate> has
completed.
This parameter defaults to 0.
=item C<< BinModeIn => 0|1 >>
This option is now a no-op. All files will be read in binmode.
=item C<< Append => 0|1 >>
The behaviour of this option is dependent on the type of output data
stream.
=over 5
=item * A Buffer
If C<Append> is enabled, all compressed data will be append to the end of
the output buffer. Otherwise the output buffer will be cleared before any
compressed data is written to it.
=item * A Filename
If C<Append> is enabled, the file will be opened in append mode. Otherwise
the contents of the file, if any, will be truncated before any compressed
data is written to it.
=item * A Filehandle
If C<Append> is enabled, the filehandle will be positioned to the end of
the file via a call to C<seek> before any compressed data is
written to it. Otherwise the file pointer will not be moved.
=back
When C<Append> is specified, and set to true, it will I<append> all compressed
data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any compressed data. If the output is a filename, it will be opened for
appending. If the output is a buffer, all compressed data will be
appended to the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
When the output is a filename, it will truncate the contents of the file
before writing any compressed data. If the output is a filehandle
its position will not be changed. If the output is a buffer, it will be
wiped before any compressed data is output.
Defaults to 0.
=back
=head2 Examples
Here are a few example that show the capabilities of the module.
=head3 Streaming
This very simple command line example demonstrates the streaming capabilities of the module.
The code reads data from STDIN, compresses it, and writes the compressed data to STDOUT.
$ echo hello world | perl -MIO::Compress::Deflate=deflate -e 'deflate \*STDIN => \*STDOUT' >output.1950
The special filename "-" can be used as a standin for both C<\*STDIN> and C<\*STDOUT>,
so the above can be rewritten as
$ echo hello world | perl -MIO::Compress::Deflate=deflate -e 'deflate "-" => "-"' >output.1950
=head3 Compressing a file from the filesystem
To read the contents of the file C<file1.txt> and write the compressed
data to the file C<file1.txt.1950>.
use strict ;
use warnings ;
use IO::Compress::Deflate qw(deflate $DeflateError) ;
my $input = "file1.txt";
deflate $input => "$input.1950"
or die "deflate failed: $DeflateError\n";
=head3 Reading from a Filehandle and writing to an in-memory buffer
To read from an existing Perl filehandle, C<$input>, and write the
compressed data to a buffer, C<$buffer>.
use strict ;
use warnings ;
use IO::Compress::Deflate qw(deflate $DeflateError) ;
use IO::File ;
my $input = IO::File->new( "<file1.txt" )
or die "Cannot open 'file1.txt': $!\n" ;
my $buffer ;
deflate $input => \$buffer
or die "deflate failed: $DeflateError\n";
=head3 Compressing multiple files
To compress all files in the directory "/my/home" that match "*.txt"
and store the compressed data in the same directory
use strict ;
use warnings ;
use IO::Compress::Deflate qw(deflate $DeflateError) ;
deflate '</my/home/*.txt>' => '<*.1950>'
or die "deflate failed: $DeflateError\n";
and if you want to compress each file one at a time, this will do the trick
use strict ;
use warnings ;
use IO::Compress::Deflate qw(deflate $DeflateError) ;
for my $input ( glob "/my/home/*.txt" )
{
my $output = "$input.1950" ;
deflate $input => $output
or die "Error compressing '$input': $DeflateError\n";
}
=head1 OO Interface
=head2 Constructor
The format of the constructor for C<IO::Compress::Deflate> is shown below
my $z = IO::Compress::Deflate->new( $output [,OPTS] )
or die "IO::Compress::Deflate failed: $DeflateError\n";
It returns an C<IO::Compress::Deflate> object on success and undef on failure.
The variable C<$DeflateError> will contain an error message on failure.
If you are running Perl 5.005 or better the object, C<$z>, returned from
IO::Compress::Deflate can be used exactly like an L<IO::File|IO::File> filehandle.
This means that all normal output file operations can be carried out
with C<$z>.
For example, to write to a compressed file/buffer you can use either of
these forms
$z->print("hello world\n");
print $z "hello world\n";
The mandatory parameter C<$output> is used to control the destination
of the compressed data. This parameter can take one of these forms.
=over 5
=item A filename
If the C<$output> parameter is a simple scalar, it is assumed to be a
filename. This file will be opened for writing and the compressed data
will be written to it.
=item A filehandle
If the C<$output> parameter is a filehandle, the compressed data will be
written to it.
The string '-' can be used as an alias for standard output.
=item A scalar reference
If C<$output> is a scalar reference, the compressed data will be stored
in C<$$output>.
=back
If the C<$output> parameter is any other type, C<IO::Compress::Deflate>::new will
return undef.
=head2 Constructor Options
C<OPTS> is any combination of zero or more the following options:
=over 5
=item C<< AutoClose => 0|1 >>
This option is only valid when the C<$output> parameter is a filehandle. If
specified, and the value is true, it will result in the C<$output> being
closed once either the C<close> method is called or the C<IO::Compress::Deflate>
object is destroyed.
This parameter defaults to 0.
=item C<< Append => 0|1 >>
Opens C<$output> in append mode.
The behaviour of this option is dependent on the type of C<$output>.
=over 5
=item * A Buffer
If C<$output> is a buffer and C<Append> is enabled, all compressed data
will be append to the end of C<$output>. Otherwise C<$output> will be
cleared before any data is written to it.
=item * A Filename
If C<$output> is a filename and C<Append> is enabled, the file will be
opened in append mode. Otherwise the contents of the file, if any, will be
truncated before any compressed data is written to it.
=item * A Filehandle
If C<$output> is a filehandle, the file pointer will be positioned to the
end of the file via a call to C<seek> before any compressed data is written
to it. Otherwise the file pointer will not be moved.
=back
This parameter defaults to 0.
=item C<< Merge => 0|1 >>
This option is used to compress input data and append it to an existing
compressed data stream in C<$output>. The end result is a single compressed
data stream stored in C<$output>.
It is a fatal error to attempt to use this option when C<$output> is not an
RFC 1950 data stream.
There are a number of other limitations with the C<Merge> option:
=over 5
=item 1
This module needs to have been built with zlib 1.2.1 or better to work. A
fatal error will be thrown if C<Merge> is used with an older version of
zlib.
=item 2
If C<$output> is a file or a filehandle, it must be seekable.
=back
This parameter defaults to 0.
=item -Level
Defines the compression level used by zlib. The value should either be
a number between 0 and 9 (0 means no compression and 9 is maximum
compression), or one of the symbolic constants defined below.
Z_NO_COMPRESSION
Z_BEST_SPEED
Z_BEST_COMPRESSION
Z_DEFAULT_COMPRESSION
The default is Z_DEFAULT_COMPRESSION.
Note, these constants are not imported by C<IO::Compress::Deflate> by default.
use IO::Compress::Deflate qw(:strategy);
use IO::Compress::Deflate qw(:constants);
use IO::Compress::Deflate qw(:all);
=item -Strategy
Defines the strategy used to tune the compression. Use one of the symbolic
constants defined below.
Z_FILTERED
Z_HUFFMAN_ONLY
Z_RLE
Z_FIXED
Z_DEFAULT_STRATEGY
The default is Z_DEFAULT_STRATEGY.
=item C<< Strict => 0|1 >>
This is a placeholder option.
=back
=head2 Examples
TODO
=head1 Methods
=head2 print
Usage is
$z->print($data)
print $z $data
Compresses and outputs the contents of the C<$data> parameter. This
has the same behaviour as the C<print> built-in.
Returns true if successful.
=head2 printf
Usage is
$z->printf($format, $data)
printf $z $format, $data
Compresses and outputs the contents of the C<$data> parameter.
Returns true if successful.
=head2 syswrite
Usage is
$z->syswrite $data
$z->syswrite $data, $length
$z->syswrite $data, $length, $offset
Compresses and outputs the contents of the C<$data> parameter.
Returns the number of uncompressed bytes written, or C<undef> if
unsuccessful.
=head2 write
Usage is
$z->write $data
$z->write $data, $length
$z->write $data, $length, $offset
Compresses and outputs the contents of the C<$data> parameter.
Returns the number of uncompressed bytes written, or C<undef> if
unsuccessful.
=head2 flush
Usage is
$z->flush;
$z->flush($flush_type);
Flushes any pending compressed data to the output file/buffer.
This method takes an optional parameter, C<$flush_type>, that controls
how the flushing will be carried out. By default the C<$flush_type>
used is C<Z_FINISH>. Other valid values for C<$flush_type> are
C<Z_NO_FLUSH>, C<Z_SYNC_FLUSH>, C<Z_FULL_FLUSH> and C<Z_BLOCK>. It is
strongly recommended that you only set the C<flush_type> parameter if
you fully understand the implications of what it does - overuse of C<flush>
can seriously degrade the level of compression achieved. See the C<zlib>
documentation for details.
Returns true on success.
=head2 tell
Usage is
$z->tell()
tell $z
Returns the uncompressed file offset.
=head2 eof
Usage is
$z->eof();
eof($z);
Returns true if the C<close> method has been called.
=head2 seek
$z->seek($position, $whence);
seek($z, $position, $whence);
Provides a sub-set of the C<seek> functionality, with the restriction
that it is only legal to seek forward in the output file/buffer.
It is a fatal error to attempt to seek backward.
Empty parts of the file/buffer will have NULL (0x00) bytes written to them.
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
SEEK_CUR or SEEK_END.
Returns 1 on success, 0 on failure.
=head2 binmode
Usage is
$z->binmode
binmode $z ;
This is a noop provided for completeness.
=head2 opened
$z->opened()
Returns true if the object currently refers to a opened file/buffer.
=head2 autoflush
my $prev = $z->autoflush()
my $prev = $z->autoflush(EXPR)
If the C<$z> object is associated with a file or a filehandle, this method
returns the current autoflush setting for the underlying filehandle. If
C<EXPR> is present, and is non-zero, it will enable flushing after every
write/print operation.
If C<$z> is associated with a buffer, this method has no effect and always
returns C<undef>.
B<Note> that the special variable C<$|> B<cannot> be used to set or
retrieve the autoflush setting.
=head2 input_line_number
$z->input_line_number()
$z->input_line_number(EXPR)
This method always returns C<undef> when compressing.
=head2 fileno
$z->fileno()
fileno($z)
If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
If the C<$z> object is associated with a buffer, this method will return
C<undef>.
=head2 close
$z->close() ;
close $z ;
Flushes any pending compressed data and then closes the output file/buffer.
For most versions of Perl this method will be automatically invoked if
the IO::Compress::Deflate object is destroyed (either explicitly or by the
variable with the reference to the object going out of scope). The
exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
these cases, the C<close> method will be called automatically, but
not until global destruction of all live objects when the program is
terminating.
Therefore, if you want your scripts to be able to run on all versions
of Perl, you should call C<close> explicitly and not rely on automatic
closing.
Returns true on success, otherwise 0.
If the C<AutoClose> option has been enabled when the IO::Compress::Deflate
object was created, and the object is associated with a file, the
underlying file will also be closed.
=head2 newStream([OPTS])
Usage is
$z->newStream( [OPTS] )
Closes the current compressed data stream and starts a new one.
OPTS consists of any of the options that are available when creating
the C<$z> object.
See the L</"Constructor Options"> section for more details.
=head2 deflateParams
Usage is
$z->deflateParams
TODO
=head1 Importing
A number of symbolic constants are required by some methods in
C<IO::Compress::Deflate>. None are imported by default.
=over 5
=item :all
Imports C<deflate>, C<$DeflateError> and all symbolic
constants that can be used by C<IO::Compress::Deflate>. Same as doing this
use IO::Compress::Deflate qw(deflate $DeflateError :constants) ;
=item :constants
Import all symbolic constants. Same as doing this
use IO::Compress::Deflate qw(:flush :level :strategy) ;
=item :flush
These symbolic constants are used by the C<flush> method.
Z_NO_FLUSH
Z_PARTIAL_FLUSH
Z_SYNC_FLUSH
Z_FULL_FLUSH
Z_FINISH
Z_BLOCK
=item :level
These symbolic constants are used by the C<Level> option in the constructor.
Z_NO_COMPRESSION
Z_BEST_SPEED
Z_BEST_COMPRESSION
Z_DEFAULT_COMPRESSION
=item :strategy
These symbolic constants are used by the C<Strategy> option in the constructor.
Z_FILTERED
Z_HUFFMAN_ONLY
Z_RLE
Z_FIXED
Z_DEFAULT_STRATEGY
=back
=head1 EXAMPLES
=head2 Apache::GZip Revisited
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited">
=head2 Working with Net::FTP
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
=head1 SUPPORT
General feedback/questions/bug reports should be sent to
L<https://github.com/pmqs/IO-Compress/issues> (preferred) or
L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>.
=head1 SEE ALSO
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
L<IO::Compress::FAQ|IO::Compress::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
L<IO::Zlib|IO::Zlib>
For RFC 1950, 1951 and 1952 see
L<https://datatracker.ietf.org/doc/html/rfc1950>,
L<https://datatracker.ietf.org/doc/html/rfc1951> and
L<https://datatracker.ietf.org/doc/html/rfc1952>
The I<zlib> compression library was written by Jean-loup Gailly
C<gzip@prep.ai.mit.edu> and Mark Adler C<madler@alumni.caltech.edu>.
The primary site for the I<zlib> compression library is
L<http://www.zlib.org>.
The primary site for the I<zlib-ng> compression library is
L<https://github.com/zlib-ng/zlib-ng>.
The primary site for gzip is L<http://www.gzip.org>.
=head1 AUTHOR
This module was written by Paul Marquess, C<pmqs@cpan.org>.
=head1 MODIFICATION HISTORY
See the Changes file.
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2005-2023 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

1273
gitportable/usr/share/perl5/core_perl/IO/Compress/Gzip.pm Normal file
View File

File diff suppressed because it is too large Load Diff

148
gitportable/usr/share/perl5/core_perl/IO/Compress/Gzip/Constants.pm Normal file
View File

@@ -0,0 +1,148 @@
package IO::Compress::Gzip::Constants;
use strict ;
use warnings;
use bytes;
require Exporter;
our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names);
our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE);
$VERSION = '2.204';
@ISA = qw(Exporter);
@EXPORT= qw(
GZIP_ID_SIZE
GZIP_ID1
GZIP_ID2
GZIP_FLG_DEFAULT
GZIP_FLG_FTEXT
GZIP_FLG_FHCRC
GZIP_FLG_FEXTRA
GZIP_FLG_FNAME
GZIP_FLG_FCOMMENT
GZIP_FLG_RESERVED
GZIP_CM_DEFLATED
GZIP_MIN_HEADER_SIZE
GZIP_TRAILER_SIZE
GZIP_MTIME_DEFAULT
GZIP_XFL_DEFAULT
GZIP_FEXTRA_HEADER_SIZE
GZIP_FEXTRA_MAX_SIZE
GZIP_FEXTRA_SUBFIELD_HEADER_SIZE
GZIP_FEXTRA_SUBFIELD_ID_SIZE
GZIP_FEXTRA_SUBFIELD_LEN_SIZE
GZIP_FEXTRA_SUBFIELD_MAX_SIZE
$GZIP_FNAME_INVALID_CHAR_RE
$GZIP_FCOMMENT_INVALID_CHAR_RE
GZIP_FHCRC_SIZE
GZIP_ISIZE_MAX
GZIP_ISIZE_MOD_VALUE
GZIP_NULL_BYTE
GZIP_OS_DEFAULT
%GZIP_OS_Names
GZIP_MINIMUM_HEADER
);
# Constant names derived from RFC 1952
use constant GZIP_ID_SIZE => 2 ;
use constant GZIP_ID1 => 0x1F;
use constant GZIP_ID2 => 0x8B;
use constant GZIP_MIN_HEADER_SIZE => 10 ;# minimum gzip header size
use constant GZIP_TRAILER_SIZE => 8 ;
use constant GZIP_FLG_DEFAULT => 0x00 ;
use constant GZIP_FLG_FTEXT => 0x01 ;
use constant GZIP_FLG_FHCRC => 0x02 ; # called CONTINUATION in gzip
use constant GZIP_FLG_FEXTRA => 0x04 ;
use constant GZIP_FLG_FNAME => 0x08 ;
use constant GZIP_FLG_FCOMMENT => 0x10 ;
#use constant GZIP_FLG_ENCRYPTED => 0x20 ; # documented in gzip sources
use constant GZIP_FLG_RESERVED => (0x20 | 0x40 | 0x80) ;
use constant GZIP_XFL_DEFAULT => 0x00 ;
use constant GZIP_MTIME_DEFAULT => 0x00 ;
use constant GZIP_FEXTRA_HEADER_SIZE => 2 ;
use constant GZIP_FEXTRA_MAX_SIZE => 0xFFFF ;
use constant GZIP_FEXTRA_SUBFIELD_ID_SIZE => 2 ;
use constant GZIP_FEXTRA_SUBFIELD_LEN_SIZE => 2 ;
use constant GZIP_FEXTRA_SUBFIELD_HEADER_SIZE => GZIP_FEXTRA_SUBFIELD_ID_SIZE +
GZIP_FEXTRA_SUBFIELD_LEN_SIZE;
use constant GZIP_FEXTRA_SUBFIELD_MAX_SIZE => GZIP_FEXTRA_MAX_SIZE -
GZIP_FEXTRA_SUBFIELD_HEADER_SIZE ;
if (ord('A') == 193)
{
# EBCDIC
$GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x3f\xff]';
$GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x0a\x11-\x14\x16-\x3f\xff]';
}
else
{
$GZIP_FNAME_INVALID_CHAR_RE = '[\x00-\x1F\x7F-\x9F]';
$GZIP_FCOMMENT_INVALID_CHAR_RE = '[\x00-\x09\x11-\x1F\x7F-\x9F]';
}
use constant GZIP_FHCRC_SIZE => 2 ; # aka CONTINUATION in gzip
use constant GZIP_CM_DEFLATED => 8 ;
use constant GZIP_NULL_BYTE => "\x00";
use constant GZIP_ISIZE_MAX => 0xFFFFFFFF ;
use constant GZIP_ISIZE_MOD_VALUE => GZIP_ISIZE_MAX + 1 ;
# OS Names sourced from http://www.gzip.org/format.txt
use constant GZIP_OS_DEFAULT=> 0xFF ;
%GZIP_OS_Names = (
0 => 'MS-DOS',
1 => 'Amiga',
2 => 'VMS',
3 => 'Unix',
4 => 'VM/CMS',
5 => 'Atari TOS',
6 => 'HPFS (OS/2, NT)',
7 => 'Macintosh',
8 => 'Z-System',
9 => 'CP/M',
10 => 'TOPS-20',
11 => 'NTFS (NT)',
12 => 'SMS QDOS',
13 => 'Acorn RISCOS',
14 => 'VFAT file system (Win95, NT)',
15 => 'MVS',
16 => 'BeOS',
17 => 'Tandem/NSK',
18 => 'THEOS',
GZIP_OS_DEFAULT() => 'Unknown',
) ;
use constant GZIP_MINIMUM_HEADER => pack("C4 V C C",
GZIP_ID1, GZIP_ID2, GZIP_CM_DEFLATED, GZIP_FLG_DEFAULT,
GZIP_MTIME_DEFAULT, GZIP_XFL_DEFAULT, GZIP_OS_DEFAULT) ;
1;

1016
gitportable/usr/share/perl5/core_perl/IO/Compress/RawDeflate.pm Normal file
View File

File diff suppressed because it is too large Load Diff

2172
gitportable/usr/share/perl5/core_perl/IO/Compress/Zip.pm Normal file
View File

File diff suppressed because it is too large Load Diff

132
gitportable/usr/share/perl5/core_perl/IO/Compress/Zip/Constants.pm Normal file
View File

@@ -0,0 +1,132 @@
package IO::Compress::Zip::Constants;
use strict ;
use warnings;
require Exporter;
our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS);
$VERSION = '2.204';
@ISA = qw(Exporter);
@EXPORT= qw(
ZIP_CM_STORE
ZIP_CM_DEFLATE
ZIP_CM_BZIP2
ZIP_CM_LZMA
ZIP_CM_PPMD
ZIP_CM_XZ
ZIP_CM_ZSTD
ZIP_CM_AES
ZIP_LOCAL_HDR_SIG
ZIP_DATA_HDR_SIG
ZIP_CENTRAL_HDR_SIG
ZIP_END_CENTRAL_HDR_SIG
ZIP64_END_CENTRAL_REC_HDR_SIG
ZIP64_END_CENTRAL_LOC_HDR_SIG
ZIP64_ARCHIVE_EXTRA_SIG
ZIP64_DIGITAL_SIGNATURE_SIG
ZIP_GP_FLAG_ENCRYPTED_MASK
ZIP_GP_FLAG_STREAMING_MASK
ZIP_GP_FLAG_PATCHED_MASK
ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK
ZIP_GP_FLAG_LZMA_EOS_PRESENT
ZIP_GP_FLAG_LANGUAGE_ENCODING
ZIP_EXTRA_ID_ZIP64
ZIP_EXTRA_ID_EXT_TIMESTAMP
ZIP_EXTRA_ID_INFO_ZIP_UNIX2
ZIP_EXTRA_ID_INFO_ZIP_UNIXN
ZIP_EXTRA_ID_INFO_ZIP_Upath
ZIP_EXTRA_ID_INFO_ZIP_Ucom
ZIP_EXTRA_ID_JAVA_EXE
ZIP_OS_CODE_UNIX
ZIP_OS_CODE_DEFAULT
ZIP_IFA_TEXT_MASK
%ZIP_CM_MIN_VERSIONS
ZIP64_MIN_VERSION
ZIP_A_RONLY
ZIP_A_HIDDEN
ZIP_A_SYSTEM
ZIP_A_LABEL
ZIP_A_DIR
ZIP_A_ARCHIVE
);
# Compression types supported
use constant ZIP_CM_STORE => 0 ;
use constant ZIP_CM_DEFLATE => 8 ;
use constant ZIP_CM_BZIP2 => 12 ;
use constant ZIP_CM_LZMA => 14 ;
use constant ZIP_CM_ZSTD => 93 ;
use constant ZIP_CM_XZ => 95 ;
use constant ZIP_CM_PPMD => 98 ; # Not Supported yet
use constant ZIP_CM_AES => 99 ;
# General Purpose Flag
use constant ZIP_GP_FLAG_ENCRYPTED_MASK => (1 << 0) ;
use constant ZIP_GP_FLAG_STREAMING_MASK => (1 << 3) ;
use constant ZIP_GP_FLAG_PATCHED_MASK => (1 << 5) ;
use constant ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK => (1 << 6) ;
use constant ZIP_GP_FLAG_LZMA_EOS_PRESENT => (1 << 1) ;
use constant ZIP_GP_FLAG_LANGUAGE_ENCODING => (1 << 11) ;
# Internal File Attributes
use constant ZIP_IFA_TEXT_MASK => 1;
# Signatures for each of the headers
use constant ZIP_LOCAL_HDR_SIG => 0x04034b50;
use constant ZIP_DATA_HDR_SIG => 0x08074b50;
use constant packed_ZIP_DATA_HDR_SIG => pack "V", ZIP_DATA_HDR_SIG;
use constant ZIP_CENTRAL_HDR_SIG => 0x02014b50;
use constant ZIP_END_CENTRAL_HDR_SIG => 0x06054b50;
use constant ZIP64_END_CENTRAL_REC_HDR_SIG => 0x06064b50;
use constant ZIP64_END_CENTRAL_LOC_HDR_SIG => 0x07064b50;
use constant ZIP64_ARCHIVE_EXTRA_SIG => 0x08064b50;
use constant ZIP64_DIGITAL_SIGNATURE_SIG => 0x05054b50;
use constant ZIP_OS_CODE_UNIX => 3;
use constant ZIP_OS_CODE_DEFAULT => 3;
# Extra Field ID's
use constant ZIP_EXTRA_ID_ZIP64 => pack "v", 1;
use constant ZIP_EXTRA_ID_EXT_TIMESTAMP => "UT";
use constant ZIP_EXTRA_ID_INFO_ZIP_UNIX2 => "Ux";
use constant ZIP_EXTRA_ID_INFO_ZIP_UNIXN => "ux";
use constant ZIP_EXTRA_ID_INFO_ZIP_Upath => "up";
use constant ZIP_EXTRA_ID_INFO_ZIP_Ucom => "uc";
use constant ZIP_EXTRA_ID_JAVA_EXE => pack "v", 0xCAFE;
# DOS Attributes
use constant ZIP_A_RONLY => 0x01;
use constant ZIP_A_HIDDEN => 0x02;
use constant ZIP_A_SYSTEM => 0x04;
use constant ZIP_A_LABEL => 0x08;
use constant ZIP_A_DIR => 0x10;
use constant ZIP_A_ARCHIVE => 0x20;
use constant ZIP64_MIN_VERSION => 45;
%ZIP_CM_MIN_VERSIONS = (
ZIP_CM_STORE() => 20,
ZIP_CM_DEFLATE() => 20,
ZIP_CM_BZIP2() => 46,
ZIP_CM_LZMA() => 63,
ZIP_CM_PPMD() => 63,
ZIP_CM_ZSTD() => 20, # Winzip needs these to be 20
ZIP_CM_XZ() => 20,
);
1;
__END__

77
gitportable/usr/share/perl5/core_perl/IO/Compress/Zlib/Constants.pm Normal file
View File

@@ -0,0 +1,77 @@
package IO::Compress::Zlib::Constants ;
use strict ;
use warnings;
use bytes;
require Exporter;
our ($VERSION, @ISA, @EXPORT);
$VERSION = '2.204';
@ISA = qw(Exporter);
@EXPORT= qw(
ZLIB_HEADER_SIZE
ZLIB_TRAILER_SIZE
ZLIB_CMF_CM_OFFSET
ZLIB_CMF_CM_BITS
ZLIB_CMF_CM_DEFLATED
ZLIB_CMF_CINFO_OFFSET
ZLIB_CMF_CINFO_BITS
ZLIB_CMF_CINFO_MAX
ZLIB_FLG_FCHECK_OFFSET
ZLIB_FLG_FCHECK_BITS
ZLIB_FLG_FDICT_OFFSET
ZLIB_FLG_FDICT_BITS
ZLIB_FLG_LEVEL_OFFSET
ZLIB_FLG_LEVEL_BITS
ZLIB_FLG_LEVEL_FASTEST
ZLIB_FLG_LEVEL_FAST
ZLIB_FLG_LEVEL_DEFAULT
ZLIB_FLG_LEVEL_SLOWEST
ZLIB_FDICT_SIZE
);
# Constant names derived from RFC1950
use constant ZLIB_HEADER_SIZE => 2;
use constant ZLIB_TRAILER_SIZE => 4;
use constant ZLIB_CMF_CM_OFFSET => 0;
use constant ZLIB_CMF_CM_BITS => 0xF ; # 0b1111
use constant ZLIB_CMF_CM_DEFLATED => 8;
use constant ZLIB_CMF_CINFO_OFFSET => 4;
use constant ZLIB_CMF_CINFO_BITS => 0xF ; # 0b1111;
use constant ZLIB_CMF_CINFO_MAX => 7;
use constant ZLIB_FLG_FCHECK_OFFSET => 0;
use constant ZLIB_FLG_FCHECK_BITS => 0x1F ; # 0b11111;
use constant ZLIB_FLG_FDICT_OFFSET => 5;
use constant ZLIB_FLG_FDICT_BITS => 0x1 ; # 0b1;
use constant ZLIB_FLG_LEVEL_OFFSET => 6;
use constant ZLIB_FLG_LEVEL_BITS => 0x3 ; # 0b11;
use constant ZLIB_FLG_LEVEL_FASTEST => 0;
use constant ZLIB_FLG_LEVEL_FAST => 1;
use constant ZLIB_FLG_LEVEL_DEFAULT => 2;
use constant ZLIB_FLG_LEVEL_SLOWEST => 3;
use constant ZLIB_FDICT_SIZE => 4;
1;

229
gitportable/usr/share/perl5/core_perl/IO/Compress/Zlib/Extra.pm Normal file
View File

@@ -0,0 +1,229 @@
package IO::Compress::Zlib::Extra;
require 5.006 ;
use strict ;
use warnings;
use bytes;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS);
$VERSION = '2.204';
use IO::Compress::Gzip::Constants 2.204 ;
sub ExtraFieldError
{
return $_[0];
return "Error with ExtraField Parameter: $_[0]" ;
}
sub validateExtraFieldPair
{
my $pair = shift ;
my $strict = shift;
my $gzipMode = shift ;
return ExtraFieldError("Not an array ref")
unless ref $pair && ref $pair eq 'ARRAY';
return ExtraFieldError("SubField must have two parts")
unless @$pair == 2 ;
return ExtraFieldError("SubField ID is a reference")
if ref $pair->[0] ;
return ExtraFieldError("SubField Data is a reference")
if ref $pair->[1] ;
# ID is exactly two chars
return ExtraFieldError("SubField ID not two chars long")
unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ;
# Check that the 2nd byte of the ID isn't 0
return ExtraFieldError("SubField ID 2nd byte is 0x00")
if $strict && $gzipMode && substr($pair->[0], 1, 1) eq "\x00" ;
return ExtraFieldError("SubField Data too long")
if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ;
return undef ;
}
sub parseRawExtra
{
my $data = shift ;
my $extraRef = shift;
my $strict = shift;
my $gzipMode = shift ;
#my $lax = shift ;
#return undef
# if $lax ;
my $XLEN = length $data ;
return ExtraFieldError("Too Large")
if $XLEN > GZIP_FEXTRA_MAX_SIZE;
my $offset = 0 ;
while ($offset < $XLEN) {
return ExtraFieldError("Truncated in FEXTRA Body Section")
if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ;
my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
$offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE;
my $subLen = unpack("v", substr($data, $offset,
GZIP_FEXTRA_SUBFIELD_LEN_SIZE));
$offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ;
return ExtraFieldError("Truncated in FEXTRA Body Section")
if $offset + $subLen > $XLEN ;
my $bad = validateExtraFieldPair( [$id,
substr($data, $offset, $subLen)],
$strict, $gzipMode );
return $bad if $bad ;
push @$extraRef, [$id => substr($data, $offset, $subLen)]
if defined $extraRef;;
$offset += $subLen ;
}
return undef ;
}
sub findID
{
my $id_want = shift ;
my $data = shift;
my $XLEN = length $data ;
my $offset = 0 ;
while ($offset < $XLEN) {
return undef
if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ;
my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
$offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE;
my $subLen = unpack("v", substr($data, $offset,
GZIP_FEXTRA_SUBFIELD_LEN_SIZE));
$offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ;
return undef
if $offset + $subLen > $XLEN ;
return substr($data, $offset, $subLen)
if $id eq $id_want ;
$offset += $subLen ;
}
return undef ;
}
sub mkSubField
{
my $id = shift ;
my $data = shift ;
return $id . pack("v", length $data) . $data ;
}
sub parseExtraField
{
my $dataRef = $_[0];
my $strict = $_[1];
my $gzipMode = $_[2];
#my $lax = @_ == 2 ? $_[1] : 1;
# ExtraField can be any of
#
# -ExtraField => $data
#
# -ExtraField => [$id1, $data1,
# $id2, $data2]
# ...
# ]
#
# -ExtraField => [ [$id1 => $data1],
# [$id2 => $data2],
# ...
# ]
#
# -ExtraField => { $id1 => $data1,
# $id2 => $data2,
# ...
# }
if ( ! ref $dataRef ) {
return undef
if ! $strict;
return parseRawExtra($dataRef, undef, 1, $gzipMode);
}
my $data = $dataRef;
my $out = '' ;
if (ref $data eq 'ARRAY') {
if (ref $data->[0]) {
foreach my $pair (@$data) {
return ExtraFieldError("Not list of lists")
unless ref $pair eq 'ARRAY' ;
my $bad = validateExtraFieldPair($pair, $strict, $gzipMode) ;
return $bad if $bad ;
$out .= mkSubField(@$pair);
}
}
else {
return ExtraFieldError("Not even number of elements")
unless @$data % 2 == 0;
for (my $ix = 0; $ix <= @$data -1 ; $ix += 2) {
my $bad = validateExtraFieldPair([$data->[$ix],
$data->[$ix+1]],
$strict, $gzipMode) ;
return $bad if $bad ;
$out .= mkSubField($data->[$ix], $data->[$ix+1]);
}
}
}
elsif (ref $data eq 'HASH') {
while (my ($id, $info) = each %$data) {
my $bad = validateExtraFieldPair([$id, $info], $strict, $gzipMode);
return $bad if $bad ;
$out .= mkSubField($id, $info);
}
}
else {
return ExtraFieldError("Not a scalar, array ref or hash ref") ;
}
return ExtraFieldError("Too Large")
if length $out > GZIP_FEXTRA_MAX_SIZE;
$_[0] = $out ;
return undef;
}
1;
__END__

1292
gitportable/usr/share/perl5/core_perl/IO/Socket/IP.pm Normal file
View File

File diff suppressed because it is too large Load Diff

111
gitportable/usr/share/perl5/core_perl/IO/Uncompress/Adapter/Bunzip2.pm Normal file
View File

@@ -0,0 +1,111 @@
package IO::Uncompress::Adapter::Bunzip2;
use strict;
use warnings;
use bytes;
use IO::Compress::Base::Common 2.204 qw(:Status);
use Compress::Raw::Bzip2 2.204 ;
our ($VERSION, @ISA);
$VERSION = '2.204';
sub mkUncompObject
{
my $small = shift || 0;
my $verbosity = shift || 0;
my ($inflate, $status) = Compress::Raw::Bunzip2->new(1, 1, $small, $verbosity, 1);
return (undef, "Could not create Inflation object: $status", $status)
if $status != BZ_OK ;
return bless {'Inf' => $inflate,
'CompSize' => 0,
'UnCompSize' => 0,
'Error' => '',
'ConsumesInput' => 1,
} ;
}
sub uncompr
{
my $self = shift ;
my $from = shift ;
my $to = shift ;
my $eof = shift ;
my $inf = $self->{Inf};
my $status = $inf->bzinflate($from, $to);
$self->{ErrorNo} = $status;
if ($status != BZ_OK && $status != BZ_STREAM_END )
{
$self->{Error} = "Inflation Error: $status";
return STATUS_ERROR;
}
return STATUS_OK if $status == BZ_OK ;
return STATUS_ENDSTREAM if $status == BZ_STREAM_END ;
return STATUS_ERROR ;
}
sub reset
{
my $self = shift ;
my ($inf, $status) = Compress::Raw::Bunzip2->new();
$self->{ErrorNo} = ($status == BZ_OK) ? 0 : $status ;
if ($status != BZ_OK)
{
$self->{Error} = "Cannot create Inflate object: $status";
return STATUS_ERROR;
}
$self->{Inf} = $inf;
return STATUS_OK ;
}
sub compressedBytes
{
my $self = shift ;
$self->{Inf}->compressedBytes();
}
sub uncompressedBytes
{
my $self = shift ;
$self->{Inf}->uncompressedBytes();
}
sub crc32
{
my $self = shift ;
#$self->{Inf}->crc32();
}
sub adler32
{
my $self = shift ;
#$self->{Inf}->adler32();
}
sub sync
{
my $self = shift ;
#( $self->{Inf}->inflateSync(@_) == BZ_OK)
# ? STATUS_OK
# : STATUS_ERROR ;
}
1;
__END__

188
gitportable/usr/share/perl5/core_perl/IO/Uncompress/Adapter/Identity.pm Normal file
View File

@@ -0,0 +1,188 @@
package IO::Uncompress::Adapter::Identity;
use warnings;
use strict;
use bytes;
use IO::Compress::Base::Common 2.204 qw(:Status);
use IO::Compress::Zip::Constants ;
our ($VERSION);
$VERSION = '2.204';
use Compress::Raw::Zlib 2.204 ();
sub mkUncompObject
{
my $streaming = shift;
my $zip64 = shift;
my $crc32 = 1; #shift ;
my $adler32 = shift;
bless { 'CompSize' => U64->new(), # 0,
'UnCompSize' => 0,
'wantCRC32' => $crc32,
'CRC32' => Compress::Raw::Zlib::crc32(''),
'wantADLER32'=> $adler32,
'ADLER32' => Compress::Raw::Zlib::adler32(''),
'ConsumesInput' => 1,
'Streaming' => $streaming,
'Zip64' => $zip64,
'DataHdrSize' => $zip64 ? 24 : 16,
'Pending' => '',
} ;
}
sub uncompr
{
my $self = shift;
my $in = $_[0];
my $eof = $_[2];
my $len = length $$in;
my $remainder = '';
if (defined $$in && $len) {
if ($self->{Streaming}) {
if (length $self->{Pending}) {
$$in = $self->{Pending} . $$in ;
$len = length $$in;
$self->{Pending} = '';
}
my $ind = index($$in, "\x50\x4b\x07\x08");
if ($ind < 0) {
$len = length $$in;
if ($len >= 3 && substr($$in, -3) eq "\x50\x4b\x07") {
$ind = $len - 3 ;
}
elsif ($len >= 2 && substr($$in, -2) eq "\x50\x4b") {
$ind = $len - 2 ;
}
elsif ($len >= 1 && substr($$in, -1) eq "\x50") {
$ind = $len - 1 ;
}
}
if ($ind >= 0) {
$remainder = substr($$in, $ind) ;
substr($$in, $ind) = '' ;
}
}
if (length $remainder && length $remainder < $self->{DataHdrSize}) {
$self->{Pending} = $remainder ;
$remainder = '';
}
elsif (length $remainder >= $self->{DataHdrSize}) {
my $crc = unpack "V", substr($remainder, 4);
if ($crc == Compress::Raw::Zlib::crc32($$in, $self->{CRC32})) {
my ($l1, $l2) ;
if ($self->{Zip64}) {
$l1 = U64::newUnpack_V64(substr($remainder, 8));
$l2 = U64::newUnpack_V64(substr($remainder, 16));
}
else {
$l1 = U64::newUnpack_V32(substr($remainder, 8));
$l2 = U64::newUnpack_V32(substr($remainder, 12));
}
my $newLen = $self->{CompSize}->clone();
$newLen->add(length $$in);
if ($l1->equal($l2) && $l1->equal($newLen) ) {
$eof = 1;
}
else {
$$in .= substr($remainder, 0, 4) ;
$remainder = substr($remainder, 4);
#$self->{Pending} = substr($remainder, 4);
#$remainder = '';
$eof = 0;
}
}
else {
$$in .= substr($remainder, 0, 4) ;
$remainder = substr($remainder, 4);
#$self->{Pending} = substr($remainder, 4);
#$remainder = '';
$eof = 0;
}
}
if (length $$in) {
$self->{CompSize}->add(length $$in) ;
$self->{CRC32} = Compress::Raw::Zlib::crc32($$in, $self->{CRC32})
if $self->{wantCRC32};
$self->{ADLER32} = Compress::Zlib::adler32($$in, $self->{ADLER32})
if $self->{wantADLER32};
}
${ $_[1] } .= $$in;
$$in = $remainder;
}
return STATUS_ENDSTREAM if $eof;
return STATUS_OK ;
}
sub reset
{
my $self = shift;
$self->{CompSize}->reset();
$self->{UnCompSize} = 0;
$self->{CRC32} = Compress::Raw::Zlib::crc32('');
$self->{ADLER32} = Compress::Raw::Zlib::adler32('');
return STATUS_OK ;
}
#sub count
#{
# my $self = shift ;
# return $self->{UnCompSize} ;
#}
sub compressedBytes
{
my $self = shift ;
return $self->{CompSize} ;
}
sub uncompressedBytes
{
my $self = shift ;
return $self->{CompSize} ;
}
sub sync
{
return STATUS_OK ;
}
sub crc32
{
my $self = shift ;
return $self->{CRC32};
}
sub adler32
{
my $self = shift ;
return $self->{ADLER32};
}
1;
__END__

156
gitportable/usr/share/perl5/core_perl/IO/Uncompress/Adapter/Inflate.pm Normal file
View File

@@ -0,0 +1,156 @@
package IO::Uncompress::Adapter::Inflate;
use strict;
use warnings;
use bytes;
use IO::Compress::Base::Common 2.204 qw(:Status);
use Compress::Raw::Zlib 2.204 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS);
our ($VERSION);
$VERSION = '2.204';
sub mkUncompObject
{
my $crc32 = shift || 1;
my $adler32 = shift || 1;
my $scan = shift || 0;
my $inflate ;
my $status ;
if ($scan)
{
($inflate, $status) = Compress::Raw::Zlib::InflateScan->new(
#LimitOutput => 1,
CRC32 => $crc32,
ADLER32 => $adler32,
WindowBits => - MAX_WBITS );
}
else
{
($inflate, $status) = Compress::Raw::Zlib::Inflate->new(
AppendOutput => 1,
LimitOutput => 1,
CRC32 => $crc32,
ADLER32 => $adler32,
WindowBits => - MAX_WBITS );
}
return (undef, "Could not create Inflation object: $status", $status)
if $status != Z_OK ;
return bless {'Inf' => $inflate,
'CompSize' => 0,
'UnCompSize' => 0,
'Error' => '',
'ConsumesInput' => 1,
} ;
}
sub uncompr
{
my $self = shift ;
my $from = shift ;
my $to = shift ;
my $eof = shift ;
my $inf = $self->{Inf};
my $status = $inf->inflate($from, $to, $eof);
$self->{ErrorNo} = $status;
if ($status != Z_OK && $status != Z_STREAM_END && $status != Z_BUF_ERROR)
{
$self->{Error} = "Inflation Error: $status";
return STATUS_ERROR;
}
return STATUS_OK if $status == Z_BUF_ERROR ; # ???
return STATUS_OK if $status == Z_OK ;
return STATUS_ENDSTREAM if $status == Z_STREAM_END ;
return STATUS_ERROR ;
}
sub reset
{
my $self = shift ;
$self->{Inf}->inflateReset();
return STATUS_OK ;
}
#sub count
#{
# my $self = shift ;
# $self->{Inf}->inflateCount();
#}
sub crc32
{
my $self = shift ;
$self->{Inf}->crc32();
}
sub compressedBytes
{
my $self = shift ;
$self->{Inf}->compressedBytes();
}
sub uncompressedBytes
{
my $self = shift ;
$self->{Inf}->uncompressedBytes();
}
sub adler32
{
my $self = shift ;
$self->{Inf}->adler32();
}
sub sync
{
my $self = shift ;
( $self->{Inf}->inflateSync(@_) == Z_OK)
? STATUS_OK
: STATUS_ERROR ;
}
sub getLastBlockOffset
{
my $self = shift ;
$self->{Inf}->getLastBlockOffset();
}
sub getEndOffset
{
my $self = shift ;
$self->{Inf}->getEndOffset();
}
sub resetLastBlockByte
{
my $self = shift ;
$self->{Inf}->resetLastBlockByte(@_);
}
sub createDeflateStream
{
my $self = shift ;
my $deflate = $self->{Inf}->createDeflateStream(@_);
return bless {'Def' => $deflate,
'CompSize' => 0,
'UnCompSize' => 0,
'Error' => '',
}, 'IO::Compress::Adapter::Deflate';
}
1;
__END__

1007
gitportable/usr/share/perl5/core_perl/IO/Uncompress/AnyInflate.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1083
gitportable/usr/share/perl5/core_perl/IO/Uncompress/AnyUncompress.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1573
gitportable/usr/share/perl5/core_perl/IO/Uncompress/Base.pm Normal file
View File

File diff suppressed because it is too large Load Diff

915
gitportable/usr/share/perl5/core_perl/IO/Uncompress/Bunzip2.pm Normal file
View File

@@ -0,0 +1,915 @@
package IO::Uncompress::Bunzip2 ;
use strict ;
use warnings;
use bytes;
use IO::Compress::Base::Common 2.204 qw(:Status );
use IO::Uncompress::Base 2.204 ;
use IO::Uncompress::Adapter::Bunzip2 2.204 ;
require Exporter ;
our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error);
$VERSION = '2.204';
$Bunzip2Error = '';
@ISA = qw(IO::Uncompress::Base Exporter);
@EXPORT_OK = qw( $Bunzip2Error bunzip2 ) ;
#%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ;
push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
#Exporter::export_ok_tags('all');
sub new
{
my $class = shift ;
my $obj = IO::Compress::Base::Common::createSelfTiedObject($class, \$Bunzip2Error);
$obj->_create(undef, 0, @_);
}
sub bunzip2
{
my $obj = IO::Compress::Base::Common::createSelfTiedObject(undef, \$Bunzip2Error);
return $obj->_inf(@_);
}
sub getExtraParams
{
return (
'verbosity' => [IO::Compress::Base::Common::Parse_boolean, 0],
'small' => [IO::Compress::Base::Common::Parse_boolean, 0],
);
}
sub ckParams
{
my $self = shift ;
my $got = shift ;
return 1;
}
sub mkUncomp
{
my $self = shift ;
my $got = shift ;
my $magic = $self->ckMagic()
or return 0;
*$self->{Info} = $self->readHeader($magic)
or return undef ;
my $Small = $got->getValue('small');
my $Verbosity = $got->getValue('verbosity');
my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::Bunzip2::mkUncompObject(
$Small, $Verbosity);
return $self->saveErrorString(undef, $errstr, $errno)
if ! defined $obj;
*$self->{Uncomp} = $obj;
return 1;
}
sub ckMagic
{
my $self = shift;
my $magic ;
$self->smartReadExact(\$magic, 4);
*$self->{HeaderPending} = $magic ;
return $self->HeaderError("Header size is " .
4 . " bytes")
if length $magic != 4;
return $self->HeaderError("Bad Magic.")
if ! isBzip2Magic($magic) ;
*$self->{Type} = 'bzip2';
return $magic;
}
sub readHeader
{
my $self = shift;
my $magic = shift ;
$self->pushBack($magic);
*$self->{HeaderPending} = '';
return {
'Type' => 'bzip2',
'FingerprintLength' => 4,
'HeaderLength' => 4,
'TrailerLength' => 0,
'Header' => '$magic'
};
}
sub chkTrailer
{
return STATUS_OK;
}
sub isBzip2Magic
{
my $buffer = shift ;
# ASCII: B Z h 0 9
return $buffer =~ qr/^\x42\x5A\x68[\x30-\x39]$/;
}
1 ;
__END__
=head1 NAME
IO::Uncompress::Bunzip2 - Read bzip2 files/buffers
=head1 SYNOPSIS
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
my $status = bunzip2 $input => $output [,OPTS]
or die "bunzip2 failed: $Bunzip2Error\n";
my $z = IO::Uncompress::Bunzip2->new( $input [OPTS] )
or die "bunzip2 failed: $Bunzip2Error\n";
$status = $z->read($buffer)
$status = $z->read($buffer, $length)
$status = $z->read($buffer, $length, $offset)
$line = $z->getline()
$char = $z->getc()
$char = $z->ungetc()
$char = $z->opened()
$data = $z->trailingData()
$status = $z->nextStream()
$data = $z->getHeaderInfo()
$z->tell()
$z->seek($position, $whence)
$z->binmode()
$z->fileno()
$z->eof()
$z->close()
$Bunzip2Error ;
# IO::File mode
<$z>
read($z, $buffer);
read($z, $buffer, $length);
read($z, $buffer, $length, $offset);
tell($z)
seek($z, $position, $whence)
binmode($z)
fileno($z)
eof($z)
close($z)
=head1 DESCRIPTION
This module provides a Perl interface that allows the reading of
bzip2 files/buffers.
For writing bzip2 files/buffers, see the companion module IO::Compress::Bzip2.
=head1 Functional Interface
A top-level function, C<bunzip2>, is provided to carry out
"one-shot" uncompression between buffers and/or files. For finer
control over the uncompression process, see the L</"OO Interface">
section.
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
bunzip2 $input_filename_or_reference => $output_filename_or_reference [,OPTS]
or die "bunzip2 failed: $Bunzip2Error\n";
The functional interface needs Perl5.005 or better.
=head2 bunzip2 $input_filename_or_reference => $output_filename_or_reference [, OPTS]
C<bunzip2> expects at least two parameters,
C<$input_filename_or_reference> and C<$output_filename_or_reference>
and zero or more optional parameters (see L</Optional Parameters>)
=head3 The C<$input_filename_or_reference> parameter
The parameter, C<$input_filename_or_reference>, is used to define the
source of the compressed data.
It can take one of the following forms:
=over 5
=item A filename
If the C<$input_filename_or_reference> parameter is a simple scalar, it is
assumed to be a filename. This file will be opened for reading and the
input data will be read from it.
=item A filehandle
If the C<$input_filename_or_reference> parameter is a filehandle, the input
data will be read from it. The string '-' can be used as an alias for
standard input.
=item A scalar reference
If C<$input_filename_or_reference> is a scalar reference, the input data
will be read from C<$$input_filename_or_reference>.
=item An array reference
If C<$input_filename_or_reference> is an array reference, each element in
the array must be a filename.
The input data will be read from each file in turn.
The complete array will be walked to ensure that it only
contains valid filenames before any data is uncompressed.
=item An Input FileGlob string
If C<$input_filename_or_reference> is a string that is delimited by the
characters "<" and ">" C<bunzip2> will assume that it is an
I<input fileglob string>. The input is the list of files that match the
fileglob.
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
If the C<$input_filename_or_reference> parameter is any other type,
C<undef> will be returned.
=head3 The C<$output_filename_or_reference> parameter
The parameter C<$output_filename_or_reference> is used to control the
destination of the uncompressed data. This parameter can take one of
these forms.
=over 5
=item A filename
If the C<$output_filename_or_reference> parameter is a simple scalar, it is
assumed to be a filename. This file will be opened for writing and the
uncompressed data will be written to it.
=item A filehandle
If the C<$output_filename_or_reference> parameter is a filehandle, the
uncompressed data will be written to it. The string '-' can be used as
an alias for standard output.
=item A scalar reference
If C<$output_filename_or_reference> is a scalar reference, the
uncompressed data will be stored in C<$$output_filename_or_reference>.
=item An Array Reference
If C<$output_filename_or_reference> is an array reference,
the uncompressed data will be pushed onto the array.
=item An Output FileGlob
If C<$output_filename_or_reference> is a string that is delimited by the
characters "<" and ">" C<bunzip2> will assume that it is an
I<output fileglob string>. The output is the list of files that match the
fileglob.
When C<$output_filename_or_reference> is an fileglob string,
C<$input_filename_or_reference> must also be a fileglob string. Anything
else is an error.
See L<File::GlobMapper|File::GlobMapper> for more details.
=back
If the C<$output_filename_or_reference> parameter is any other type,
C<undef> will be returned.
=head2 Notes
When C<$input_filename_or_reference> maps to multiple compressed
files/buffers and C<$output_filename_or_reference> is
a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a
concatenation of all the uncompressed data from each of the input
files/buffers.
=head2 Optional Parameters
The optional parameters for the one-shot function C<bunzip2>
are (for the most part) identical to those used with the OO interface defined in the
L</"Constructor Options"> section. The exceptions are listed below
=over 5
=item C<< AutoClose => 0|1 >>
This option applies to any input or output data streams to
C<bunzip2> that are filehandles.
If C<AutoClose> is specified, and the value is true, it will result in all
input and/or output filehandles being closed once C<bunzip2> has
completed.
This parameter defaults to 0.
=item C<< BinModeOut => 0|1 >>
This option is now a no-op. All files will be written in binmode.
=item C<< Append => 0|1 >>
The behaviour of this option is dependent on the type of output data
stream.
=over 5
=item * A Buffer
If C<Append> is enabled, all uncompressed data will be append to the end of
the output buffer. Otherwise the output buffer will be cleared before any
uncompressed data is written to it.
=item * A Filename
If C<Append> is enabled, the file will be opened in append mode. Otherwise
the contents of the file, if any, will be truncated before any uncompressed
data is written to it.
=item * A Filehandle
If C<Append> is enabled, the filehandle will be positioned to the end of
the file via a call to C<seek> before any uncompressed data is
written to it. Otherwise the file pointer will not be moved.
=back
When C<Append> is specified, and set to true, it will I<append> all uncompressed
data to the output data stream.
So when the output is a filehandle it will carry out a seek to the eof
before writing any uncompressed data. If the output is a filename, it will be opened for
appending. If the output is a buffer, all uncompressed data will be
appended to the existing buffer.
Conversely when C<Append> is not specified, or it is present and is set to
false, it will operate as follows.
When the output is a filename, it will truncate the contents of the file
before writing any uncompressed data. If the output is a filehandle
its position will not be changed. If the output is a buffer, it will be
wiped before any uncompressed data is output.
Defaults to 0.
=item C<< MultiStream => 0|1 >>
If the input file/buffer contains multiple compressed data streams, this
option will uncompress the whole lot as a single data stream.
Defaults to 0.
=item C<< TrailingData => $scalar >>
Returns the data, if any, that is present immediately after the compressed
data stream once uncompression is complete.
This option can be used when there is useful information immediately
following the compressed data stream, and you don't know the length of the
compressed data stream.
If the input is a buffer, C<trailingData> will return everything from the
end of the compressed data stream to the end of the buffer.
If the input is a filehandle, C<trailingData> will return the data that is
left in the filehandle input buffer once the end of the compressed data
stream has been reached. You can then use the filehandle to read the rest
of the input file.
Don't bother using C<trailingData> if the input is a filename.
If you know the length of the compressed data stream before you start
uncompressing, you can avoid having to use C<trailingData> by setting the
C<InputLength> option.
=back
=head2 Examples
To read the contents of the file C<file1.txt.bz2> and write the
uncompressed data to the file C<file1.txt>.
use strict ;
use warnings ;
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
my $input = "file1.txt.bz2";
my $output = "file1.txt";
bunzip2 $input => $output
or die "bunzip2 failed: $Bunzip2Error\n";
To read from an existing Perl filehandle, C<$input>, and write the
uncompressed data to a buffer, C<$buffer>.
use strict ;
use warnings ;
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
use IO::File ;
my $input = IO::File->new( "<file1.txt.bz2" )
or die "Cannot open 'file1.txt.bz2': $!\n" ;
my $buffer ;
bunzip2 $input => \$buffer
or die "bunzip2 failed: $Bunzip2Error\n";
To uncompress all files in the directory "/my/home" that match "*.txt.bz2" and store the compressed data in the same directory
use strict ;
use warnings ;
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
bunzip2 '</my/home/*.txt.bz2>' => '</my/home/#1.txt>'
or die "bunzip2 failed: $Bunzip2Error\n";
and if you want to compress each file one at a time, this will do the trick
use strict ;
use warnings ;
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
for my $input ( glob "/my/home/*.txt.bz2" )
{
my $output = $input;
$output =~ s/.bz2// ;
bunzip2 $input => $output
or die "Error compressing '$input': $Bunzip2Error\n";
}
=head1 OO Interface
=head2 Constructor
The format of the constructor for IO::Uncompress::Bunzip2 is shown below
my $z = IO::Uncompress::Bunzip2->new( $input [OPTS] )
or die "IO::Uncompress::Bunzip2 failed: $Bunzip2Error\n";
Returns an C<IO::Uncompress::Bunzip2> object on success and undef on failure.
The variable C<$Bunzip2Error> will contain an error message on failure.
If you are running Perl 5.005 or better the object, C<$z>, returned from
IO::Uncompress::Bunzip2 can be used exactly like an L<IO::File|IO::File> filehandle.
This means that all normal input file operations can be carried out with
C<$z>. For example, to read a line from a compressed file/buffer you can
use either of these forms
$line = $z->getline();
$line = <$z>;
The mandatory parameter C<$input> is used to determine the source of the
compressed data. This parameter can take one of three forms.
=over 5
=item A filename
If the C<$input> parameter is a scalar, it is assumed to be a filename. This
file will be opened for reading and the compressed data will be read from it.
=item A filehandle
If the C<$input> parameter is a filehandle, the compressed data will be
read from it.
The string '-' can be used as an alias for standard input.
=item A scalar reference
If C<$input> is a scalar reference, the compressed data will be read from
C<$$input>.
=back
=head2 Constructor Options
The option names defined below are case insensitive and can be optionally
prefixed by a '-'. So all of the following are valid
-AutoClose
-autoclose
AUTOCLOSE
autoclose
OPTS is a combination of the following options:
=over 5
=item C<< AutoClose => 0|1 >>
This option is only valid when the C<$input> parameter is a filehandle. If
specified, and the value is true, it will result in the file being closed once
either the C<close> method is called or the IO::Uncompress::Bunzip2 object is
destroyed.
This parameter defaults to 0.
=item C<< MultiStream => 0|1 >>
Allows multiple concatenated compressed streams to be treated as a single
compressed stream. Decompression will stop once either the end of the
file/buffer is reached, an error is encountered (premature eof, corrupt
compressed data) or the end of a stream is not immediately followed by the
start of another stream.
This parameter defaults to 0.
=item C<< Prime => $string >>
This option will uncompress the contents of C<$string> before processing the
input file/buffer.
This option can be useful when the compressed data is embedded in another
file/data structure and it is not possible to work out where the compressed
data begins without having to read the first few bytes. If this is the
case, the uncompression can be I<primed> with these bytes using this
option.
=item C<< Transparent => 0|1 >>
If this option is set and the input file/buffer is not compressed data,
the module will allow reading of it anyway.
In addition, if the input file/buffer does contain compressed data and
there is non-compressed data immediately following it, setting this option
will make this module treat the whole file/buffer as a single data stream.
This option defaults to 1.
=item C<< BlockSize => $num >>
When reading the compressed input data, IO::Uncompress::Bunzip2 will read it in
blocks of C<$num> bytes.
This option defaults to 4096.
=item C<< InputLength => $size >>
When present this option will limit the number of compressed bytes read
from the input file/buffer to C<$size>. This option can be used in the
situation where there is useful data directly after the compressed data
stream and you know beforehand the exact length of the compressed data
stream.
This option is mostly used when reading from a filehandle, in which case
the file pointer will be left pointing to the first byte directly after the
compressed data stream.
This option defaults to off.
=item C<< Append => 0|1 >>
This option controls what the C<read> method does with uncompressed data.
If set to 1, all uncompressed data will be appended to the output parameter
of the C<read> method.
If set to 0, the contents of the output parameter of the C<read> method
will be overwritten by the uncompressed data.
Defaults to 0.
=item C<< Strict => 0|1 >>
This option is a no-op.
=item C<< Small => 0|1 >>
When non-zero this options will make bzip2 use a decompression algorithm
that uses less memory at the expense of increasing the amount of time
taken for decompression.
Default is 0.
=back
=head2 Examples
TODO
=head1 Methods
=head2 read
Usage is
$status = $z->read($buffer)
Reads a block of compressed data (the size of the compressed block is
determined by the C<Buffer> option in the constructor), uncompresses it and
writes any uncompressed data into C<$buffer>. If the C<Append> parameter is
set in the constructor, the uncompressed data will be appended to the
C<$buffer> parameter. Otherwise C<$buffer> will be overwritten.
Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
or a negative number on error.
=head2 read
Usage is
$status = $z->read($buffer, $length)
$status = $z->read($buffer, $length, $offset)
$status = read($z, $buffer, $length)
$status = read($z, $buffer, $length, $offset)
Attempt to read C<$length> bytes of uncompressed data into C<$buffer>.
The main difference between this form of the C<read> method and the
previous one, is that this one will attempt to return I<exactly> C<$length>
bytes. The only circumstances that this function will not is if end-of-file
or an IO error is encountered.
Returns the number of uncompressed bytes written to C<$buffer>, zero if eof
or a negative number on error.
=head2 getline
Usage is
$line = $z->getline()
$line = <$z>
Reads a single line.
This method fully supports the use of the variable C<$/> (or
C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C<English> is in use) to
determine what constitutes an end of line. Paragraph mode, record mode and
file slurp mode are all supported.
=head2 getc
Usage is
$char = $z->getc()
Read a single character.
=head2 ungetc
Usage is
$char = $z->ungetc($string)
=head2 getHeaderInfo
Usage is
$hdr = $z->getHeaderInfo();
@hdrs = $z->getHeaderInfo();
This method returns either a hash reference (in scalar context) or a list
or hash references (in array context) that contains information about each
of the header fields in the compressed data stream(s).
=head2 tell
Usage is
$z->tell()
tell $z
Returns the uncompressed file offset.
=head2 eof
Usage is
$z->eof();
eof($z);
Returns true if the end of the compressed input stream has been reached.
=head2 seek
$z->seek($position, $whence);
seek($z, $position, $whence);
Provides a sub-set of the C<seek> functionality, with the restriction
that it is only legal to seek forward in the input file/buffer.
It is a fatal error to attempt to seek backward.
Note that the implementation of C<seek> in this module does not provide
true random access to a compressed file/buffer. It works by uncompressing
data from the current offset in the file/buffer until it reaches the
uncompressed offset specified in the parameters to C<seek>. For very small
files this may be acceptable behaviour. For large files it may cause an
unacceptable delay.
The C<$whence> parameter takes one the usual values, namely SEEK_SET,
SEEK_CUR or SEEK_END.
Returns 1 on success, 0 on failure.
=head2 binmode
Usage is
$z->binmode
binmode $z ;
This is a noop provided for completeness.
=head2 opened
$z->opened()
Returns true if the object currently refers to a opened file/buffer.
=head2 autoflush
my $prev = $z->autoflush()
my $prev = $z->autoflush(EXPR)
If the C<$z> object is associated with a file or a filehandle, this method
returns the current autoflush setting for the underlying filehandle. If
C<EXPR> is present, and is non-zero, it will enable flushing after every
write/print operation.
If C<$z> is associated with a buffer, this method has no effect and always
returns C<undef>.
B<Note> that the special variable C<$|> B<cannot> be used to set or
retrieve the autoflush setting.
=head2 input_line_number
$z->input_line_number()
$z->input_line_number(EXPR)
Returns the current uncompressed line number. If C<EXPR> is present it has
the effect of setting the line number. Note that setting the line number
does not change the current position within the file/buffer being read.
The contents of C<$/> are used to determine what constitutes a line
terminator.
=head2 fileno
$z->fileno()
fileno($z)
If the C<$z> object is associated with a file or a filehandle, C<fileno>
will return the underlying file descriptor. Once the C<close> method is
called C<fileno> will return C<undef>.
If the C<$z> object is associated with a buffer, this method will return
C<undef>.
=head2 close
$z->close() ;
close $z ;
Closes the output file/buffer.
For most versions of Perl this method will be automatically invoked if
the IO::Uncompress::Bunzip2 object is destroyed (either explicitly or by the
variable with the reference to the object going out of scope). The
exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In
these cases, the C<close> method will be called automatically, but
not until global destruction of all live objects when the program is
terminating.
Therefore, if you want your scripts to be able to run on all versions
of Perl, you should call C<close> explicitly and not rely on automatic
closing.
Returns true on success, otherwise 0.
If the C<AutoClose> option has been enabled when the IO::Uncompress::Bunzip2
object was created, and the object is associated with a file, the
underlying file will also be closed.
=head2 nextStream
Usage is
my $status = $z->nextStream();
Skips to the next compressed data stream in the input file/buffer. If a new
compressed data stream is found, the eof marker will be cleared and C<$.>
will be reset to 0.
Returns 1 if a new stream was found, 0 if none was found, and -1 if an
error was encountered.
=head2 trailingData
Usage is
my $data = $z->trailingData();
Returns the data, if any, that is present immediately after the compressed
data stream once uncompression is complete. It only makes sense to call
this method once the end of the compressed data stream has been
encountered.
This option can be used when there is useful information immediately
following the compressed data stream, and you don't know the length of the
compressed data stream.
If the input is a buffer, C<trailingData> will return everything from the
end of the compressed data stream to the end of the buffer.
If the input is a filehandle, C<trailingData> will return the data that is
left in the filehandle input buffer once the end of the compressed data
stream has been reached. You can then use the filehandle to read the rest
of the input file.
Don't bother using C<trailingData> if the input is a filename.
If you know the length of the compressed data stream before you start
uncompressing, you can avoid having to use C<trailingData> by setting the
C<InputLength> option in the constructor.
=head1 Importing
No symbolic constants are required by IO::Uncompress::Bunzip2 at present.
=over 5
=item :all
Imports C<bunzip2> and C<$Bunzip2Error>.
Same as doing this
use IO::Uncompress::Bunzip2 qw(bunzip2 $Bunzip2Error) ;
=back
=head1 EXAMPLES
=head2 Working with Net::FTP
See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP">
=head1 SUPPORT
General feedback/questions/bug reports should be sent to
L<https://github.com/pmqs/IO-Compress/issues> (preferred) or
L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>.
=head1 SEE ALSO
L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
L<IO::Compress::FAQ|IO::Compress::FAQ>
L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
L<Archive::Tar|Archive::Tar>,
L<IO::Zlib|IO::Zlib>
The primary site for the bzip2 program is L<https://sourceware.org/bzip2/>.
See the module L<Compress::Bzip2|Compress::Bzip2>
=head1 AUTHOR
This module was written by Paul Marquess, C<pmqs@cpan.org>.
=head1 MODIFICATION HISTORY
See the Changes file.
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2005-2023 Paul Marquess. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

1131
gitportable/usr/share/perl5/core_perl/IO/Uncompress/Gunzip.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1003
gitportable/usr/share/perl5/core_perl/IO/Uncompress/Inflate.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1131
gitportable/usr/share/perl5/core_perl/IO/Uncompress/RawInflate.pm Normal file
View File

File diff suppressed because it is too large Load Diff

1973
gitportable/usr/share/perl5/core_perl/IO/Uncompress/Unzip.pm Normal file
View File

File diff suppressed because it is too large Load Diff

740
gitportable/usr/share/perl5/core_perl/IO/Zlib.pm Normal file
View File

@@ -0,0 +1,740 @@
# IO::Zlib.pm
#
# Copyright (c) 1998-2004 Tom Hughes <tom@compton.nu>.
# 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::Zlib;
=head1 NAME
IO::Zlib - IO:: style interface to L<Compress::Zlib>
=head1 SYNOPSIS
With any version of Perl 5 you can use the basic OO interface:
use IO::Zlib;
$fh = new IO::Zlib;
if ($fh->open("file.gz", "rb")) {
print <$fh>;
$fh->close;
}
$fh = IO::Zlib->new("file.gz", "wb9");
if (defined $fh) {
print $fh "bar\n";
$fh->close;
}
$fh = IO::Zlib->new("file.gz", "rb");
if (defined $fh) {
print <$fh>;
undef $fh; # automatically closes the file
}
With Perl 5.004 you can also use the TIEHANDLE interface to access
compressed files just like ordinary files:
use IO::Zlib;
tie *FILE, 'IO::Zlib', "file.gz", "wb";
print FILE "line 1\nline2\n";
tie *FILE, 'IO::Zlib', "file.gz", "rb";
while (<FILE>) { print "LINE: ", $_ };
=head1 DESCRIPTION
C<IO::Zlib> provides an IO:: style interface to L<Compress::Zlib> and
hence to gzip/zlib compressed files. It provides many of the same methods
as the L<IO::Handle> interface.
Starting from IO::Zlib version 1.02, IO::Zlib can also use an
external F<gzip> command. The default behaviour is to try to use
an external F<gzip> if no C<Compress::Zlib> can be loaded, unless
explicitly disabled by
use IO::Zlib qw(:gzip_external 0);
If explicitly enabled by
use IO::Zlib qw(:gzip_external 1);
then the external F<gzip> is used B<instead> of C<Compress::Zlib>.
=head1 CONSTRUCTOR
=over 4
=item new ( [ARGS] )
Creates an C<IO::Zlib> object. If it receives any parameters, they are
passed to the method C<open>; if the open fails, the object is destroyed.
Otherwise, it is returned to the caller.
=back
=head1 OBJECT METHODS
=over 4
=item open ( FILENAME, MODE )
C<open> takes two arguments. The first is the name of the file to open
and the second is the open mode. The mode can be anything acceptable to
L<Compress::Zlib> and by extension anything acceptable to I<zlib> (that
basically means POSIX fopen() style mode strings plus an optional number
to indicate the compression level).
=item opened
Returns true if the object currently refers to a opened file.
=item close
Close the file associated with the object and disassociate
the file from the handle.
Done automatically on destroy.
=item getc
Return the next character from the file, or undef if none remain.
=item getline
Return the next line from the file, or undef on end of string.
Can safely be called in an array context.
Currently ignores $/ ($INPUT_RECORD_SEPARATOR or $RS when L<English>
is in use) and treats lines as delimited by "\n".
=item getlines
Get all remaining lines from the file.
It will croak() if accidentally called in a scalar context.
=item print ( ARGS... )
Print ARGS to the file.
=item read ( BUF, NBYTES, [OFFSET] )
Read some bytes from the file.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.
=item eof
Returns true if the handle is currently positioned at end of file?
=item seek ( OFFSET, WHENCE )
Seek to a given position in the stream.
Not yet supported.
=item tell
Return the current position in the stream, as a numeric offset.
Not yet supported.
=item setpos ( POS )
Set the current position, using the opaque value returned by C<getpos()>.
Not yet supported.
=item getpos ( POS )
Return the current position in the string, as an opaque object.
Not yet supported.
=back
=head1 USING THE EXTERNAL GZIP
If the external F<gzip> is used, the following C<open>s are used:
open(FH, "gzip -dc $filename |") # for read opens
open(FH, " | gzip > $filename") # for write opens
You can modify the 'commands' for example to hardwire
an absolute path by e.g.
use IO::Zlib ':gzip_read_open' => '/some/where/gunzip -c %s |';
use IO::Zlib ':gzip_write_open' => '| /some/where/gzip.exe > %s';
The C<%s> is expanded to be the filename (C<sprintf> is used, so be
careful to escape any other C<%> signs). The 'commands' are checked
for sanity - they must contain the C<%s>, and the read open must end
with the pipe sign, and the write open must begin with the pipe sign.
=head1 CLASS METHODS
=over 4
=item has_Compress_Zlib
Returns true if C<Compress::Zlib> is available. Note that this does
not mean that C<Compress::Zlib> is being used: see L</gzip_external>
and L<gzip_used>.
=item gzip_external
Undef if an external F<gzip> B<can> be used if C<Compress::Zlib> is
not available (see L</has_Compress_Zlib>), true if an external F<gzip>
is explicitly used, false if an external F<gzip> must not be used.
See L</gzip_used>.
=item gzip_used
True if an external F<gzip> is being used, false if not.
=item gzip_read_open
Return the 'command' being used for opening a file for reading using an
external F<gzip>.
=item gzip_write_open
Return the 'command' being used for opening a file for writing using an
external F<gzip>.
=back
=head1 DIAGNOSTICS
=over 4
=item IO::Zlib::getlines: must be called in list context
If you want read lines, you must read in list context.
=item IO::Zlib::gzopen_external: mode '...' is illegal
Use only modes 'rb' or 'wb' or /wb[1-9]/.
=item IO::Zlib::import: '...' is illegal
The known import symbols are the C<:gzip_external>, C<:gzip_read_open>,
and C<:gzip_write_open>. Anything else is not recognized.
=item IO::Zlib::import: ':gzip_external' requires an argument
The C<:gzip_external> requires one boolean argument.
=item IO::Zlib::import: 'gzip_read_open' requires an argument
The C<:gzip_external> requires one string argument.
=item IO::Zlib::import: 'gzip_read' '...' is illegal
The C<:gzip_read_open> argument must end with the pipe sign (|)
and have the C<%s> for the filename. See L</"USING THE EXTERNAL GZIP">.
=item IO::Zlib::import: 'gzip_write_open' requires an argument
The C<:gzip_external> requires one string argument.
=item IO::Zlib::import: 'gzip_write_open' '...' is illegal
The C<:gzip_write_open> argument must begin with the pipe sign (|)
and have the C<%s> for the filename. An output redirect (>) is also
often a good idea, depending on your operating system shell syntax.
See L</"USING THE EXTERNAL GZIP">.
=item IO::Zlib::import: no Compress::Zlib and no external gzip
Given that we failed to load C<Compress::Zlib> and that the use of
an external F<gzip> was disabled, IO::Zlib has not much chance of working.
=item IO::Zlib::open: needs a filename
No filename, no open.
=item IO::Zlib::READ: NBYTES must be specified
We must know how much to read.
=item IO::Zlib::WRITE: too long LENGTH
The LENGTH must be less than or equal to the buffer size.
=back
=head1 SEE ALSO
L<perlfunc>,
L<perlop/"I/O Operators">,
L<IO::Handle>,
L<Compress::Zlib>
=head1 HISTORY
Created by Tom Hughes E<lt>F<tom@compton.nu>E<gt>.
Support for external gzip added by Jarkko Hietaniemi E<lt>F<jhi@iki.fi>E<gt>.
=head1 COPYRIGHT
Copyright (c) 1998-2004 Tom Hughes E<lt>F<tom@compton.nu>E<gt>.
All rights reserved. This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
=cut
require 5.006;
use strict;
use warnings;
use Carp;
use Fcntl qw(SEEK_SET);
use Symbol;
use Tie::Handle;
our $VERSION = "1.14";
our $AUTOLOAD;
our @ISA = qw(Tie::Handle);
my $has_Compress_Zlib;
my $gzip_external;
my $gzip_used;
my $gzip_read_open = "gzip -dc %s |";
my $gzip_write_open = "| gzip > %s";
my $aliased;
BEGIN {
eval { require Compress::Zlib };
$has_Compress_Zlib = $@ || $Compress::Zlib::VERSION < 2.000 ? 0 : 1;
}
sub has_Compress_Zlib
{
$has_Compress_Zlib;
}
sub gzip_external
{
$gzip_external;
}
sub gzip_used
{
$gzip_used;
}
sub gzip_read_open
{
$gzip_read_open;
}
sub gzip_write_open
{
$gzip_write_open;
}
sub can_gunzip
{
$has_Compress_Zlib || $gzip_external;
}
sub _import
{
my $import = shift;
while (@_)
{
if ($_[0] eq ':gzip_external')
{
shift;
if (@_)
{
$gzip_external = shift;
}
else
{
croak "$import: ':gzip_external' requires an argument";
}
}
elsif ($_[0] eq ':gzip_read_open')
{
shift;
if (@_)
{
$gzip_read_open = shift;
croak "$import: ':gzip_read_open' '$gzip_read_open' is illegal"
unless $gzip_read_open =~ /^.+%s.+\|\s*$/;
}
else
{
croak "$import: ':gzip_read_open' requires an argument";
}
}
elsif ($_[0] eq ':gzip_write_open')
{
shift;
if (@_)
{
$gzip_write_open = shift;
croak "$import: ':gzip_write_open' '$gzip_read_open' is illegal"
unless $gzip_write_open =~ /^\s*\|.+%s.*$/;
}
else
{
croak "$import: ':gzip_write_open' requires an argument";
}
}
else
{
last;
}
}
return @_;
}
sub _alias
{
my $import = shift;
if ($gzip_external || (!$has_Compress_Zlib && !defined($gzip_external)))
{
require IO::Handle;
undef *gzopen;
*gzopen = \&gzopen_external;
*IO::Handle::gzread = \&gzread_external;
*IO::Handle::gzwrite = \&gzwrite_external;
*IO::Handle::gzreadline = \&gzreadline_external;
*IO::Handle::gzeof = \&gzeof_external;
*IO::Handle::gzclose = \&gzclose_external;
$gzip_used = 1;
}
elsif ($has_Compress_Zlib)
{
*gzopen = \&Compress::Zlib::gzopen;
*gzread = \&Compress::Zlib::gzread;
*gzwrite = \&Compress::Zlib::gzwrite;
*gzreadline = \&Compress::Zlib::gzreadline;
*gzeof = \&Compress::Zlib::gzeof;
}
else
{
croak "$import: no Compress::Zlib and no external gzip";
}
$aliased = 1;
}
sub import
{
my $class = shift;
my $import = "IO::Zlib::import";
if (@_)
{
if (_import($import, @_))
{
croak "$import: '@_' is illegal";
}
}
_alias($import);
}
sub TIEHANDLE
{
my $class = shift;
my @args = @_;
my $self = bless {}, $class;
return @args ? $self->OPEN(@args) : $self;
}
sub DESTROY
{
}
sub OPEN
{
my $self = shift;
my $filename = shift;
my $mode = shift;
croak "IO::Zlib::open: needs a filename" unless defined($filename);
$self->{'file'} = gzopen($filename,$mode);
return defined($self->{'file'}) ? $self : undef;
}
sub CLOSE
{
my $self = shift;
return undef unless defined($self->{'file'});
my $status = $self->{'file'}->gzclose();
delete $self->{'file'};
return ($status == 0) ? 1 : undef;
}
sub READ
{
my $self = shift;
my $bufref = \$_[0];
my $nbytes = $_[1];
my $offset = $_[2] || 0;
croak "IO::Zlib::READ: NBYTES must be specified" unless defined($nbytes);
$$bufref = "" unless defined($$bufref);
my $bytesread = $self->{'file'}->gzread(substr($$bufref,$offset),$nbytes);
return undef if $bytesread < 0;
return $bytesread;
}
sub READLINE
{
my $self = shift;
my $line;
return () if $self->{'file'}->gzreadline($line) <= 0;
return $line unless wantarray;
my @lines = $line;
while ($self->{'file'}->gzreadline($line) > 0)
{
push @lines, $line;
}
return @lines;
}
sub WRITE
{
my $self = shift;
my $buf = shift;
my $length = shift;
my $offset = shift;
croak "IO::Zlib::WRITE: too long LENGTH" unless $offset + $length <= length($buf);
return $self->{'file'}->gzwrite(substr($buf,$offset,$length));
}
sub EOF
{
my $self = shift;
return $self->{'file'}->gzeof();
}
sub FILENO
{
return undef;
}
sub new
{
my $class = shift;
my @args = @_;
_alias("new", @_) unless $aliased; # Some call new IO::Zlib directly...
my $self = gensym();
tie *{$self}, $class, @args;
return tied(${$self}) ? bless $self, $class : undef;
}
sub getline
{
my $self = shift;
return scalar tied(*{$self})->READLINE();
}
sub getlines
{
my $self = shift;
croak "IO::Zlib::getlines: must be called in list context"
unless wantarray;
return tied(*{$self})->READLINE();
}
sub opened
{
my $self = shift;
return defined tied(*{$self})->{'file'};
}
sub AUTOLOAD
{
my $self = shift;
$AUTOLOAD =~ s/.*:://;
$AUTOLOAD =~ tr/a-z/A-Z/;
return tied(*{$self})->$AUTOLOAD(@_);
}
sub gzopen_external
{
my $filename = shift;
my $mode = shift;
my $fh = IO::Handle->new();
if ($mode =~ /r/)
{
# Because someone will try to read ungzipped files
# with this we peek and verify the signature. Yes,
# this means that we open the file twice (if it is
# gzipped).
# Plenty of race conditions exist in this code, but
# the alternative would be to capture the stderr of
# gzip and parse it, which would be a portability nightmare.
if (-e $filename && open($fh, $filename))
{
binmode $fh;
my $sig;
my $rdb = read($fh, $sig, 2);
if ($rdb == 2 && $sig eq "\x1F\x8B")
{
my $ropen = sprintf($gzip_read_open, $filename);
if (open($fh, $ropen))
{
binmode $fh;
return $fh;
}
else
{
return undef;
}
}
seek($fh, 0, SEEK_SET) or
die "IO::Zlib: open('$filename', 'r'): seek: $!";
return $fh;
}
else
{
return undef;
}
}
elsif ($mode =~ /w/)
{
my $level = $mode =~ /([1-9])/ ? "-$1" : "";
# To maximize portability we would need to open
# two filehandles here, one for "| gzip $level"
# and another for "> $filename", and then when
# writing copy bytes from the first to the second.
# We are using IO::Handle objects for now, however,
# and they can only contain one stream at a time.
my $wopen = sprintf($gzip_write_open, $filename);
if (open($fh, $wopen))
{
$fh->autoflush(1);
binmode $fh;
return $fh;
}
else
{
return undef;
}
}
else
{
croak "IO::Zlib::gzopen_external: mode '$mode' is illegal";
}
return undef;
}
sub gzread_external
{
my $file = shift;
my $bufref = \$_[0];
my $nbytes = $_[1] || 4096;
# Use read() instead of sysread() because people may
# mix reads and readlines, and we don't want to mess
# the stdio buffering. See also gzreadline_external()
# and gzwrite_external().
my $nread = read($file, $$bufref, $nbytes);
return defined $nread ? $nread : -1;
}
sub gzwrite_external
{
my $file = shift;
my $buf = shift;
# Using syswrite() is okay (cf. gzread_external())
# since the bytes leave this process and buffering
# is therefore not an issue.
my $nwrote = syswrite($file, $buf);
return defined $nwrote ? $nwrote : -1;
}
sub gzreadline_external
{
my $file = shift;
my $bufref = \$_[0];
# See the comment in gzread_external().
$$bufref = readline($file);
return defined $$bufref ? length($$bufref) : -1;
}
sub gzeof_external
{
my $file = shift;
return eof($file);
}
sub gzclose_external
{
my $file = shift;
close($file);
# I am not entirely certain why this is needed but it seems
# the above close() always fails (as if the stream would have
# been already closed - something to do with using external
# processes via pipes?)
return 0;
}
1;

2187
gitportable/usr/share/perl5/core_perl/IPC/Cmd.pm Normal file
View File

File diff suppressed because it is too large Load Diff

122
gitportable/usr/share/perl5/core_perl/IPC/Open2.pm Normal file
View File

@@ -0,0 +1,122 @@
package IPC::Open2;
use strict;
require 5.006;
use Exporter 'import';
our $VERSION = 1.06;
our @EXPORT = qw(open2);
=head1 NAME
IPC::Open2 - open a process for both reading and writing using open2()
=head1 SYNOPSIS
use IPC::Open2;
my $pid = open2(my $chld_out, my $chld_in,
'some', 'cmd', 'and', 'args');
# or passing the command through the shell
my $pid = open2(my $chld_out, my $chld_in, 'some cmd and args');
# read from parent STDIN and write to already open handle
open my $outfile, '>', 'outfile.txt' or die "open failed: $!";
my $pid = open2($outfile, '<&STDIN', 'some', 'cmd', 'and', 'args');
# read from already open handle and write to parent STDOUT
open my $infile, '<', 'infile.txt' or die "open failed: $!";
my $pid = open2('>&STDOUT', $infile, 'some', 'cmd', 'and', 'args');
# reap zombie and retrieve exit status
waitpid( $pid, 0 );
my $child_exit_status = $? >> 8;
=head1 DESCRIPTION
The open2() function runs the given command and connects $chld_out for
reading and $chld_in for writing. It's what you think should work
when you try
my $pid = open(my $fh, "|cmd args|");
The $chld_in filehandle will have autoflush turned on.
If $chld_out is a string (that is, a bareword filehandle rather than a glob
or a reference) and it begins with C<< >& >>, then the child will send output
directly to that file handle. If $chld_in is a string that begins with
C<< <& >>, then $chld_in will be closed in the parent, and the child will
read from it directly. In both cases, there will be a L<dup(2)> instead of a
L<pipe(2)> made.
If either reader or writer is the empty string or undefined, this will be
replaced by an autogenerated filehandle. If so, you must pass a valid lvalue
in the parameter slot so it can be overwritten in the caller, or
an exception will be raised.
open2() returns the process ID of the child process. It doesn't return on
failure: it just raises an exception matching C</^open2:/>. However,
C<exec> failures in the child are not detected. You'll have to
trap SIGPIPE yourself.
open2() does not wait for and reap the child process after it exits.
Except for short programs where it's acceptable to let the operating system
take care of this, you need to do this yourself. This is normally as
simple as calling C<waitpid $pid, 0> when you're done with the process.
Failing to do this can result in an accumulation of defunct or "zombie"
processes. See L<perlfunc/waitpid> for more information.
This whole affair is quite dangerous, as you may block forever. It
assumes it's going to talk to something like L<bc(1)>, both writing
to it and reading from it. This is presumably safe because you
"know" that commands like L<bc(1)> will read a line at a time and
output a line at a time. Programs like L<sort(1)> that read their
entire input stream first, however, are quite apt to cause deadlock.
The big problem with this approach is that if you don't have control
over source code being run in the child process, you can't control
what it does with pipe buffering. Thus you can't just open a pipe to
C<cat -v> and continually read and write a line from it.
The L<IO::Pty> and L<Expect> modules from CPAN can help with this, as
they provide a real tty (well, a pseudo-tty, actually), which gets you
back to line buffering in the invoked command again.
=head1 WARNING
The order of arguments differs from that of open3().
=head1 SEE ALSO
See L<IPC::Open3> for an alternative that handles STDERR as well. This
function is really just a wrapper around open3().
=cut
# &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

442
gitportable/usr/share/perl5/core_perl/IPC/Open3.pm Normal file
View File

@@ -0,0 +1,442 @@
package IPC::Open3;
use strict;
no strict 'refs'; # because users pass me bareword filehandles
use Exporter 'import';
use Carp;
use Symbol qw(gensym qualify);
our $VERSION = '1.22';
our @EXPORT = qw(open3);
=head1 NAME
IPC::Open3 - open a process for reading, writing, and error handling using open3()
=head1 SYNOPSIS
use Symbol 'gensym'; # vivify a separate handle for STDERR
my $pid = open3(my $chld_in, my $chld_out, my $chld_err = gensym,
'some', 'cmd', 'and', 'args');
# or pass the command through the shell
my $pid = open3(my $chld_in, my $chld_out, my $chld_err = gensym,
'some cmd and args');
# read from parent STDIN
# send STDOUT and STDERR to already open handle
open my $outfile, '>>', 'output.txt' or die "open failed: $!";
my $pid = open3('<&STDIN', $outfile, undef,
'some', 'cmd', 'and', 'args');
# write to parent STDOUT and STDERR
my $pid = open3(my $chld_in, '>&STDOUT', '>&STDERR',
'some', 'cmd', 'and', 'args');
# reap zombie and retrieve exit status
waitpid( $pid, 0 );
my $child_exit_status = $? >> 8;
=head1 DESCRIPTION
Extremely similar to open2(), open3() spawns the given command and
connects $chld_out for reading from the child, $chld_in for writing to
the child, and $chld_err for errors. If $chld_err is false, or the
same file descriptor as $chld_out, then STDOUT and STDERR of the child
are on the same filehandle. This means that an autovivified lexical
cannot be used for the STDERR filehandle, but gensym from L<Symbol> can
be used to vivify a new glob reference, see L</SYNOPSIS>. The $chld_in
will have autoflush turned on.
If $chld_in begins with C<< <& >>, then $chld_in will be closed in the
parent, and the child will read from it directly. If $chld_out or
$chld_err begins with C<< >& >>, then the child will send output
directly to that filehandle. In both cases, there will be a L<dup(2)>
instead of a L<pipe(2)> made.
If either reader or writer is the empty string or undefined, this will
be replaced by an autogenerated filehandle. If so, you must pass a
valid lvalue in the parameter slot so it can be overwritten in the
caller, or an exception will be raised.
The filehandles may also be integers, in which case they are understood
as file descriptors.
open3() returns the process ID of the child process. It doesn't return on
failure: it just raises an exception matching C</^open3:/>. However,
C<exec> failures in the child (such as no such file or permission denied),
are just reported to $chld_err under Windows and OS/2, as it is not possible
to trap them.
If the child process dies for any reason, the next write to $chld_in is
likely to generate a SIGPIPE in the parent, which is fatal by default.
So you may wish to handle this signal.
Note if you specify C<-> as the command, in an analogous fashion to
C<open(my $fh, "-|")> the child process will just be the forked Perl
process rather than an external command. This feature isn't yet
supported on Win32 platforms.
open3() does not wait for and reap the child process after it exits.
Except for short programs where it's acceptable to let the operating system
take care of this, you need to do this yourself. This is normally as
simple as calling C<waitpid $pid, 0> when you're done with the process.
Failing to do this can result in an accumulation of defunct or "zombie"
processes. See L<perlfunc/waitpid> for more information.
If you try to read from the child's stdout writer and their stderr
writer, you'll have problems with blocking, which means you'll want
to use select() or L<IO::Select>, which means you'd best use
sysread() instead of readline() for normal stuff.
This is very dangerous, as you may block forever. It assumes it's
going to talk to something like L<bc(1)>, both writing to it and reading
from it. This is presumably safe because you "know" that commands
like L<bc(1)> will read a line at a time and output a line at a time.
Programs like L<sort(1)> that read their entire input stream first,
however, are quite apt to cause deadlock.
The big problem with this approach is that if you don't have control
over source code being run in the child process, you can't control
what it does with pipe buffering. Thus you can't just open a pipe to
C<cat -v> and continually read and write a line from it.
=head1 See Also
=over 4
=item L<IPC::Open2>
Like Open3 but without STDERR capture.
=item L<IPC::Run>
This is a CPAN module that has better error handling and more facilities
than Open3.
=back
=head1 WARNING
The order of arguments differs from that of open2().
=cut
# &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

3142
gitportable/usr/share/perl5/core_perl/JSON/PP.pm Normal file
View File

File diff suppressed because it is too large Load Diff

43
gitportable/usr/share/perl5/core_perl/JSON/PP/Boolean.pm Normal file
View File

@@ -0,0 +1,43 @@
package JSON::PP::Boolean;
use strict;
use warnings;
use overload ();
overload::unimport('overload', qw(0+ ++ -- fallback));
overload::import('overload',
"0+" => sub { ${$_[0]} },
"++" => sub { $_[0] = ${$_[0]} + 1 },
"--" => sub { $_[0] = ${$_[0]} - 1 },
fallback => 1,
);
our $VERSION = '4.16';
1;
__END__
=head1 NAME
JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
=head1 SYNOPSIS
# do not "use" yourself
=head1 DESCRIPTION
This module exists only to provide overload resolution for Storable and similar modules. See
L<JSON::PP> for more info about this class.
=head1 AUTHOR
This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

6832
gitportable/usr/share/perl5/core_perl/Math/BigFloat.pm Normal file
View File

File diff suppressed because it is too large Load Diff

76
gitportable/usr/share/perl5/core_perl/Math/BigFloat/Trace.pm Normal file
View File

@@ -0,0 +1,76 @@
# -*- mode: perl; -*-
package Math::BigFloat::Trace;
use strict;
use warnings;
use Exporter;
use Math::BigFloat;
our @ISA = qw(Exporter Math::BigFloat);
our $VERSION = '0.66';
use overload; # inherit overload from Math::BigFloat
# Globals
our $accuracy = undef;
our $precision = undef;
our $round_mode = 'even';
our $div_scale = 40;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $value = shift;
my $a = $accuracy;
$a = $_[0] if defined $_[0];
my $p = $precision;
$p = $_[1] if defined $_[1];
my $self = $class -> SUPER::new($value, $a, $p, $round_mode);
printf "Math::BigFloat new '%s' => '%s' (%s)\n",
$value, $self, ref($self);
return $self;
}
sub import {
my $class = shift;
printf "%s -> import(%s)\n", $class, join(", ", @_);
# we catch the constants, the rest goes to parent
my $constant = grep { $_ eq ':constant' } @_;
my @a = grep { $_ ne ':constant' } @_;
if ($constant) {
overload::constant
integer => sub {
$class -> new(shift);
},
float => sub {
$class -> new(shift);
},
binary => sub {
# E.g., a literal 0377 shall result in an object whose value
# is decimal 255, but new("0377") returns decimal 377.
return $class -> from_oct($_[0]) if $_[0] =~ /^0_*[0-7]/;
$class -> new(shift);
};
}
$class -> SUPER::import(@a); # need it for subclasses
#$self -> export_to_level(1, $class, @_); # need this ?
}
1;

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