GSP/Panel
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added Cyg-Win

Browse source
This commit is contained in:
Frank Harris 2026-06-06 18:46:40 -04:00
parent 82cbc206eb
commit 413c315806
10586 changed files with 3806249 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

96
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/App/Cpan.pm Normal file
View file

File diff suppressed because it is too large Load diff

817
Agent-Windows/OGP64/usr/share/perl5/5.40/App/Prove.pm Normal file
View file

@ -0,0 +1,817 @@
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.48
=cut
our $VERSION = '3.48';
=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 ) ) {
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;
...
}
=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
Agent-Windows/OGP64/usr/share/perl5/5.40/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.48
=cut
our $VERSION = '3.48';
=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
Agent-Windows/OGP64/usr/share/perl5/5.40/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.48
=cut
our $VERSION = '3.48';
=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
Agent-Windows/OGP64/usr/share/perl5/5.40/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.48
=cut
our $VERSION = '3.48';
=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;

2450
Agent-Windows/OGP64/usr/share/perl5/5.40/Archive/Tar.pm Normal file
View file

File diff suppressed because it is too large Load diff

127
Agent-Windows/OGP64/usr/share/perl5/5.40/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 = '3.02_001';
@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;

718
Agent-Windows/OGP64/usr/share/perl5/5.40/Archive/Tar/File.pm Normal file
View file

@ -0,0 +1,718 @@
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 = '3.02_001';
### 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::File 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
my $path = File::Spec::Unix->catfile( $self->prefix, $self->name );
$path .= "/" if $self->name =~ m{/$}; # Re-add trailing slash if necessary, as catfile() strips them off.
return $path;
}
=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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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; }

7282
Agent-Windows/OGP64/usr/share/perl5/5.40/B/Deparse.pm Normal file
View file

File diff suppressed because it is too large Load diff

961
Agent-Windows/OGP64/usr/share/perl5/5.40/B/Op_private.pm Normal file
View file

@ -0,0 +1,961 @@
# -*- 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.040003";
$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv);
$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv);
$bits{$_}{2} = 'OPpENTERSUB_HASTARG' for qw(ceil entersub floor goto refaddr reftype 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{$_}{1} = 'OPpMETH_NO_BAREWORD_IO' for qw(method method_named method_redir method_redir_super method_super);
$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_negate i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement negate 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',
],
},
{
label => 'TOKEN',
mask_def => 'OPpCONST_TOKEN_MASK',
baseshift_def => 'OPpCONST_TOKEN_SHIFT',
bitcount_def => 'OPpCONST_TOKEN_BITS',
bitmin => 6,
bitmax => 7,
bitmask => 192,
enum => [
1, 'OPpCONST_TOKEN_LINE', 'LINE',
2, 'OPpCONST_TOKEN_FILE', 'FILE',
3, 'OPpCONST_TOKEN_PACKAGE', 'PACKAGE',
],
},
);
@{$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}}{7,6,5,4,3,2,1} = ($bf[10], $bf[10], '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 => 32,
OPpCONST_ENTERED => 16,
OPpCONST_NOVER => 2,
OPpCONST_SHORTCIRCUIT => 4,
OPpCONST_STRICT => 8,
OPpCONST_TOKEN_BITS => 2,
OPpCONST_TOKEN_FILE => 128,
OPpCONST_TOKEN_LINE => 64,
OPpCONST_TOKEN_MASK => 192,
OPpCONST_TOKEN_PACKAGE => 192,
OPpCONST_TOKEN_SHIFT => 6,
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,
OPpMETH_NO_BAREWORD_IO => 2,
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',
OPpCONST_TOKEN_FILE => 'FILE',
OPpCONST_TOKEN_LINE => 'LINE',
OPpCONST_TOKEN_PACKAGE => 'PACKAGE',
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',
OPpMETH_NO_BAREWORD_IO => 'NO_BAREWORD_IO',
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_HASTARG => [qw(ceil entersub floor goto refaddr reftype 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)],
OPpMETH_NO_BAREWORD_IO => [qw(method method_named method_redir method_redir_super method_super)],
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_negate i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement negate 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{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
Agent-Windows/OGP64/usr/share/perl5/5.40/Benchmark.pm Normal file
View file

File diff suppressed because it is too large Load diff

94
Agent-Windows/OGP64/usr/share/perl5/5.40/CORE.pod Normal file
View file

@ -0,0 +1,94 @@
=head1 NAME
CORE - Namespace for Perl's core routines
=head1 SYNOPSIS
BEGIN {
*CORE::GLOBAL::hex = sub { 1; };
}
print hex("0x50"),"\n"; # prints 1
print CORE::hex("0x50"),"\n"; # prints 80
CORE::say "yes"; # prints yes
BEGIN { *shove = \&CORE::push; }
shove @array, 1,2,3; # pushes on to @array
=head1 DESCRIPTION
The C<CORE> namespace gives access to the original built-in functions of
Perl. The C<CORE> package is built into
Perl, and therefore you do not need to use or
require a hypothetical "CORE" module prior to accessing routines in this
namespace.
A list of the built-in functions in Perl can be found in L<perlfunc>.
For all Perl keywords, a C<CORE::> prefix will force the built-in function
to be used, even if it has been overridden or would normally require the
L<feature> pragma. Despite appearances, this has nothing to do with the
CORE package, but is part of Perl's syntax.
For many Perl functions, the CORE package contains real subroutines. This
feature is new in Perl 5.16. You can take references to these and make
aliases. However, some can only be called as barewords; i.e., you cannot
use ampersand syntax (C<&foo>) or call them through references. See the
C<shove> example above. These subroutines exist for all keywords except the following:
C<__DATA__>, C<__END__>, C<and>, C<cmp>, C<default>, C<do>, C<dump>,
C<else>, C<elsif>, C<eq>, C<eval>, C<for>, C<foreach>, C<format>, C<ge>,
C<given>, C<goto>, C<grep>, C<gt>, C<if>, C<last>, C<le>, C<local>, C<lt>,
C<m>, C<map>, C<my>, C<ne>, C<next>, C<no>, C<or>, C<our>, C<package>,
C<print>, C<printf>, C<q>, C<qq>, C<qr>, C<qw>, C<qx>, C<redo>, C<require>,
C<return>, C<s>, C<say>, C<sort>, C<state>, C<sub>, C<tr>, C<unless>,
C<until>, C<use>, C<when>, C<while>, C<x>, C<xor>, C<y>
Calling with
ampersand syntax and through references does not work for the following
functions, as they have special syntax that cannot always be translated
into a simple list (e.g., C<eof> vs C<eof()>):
C<chdir>, C<chomp>, C<chop>, C<defined>, C<delete>, C<eof>, C<exec>,
C<exists>, C<lstat>, C<split>, C<stat>, C<system>, C<truncate>, C<unlink>
=head1 OVERRIDING CORE FUNCTIONS
To override a Perl built-in routine with your own version, you need to
import it at compile-time. This can be conveniently achieved with the
C<subs> pragma. This will affect only the package in which you've imported
the said subroutine:
use subs 'chdir';
sub chdir { ... }
chdir $somewhere;
To override a built-in globally (that is, in all namespaces), you need to
import your function into the C<CORE::GLOBAL> pseudo-namespace at compile
time:
BEGIN {
*CORE::GLOBAL::hex = sub {
# ... your code here
};
}
The new routine will be called whenever a built-in function is called
without a qualifying package:
print hex("0x50"),"\n"; # prints 1
In both cases, if you want access to the original, unaltered routine, use
the C<CORE::> prefix:
print CORE::hex("0x50"),"\n"; # prints 80
=head1 AUTHOR
This documentation provided by Tels <nospam-abuse@bloodgate.com> 2007.
=head1 SEE ALSO
L<perlsub>, L<perlfunc>.
=cut

4118
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN.pm Normal file
View file

File diff suppressed because it is too large Load diff

44
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/API/HOWTO.pod Normal file
View file

@ -0,0 +1,44 @@
=head1 NAME
CPAN::API::HOWTO - a recipe book for programming with CPAN.pm
=head1 RECIPES
All of these recipes assume that you have put "use CPAN" at the top of
your program.
=head2 What distribution contains a particular module?
my $distribution = CPAN::Shell->expand(
"Module", "Data::UUID"
)->distribution()->pretty_id();
This returns a string of the form "AUTHORID/TARBALL". If you want the
full path and filename to this distribution on a CPAN mirror, then it is
C<.../authors/id/A/AU/AUTHORID/TARBALL>.
=head2 What modules does a particular distribution contain?
CPAN::Index->reload();
my @modules = CPAN::Shell->expand(
"Distribution", "JHI/Graph-0.83.tar.gz"
)->containsmods();
You may also refer to a distribution in the form A/AU/AUTHORID/TARBALL.
=head1 SEE ALSO
the main CPAN.pm documentation
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=head1 AUTHOR
David Cantrell
=cut

236
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Author.pm Normal file
View file

@ -0,0 +1,236 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Author;
use strict;
use CPAN::InfoObj;
@CPAN::Author::ISA = qw(CPAN::InfoObj);
use vars qw(
$VERSION
);
$VERSION = "5.5002";
package CPAN::Author;
use strict;
#-> sub CPAN::Author::force
sub force {
my $self = shift;
$self->{force}++;
}
#-> sub CPAN::Author::force
sub unforce {
my $self = shift;
delete $self->{force};
}
#-> sub CPAN::Author::id
sub id {
my $self = shift;
my $id = $self->{ID};
$CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
$id;
}
#-> sub CPAN::Author::as_glimpse ;
sub as_glimpse {
my($self) = @_;
my(@m);
my $class = ref($self);
$class =~ s/^CPAN:://;
push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
$class,
$self->{ID},
$self->fullname,
$self->email);
join "", @m;
}
#-> sub CPAN::Author::fullname ;
sub fullname {
shift->ro->{FULLNAME};
}
*name = \&fullname;
#-> sub CPAN::Author::email ;
sub email { shift->ro->{EMAIL}; }
#-> sub CPAN::Author::ls ;
sub ls {
my $self = shift;
my $glob = shift || "";
my $silent = shift || 0;
my $id = $self->id;
# adapted from CPAN::Distribution::verifyCHECKSUM ;
my(@csf); # chksumfile
@csf = $self->id =~ /(.)(.)(.*)/;
$csf[1] = join "", @csf[0,1];
$csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
my(@dl);
@dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
unless (grep {$_->[2] eq $csf[1]} @dl) {
$CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
return;
}
@dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
unless (grep {$_->[2] eq $csf[2]} @dl) {
$CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
return;
}
@dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
if ($glob) {
if ($CPAN::META->has_inst("Text::Glob")) {
$glob =~ s|/$|/*|;
my $rglob = Text::Glob::glob_to_regex($glob);
CPAN->debug("glob[$glob]rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
my @tmpdl = grep { $_->[2] =~ /$rglob/ } @dl;
if (1==@tmpdl && $tmpdl[0][0]==0) {
$rglob = Text::Glob::glob_to_regex("$glob/*");
@dl = grep { $_->[2] =~ /$rglob/ } @dl;
} else {
@dl = @tmpdl;
}
CPAN->debug("rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
} else {
$CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
}
}
unless ($silent >= 2) {
$CPAN::Frontend->myprint
(
join "",
map {
sprintf
(
"%8d %10s %s/%s%s\n",
$_->[0],
$_->[1],
$id,
$_->[2],
0==$_->[0]?"/":"",
)
} sort { $a->[2] cmp $b->[2] } @dl
);
}
@dl;
}
# returns an array of arrays, the latter contain (size,mtime,filename)
#-> sub CPAN::Author::dir_listing ;
sub dir_listing {
my $self = shift;
my $chksumfile = shift;
my $recursive = shift;
my $may_ftp = shift;
my $lc_want =
File::Spec->catfile($CPAN::Config->{keep_source_where},
"authors", "id", @$chksumfile);
my $fh;
CPAN->debug("chksumfile[@$chksumfile]recursive[$recursive]may_ftp[$may_ftp]") if $CPAN::DEBUG;
# Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
# hazard. (Without GPG installed they are not that much better,
# though.)
$fh = FileHandle->new;
if (open($fh, $lc_want)) {
my $line = <$fh>; close $fh;
unlink($lc_want) unless $line =~ /PGP/;
}
local($") = "/";
# connect "force" argument with "index_expire".
my $force = $self->{force};
if (my @stat = stat $lc_want) {
$force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
}
my $lc_file;
if ($may_ftp) {
$lc_file = eval {
CPAN::FTP->localize
(
"authors/id/@$chksumfile",
$lc_want,
$force,
);
};
unless ($lc_file) {
$CPAN::Frontend->myprint("Trying $lc_want.gz\n");
$chksumfile->[-1] .= ".gz";
$lc_file = eval {
CPAN::FTP->localize
("authors/id/@$chksumfile",
"$lc_want.gz",
1,
);
};
if ($lc_file) {
$lc_file =~ s{\.gz(?!\n)\Z}{}; #};
eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
} else {
return;
}
}
} else {
$lc_file = $lc_want;
# we *could* second-guess and if the user has a file: URL,
# then we could look there. But on the other hand, if they do
# have a file: URL, why did they choose to set
# $CPAN::Config->{show_upload_date} to false?
}
# adapted from CPAN::Distribution::CHECKSUM_check_file ;
$fh = FileHandle->new;
my($cksum);
if (open $fh, $lc_file) {
local($/);
my $eval = <$fh>;
$eval =~ s/\015?\012/\n/g;
close $fh;
my($compmt) = Safe->new();
$cksum = $compmt->reval($eval);
if ($@) {
rename $lc_file, "$lc_file.bad";
Carp::confess($@) if $@;
}
} elsif ($may_ftp) {
Carp::carp ("Could not open '$lc_file' for reading.");
} else {
# Maybe should warn: "You may want to set show_upload_date to a true value"
return;
}
my(@result,$f);
for $f (sort keys %$cksum) {
if (exists $cksum->{$f}{isdir}) {
if ($recursive) {
my(@dir) = @$chksumfile;
pop @dir;
push @dir, $f, "CHECKSUMS";
push @result, [ 0, "-", $f ];
push @result, map {
[$_->[0], $_->[1], "$f/$_->[2]"]
} $self->dir_listing(\@dir,1,$may_ftp);
} else {
push @result, [ 0, "-", $f ];
}
} else {
push @result, [
($cksum->{$f}{"size"}||0),
$cksum->{$f}{"mtime"}||"---",
$f
];
}
}
@result;
}
#-> sub CPAN::Author::reports
sub reports {
$CPAN::Frontend->mywarn("reports on authors not implemented.
Please file a bugreport if you need this.\n");
}
1;

306
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Bundle.pm Normal file
View file

@ -0,0 +1,306 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Bundle;
use strict;
use CPAN::Module;
@CPAN::Bundle::ISA = qw(CPAN::Module);
use vars qw(
$VERSION
);
$VERSION = "5.5005";
sub look {
my $self = shift;
$CPAN::Frontend->myprint($self->as_string);
}
#-> CPAN::Bundle::undelay
sub undelay {
my $self = shift;
delete $self->{later};
for my $c ( $self->contains ) {
my $obj = CPAN::Shell->expandany($c) or next;
if ($obj->id eq $self->id){
my $id = $obj->id;
$CPAN::Frontend->mywarn("$id seems to contain itself, skipping\n");
next;
}
$obj->undelay;
}
}
# mark as dirty/clean
#-> sub CPAN::Bundle::color_cmd_tmps ;
sub color_cmd_tmps {
my($self) = shift;
my($depth) = shift || 0;
my($color) = shift || 0;
my($ancestors) = shift || [];
# a module needs to recurse to its cpan_file, a distribution needs
# to recurse into its prereq_pms, a bundle needs to recurse into its modules
return if exists $self->{incommandcolor}
&& $color==1
&& $self->{incommandcolor}==$color;
if ($depth>=$CPAN::MAX_RECURSION) {
my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
if ($e->is_resolvable) {
return $self->{incommandcolor}=2;
} else {
die $e;
}
}
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
for my $c ( $self->contains ) {
my $obj = CPAN::Shell->expandany($c) or next;
CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
$obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
}
# never reached code?
#if ($color==0) {
#delete $self->{badtestcnt};
#}
$self->{incommandcolor} = $color;
}
#-> sub CPAN::Bundle::as_string ;
sub as_string {
my($self) = @_;
$self->contains;
# following line must be "=", not "||=" because we have a moving target
$self->{INST_VERSION} = $self->inst_version;
return $self->SUPER::as_string;
}
#-> sub CPAN::Bundle::contains ;
sub contains {
my($self) = @_;
my($inst_file) = $self->inst_file || "";
my($id) = $self->id;
$self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
undef $inst_file;
}
unless ($inst_file) {
# Try to get at it in the cpan directory
$self->debug("no inst_file") if $CPAN::DEBUG;
my $cpan_file;
$CPAN::Frontend->mydie("I don't know a bundle with ID '$id'\n") unless
$cpan_file = $self->cpan_file;
if ($cpan_file eq "N/A") {
$CPAN::Frontend->mywarn("Bundle '$id' not found on disk and not on CPAN. Maybe stale symlink? Maybe removed during session?\n");
return;
}
my $dist = $CPAN::META->instance('CPAN::Distribution',
$self->cpan_file);
$self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
$dist->get;
$self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
my($todir) = $CPAN::Config->{'cpan_home'};
my(@me,$from,$to,$me);
@me = split /::/, $self->id;
$me[-1] .= ".pm";
$me = File::Spec->catfile(@me);
my $build_dir;
unless ($build_dir = $dist->{build_dir}) {
$CPAN::Frontend->mywarn("Warning: cannot determine bundle content without a build_dir.\n");
return;
}
$from = $self->find_bundle_file($build_dir,join('/',@me));
$to = File::Spec->catfile($todir,$me);
File::Path::mkpath(File::Basename::dirname($to));
File::Copy::copy($from, $to)
or Carp::confess("Couldn't copy $from to $to: $!");
$inst_file = $to;
}
my @result;
my $fh = FileHandle->new;
local $/ = "\n";
open($fh,$inst_file) or die "Could not open '$inst_file': $!";
my $in_cont = 0;
$self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
while (<$fh>) {
$in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
next unless $in_cont;
next if /^=/;
s/\#.*//;
next if /^\s+$/;
chomp;
push @result, (split " ", $_, 2)[0];
}
close $fh;
delete $self->{STATUS};
$self->{CONTAINS} = \@result;
$self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
unless (@result) {
$CPAN::Frontend->mywarn(qq{
The bundle file "$inst_file" may be a broken
bundlefile. It seems not to contain any bundle definition.
Please check the file and if it is bogus, please delete it.
Sorry for the inconvenience.
});
}
@result;
}
#-> sub CPAN::Bundle::find_bundle_file
# $where is in local format, $what is in unix format
sub find_bundle_file {
my($self,$where,$what) = @_;
$self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
### my $bu = File::Spec->catfile($where,$what);
### return $bu if -f $bu;
my $manifest = File::Spec->catfile($where,"MANIFEST");
unless (-f $manifest) {
require ExtUtils::Manifest;
my $cwd = CPAN::anycwd();
$self->safe_chdir($where);
ExtUtils::Manifest::mkmanifest();
$self->safe_chdir($cwd);
}
my $fh = FileHandle->new($manifest)
or Carp::croak("Couldn't open $manifest: $!");
local($/) = "\n";
my $bundle_filename = $what;
$bundle_filename =~ s|Bundle.*/||;
my $bundle_unixpath;
while (<$fh>) {
next if /^\s*\#/;
my($file) = /(\S+)/;
if ($file =~ m|\Q$what\E$|) {
$bundle_unixpath = $file;
# return File::Spec->catfile($where,$bundle_unixpath); # bad
last;
}
# retry if she managed to have no Bundle directory
$bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
}
return File::Spec->catfile($where, split /\//, $bundle_unixpath)
if $bundle_unixpath;
Carp::croak("Couldn't find a Bundle file in $where");
}
# needs to work quite differently from Module::inst_file because of
# cpan_home/Bundle/ directory and the possibility that we have
# shadowing effect. As it makes no sense to take the first in @INC for
# Bundles, we parse them all for $VERSION and take the newest.
#-> sub CPAN::Bundle::inst_file ;
sub inst_file {
my($self) = @_;
my($inst_file);
my(@me);
@me = split /::/, $self->id;
$me[-1] .= ".pm";
my($incdir,$bestv);
foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
my $parsefile = File::Spec->catfile($incdir, @me);
CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
next unless -f $parsefile;
my $have = eval { MM->parse_version($parsefile); };
if ($@) {
$CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
}
if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
$self->{INST_FILE} = $parsefile;
$self->{INST_VERSION} = $bestv = $have;
}
}
$self->{INST_FILE};
}
#-> sub CPAN::Bundle::inst_version ;
sub inst_version {
my($self) = @_;
$self->inst_file; # finds INST_VERSION as side effect
$self->{INST_VERSION};
}
#-> sub CPAN::Bundle::rematein ;
sub rematein {
my($self,$meth) = @_;
$self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
my($id) = $self->id;
Carp::croak( "Can't $meth $id, don't have an associated bundle file. :-(\n" )
unless $self->inst_file || $self->cpan_file;
my($s,%fail);
for $s ($self->contains) {
my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
$s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
if ($type eq 'CPAN::Distribution') {
$CPAN::Frontend->mywarn(qq{
The Bundle }.$self->id.qq{ contains
explicitly a file '$s'.
Going to $meth that.
});
$CPAN::Frontend->mysleep(5);
}
# possibly noisy action:
$self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
my $obj = $CPAN::META->instance($type,$s);
$obj->{reqtype} = $self->{reqtype};
$obj->{viabundle} ||= { id => $id, reqtype => $self->{reqtype}, optional => !$self->{mandatory}};
# $obj->$meth();
# XXX should optional be based on whether bundle was optional? -- xdg, 2012-04-01
# A: Sure, what could demand otherwise? --andk, 2013-11-25
CPAN::Queue->queue_item(qmod => $obj->id, reqtype => $self->{reqtype}, optional => !$self->{mandatory});
}
}
# If a bundle contains another that contains an xs_file we have here,
# we just don't bother I suppose
#-> sub CPAN::Bundle::xs_file
sub xs_file {
return 0;
}
#-> sub CPAN::Bundle::force ;
sub fforce { shift->rematein('fforce',@_); }
#-> sub CPAN::Bundle::force ;
sub force { shift->rematein('force',@_); }
#-> sub CPAN::Bundle::notest ;
sub notest { shift->rematein('notest',@_); }
#-> sub CPAN::Bundle::get ;
sub get { shift->rematein('get',@_); }
#-> sub CPAN::Bundle::make ;
sub make { shift->rematein('make',@_); }
#-> sub CPAN::Bundle::test ;
sub test {
my $self = shift;
# $self->{badtestcnt} ||= 0;
$self->rematein('test',@_);
}
#-> sub CPAN::Bundle::install ;
sub install {
my $self = shift;
$self->rematein('install',@_);
}
#-> sub CPAN::Bundle::clean ;
sub clean { shift->rematein('clean',@_); }
#-> sub CPAN::Bundle::uptodate ;
sub uptodate {
my($self) = @_;
return 0 unless $self->SUPER::uptodate; # we must have the current Bundle def
my $c;
foreach $c ($self->contains) {
my $obj = CPAN::Shell->expandany($c);
return 0 unless $obj->uptodate;
}
return 1;
}
#-> sub CPAN::Bundle::readme ;
sub readme {
my($self) = @_;
my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
No File found for bundle } . $self->id . qq{\n}), return;
$self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
$CPAN::META->instance('CPAN::Distribution',$file)->readme;
}
1;

249
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/CacheMgr.pm Normal file
View file

@ -0,0 +1,249 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::CacheMgr;
use strict;
use CPAN::InfoObj;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
use Cwd qw(chdir);
use File::Find;
use vars qw(
$VERSION
);
$VERSION = "5.5002";
package CPAN::CacheMgr;
use strict;
#-> sub CPAN::CacheMgr::as_string ;
sub as_string {
eval { require Data::Dumper };
if ($@) {
return shift->SUPER::as_string;
} else {
return Data::Dumper::Dumper(shift);
}
}
#-> sub CPAN::CacheMgr::cachesize ;
sub cachesize {
shift->{DU};
}
#-> sub CPAN::CacheMgr::tidyup ;
sub tidyup {
my($self) = @_;
return unless $CPAN::META->{LOCK};
return unless -d $self->{ID};
my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
for my $current (0..$#toremove) {
my $toremove = $toremove[$current];
$CPAN::Frontend->myprint(sprintf(
"DEL(%d/%d): %s \n",
$current+1,
scalar @toremove,
$toremove,
)
);
return if $CPAN::Signal;
$self->_clean_cache($toremove);
return if $CPAN::Signal;
}
$self->{FIFO} = [];
}
#-> sub CPAN::CacheMgr::dir ;
sub dir {
shift->{ID};
}
#-> sub CPAN::CacheMgr::entries ;
sub entries {
my($self,$dir) = @_;
return unless defined $dir;
$self->debug("reading dir[$dir]") if $CPAN::DEBUG;
$dir ||= $self->{ID};
my($cwd) = CPAN::anycwd();
chdir $dir or Carp::croak("Can't chdir to $dir: $!");
my $dh = DirHandle->new(File::Spec->curdir)
or Carp::croak("Couldn't opendir $dir: $!");
my(@entries);
for ($dh->read) {
next if $_ eq "." || $_ eq "..";
if (-f $_) {
push @entries, File::Spec->catfile($dir,$_);
} elsif (-d _) {
push @entries, File::Spec->catdir($dir,$_);
} else {
$CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
}
}
chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
sort { -M $a <=> -M $b} @entries;
}
#-> sub CPAN::CacheMgr::disk_usage ;
sub disk_usage {
my($self,$dir,$fast) = @_;
return if exists $self->{SIZE}{$dir};
return if $CPAN::Signal;
my($Du) = 0;
if (-e $dir) {
if (-d $dir) {
unless (-x $dir) {
unless (chmod 0755, $dir) {
$CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
"permission to change the permission; cannot ".
"estimate disk usage of '$dir'\n");
$CPAN::Frontend->mysleep(5);
return;
}
}
} elsif (-f $dir) {
# nothing to say, no matter what the permissions
}
} else {
$CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
return;
}
if ($fast) {
$Du = 0; # placeholder
} else {
find(
sub {
$File::Find::prune++ if $CPAN::Signal;
return if -l $_;
if ($^O eq 'MacOS') {
require Mac::Files;
my $cat = Mac::Files::FSpGetCatInfo($_);
$Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
} else {
if (-d _) {
unless (-x _) {
unless (chmod 0755, $_) {
$CPAN::Frontend->mywarn("I have neither the -x permission nor ".
"the permission to change the permission; ".
"can only partially estimate disk usage ".
"of '$_'\n");
$CPAN::Frontend->mysleep(5);
return;
}
}
} else {
$Du += (-s _);
}
}
},
$dir
);
}
return if $CPAN::Signal;
$self->{SIZE}{$dir} = $Du/1024/1024;
unshift @{$self->{FIFO}}, $dir;
$self->debug("measured $dir is $Du") if $CPAN::DEBUG;
$self->{DU} += $Du/1024/1024;
$self->{DU};
}
#-> sub CPAN::CacheMgr::_clean_cache ;
sub _clean_cache {
my($self,$dir) = @_;
return unless -e $dir;
unless (File::Spec->canonpath(File::Basename::dirname($dir))
eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
$CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
"will not remove\n");
$CPAN::Frontend->mysleep(5);
return;
}
$self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
if $CPAN::DEBUG;
File::Path::rmtree($dir);
my $id_deleted = 0;
if ($dir !~ /\.yml$/ && -f "$dir.yml") {
my $yaml_module = CPAN::_yaml_module();
if ($CPAN::META->has_inst($yaml_module)) {
my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
if ($@) {
$CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
unlink "$dir.yml" or
$CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
return;
} elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
$CPAN::META->delete("CPAN::Distribution", $id);
# XXX we should restore the state NOW, otherwise this
# distro does not exist until we read an index. BUG ALERT(?)
# $CPAN::Frontend->mywarn (" +++\n");
$id_deleted++;
}
}
unlink "$dir.yml"; # may fail
unless ($id_deleted) {
CPAN->debug("no distro found associated with '$dir'");
}
}
$self->{DU} -= $self->{SIZE}{$dir};
delete $self->{SIZE}{$dir};
}
#-> sub CPAN::CacheMgr::new ;
sub new {
my($class,$phase) = @_;
$phase ||= "atstart";
my $time = time;
my($debug,$t2);
$debug = "";
my $self = {
ID => $CPAN::Config->{build_dir},
MAX => $CPAN::Config->{'build_cache'},
SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
DU => 0
};
$CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
unless $self->{SCAN} =~ /never|atstart|atexit/;
File::Path::mkpath($self->{ID});
my $dh = DirHandle->new($self->{ID});
bless $self, $class;
$self->scan_cache($phase);
$t2 = time;
$debug .= "timing of CacheMgr->new: ".($t2 - $time);
$time = $t2;
CPAN->debug($debug) if $CPAN::DEBUG;
$self;
}
#-> sub CPAN::CacheMgr::scan_cache ;
sub scan_cache {
my ($self, $phase) = @_;
$phase = '' unless defined $phase;
return unless $phase eq $self->{SCAN};
return unless $CPAN::META->{LOCK};
$CPAN::Frontend->myprint(
sprintf("Scanning cache %s for sizes\n",
$self->{ID}));
my $e;
my @entries = $self->entries($self->{ID});
my $i = 0;
my $painted = 0;
for $e (@entries) {
my $symbol = ".";
if ($self->{DU} > $self->{MAX}) {
$symbol = "-";
$self->disk_usage($e,1);
} else {
$self->disk_usage($e);
}
$i++;
while (($painted/76) < ($i/@entries)) {
$CPAN::Frontend->myprint($symbol);
$painted++;
}
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
$self->tidyup;
}
1;

175
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Complete.pm Normal file
View file

@ -0,0 +1,175 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Complete;
use strict;
@CPAN::Complete::ISA = qw(CPAN::Debug);
# Q: where is the "How do I add a new command" HOWTO?
# A: git log -p -1 355c44e9caaec857e4b12f51afb96498833c3e36 where andk added the report command
@CPAN::Complete::COMMANDS = sort qw(
? ! a b d h i m o q r u
autobundle
bye
clean
cvs_import
dump
exit
failed
force
fforce
hosts
install
install_tested
is_tested
look
ls
make
mkmyconfig
notest
perldoc
quit
readme
recent
recompile
reload
report
reports
scripts
smoke
test
upgrade
);
use vars qw(
$VERSION
);
$VERSION = "5.5001";
package CPAN::Complete;
use strict;
sub gnu_cpl {
my($text, $line, $start, $end) = @_;
my(@perlret) = cpl($text, $line, $start);
# find longest common match. Can anybody show me how to peruse
# T::R::Gnu to have this done automatically? Seems expensive.
return () unless @perlret;
my($newtext) = $text;
for (my $i = length($text)+1;;$i++) {
last unless length($perlret[0]) && length($perlret[0]) >= $i;
my $try = substr($perlret[0],0,$i);
my @tries = grep {substr($_,0,$i) eq $try} @perlret;
# warn "try[$try]tries[@tries]";
if (@tries == @perlret) {
$newtext = $try;
} else {
last;
}
}
($newtext,@perlret);
}
#-> sub CPAN::Complete::cpl ;
sub cpl {
my($word,$line,$pos) = @_;
$word ||= "";
$line ||= "";
$pos ||= 0;
CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
$line =~ s/^\s*//;
if ($line =~ s/^((?:notest|f?force)\s*)//) {
$pos -= length($1);
}
my @return;
if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
@return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
} elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
@return = ();
} elsif ($line =~ /^a\s/) {
@return = cplx('CPAN::Author',uc($word));
} elsif ($line =~ /^ls\s/) {
my($author,$rest) = $word =~ m|([^/]+)/?(.*)|;
@return = $rest ? () : map {"$_/"} cplx('CPAN::Author',uc($author||""));
if (0 && 1==@return) { # XXX too slow and even wrong when there is a * already
@return = grep /^\Q$word\E/, map {"$author/$_->[2]"} CPAN::Shell->expand("Author",$author)->ls("$rest*","2");
}
} elsif ($line =~ /^b\s/) {
CPAN::Shell->local_bundles;
@return = cplx('CPAN::Bundle',$word);
} elsif ($line =~ /^d\s/) {
@return = cplx('CPAN::Distribution',$word);
} elsif ($line =~ m/^(
[mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
)\s/x ) {
if ($word =~ /^Bundle::/) {
CPAN::Shell->local_bundles;
}
@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
} elsif ($line =~ /^i\s/) {
@return = cpl_any($word);
} elsif ($line =~ /^reload\s/) {
@return = cpl_reload($word,$line,$pos);
} elsif ($line =~ /^o\s/) {
@return = cpl_option($word,$line,$pos);
} elsif ($line =~ m/^\S+\s/ ) {
# fallback for future commands and what we have forgotten above
@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
} else {
@return = ();
}
return @return;
}
#-> sub CPAN::Complete::cplx ;
sub cplx {
my($class, $word) = @_;
if (CPAN::_sqlite_running()) {
$CPAN::SQLite->search($class, "^\Q$word\E");
}
my $method = "id";
$method = "pretty_id" if $class eq "CPAN::Distribution";
sort grep /^\Q$word\E/, map { $_->$method() } $CPAN::META->all_objects($class);
}
#-> sub CPAN::Complete::cpl_any ;
sub cpl_any {
my($word) = shift;
return (
cplx('CPAN::Author',$word),
cplx('CPAN::Bundle',$word),
cplx('CPAN::Distribution',$word),
cplx('CPAN::Module',$word),
);
}
#-> sub CPAN::Complete::cpl_reload ;
sub cpl_reload {
my($word,$line,$pos) = @_;
$word ||= "";
my(@words) = split " ", $line;
CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
my(@ok) = qw(cpan index);
return @ok if @words == 1;
return grep /^\Q$word\E/, @ok if @words == 2 && $word;
}
#-> sub CPAN::Complete::cpl_option ;
sub cpl_option {
my($word,$line,$pos) = @_;
$word ||= "";
my(@words) = split " ", $line;
CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
my(@ok) = qw(conf debug);
return @ok if @words == 1;
return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
if (0) {
} elsif ($words[1] eq 'index') {
return ();
} elsif ($words[1] eq 'conf') {
return CPAN::HandleConfig::cpl(@_);
} elsif ($words[1] eq 'debug') {
return sort grep /^\Q$word\E/i,
sort keys %CPAN::DEBUG, 'all';
}
}
1;

83
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Debug.pm Normal file
View file

@ -0,0 +1,83 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN::Debug;
use strict;
use vars qw($VERSION);
$VERSION = "5.5001";
# module is internal to CPAN.pm
%CPAN::DEBUG = qw[
CPAN 1
Index 2
InfoObj 4
Author 8
Distribution 16
Bundle 32
Module 64
CacheMgr 128
Complete 256
FTP 512
Shell 1024
Eval 2048
HandleConfig 4096
Tarzip 8192
Version 16384
Queue 32768
FirstTime 65536
];
$CPAN::DEBUG ||= 0;
#-> sub CPAN::Debug::debug ;
sub debug {
my($self,$arg) = @_;
my @caller;
my $i = 0;
while () {
my(@c) = (caller($i))[0 .. ($i ? 3 : 2)];
last unless defined $c[0];
push @caller, \@c;
for (0,3) {
last if $_ > $#c;
$c[$_] =~ s/.*:://;
}
for (1) {
$c[$_] =~ s|.*/||;
}
last if ++$i>=3;
}
pop @caller;
if ($CPAN::DEBUG{$caller[0][0]} & $CPAN::DEBUG) {
if ($arg and ref $arg) {
eval { require Data::Dumper };
if ($@) {
$CPAN::Frontend->myprint("Debug(\n" . $arg->as_string . ")\n");
} else {
$CPAN::Frontend->myprint("Debug(\n" . Data::Dumper::Dumper($arg) . ")\n");
}
} else {
my $outer = "";
local $" = ",";
if (@caller>1) {
$outer = ",[@{$caller[1]}]";
}
$CPAN::Frontend->myprint("Debug(@{$caller[0]}$outer): $arg\n");
}
}
}
1;
__END__
=head1 NAME
CPAN::Debug - internal debugging for CPAN.pm
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

16
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/DeferredCode.pm Normal file
View file

@ -0,0 +1,16 @@
package CPAN::DeferredCode;
use strict;
use vars qw/$VERSION/;
use overload fallback => 1, map { ($_ => 'run') } qw/
bool "" 0+
/;
$VERSION = "5.50";
sub run {
$_[0]->();
}
1;

4930
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Distribution.pm Normal file
View file

File diff suppressed because it is too large Load diff

481
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Distroprefs.pm Normal file
View file

@ -0,0 +1,481 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
use 5.006;
use strict;
package CPAN::Distroprefs;
use vars qw($VERSION);
$VERSION = '6.0001';
package CPAN::Distroprefs::Result;
use File::Spec;
sub new { bless $_[1] || {} => $_[0] }
sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) }
sub __cloner {
my ($class, $name, $newclass) = @_;
$newclass = 'CPAN::Distroprefs::Result::' . $newclass;
no strict 'refs';
*{$class . '::' . $name} = sub {
$newclass->new({
%{ $_[0] },
%{ $_[1] },
});
};
}
BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') }
BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') }
BEGIN { __PACKAGE__->__cloner(as_success => 'Success') }
sub __accessor {
my ($class, $key) = @_;
no strict 'refs';
*{$class . '::' . $key} = sub { $_[0]->{$key} };
}
BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) }
sub is_warning { 0 }
sub is_fatal { 0 }
sub is_success { 0 }
package CPAN::Distroprefs::Result::Error;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
BEGIN { __PACKAGE__->__accessor($_) for qw(msg) }
sub as_string {
my ($self) = @_;
if ($self->msg) {
return sprintf $self->fmt_reason, $self->file, $self->msg;
} else {
return sprintf $self->fmt_unknown, $self->file;
}
}
package CPAN::Distroprefs::Result::Warning;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
sub is_warning { 1 }
sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" }
sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." }
package CPAN::Distroprefs::Result::Fatal;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
sub is_fatal { 1 }
sub fmt_reason { "Error reading distroprefs file %s: %s" }
sub fmt_unknown { "Unknown error reading distroprefs file %s." }
package CPAN::Distroprefs::Result::Success;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) }
sub is_success { 1 }
package CPAN::Distroprefs::Iterator;
sub new { bless $_[1] => $_[0] }
sub next { $_[0]->() }
package CPAN::Distroprefs;
use Carp ();
use DirHandle;
sub _load_method {
my ($self, $loader, $result) = @_;
return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/;
return '_load_' . $result->ext;
}
sub _load_yaml {
my ($self, $loader, $result) = @_;
my $data = eval {
$loader eq 'CPAN'
? $loader->_yaml_loadfile($result->abs)
: [ $loader->can('LoadFile')->($result->abs) ]
};
if (my $err = $@) {
die $result->as_warning({
msg => $err,
});
} elsif (!$data) {
die $result->as_warning;
} else {
return @$data;
}
}
sub _load_dd {
my ($self, $loader, $result) = @_;
my @data;
{
package CPAN::Eval;
# this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm
# not sure why we wouldn't just skip the file as we do for all other
# errors. -- hdp
my $abs = $result->abs;
open FH, "<$abs" or die $result->as_fatal(msg => "$!");
local $/;
my $eval = <FH>;
close FH;
no strict;
eval $eval;
if (my $err = $@) {
die $result->as_warning({ msg => $err });
}
my $i = 1;
while (${"VAR$i"}) {
push @data, ${"VAR$i"};
$i++;
}
}
return @data;
}
sub _load_st {
my ($self, $loader, $result) = @_;
# eval because Storable is never forward compatible
my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } };
if (my $err = $@) {
die $result->as_warning({ msg => $err });
}
return @data;
}
sub _build_file_list {
if (@_ > 3) {
die "_build_file_list should be called with 3 arguments, was called with more. First argument is '$_[0]'.";
}
my ($dir, $dir1, $ext_re) = @_;
my @list;
my $dh;
unless (opendir($dh, $dir)) {
$CPAN::Frontend->mywarn("ignoring prefs directory '$dir': $!");
return @list;
}
while (my $fn = readdir $dh) {
next if $fn eq '.' || $fn eq '..';
if (-d "$dir/$fn") {
next if $fn =~ /^[._]/; # prune .svn, .git, .hg, _darcs and what the user wants to hide
push @list, _build_file_list("$dir/$fn", "$dir1$fn/", $ext_re);
} else {
if ($fn =~ $ext_re) {
push @list, "$dir1$fn";
}
}
}
return @list;
}
sub find {
my ($self, $dir, $ext_map) = @_;
return CPAN::Distroprefs::Iterator->new(sub { return }) unless %$ext_map;
my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
my $ext_re = qr/\.($possible_ext)$/;
my @files = _build_file_list($dir, '', $ext_re);
@files = sort @files if @files;
# label the block so that we can use redo in the middle
return CPAN::Distroprefs::Iterator->new(sub { LOOP: {
my $fn = shift @files;
return unless defined $fn;
my ($ext) = $fn =~ $ext_re;
my $loader = $ext_map->{$ext};
my $result = CPAN::Distroprefs::Result->new({
file => $fn, ext => $ext, dir => $dir
});
# copied from CPAN.pm; is this ever actually possible?
redo unless -f $result->abs;
my $load_method = $self->_load_method($loader, $result);
my @prefs = eval { $self->$load_method($loader, $result) };
if (my $err = $@) {
if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) {
return $err;
}
# rethrow any exceptions that we did not generate
die $err;
} elsif (!@prefs) {
# the loader should have handled this, but just in case:
return $result->as_warning;
}
return $result->as_success({
prefs => [
map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs
],
});
} });
}
package CPAN::Distroprefs::Pref;
use Carp ();
sub new { bless $_[1] => $_[0] }
sub data { shift->{data} }
sub has_any_match { $_[0]->data->{match} ? 1 : 0 }
sub has_match {
my $match = $_[0]->data->{match} || return 0;
exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
}
sub has_valid_subkeys {
grep { exists $_[0]->data->{match}{$_} }
map { $_, "not_$_" }
$_[0]->match_attributes
}
sub _pattern {
my $re = shift;
my $p = eval sprintf 'qr{%s}', $re;
if ($@) {
$@ =~ s/\n$//;
die "Error in Distroprefs pattern qr{$re}\n$@";
}
return $p;
}
sub _match_scalar {
my ($match, $data) = @_;
my $qr = _pattern($match);
return $data =~ /$qr/;
}
sub _match_hash {
my ($match, $data) = @_;
for my $mkey (keys %$match) {
(my $dkey = $mkey) =~ s/^not_//;
my $val = defined $data->{$dkey} ? $data->{$dkey} : '';
if (_match_scalar($match->{$mkey}, $val)) {
return 0 if $mkey =~ /^not_/;
}
else {
return 0 if $mkey !~ /^not_/;
}
}
return 1;
}
sub _match {
my ($self, $key, $data, $matcher) = @_;
my $m = $self->data->{match};
if (exists $m->{$key}) {
return 0 unless $matcher->($m->{$key}, $data);
}
if (exists $m->{"not_$key"}) {
return 0 if $matcher->($m->{"not_$key"}, $data);
}
return 1;
}
sub _scalar_match {
my ($self, $key, $data) = @_;
return $self->_match($key, $data, \&_match_scalar);
}
sub _hash_match {
my ($self, $key, $data) = @_;
return $self->_match($key, $data, \&_match_hash);
}
# do not take the order of C<keys %$match> because "module" is by far the
# slowest
sub match_attributes { qw(env distribution perl perlconfig module) }
sub match_module {
my ($self, $modules) = @_;
return $self->_match("module", $modules, sub {
my($match, $data) = @_;
my $qr = _pattern($match);
for my $module (@$data) {
return 1 if $module =~ /$qr/;
}
return 0;
});
}
sub match_distribution { shift->_scalar_match(distribution => @_) }
sub match_perl { shift->_scalar_match(perl => @_) }
sub match_perlconfig { shift->_hash_match(perlconfig => @_) }
sub match_env { shift->_hash_match(env => @_) }
sub matches {
my ($self, $arg) = @_;
my $default_match = 0;
for my $key (grep { $self->has_match($_) } $self->match_attributes) {
unless (exists $arg->{$key}) {
Carp::croak "Can't match pref: missing argument key $key";
}
$default_match = 1;
my $val = $arg->{$key};
# make it possible to avoid computing things until we have to
if (ref($val) eq 'CODE') { $val = $val->() }
my $meth = "match_$key";
return 0 unless $self->$meth($val);
}
return $default_match;
}
1;
__END__
=head1 NAME
CPAN::Distroprefs -- read and match distroprefs
=head1 SYNOPSIS
use CPAN::Distroprefs;
my %info = (... distribution/environment info ...);
my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map);
while (my $result = $finder->next) {
die $result->as_string if $result->is_fatal;
warn($result->as_string), next if $result->is_warning;
for my $pref (@{ $result->prefs }) {
if ($pref->matches(\%info)) {
return $pref;
}
}
}
=head1 DESCRIPTION
This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions.
=head1 INTERFACE
my $finder = CPAN::Distroprefs->find($dir, \%ext_map);
while (my $result = $finder->next) { ... }
Build an iterator which finds distroprefs files in the tree below the
given directory. Within the tree directories matching C<m/^[._]/> are
pruned.
C<%ext_map> is a hashref whose keys are file extensions and whose values are
modules used to load matching files:
{
'yml' => 'YAML::Syck',
'dd' => 'Data::Dumper',
...
}
Each time C<< $finder->next >> is called, the iterator returns one of two
possible values:
=over
=item * a CPAN::Distroprefs::Result object
=item * C<undef>, indicating that no prefs files remain to be found
=back
=head1 RESULTS
L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
indicate success or failure when reading a prefs file.
=head2 Common
All results share some common attributes:
=head3 type
C<success>, C<warning>, or C<fatal>
=head3 file
the file from which these prefs were read, or to which this error refers (relative filename)
=head3 ext
the file's extension, which determines how to load it
=head3 dir
the directory the file was read from
=head3 abs
the absolute path to the file
=head2 Errors
Error results (warning and fatal) contain:
=head3 msg
the error message (usually either C<$!> or a YAML error)
=head2 Successes
Success results contain:
=head3 prefs
an arrayref of CPAN::Distroprefs::Pref objects
=head1 PREFS
CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
They are constructed automatically as part of C<success> results from C<find()>.
=head3 data
the pref information as a hashref, suitable for e.g. passing to Kwalify
=head3 match_attributes
returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)
currently: C<env perl perlconfig distribution module>
=head3 has_any_match
true if this pref has a 'match' attribute at all
=head3 has_valid_subkeys
true if this pref has a 'match' attribute and at least one valid match attribute
=head3 matches
if ($pref->matches(\%arg)) { ... }
true if this pref matches the passed-in hashref, which must have a value for
each of the C<match_attributes> (above)
=head1 LICENSE
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut

45
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Distrostatus.pm Normal file
View file

@ -0,0 +1,45 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Distrostatus;
use overload '""' => "as_string",
fallback => 1;
use vars qw($something_has_failed_at);
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub new {
my($class,$arg) = @_;
my $failed = substr($arg,0,2) eq "NO";
if ($failed) {
$something_has_failed_at = $CPAN::CurrentCommandId;
}
bless {
TEXT => $arg,
FAILED => $failed,
COMMANDID => $CPAN::CurrentCommandId,
TIME => time,
}, $class;
}
sub something_has_just_failed () {
defined $something_has_failed_at &&
$something_has_failed_at == $CPAN::CurrentCommandId;
}
sub commandid { shift->{COMMANDID} }
sub failed { shift->{FAILED} }
sub text {
my($self,$set) = @_;
if (defined $set) {
$self->{TEXT} = $set;
}
$self->{TEXT};
}
sub as_string {
my($self) = @_;
$self->text;
}
1;

113
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Exception/RecursiveDependency.pm Normal file
View file

@ -0,0 +1,113 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::RecursiveDependency;
use strict;
use overload '""' => "as_string";
use vars qw(
$VERSION
);
$VERSION = "5.5001";
{
package CPAN::Exception::RecursiveDependency::na;
use overload '""' => "as_string";
sub new { bless {}, shift };
sub as_string { "N/A" };
}
my $NA = CPAN::Exception::RecursiveDependency::na->new;
# a module sees its distribution (no version)
# a distribution sees its prereqs (which are module names) (usually with versions)
# a bundle sees its module names and/or its distributions (no version)
sub new {
my($class) = shift;
my($deps_arg) = shift;
my (@deps,%seen,$loop_starts_with);
DCHAIN: for my $dep (@$deps_arg) {
push @deps, {name => $dep, display_as => $dep};
if ($seen{$dep}++) {
$loop_starts_with = $dep;
last DCHAIN;
}
}
my $in_loop = 0;
my %mark;
DWALK: for my $i (0..$#deps) {
my $x = $deps[$i]{name};
$in_loop ||= $loop_starts_with && $x eq $loop_starts_with;
my $xo = CPAN::Shell->expandany($x) or next;
if ($xo->isa("CPAN::Module")) {
my $have = $xo->inst_version || $NA;
my($want,$d,$want_type);
if ($i>0 and $d = $deps[$i-1]{name}) {
my $do = CPAN::Shell->expandany($d);
$want = $do->{prereq_pm}{requires}{$x};
if (defined $want) {
$want_type = "requires: ";
} else {
$want = $do->{prereq_pm}{build_requires}{$x};
if (defined $want) {
$want_type = "build_requires: ";
} else {
$want_type = "unknown status";
$want = "???";
}
}
} else {
$want = $xo->cpan_version;
$want_type = "want: ";
}
$deps[$i]{have} = $have;
$deps[$i]{want_type} = $want_type;
$deps[$i]{want} = $want;
$deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
if ((! ref $have || !$have->isa('CPAN::Exception::RecursiveDependency::na'))
&& CPAN::Version->vge($have, $want)) {
# https://rt.cpan.org/Ticket/Display.html?id=115340
undef $loop_starts_with;
last DWALK;
}
} elsif ($xo->isa("CPAN::Distribution")) {
my $pretty = $deps[$i]{display_as} = $xo->pretty_id;
my $mark_as;
if ($in_loop) {
$mark_as = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
} else {
$mark_as = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
}
$mark{$pretty} = { xo => $xo, mark_as => $mark_as };
}
}
if ($loop_starts_with) {
while (my($k,$v) = each %mark) {
my $xo = $v->{xo};
$xo->{make} = $v->{mark_as};
$xo->store_persistent_state; # otherwise I will not reach
# all involved parties for
# the next session
}
}
bless { deps => \@deps, loop_starts_with => $loop_starts_with }, $class;
}
sub is_resolvable {
! defined shift->{loop_starts_with};
}
sub as_string {
my($self) = shift;
my $deps = $self->{deps};
my $loop_starts_with = $self->{loop_starts_with};
unless ($loop_starts_with) {
return "--not a recursive/circular dependency--";
}
my $ret = "\nRecursive dependency detected:\n ";
$ret .= join("\n => ", map {$_->{display_as}} @$deps);
$ret .= ".\nCannot resolve.\n";
$ret;
}
1;

46
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Exception/blocked_urllist.pm Normal file
View file

@ -0,0 +1,46 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::blocked_urllist;
use strict;
use overload '""' => "as_string";
use vars qw(
$VERSION
);
$VERSION = "1.001";
sub new {
my($class) = @_;
bless {}, $class;
}
sub as_string {
my($self) = shift;
if ($CPAN::Config->{connect_to_internet_ok}) {
return qq{
You have not configured a urllist for CPAN mirrors. Configure it with
o conf init urllist
};
} else {
return qq{
You have not configured a urllist and do not allow connections to the
internet to get a list of mirrors. If you wish to get a list of CPAN
mirrors to pick from, use this command
o conf init connect_to_internet_ok urllist
If you do not wish to get a list of mirrors and would prefer to set
your urllist manually, use just this command instead
o conf init urllist
};
}
}
1;

23
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Exception/yaml_not_installed.pm Normal file
View file

@ -0,0 +1,23 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::yaml_not_installed;
use strict;
use overload '""' => "as_string";
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub new {
my($class,$module,$file,$during) = @_;
bless { module => $module, file => $file, during => $during }, $class;
}
sub as_string {
my($self) = shift;
"'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
}
1;

53
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Exception/yaml_process_error.pm Normal file
View file

@ -0,0 +1,53 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::yaml_process_error;
use strict;
use overload '""' => "as_string";
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub new {
my($class,$module,$file,$during,$error) = @_;
# my $at = Carp::longmess(""); # XXX find something more beautiful
bless { module => $module,
file => $file,
during => $during,
error => $error,
# at => $at,
}, $class;
}
sub as_string {
my($self) = shift;
if ($self->{during}) {
if ($self->{file}) {
if ($self->{module}) {
if ($self->{error}) {
return "Alert: While trying to '$self->{during}' YAML file\n".
" '$self->{file}'\n".
"with '$self->{module}' the following error was encountered:\n".
" $self->{error}\n";
} else {
return "Alert: While trying to '$self->{during}' YAML file\n".
" '$self->{file}'\n".
"with '$self->{module}' some unknown error was encountered\n";
}
} else {
return "Alert: While trying to '$self->{during}' YAML file\n".
" '$self->{file}'\n".
"some unknown error was encountered\n";
}
} else {
return "Alert: While trying to '$self->{during}' some YAML file\n".
"some unknown error was encountered\n";
}
} else {
return "Alert: unknown error encountered\n";
}
}
1;

1323
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/FTP.pm Normal file
View file

File diff suppressed because it is too large Load diff

62
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/FTP/netrc.pm Normal file
View file

@ -0,0 +1,62 @@
package CPAN::FTP::netrc;
use strict;
$CPAN::FTP::netrc::VERSION = $CPAN::FTP::netrc::VERSION = "1.01";
# package CPAN::FTP::netrc;
sub new {
my($class) = @_;
my $file = File::Spec->catfile($ENV{HOME},".netrc");
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks)
= stat($file);
$mode ||= 0;
my $protected = 0;
my($fh,@machines,$hasdefault);
$hasdefault = 0;
$fh = FileHandle->new or die "Could not create a filehandle";
if($fh->open($file)) {
$protected = ($mode & 077) == 0;
local($/) = "";
NETRC: while (<$fh>) {
my(@tokens) = split " ", $_;
TOKEN: while (@tokens) {
my($t) = shift @tokens;
if ($t eq "default") {
$hasdefault++;
last NETRC;
}
last TOKEN if $t eq "macdef";
if ($t eq "machine") {
push @machines, shift @tokens;
}
}
}
} else {
$file = $hasdefault = $protected = "";
}
bless {
'mach' => [@machines],
'netrc' => $file,
'hasdefault' => $hasdefault,
'protected' => $protected,
}, $class;
}
# CPAN::FTP::netrc::hasdefault;
sub hasdefault { shift->{'hasdefault'} }
sub netrc { shift->{'netrc'} }
sub protected { shift->{'protected'} }
sub contains {
my($self,$mach) = @_;
for ( @{$self->{'mach'}} ) {
return 1 if $_ eq $mach;
}
return 0;
}
1;

2216
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/FirstTime.pm Normal file
View file

File diff suppressed because it is too large Load diff

255
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/HTTP/Client.pm Normal file
View file

@ -0,0 +1,255 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::HTTP::Client;
use strict;
use vars qw(@ISA);
use CPAN::HTTP::Credentials;
use HTTP::Tiny 0.005;
$CPAN::HTTP::Client::VERSION = $CPAN::HTTP::Client::VERSION = "1.9602";
# CPAN::HTTP::Client is adapted from parts of cpanm by Tatsuhiko Miyagawa
# and parts of LWP by Gisle Aas
sub new {
my $class = shift;
my %args = @_;
for my $k ( keys %args ) {
$args{$k} = '' unless defined $args{$k};
}
$args{no_proxy} = [split(",", $args{no_proxy}) ] if $args{no_proxy};
return bless \%args, $class;
}
# This executes a request with redirection (up to 5) and returns the
# response structure generated by HTTP::Tiny
#
# If authentication fails, it will attempt to get new authentication
# information and repeat up to 5 times
sub mirror {
my($self, $uri, $path) = @_;
my $want_proxy = $self->_want_proxy($uri);
my $http = HTTP::Tiny->new(
verify_SSL => 1,
$want_proxy ? (proxy => $self->{proxy}) : ()
);
my ($response, %headers);
my $retries = 0;
while ( $retries++ < 5 ) {
$response = $http->mirror( $uri, $path, {headers => \%headers} );
if ( $response->{status} eq '401' ) {
last unless $self->_get_auth_params( $response, 'non_proxy' );
}
elsif ( $response->{status} eq '407' ) {
last unless $self->_get_auth_params( $response, 'proxy' );
}
else {
last; # either success or failure
}
my %headers = (
$self->_auth_headers( $uri, 'non_proxy' ),
( $want_proxy ? $self->_auth_headers($uri, 'proxy') : () ),
);
}
return $response;
}
sub _want_proxy {
my ($self, $uri) = @_;
return unless $self->{proxy};
my($host) = $uri =~ m|://([^/:]+)|;
return ! grep { $host =~ /\Q$_\E$/ } @{ $self->{no_proxy} || [] };
}
# Generates the authentication headers for a given mode
# C<mode> is 'proxy' or 'non_proxy'
# C<_${mode}_type> is 'basic' or 'digest'
# C<_${mode}_params> will be the challenge parameters from the 401/407 headers
sub _auth_headers {
my ($self, $uri, $mode) = @_;
# Get names for our mode-specific attributes
my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/;
# If _prepare_auth has not been called, we can't prepare headers
return unless $self->{$type_key};
# Get user credentials for mode
my $cred_method = "get_" . ($mode ? "proxy" : "non_proxy") ."_credentials";
my ($user, $pass) = CPAN::HTTP::Credentials->$cred_method;
# Generate the header for the mode & type
my $header = $mode eq 'proxy' ? 'Proxy-Authorization' : 'Authorization';
my $value_method = "_" . $self->{$type_key} . "_auth";
my $value = $self->$value_method($user, $pass, $self->{$param_key}, $uri);
# If we didn't get a value, we didn't have the right modules available
return $value ? ( $header, $value ) : ();
}
# Extract authentication parameters from headers, but clear any prior
# credentials if we failed (so we might prompt user for password again)
sub _get_auth_params {
my ($self, $response, $mode) = @_;
my $prefix = $mode eq 'proxy' ? 'Proxy' : 'WWW';
my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/;
if ( ! $response->{success} ) { # auth failed
my $method = "clear_${mode}_credentials";
CPAN::HTTP::Credentials->$method;
delete $self->{$_} for $type_key, $param_key;
}
($self->{$type_key}, $self->{$param_key}) =
$self->_get_challenge( $response, "${prefix}-Authenticate");
return $self->{$type_key};
}
# Extract challenge type and parameters for a challenge list
sub _get_challenge {
my ($self, $response, $auth_header) = @_;
my $auth_list = $response->{headers}(lc $auth_header);
return unless defined $auth_list;
$auth_list = [$auth_list] unless ref $auth_list;
for my $challenge (@$auth_list) {
$challenge =~ tr/,/;/; # "," is used to separate auth-params!!
($challenge) = $self->split_header_words($challenge);
my $scheme = shift(@$challenge);
shift(@$challenge); # no value
$challenge = { @$challenge }; # make rest into a hash
unless ($scheme =~ /^(basic|digest)$/) {
next; # bad scheme
}
$scheme = $1; # untainted now
return ($scheme, $challenge);
}
return;
}
# Generate a basic authentication header value
sub _basic_auth {
my ($self, $user, $pass) = @_;
unless ( $CPAN::META->has_usable('MIME::Base64') ) {
$CPAN::Frontend->mywarn(
"MIME::Base64 is required for 'Basic' style authentication"
);
return;
}
return "Basic " . MIME::Base64::encode_base64("$user\:$pass", q{});
}
# Generate a digest authentication header value
sub _digest_auth {
my ($self, $user, $pass, $auth_param, $uri) = @_;
unless ( $CPAN::META->has_usable('Digest::MD5') ) {
$CPAN::Frontend->mywarn(
"Digest::MD5 is required for 'Digest' style authentication"
);
return;
}
my $nc = sprintf "%08X", ++$self->{_nonce_count}{$auth_param->{nonce}};
my $cnonce = sprintf "%8x", time;
my ($path) = $uri =~ m{^\w+?://[^/]+(/.*)$};
$path = "/" unless defined $path;
my $md5 = Digest::MD5->new;
my(@digest);
$md5->add(join(":", $user, $auth_param->{realm}, $pass));
push(@digest, $md5->hexdigest);
$md5->reset;
push(@digest, $auth_param->{nonce});
if ($auth_param->{qop}) {
push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
}
$md5->add(join(":", 'GET', $path));
push(@digest, $md5->hexdigest);
$md5->reset;
$md5->add(join(":", @digest));
my($digest) = $md5->hexdigest;
$md5->reset;
my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
@resp{qw(username uri response algorithm)} = ($user, $path, $digest, "MD5");
if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
@resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
}
my(@order) =
qw(username realm qop algorithm uri nonce nc cnonce response opaque);
my @pairs;
for (@order) {
next unless defined $resp{$_};
push(@pairs, "$_=" . qq("$resp{$_}"));
}
my $auth_value = "Digest " . join(", ", @pairs);
return $auth_value;
}
# split_header_words adapted from HTTP::Headers::Util
sub split_header_words {
my ($self, @words) = @_;
my @res = $self->_split_header_words(@words);
for my $arr (@res) {
for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
$arr->[$i] = lc($arr->[$i]);
}
}
return @res;
}
sub _split_header_words {
my($self, @val) = @_;
my @res;
for (@val) {
my @cur;
while (length) {
if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute'
push(@cur, $1);
# a quoted value
if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
my $val = $1;
$val =~ s/\\(.)/$1/g;
push(@cur, $val);
# some unquoted value
}
elsif (s/^\s*=\s*([^;,\s]*)//) {
my $val = $1;
$val =~ s/\s+$//;
push(@cur, $val);
# no value, a lone token
}
else {
push(@cur, undef);
}
}
elsif (s/^\s*,//) {
push(@res, [@cur]) if @cur;
@cur = ();
}
elsif (s/^\s*;// || s/^\s+//) {
# continue
}
else {
die "This should not happen: '$_'";
}
}
push(@res, \@cur) if @cur;
}
@res;
}
1;

91
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/HTTP/Credentials.pm Normal file
View file

@ -0,0 +1,91 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::HTTP::Credentials;
use strict;
use vars qw($USER $PASSWORD $PROXY_USER $PROXY_PASSWORD);
$CPAN::HTTP::Credentials::VERSION = $CPAN::HTTP::Credentials::VERSION = "1.9601";
sub clear_credentials {
clear_non_proxy_credentials();
clear_proxy_credentials();
}
sub clear_non_proxy_credentials {
undef $USER;
undef $PASSWORD;
}
sub clear_proxy_credentials {
undef $PROXY_USER;
undef $PROXY_PASSWORD;
}
sub get_proxy_credentials {
my $self = shift;
if ($PROXY_USER && $PROXY_PASSWORD) {
return ($PROXY_USER, $PROXY_PASSWORD);
}
if ( defined $CPAN::Config->{proxy_user}
&& $CPAN::Config->{proxy_user}
) {
$PROXY_USER = $CPAN::Config->{proxy_user};
$PROXY_PASSWORD = $CPAN::Config->{proxy_pass} || "";
return ($PROXY_USER, $PROXY_PASSWORD);
}
my $username_prompt = "\nProxy authentication needed!
(Note: to permanently configure username and password run
o conf proxy_user your_username
o conf proxy_pass your_password
)\nUsername:";
($PROXY_USER, $PROXY_PASSWORD) =
_get_username_and_password_from_user($username_prompt);
return ($PROXY_USER,$PROXY_PASSWORD);
}
sub get_non_proxy_credentials {
my $self = shift;
if ($USER && $PASSWORD) {
return ($USER, $PASSWORD);
}
if ( defined $CPAN::Config->{username} ) {
$USER = $CPAN::Config->{username};
$PASSWORD = $CPAN::Config->{password} || "";
return ($USER, $PASSWORD);
}
my $username_prompt = "\nAuthentication needed!
(Note: to permanently configure username and password run
o conf username your_username
o conf password your_password
)\nUsername:";
($USER, $PASSWORD) =
_get_username_and_password_from_user($username_prompt);
return ($USER,$PASSWORD);
}
sub _get_username_and_password_from_user {
my $username_message = shift;
my ($username,$password);
ExtUtils::MakeMaker->import(qw(prompt));
$username = prompt($username_message);
if ($CPAN::META->has_inst("Term::ReadKey")) {
Term::ReadKey::ReadMode("noecho");
}
else {
$CPAN::Frontend->mywarn(
"Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
);
}
$password = prompt("Password:");
if ($CPAN::META->has_inst("Term::ReadKey")) {
Term::ReadKey::ReadMode("restore");
}
$CPAN::Frontend->myprint("\n\n");
return ($username,$password);
}
1;

826
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/HandleConfig.pm Normal file
View file

@ -0,0 +1,826 @@
package CPAN::HandleConfig;
use strict;
use vars qw(%can %keys $loading $VERSION);
use File::Path ();
use File::Spec ();
use File::Basename ();
use Carp ();
=head1 NAME
CPAN::HandleConfig - internal configuration handling for CPAN.pm
=cut
$VERSION = "5.5012"; # see also CPAN::Config::VERSION at end of file
%can = (
commit => "Commit changes to disk",
defaults => "Reload defaults from disk",
help => "Short help about 'o conf' usage",
init => "Interactive setting of all options",
);
# Q: where is the "How do I add a new config option" HOWTO?
# A1: svn diff -r 757:758 # where dagolden added test_report [git e997b71de88f1019a1472fc13cb97b1b7f96610f]
# A2: svn diff -r 985:986 # where andk added yaml_module [git 312b6d9b12b1bdec0b6e282d853482145475021f]
# A3: 1. add new config option to %keys below
# 2. add a Pod description in CPAN::FirstTime in the DESCRIPTION
# section; it should include a prompt line; see others for
# examples
# 3. add a "matcher" section in CPAN::FirstTime::init that includes
# a prompt function; see others for examples
# 4. add config option to documentation section in CPAN.pm
%keys = map { $_ => undef }
(
"allow_installing_module_downgrades",
"allow_installing_outdated_dists",
"applypatch",
"auto_commit",
"build_cache",
"build_dir",
"build_dir_reuse",
"build_requires_install_policy",
"bzip2",
"cache_metadata",
"check_sigs",
"cleanup_after_install",
"colorize_debug",
"colorize_output",
"colorize_print",
"colorize_warn",
"commandnumber_in_prompt",
"commands_quote",
"connect_to_internet_ok",
"cpan_home",
"curl",
"dontload_hash", # deprecated after 1.83_68 (rev. 581)
"dontload_list",
"ftp",
"ftp_passive",
"ftp_proxy",
"ftpstats_size",
"ftpstats_period",
"getcwd",
"gpg",
"gzip",
"halt_on_failure",
"histfile",
"histsize",
"http_proxy",
"inactivity_timeout",
"index_expire",
"inhibit_startup_message",
"keep_source_where",
"load_module_verbosity",
"lynx",
"make",
"make_arg",
"make_install_arg",
"make_install_make_command",
"makepl_arg",
"mbuild_arg",
"mbuild_install_arg",
"mbuild_install_build_command",
"mbuildpl_arg",
"ncftp",
"ncftpget",
"no_proxy",
"pager",
"password",
"patch",
"patches_dir",
"perl5lib_verbosity",
"plugin_list",
"prefer_external_tar",
"prefer_installer",
"prefs_dir",
"prerequisites_policy",
"proxy_pass",
"proxy_user",
"pushy_https",
"randomize_urllist",
"recommends_policy",
"scan_cache",
"shell",
"show_unparsable_versions",
"show_upload_date",
"show_zero_versions",
"suggests_policy",
"tar",
"tar_verbosity",
"term_is_latin",
"term_ornaments",
"test_report",
"trust_test_report_history",
"unzip",
"urllist",
"urllist_ping_verbose",
"urllist_ping_external",
"use_prompt_default",
"use_sqlite",
"username",
"version_timeout",
"wait_list",
"wget",
"yaml_load_code",
"yaml_module",
);
my %prefssupport = map { $_ => 1 }
(
"allow_installing_module_downgrades",
"allow_installing_outdated_dists",
"build_requires_install_policy",
"check_sigs",
"make",
"make_install_make_command",
"prefer_installer",
"test_report",
);
# returns true on successful action
sub edit {
my($self,@args) = @_;
return unless @args;
CPAN->debug("self[$self]args[".join(" | ",@args)."]");
my($o,$str,$func,$args,$key_exists);
$o = shift @args;
if($can{$o}) {
my $success = $self->$o(args => \@args); # o conf init => sub init => sub load
unless ($success) {
die "Panic: could not configure CPAN.pm for args [@args]. Giving up.";
}
} else {
CPAN->debug("o[$o]") if $CPAN::DEBUG;
unless (exists $keys{$o}) {
$CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
}
my $changed;
# one day I used randomize_urllist for a boolean, so we must
# list them explicitly --ak
if (0) {
} elsif ($o =~ /^(wait_list|urllist|dontload_list|plugin_list)$/) {
#
# ARRAYS
#
$func = shift @args;
$func ||= "";
CPAN->debug("func[$func]args[@args]") if $CPAN::DEBUG;
# Let's avoid eval, it's easier to comprehend without.
if ($func eq "push") {
push @{$CPAN::Config->{$o}}, @args;
$changed = 1;
} elsif ($func eq "pop") {
pop @{$CPAN::Config->{$o}};
$changed = 1;
} elsif ($func eq "shift") {
shift @{$CPAN::Config->{$o}};
$changed = 1;
} elsif ($func eq "unshift") {
unshift @{$CPAN::Config->{$o}}, @args;
$changed = 1;
} elsif ($func eq "splice") {
my $offset = shift @args || 0;
my $length = shift @args || 0;
splice @{$CPAN::Config->{$o}}, $offset, $length, @args; # may warn
$changed = 1;
} elsif ($func) {
$CPAN::Config->{$o} = [$func, @args];
$changed = 1;
} else {
$self->prettyprint($o);
}
if ($changed) {
if ($o eq "urllist") {
# reset the cached values
undef $CPAN::FTP::Thesite;
undef $CPAN::FTP::Themethod;
$CPAN::Index::LAST_TIME = 0;
} elsif ($o eq "dontload_list") {
# empty it, it will be built up again
$CPAN::META->{dontload_hash} = {};
}
}
} elsif ($o =~ /_hash$/) {
#
# HASHES
#
if (@args==1 && $args[0] eq "") {
@args = ();
} elsif (@args % 2) {
push @args, "";
}
$CPAN::Config->{$o} = { @args };
$changed = 1;
} else {
#
# SCALARS
#
if (defined $args[0]) {
$CPAN::CONFIG_DIRTY = 1;
$CPAN::Config->{$o} = $args[0];
$changed = 1;
}
$self->prettyprint($o)
if exists $keys{$o} or defined $CPAN::Config->{$o};
}
if ($changed) {
if ($CPAN::Config->{auto_commit}) {
$self->commit;
} else {
$CPAN::CONFIG_DIRTY = 1;
$CPAN::Frontend->myprint("Please use 'o conf commit' to ".
"make the config permanent!\n\n");
}
}
}
}
sub prettyprint {
my($self,$k) = @_;
my $v = $CPAN::Config->{$k};
if (ref $v) {
my(@report);
if (ref $v eq "ARRAY") {
@report = map {"\t$_ \[$v->[$_]]\n"} 0..$#$v;
} else {
@report = map
{
sprintf "\t%-18s => %s\n",
"[$_]",
defined $v->{$_} ? "[$v->{$_}]" : "undef"
} sort keys %$v;
}
$CPAN::Frontend->myprint(
join(
"",
sprintf(
" %-18s\n",
$k
),
@report
)
);
} elsif (defined $v) {
$CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
} else {
$CPAN::Frontend->myprint(sprintf " %-18s undef\n", $k);
}
}
# generally, this should be called without arguments so that the currently
# loaded config file is where changes are committed.
sub commit {
my($self,@args) = @_;
CPAN->debug("args[@args]") if $CPAN::DEBUG;
if ($CPAN::RUN_DEGRADED) {
$CPAN::Frontend->mydie(
"'o conf commit' disabled in ".
"degraded mode. Maybe try\n".
" !undef \$CPAN::RUN_DEGRADED\n"
);
}
my ($configpm, $must_reload);
# XXX does anything do this? can it be simplified? -- dagolden, 2011-01-19
if (@args) {
if ($args[0] eq "args") {
# we have not signed that contract
} else {
$configpm = $args[0];
}
}
# use provided name or the current config or create a new MyConfig
$configpm ||= require_myconfig_or_config() || make_new_config();
# commit to MyConfig if we can't write to Config
if ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm} ) {
my $myconfig = _new_config_name();
$CPAN::Frontend->mywarn(
"Your $configpm file\n".
"is not writable. I will attempt to write your configuration to\n" .
"$myconfig instead.\n\n"
);
$configpm = make_new_config();
$must_reload++; # so it gets loaded as $INC{'CPAN/MyConfig.pm'}
}
# XXX why not just "-w $configpm"? -- dagolden, 2011-01-19
my($mode);
if (-f $configpm) {
$mode = (stat $configpm)[2];
if ($mode && ! -w _) {
_die_cant_write_config($configpm);
}
}
$self->_write_config_file($configpm);
require_myconfig_or_config() if $must_reload;
#$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
#chmod $mode, $configpm;
###why was that so? $self->defaults;
$CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
$CPAN::CONFIG_DIRTY = 0;
1;
}
sub _write_config_file {
my ($self, $configpm) = @_;
my $msg;
$msg = <<EOF if $configpm =~ m{CPAN/Config\.pm};
# This is CPAN.pm's systemwide configuration file. This file provides
# defaults for users, and the values can be changed in a per-user
# configuration file.
EOF
$msg ||= "\n";
my($fh) = FileHandle->new;
rename $configpm, "$configpm~" if -f $configpm;
open $fh, ">$configpm" or
$CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
$fh->print(qq[$msg\$CPAN::Config = \{\n]);
foreach (sort keys %$CPAN::Config) {
unless (exists $keys{$_}) {
# do not drop them: forward compatibility!
$CPAN::Frontend->mywarn("Unknown config variable '$_'\n");
next;
}
$fh->print(
" '$_' => ",
$self->neatvalue($CPAN::Config->{$_}),
",\n"
);
}
$fh->print("};\n1;\n__END__\n");
close $fh;
return;
}
# stolen from MakeMaker; not taking the original because it is buggy;
# bugreport will have to say: keys of hashes remain unquoted and can
# produce syntax errors
sub neatvalue {
my($self, $v) = @_;
return "undef" unless defined $v;
my($t) = ref $v;
unless ($t) {
$v =~ s/\\/\\\\/g;
return "q[$v]";
}
if ($t eq 'ARRAY') {
my(@m, @neat);
push @m, "[";
foreach my $elem (@$v) {
push @neat, "q[$elem]";
}
push @m, join ", ", @neat;
push @m, "]";
return join "", @m;
}
return "$v" unless $t eq 'HASH';
my @m;
foreach my $key (sort keys %$v) {
my $val = $v->{$key};
push(@m,"q[$key]=>".$self->neatvalue($val)) ;
}
return "{ ".join(', ',@m)." }";
}
sub defaults {
my($self) = @_;
if ($CPAN::RUN_DEGRADED) {
$CPAN::Frontend->mydie(
"'o conf defaults' disabled in ".
"degraded mode. Maybe try\n".
" !undef \$CPAN::RUN_DEGRADED\n"
);
}
my $done;
for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) {
if ($INC{$config}) {
CPAN->debug("INC{'$config'}[$INC{$config}]") if $CPAN::DEBUG;
CPAN::Shell->_reload_this($config,{reloforce => 1});
$CPAN::Frontend->myprint("'$INC{$config}' reread\n");
last;
}
}
$CPAN::CONFIG_DIRTY = 0;
1;
}
=head2 C<< CLASS->safe_quote ITEM >>
Quotes an item to become safe against spaces
in shell interpolation. An item is enclosed
in double quotes if:
- the item contains spaces in the middle
- the item does not start with a quote
This happens to avoid shell interpolation
problems when whitespace is present in
directory names.
This method uses C<commands_quote> to determine
the correct quote. If C<commands_quote> is
a space, no quoting will take place.
if it starts and ends with the same quote character: leave it as it is
if it contains no whitespace: leave it as it is
if it contains whitespace, then
if it contains quotes: better leave it as it is
else: quote it with the correct quote type for the box we're on
=cut
{
# Instead of patching the guess, set commands_quote
# to the right value
my ($quotes,$use_quote)
= $^O eq 'MSWin32'
? ('"', '"')
: (q{"'}, "'")
;
sub safe_quote {
my ($self, $command) = @_;
# Set up quote/default quote
my $quote = $CPAN::Config->{commands_quote} || $quotes;
if ($quote ne ' '
and defined($command )
and $command =~ /\s/
and $command !~ /[$quote]/) {
return qq<$use_quote$command$use_quote>
}
return $command;
}
}
sub init {
my($self,@args) = @_;
CPAN->debug("self[$self]args[".join(",",@args)."]");
$self->load(do_init => 1, @args);
1;
}
# Loads CPAN::MyConfig or fall-back to CPAN::Config. Will not reload a file
# if already loaded. Returns the path to the file %INC or else the empty string
#
# Note -- if CPAN::Config were loaded and CPAN::MyConfig subsequently
# created, calling this again will leave *both* in %INC
sub require_myconfig_or_config () {
if ( $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) {
return $INC{"CPAN/MyConfig.pm"};
}
elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) {
return $INC{"CPAN/Config.pm"};
}
else {
return q{};
}
}
# Load a module, but ignore "can't locate..." errors
# Optionally take a list of directories to add to @INC for the load
sub _try_loading {
my ($module, @dirs) = @_;
(my $file = $module) =~ s{::}{/}g;
$file .= ".pm";
local @INC = @INC;
for my $dir ( @dirs ) {
if ( -f File::Spec->catfile($dir, $file) ) {
unshift @INC, $dir;
last;
}
}
eval { require $file };
my $err_myconfig = $@;
if ($err_myconfig and $err_myconfig !~ m#locate \Q$file\E#) {
die "Error while requiring ${module}:\n$err_myconfig";
}
return $INC{$file};
}
# prioritized list of possible places for finding "CPAN/MyConfig.pm"
sub cpan_home_dir_candidates {
my @dirs;
my $old_v = $CPAN::Config->{load_module_verbosity};
$CPAN::Config->{load_module_verbosity} = q[none];
if ($CPAN::META->has_usable('File::HomeDir')) {
if ($^O ne 'darwin') {
push @dirs, File::HomeDir->my_data;
# my_data is ~/Library/Application Support on darwin,
# which causes issues in the toolchain.
}
push @dirs, File::HomeDir->my_home;
}
# Windows might not have HOME, so check it first
push @dirs, $ENV{HOME} if $ENV{HOME};
# Windows might have these instead
push( @dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
push @dirs, $ENV{USERPROFILE} if $ENV{USERPROFILE};
$CPAN::Config->{load_module_verbosity} = $old_v;
my $dotcpan = $^O eq 'VMS' ? '_cpan' : '.cpan';
@dirs = map { File::Spec->catdir($_, $dotcpan) } grep { defined } @dirs;
return wantarray ? @dirs : $dirs[0];
}
sub load {
my($self, %args) = @_;
$CPAN::Be_Silent+=0; # protect against 'used only once'
$CPAN::Be_Silent++ if $args{be_silent}; # do not use; planned to be removed in 2011
my $do_init = delete $args{do_init} || 0;
my $make_myconfig = delete $args{make_myconfig};
$loading = 0 unless defined $loading;
my $configpm = require_myconfig_or_config;
my @miss = $self->missing_config_data;
CPAN->debug("do_init[$do_init]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
return unless $do_init || @miss;
if (@miss==1 and $miss[0] eq "pushy_https" && !$do_init) {
$CPAN::Frontend->myprint(<<'END');
Starting with version 2.29 of the cpan shell, a new download mechanism
is the default which exclusively uses cpan.org as the host to download
from. The configuration variable pushy_https can be used to (de)select
the new mechanism. Please read more about it and make your choice
between the old and the new mechanism by running
o conf init pushy_https
Once you have done that and stored the config variable this dialog
will disappear.
END
return;
}
# I'm not how we'd ever wind up in a recursive loop, but I'm leaving
# this here for safety's sake -- dagolden, 2011-01-19
return if $loading;
local $loading = ($loading||0) + 1;
# Warn if we have a config file, but things were found missing
if ($configpm && @miss && !$do_init) {
if ($make_myconfig || ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm})) {
$configpm = make_new_config();
$CPAN::Frontend->myprint(<<END);
The system CPAN configuration file has provided some default values,
but you need to complete the configuration dialog for CPAN.pm.
Configuration will be written to
<<$configpm>>
END
}
else {
$CPAN::Frontend->myprint(<<END);
Sorry, we have to rerun the configuration dialog for CPAN.pm due to
some missing parameters. Configuration will be written to
<<$configpm>>
END
}
}
require CPAN::FirstTime;
return CPAN::FirstTime::init($configpm || make_new_config(), %args);
}
# Creates a new, empty config file at the preferred location
# Any existing will be renamed with a ".bak" suffix if possible
# If the file cannot be created, an exception is thrown
sub make_new_config {
my $configpm = _new_config_name();
my $configpmdir = File::Basename::dirname( $configpm );
File::Path::mkpath($configpmdir) unless -d $configpmdir;
if ( -w $configpmdir ) {
#_#_# following code dumped core on me with 5.003_11, a.k.
if( -f $configpm ) {
my $configpm_bak = "$configpm.bak";
unlink $configpm_bak if -f $configpm_bak;
if( rename $configpm, $configpm_bak ) {
$CPAN::Frontend->mywarn(<<END);
Old configuration file $configpm
moved to $configpm_bak
END
}
}
my $fh = FileHandle->new;
if ($fh->open(">$configpm")) {
$fh->print("1;\n");
return $configpm;
}
}
_die_cant_write_config($configpm);
}
sub _die_cant_write_config {
my ($configpm) = @_;
$CPAN::Frontend->mydie(<<"END");
WARNING: CPAN.pm is unable to write a configuration file. You
must be able to create and write to '$configpm'.
Aborting configuration.
END
}
# From candidate directories, we would like (in descending preference order):
# * the one that contains a MyConfig file
# * one that exists (even without MyConfig)
# * the first one on the list
sub cpan_home {
my @dirs = cpan_home_dir_candidates();
for my $d (@dirs) {
return $d if -f "$d/CPAN/MyConfig.pm";
}
for my $d (@dirs) {
return $d if -d $d;
}
return $dirs[0];
}
sub _new_config_name {
return File::Spec->catfile(cpan_home(), 'CPAN', 'MyConfig.pm');
}
# returns mandatory but missing entries in the Config
sub missing_config_data {
my(@miss);
for (
"auto_commit",
"build_cache",
"build_dir",
"cache_metadata",
"cpan_home",
"ftp_proxy",
#"gzip",
"http_proxy",
"index_expire",
#"inhibit_startup_message",
"keep_source_where",
#"make",
"make_arg",
"make_install_arg",
"makepl_arg",
"mbuild_arg",
"mbuild_install_arg",
($^O eq "MSWin32" ? "" : "mbuild_install_build_command"),
"mbuildpl_arg",
"no_proxy",
#"pager",
"prerequisites_policy",
"pushy_https",
"scan_cache",
#"tar",
#"unzip",
"urllist",
) {
next unless exists $keys{$_};
push @miss, $_ unless defined $CPAN::Config->{$_};
}
return @miss;
}
sub help {
$CPAN::Frontend->myprint(q[
Known options:
commit commit session changes to disk
defaults reload default config values from disk
help this help
init enter a dialog to set all or a set of parameters
Edit key values as in the following (the "o" is a literal letter o):
o conf build_cache 15
o conf build_dir "/foo/bar"
o conf urllist shift
o conf urllist unshift ftp://ftp.foo.bar/
o conf inhibit_startup_message 1
]);
1; #don't reprint CPAN::Config
}
sub cpl {
my($word,$line,$pos) = @_;
$word ||= "";
CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
my(@words) = split " ", substr($line,0,$pos+1);
if (
defined($words[2])
and
$words[2] =~ /list$/
and
(
@words == 3
||
@words == 4 && length($word)
)
) {
return grep /^\Q$word\E/, qw(splice shift unshift pop push);
} elsif (defined($words[2])
and
$words[2] eq "init"
and
(
@words == 3
||
@words >= 4 && length($word)
)) {
return sort grep /^\Q$word\E/, keys %keys;
} elsif (@words >= 4) {
return ();
}
my %seen;
my(@o_conf) = sort grep { !$seen{$_}++ }
keys %can,
keys %$CPAN::Config,
keys %keys;
return grep /^\Q$word\E/, @o_conf;
}
sub prefs_lookup {
my($self,$distro,$what) = @_;
if ($prefssupport{$what}) {
return $CPAN::Config->{$what} unless
$distro
and $distro->prefs
and $distro->prefs->{cpanconfig}
and defined $distro->prefs->{cpanconfig}{$what};
return $distro->prefs->{cpanconfig}{$what};
} else {
$CPAN::Frontend->mywarn("Warning: $what not yet officially ".
"supported for distroprefs, doing a normal lookup\n");
return $CPAN::Config->{$what};
}
}
{
package
CPAN::Config; ####::###### #hide from indexer
# note: J. Nick Koston wrote me that they are using
# CPAN::Config->commit although undocumented. I suggested
# CPAN::Shell->o("conf","commit") even when ugly it is at least
# documented
# that's why I added the CPAN::Config class with autoload and
# deprecated warning
use strict;
use vars qw($AUTOLOAD $VERSION);
$VERSION = "5.5012";
# formerly CPAN::HandleConfig was known as CPAN::Config
sub AUTOLOAD { ## no critic
my $class = shift; # e.g. in dh-make-perl: CPAN::Config
my($l) = $AUTOLOAD;
$CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig\n");
$l =~ s/.*:://;
CPAN::HandleConfig->$l(@_);
}
}
1;
__END__
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# End:
# vim: ts=4 sts=4 sw=4:

626
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Index.pm Normal file
View file

@ -0,0 +1,626 @@
package CPAN::Index;
use strict;
use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
$VERSION = "2.29";
@CPAN::Index::ISA = qw(CPAN::Debug);
$LAST_TIME ||= 0;
$DATE_OF_03 ||= 0;
# use constant PROTOCOL => "2.0"; # commented out to avoid warning on upgrade from 1.57
sub PROTOCOL { 2.0 }
#-> sub CPAN::Index::force_reload ;
sub force_reload {
my($class) = @_;
$CPAN::Index::LAST_TIME = 0;
$class->reload(1);
}
my @indexbundle =
(
{
reader => "rd_authindex",
dir => "authors",
remotefile => '01mailrc.txt.gz',
shortlocalfile => '01mailrc.gz',
},
{
reader => "rd_modpacks",
dir => "modules",
remotefile => '02packages.details.txt.gz',
shortlocalfile => '02packag.gz',
},
{
reader => "rd_modlist",
dir => "modules",
remotefile => '03modlist.data.gz',
shortlocalfile => '03mlist.gz',
},
);
#-> sub CPAN::Index::reload ;
sub reload {
my($self,$force) = @_;
my $time = time;
# XXX check if a newer one is available. (We currently read it
# from time to time)
for ($CPAN::Config->{index_expire}) {
$_ = 0.001 unless $_ && $_ > 0.001;
}
unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
# debug here when CPAN doesn't seem to read the Metadata
require Carp;
Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
}
unless ($CPAN::META->{PROTOCOL}) {
$self->read_metadata_cache;
$CPAN::META->{PROTOCOL} ||= "1.0";
}
if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
# warn "Setting last_time to 0";
$LAST_TIME = 0; # No warning necessary
}
if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
and ! $force) {
# called too often
# CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
} elsif (0) {
# IFF we are developing, it helps to wipe out the memory
# between reloads, otherwise it is not what a user expects.
undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
$CPAN::META = CPAN->new;
} else {
my($debug,$t2);
local $LAST_TIME = $time;
local $CPAN::META->{PROTOCOL} = PROTOCOL;
my $needshort = $^O eq "dos";
INX: for my $indexbundle (@indexbundle) {
my $reader = $indexbundle->{reader};
my $localfile = $needshort ? $indexbundle->{shortlocalfile} : $indexbundle->{remotefile};
my $localpath = File::Spec->catfile($indexbundle->{dir}, $localfile);
my $remote = join "/", $indexbundle->{dir}, $indexbundle->{remotefile};
my $localized = $self->reload_x($remote, $localpath, $force);
$self->$reader($localized); # may die but we let the shell catch it
if ($CPAN::DEBUG){
$t2 = time;
$debug = "timing reading 01[".($t2 - $time)."]";
$time = $t2;
}
return if $CPAN::Signal; # this is sometimes lengthy
}
$self->write_metadata_cache;
if ($CPAN::DEBUG){
$t2 = time;
$debug .= "03[".($t2 - $time)."]";
$time = $t2;
}
CPAN->debug($debug) if $CPAN::DEBUG;
}
if ($CPAN::Config->{build_dir_reuse}) {
$self->reanimate_build_dir;
}
if (CPAN::_sqlite_running()) {
$CPAN::SQLite->reload(time => $time, force => $force)
if not $LAST_TIME;
}
$LAST_TIME = $time;
$CPAN::META->{PROTOCOL} = PROTOCOL;
}
#-> sub CPAN::Index::reanimate_build_dir ;
sub reanimate_build_dir {
my($self) = @_;
unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
return;
}
return if $HAVE_REANIMATED++;
my $d = $CPAN::Config->{build_dir};
my $dh = DirHandle->new;
opendir $dh, $d or return; # does not exist
my $dirent;
my $i = 0;
my $painted = 0;
my $restored = 0;
my $start = CPAN::FTP::_mytime();
my @candidates = map { $_->[0] }
sort { $b->[1] <=> $a->[1] }
map { [ $_, -M File::Spec->catfile($d,$_) ] }
grep {/(.+)\.yml$/ && -d File::Spec->catfile($d,$1)} readdir $dh;
if ( @candidates ) {
$CPAN::Frontend->myprint
(sprintf("Reading %d yaml file%s from %s/\n",
scalar @candidates,
@candidates==1 ? "" : "s",
$CPAN::Config->{build_dir}
));
DISTRO: for $i (0..$#candidates) {
my $dirent = $candidates[$i];
my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent), {loadblessed => 1})};
if ($@) {
warn "Error while parsing file '$dirent'; error: '$@'";
next DISTRO;
}
my $c = $y->[0];
if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) {
my $key = $c->{distribution}{ID};
for my $k (keys %{$c->{distribution}}) {
if ($c->{distribution}{$k}
&& ref $c->{distribution}{$k}
&& UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
$c->{distribution}{$k}{COMMANDID} = $i - @candidates;
}
}
#we tried to restore only if element already
#exists; but then we do not work with metadata
#turned off.
my $do
= $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
= $c->{distribution};
for my $skipper (qw(
badtestcnt
configure_requires_later
configure_requires_later_for
force_update
later
later_for
notest
should_report
sponsored_mods
prefs
negative_prefs_cache
)) {
delete $do->{$skipper};
}
if ($do->can("tested_ok_but_not_installed")) {
if ($do->tested_ok_but_not_installed) {
$CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
} else {
next DISTRO;
}
}
$restored++;
}
$i++;
while (($painted/76) < ($i/@candidates)) {
$CPAN::Frontend->myprint(".");
$painted++;
}
}
}
else {
$CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
}
my $took = CPAN::FTP::_mytime() - $start;
$CPAN::Frontend->myprint(sprintf(
"DONE\nRestored the state of %s (in %.4f secs)\n",
$restored || "none",
$took,
));
}
#-> sub CPAN::Index::reload_x ;
sub reload_x {
my($cl,$wanted,$localname,$force) = @_;
$force |= 2; # means we're dealing with an index here
CPAN::HandleConfig->load; # we should guarantee loading wherever
# we rely on Config XXX
$localname ||= $wanted;
my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
$localname);
if (
-f $abs_wanted &&
-M $abs_wanted < $CPAN::Config->{'index_expire'} &&
!($force & 1)
) {
my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
$cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
qq{day$s. I\'ll use that.});
return $abs_wanted;
} else {
$force |= 1; # means we're quite serious about it.
}
return CPAN::FTP->localize($wanted,$abs_wanted,$force);
}
#-> sub CPAN::Index::rd_authindex ;
sub rd_authindex {
my($cl, $index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
my @lines;
$CPAN::Frontend->myprint("Reading '$index_target'\n");
local(*FH);
tie *FH, 'CPAN::Tarzip', $index_target;
local($/) = "\n";
local($_);
push @lines, split /\012/ while <FH>;
my $i = 0;
my $painted = 0;
foreach (@lines) {
my($userid,$fullname,$email) =
m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
$fullname ||= $email;
if ($userid && $fullname && $email) {
my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
$userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
} else {
CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
}
$i++;
while (($painted/76) < ($i/@lines)) {
$CPAN::Frontend->myprint(".");
$painted++;
}
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
}
sub userid {
my($self,$dist) = @_;
$dist = $self->{'id'} unless defined $dist;
my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
$ret;
}
#-> sub CPAN::Index::rd_modpacks ;
sub rd_modpacks {
my($self, $index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
$CPAN::Frontend->myprint("Reading '$index_target'\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
my $slurp = "";
my $chunk;
while (my $bytes = $fh->READ(\$chunk,8192)) {
$slurp.=$chunk;
}
my @lines = split /\012/, $slurp;
CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
undef $fh;
# read header
my($line_count,$last_updated);
while (@lines) {
my $shift = shift(@lines);
last if $shift =~ /^\s*$/;
$shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
$shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
}
CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
my $errors = 0;
if (not defined $line_count) {
$CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
});
$errors++;
$CPAN::Frontend->mysleep(5);
} elsif ($line_count != scalar @lines) {
$CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
contains a Line-Count header of %d but I see %d lines there. Please
check the validity of the index file by comparing it to more than one
CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
$index_target, $line_count, scalar(@lines));
}
if (not defined $last_updated) {
$CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
});
$errors++;
$CPAN::Frontend->mysleep(5);
} else {
$CPAN::Frontend
->myprint(sprintf qq{ Database was generated on %s\n},
$last_updated);
$DATE_OF_02 = $last_updated;
my $age = time;
if ($CPAN::META->has_inst('HTTP::Date')) {
require HTTP::Date;
$age -= HTTP::Date::str2time($last_updated);
} else {
$CPAN::Frontend->mywarn(" HTTP::Date not available\n");
require Time::Local;
my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
$d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
$age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
}
$age /= 3600*24;
if ($age > 30) {
$CPAN::Frontend
->mywarn(sprintf
qq{Warning: This index file is %d days old.
Please check the host you chose as your CPAN mirror for staleness.
I'll continue but problems seem likely to happen.\a\n},
$age);
} elsif ($age < -1) {
$CPAN::Frontend
->mywarn(sprintf
qq{Warning: Your system date is %d days behind this index file!
System time: %s
Timestamp index file: %s
Please fix your system time, problems with the make command expected.\n},
-$age,
scalar gmtime,
$DATE_OF_02,
);
}
}
# A necessity since we have metadata_cache: delete what isn't
# there anymore
my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
my(%exists);
my $i = 0;
my $painted = 0;
LINE: foreach (@lines) {
# before 1.56 we split into 3 and discarded the rest. From
# 1.57 we assign remaining text to $comment thus allowing to
# influence isa_perl
my($mod,$version,$dist,$comment) = split " ", $_, 4;
unless ($mod && defined $version && $dist) {
require Dumpvalue;
my $dv = Dumpvalue->new(tick => '"');
$CPAN::Frontend->mywarn(sprintf "Could not split line[%s]\n", $dv->stringify($_));
if ($errors++ >= 5){
$CPAN::Frontend->mydie("Giving up parsing your $index_target, too many errors");
}
next LINE;
}
my($bundle,$id,$userid);
if ($mod eq 'CPAN' &&
! (
CPAN::Queue->exists('Bundle::CPAN') ||
CPAN::Queue->exists('CPAN')
)
) {
local($^W)= 0;
if ($version > $CPAN::VERSION) {
$CPAN::Frontend->mywarn(qq{
New CPAN.pm version (v$version) available.
[Currently running version is v$CPAN::VERSION]
You might want to try
install CPAN
reload cpan
to both upgrade CPAN.pm and run the new version without leaving
the current session.
}); #});
$CPAN::Frontend->mysleep(2);
$CPAN::Frontend->myprint(qq{\n});
}
last if $CPAN::Signal;
} elsif ($mod =~ /^Bundle::(.*)/) {
$bundle = $1;
}
if ($bundle) {
$id = $CPAN::META->instance('CPAN::Bundle',$mod);
# Let's make it a module too, because bundles have so much
# in common with modules.
# Changed in 1.57_63: seems like memory bloat now without
# any value, so commented out
# $CPAN::META->instance('CPAN::Module',$mod);
} else {
# instantiate a module object
$id = $CPAN::META->instance('CPAN::Module',$mod);
}
# Although CPAN prohibits same name with different version the
# indexer may have changed the version for the same distro
# since the last time ("Force Reindexing" feature)
if ($id->cpan_file ne $dist
||
$id->cpan_version ne $version
) {
$userid = $id->userid || $self->userid($dist);
$id->set(
'CPAN_USERID' => $userid,
'CPAN_VERSION' => $version,
'CPAN_FILE' => $dist,
);
}
# instantiate a distribution object
if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
# we do not need CONTAINSMODS unless we do something with
# this dist, so we better produce it on demand.
## my $obj = $CPAN::META->instance(
## 'CPAN::Distribution' => $dist
## );
## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
} else {
$CPAN::META->instance(
'CPAN::Distribution' => $dist
)->set(
'CPAN_USERID' => $userid,
'CPAN_COMMENT' => $comment,
);
}
if ($secondtime) {
for my $name ($mod,$dist) {
# $self->debug("exists name[$name]") if $CPAN::DEBUG;
$exists{$name} = undef;
}
}
$i++;
while (($painted/76) < ($i/@lines)) {
$CPAN::Frontend->myprint(".");
$painted++;
}
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
if ($secondtime) {
for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
for my $o ($CPAN::META->all_objects($class)) {
next if exists $exists{$o->{ID}};
$CPAN::META->delete($class,$o->{ID});
# CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
# if $CPAN::DEBUG;
}
}
}
}
#-> sub CPAN::Index::rd_modlist ;
sub rd_modlist {
my($cl,$index_target) = @_;
return unless defined $index_target;
return if CPAN::_sqlite_running();
$CPAN::Frontend->myprint("Reading '$index_target'\n");
my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
local $_;
my $slurp = "";
my $chunk;
while (my $bytes = $fh->READ(\$chunk,8192)) {
$slurp.=$chunk;
}
my @eval2 = split /\012/, $slurp;
while (@eval2) {
my $shift = shift(@eval2);
if ($shift =~ /^Date:\s+(.*)/) {
if ($DATE_OF_03 eq $1) {
$CPAN::Frontend->myprint("Unchanged.\n");
return;
}
($DATE_OF_03) = $1;
}
last if $shift =~ /^\s*$/;
}
push @eval2, q{CPAN::Modulelist->data;};
local($^W) = 0;
my($compmt) = Safe->new("CPAN::Safe1");
my($eval2) = join("\n", @eval2);
CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
my $ret = $compmt->reval($eval2);
Carp::confess($@) if $@;
return if $CPAN::Signal;
my $i = 0;
my $until = keys(%$ret);
my $painted = 0;
CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
for (sort keys %$ret) {
my $obj = $CPAN::META->instance("CPAN::Module",$_);
delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
$obj->set(%{$ret->{$_}});
$i++;
while (($painted/76) < ($i/$until)) {
$CPAN::Frontend->myprint(".");
$painted++;
}
return if $CPAN::Signal;
}
$CPAN::Frontend->myprint("DONE\n");
}
#-> sub CPAN::Index::write_metadata_cache ;
sub write_metadata_cache {
my($self) = @_;
return unless $CPAN::Config->{'cache_metadata'};
return if CPAN::_sqlite_running();
return unless $CPAN::META->has_usable("Storable");
my $cache;
foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
CPAN::Distribution)) {
$cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
}
my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
$cache->{last_time} = $LAST_TIME;
$cache->{DATE_OF_02} = $DATE_OF_02;
$cache->{PROTOCOL} = PROTOCOL;
$CPAN::Frontend->myprint("Writing $metadata_file\n");
eval { Storable::nstore($cache, $metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
}
#-> sub CPAN::Index::read_metadata_cache ;
sub read_metadata_cache {
my($self) = @_;
return unless $CPAN::Config->{'cache_metadata'};
return if CPAN::_sqlite_running();
return unless $CPAN::META->has_usable("Storable");
my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
return unless -r $metadata_file and -f $metadata_file;
$CPAN::Frontend->myprint("Reading '$metadata_file'\n");
my $cache;
eval { $cache = Storable::retrieve($metadata_file) };
$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
$LAST_TIME = 0;
return;
}
if (exists $cache->{PROTOCOL}) {
if (PROTOCOL > $cache->{PROTOCOL}) {
$CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
"with protocol v%s, requiring v%s\n",
$cache->{PROTOCOL},
PROTOCOL)
);
return;
}
} else {
$CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
"with protocol v1.0\n");
return;
}
my $clcnt = 0;
my $idcnt = 0;
while(my($class,$v) = each %$cache) {
next unless $class =~ /^CPAN::/;
$CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
while (my($id,$ro) = each %$v) {
$CPAN::META->{readwrite}{$class}{$id} ||=
$class->new(ID=>$id, RO=>$ro);
$idcnt++;
}
$clcnt++;
}
unless ($clcnt) { # sanity check
$CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
return;
}
if ($idcnt < 1000) {
$CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
"in $metadata_file\n");
return;
}
$CPAN::META->{PROTOCOL} ||=
$cache->{PROTOCOL}; # reading does not up or downgrade, but it
# does initialize to some protocol
$LAST_TIME = $cache->{last_time};
$DATE_OF_02 = $cache->{DATE_OF_02};
$CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
return;
}
1;

224
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/InfoObj.pm Normal file
View file

@ -0,0 +1,224 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::InfoObj;
use strict;
use CPAN::Debug;
@CPAN::InfoObj::ISA = qw(CPAN::Debug);
use Cwd qw(chdir);
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub ro {
my $self = shift;
exists $self->{RO} and return $self->{RO};
}
#-> sub CPAN::InfoObj::cpan_userid
sub cpan_userid {
my $self = shift;
my $ro = $self->ro;
if ($ro) {
return $ro->{CPAN_USERID} || "N/A";
} else {
$self->debug("ID[$self->{ID}]");
# N/A for bundles found locally
return "N/A";
}
}
sub id { shift->{ID}; }
#-> sub CPAN::InfoObj::new ;
sub new {
my $this = bless {}, shift;
%$this = @_;
$this
}
# The set method may only be used by code that reads index data or
# otherwise "objective" data from the outside world. All session
# related material may do anything else with instance variables but
# must not touch the hash under the RO attribute. The reason is that
# the RO hash gets written to Metadata file and is thus persistent.
#-> sub CPAN::InfoObj::safe_chdir ;
sub safe_chdir {
my($self,$todir) = @_;
# we die if we cannot chdir and we are debuggable
Carp::confess("safe_chdir called without todir argument")
unless defined $todir and length $todir;
if (chdir $todir) {
$self->debug(sprintf "changed directory to %s", CPAN::anycwd())
if $CPAN::DEBUG;
} else {
if (-e $todir) {
unless (-x $todir) {
unless (chmod 0755, $todir) {
my $cwd = CPAN::anycwd();
$CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
"permission to change the permission; cannot ".
"chdir to '$todir'\n");
$CPAN::Frontend->mysleep(5);
$CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
qq{to todir[$todir]: $!});
}
}
} else {
$CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
}
if (chdir $todir) {
$self->debug(sprintf "changed directory to %s", CPAN::anycwd())
if $CPAN::DEBUG;
} else {
my $cwd = CPAN::anycwd();
$CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
qq{to todir[$todir] (a chmod has been issued): $!});
}
}
}
#-> sub CPAN::InfoObj::set ;
sub set {
my($self,%att) = @_;
my $class = ref $self;
# This must be ||=, not ||, because only if we write an empty
# reference, only then the set method will write into the readonly
# area. But for Distributions that spring into existence, maybe
# because of a typo, we do not like it that they are written into
# the readonly area and made permanent (at least for a while) and
# that is why we do not "allow" other places to call ->set.
unless ($self->id) {
CPAN->debug("Bug? Empty ID, rejecting");
return;
}
my $ro = $self->{RO} =
$CPAN::META->{readonly}{$class}{$self->id} ||= {};
while (my($k,$v) = each %att) {
$ro->{$k} = $v;
}
}
#-> sub CPAN::InfoObj::as_glimpse ;
sub as_glimpse {
my($self) = @_;
my(@m);
my $class = ref($self);
$class =~ s/^CPAN:://;
my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
push @m, sprintf "%-15s %s\n", $class, $id;
join "", @m;
}
#-> sub CPAN::InfoObj::as_string ;
sub as_string {
my($self) = @_;
my(@m);
my $class = ref($self);
$class =~ s/^CPAN:://;
push @m, $class, " id = $self->{ID}\n";
my $ro;
unless ($ro = $self->ro) {
if (substr($self->{ID},-1,1) eq ".") { # directory
$ro = +{};
} else {
$CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
$CPAN::Frontend->mysleep(5);
return;
}
}
for (sort keys %$ro) {
# next if m/^(ID|RO)$/;
my $extra = "";
if ($_ eq "CPAN_USERID") {
$extra .= " (";
$extra .= $self->fullname;
my $email; # old perls!
if ($email = $CPAN::META->instance("CPAN::Author",
$self->cpan_userid
)->email) {
$extra .= " <$email>";
} else {
$extra .= " <no email>";
}
$extra .= ")";
} elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
push @m, sprintf " %-12s %s\n", $_, $self->fullname;
next;
}
next unless defined $ro->{$_};
push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
}
KEY: for (sort keys %$self) {
next if m/^(ID|RO)$/;
unless (defined $self->{$_}) {
delete $self->{$_};
next KEY;
}
if (ref($self->{$_}) eq "ARRAY") {
push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
} elsif (ref($self->{$_}) eq "HASH") {
my $value;
if (/^CONTAINSMODS$/) {
$value = join(" ",sort keys %{$self->{$_}});
} elsif (/^prereq_pm$/) {
my @value;
my $v = $self->{$_};
for my $x (sort keys %$v) {
my @svalue;
for my $y (sort keys %{$v->{$x}}) {
push @svalue, "$y=>$v->{$x}{$y}";
}
push @value, "$x\:" . join ",", @svalue if @svalue;
}
$value = join ";", @value;
} else {
$value = $self->{$_};
}
push @m, sprintf(
" %-12s %s\n",
$_,
$value,
);
} else {
push @m, sprintf " %-12s %s\n", $_, $self->{$_};
}
}
join "", @m, "\n";
}
#-> sub CPAN::InfoObj::fullname ;
sub fullname {
my($self) = @_;
$CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
}
#-> sub CPAN::InfoObj::dump ;
sub dump {
my($self, $what) = @_;
unless ($CPAN::META->has_inst("Data::Dumper")) {
$CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
}
local $Data::Dumper::Sortkeys;
$Data::Dumper::Sortkeys = 1;
my $out = Data::Dumper::Dumper($what ? eval $what : $self);
if (length $out > 100000) {
my $fh_pager = FileHandle->new;
local($SIG{PIPE}) = "IGNORE";
my $pager = $CPAN::Config->{'pager'} || "cat";
$fh_pager->open("|$pager")
or die "Could not open pager $pager\: $!";
$fh_pager->print($out);
close $fh_pager;
} else {
$CPAN::Frontend->myprint($out);
}
}
1;

136
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Kwalify.pm Normal file
View file

@ -0,0 +1,136 @@
=head1 NAME
CPAN::Kwalify - Interface between CPAN.pm and Kwalify.pm
=head1 SYNOPSIS
use CPAN::Kwalify;
validate($schema_name, $data, $file, $doc);
=head1 DESCRIPTION
=over
=item _validate($schema_name, $data, $file, $doc)
$schema_name is the name of a supported schema. Currently only
C<distroprefs> is supported. $data is the data to be validated. $file
is the absolute path to the file the data are coming from. $doc is the
index of the document within $doc that is to be validated. The last
two arguments are only there for better error reporting.
Relies on being called from within CPAN.pm.
Dies if something fails. Does not return anything useful.
=item yaml($schema_name)
Returns the YAML text of that schema. Dies if something fails.
=back
=head1 AUTHOR
Andreas Koenig C<< <andk@cpan.org> >>
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=cut
use strict;
package CPAN::Kwalify;
use vars qw($VERSION $VAR1);
$VERSION = "5.50";
use File::Spec ();
my %vcache = ();
my $schema_loaded = {};
sub _validate {
my($schema_name,$data,$abs,$y) = @_;
my $yaml_module = CPAN->_yaml_module;
if (
$CPAN::META->has_inst($yaml_module)
&&
$CPAN::META->has_inst("Kwalify")
) {
my $load = UNIVERSAL::can($yaml_module,"Load");
unless ($schema_loaded->{$schema_name}) {
eval {
my $schema_yaml = yaml($schema_name);
$schema_loaded->{$schema_name} = $load->($schema_yaml);
};
if ($@) {
# we know that YAML.pm 0.62 cannot parse the schema,
# so we try a fallback
my $content = do {
my $path = __FILE__;
$path =~ s/\.pm$//;
$path = File::Spec->catfile($path, "$schema_name.dd");
local *FH;
open FH, $path or die "Could not open '$path': $!";
local $/;
<FH>;
};
$VAR1 = undef;
eval $content;
if (my $err = $@) {
die "parsing of '$schema_name.dd' failed: $err";
}
$schema_loaded->{$schema_name} = $VAR1;
}
}
}
if (my $schema = $schema_loaded->{$schema_name}) {
my $mtime = (stat $abs)[9];
for my $k (keys %{$vcache{$abs}}) {
delete $vcache{$abs}{$k} unless $k eq $mtime;
}
return if $vcache{$abs}{$mtime}{$y}++;
eval { Kwalify::validate($schema, $data) };
if (my $err = $@) {
my $info = {}; yaml($schema_name, info => $info);
die "validation of distropref '$abs'[$y] against schema '$info->{path}' failed: $err";
}
}
}
sub _clear_cache {
%vcache = ();
}
sub yaml {
my($schema_name, %opt) = @_;
my $content = do {
my $path = __FILE__;
$path =~ s/\.pm$//;
$path = File::Spec->catfile($path, "$schema_name.yml");
if ($opt{info}) {
$opt{info}{path} = $path;
}
local *FH;
open FH, $path or die "Could not open '$path': $!";
local $/;
<FH>;
};
return $content;
}
1;
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# End:

150
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Kwalify/distroprefs.dd Normal file
View file

@ -0,0 +1,150 @@
$VAR1 = {
"mapping" => {
"comment" => {
"type" => "text"
},
"cpanconfig" => {
"mapping" => {
"=" => {
"type" => "text"
}
},
"type" => "map"
},
"depends" => {
"mapping" => {
"build_requires" => {
"mapping" => {
"=" => {
"type" => "text"
}
},
"type" => "map"
},
"configure_requires" => {},
"requires" => {}
},
"type" => "map"
},
"disabled" => {
"enum" => [
0,
1
],
"type" => "int"
},
"features" => {
"sequence" => [
{
"type" => "text"
}
],
"type" => "seq"
},
"goto" => {
"type" => "text"
},
"install" => {
"mapping" => {
"args" => {
"sequence" => [
{
"type" => "text"
}
],
"type" => "seq"
},
"commandline" => {
"type" => "text"
},
"eexpect" => {
"mapping" => {
"mode" => {
"enum" => [
"deterministic",
"anyorder"
],
"type" => "text"
},
"reuse" => {
"type" => "int"
},
"talk" => {
"sequence" => [
{
"type" => "text"
}
],
"type" => "seq"
},
"timeout" => {
"type" => "number"
}
},
"type" => "map"
},
"env" => {
"mapping" => {
"=" => {
"type" => "text"
}
},
"type" => "map"
},
"expect" => {
"sequence" => [
{
"type" => "text"
}
],
"type" => "seq"
}
},
"type" => "map"
},
"make" => {},
"match" => {
"mapping" => {
"distribution" => {
"type" => "text"
},
"env" => {
"mapping" => {
"=" => {
"type" => "text"
}
},
"type" => "map"
},
"module" => {
"type" => "text"
},
"perl" => {
"type" => "text"
},
"perlconfig" => {}
},
"type" => "map"
},
"patches" => {
"sequence" => [
{
"type" => "text"
}
],
"type" => "seq"
},
"pl" => {},
"reminder" => {
"type" => "text"
},
"test" => {}
},
"type" => "map"
};
$VAR1->{"mapping"}{"depends"}{"mapping"}{"configure_requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"};
$VAR1->{"mapping"}{"depends"}{"mapping"}{"requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"};
$VAR1->{"mapping"}{"make"} = $VAR1->{"mapping"}{"install"};
$VAR1->{"mapping"}{"match"}{"mapping"}{"perlconfig"} = $VAR1->{"mapping"}{"match"}{"mapping"}{"env"};
$VAR1->{"mapping"}{"pl"} = $VAR1->{"mapping"}{"install"};
$VAR1->{"mapping"}{"test"} = $VAR1->{"mapping"}{"install"};

92
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Kwalify/distroprefs.yml Normal file
View file

@ -0,0 +1,92 @@
---
type: map
mapping:
comment:
type: text
depends:
type: map
mapping:
configure_requires:
&requires_common
type: map
mapping:
=:
type: text
build_requires: *requires_common
requires: *requires_common
match:
type: map
mapping:
distribution:
type: text
module:
type: text
perl:
type: text
perlconfig:
&matchhash_common
type: map
mapping:
=:
type: text
env: *matchhash_common
install:
&args_env_expect
type: map
mapping:
args:
type: seq
sequence:
- type: text
commandline:
type: text
env:
type: map
mapping:
=:
type: text
expect:
type: seq
sequence:
- type: text
eexpect:
type: map
mapping:
mode:
type: text
enum:
- deterministic
- anyorder
timeout:
type: number
reuse:
type: int
talk:
type: seq
sequence:
- type: text
make: *args_env_expect
pl: *args_env_expect
test: *args_env_expect
patches:
type: seq
sequence:
- type: text
disabled:
type: int
enum:
- 0
- 1
goto:
type: text
cpanconfig:
type: map
mapping:
=:
type: text
features:
type: seq
sequence:
- type: text
reminder:
type: text

62
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/LWP/UserAgent.pm Normal file
View file

@ -0,0 +1,62 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::LWP::UserAgent;
use strict;
use vars qw(@ISA $USER $PASSWD $SETUPDONE);
use CPAN::HTTP::Credentials;
# we delay requiring LWP::UserAgent and setting up inheritance until we need it
$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.9601";
sub config {
return if $SETUPDONE;
if ($CPAN::META->has_usable('LWP::UserAgent')) {
require LWP::UserAgent;
@ISA = qw(Exporter LWP::UserAgent); ## no critic
$SETUPDONE++;
} else {
$CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
}
}
sub get_basic_credentials {
my($self, $realm, $uri, $proxy) = @_;
if ( $proxy ) {
return CPAN::HTTP::Credentials->get_proxy_credentials();
} else {
return CPAN::HTTP::Credentials->get_non_proxy_credentials();
}
}
sub no_proxy {
my ( $self, $no_proxy ) = @_;
return $self->SUPER::no_proxy( split(',',$no_proxy) );
}
# mirror(): Its purpose is to deal with proxy authentication. When we
# call SUPER::mirror, we really call the mirror method in
# LWP::UserAgent. LWP::UserAgent will then call
# $self->get_basic_credentials or some equivalent and this will be
# $self->dispatched to our own get_basic_credentials method.
# Our own get_basic_credentials sets $USER and $PASSWD, two globals.
# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
# although we have gone through our get_basic_credentials, the proxy
# server refuses to connect. This could be a case where the username or
# password has changed in the meantime, so I'm trying once again without
# $USER and $PASSWD to give the get_basic_credentials routine another
# chance to set $USER and $PASSWD.
sub mirror {
my($self,$url,$aslocal) = @_;
my $result = $self->SUPER::mirror($url,$aslocal);
if ($result->code == 407) {
CPAN::HTTP::Credentials->clear_credentials;
$result = $self->SUPER::mirror($url,$aslocal);
}
$result;
}
1;

1176
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta.pm Normal file
View file

File diff suppressed because it is too large Load diff

1657
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/Converter.pm Normal file
View file

File diff suppressed because it is too large Load diff

153
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/Feature.pm Normal file
View file

@ -0,0 +1,153 @@
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Feature;
our $VERSION = '2.150010';
use CPAN::Meta::Prereqs;
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
#pod distribution and specified in the distribution's F<META.json> (or F<META.yml>)
#pod file.
#pod
#pod For the most part, this class will only be used when operating on the result of
#pod the C<feature> or C<features> methods on a L<CPAN::Meta> object.
#pod
#pod =method new
#pod
#pod my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
#pod
#pod This returns a new Feature object. The C<%spec> argument to the constructor
#pod should be the same as the value of the C<optional_feature> entry in the
#pod distmeta. It must contain entries for C<description> and C<prereqs>.
#pod
#pod =cut
sub new {
my ($class, $identifier, $spec) = @_;
my %guts = (
identifier => $identifier,
description => $spec->{description},
prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}),
);
bless \%guts => $class;
}
#pod =method identifier
#pod
#pod This method returns the feature's identifier.
#pod
#pod =cut
sub identifier { $_[0]{identifier} }
#pod =method description
#pod
#pod This method returns the feature's long description.
#pod
#pod =cut
sub description { $_[0]{description} }
#pod =method prereqs
#pod
#pod This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
#pod object.
#pod
#pod =cut
sub prereqs { $_[0]{prereqs} }
1;
# ABSTRACT: an optional feature provided by a CPAN distribution
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Feature - an optional feature provided by a CPAN distribution
=head1 VERSION
version 2.150010
=head1 DESCRIPTION
A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
distribution and specified in the distribution's F<META.json> (or F<META.yml>)
file.
For the most part, this class will only be used when operating on the result of
the C<feature> or C<features> methods on a L<CPAN::Meta> object.
=head1 METHODS
=head2 new
my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
This returns a new Feature object. The C<%spec> argument to the constructor
should be the same as the value of the C<optional_feature> entry in the
distmeta. It must contain entries for C<description> and C<prereqs>.
=head2 identifier
This method returns the feature's identifier.
=head2 description
This method returns the feature's long description.
=head2 prereqs
This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
object.
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Adam Kennedy <adamk@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
# vim: ts=2 sts=2 sw=2 et :

320
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/History.pm Normal file
View file

@ -0,0 +1,320 @@
# vi:tw=72
use 5.006;
use strict;
use warnings;
package CPAN::Meta::History;
our $VERSION = '2.150010';
1;
# ABSTRACT: history of CPAN Meta Spec changes
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::History - history of CPAN Meta Spec changes
=head1 VERSION
version 2.150010
=head1 DESCRIPTION
The CPAN Meta Spec has gone through several iterations. It was
originally written in HTML and later revised into POD (though published
in HTML generated from the POD). Fields were added, removed or changed,
sometimes by design and sometimes to reflect real-world usage after the
fact.
This document reconstructs the history of the CPAN Meta Spec based on
change logs, repository commit messages and the published HTML files.
In some cases, particularly prior to version 1.2, the exact version
when certain fields were introduced or changed is inconsistent between
sources. When in doubt, the published HTML files for versions 1.0 to
1.4 as they existed when version 2 was developed are used as the
definitive source.
Starting with version 2, the specification document is part of the
CPAN-Meta distribution and will be published on CPAN as
L<CPAN::Meta::Spec>.
Going forward, specification version numbers will be integers and
decimal portions will correspond to a release date for the CPAN::Meta
library.
=head1 HISTORY
=head2 Version 2
April 2010
=over
=item *
Revised spec examples as perl data structures rather than YAML
=item *
Switched to JSON serialization from YAML
=item *
Specified allowed version number formats
=item *
Replaced 'requires', 'build_requires', 'configure_requires',
'recommends' and 'conflicts' with new 'prereqs' data structure divided
by I<phase> (configure, build, test, runtime, etc.) and I<relationship>
(requires, recommends, suggests, conflicts)
=item *
Added support for 'develop' phase for requirements for maintaining
a list of authoring tools
=item *
Changed 'license' to a list and revised the set of valid licenses
=item *
Made 'dynamic_config' mandatory to reduce confusion
=item *
Changed 'resources' subkey 'repository' to a hash that clarifies
repository type, url for browsing and url for checkout
=item *
Changed 'resources' subkey 'bugtracker' to a hash for either web
or mailto resource
=item *
Changed specification of 'optional_features':
=over
=item *
Added formal specification and usage guide instead of just example
=item *
Changed to use new prereqs data structure instead of individual keys
=back
=item *
Clarified intended use of 'author' as generalized contact list
=item *
Added 'release_status' field to indicate stable, testing or unstable
status to provide hints to indexers
=item *
Added 'description' field for a longer description of the distribution
=item *
Formalized use of "x_" or "X_" for all custom keys not listed in the
official spec
=back
=head2 Version 1.4
June 2008
=over
=item *
Noted explicit support for 'perl' in prerequisites
=item *
Added 'configure_requires' prerequisite type
=item *
Changed 'optional_features'
=over
=item *
Example corrected to show map of maps instead of list of maps
(though descriptive text said 'map' even in v1.3)
=item *
Removed 'requires_packages', 'requires_os' and 'excluded_os'
as valid subkeys
=back
=back
=head2 Version 1.3
November 2006
=over
=item *
Added 'no_index' subkey 'directory' and removed 'dir' to match actual
usage in the wild
=item *
Added a 'repository' subkey to 'resources'
=back
=head2 Version 1.2
August 2005
=over
=item *
Re-wrote and restructured spec in POD syntax
=item *
Changed 'name' to be mandatory
=item *
Changed 'generated_by' to be mandatory
=item *
Changed 'license' to be mandatory
=item *
Added version range specifications for prerequisites
=item *
Added required 'abstract' field
=item *
Added required 'author' field
=item *
Added required 'meta-spec' field to define 'version' (and 'url') of the
CPAN Meta Spec used for metadata
=item *
Added 'provides' field
=item *
Added 'no_index' field and deprecated 'private' field. 'no_index'
subkeys include 'file', 'dir', 'package' and 'namespace'
=item *
Added 'keywords' field
=item *
Added 'resources' field with subkeys 'homepage', 'license', and
'bugtracker'
=item *
Added 'optional_features' field as an alternate under 'recommends'.
Includes 'description', 'requires', 'build_requires', 'conflicts',
'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys
=item *
Removed 'license_uri' field
=back
=head2 Version 1.1
May 2003
=over
=item *
Changed 'version' to be mandatory
=item *
Added 'private' field
=item *
Added 'license_uri' field
=back
=head2 Version 1.0
March 2003
=over
=item *
Original release (in HTML format only)
=item *
Included 'name', 'version', 'license', 'distribution_type', 'requires',
'recommends', 'build_requires', 'conflicts', 'dynamic_config',
'generated_by'
=back
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Adam Kennedy <adamk@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

247
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/History/Meta_1_0.pod Normal file
View file

@ -0,0 +1,247 @@
=for :stopwords DOAP RDF
=head1 NAME
CPAN::Meta::History::Meta_1_0 - Version 1.0 metadata specification for META.yml
=head1 PREFACE
This is a historical copy of the version 1.0 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.
Modifications from the original:
=over
=item *
Conversion from the original HTML to POD format
=item *
Include list of valid licenses from L<Module::Build> 0.17 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.
=item *
Fixed some dead links to point to active resources.
=back
=head1 DESCRIPTION
This document describes version 1.0 of the F<META.yml> specification.
The META.yml file describes important properties of contributed Perl
distributions such as the ones found on L<CPAN|http://www.cpan.org>. It is
typically created by tools like L<Module::Build> and L<ExtUtils::MakeMaker>.
The fields in the F<META.yml> file are meant to be helpful to people
maintaining module collections (like CPAN), for people writing
installation tools (like L<CPAN> or L<CPANPLUS>), or just people who want to
know some stuff about a distribution before downloading it and starting to
install it.
=head1 Format
F<META.yml> files are written in the L<YAML|http://www.yaml.org/> format. The
reasons we chose YAML instead of, say, XML or Data::Dumper are discussed in
L<this thread|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg406.html>
on the MakeMaker mailing list.
The first line of a F<META.yml> file should be a valid
L<YAML document header|http://yaml.org/spec/history/2002-10-31.html#syntax-document>
like C<"--- #YAML:1.0">
=head1 Fields
The rest of the META.yml file is one big YAML
L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>,
whose keys are described here.
=over 4
=item name
Example: C<Module-Build>
The name of the distribution. Often created by taking the "main
module" in the distribution and changing "::" to "-". Sometimes it's
completely different, however, as in the case of the
L<libwww-perl|http://search.cpan.org/author/GAAS/libwww-perl/> distribution.
=item version
Example: C<0.16>
The version of the distribution to which the META.yml file refers.
=item license
Example: C<perl>
The license under which this distribution may be used and
redistributed.
Must be one of the following licenses:
=over 4
=item perl
The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.
=item gpl
The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item artistic
The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).
=item open_source
The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.
=item unrestricted
The distribution is licensed under a license that is B<not> approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=item restrictive
The distribution may not be redistributed without special permission from the
author and/or copyright holder.
=back
=item distribution_type
Example: C<module>
What kind of stuff is contained in this distribution. Most things on
CPAN are C<module>s (which can also mean a collection of
modules), but some things are C<script>s.
=item requires
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution requires for proper
operation. The keys are the module names, and the values are version
specifications as described in the
L<documentation for Module::Build's "requires" parameter|Module::Build::API/requires>.
I<Note: the exact nature of the fancy specifications like
C<< ">= 1.2, != 1.5, < 2.0" >> is subject to
change. Advance notice will be given here. The simple specifications
like C<"1.2"> will not change in format.>
=item recommends
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution recommends for enhanced
operation.
=item build_requires
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules required for building and/or testing of
this distribution. These dependencies are not required after the
module is installed.
=item conflicts
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules that cannot be installed while this
distribution is installed. This is a pretty uncommon situation.
=item dynamic_config
Example: C<0>
A boolean flag indicating whether a F<Build.PL> or
F<Makefile.PL> (or similar) must be executed, or whether this
module can be built, tested and installed solely from consulting its
metadata file. The main reason to set this to a true value if that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.
Currently L<Module::Build> doesn't actually do anything with
this flag - it's probably going to be up to higher-level tools like
L<CPAN.pm|CPAN> to do something useful with it. It can potentially
bring lots of security, packaging, and convenience improvements.
=item generated_by
Example: C<Module::Build version 0.16>
Indicates the tool that was used to create this F<META.yml> file. It's
good form to include both the name of the tool and its version, but
this field is essentially opaque, at least for the moment.
=back
=head1 Related Projects
=over 4
=item DOAP
An RDF vocabulary to describe software projects. L<http://usefulinc.com/doap>.
=back
=head1 History
=over 4
=item *
B<March 14, 2003> (Pi day) - created version 1.0 of this document.
=item *
B<May 8, 2003> - added the "dynamic_config" field, which was missing from the
initial version.
=back

309
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/History/Meta_1_1.pod Normal file
View file

@ -0,0 +1,309 @@
=for :stopwords Ingy READMEs WTF licensure
=head1 NAME
CPAN::Meta::History::Meta_1_1 - Version 1.1 metadata specification for META.yml
=head1 PREFACE
This is a historical copy of the version 1.1 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.
Modifications from the original:
=over
=item *
Conversion from the original HTML to POD format
=item *
Include list of valid licenses from L<Module::Build> 0.18 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.
=item *
Fixed some dead links to point to active resources.
=back
=head1 DESCRIPTION
This document describes version 1.1 of the F<META.yml> specification.
The F<META.yml> file describes important properties of contributed Perl
distributions such as the ones found on L<CPAN|http://www.cpan.org>. It is
typically created by tools like L<Module::Build> and L<ExtUtils::MakeMaker>.
The fields in the F<META.yml> file are meant to be helpful to people
maintaining module collections (like CPAN), for people writing
installation tools (like L<CPAN> or L<CPANPLUS>), or just people who want to
know some stuff about a distribution before downloading it and starting to
install it.
=head1 Format
F<META.yml> files are written in the L<YAML|http://www.yaml.org/> format. The
reasons we chose YAML instead of, say, XML or Data::Dumper are discussed in
L<this thread|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg406.html>
on the MakeMaker mailing list.
The first line of a F<META.yml> file should be a valid
L<YAML document header|http://yaml.org/spec/history/2002-10-31.html#syntax-document>
like C<"--- #YAML:1.0">
=head1 Fields
The rest of the META.yml file is one big YAML
L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>,
whose keys are described here.
=over 4
=item name
Example: C<Module-Build>
The name of the distribution. Often created by taking the "main
module" in the distribution and changing "::" to "-". Sometimes it's
completely different, however, as in the case of the
L<libwww-perl|http://search.cpan.org/author/GAAS/libwww-perl/> distribution.
=item version
Example: C<0.16>
The version of the distribution to which the META.yml file refers.
This is a mandatory field.
The version is essentially an arbitrary string, but I<must> be
only ASCII characters, and I<strongly should> be of the format
integer-dot-digit-digit, i.e. C<25.57>, optionally followed by
underscore-digit-digit, i.e. C<25.57_04>.
The standard tools that deal with module distribution (PAUSE, CPAN,
etc.) form an identifier for each distribution by joining the 'name'
and 'version' attributes with a dash (C<->) character. Tools
who are prepared to deal with distributions that have no version
numbers generally omit the dash as well.
=item license
Example: C<perl>
a descriptive term for the licenses ... not authoritative, but must
be consistent with licensure statements in the READMEs, documentation, etc.
The license under which this distribution may be used and
redistributed.
Must be one of the following licenses:
=over 4
=item perl
The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.
=item gpl
The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item artistic
The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).
=item open_source
The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.
=item unrestricted
The distribution is licensed under a license that is B<not> approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=item restrictive
The distribution may not be redistributed without special permission from the
author and/or copyright holder.
=back
=item license_uri
This should contain a URI where the exact terms of the license may be found.
(change "unrestricted" to "redistributable"?)
=item distribution_type
Example: C<module>
What kind of stuff is contained in this distribution. Most things on
CPAN are C<module>s (which can also mean a collection of
modules), but some things are C<script>s.
This field is basically meaningless, and tools (like Module::Build or
MakeMaker) will likely stop generating it in the future.
=item private
WTF is going on here?
index_ignore: any application that indexes the contents of
distributions (PAUSE, search.cpan.org) ought to ignore the items
(packages, files, directories, namespace hierarchies).
=item requires
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution requires for proper
operation. The keys are the module names, and the values are version
specifications as described in the
L<documentation for Module::Build's "requires" parameter|Module::Build::API/requires>.
I<Note: the exact nature of the fancy specifications like
C<< ">= 1.2, != 1.5, < 2.0" >> is subject to
change. Advance notice will be given here. The simple specifications
like C<"1.2"> will not change in format.>
=item recommends
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution recommends for enhanced
operation.
=item build_requires
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules required for building and/or testing of
this distribution. These dependencies are not required after the
module is installed.
=item conflicts
Example:
Data::Dumper: 0
File::Find: 1.03
A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules that cannot be installed while this
distribution is installed. This is a pretty uncommon situation.
- possibly separate out test-time prereqs, complications include: can
tests be meaningfully preserved for later running? are test-time
prereqs in addition to build-time, or exclusive?
- make official location for installed *distributions*, which can
contain tests, etc.
=item dynamic_config
Example: C<0>
A boolean flag indicating whether a F<Build.PL> or
F<Makefile.PL> (or similar) must be executed, or whether this
module can be built, tested and installed solely from consulting its
metadata file. The main reason to set this to a true value if that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.
Currently L<Module::Build> doesn't actually do anything with
this flag - it's probably going to be up to higher-level tools like
L<CPAN.pm|CPAN> to do something useful with it. It can potentially
bring lots of security, packaging, and convenience improvements.
=item generated_by
Example: C<Module::Build version 0.16>
Indicates the tool that was used to create this F<META.yml> file. It's
good form to include both the name of the tool and its version, but
this field is essentially opaque, at least for the moment.
=back
=head2 Ingy's suggestions
=over 4
=item short_description
add as field, containing abstract, maximum 80 characters, suggested minimum 40 characters
=item description
long version of abstract, should add?
=item maturity
alpha, beta, gamma, mature, stable
=item author_id, owner_id
=item categorization, keyword, chapter_id
=item URL for further information
could default to search.cpan.org on PAUSE
=item namespaces
can be specified for single elements by prepending
dotted-form, i.e. "com.example.my_application.my_property". Default
namespace for META.yml is probably "org.cpan.meta_author" or
something. Precedent for this is Apple's Carbon namespaces, I think.
=back
=head1 History
=over 4
=item *
B<March 14, 2003> (Pi day) - created version 1.0 of this document.
=item *
B<May 8, 2003> - added the "dynamic_config" field, which was missing from the
initial version.
=back

712
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/History/Meta_1_2.pod Normal file
View file

@ -0,0 +1,712 @@
=for :stopwords MailingList RWS subcontext
=head1 NAME
CPAN::Meta::History::Meta_1_2 - Version 1.2 metadata specification for META.yml
=head1 PREFACE
This is a historical copy of the version 1.2 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.
Modifications from the original:
=over
=item *
Various spelling corrections
=item *
Include list of valid licenses from L<Module::Build> 0.2611 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.
=item *
Fixed some dead links to point to active resources.
=back
=head1 SYNOPSIS
--- #YAML:1.0
name: Module-Build
abstract: Build and install Perl modules
version: 0.20
author:
- Ken Williams <kwilliams@cpan.org>
license: perl
distribution_type: module
requires:
Config: 0
Cwd: 0
Data::Dumper: 0
ExtUtils::Install: 0
File::Basename: 0
File::Compare: 0
File::Copy: 0
File::Find: 0
File::Path: 0
File::Spec: 0
IO::File: 0
perl: 5.005_03
recommends:
Archive::Tar: 1.00
ExtUtils::Install: 0.3
ExtUtils::ParseXS: 2.02
Pod::Text: 0
YAML: 0.35
build_requires:
Test: 0
urls:
license: http://dev.perl.org/licenses/
meta-spec:
version: 1.2
url: http://module-build.sourceforge.net/META-spec-v1.2.html
generated_by: Module::Build version 0.20
=head1 DESCRIPTION
This document describes version 1.2 of the F<META.yml> specification.
The F<META.yml> file describes important properties of contributed
Perl distributions such as the ones found on CPAN. It is typically
created by tools like Module::Build, Module::Install, and
ExtUtils::MakeMaker.
The fields in the F<META.yml> file are meant to be helpful for people
maintaining module collections (like CPAN), for people writing
installation tools (like CPAN.pm or CPANPLUS), or just for people who
want to know some stuff about a distribution before downloading it and
starting to install it.
I<Note: The latest stable version of this specification can always be
found at L<http://module-build.sourceforge.net/META-spec-current.html>,
and the latest development version (which may include things that
won't make it into the stable version can always be found at
L<http://module-build.sourceforge.net/META-spec-blead.html>.>
=head1 FORMAT
F<META.yml> files are written in the YAML format (see
L<http://www.yaml.org/>).
See the following links to learn why we chose YAML instead of, say,
XML or Data::Dumper:
=over 4
=item *
L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
=item *
L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
=item *
L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
=back
=head1 TERMINOLOGY
=over 4
=item distribution
This is the primary object described by the F<META.yml>
specification. In the context of this document it usually refers to a
collection of modules, scripts, and/or documents that are distributed
for other developers to use.
=item module
This refers to a reusable library of code typically contained in a
single file. Currently, we primarily talk of perl modules, but this
specification should be open enough to apply to other languages as
well (ex. python, ruby).
=back
=head1 VERSION SPECIFICATIONS
Some fields require a version specification (ex. L</requires>,
L</recommends>, L</build_requires>, etc.). This section details the
version specifications that are currently supported.
If a single version is listed, then that version is considered to be
the minimum version supported.
If 0 is given as the version number, then any version is supported.
Additionally, for more complicated requirements, the specification
supports a list of versions, each of which may be optionally preceded
by a relational operator.
Supported operators include E<lt> (less than), E<lt>= (less than or
equal), E<gt> (greater than), E<gt>= (greater than or equal), == (equal), and !=
(not equal).
If a list is given then it is evaluated from left to right so that any
specifications in the list that conflict with a previous specification
are overridden by the later.
Examples:
>= 1.2, != 1.5, < 2.0
Any version from version 1.2 onward, except version 1.5, that also
precedes version 2.0.
=head1 HEADER
The first line of a F<META.yml> file should be a valid YAML document
header like C<"--- #YAML:1.0">.
=head1 FIELDS
The rest of the F<META.yml> file is one big YAML mapping whose keys
are described here.
=head2 meta-spec
Example:
meta-spec:
version: 1.2
url: http://module-build.sourceforge.net/META-spec-v1.2.html
(Spec 1.1) [required] {URL} This field indicates the location of the
version of the META.yml specification used.
=head2 name
Example:
name: Module-Build
(Spec 1.0) [required] {string} The name of the distribution which is often
created by taking the "main module" in the distribution and changing
"::" to "-". Sometimes it's completely different, however, as in the
case of the libwww-perl distribution (see
L<http://search.cpan.org/author/GAAS/libwww-perl/>).
=head2 version
Example:
version: 0.20
(Spec 1.0) [required] {version} The version of the distribution to which the
F<META.yml> file refers.
=head2 abstract
Example:
abstract: Build and install Perl modules.
(Spec 1.1) [required] {string} A short description of the purpose of the
distribution.
=head2 author
Example:
author:
- Ken Williams <kwilliams@cpan.org>
(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
distribution. The preferred form is author-name <email-address>.
=head2 license
Example:
license: perl
(Spec 1.0) [required] {string} The license under which this distribution may be
used and redistributed.
Must be one of the following licenses:
=over 4
=item perl
The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.
=item gpl
The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item artistic
The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).
=item open_source
The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.
=item unrestricted
The distribution is licensed under a license that is B<not> approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=item restrictive
The distribution may not be redistributed without special permission from the
author and/or copyright holder.
=back
=head2 distribution_type
Example:
distribution_type: module
(Spec 1.0) [optional] {string} What kind of stuff is contained in this
distribution. Most things on CPAN are C<module>s (which can also mean
a collection of modules), but some things are C<script>s.
Unfortunately this field is basically meaningless, since many
distributions are hybrids of several kinds of things, or some new
thing, or subjectively different in focus depending on who's using
them. Tools like Module::Build and MakeMaker will likely stop
generating this field.
=head2 requires
Example:
requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
distribution requires for proper operation. The keys are the module
names, and the values are version specifications as described in
L<Module::Build> for the "requires" parameter.
=head2 recommends
Example:
recommends:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
distribution recommends for enhanced operation.
I<ALTERNATIVE: It may be desirable to present to the user which
features depend on which modules so they can make an informed
decision about which recommended modules to install.>
Example:
optional_features:
- foo:
description: Provides the ability to blah.
requires:
Data::Dumper: 0
File::Find: 1.03
- bar:
description: This feature is not available on this platform.
excludes_os: MSWin32
I<(Spec 1.1) [optional] {map} A YAML sequence of names for optional features
which are made available when its requirements are met. For each
feature a description is provided along with any of L</requires>,
L</build_requires>, L</conflicts>, C<requires_packages>,
C<requires_os>, and C<excludes_os> which have the same meaning in
this subcontext as described elsewhere in this document.>
=head2 build_requires
Example:
build_requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
required for building and/or testing of this distribution. These
dependencies are not required after the module is installed.
=head2 conflicts
Example:
conflicts:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules that
cannot be installed while this distribution is installed. This is a
pretty uncommon situation.
=head2 dynamic_config
Example:
dynamic_config: 0
(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
or F<Makefile.PL> (or similar) must be executed when building this
distribution, or whether it can be built, tested and installed solely
from consulting its
metadata file. The main reason to set this to a true value if that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.
Currently Module::Build doesn't actually do anything with this flag
- it's probably going to be up to higher-level tools like CPAN
to do something useful with it. It can potentially bring lots of
security, packaging, and convenience improvements.
If this field is omitted, it defaults to 1 (true).
=head2 private
I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
L</no_index>. See below.
=head2 provides
Example:
provides:
Foo::Bar:
file: lib/Foo/Bar.pm
version: 0.27_02
Foo::Bar::Blah:
file: lib/Foo/Bar/Blah.pm
Foo::Bar::Baz:
file: lib/Foo/Bar/Baz.pm
version: 0.3
(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
provided by this distribution. This information can be (and, in some
cases, is) used by distribution and automation mechanisms like PAUSE,
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.
When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
scanning through the distribution files themselves to figure out
packages and versions. This is a good thing, because it means you can
use the C<provides> field to tell the indexers precisely what you want
indexed about your distribution, rather than relying on them to
essentially guess what you want indexed.
=head2 no_index
Example:
no_index:
file:
- My/Module.pm
dir:
- My/Private
package:
- My::Module::Stuff
namespace:
- My::Module::Stuff
(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
directories, packages, and namespaces that are private
(i.e. implementation artifacts) that are not of interest to searching
and indexing tools. This is useful when no C<provides> field is
present.
I<(Note: I'm not actually sure who looks at this field, or exactly
what they do with it. This spec could be off in some way from actual
usage.)>
=head3 file
(Spec 1.1) [optional] Exclude any listed file(s).
=head3 dir
(Spec 1.1) [optional] Exclude anything below the listed
directory(ies).
=head3 package
(Spec 1.1) [optional] Exclude the listed package(s).
=head3 namespace
(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
but I<not> the listed namespace(s) its self.
=head2 keywords
Example:
keywords:
- make
- build
- install
(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
this distribution.
=head2 resources
Example:
resources:
license: http://dev.perl.org/licenses/
homepage: http://sourceforge.net/projects/module-build
bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general
(Spec 1.1) [optional] {map} A mapping of any URL resources related to
this distribution. All-lower-case keys, such as C<homepage>,
C<license>, and C<bugtracker>, are reserved by this specification, as
they have "official" meanings defined here in this specification. If
you'd like to add your own "special" entries (like the "MailingList"
entry above), use at least one upper-case letter.
The current set of official keys is:
=over 2
=item homepage
The official home of this project on the web.
=item license
An URL for an official statement of this distribution's license.
=item bugtracker
An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.
=back
=head2 generated_by
Example:
generated_by: Module::Build version 0.20
(Spec 1.0) [required] {string} Indicates the tool that was used to create this
F<META.yml> file. It's good form to include both the name of the tool
and its version, but this field is essentially opaque, at least for
the moment. If F<META.yml> was generated by hand, it is suggested that
the author be specified here.
[Note: My F<meta_stats.pl> script which I use to gather statistics
regarding F<META.yml> usage prefers the form listed above, i.e. it
splits on /\s+version\s+/ taking the first field as the name of the
tool that generated the file and the second field as version of that
tool. RWS]
=head1 SEE ALSO
L<CPAN|http://www.cpan.org/>
L<CPAN.pm|CPAN>
L<CPANPLUS>
L<Data::Dumper>
L<ExtUtils::MakeMaker>
L<Module::Build>
L<Module::Install>
L<XML|http://www.w3.org/XML/>
L<YAML|http://www.yaml.org/>
=head1 HISTORY
=over 4
=item March 14, 2003 (Pi day)
=over 2
=item *
Created version 1.0 of this document.
=back
=item May 8, 2003
=over 2
=item *
Added the L</dynamic_config> field, which was missing from the initial
version.
=back
=item November 13, 2003
=over 2
=item *
Added more YAML rationale articles.
=item *
Fixed existing link to YAML discussion thread to point to new
L<http://nntp.x.perl.org/group/> site.
=item *
Added and deprecated the L</private> field.
=item *
Added L</abstract>, C<configure>, C<requires_packages>,
C<requires_os>, C<excludes_os>, and L</no_index> fields.
=item *
Bumped version.
=back
=item November 16, 2003
=over 2
=item *
Added C<generation>, C<authored_by> fields.
=item *
Add alternative proposal to the L</recommends> field.
=item *
Add proposal for a C<requires_build_tools> field.
=back
=item December 9, 2003
=over 2
=item *
Added link to latest version of this specification on CPAN.
=item *
Added section L</"VERSION SPECIFICATIONS">.
=item *
Chang name from Module::Build::META-spec to CPAN::META::Specification.
=item *
Add proposal for C<auto_regenerate> field.
=back
=item December 15, 2003
=over 2
=item *
Add C<index> field as a compliment to L</no_index>
=item *
Add L</keywords> field as a means to aid searching distributions.
=item *
Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.
=back
=item July 26, 2005
=over 2
=item *
Removed a bunch of items (generation, requires_build_tools,
requires_packages, configure, requires_os, excludes_os,
auto_regenerate) that have never actually been supported, but were
more like records of brainstorming.
=item *
Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.
=item *
Added the "==" operator to the list of supported version-checking
operators.
=item *
Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.
=item *
Clarified L</dynamic_config> a bit.
=back
=item August 23, 2005
=over 2
=item *
Removed the name C<CPAN::META::Specification>, since that implies a
module that doesn't actually exist.
=back
=back

741
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/History/Meta_1_3.pod Normal file
View file

@ -0,0 +1,741 @@
=for :stopwords MailingList PODs RWS subcontext
=head1 NAME
CPAN::Meta::History::Meta_1_3 - Version 1.3 metadata specification for META.yml
=head1 PREFACE
This is a historical copy of the version 1.3 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.
Modifications from the original:
=over
=item *
Various spelling corrections
=item *
Include list of valid licenses from L<Module::Build> 0.2805 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.
=item *
Fixed some dead links to point to active resources.
=back
=head1 SYNOPSIS
--- #YAML:1.0
name: Module-Build
abstract: Build and install Perl modules
version: 0.20
author:
- Ken Williams <kwilliams@cpan.org>
license: perl
distribution_type: module
requires:
Config: 0
Cwd: 0
Data::Dumper: 0
ExtUtils::Install: 0
File::Basename: 0
File::Compare: 0
File::Copy: 0
File::Find: 0
File::Path: 0
File::Spec: 0
IO::File: 0
perl: 5.005_03
recommends:
Archive::Tar: 1.00
ExtUtils::Install: 0.3
ExtUtils::ParseXS: 2.02
Pod::Text: 0
YAML: 0.35
build_requires:
Test: 0
urls:
license: http://dev.perl.org/licenses/
meta-spec:
version: 1.3
url: http://module-build.sourceforge.net/META-spec-v1.3.html
generated_by: Module::Build version 0.20
=head1 DESCRIPTION
This document describes version 1.3 of the F<META.yml> specification.
The F<META.yml> file describes important properties of contributed
Perl distributions such as the ones found on CPAN. It is typically
created by tools like Module::Build, Module::Install, and
ExtUtils::MakeMaker.
The fields in the F<META.yml> file are meant to be helpful for people
maintaining module collections (like CPAN), for people writing
installation tools (like CPAN.pm or CPANPLUS), or just for people who
want to know some stuff about a distribution before downloading it and
starting to install it.
I<Note: The latest stable version of this specification can always be
found at L<http://module-build.sourceforge.net/META-spec-current.html>,
and the latest development version (which may include things that
won't make it into the stable version) can always be found at
L<http://module-build.sourceforge.net/META-spec-blead.html>.>
=head1 FORMAT
F<META.yml> files are written in the YAML format (see
L<http://www.yaml.org/>).
See the following links to learn why we chose YAML instead of, say,
XML or Data::Dumper:
=over 4
=item *
L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
=item *
L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
=item *
L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
=back
=head1 TERMINOLOGY
=over 4
=item distribution
This is the primary object described by the F<META.yml>
specification. In the context of this document it usually refers to a
collection of modules, scripts, and/or documents that are distributed
together for other developers to use. Examples of distributions are
C<Class-Container>, C<libwww-perl>, or C<DBI>.
=item module
This refers to a reusable library of code typically contained in a
single file. Currently, we primarily talk of perl modules, but this
specification should be open enough to apply to other languages as
well (ex. python, ruby). Examples of modules are C<Class::Container>,
C<LWP::Simple>, or C<DBD::File>.
=back
=head1 HEADER
The first line of a F<META.yml> file should be a valid YAML document
header like C<"--- #YAML:1.0">.
=head1 FIELDS
The rest of the F<META.yml> file is one big YAML mapping whose keys
are described here.
=head2 meta-spec
Example:
meta-spec:
version: 1.3
url: http://module-build.sourceforge.net/META-spec-v1.3.html
(Spec 1.1) [required] {URL} This field indicates the location of the
version of the META.yml specification used.
=head2 name
Example:
name: Module-Build
(Spec 1.0) [required] {string} The name of the distribution which is often
created by taking the "main module" in the distribution and changing
"::" to "-". Sometimes it's completely different, however, as in the
case of the libwww-perl distribution (see
L<http://search.cpan.org/dist/libwww-perl/>).
=head2 version
Example:
version: 0.20
(Spec 1.0) [required] {version} The version of the distribution to which the
F<META.yml> file refers.
=head2 abstract
Example:
abstract: Build and install Perl modules.
(Spec 1.1) [required] {string} A short description of the purpose of the
distribution.
=head2 author
Example:
author:
- Ken Williams <kwilliams@cpan.org>
(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
distribution. The preferred form is author-name <email-address>.
=head2 license
Example:
license: perl
(Spec 1.0) [required] {string} The license under which this distribution may be
used and redistributed.
Must be one of the following licenses:
=over 4
=item apache
The distribution is licensed under the Apache Software License version 1.1
(L<http://opensource.org/licenses/Apache-1.1>).
=item artistic
The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).
=item gpl
The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item mit
The distribution is licensed under the MIT License
(L<http://opensource.org/licenses/MIT>).
=item mozilla
The distribution is licensed under the Mozilla Public License.
(L<http://opensource.org/licenses/MPL-1.0> or
L<http://opensource.org/licenses/MPL-1.1>)
=item open_source
The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.
=item perl
The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.
=item restrictive
The distribution may not be redistributed without special permission from the
author and/or copyright holder.
=item unrestricted
The distribution is licensed under a license that is not approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=back
=head2 distribution_type
Example:
distribution_type: module
(Spec 1.0) [optional] {string} What kind of stuff is contained in this
distribution. Most things on CPAN are C<module>s (which can also mean
a collection of modules), but some things are C<script>s.
Unfortunately this field is basically meaningless, since many
distributions are hybrids of several kinds of things, or some new
thing, or subjectively different in focus depending on who's using
them. Tools like Module::Build and MakeMaker will likely stop
generating this field.
=head2 requires
Example:
requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
distribution requires for proper operation. The keys are the module
names, and the values are version specifications as described in
L</"VERSION SPECIFICATIONS">.
=head2 recommends
Example:
recommends:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
this distribution recommends for enhanced operation. The keys are the
module names, and the values are version specifications as described
in L</"VERSION SPECIFICATIONS">.
I<ALTERNATIVE: It may be desirable to present to the user which
features depend on which modules so they can make an informed decision
about which recommended modules to install.>
Example:
optional_features:
- foo:
description: Provides the ability to blah.
requires:
Data::Dumper: 0
File::Find: 1.03
- bar:
description: This feature is not available on this platform.
excludes_os: MSWin32
I<(Spec 1.1) [optional] {map} A YAML sequence of names for optional features
which are made available when its requirements are met. For each
feature a description is provided along with any of L</requires>,
L</build_requires>, L</conflicts>, C<requires_packages>,
C<requires_os>, and C<excludes_os> which have the same meaning in
this subcontext as described elsewhere in this document.>
=head2 build_requires
Example:
build_requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
required for building and/or testing of this distribution. The keys
are the module names, and the values are version specifications as
described in L</"VERSION SPECIFICATIONS">. These dependencies are not
required after the module is installed.
=head2 conflicts
Example:
conflicts:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules that
cannot be installed while this distribution is installed. This is a
pretty uncommon situation. The keys for C<conflicts> are the module
names, and the values are version specifications as described in
L</"VERSION SPECIFICATIONS">.
=head2 dynamic_config
Example:
dynamic_config: 0
(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
or F<Makefile.PL> (or similar) must be executed when building this
distribution, or whether it can be built, tested and installed solely
from consulting its
metadata file. The main reason to set this to a true value is that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.
Currently Module::Build doesn't actually do anything with this flag
- it's probably going to be up to higher-level tools like CPAN
to do something useful with it. It can potentially bring lots of
security, packaging, and convenience improvements.
If this field is omitted, it defaults to 1 (true).
=head2 private
I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
L</no_index>. See below.
=head2 provides
Example:
provides:
Foo::Bar:
file: lib/Foo/Bar.pm
version: 0.27_02
Foo::Bar::Blah:
file: lib/Foo/Bar/Blah.pm
Foo::Bar::Baz:
file: lib/Foo/Bar/Baz.pm
version: 0.3
(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
provided by this distribution. This information can be (and, in some
cases, is) used by distribution and automation mechanisms like PAUSE,
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.
When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
scanning through the distribution files themselves to figure out
packages and versions. This is a good thing, because it means you can
use the C<provides> field to tell the indexers precisely what you want
indexed about your distribution, rather than relying on them to
essentially guess what you want indexed.
=head2 no_index
Example:
no_index:
file:
- My/Module.pm
directory:
- My/Private
package:
- My::Module::Stuff
namespace:
- My::Module::Stuff
(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
directories, packages, and namespaces that are private
(i.e. implementation artifacts) that are not of interest to searching
and indexing tools. This is useful when no C<provides> field is
present.
For example, L<http://search.cpan.org/> excludes items listed in C<no_index>
when searching for POD, meaning files in these directories will not
converted to HTML and made public - which is useful if you have
example or test PODs that you don't want the search engine to go
through.
=head3 file
(Spec 1.1) [optional] Exclude any listed file(s).
=head3 directory
(Spec 1.1) [optional] Exclude anything below the listed
directory(ies).
[Note: previous editions of the spec had C<dir> instead of
C<directory>, but I think MakeMaker and various users started using
C<directory>, so in deference we switched to that.]
=head3 package
(Spec 1.1) [optional] Exclude the listed package(s).
=head3 namespace
(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
but I<not> the listed namespace(s) its self.
=head2 keywords
Example:
keywords:
- make
- build
- install
(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
this distribution.
=head2 resources
Example:
resources:
license: http://dev.perl.org/licenses/
homepage: http://sourceforge.net/projects/module-build
bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
repository: http://sourceforge.net/cvs/?group_id=45731
MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general
(Spec 1.1) [optional] {map} A mapping of any URL resources related to
this distribution. All-lower-case keys, such as C<homepage>,
C<license>, and C<bugtracker>, are reserved by this specification, as
they have "official" meanings defined here in this specification. If
you'd like to add your own "special" entries (like the "MailingList"
entry above), use at least one upper-case letter.
The current set of official keys is:
=over 2
=item homepage
The official home of this project on the web.
=item license
An URL for an official statement of this distribution's license.
=item bugtracker
An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.
=back
=head2 generated_by
Example:
generated_by: Module::Build version 0.20
(Spec 1.0) [required] {string} Indicates the tool that was used to create this
F<META.yml> file. It's good form to include both the name of the tool
and its version, but this field is essentially opaque, at least for
the moment. If F<META.yml> was generated by hand, it is suggested that
the author be specified here.
[Note: My F<meta_stats.pl> script which I use to gather statistics
regarding F<META.yml> usage prefers the form listed above, i.e. it
splits on /\s+version\s+/ taking the first field as the name of the
tool that generated the file and the second field as version of that
tool. RWS]
=head1 VERSION SPECIFICATIONS
Some fields require a version specification (ex. L</requires>,
L</recommends>, L</build_requires>, etc.) to indicate the particular
versionZ<>(s) of some other module that may be required as a
prerequisite. This section details the version specification formats
that are currently supported.
The simplest format for a version specification is just the version
number itself, e.g. C<2.4>. This means that B<at least> version 2.4
must be present. To indicate that B<any> version of a prerequisite is
okay, even if the prerequisite doesn't define a version at all, use
the version C<0>.
You may also use the operators E<lt> (less than), E<lt>= (less than or
equal), E<gt> (greater than), E<gt>= (greater than or equal), ==
(equal), and != (not equal). For example, the specification C<E<lt>
2.0> means that any version of the prerequisite less than 2.0 is
suitable.
For more complicated situations, version specifications may be AND-ed
together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
2.0> indicates a version that must be B<at least> 1.2, B<less than>
2.0, and B<not equal to> 1.5.
=head1 SEE ALSO
L<CPAN|http://www.cpan.org/>
L<CPAN.pm|CPAN>
L<CPANPLUS>
L<Data::Dumper>
L<ExtUtils::MakeMaker>
L<Module::Build>
L<Module::Install>
L<XML|http://www.w3.org/XML/>
L<YAML|http://www.yaml.org/>
=head1 HISTORY
=over 4
=item March 14, 2003 (Pi day)
=over 2
=item *
Created version 1.0 of this document.
=back
=item May 8, 2003
=over 2
=item *
Added the L</dynamic_config> field, which was missing from the initial
version.
=back
=item November 13, 2003
=over 2
=item *
Added more YAML rationale articles.
=item *
Fixed existing link to YAML discussion thread to point to new
L<http://nntp.x.perl.org/group/> site.
=item *
Added and deprecated the L</private> field.
=item *
Added L</abstract>, C<configure>, C<requires_packages>,
C<requires_os>, C<excludes_os>, and L</no_index> fields.
=item *
Bumped version.
=back
=item November 16, 2003
=over 2
=item *
Added C<generation>, C<authored_by> fields.
=item *
Add alternative proposal to the L</recommends> field.
=item *
Add proposal for a C<requires_build_tools> field.
=back
=item December 9, 2003
=over 2
=item *
Added link to latest version of this specification on CPAN.
=item *
Added section L</"VERSION SPECIFICATIONS">.
=item *
Chang name from Module::Build::META-spec to CPAN::META::Specification.
=item *
Add proposal for C<auto_regenerate> field.
=back
=item December 15, 2003
=over 2
=item *
Add C<index> field as a compliment to L</no_index>
=item *
Add L</keywords> field as a means to aid searching distributions.
=item *
Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.
=back
=item July 26, 2005
=over 2
=item *
Removed a bunch of items (generation, requires_build_tools,
requires_packages, configure, requires_os, excludes_os,
auto_regenerate) that have never actually been supported, but were
more like records of brainstorming.
=item *
Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.
=item *
Added the "==" operator to the list of supported version-checking
operators.
=item *
Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.
=item *
Clarified L</dynamic_config> a bit.
=back
=item August 23, 2005
=over 2
=item *
Removed the name C<CPAN::META::Specification>, since that implies a
module that doesn't actually exist.
=back
=back

765
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/History/Meta_1_4.pod Normal file
View file

@ -0,0 +1,765 @@
=for :stopwords MailingList PODs RWS subcontext
=head1 NAME
CPAN::Meta::History::Meta_1_4 - Version 1.4 metadata specification for META.yml
=head1 PREFACE
This is a historical copy of the version 1.4 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.
Modifications from the original:
=over
=item *
Various spelling corrections
=item *
Include list of valid licenses from L<Module::Build> 0.2807 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.
=item *
Fixed some dead links to point to active resources.
=back
=head1 SYNOPSIS
--- #YAML:1.0
name: Module-Build
abstract: Build and install Perl modules
version: 0.20
author:
- Ken Williams <kwilliams@cpan.org>
license: perl
distribution_type: module
requires:
Config: 0
Cwd: 0
Data::Dumper: 0
ExtUtils::Install: 0
File::Basename: 0
File::Compare: 0
File::Copy: 0
File::Find: 0
File::Path: 0
File::Spec: 0
IO::File: 0
perl: 5.005_03
recommends:
Archive::Tar: 1.00
ExtUtils::Install: 0.3
ExtUtils::ParseXS: 2.02
Pod::Text: 0
YAML: 0.35
build_requires:
Test: 0
resources:
license: http://dev.perl.org/licenses/
meta-spec:
version: 1.4
url: http://module-build.sourceforge.net/META-spec-v1.3.html
generated_by: Module::Build version 0.20
=head1 DESCRIPTION
This document describes version 1.4 of the F<META.yml> specification.
The F<META.yml> file describes important properties of contributed
Perl distributions such as the ones found on CPAN. It is typically
created by tools like Module::Build, Module::Install, and
ExtUtils::MakeMaker.
The fields in the F<META.yml> file are meant to be helpful for people
maintaining module collections (like CPAN), for people writing
installation tools (like CPAN.pm or CPANPLUS), or just for people who
want to know some stuff about a distribution before downloading it and
starting to install it.
I<Note: The latest stable version of this specification can always be
found at L<http://module-build.sourceforge.net/META-spec-current.html>,
and the latest development version (which may include things that
won't make it into the stable version) can always be found at
L<http://module-build.sourceforge.net/META-spec-blead.html>.>
=head1 FORMAT
F<META.yml> files are written in the YAML format (see
L<http://www.yaml.org/>).
See the following links to learn why we chose YAML instead of, say,
XML or Data::Dumper:
=over 4
=item *
L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>
=item *
L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>
=item *
L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>
=back
=head1 TERMINOLOGY
=over 4
=item distribution
This is the primary object described by the F<META.yml>
specification. In the context of this document it usually refers to a
collection of modules, scripts, and/or documents that are distributed
together for other developers to use. Examples of distributions are
C<Class-Container>, C<libwww-perl>, or C<DBI>.
=item module
This refers to a reusable library of code typically contained in a
single file. Currently, we primarily talk of perl modules, but this
specification should be open enough to apply to other languages as
well (ex. python, ruby). Examples of modules are C<Class::Container>,
C<LWP::Simple>, or C<DBD::File>.
=back
=head1 HEADER
The first line of a F<META.yml> file should be a valid YAML document
header like C<"--- #YAML:1.0">.
=head1 FIELDS
The rest of the F<META.yml> file is one big YAML mapping whose keys
are described here.
=head2 meta-spec
Example:
meta-spec:
version: 1.4
url: http://module-build.sourceforge.net/META-spec-v1.3.html
(Spec 1.1) [required] {URL} This field indicates the location of the
version of the META.yml specification used.
=head2 name
Example:
name: Module-Build
(Spec 1.0) [required] {string} The name of the distribution which is often
created by taking the "main module" in the distribution and changing
"::" to "-". Sometimes it's completely different, however, as in the
case of the libwww-perl distribution (see
L<http://search.cpan.org/dist/libwww-perl/>).
=head2 version
Example:
version: 0.20
(Spec 1.0) [required] {version} The version of the distribution to which the
F<META.yml> file refers.
=head2 abstract
Example:
abstract: Build and install Perl modules.
(Spec 1.1) [required] {string} A short description of the purpose of the
distribution.
=head2 author
Example:
author:
- Ken Williams <kwilliams@cpan.org>
(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
distribution. The preferred form is author-name <email-address>.
=head2 license
Example:
license: perl
(Spec 1.0) [required] {string} The license under which this
distribution may be used and redistributed.
Must be one of the following licenses:
=over 4
=item apache
The distribution is licensed under the Apache Software License version 1.1
(L<http://opensource.org/licenses/Apache-1.1>).
=item artistic
The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).
=item bsd
The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).
=item gpl
The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).
=item lgpl
The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).
=item mit
The distribution is licensed under the MIT License
(L<http://opensource.org/licenses/MIT>).
=item mozilla
The distribution is licensed under the Mozilla Public License.
(L<http://opensource.org/licenses/MPL-1.0> or
L<http://opensource.org/licenses/MPL-1.1>)
=item open_source
The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.
=item perl
The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL or
the Artistic license.
=item restrictive
The distribution may not be redistributed without special permission from the
author and/or copyright holder.
=item unrestricted
The distribution is licensed under a license that is not approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.
=back
=head2 distribution_type
Example:
distribution_type: module
(Spec 1.0) [optional] {string} What kind of stuff is contained in this
distribution. Most things on CPAN are C<module>s (which can also mean
a collection of modules), but some things are C<script>s.
Unfortunately this field is basically meaningless, since many
distributions are hybrids of several kinds of things, or some new
thing, or subjectively different in focus depending on who's using
them. Tools like Module::Build and MakeMaker will likely stop
generating this field.
=head2 requires
Example:
requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
prerequisites this distribution requires for proper operation. The
keys are the names of the prerequisites (module names or 'perl'), and
the values are version specifications as described in L<VERSION
SPECIFICATIONS>.
=head2 recommends
Example:
recommends:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
prerequisites this distribution recommends for enhanced operation.
The keys are the names of the prerequisites (module names or 'perl'),
and the values are version specifications as described in L<VERSION
SPECIFICATIONS>.
I<ALTERNATIVE: It may be desirable to present to the user which
features depend on which modules so they can make an informed decision
about which recommended modules to install.>
Example:
optional_features:
foo:
description: Provides the ability to blah.
requires:
Data::Dumper: 0
File::Find: 1.03
I<(Spec 1.1) [optional] {map} A YAML mapping of names for optional features
which are made available when its requirements are met. For each
feature a description is provided along with any of L</requires>,
L</build_requires>, and L</conflicts>, which have the same meaning in
this subcontext as described elsewhere in this document.>
=head2 build_requires
Example:
build_requires:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
prerequisites required for building and/or testing of this
distribution. The keys are the names of the prerequisites (module
names or 'perl'), and the values are version specifications as
described in L</"VERSION SPECIFICATIONS">. These dependencies are not
required after the distribution is installed.
=head2 configure_requires
Example:
configure_requires:
Module::Build: 0.2809
Data::Dumper: 0
File::Find: 1.03
(Spec 1.4) [optional] {map} A YAML mapping indicating the Perl prerequisites
required before configuring this distribution. The keys are the
names of the prerequisites (module names or 'perl'), and the values are version
specifications as described in L</"VERSION SPECIFICATIONS">. These
dependencies are not required after the distribution is installed.
=head2 conflicts
Example:
conflicts:
Data::Dumper: 0
File::Find: 1.03
(Spec 1.0) [optional] {map} A YAML mapping indicating any items that
cannot be installed while this distribution is installed. This is a
pretty uncommon situation. The keys for C<conflicts> are the item
names (module names or 'perl'), and the values are version
specifications as described in L</"VERSION SPECIFICATIONS">.
=head2 dynamic_config
Example:
dynamic_config: 0
(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
or F<Makefile.PL> (or similar) must be executed when building this
distribution, or whether it can be built, tested and installed solely
from consulting its
metadata file. The main reason to set this to a true value is that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.
Currently Module::Build doesn't actually do anything with this flag
- it's probably going to be up to higher-level tools like CPAN
to do something useful with it. It can potentially bring lots of
security, packaging, and convenience improvements.
If this field is omitted, it defaults to 1 (true).
=head2 private
I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
L</no_index>. See below.
=head2 provides
Example:
provides:
Foo::Bar:
file: lib/Foo/Bar.pm
version: 0.27_02
Foo::Bar::Blah:
file: lib/Foo/Bar/Blah.pm
Foo::Bar::Baz:
file: lib/Foo/Bar/Baz.pm
version: 0.3
(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
provided by this distribution. This information can be (and, in some
cases, is) used by distribution and automation mechanisms like PAUSE,
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.
When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
scanning through the distribution files themselves to figure out
packages and versions. This is a good thing, because it means you can
use the C<provides> field to tell the indexers precisely what you want
indexed about your distribution, rather than relying on them to
essentially guess what you want indexed.
=head2 no_index
Example:
no_index:
file:
- My/Module.pm
directory:
- My/Private
package:
- My::Module::Stuff
namespace:
- My::Module::Stuff
(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
directories, packages, and namespaces that are private
(i.e. implementation artifacts) that are not of interest to searching
and indexing tools. This is useful when no C<provides> field is
present.
For example, L<http://search.cpan.org/> excludes items listed in C<no_index>
when searching for POD, meaning files in these directories will not
converted to HTML and made public - which is useful if you have
example or test PODs that you don't want the search engine to go
through.
=head3 file
(Spec 1.1) [optional] Exclude any listed file(s).
=head3 directory
(Spec 1.1) [optional] Exclude anything below the listed
directory(ies).
[Note: previous editions of the spec had C<dir> instead of
C<directory>, but I think MakeMaker and various users started using
C<directory>, so in deference we switched to that.]
=head3 package
(Spec 1.1) [optional] Exclude the listed package(s).
=head3 namespace
(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
but I<not> the listed namespace(s) its self.
=head2 keywords
Example:
keywords:
- make
- build
- install
(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
this distribution.
=head2 resources
Example:
resources:
license: http://dev.perl.org/licenses/
homepage: http://sourceforge.net/projects/module-build
bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
repository: http://sourceforge.net/cvs/?group_id=45731
MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general
(Spec 1.1) [optional] {map} A mapping of any URL resources related to
this distribution. All-lower-case keys, such as C<homepage>,
C<license>, and C<bugtracker>, are reserved by this specification, as
they have "official" meanings defined here in this specification. If
you'd like to add your own "special" entries (like the "MailingList"
entry above), use at least one upper-case letter.
The current set of official keys is:
=over 2
=item homepage
The official home of this project on the web.
=item license
An URL for an official statement of this distribution's license.
=item bugtracker
An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.
=back
=head2 generated_by
Example:
generated_by: Module::Build version 0.20
(Spec 1.0) [required] {string} Indicates the tool that was used to create this
F<META.yml> file. It's good form to include both the name of the tool
and its version, but this field is essentially opaque, at least for
the moment. If F<META.yml> was generated by hand, it is suggested that
the author be specified here.
[Note: My F<meta_stats.pl> script which I use to gather statistics
regarding F<META.yml> usage prefers the form listed above, i.e. it
splits on /\s+version\s+/ taking the first field as the name of the
tool that generated the file and the second field as version of that
tool. RWS]
=head1 VERSION SPECIFICATIONS
Some fields require a version specification (ex. L</requires>,
L</recommends>, L</build_requires>, etc.) to indicate the particular
versionZ<>(s) of some other module that may be required as a
prerequisite. This section details the version specification formats
that are currently supported.
The simplest format for a version specification is just the version
number itself, e.g. C<2.4>. This means that B<at least> version 2.4
must be present. To indicate that B<any> version of a prerequisite is
okay, even if the prerequisite doesn't define a version at all, use
the version C<0>.
You may also use the operators E<lt> (less than), E<lt>= (less than or
equal), E<gt> (greater than), E<gt>= (greater than or equal), ==
(equal), and != (not equal). For example, the specification C<E<lt>
2.0> means that any version of the prerequisite less than 2.0 is
suitable.
For more complicated situations, version specifications may be AND-ed
together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
2.0> indicates a version that must be B<at least> 1.2, B<less than>
2.0, and B<not equal to> 1.5.
=head1 SEE ALSO
L<CPAN|http://www.cpan.org/>
L<CPAN.pm|CPAN>
L<CPANPLUS>
L<Data::Dumper>
L<ExtUtils::MakeMaker>
L<Module::Build>
L<Module::Install>
L<XML|http://www.w3.org/XML/>
L<YAML|http://www.yaml.org/>
=head1 HISTORY
=over 4
=item March 14, 2003 (Pi day)
=over 2
=item *
Created version 1.0 of this document.
=back
=item May 8, 2003
=over 2
=item *
Added the L</dynamic_config> field, which was missing from the initial
version.
=back
=item November 13, 2003
=over 2
=item *
Added more YAML rationale articles.
=item *
Fixed existing link to YAML discussion thread to point to new
L<http://nntp.x.perl.org/group/> site.
=item *
Added and deprecated the L</private> field.
=item *
Added L</abstract>, C<configure>, C<requires_packages>,
C<requires_os>, C<excludes_os>, and L</no_index> fields.
=item *
Bumped version.
=back
=item November 16, 2003
=over 2
=item *
Added C<generation>, C<authored_by> fields.
=item *
Add alternative proposal to the L</recommends> field.
=item *
Add proposal for a C<requires_build_tools> field.
=back
=item December 9, 2003
=over 2
=item *
Added link to latest version of this specification on CPAN.
=item *
Added section L</"VERSION SPECIFICATIONS">.
=item *
Chang name from Module::Build::META-spec to CPAN::META::Specification.
=item *
Add proposal for C<auto_regenerate> field.
=back
=item December 15, 2003
=over 2
=item *
Add C<index> field as a compliment to L</no_index>
=item *
Add L</keywords> field as a means to aid searching distributions.
=item *
Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.
=back
=item July 26, 2005
=over 2
=item *
Removed a bunch of items (generation, requires_build_tools,
requires_packages, configure, requires_os, excludes_os,
auto_regenerate) that have never actually been supported, but were
more like records of brainstorming.
=item *
Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.
=item *
Added the "==" operator to the list of supported version-checking
operators.
=item *
Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.
=item *
Clarified L</dynamic_config> a bit.
=back
=item August 23, 2005
=over 2
=item *
Removed the name C<CPAN::META::Specification>, since that implies a
module that doesn't actually exist.
=back
=item June 12, 2007
=over 2
=item *
Added L</configure_requires>.
=back
=back

351
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/Merge.pm Normal file
View file

@ -0,0 +1,351 @@
use strict;
use warnings;
package CPAN::Meta::Merge;
our $VERSION = '2.150010';
use Carp qw/croak/;
use Scalar::Util qw/blessed/;
use CPAN::Meta::Converter 2.141170;
sub _is_identical {
my ($left, $right) = @_;
return
(not defined $left and not defined $right)
# if either of these are references, we compare the serialized value
|| (defined $left and defined $right and $left eq $right);
}
sub _identical {
my ($left, $right, $path) = @_;
croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right
unless _is_identical($left, $right);
return $left;
}
sub _merge {
my ($current, $next, $mergers, $path) = @_;
for my $key (keys %{$next}) {
if (not exists $current->{$key}) {
$current->{$key} = $next->{$key};
}
elsif (my $merger = $mergers->{$key}) {
$current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
}
elsif ($merger = $mergers->{':default'}) {
$current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
}
else {
croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
}
}
return $current;
}
sub _uniq {
my %seen = ();
return grep { not $seen{$_}++ } @_;
}
sub _set_addition {
my ($left, $right) = @_;
return [ +_uniq(@{$left}, @{$right}) ];
}
sub _uniq_map {
my ($left, $right, $path) = @_;
for my $key (keys %{$right}) {
if (not exists $left->{$key}) {
$left->{$key} = $right->{$key};
}
# identical strings or references are merged identically
elsif (_is_identical($left->{$key}, $right->{$key})) {
1; # do nothing - keep left
}
elsif (ref $left->{$key} eq 'HASH' and ref $right->{$key} eq 'HASH') {
$left->{$key} = _uniq_map($left->{$key}, $right->{$key}, [ @{$path}, $key ]);
}
else {
croak 'Duplication of element ' . join '.', @{$path}, $key;
}
}
return $left;
}
sub _improvise {
my ($left, $right, $path) = @_;
my ($name) = reverse @{$path};
if ($name =~ /^x_/) {
if (ref($left) eq 'ARRAY') {
return _set_addition($left, $right, $path);
}
elsif (ref($left) eq 'HASH') {
return _uniq_map($left, $right, $path);
}
else {
return _identical($left, $right, $path);
}
}
croak sprintf "Can't merge '%s'", join '.', @{$path};
}
sub _optional_features {
my ($left, $right, $path) = @_;
for my $key (keys %{$right}) {
if (not exists $left->{$key}) {
$left->{$key} = $right->{$key};
}
else {
for my $subkey (keys %{ $right->{$key} }) {
next if $subkey eq 'prereqs';
if (not exists $left->{$key}{$subkey}) {
$left->{$key}{$subkey} = $right->{$key}{$subkey};
}
else {
Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
}
}
require CPAN::Meta::Prereqs;
$left->{$key}{prereqs} =
CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
->as_string_hash;
}
}
return $left;
}
my %default = (
abstract => \&_identical,
author => \&_set_addition,
dynamic_config => sub {
my ($left, $right) = @_;
return $left || $right;
},
generated_by => sub {
my ($left, $right) = @_;
return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
},
license => \&_set_addition,
'meta-spec' => {
version => \&_identical,
url => \&_identical
},
name => \&_identical,
release_status => \&_identical,
version => \&_identical,
description => \&_identical,
keywords => \&_set_addition,
no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
optional_features => \&_optional_features,
prereqs => sub {
require CPAN::Meta::Prereqs;
my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
return $left->with_merged_prereqs($right)->as_string_hash;
},
provides => \&_uniq_map,
resources => {
license => \&_set_addition,
homepage => \&_identical,
bugtracker => \&_uniq_map,
repository => \&_uniq_map,
':default' => \&_improvise,
},
':default' => \&_improvise,
);
sub new {
my ($class, %arguments) = @_;
croak 'default version required' if not exists $arguments{default_version};
my %mapping = %default;
my %extra = %{ $arguments{extra_mappings} || {} };
for my $key (keys %extra) {
if (ref($mapping{$key}) eq 'HASH') {
$mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
}
else {
$mapping{$key} = $extra{$key};
}
}
return bless {
default_version => $arguments{default_version},
mapping => _coerce_mapping(\%mapping, []),
}, $class;
}
my %coderef_for = (
set_addition => \&_set_addition,
uniq_map => \&_uniq_map,
identical => \&_identical,
improvise => \&_improvise,
improvize => \&_improvise, # [sic] for backwards compatibility
);
sub _coerce_mapping {
my ($orig, $map_path) = @_;
my %ret;
for my $key (keys %{$orig}) {
my $value = $orig->{$key};
if (ref($orig->{$key}) eq 'CODE') {
$ret{$key} = $value;
}
elsif (ref($value) eq 'HASH') {
my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
$ret{$key} = sub {
my ($left, $right, $path) = @_;
return _merge($left, $right, $mapping, [ @{$path} ]);
};
}
elsif ($coderef_for{$value}) {
$ret{$key} = $coderef_for{$value};
}
else {
croak "Don't know what to do with " . join '.', @{$map_path}, $key;
}
}
return \%ret;
}
sub merge {
my ($self, @items) = @_;
my $current = {};
for my $next (@items) {
if ( blessed($next) && $next->isa('CPAN::Meta') ) {
$next = $next->as_struct;
}
elsif ( ref($next) eq 'HASH' ) {
my $cmc = CPAN::Meta::Converter->new(
$next, default_version => $self->{default_version}
);
$next = $cmc->upgrade_fragment;
}
else {
croak "Don't know how to merge '$next'";
}
$current = _merge($current, $next, $self->{mapping}, []);
}
return $current;
}
1;
# ABSTRACT: Merging CPAN Meta fragments
# vim: ts=2 sts=2 sw=2 et :
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Merge - Merging CPAN Meta fragments
=head1 VERSION
version 2.150010
=head1 SYNOPSIS
my $merger = CPAN::Meta::Merge->new(default_version => "2");
my $meta = $merger->merge($base, @additional);
=head1 DESCRIPTION
=head1 METHODS
=head2 new
This creates a CPAN::Meta::Merge object. It takes one mandatory named
argument, C<version>, declaring the version of the meta-spec that must be
used for the merge. It can optionally take an C<extra_mappings> argument
that allows one to add additional merging functions for specific elements.
The C<extra_mappings> arguments takes a hash ref with the same type of
structure as described in L<CPAN::Meta::Spec>, except with its values as
one of the L<defined merge strategies|/"MERGE STRATEGIES"> or a code ref
to a merging function.
my $merger = CPAN::Meta::Merge->new(
default_version => '2',
extra_mappings => {
'optional_features' => \&custom_merge_function,
'x_custom' => 'set_addition',
'x_meta_meta' => {
name => 'identical',
tags => 'set_addition',
}
}
);
=head2 merge(@fragments)
Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
(possibly incomplete) hashrefs of metadata.
=head1 MERGE STRATEGIES
C<merge> uses various strategies to combine different elements of the CPAN::Meta objects. The following strategies can be used with the extra_mappings argument of C<new>:
=over
=item identical
The elements must be identical
=item set_addition
The union of two array refs
[ a, b ] U [ a, c] = [ a, b, c ]
=item uniq_map
Key value pairs from the right hash are merged to the left hash. Key
collisions are only allowed if their values are the same. This merge
function will recurse into nested hash refs following the same merge
rules.
=item improvise
This merge strategy will try to pick the appropriate predefined strategy
based on what element type. Array refs will try to use the
C<set_addition> strategy, Hash refs will try to use the C<uniq_map>
strategy, and everything else will try the C<identical> strategy.
=back
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Adam Kennedy <adamk@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

481
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/Prereqs.pm Normal file
View file

@ -0,0 +1,481 @@
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Prereqs;
our $VERSION = '2.150010';
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
#pod distribution or one of its optional features. Each set of prereqs is
#pod organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
#pod
#pod =cut
use Carp qw(confess);
use Scalar::Util qw(blessed);
use CPAN::Meta::Requirements 2.121;
#pod =method new
#pod
#pod my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
#pod
#pod This method returns a new set of Prereqs. The input should look like the
#pod contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
#pod something more or less like this:
#pod
#pod my $prereq = CPAN::Meta::Prereqs->new({
#pod runtime => {
#pod requires => {
#pod 'Some::Module' => '1.234',
#pod ...,
#pod },
#pod ...,
#pod },
#pod ...,
#pod });
#pod
#pod You can also construct an empty set of prereqs with:
#pod
#pod my $prereqs = CPAN::Meta::Prereqs->new;
#pod
#pod This empty set of prereqs is useful for accumulating new prereqs before finally
#pod dumping the whole set into a structure or string.
#pod
#pod =cut
# note we also accept anything matching /\Ax_/i
sub __legal_phases { qw(configure build test runtime develop) }
sub __legal_types { qw(requires recommends suggests conflicts) }
# expect a prereq spec from META.json -- rjbs, 2010-04-11
sub new {
my ($class, $prereq_spec) = @_;
$prereq_spec ||= {};
my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases;
my %is_legal_type = map {; $_ => 1 } $class->__legal_types;
my %guts;
PHASE: for my $phase (keys %$prereq_spec) {
next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase};
my $phase_spec = $prereq_spec->{ $phase };
next PHASE unless keys %$phase_spec;
TYPE: for my $type (keys %$phase_spec) {
next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type};
my $spec = $phase_spec->{ $type };
next TYPE unless keys %$spec;
$guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
$spec
);
}
}
return bless \%guts => $class;
}
#pod =method requirements_for
#pod
#pod my $requirements = $prereqs->requirements_for( $phase, $type );
#pod
#pod This method returns a L<CPAN::Meta::Requirements> object for the given
#pod phase/type combination. If no prerequisites are registered for that
#pod combination, a new CPAN::Meta::Requirements object will be returned, and it may
#pod be added to as needed.
#pod
#pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
#pod be raised.
#pod
#pod =cut
sub requirements_for {
my ($self, $phase, $type) = @_;
confess "requirements_for called without phase" unless defined $phase;
confess "requirements_for called without type" unless defined $type;
unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
confess "requested requirements for unknown phase: $phase";
}
unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
confess "requested requirements for unknown type: $type";
}
my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new);
$req->finalize if $self->is_finalized;
return $req;
}
#pod =method phases
#pod
#pod my @phases = $prereqs->phases;
#pod
#pod This method returns the list of all phases currently populated in the prereqs
#pod object, suitable for iterating.
#pod
#pod =cut
sub phases {
my ($self) = @_;
my %is_legal_phase = map {; $_ => 1 } $self->__legal_phases;
grep { /\Ax_/i or $is_legal_phase{$_} } keys %{ $self->{prereqs} };
}
#pod =method types_in
#pod
#pod my @runtime_types = $prereqs->types_in('runtime');
#pod
#pod This method returns the list of all types currently populated in the prereqs
#pod object for the provided phase, suitable for iterating.
#pod
#pod =cut
sub types_in {
my ($self, $phase) = @_;
return unless $phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases;
my %is_legal_type = map {; $_ => 1 } $self->__legal_types;
grep { /\Ax_/i or $is_legal_type{$_} } keys %{ $self->{prereqs}{$phase} };
}
#pod =method with_merged_prereqs
#pod
#pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
#pod
#pod my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
#pod
#pod This method returns a new CPAN::Meta::Prereqs objects in which all the
#pod other prerequisites given are merged into the current set. This is primarily
#pod provided for combining a distribution's core prereqs with the prereqs of one of
#pod its optional features.
#pod
#pod The new prereqs object has no ties to the originals, and altering it further
#pod will not alter them.
#pod
#pod =cut
sub with_merged_prereqs {
my ($self, $other) = @_;
my @other = blessed($other) ? $other : @$other;
my @prereq_objs = ($self, @other);
my %new_arg;
for my $phase (__uniq(map { $_->phases } @prereq_objs)) {
for my $type (__uniq(map { $_->types_in($phase) } @prereq_objs)) {
my $req = CPAN::Meta::Requirements->new;
for my $prereq (@prereq_objs) {
my $this_req = $prereq->requirements_for($phase, $type);
next unless $this_req->required_modules;
$req->add_requirements($this_req);
}
next unless $req->required_modules;
$new_arg{ $phase }{ $type } = $req->as_string_hash;
}
}
return (ref $self)->new(\%new_arg);
}
#pod =method merged_requirements
#pod
#pod my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
#pod my $new_reqs = $prereqs->merged_requirements( \@phases );
#pod my $new_reqs = $prereqs->merged_requirements();
#pod
#pod This method joins together all requirements across a number of phases
#pod and types into a new L<CPAN::Meta::Requirements> object. If arguments
#pod are omitted, it defaults to "runtime", "build" and "test" for phases
#pod and "requires" and "recommends" for types.
#pod
#pod =cut
sub merged_requirements {
my ($self, $phases, $types) = @_;
$phases = [qw/runtime build test/] unless defined $phases;
$types = [qw/requires recommends/] unless defined $types;
confess "merged_requirements phases argument must be an arrayref"
unless ref $phases eq 'ARRAY';
confess "merged_requirements types argument must be an arrayref"
unless ref $types eq 'ARRAY';
my $req = CPAN::Meta::Requirements->new;
for my $phase ( @$phases ) {
unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
confess "requested requirements for unknown phase: $phase";
}
for my $type ( @$types ) {
unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
confess "requested requirements for unknown type: $type";
}
$req->add_requirements( $self->requirements_for($phase, $type) );
}
}
$req->finalize if $self->is_finalized;
return $req;
}
#pod =method as_string_hash
#pod
#pod This method returns a hashref containing structures suitable for dumping into a
#pod distmeta data structure. It is made up of hashes and strings, only; there will
#pod be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
#pod
#pod =cut
sub as_string_hash {
my ($self) = @_;
my %hash;
for my $phase ($self->phases) {
for my $type ($self->types_in($phase)) {
my $req = $self->requirements_for($phase, $type);
next unless $req->required_modules;
$hash{ $phase }{ $type } = $req->as_string_hash;
}
}
return \%hash;
}
#pod =method is_finalized
#pod
#pod This method returns true if the set of prereqs has been marked "finalized," and
#pod cannot be altered.
#pod
#pod =cut
sub is_finalized { $_[0]{finalized} }
#pod =method finalize
#pod
#pod Calling C<finalize> on a Prereqs object will close it for further modification.
#pod Attempting to make any changes that would actually alter the prereqs will
#pod result in an exception being thrown.
#pod
#pod =cut
sub finalize {
my ($self) = @_;
$self->{finalized} = 1;
for my $phase (keys %{ $self->{prereqs} }) {
$_->finalize for values %{ $self->{prereqs}{$phase} };
}
}
#pod =method clone
#pod
#pod my $cloned_prereqs = $prereqs->clone;
#pod
#pod This method returns a Prereqs object that is identical to the original object,
#pod but can be altered without affecting the original object. Finalization does
#pod not survive cloning, meaning that you may clone a finalized set of prereqs and
#pod then modify the clone.
#pod
#pod =cut
sub clone {
my ($self) = @_;
my $clone = (ref $self)->new( $self->as_string_hash );
}
sub __uniq {
my (%s, $u);
grep { defined($_) ? !$s{$_}++ : !$u++ } @_;
}
1;
# ABSTRACT: a set of distribution prerequisites by phase and type
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type
=head1 VERSION
version 2.150010
=head1 DESCRIPTION
A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
distribution or one of its optional features. Each set of prereqs is
organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
=head1 METHODS
=head2 new
my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
This method returns a new set of Prereqs. The input should look like the
contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
something more or less like this:
my $prereq = CPAN::Meta::Prereqs->new({
runtime => {
requires => {
'Some::Module' => '1.234',
...,
},
...,
},
...,
});
You can also construct an empty set of prereqs with:
my $prereqs = CPAN::Meta::Prereqs->new;
This empty set of prereqs is useful for accumulating new prereqs before finally
dumping the whole set into a structure or string.
=head2 requirements_for
my $requirements = $prereqs->requirements_for( $phase, $type );
This method returns a L<CPAN::Meta::Requirements> object for the given
phase/type combination. If no prerequisites are registered for that
combination, a new CPAN::Meta::Requirements object will be returned, and it may
be added to as needed.
If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
be raised.
=head2 phases
my @phases = $prereqs->phases;
This method returns the list of all phases currently populated in the prereqs
object, suitable for iterating.
=head2 types_in
my @runtime_types = $prereqs->types_in('runtime');
This method returns the list of all types currently populated in the prereqs
object for the provided phase, suitable for iterating.
=head2 with_merged_prereqs
my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
This method returns a new CPAN::Meta::Prereqs objects in which all the
other prerequisites given are merged into the current set. This is primarily
provided for combining a distribution's core prereqs with the prereqs of one of
its optional features.
The new prereqs object has no ties to the originals, and altering it further
will not alter them.
=head2 merged_requirements
my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
my $new_reqs = $prereqs->merged_requirements( \@phases );
my $new_reqs = $prereqs->merged_requirements();
This method joins together all requirements across a number of phases
and types into a new L<CPAN::Meta::Requirements> object. If arguments
are omitted, it defaults to "runtime", "build" and "test" for phases
and "requires" and "recommends" for types.
=head2 as_string_hash
This method returns a hashref containing structures suitable for dumping into a
distmeta data structure. It is made up of hashes and strings, only; there will
be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
=head2 is_finalized
This method returns true if the set of prereqs has been marked "finalized," and
cannot be altered.
=head2 finalize
Calling C<finalize> on a Prereqs object will close it for further modification.
Attempting to make any changes that would actually alter the prereqs will
result in an exception being thrown.
=head2 clone
my $cloned_prereqs = $prereqs->clone;
This method returns a Prereqs object that is identical to the original object,
but can be altered without affecting the original object. Finalization does
not survive cloning, meaning that you may clone a finalized set of prereqs and
then modify the clone.
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Adam Kennedy <adamk@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
# vim: ts=2 sts=2 sw=2 et :

834
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/Requirements.pm Normal file
View file

@ -0,0 +1,834 @@
use v5.10;
use strict;
use warnings;
package CPAN::Meta::Requirements;
# ABSTRACT: a set of version requirements for a CPAN dist
our $VERSION = '2.143';
use CPAN::Meta::Requirements::Range;
#pod =head1 SYNOPSIS
#pod
#pod use CPAN::Meta::Requirements;
#pod
#pod my $build_requires = CPAN::Meta::Requirements->new;
#pod
#pod $build_requires->add_minimum('Library::Foo' => 1.208);
#pod
#pod $build_requires->add_minimum('Library::Foo' => 2.602);
#pod
#pod $build_requires->add_minimum('Module::Bar' => 'v1.2.3');
#pod
#pod $METAyml->{build_requires} = $build_requires->as_string_hash;
#pod
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Requirements object models a set of version constraints like
#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
#pod and as defined by L<CPAN::Meta::Spec>.
#pod It can be built up by adding more and more constraints, and it will reduce them
#pod to the simplest representation.
#pod
#pod Logically impossible constraints will be identified immediately by thrown
#pod exceptions.
#pod
#pod =cut
use Carp ();
#pod =method new
#pod
#pod my $req = CPAN::Meta::Requirements->new;
#pod
#pod This returns a new CPAN::Meta::Requirements object. It takes an optional
#pod hash reference argument. Currently, only one key is supported:
#pod
#pod =for :list
#pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into
#pod a version object, this code reference will be called with the invalid
#pod version string as first argument, and the module name as second
#pod argument. It must return a valid version object.
#pod
#pod All other keys are ignored.
#pod
#pod =cut
my @valid_options = qw( bad_version_hook );
sub new {
my ($class, $options) = @_;
$options ||= {};
Carp::croak "Argument to $class\->new() must be a hash reference"
unless ref $options eq 'HASH';
my %self = map {; $_ => $options->{$_}} @valid_options;
return bless \%self => $class;
}
#pod =method add_minimum
#pod
#pod $req->add_minimum( $module => $version );
#pod
#pod This adds a new minimum version requirement. If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Minimum requirements are inclusive. C<$version> is required, along with any
#pod greater version number.
#pod
#pod This method returns the requirements object.
#pod
#pod =method add_maximum
#pod
#pod $req->add_maximum( $module => $version );
#pod
#pod This adds a new maximum version requirement. If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Maximum requirements are inclusive. No version strictly greater than the given
#pod version is allowed.
#pod
#pod This method returns the requirements object.
#pod
#pod =method add_exclusion
#pod
#pod $req->add_exclusion( $module => $version );
#pod
#pod This adds a new excluded version. For example, you might use these three
#pod method calls:
#pod
#pod $req->add_minimum( $module => '1.00' );
#pod $req->add_maximum( $module => '1.82' );
#pod
#pod $req->add_exclusion( $module => '1.75' );
#pod
#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
#pod 1.75.
#pod
#pod This method returns the requirements object.
#pod
#pod =method exact_version
#pod
#pod $req->exact_version( $module => $version );
#pod
#pod This sets the version required for the given module to I<exactly> the given
#pod version. No other version would be considered acceptable.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
BEGIN {
for my $type (qw(maximum exclusion exact_version)) {
my $method = "with_$type";
my $to_add = $type eq 'exact_version' ? $type : "add_$type";
my $code = sub {
my ($self, $name, $version) = @_;
$self->__modify_entry_for($name, $method, $version);
return $self;
};
no strict 'refs';
*$to_add = $code;
}
}
# add_minimum is optimized compared to generated subs above because
# it is called frequently and with "0" or equivalent input
sub add_minimum {
my ($self, $name, $version) = @_;
# stringify $version so that version->new("0.00")->stringify ne "0"
# which preserves the user's choice of "0.00" as the requirement
if (not defined $version or "$version" eq '0') {
return $self if $self->__entry_for($name);
Carp::croak("can't add new requirements to finalized requirements")
if $self->is_finalized;
$self->{requirements}{ $name } =
CPAN::Meta::Requirements::Range->with_minimum('0', $name);
}
else {
$self->__modify_entry_for($name, 'with_minimum', $version);
}
return $self;
}
#pod =method version_range_for_module
#pod
#pod $req->version_range_for_module( $another_req_object );
#pod
#pod =cut
sub version_range_for_module {
my ($self, $module) = @_;
return $self->{requirements}{$module};
}
#pod =method add_requirements
#pod
#pod $req->add_requirements( $another_req_object );
#pod
#pod This method adds all the requirements in the given CPAN::Meta::Requirements
#pod object to the requirements object on which it was called. If there are any
#pod conflicts, an exception is thrown.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
sub add_requirements {
my ($self, $req) = @_;
for my $module ($req->required_modules) {
my $new_range = $req->version_range_for_module($module);
$self->__modify_entry_for($module, 'with_range', $new_range);
}
return $self;
}
#pod =method accepts_module
#pod
#pod my $bool = $req->accepts_module($module => $version);
#pod
#pod Given an module and version, this method returns true if the version
#pod specification for the module accepts the provided version. In other words,
#pod given:
#pod
#pod Module => '>= 1.00, < 2.00'
#pod
#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
#pod
#pod For modules that do not appear in the requirements, this method will return
#pod true.
#pod
#pod =cut
sub accepts_module {
my ($self, $module, $version) = @_;
return 1 unless my $range = $self->__entry_for($module);
return $range->accepts($version);
}
#pod =method clear_requirement
#pod
#pod $req->clear_requirement( $module );
#pod
#pod This removes the requirement for a given module from the object.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
sub clear_requirement {
my ($self, $module) = @_;
return $self unless $self->__entry_for($module);
Carp::croak("can't clear requirements on finalized requirements")
if $self->is_finalized;
delete $self->{requirements}{ $module };
return $self;
}
#pod =method requirements_for_module
#pod
#pod $req->requirements_for_module( $module );
#pod
#pod This returns a string containing the version requirements for a given module in
#pod the format described in L<CPAN::Meta::Spec> or undef if the given module has no
#pod requirements. This should only be used for informational purposes such as error
#pod messages and should not be interpreted or used for comparison (see
#pod L</accepts_module> instead).
#pod
#pod =cut
sub requirements_for_module {
my ($self, $module) = @_;
my $entry = $self->__entry_for($module);
return unless $entry;
return $entry->as_string;
}
#pod =method structured_requirements_for_module
#pod
#pod $req->structured_requirements_for_module( $module );
#pod
#pod This returns a data structure containing the version requirements for a given
#pod module or undef if the given module has no requirements. This should
#pod not be used for version checks (see L</accepts_module> instead).
#pod
#pod Added in version 2.134.
#pod
#pod =cut
sub structured_requirements_for_module {
my ($self, $module) = @_;
my $entry = $self->__entry_for($module);
return unless $entry;
return $entry->as_struct;
}
#pod =method required_modules
#pod
#pod This method returns a list of all the modules for which requirements have been
#pod specified.
#pod
#pod =cut
sub required_modules { keys %{ $_[0]{requirements} } }
#pod =method clone
#pod
#pod $req->clone;
#pod
#pod This method returns a clone of the invocant. The clone and the original object
#pod can then be changed independent of one another.
#pod
#pod =cut
sub clone {
my ($self) = @_;
my $new = (ref $self)->new;
return $new->add_requirements($self);
}
sub __entry_for { $_[0]{requirements}{ $_[1] } }
sub __modify_entry_for {
my ($self, $name, $method, $version) = @_;
my $fin = $self->is_finalized;
my $old = $self->__entry_for($name);
Carp::croak("can't add new requirements to finalized requirements")
if $fin and not $old;
my $new = ($old || 'CPAN::Meta::Requirements::Range')
->$method($version, $name, $self->{bad_version_hook});
Carp::croak("can't modify finalized requirements")
if $fin and $old->as_string ne $new->as_string;
$self->{requirements}{ $name } = $new;
}
#pod =method is_simple
#pod
#pod This method returns true if and only if all requirements are inclusive minimums
#pod -- that is, if their string expression is just the version number.
#pod
#pod =cut
sub is_simple {
my ($self) = @_;
for my $module ($self->required_modules) {
# XXX: This is a complete hack, but also entirely correct.
return if not $self->__entry_for($module)->is_simple;
}
return 1;
}
#pod =method is_finalized
#pod
#pod This method returns true if the requirements have been finalized by having the
#pod C<finalize> method called on them.
#pod
#pod =cut
sub is_finalized { $_[0]{finalized} }
#pod =method finalize
#pod
#pod This method marks the requirements finalized. Subsequent attempts to change
#pod the requirements will be fatal, I<if> they would result in a change. If they
#pod would not alter the requirements, they have no effect.
#pod
#pod If a finalized set of requirements is cloned, the cloned requirements are not
#pod also finalized.
#pod
#pod =cut
sub finalize { $_[0]{finalized} = 1 }
#pod =method as_string_hash
#pod
#pod This returns a reference to a hash describing the requirements using the
#pod strings in the L<CPAN::Meta::Spec> specification.
#pod
#pod For example after the following program:
#pod
#pod my $req = CPAN::Meta::Requirements->new;
#pod
#pod $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
#pod
#pod $req->add_minimum('Library::Foo' => 1.208);
#pod
#pod $req->add_maximum('Library::Foo' => 2.602);
#pod
#pod $req->add_minimum('Module::Bar' => 'v1.2.3');
#pod
#pod $req->add_exclusion('Module::Bar' => 'v1.2.8');
#pod
#pod $req->exact_version('Xyzzy' => '6.01');
#pod
#pod my $hashref = $req->as_string_hash;
#pod
#pod C<$hashref> would contain:
#pod
#pod {
#pod 'CPAN::Meta::Requirements' => '0.102',
#pod 'Library::Foo' => '>= 1.208, <= 2.206',
#pod 'Module::Bar' => '>= v1.2.3, != v1.2.8',
#pod 'Xyzzy' => '== 6.01',
#pod }
#pod
#pod =cut
sub as_string_hash {
my ($self) = @_;
my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
$self->required_modules;
return \%hash;
}
#pod =method add_string_requirement
#pod
#pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
#pod $req->add_string_requirement('Library::Foo' => v1.208);
#pod
#pod This method parses the passed in string and adds the appropriate requirement
#pod for the given module. A version can be a Perl "v-string". It understands
#pod version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
#pod example:
#pod
#pod =over 4
#pod
#pod =item 1.3
#pod
#pod =item >= 1.3
#pod
#pod =item <= 1.3
#pod
#pod =item == 1.3
#pod
#pod =item != 1.3
#pod
#pod =item > 1.3
#pod
#pod =item < 1.3
#pod
#pod =item >= 1.3, != 1.5, <= 2.0
#pod
#pod A version number without an operator is equivalent to specifying a minimum
#pod (C<E<gt>=>). Extra whitespace is allowed.
#pod
#pod =back
#pod
#pod =cut
sub add_string_requirement {
my ($self, $module, $req) = @_;
$self->__modify_entry_for($module, 'with_string_requirement', $req);
}
#pod =method from_string_hash
#pod
#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
#pod
#pod This is an alternate constructor for a CPAN::Meta::Requirements
#pod object. It takes a hash of module names and version requirement
#pod strings and returns a new CPAN::Meta::Requirements object. As with
#pod add_string_requirement, a version can be a Perl "v-string". Optionally,
#pod you can supply a hash-reference of options, exactly as with the L</new>
#pod method.
#pod
#pod =cut
sub from_string_hash {
my ($class, $hash, $options) = @_;
my $self = $class->new($options);
for my $module (keys %$hash) {
my $req = $hash->{$module};
$self->add_string_requirement($module, $req);
}
return $self;
}
1;
# vim: ts=2 sts=2 sw=2 et:
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Requirements - a set of version requirements for a CPAN dist
=head1 VERSION
version 2.143
=head1 SYNOPSIS
use CPAN::Meta::Requirements;
my $build_requires = CPAN::Meta::Requirements->new;
$build_requires->add_minimum('Library::Foo' => 1.208);
$build_requires->add_minimum('Library::Foo' => 2.602);
$build_requires->add_minimum('Module::Bar' => 'v1.2.3');
$METAyml->{build_requires} = $build_requires->as_string_hash;
=head1 DESCRIPTION
A CPAN::Meta::Requirements object models a set of version constraints like
those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
and as defined by L<CPAN::Meta::Spec>.
It can be built up by adding more and more constraints, and it will reduce them
to the simplest representation.
Logically impossible constraints will be identified immediately by thrown
exceptions.
=head1 METHODS
=head2 new
my $req = CPAN::Meta::Requirements->new;
This returns a new CPAN::Meta::Requirements object. It takes an optional
hash reference argument. Currently, only one key is supported:
=over 4
=item *
C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument. It must return a valid version object.
=back
All other keys are ignored.
=head2 add_minimum
$req->add_minimum( $module => $version );
This adds a new minimum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Minimum requirements are inclusive. C<$version> is required, along with any
greater version number.
This method returns the requirements object.
=head2 add_maximum
$req->add_maximum( $module => $version );
This adds a new maximum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Maximum requirements are inclusive. No version strictly greater than the given
version is allowed.
This method returns the requirements object.
=head2 add_exclusion
$req->add_exclusion( $module => $version );
This adds a new excluded version. For example, you might use these three
method calls:
$req->add_minimum( $module => '1.00' );
$req->add_maximum( $module => '1.82' );
$req->add_exclusion( $module => '1.75' );
Any version between 1.00 and 1.82 inclusive would be acceptable, except for
1.75.
This method returns the requirements object.
=head2 exact_version
$req->exact_version( $module => $version );
This sets the version required for the given module to I<exactly> the given
version. No other version would be considered acceptable.
This method returns the requirements object.
=head2 version_range_for_module
$req->version_range_for_module( $another_req_object );
=head2 add_requirements
$req->add_requirements( $another_req_object );
This method adds all the requirements in the given CPAN::Meta::Requirements
object to the requirements object on which it was called. If there are any
conflicts, an exception is thrown.
This method returns the requirements object.
=head2 accepts_module
my $bool = $req->accepts_module($module => $version);
Given an module and version, this method returns true if the version
specification for the module accepts the provided version. In other words,
given:
Module => '>= 1.00, < 2.00'
We will accept 1.00 and 1.75 but not 0.50 or 2.00.
For modules that do not appear in the requirements, this method will return
true.
=head2 clear_requirement
$req->clear_requirement( $module );
This removes the requirement for a given module from the object.
This method returns the requirements object.
=head2 requirements_for_module
$req->requirements_for_module( $module );
This returns a string containing the version requirements for a given module in
the format described in L<CPAN::Meta::Spec> or undef if the given module has no
requirements. This should only be used for informational purposes such as error
messages and should not be interpreted or used for comparison (see
L</accepts_module> instead).
=head2 structured_requirements_for_module
$req->structured_requirements_for_module( $module );
This returns a data structure containing the version requirements for a given
module or undef if the given module has no requirements. This should
not be used for version checks (see L</accepts_module> instead).
Added in version 2.134.
=head2 required_modules
This method returns a list of all the modules for which requirements have been
specified.
=head2 clone
$req->clone;
This method returns a clone of the invocant. The clone and the original object
can then be changed independent of one another.
=head2 is_simple
This method returns true if and only if all requirements are inclusive minimums
-- that is, if their string expression is just the version number.
=head2 is_finalized
This method returns true if the requirements have been finalized by having the
C<finalize> method called on them.
=head2 finalize
This method marks the requirements finalized. Subsequent attempts to change
the requirements will be fatal, I<if> they would result in a change. If they
would not alter the requirements, they have no effect.
If a finalized set of requirements is cloned, the cloned requirements are not
also finalized.
=head2 as_string_hash
This returns a reference to a hash describing the requirements using the
strings in the L<CPAN::Meta::Spec> specification.
For example after the following program:
my $req = CPAN::Meta::Requirements->new;
$req->add_minimum('CPAN::Meta::Requirements' => 0.102);
$req->add_minimum('Library::Foo' => 1.208);
$req->add_maximum('Library::Foo' => 2.602);
$req->add_minimum('Module::Bar' => 'v1.2.3');
$req->add_exclusion('Module::Bar' => 'v1.2.8');
$req->exact_version('Xyzzy' => '6.01');
my $hashref = $req->as_string_hash;
C<$hashref> would contain:
{
'CPAN::Meta::Requirements' => '0.102',
'Library::Foo' => '>= 1.208, <= 2.206',
'Module::Bar' => '>= v1.2.3, != v1.2.8',
'Xyzzy' => '== 6.01',
}
=head2 add_string_requirement
$req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
$req->add_string_requirement('Library::Foo' => v1.208);
This method parses the passed in string and adds the appropriate requirement
for the given module. A version can be a Perl "v-string". It understands
version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
example:
=over 4
=item 1.3
=item >= 1.3
=item <= 1.3
=item == 1.3
=item != 1.3
=item > 1.3
=item < 1.3
=item >= 1.3, != 1.5, <= 2.0
A version number without an operator is equivalent to specifying a minimum
(C<E<gt>=>). Extra whitespace is allowed.
=back
=head2 from_string_hash
my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
This is an alternate constructor for a CPAN::Meta::Requirements
object. It takes a hash of module names and version requirement
strings and returns a new CPAN::Meta::Requirements object. As with
add_string_requirement, a version can be a Perl "v-string". Optionally,
you can supply a hash-reference of options, exactly as with the L</new>
method.
=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements>
git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 CONTRIBUTORS
=for stopwords Ed J Graham Knop Karen Etheridge Leon Timmermans Paul Howarth Ricardo Signes robario Tatsuhiko Miyagawa
=over 4
=item *
Ed J <mohawk2@users.noreply.github.com>
=item *
Graham Knop <haarg@haarg.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Leon Timmermans <fawaka@gmail.com>
=item *
Paul Howarth <paul@city-fan.org>
=item *
Ricardo Signes <rjbs@semiotic.systems>
=item *
robario <webmaster@robario.com>
=item *
Tatsuhiko Miyagawa <miyagawa@bulknews.net>
=item *
Tatsuhiko Miyagawa <miyagawa@gmail.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

776
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/Requirements/Range.pm Normal file
View file

@ -0,0 +1,776 @@
use v5.10;
use strict;
use warnings;
package CPAN::Meta::Requirements::Range;
# ABSTRACT: a set of version requirements for a CPAN dist
our $VERSION = '2.143';
use Carp ();
#pod =head1 SYNOPSIS
#pod
#pod use CPAN::Meta::Requirements::Range;
#pod
#pod my $range = CPAN::Meta::Requirements::Range->with_minimum(1);
#pod
#pod $range = $range->with_maximum('v2.2');
#pod
#pod my $stringified = $range->as_string;
#pod
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Requirements::Range object models a set of version constraints like
#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
#pod and as defined by L<CPAN::Meta::Spec>;
#pod It can be built up by adding more and more constraints, and it will reduce them
#pod to the simplest representation.
#pod
#pod Logically impossible constraints will be identified immediately by thrown
#pod exceptions.
#pod
#pod =cut
use Carp ();
package
CPAN::Meta::Requirements::Range::_Base;
# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
# before 5.10, we fall back to the EUMM bundled compatibility version module if
# that's the only thing available. This shouldn't ever happen in a normal CPAN
# install of CPAN::Meta::Requirements, as version.pm will be picked up from
# prereqs and be available at runtime.
BEGIN {
eval "use version ()"; ## no critic
if ( my $err = $@ ) {
eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
}
}
# from version::vpp
sub _find_magic_vstring {
my $value = shift;
my $tvalue = '';
require B;
my $sv = B::svref_2object(\$value);
my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
while ( $magic ) {
if ( $magic->TYPE eq 'V' ) {
$tvalue = $magic->PTR;
$tvalue =~ s/^v?(.+)$/v$1/;
last;
}
else {
$magic = $magic->MOREMAGIC;
}
}
return $tvalue;
}
# Perl 5.10.0 didn't have "is_qv" in version.pm
*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
# construct once, reuse many times
my $V0 = version->new(0);
# safe if given an unblessed reference
sub _isa_version {
UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version')
}
sub _version_object {
my ($self, $version, $module, $bad_version_hook) = @_;
my ($vobj, $err);
if (not defined $version or (!ref($version) && $version eq '0')) {
return $V0;
}
elsif ( ref($version) eq 'version' || ( ref($version) && _isa_version($version) ) ) {
$vobj = $version;
}
else {
# hack around version::vpp not handling <3 character vstring literals
if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) {
my $magic = _find_magic_vstring( $version );
$version = $magic if length $magic;
}
# pad to 3 characters if before 5.8.1 and appears to be a v-string
if ( $] < 5.008001 && $version !~ /\A[0-9]/ && substr($version,0,1) ne 'v' && length($version) < 3 ) {
$version .= "\0" x (3 - length($version));
}
eval {
local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
# avoid specific segfault on some older version.pm versions
die "Invalid version: $version" if $version eq 'version';
$vobj = version->new($version);
};
if ( my $err = $@ ) {
$vobj = eval { $bad_version_hook->($version, $module) }
if ref $bad_version_hook eq 'CODE';
unless (eval { $vobj->isa("version") }) {
$err =~ s{ at .* line \d+.*$}{};
die "Can't convert '$version': $err";
}
}
}
# ensure no leading '.'
if ( $vobj =~ m{\A\.} ) {
$vobj = version->new("0$vobj");
}
# ensure normal v-string form
if ( _is_qv($vobj) ) {
$vobj = version->new($vobj->normal);
}
return $vobj;
}
#pod =method with_string_requirement
#pod
#pod $req->with_string_requirement('>= 1.208, <= 2.206');
#pod $req->with_string_requirement(v1.208);
#pod
#pod This method parses the passed in string and adds the appropriate requirement.
#pod A version can be a Perl "v-string". It understands version ranges as described
#pod in the L<CPAN::Meta::Spec/Version Ranges>. For example:
#pod
#pod =over 4
#pod
#pod =item 1.3
#pod
#pod =item >= 1.3
#pod
#pod =item <= 1.3
#pod
#pod =item == 1.3
#pod
#pod =item != 1.3
#pod
#pod =item > 1.3
#pod
#pod =item < 1.3
#pod
#pod =item >= 1.3, != 1.5, <= 2.0
#pod
#pod A version number without an operator is equivalent to specifying a minimum
#pod (C<E<gt>=>). Extra whitespace is allowed.
#pod
#pod =back
#pod
#pod =cut
my %methods_for_op = (
'==' => [ qw(with_exact_version) ],
'!=' => [ qw(with_exclusion) ],
'>=' => [ qw(with_minimum) ],
'<=' => [ qw(with_maximum) ],
'>' => [ qw(with_minimum with_exclusion) ],
'<' => [ qw(with_maximum with_exclusion) ],
);
sub with_string_requirement {
my ($self, $req, $module, $bad_version_hook) = @_;
$module //= 'module';
unless ( defined $req && length $req ) {
$req = 0;
Carp::carp("Undefined requirement for $module treated as '0'");
}
my $magic = _find_magic_vstring( $req );
if (length $magic) {
return $self->with_minimum($magic, $module, $bad_version_hook);
}
my @parts = split qr{\s*,\s*}, $req;
for my $part (@parts) {
my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};
if (! defined $op) {
$self = $self->with_minimum($part, $module, $bad_version_hook);
} else {
Carp::croak("illegal requirement string: $req")
unless my $methods = $methods_for_op{ $op };
$self = $self->$_($ver, $module, $bad_version_hook) for @$methods;
}
}
return $self;
}
#pod =method with_range
#pod
#pod $range->with_range($other_range)
#pod
#pod This creates a new range object that is a merge two others.
#pod
#pod =cut
sub with_range {
my ($self, $other, $module, $bad_version_hook) = @_;
for my $modifier($other->_as_modifiers) {
my ($method, $arg) = @$modifier;
$self = $self->$method($arg, $module, $bad_version_hook);
}
return $self;
}
package CPAN::Meta::Requirements::Range;
our @ISA = 'CPAN::Meta::Requirements::Range::_Base';
sub _clone {
return (bless { } => $_[0]) unless ref $_[0];
my ($s) = @_;
my %guts = (
(exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
(exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),
(exists $s->{exclusions}
? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
: ()),
);
bless \%guts => ref($s);
}
#pod =method with_exact_version
#pod
#pod $range->with_exact_version( $version );
#pod
#pod This sets the version required to I<exactly> the given
#pod version. No other version would be considered acceptable.
#pod
#pod This method returns the version range object.
#pod
#pod =cut
sub with_exact_version {
my ($self, $version, $module, $bad_version_hook) = @_;
$module //= 'module';
$self = $self->_clone;
$version = $self->_version_object($version, $module, $bad_version_hook);
unless ($self->accepts($version)) {
$self->_reject_requirements(
$module,
"exact specification $version outside of range " . $self->as_string
);
}
return CPAN::Meta::Requirements::Range::_Exact->_new($version);
}
sub _simplify {
my ($self, $module) = @_;
if (defined $self->{minimum} and defined $self->{maximum}) {
if ($self->{minimum} == $self->{maximum}) {
if (grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }) {
$self->_reject_requirements(
$module,
"minimum and maximum are both $self->{minimum}, which is excluded",
);
}
return CPAN::Meta::Requirements::Range::_Exact->_new($self->{minimum});
}
if ($self->{minimum} > $self->{maximum}) {
$self->_reject_requirements(
$module,
"minimum $self->{minimum} exceeds maximum $self->{maximum}",
);
}
}
# eliminate irrelevant exclusions
if ($self->{exclusions}) {
my %seen;
@{ $self->{exclusions} } = grep {
(! defined $self->{minimum} or $_ >= $self->{minimum})
and
(! defined $self->{maximum} or $_ <= $self->{maximum})
and
! $seen{$_}++
} @{ $self->{exclusions} };
}
return $self;
}
#pod =method with_minimum
#pod
#pod $range->with_minimum( $version );
#pod
#pod This adds a new minimum version requirement. If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Minimum requirements are inclusive. C<$version> is required, along with any
#pod greater version number.
#pod
#pod This method returns the version range object.
#pod
#pod =cut
sub with_minimum {
my ($self, $minimum, $module, $bad_version_hook) = @_;
$module //= 'module';
$self = $self->_clone;
$minimum = $self->_version_object( $minimum, $module, $bad_version_hook );
if (defined (my $old_min = $self->{minimum})) {
$self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
} else {
$self->{minimum} = $minimum;
}
return $self->_simplify($module);
}
#pod =method with_maximum
#pod
#pod $range->with_maximum( $version );
#pod
#pod This adds a new maximum version requirement. If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Maximum requirements are inclusive. No version strictly greater than the given
#pod version is allowed.
#pod
#pod This method returns the version range object.
#pod
#pod =cut
sub with_maximum {
my ($self, $maximum, $module, $bad_version_hook) = @_;
$module //= 'module';
$self = $self->_clone;
$maximum = $self->_version_object( $maximum, $module, $bad_version_hook );
if (defined (my $old_max = $self->{maximum})) {
$self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
} else {
$self->{maximum} = $maximum;
}
return $self->_simplify($module);
}
#pod =method with_exclusion
#pod
#pod $range->with_exclusion( $version );
#pod
#pod This adds a new excluded version. For example, you might use these three
#pod method calls:
#pod
#pod $range->with_minimum( '1.00' );
#pod $range->with_maximum( '1.82' );
#pod
#pod $range->with_exclusion( '1.75' );
#pod
#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
#pod 1.75.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut
sub with_exclusion {
my ($self, $exclusion, $module, $bad_version_hook) = @_;
$module //= 'module';
$self = $self->_clone;
$exclusion = $self->_version_object( $exclusion, $module, $bad_version_hook );
push @{ $self->{exclusions} ||= [] }, $exclusion;
return $self->_simplify($module);
}
sub _as_modifiers {
my ($self) = @_;
my @mods;
push @mods, [ with_minimum => $self->{minimum} ] if exists $self->{minimum};
push @mods, [ with_maximum => $self->{maximum} ] if exists $self->{maximum};
push @mods, map {; [ with_exclusion => $_ ] } @{$self->{exclusions} || []};
return @mods;
}
#pod =method as_struct
#pod
#pod $range->as_struct( $module );
#pod
#pod This returns a data structure containing the version requirements. This should
#pod not be used for version checks (see L</accepts_module> instead).
#pod
#pod =cut
sub as_struct {
my ($self) = @_;
return 0 if ! keys %$self;
my @exclusions = @{ $self->{exclusions} || [] };
my @parts;
for my $tuple (
[ qw( >= > minimum ) ],
[ qw( <= < maximum ) ],
) {
my ($op, $e_op, $k) = @$tuple;
if (exists $self->{$k}) {
my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
if (@new_exclusions == @exclusions) {
push @parts, [ $op, "$self->{ $k }" ];
} else {
push @parts, [ $e_op, "$self->{ $k }" ];
@exclusions = @new_exclusions;
}
}
}
push @parts, map {; [ "!=", "$_" ] } @exclusions;
return \@parts;
}
#pod =method as_string
#pod
#pod $range->as_string;
#pod
#pod This returns a string containing the version requirements in the format
#pod described in L<CPAN::Meta::Spec>. This should only be used for informational
#pod purposes such as error messages and should not be interpreted or used for
#pod comparison (see L</accepts> instead).
#pod
#pod =cut
sub as_string {
my ($self) = @_;
my @parts = @{ $self->as_struct };
return $parts[0][1] if @parts == 1 and $parts[0][0] eq '>=';
return join q{, }, map {; join q{ }, @$_ } @parts;
}
sub _reject_requirements {
my ($self, $module, $error) = @_;
Carp::croak("illegal requirements for $module: $error")
}
#pod =method accepts
#pod
#pod my $bool = $range->accepts($version);
#pod
#pod Given a version, this method returns true if the version specification
#pod accepts the provided version. In other words, given:
#pod
#pod '>= 1.00, < 2.00'
#pod
#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
#pod
#pod =cut
sub accepts {
my ($self, $version) = @_;
return if defined $self->{minimum} and $version < $self->{minimum};
return if defined $self->{maximum} and $version > $self->{maximum};
return if defined $self->{exclusions}
and grep { $version == $_ } @{ $self->{exclusions} };
return 1;
}
#pod =method is_simple
#pod
#pod This method returns true if and only if the range is an inclusive minimum
#pod -- that is, if their string expression is just the version number.
#pod
#pod =cut
sub is_simple {
my ($self) = @_;
# XXX: This is a complete hack, but also entirely correct.
return if $self->as_string =~ /\s/;
return 1;
}
package
CPAN::Meta::Requirements::Range::_Exact;
our @ISA = 'CPAN::Meta::Requirements::Range::_Base';
our $VERSION = '2.141';
BEGIN {
eval "use version ()"; ## no critic
if ( my $err = $@ ) {
eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
}
}
sub _new { bless { version => $_[1] } => $_[0] }
sub accepts { return $_[0]{version} == $_[1] }
sub _reject_requirements {
my ($self, $module, $error) = @_;
Carp::croak("illegal requirements for $module: $error")
}
sub _clone {
(ref $_[0])->_new( version->new( $_[0]{version} ) )
}
sub with_exact_version {
my ($self, $version, $module, $bad_version_hook) = @_;
$module //= 'module';
$version = $self->_version_object($version, $module, $bad_version_hook);
return $self->_clone if $self->accepts($version);
$self->_reject_requirements(
$module,
"can't be exactly $version when exact requirement is already $self->{version}",
);
}
sub with_minimum {
my ($self, $minimum, $module, $bad_version_hook) = @_;
$module //= 'module';
$minimum = $self->_version_object( $minimum, $module, $bad_version_hook );
return $self->_clone if $self->{version} >= $minimum;
$self->_reject_requirements(
$module,
"minimum $minimum exceeds exact specification $self->{version}",
);
}
sub with_maximum {
my ($self, $maximum, $module, $bad_version_hook) = @_;
$module //= 'module';
$maximum = $self->_version_object( $maximum, $module, $bad_version_hook );
return $self->_clone if $self->{version} <= $maximum;
$self->_reject_requirements(
$module,
"maximum $maximum below exact specification $self->{version}",
);
}
sub with_exclusion {
my ($self, $exclusion, $module, $bad_version_hook) = @_;
$module //= 'module';
$exclusion = $self->_version_object( $exclusion, $module, $bad_version_hook );
return $self->_clone unless $exclusion == $self->{version};
$self->_reject_requirements(
$module,
"tried to exclude $exclusion, which is already exactly specified",
);
}
sub as_string { return "== $_[0]{version}" }
sub as_struct { return [ [ '==', "$_[0]{version}" ] ] }
sub _as_modifiers { return [ with_exact_version => $_[0]{version} ] }
1;
# vim: ts=2 sts=2 sw=2 et:
__END__
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Requirements::Range - a set of version requirements for a CPAN dist
=head1 VERSION
version 2.143
=head1 SYNOPSIS
use CPAN::Meta::Requirements::Range;
my $range = CPAN::Meta::Requirements::Range->with_minimum(1);
$range = $range->with_maximum('v2.2');
my $stringified = $range->as_string;
=head1 DESCRIPTION
A CPAN::Meta::Requirements::Range object models a set of version constraints like
those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
and as defined by L<CPAN::Meta::Spec>;
It can be built up by adding more and more constraints, and it will reduce them
to the simplest representation.
Logically impossible constraints will be identified immediately by thrown
exceptions.
=head1 METHODS
=head2 with_string_requirement
$req->with_string_requirement('>= 1.208, <= 2.206');
$req->with_string_requirement(v1.208);
This method parses the passed in string and adds the appropriate requirement.
A version can be a Perl "v-string". It understands version ranges as described
in the L<CPAN::Meta::Spec/Version Ranges>. For example:
=over 4
=item 1.3
=item >= 1.3
=item <= 1.3
=item == 1.3
=item != 1.3
=item > 1.3
=item < 1.3
=item >= 1.3, != 1.5, <= 2.0
A version number without an operator is equivalent to specifying a minimum
(C<E<gt>=>). Extra whitespace is allowed.
=back
=head2 with_range
$range->with_range($other_range)
This creates a new range object that is a merge two others.
=head2 with_exact_version
$range->with_exact_version( $version );
This sets the version required to I<exactly> the given
version. No other version would be considered acceptable.
This method returns the version range object.
=head2 with_minimum
$range->with_minimum( $version );
This adds a new minimum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Minimum requirements are inclusive. C<$version> is required, along with any
greater version number.
This method returns the version range object.
=head2 with_maximum
$range->with_maximum( $version );
This adds a new maximum version requirement. If the new requirement is
redundant to the existing specification, this has no effect.
Maximum requirements are inclusive. No version strictly greater than the given
version is allowed.
This method returns the version range object.
=head2 with_exclusion
$range->with_exclusion( $version );
This adds a new excluded version. For example, you might use these three
method calls:
$range->with_minimum( '1.00' );
$range->with_maximum( '1.82' );
$range->with_exclusion( '1.75' );
Any version between 1.00 and 1.82 inclusive would be acceptable, except for
1.75.
This method returns the requirements object.
=head2 as_struct
$range->as_struct( $module );
This returns a data structure containing the version requirements. This should
not be used for version checks (see L</accepts_module> instead).
=head2 as_string
$range->as_string;
This returns a string containing the version requirements in the format
described in L<CPAN::Meta::Spec>. This should only be used for informational
purposes such as error messages and should not be interpreted or used for
comparison (see L</accepts> instead).
=head2 accepts
my $bool = $range->accepts($version);
Given a version, this method returns true if the version specification
accepts the provided version. In other words, given:
'>= 1.00, < 2.00'
We will accept 1.00 and 1.75 but not 0.50 or 2.00.
=head2 is_simple
This method returns true if and only if the range is an inclusive minimum
-- that is, if their string expression is just the version number.
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

1244
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/Spec.pm Normal file
View file

File diff suppressed because it is too large Load diff

1214
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/Validator.pm Normal file
View file

File diff suppressed because it is too large Load diff

951
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Meta/YAML.pm Normal file
View file

@ -0,0 +1,951 @@
use 5.008001; # sane UTF-8 support
use strict;
use warnings;
package CPAN::Meta::YAML; # git description: v1.68-2-gcc5324e
# XXX-INGY is 5.8.1 too old/broken for utf8?
# XXX-XDG Lancaster consensus was that it was sufficient until
# proven otherwise
$CPAN::Meta::YAML::VERSION = '0.018';
; # original $VERSION removed by Doppelgaenger
#####################################################################
# The CPAN::Meta::YAML API.
#
# These are the currently documented API functions/methods and
# exports:
use Exporter;
our @ISA = qw{ Exporter };
our @EXPORT = qw{ Load Dump };
our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
###
# Functional/Export API:
sub Dump {
return CPAN::Meta::YAML->new(@_)->_dump_string;
}
# XXX-INGY Returning last document seems a bad behavior.
# XXX-XDG I think first would seem more natural, but I don't know
# that it's worth changing now
sub Load {
my $self = CPAN::Meta::YAML->_load_string(@_);
if ( wantarray ) {
return @$self;
} else {
# To match YAML.pm, return the last document
return $self->[-1];
}
}
# XXX-INGY Do we really need freeze and thaw?
# XXX-XDG I don't think so. I'd support deprecating them.
BEGIN {
*freeze = \&Dump;
*thaw = \&Load;
}
sub DumpFile {
my $file = shift;
return CPAN::Meta::YAML->new(@_)->_dump_file($file);
}
sub LoadFile {
my $file = shift;
my $self = CPAN::Meta::YAML->_load_file($file);
if ( wantarray ) {
return @$self;
} else {
# Return only the last document to match YAML.pm,
return $self->[-1];
}
}
###
# Object Oriented API:
# Create an empty CPAN::Meta::YAML object
# XXX-INGY Why do we use ARRAY object?
# NOTE: I get it now, but I think it's confusing and not needed.
# Will change it on a branch later, for review.
#
# XXX-XDG I don't support changing it yet. It's a very well-documented
# "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested
# we not change it until YAML.pm's own OO API is established so that
# users only have one API change to digest, not two
sub new {
my $class = shift;
bless [ @_ ], $class;
}
# XXX-INGY It probably doesn't matter, and it's probably too late to
# change, but 'read/write' are the wrong names. Read and Write
# are actions that take data from storage to memory
# characters/strings. These take the data to/from storage to native
# Perl objects, which the terms dump and load are meant. As long as
# this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
# to add new {read,write}_* methods to this API.
sub read_string {
my $self = shift;
$self->_load_string(@_);
}
sub write_string {
my $self = shift;
$self->_dump_string(@_);
}
sub read {
my $self = shift;
$self->_load_file(@_);
}
sub write {
my $self = shift;
$self->_dump_file(@_);
}
#####################################################################
# Constants
# Printed form of the unprintable characters in the lowest range
# of ASCII characters, listed by ASCII ordinal position.
my @UNPRINTABLE = qw(
0 x01 x02 x03 x04 x05 x06 a
b t n v f r x0E x0F
x10 x11 x12 x13 x14 x15 x16 x17
x18 x19 x1A e x1C x1D x1E x1F
);
# Printable characters for escapes
my %UNESCAPES = (
0 => "\x00", z => "\x00", N => "\x85",
a => "\x07", b => "\x08", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
# XXX-INGY
# I(ngy) need to decide if these values should be quoted in
# CPAN::Meta::YAML or not. Probably yes.
# These 3 values have special meaning when unquoted and using the
# default YAML schema. They need quotes if they are strings.
my %QUOTE = map { $_ => 1 } qw{
null true false
};
# The commented out form is simpler, but overloaded the Perl regex
# engine due to recursion and backtracking problems on strings
# larger than 32,000ish characters. Keep it for reference purposes.
# qr/\"((?:\\.|[^\"])*)\"/
my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
# unquoted re gets trailing space that needs to be stripped
my $re_capture_unquoted_key = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
my $re_trailing_comment = qr/(?:\s+\#.*)?/;
my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/;
#####################################################################
# CPAN::Meta::YAML Implementation.
#
# These are the private methods that do all the work. They may change
# at any time.
###
# Loader functions:
# Create an object from a file
sub _load_file {
my $class = ref $_[0] ? ref shift : shift;
# Check the file
my $file = shift or $class->_error( 'You did not specify a file name' );
$class->_error( "File '$file' does not exist" )
unless -e $file;
$class->_error( "'$file' is a directory, not a file" )
unless -f _;
$class->_error( "Insufficient permissions to read '$file'" )
unless -r _;
# Open unbuffered with strict UTF-8 decoding and no translation layers
open( my $fh, "<:unix:encoding(UTF-8)", $file );
unless ( $fh ) {
$class->_error("Failed to open file '$file': $!");
}
# flock if available (or warn if not possible for OS-specific reasons)
if ( _can_flock() ) {
flock( $fh, Fcntl::LOCK_SH() )
or warn "Couldn't lock '$file' for reading: $!";
}
# slurp the contents
my $contents = eval {
use warnings FATAL => 'utf8';
local $/;
<$fh>
};
if ( my $err = $@ ) {
$class->_error("Error reading from file '$file': $err");
}
# close the file (release the lock)
unless ( close $fh ) {
$class->_error("Failed to close file '$file': $!");
}
$class->_load_string( $contents );
}
# Create an object from a string
sub _load_string {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless [], $class;
my $string = $_[0];
eval {
unless ( defined $string ) {
die \"Did not provide a string to load";
}
# Check if Perl has it marked as characters, but it's internally
# inconsistent. E.g. maybe latin1 got read on a :utf8 layer
if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
die \<<'...';
Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
...
}
# Ensure Unicode character semantics, even for 0x80-0xff
utf8::upgrade($string);
# Check for and strip any leading UTF-8 BOM
$string =~ s/^\x{FEFF}//;
# Check for some special cases
return $self unless length $string;
# Split the file into lines
my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
split /(?:\015{1,2}\012|\015|\012)/, $string;
# Strip the initial YAML header
@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
# A nibbling parser
my $in_document = 0;
while ( @lines ) {
# Do we have a document header?
if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
# Handle scalar documents
shift @lines;
if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
push @$self,
$self->_load_scalar( "$1", [ undef ], \@lines );
next;
}
$in_document = 1;
}
if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
# A naked document
push @$self, undef;
while ( @lines and $lines[0] !~ /^---/ ) {
shift @lines;
}
$in_document = 0;
# XXX The final '-+$' is to look for -- which ends up being an
# error later.
} elsif ( ! $in_document && @$self ) {
# only the first document can be explicit
die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
} elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
# An array at the root
my $document = [ ];
push @$self, $document;
$self->_load_array( $document, [ 0 ], \@lines );
} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
# A hash at the root
my $document = { };
push @$self, $document;
$self->_load_hash( $document, [ length($1) ], \@lines );
} else {
# Shouldn't get here. @lines have whitespace-only lines
# stripped, and previous match is a line with any
# non-whitespace. So this clause should only be reachable via
# a perlbug where \s is not symmetric with \S
# uncoverable statement
die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
}
}
};
my $err = $@;
if ( ref $err eq 'SCALAR' ) {
$self->_error(${$err});
} elsif ( $err ) {
$self->_error($err);
}
return $self;
}
sub _unquote_single {
my ($self, $string) = @_;
return '' unless length $string;
$string =~ s/\'\'/\'/g;
return $string;
}
sub _unquote_double {
my ($self, $string) = @_;
return '' unless length $string;
$string =~ s/\\"/"/g;
$string =~
s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
{(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
return $string;
}
# Load a YAML scalar string to the actual Perl scalar
sub _load_scalar {
my ($self, $string, $indent, $lines) = @_;
# Trim trailing whitespace
$string =~ s/\s*\z//;
# Explitic null/undef
return undef if $string eq '~';
# Single quote
if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
return $self->_unquote_single($1);
}
# Double quote.
if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
return $self->_unquote_double($1);
}
# Special cases
if ( $string =~ /^[\'\"!&]/ ) {
die \"CPAN::Meta::YAML does not support a feature in line '$string'";
}
return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
# Regular unquoted string
if ( $string !~ /^[>|]/ ) {
die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
$string =~ /:(?:\s|$)/;
$string =~ s/\s+#.*\z//;
return $string;
}
# Error
die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
# Check the indent depth
$lines->[0] =~ /^(\s*)/;
$indent->[-1] = length("$1");
if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
# Pull the lines
my @multiline = ();
while ( @$lines ) {
$lines->[0] =~ /^(\s*)/;
last unless length($1) >= $indent->[-1];
push @multiline, substr(shift(@$lines), length($1));
}
my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
return join( $j, @multiline ) . $t;
}
# Load an array
sub _load_array {
my ($self, $array, $indent, $lines) = @_;
while ( @$lines ) {
# Check for a new document
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
while ( @$lines and $lines->[0] !~ /^---/ ) {
shift @$lines;
}
return 1;
}
# Check the indent level
$lines->[0] =~ /^(\s*)/;
if ( length($1) < $indent->[-1] ) {
return 1;
} elsif ( length($1) > $indent->[-1] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
# Inline nested hash
my $indent2 = length("$1");
$lines->[0] =~ s/-/ /;
push @$array, { };
$self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
shift @$lines;
unless ( @$lines ) {
push @$array, undef;
return 1;
}
if ( $lines->[0] =~ /^(\s*)\-/ ) {
my $indent2 = length("$1");
if ( $indent->[-1] == $indent2 ) {
# Null array entry
push @$array, undef;
} else {
# Naked indenter
push @$array, [ ];
$self->_load_array(
$array->[-1], [ @$indent, $indent2 ], $lines
);
}
} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
push @$array, { };
$self->_load_hash(
$array->[-1], [ @$indent, length("$1") ], $lines
);
} else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
} elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
# Array entry with a value
shift @$lines;
push @$array, $self->_load_scalar(
"$2", [ @$indent, undef ], $lines
);
} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
# This is probably a structure like the following...
# ---
# foo:
# - list
# bar: value
#
# ... so lets return and let the hash parser handle it
return 1;
} else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
}
return 1;
}
# Load a hash
sub _load_hash {
my ($self, $hash, $indent, $lines) = @_;
while ( @$lines ) {
# Check for a new document
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
while ( @$lines and $lines->[0] !~ /^---/ ) {
shift @$lines;
}
return 1;
}
# Check the indent level
$lines->[0] =~ /^(\s*)/;
if ( length($1) < $indent->[-1] ) {
return 1;
} elsif ( length($1) > $indent->[-1] ) {
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
}
# Find the key
my $key;
# Quoted keys
if ( $lines->[0] =~
s/^\s*$re_capture_single_quoted$re_key_value_separator//
) {
$key = $self->_unquote_single($1);
}
elsif ( $lines->[0] =~
s/^\s*$re_capture_double_quoted$re_key_value_separator//
) {
$key = $self->_unquote_double($1);
}
elsif ( $lines->[0] =~
s/^\s*$re_capture_unquoted_key$re_key_value_separator//
) {
$key = $1;
$key =~ s/\s+$//;
}
elsif ( $lines->[0] =~ /^\s*\?/ ) {
die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
}
else {
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
}
if ( exists $hash->{$key} ) {
warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'";
}
# Do we have a value?
if ( length $lines->[0] ) {
# Yes
$hash->{$key} = $self->_load_scalar(
shift(@$lines), [ @$indent, undef ], $lines
);
} else {
# An indent
shift @$lines;
unless ( @$lines ) {
$hash->{$key} = undef;
return 1;
}
if ( $lines->[0] =~ /^(\s*)-/ ) {
$hash->{$key} = [];
$self->_load_array(
$hash->{$key}, [ @$indent, length($1) ], $lines
);
} elsif ( $lines->[0] =~ /^(\s*)./ ) {
my $indent2 = length("$1");
if ( $indent->[-1] >= $indent2 ) {
# Null hash entry
$hash->{$key} = undef;
} else {
$hash->{$key} = {};
$self->_load_hash(
$hash->{$key}, [ @$indent, length($1) ], $lines
);
}
}
}
}
return 1;
}
###
# Dumper functions:
# Save an object to a file
sub _dump_file {
my $self = shift;
require Fcntl;
# Check the file
my $file = shift or $self->_error( 'You did not specify a file name' );
my $fh;
# flock if available (or warn if not possible for OS-specific reasons)
if ( _can_flock() ) {
# Open without truncation (truncate comes after lock)
my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
sysopen( $fh, $file, $flags );
unless ( $fh ) {
$self->_error("Failed to open file '$file' for writing: $!");
}
# Use no translation and strict UTF-8
binmode( $fh, ":raw:encoding(UTF-8)");
flock( $fh, Fcntl::LOCK_EX() )
or warn "Couldn't lock '$file' for reading: $!";
# truncate and spew contents
truncate $fh, 0;
seek $fh, 0, 0;
}
else {
open $fh, ">:unix:encoding(UTF-8)", $file;
}
# serialize and spew to the handle
print {$fh} $self->_dump_string;
# close the file (release the lock)
unless ( close $fh ) {
$self->_error("Failed to close file '$file': $!");
}
return 1;
}
# Save an object to a string
sub _dump_string {
my $self = shift;
return '' unless ref $self && @$self;
# Iterate over the documents
my $indent = 0;
my @lines = ();
eval {
foreach my $cursor ( @$self ) {
push @lines, '---';
# An empty document
if ( ! defined $cursor ) {
# Do nothing
# A scalar document
} elsif ( ! ref $cursor ) {
$lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
# A list at the root
} elsif ( ref $cursor eq 'ARRAY' ) {
unless ( @$cursor ) {
$lines[-1] .= ' []';
next;
}
push @lines, $self->_dump_array( $cursor, $indent, {} );
# A hash at the root
} elsif ( ref $cursor eq 'HASH' ) {
unless ( %$cursor ) {
$lines[-1] .= ' {}';
next;
}
push @lines, $self->_dump_hash( $cursor, $indent, {} );
} else {
die \("Cannot serialize " . ref($cursor));
}
}
};
if ( ref $@ eq 'SCALAR' ) {
$self->_error(${$@});
} elsif ( $@ ) {
$self->_error($@);
}
join '', map { "$_\n" } @lines;
}
sub _has_internal_string_value {
my $value = shift;
my $b_obj = B::svref_2object(\$value); # for round trip problem
return $b_obj->FLAGS & B::SVf_POK();
}
sub _dump_scalar {
my $string = $_[1];
my $is_key = $_[2];
# Check this before checking length or it winds up looking like a string!
my $has_string_flag = _has_internal_string_value($string);
return '~' unless defined $string;
return "''" unless length $string;
if (Scalar::Util::looks_like_number($string)) {
# keys and values that have been used as strings get quoted
if ( $is_key || $has_string_flag ) {
return qq['$string'];
}
else {
return $string;
}
}
if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
$string =~ s/\\/\\\\/g;
$string =~ s/"/\\"/g;
$string =~ s/\n/\\n/g;
$string =~ s/[\x85]/\\N/g;
$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
$string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
return qq|"$string"|;
}
if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
$QUOTE{$string}
) {
return "'$string'";
}
return $string;
}
sub _dump_array {
my ($self, $array, $indent, $seen) = @_;
if ( $seen->{refaddr($array)}++ ) {
die \"CPAN::Meta::YAML does not support circular references";
}
my @lines = ();
foreach my $el ( @$array ) {
my $line = (' ' x $indent) . '-';
my $type = ref $el;
if ( ! $type ) {
$line .= ' ' . $self->_dump_scalar( $el );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
push @lines, $self->_dump_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
}
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
die \"CPAN::Meta::YAML does not support $type references";
}
}
@lines;
}
sub _dump_hash {
my ($self, $hash, $indent, $seen) = @_;
if ( $seen->{refaddr($hash)}++ ) {
die \"CPAN::Meta::YAML does not support circular references";
}
my @lines = ();
foreach my $name ( sort keys %$hash ) {
my $el = $hash->{$name};
my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":";
my $type = ref $el;
if ( ! $type ) {
$line .= ' ' . $self->_dump_scalar( $el );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
push @lines, $self->_dump_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
}
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
die \"CPAN::Meta::YAML does not support $type references";
}
}
@lines;
}
#####################################################################
# DEPRECATED API methods:
# Error storage (DEPRECATED as of 1.57)
our $errstr = '';
# Set error
sub _error {
require Carp;
$errstr = $_[1];
$errstr =~ s/ at \S+ line \d+.*//;
Carp::croak( $errstr );
}
# Retrieve error
my $errstr_warned;
sub errstr {
require Carp;
Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" )
unless $errstr_warned++;
$errstr;
}
#####################################################################
# Helper functions. Possibly not needed.
# Use to detect nv or iv
use B;
# XXX-INGY Is flock CPAN::Meta::YAML's responsibility?
# Some platforms can't flock :-(
# XXX-XDG I think it is. When reading and writing files, we ought
# to be locking whenever possible. People (foolishly) use YAML
# files for things like session storage, which has race issues.
my $HAS_FLOCK;
sub _can_flock {
if ( defined $HAS_FLOCK ) {
return $HAS_FLOCK;
}
else {
require Config;
my $c = \%Config::Config;
$HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
require Fcntl if $HAS_FLOCK;
return $HAS_FLOCK;
}
}
# XXX-INGY Is this core in 5.8.1? Can we remove this?
# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
#####################################################################
# Use Scalar::Util if possible, otherwise emulate it
use Scalar::Util ();
BEGIN {
local $@;
if ( eval { Scalar::Util->VERSION(1.18); } ) {
*refaddr = *Scalar::Util::refaddr;
}
else {
eval <<'END_PERL';
# Scalar::Util failed to load or too old
sub refaddr {
my $pkg = ref($_[0]) or return undef;
if ( !! UNIVERSAL::can($_[0], 'can') ) {
bless $_[0], 'Scalar::Util::Fake';
} else {
$pkg = undef;
}
"$_[0]" =~ /0x(\w+)/;
my $i = do { no warnings 'portable'; hex $1 };
bless $_[0], $pkg if defined $pkg;
$i;
}
END_PERL
}
}
delete $CPAN::Meta::YAML::{refaddr};
1;
# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
# but leaving grey area stuff up here.
#
# I would like to change Read/Write to Load/Dump below without
# changing the actual API names.
#
# It might be better to put Load/Dump API in the SYNOPSIS instead of the
# dubious OO API.
#
# null and bool explanations may be outdated.
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
=head1 VERSION
version 0.018
=head1 SYNOPSIS
use CPAN::Meta::YAML;
# reading a META file
open $fh, "<:utf8", "META.yml";
$yaml_text = do { local $/; <$fh> };
$yaml = CPAN::Meta::YAML->read_string($yaml_text)
or die CPAN::Meta::YAML->errstr;
# finding the metadata
$meta = $yaml->[0];
# writing a META file
$yaml_text = $yaml->write_string
or die CPAN::Meta::YAML->errstr;
open $fh, ">:utf8", "META.yml";
print $fh $yaml_text;
=head1 DESCRIPTION
This module implements a subset of the YAML specification for use in reading
and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>. It should
not be used for any other general YAML parsing or generation task.
NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are
responsible for proper encoding and decoding. In particular, the C<read> and
C<write> methods do B<not> support UTF-8 and should not be used.
=head1 SUPPORT
This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If
there are bugs in how it parses a particular META.yml file, please file
a bug report in the YAML::Tiny bugtracker:
L<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues>
=head1 SEE ALSO
L<YAML::Tiny>, L<YAML>, L<YAML::XS>
=head1 AUTHORS
=over 4
=item *
Adam Kennedy <adamk@cpan.org>
=item *
David Golden <dagolden@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by Adam Kennedy.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
# ABSTRACT: Read and write a subset of YAML for CPAN Meta files

638
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Mirrors.pm Normal file
View file

@ -0,0 +1,638 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
=head1 NAME
CPAN::Mirrors - Get CPAN mirror information and select a fast one
=head1 SYNOPSIS
use CPAN::Mirrors;
my $mirrors = CPAN::Mirrors->new( $mirrored_by_file );
my $seen = {};
my $best_continent = $mirrors->find_best_continents( { seen => $seen } );
my @mirrors = $mirrors->get_mirrors_by_continents( $best_continent );
my $callback = sub {
my( $m ) = @_;
printf "%s = %s\n", $m->hostname, $m->rtt
};
$mirrors->get_mirrors_timings( \@mirrors, $seen, $callback, %args );
@mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;
print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";
=head1 DESCRIPTION
=over
=cut
package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
$VERSION = "2.27";
use Carp;
use FileHandle;
use Fcntl ":flock";
use Net::Ping ();
use CPAN::Version;
=item new( LOCAL_FILE_NAME )
Create a new CPAN::Mirrors object from LOCAL_FILE_NAME. This file
should look like that in http://www.cpan.org/MIRRORED.BY .
=cut
sub new {
my ($class, $file) = @_;
croak "CPAN::Mirrors->new requires a filename" unless defined $file;
croak "The file [$file] was not found" unless -e $file;
my $self = bless {
mirrors => [],
geography => {},
}, $class;
$self->parse_mirrored_by( $file );
return $self;
}
sub parse_mirrored_by {
my ($self, $file) = @_;
my $handle = FileHandle->new;
$handle->open($file)
or croak "Couldn't open $file: $!";
flock $handle, LOCK_SH;
$self->_parse($file,$handle);
flock $handle, LOCK_UN;
$handle->close;
}
=item continents()
Return a list of continents based on those defined in F<MIRRORED.BY>.
=cut
sub continents {
my ($self) = @_;
return sort keys %{$self->{geography} || {}};
}
=item countries( [CONTINENTS] )
Return a list of countries based on those defined in F<MIRRORED.BY>.
It only returns countries for the continents you specify (as defined
in C<continents>). If you don't specify any continents, it returns all
of the countries listed in F<MIRRORED.BY>.
=cut
sub countries {
my ($self, @continents) = @_;
@continents = $self->continents unless @continents;
my @countries;
for my $c (@continents) {
push @countries, sort keys %{ $self->{geography}{$c} || {} };
}
return @countries;
}
=item mirrors( [COUNTRIES] )
Return a list of mirrors based on those defined in F<MIRRORED.BY>.
It only returns mirrors for the countries you specify (as defined
in C<countries>). If you don't specify any countries, it returns all
of the mirrors listed in F<MIRRORED.BY>.
=cut
sub mirrors {
my ($self, @countries) = @_;
return @{$self->{mirrors}} unless @countries;
my %wanted = map { $_ => 1 } @countries;
my @found;
for my $m (@{$self->{mirrors}}) {
push @found, $m if exists $wanted{$m->country};
}
return @found;
}
=item get_mirrors_by_countries( [COUNTRIES] )
A more sensible synonym for mirrors.
=cut
sub get_mirrors_by_countries { &mirrors }
=item get_mirrors_by_continents( [CONTINENTS] )
Return a list of mirrors for all of continents you specify. If you don't
specify any continents, it returns all of the mirrors.
You can specify a single continent or an array reference of continents.
=cut
sub get_mirrors_by_continents {
my ($self, $continents ) = @_;
$continents = [ $continents ] unless ref $continents;
eval {
$self->mirrors( $self->get_countries_by_continents( @$continents ) );
};
}
=item get_countries_by_continents( [CONTINENTS] )
A more sensible synonym for countries.
=cut
sub get_countries_by_continents { &countries }
=item default_mirror
Returns the default mirror, http://www.cpan.org/ . This mirror uses
dynamic DNS to give a close mirror.
=cut
sub default_mirror {
CPAN::Mirrored::By->new({ http => 'http://www.cpan.org/'});
}
=item best_mirrors
C<best_mirrors> checks for the best mirrors based on the list of
continents you pass, or, without that, all continents, as defined
by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of
C<how_many>. In list context, it returns up to C<how_many> mirrors.
In scalar context, it returns the single best mirror.
Arguments
how_many - the number of mirrors to return. Default: 1
callback - a callback for find_best_continents
verbose - true or false on all the whining and moaning. Default: false
continents - an array ref of the continents to check
external_ping - if true, use external ping via Net::Ping::External. Default: false
If you don't specify the continents, C<best_mirrors> calls
C<find_best_continents> to get the list of continents to check.
If you don't have L<Net::Ping> v2.13 or later, needed for timings,
this returns the default mirror.
C<external_ping> should be set and then C<Net::Ping::External> needs
to be installed, if the local network has a transparent proxy.
=cut
sub best_mirrors {
my ($self, %args) = @_;
my $how_many = $args{how_many} || 1;
my $callback = $args{callback};
my $verbose = defined $args{verbose} ? $args{verbose} : 0;
my $continents = $args{continents} || [];
$continents = [$continents] unless ref $continents;
$args{external_ping} = 0 unless defined $args{external_ping};
my $external_ping = $args{external_ping};
# Old Net::Ping did not do timings at all
my $min_version = '2.13';
unless( CPAN::Version->vgt(Net::Ping->VERSION, $min_version) ) {
carp sprintf "Net::Ping version is %s (< %s). Returning %s",
Net::Ping->VERSION, $min_version, $self->default_mirror;
return $self->default_mirror;
}
my $seen = {};
if ( ! @$continents ) {
print "Searching for the best continent ...\n" if $verbose;
my @best_continents = $self->find_best_continents(
seen => $seen,
verbose => $verbose,
callback => $callback,
external_ping => $external_ping,
);
# Only add enough continents to find enough mirrors
my $count = 0;
for my $continent ( @best_continents ) {
push @$continents, $continent;
$count += $self->mirrors( $self->countries($continent) );
last if $count >= $how_many;
}
}
return $self->default_mirror unless @$continents;
print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;
my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );
my $timings = $self->get_mirrors_timings(
$trial_mirrors,
$seen,
$callback,
%args,
);
return $self->default_mirror unless @$timings;
$how_many = @$timings if $how_many > @$timings;
return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0];
}
=item get_n_random_mirrors_by_continents( N, [CONTINENTS] )
Returns up to N random mirrors for the specified continents. Specify the
continents as an array reference.
=cut
sub get_n_random_mirrors_by_continents {
my( $self, $n, $continents ) = @_;
$n ||= 3;
$continents = [ $continents ] unless ref $continents;
if ( $n <= 0 ) {
return wantarray ? () : [];
}
my @long_list = $self->get_mirrors_by_continents( $continents );
if ( $n eq '*' or $n > @long_list ) {
return wantarray ? @long_list : \@long_list;
}
@long_list = map {$_->[0]}
sort {$a->[1] <=> $b->[1]}
map {[$_, rand]} @long_list;
splice @long_list, $n; # truncate
\@long_list;
}
=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK, %ARGS );
Pings the listed mirrors and returns a list of mirrors sorted in
ascending ping times.
C<MIRROR_LIST> is an anonymous array of C<CPAN::Mirrored::By> objects to
ping.
The optional argument C<SEEN> is a hash reference used to track the
mirrors you've already pinged.
The optional argument C<CALLBACK> is a subroutine reference to call
after each ping. It gets the C<CPAN::Mirrored::By> object after each
ping.
=cut
sub get_mirrors_timings {
my( $self, $mirror_list, $seen, $callback, %args ) = @_;
$seen = {} unless defined $seen;
croak "The mirror list argument must be an array reference"
unless ref $mirror_list eq ref [];
croak "The seen argument must be a hash reference"
unless ref $seen eq ref {};
croak "callback must be a subroutine"
if( defined $callback and ref $callback ne ref sub {} );
my $timings = [];
for my $m ( @$mirror_list ) {
$seen->{$m->hostname} = $m;
next unless eval{ $m->http };
if( $self->_try_a_ping( $seen, $m, ) ) {
my $ping = $m->ping(%args);
next unless defined $ping;
# printf "m %s ping %s\n", $m, $ping;
push @$timings, $m;
$callback->( $m ) if $callback;
}
else {
push @$timings, $seen->{$m->hostname}
if defined $seen->{$m->hostname}->rtt;
}
}
my @best = sort {
if( defined $a->rtt and defined $b->rtt ) {
$a->rtt <=> $b->rtt
}
elsif( defined $a->rtt and ! defined $b->rtt ) {
return -1;
}
elsif( ! defined $a->rtt and defined $b->rtt ) {
return 1;
}
elsif( ! defined $a->rtt and ! defined $b->rtt ) {
return 0;
}
} @$timings;
return wantarray ? @best : \@best;
}
=item find_best_continents( HASH_REF );
C<find_best_continents> goes through each continent and pings C<N>
random mirrors on that continent. It then orders the continents by
ascending median ping time. In list context, it returns the ordered list
of continent. In scalar context, it returns the same list as an
anonymous array.
Arguments:
n - the number of hosts to ping for each continent. Default: 3
seen - a hashref of cached hostname ping times
verbose - true or false for noisy or quiet. Default: false
callback - a subroutine to run after each ping.
ping_cache_limit - how long, in seconds, to reuse previous ping times.
Default: 1 day
The C<seen> hash has hostnames as keys and anonymous arrays as values.
The anonymous array is a triplet of a C<CPAN::Mirrored::By> object, a
ping time, and the epoch time for the measurement.
The callback subroutine gets the C<CPAN::Mirrored::By> object, the ping
time, and measurement time (the same things in the C<seen> hashref) as
arguments. C<find_best_continents> doesn't care what the callback does
and ignores the return value.
With a low value for C<N>, a single mirror might skew the results enough
to choose a worse continent. If you have that problem, try a larger
value.
=cut
sub find_best_continents {
my ($self, %args) = @_;
$args{n} ||= 3;
$args{verbose} = 0 unless defined $args{verbose};
$args{seen} = {} unless defined $args{seen};
croak "The seen argument must be a hash reference"
unless ref $args{seen} eq ref {};
$args{ping_cache_limit} = 24 * 60 * 60
unless defined $args{ping_cache_limit};
croak "callback must be a subroutine"
if( defined $args{callback} and ref $args{callback} ne ref sub {} );
my %medians;
CONT: for my $c ( $self->continents ) {
my @mirrors = $self->mirrors( $self->countries($c) );
printf "Testing %s (%d mirrors)\n", $c, scalar @mirrors
if $args{verbose};
next CONT unless @mirrors;
my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};
my @tests;
my $tries = 0;
RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
if( $self->_try_a_ping(
$args{seen}, $m, $args{ping_cache_limit}
)) {
$self->get_mirrors_timings(
[ $m ],
$args{seen},
$args{callback},
%args,
);
next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
}
printf "(%s -> %0.2f ms)",
$m->hostname,
join ' ', 1000 * $args{seen}{$m->hostname}->rtt
if $args{verbose};
push @tests, $args{seen}{$m->hostname}->rtt;
}
my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
$medians{$c} = $median if defined $median;
}
my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians;
if ( $args{verbose} ) {
print "Median result by continent:\n";
if ( @best_cont ) {
for my $c ( @best_cont ) {
printf( " %7.2f ms %s\n", $medians{$c}*1000, $c );
}
} else {
print " **** No results found ****\n"
}
}
return wantarray ? @best_cont : $best_cont[0];
}
# retry if
sub _try_a_ping {
my ($self, $seen, $mirror, $ping_cache_limit ) = @_;
( ! exists $seen->{$mirror->hostname}
or
! defined $seen->{$mirror->hostname}->rtt
or
! defined $ping_cache_limit
or
time - $seen->{$mirror->hostname}->ping_time
> $ping_cache_limit
)
}
sub _get_median_ping_time {
my ($self, $tests, $verbose ) = @_;
my @sorted = sort { $a <=> $b } @$tests;
my $median = do {
if ( @sorted == 0 ) { undef }
elsif ( @sorted == 1 ) { $sorted[0] }
elsif ( @sorted % 2 ) { $sorted[ int(@sorted / 2) ] }
else {
my $mid_high = int(@sorted/2);
($sorted[$mid_high-1] + $sorted[$mid_high])/2;
}
};
if ($verbose){
if ($median) {
printf " => median time: %.2f ms\n", $median * 1000
} else {
printf " => **** no median time ****\n";
}
}
return $median;
}
# Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
sub _parse {
my ($self, $file, $handle) = @_;
my $output = $self->{mirrors};
my $geo = $self->{geography};
local $/ = "\012";
my $line = 0;
my $mirror = undef;
while ( 1 ) {
# Next line
my $string = <$handle>;
last if ! defined $string;
$line = $line + 1;
# Remove the useless lines
chomp( $string );
next if $string =~ /^\s*$/;
next if $string =~ /^\s*#/;
# Hostname or property?
if ( $string =~ /^\s/ ) {
# Property
unless ( $string =~ /^\s+(\w+)\s+=\s+\"(.*)\"$/ ) {
croak("Invalid property on line $line");
}
my ($prop, $value) = ($1,$2);
$mirror ||= {};
if ( $prop eq 'dst_location' ) {
my (@location,$continent,$country);
@location = (split /\s*,\s*/, $value)
and ($continent, $country) = @location[-1,-2];
$continent =~ s/\s\(.*//;
$continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
$geo->{$continent}{$country} = 1 if $continent && $country;
$mirror->{continent} = $continent || "unknown";
$mirror->{country} = $country || "unknown";
}
elsif ( $prop eq 'dst_http' ) {
$mirror->{http} = $value;
}
elsif ( $prop eq 'dst_ftp' ) {
$mirror->{ftp} = $value;
}
elsif ( $prop eq 'dst_rsync' ) {
$mirror->{rsync} = $value;
}
else {
$prop =~ s/^dst_//;
$mirror->{$prop} = $value;
}
} else {
# Hostname
unless ( $string =~ /^([\w\.-]+)\:\s*$/ ) {
croak("Invalid host name on line $line");
}
my $current = $mirror;
$mirror = { hostname => "$1" };
if ( $current ) {
push @$output, CPAN::Mirrored::By->new($current);
}
}
}
if ( $mirror ) {
push @$output, CPAN::Mirrored::By->new($mirror);
}
return;
}
#--------------------------------------------------------------------------#
package CPAN::Mirrored::By;
use strict;
use Net::Ping ();
sub new {
my($self,$arg) = @_;
$arg ||= {};
bless $arg, $self;
}
sub hostname { shift->{hostname} }
sub continent { shift->{continent} }
sub country { shift->{country} }
sub http { shift->{http} || '' }
sub ftp { shift->{ftp} || '' }
sub rsync { shift->{rsync} || '' }
sub rtt { shift->{rtt} }
sub ping_time { shift->{ping_time} }
sub url {
my $self = shift;
return $self->{http} || $self->{ftp};
}
sub ping {
my($self, %args) = @_;
my $external_ping = $args{external_ping};
if ($external_ping) {
eval { require Net::Ping::External }
or die "Net::Ping::External required to use external ping command";
}
my $ping = Net::Ping->new(
$external_ping ? 'external' : $^O eq 'VMS' ? 'icmp' : 'tcp',
1
);
my ($proto) = $self->url =~ m{^([^:]+)};
my $port = $proto eq 'http' ? 80 : 21;
return unless $port;
if ( $ping->can('port_number') ) {
$ping->port_number($port);
}
else {
$ping->{'port_num'} = $port;
}
$ping->hires(1) if $ping->can('hires');
my ($alive,$rtt) = eval { $ping->ping($self->hostname); };
my $verbose = $args{verbose};
if ($verbose && !$alive) {
printf "(host %s not alive)", $self->hostname;
}
$self->{rtt} = $alive ? $rtt : undef;
$self->{ping_time} = time;
$self->rtt;
}
1;
=back
=head1 AUTHOR
Andreas Koenig C<< <andk@cpan.org> >>, David Golden C<< <dagolden@cpan.org> >>,
brian d foy C<< <bdfoy@cpan.org> >>
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=cut

702
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Module.pm Normal file
View file

@ -0,0 +1,702 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Module;
use strict;
@CPAN::Module::ISA = qw(CPAN::InfoObj);
use vars qw(
$VERSION
);
$VERSION = "5.5003";
BEGIN {
# alarm() is not implemented in perl 5.6.x and earlier under Windows
*ALARM_IMPLEMENTED = sub () { $] >= 5.007 || $^O !~ /MSWin/ };
}
# Accessors
#-> sub CPAN::Module::userid
sub userid {
my $self = shift;
my $ro = $self->ro;
return unless $ro;
return $ro->{userid} || $ro->{CPAN_USERID};
}
#-> sub CPAN::Module::description
sub description {
my $self = shift;
my $ro = $self->ro or return "";
$ro->{description}
}
#-> sub CPAN::Module::distribution
sub distribution {
my($self) = @_;
CPAN::Shell->expand("Distribution",$self->cpan_file);
}
#-> sub CPAN::Module::_is_representative_module
sub _is_representative_module {
my($self) = @_;
return $self->{_is_representative_module} if defined $self->{_is_representative_module};
my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
$pm =~ s|.+/||;
$pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id
$pm =~ s|-\d+\.\d+.+$||;
$pm =~ s|-[\d\.]+$||;
$pm =~ s/-/::/g;
$self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
# warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
$self->{_is_representative_module};
}
#-> sub CPAN::Module::undelay
sub undelay {
my $self = shift;
delete $self->{later};
if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
$dist->undelay;
}
}
# mark as dirty/clean
#-> sub CPAN::Module::color_cmd_tmps ;
sub color_cmd_tmps {
my($self) = shift;
my($depth) = shift || 0;
my($color) = shift || 0;
my($ancestors) = shift || [];
# a module needs to recurse to its cpan_file
return if exists $self->{incommandcolor}
&& $color==1
&& $self->{incommandcolor}==$color;
return if $color==0 && !$self->{incommandcolor};
if ($color>=1) {
if ( $self->uptodate ) {
$self->{incommandcolor} = $color;
return;
} elsif (my $have_version = $self->available_version) {
# maybe what we have is good enough
if (@$ancestors) {
my $who_asked_for_me = $ancestors->[-1];
my $obj = CPAN::Shell->expandany($who_asked_for_me);
if (0) {
} elsif ($obj->isa("CPAN::Bundle")) {
# bundles cannot specify a minimum version
return;
} elsif ($obj->isa("CPAN::Distribution")) {
if (my $prereq_pm = $obj->prereq_pm) {
for my $k (keys %$prereq_pm) {
if (my $want_version = $prereq_pm->{$k}{$self->id}) {
if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
$self->{incommandcolor} = $color;
return;
}
}
}
}
}
}
}
} else {
$self->{incommandcolor} = $color; # set me before recursion,
# so we can break it
}
if ($depth>=$CPAN::MAX_RECURSION) {
my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
if ($e->is_resolvable) {
return $self->{incommandcolor}=2;
} else {
die $e;
}
}
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
$dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
}
# unreached code?
# if ($color==0) {
# delete $self->{badtestcnt};
# }
$self->{incommandcolor} = $color;
}
#-> sub CPAN::Module::as_glimpse ;
sub as_glimpse {
my($self) = @_;
my(@m);
my $class = ref($self);
$class =~ s/^CPAN:://;
my $color_on = "";
my $color_off = "";
if (
$CPAN::Shell::COLOR_REGISTERED
&&
$CPAN::META->has_inst("Term::ANSIColor")
&&
$self->description
) {
$color_on = Term::ANSIColor::color("green");
$color_off = Term::ANSIColor::color("reset");
}
my $uptodateness = " ";
unless ($class eq "Bundle") {
my $u = $self->uptodate;
$uptodateness = $u ? "=" : "<" if defined $u;
};
my $id = do {
my $d = $self->distribution;
$d ? $d -> pretty_id : $self->cpan_userid;
};
push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
$class,
$uptodateness,
$color_on,
$self->id,
$color_off,
$id,
);
join "", @m;
}
#-> sub CPAN::Module::dslip_status
sub dslip_status {
my($self) = @_;
my($stat);
# development status
@{$stat->{D}}{qw,i c a b R M S,} = qw,idea
pre-alpha alpha beta released
mature standard,;
# support level
@{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
developer comp.lang.perl.*
none abandoned,;
# language
@{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
# interface
@{$stat->{I}}{qw,f r O p h n,} = qw,functions
references+ties
object-oriented pragma
hybrid none,;
# public licence
@{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
GPL LGPL
BSD Artistic Artistic_2
open-source
distribution_allowed
restricted_distribution
no_licence,;
for my $x (qw(d s l i p)) {
$stat->{$x}{' '} = 'unknown';
$stat->{$x}{'?'} = 'unknown';
}
my $ro = $self->ro;
return +{} unless $ro && $ro->{statd};
return {
D => $ro->{statd},
S => $ro->{stats},
L => $ro->{statl},
I => $ro->{stati},
P => $ro->{statp},
DV => $stat->{D}{$ro->{statd}},
SV => $stat->{S}{$ro->{stats}},
LV => $stat->{L}{$ro->{statl}},
IV => $stat->{I}{$ro->{stati}},
PV => $stat->{P}{$ro->{statp}},
};
}
#-> sub CPAN::Module::as_string ;
sub as_string {
my($self) = @_;
my(@m);
CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
my $class = ref($self);
$class =~ s/^CPAN:://;
local($^W) = 0;
push @m, $class, " id = $self->{ID}\n";
my $sprintf = " %-12s %s\n";
push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
if $self->description;
my $sprintf2 = " %-12s %s (%s)\n";
my($userid);
$userid = $self->userid;
if ( $userid ) {
my $author;
if ($author = CPAN::Shell->expand('Author',$userid)) {
my $email = "";
my $m; # old perls
if ($m = $author->email) {
$email = " <$m>";
}
push @m, sprintf(
$sprintf2,
'CPAN_USERID',
$userid,
$author->fullname . $email
);
}
}
push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
if $self->cpan_version;
if (my $cpan_file = $self->cpan_file) {
push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
my $upload_date = $dist->upload_date;
if ($upload_date) {
push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
}
}
}
my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
my $dslip = $self->dslip_status;
push @m, sprintf(
$sprintf3,
'DSLIP_STATUS',
@{$dslip}{qw(D S L I P DV SV LV IV PV)},
) if $dslip->{D};
my $local_file = $self->inst_file;
unless ($self->{MANPAGE}) {
my $manpage;
if ($local_file) {
$manpage = $self->manpage_headline($local_file);
} else {
# If we have already untarred it, we should look there
my $dist = $CPAN::META->instance('CPAN::Distribution',
$self->cpan_file);
# warn "dist[$dist]";
# mff=manifest file; mfh=manifest handle
my($mff,$mfh);
if (
$dist->{build_dir}
and
(-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
and
$mfh = FileHandle->new($mff)
) {
CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
my $lfre = $self->id; # local file RE
$lfre =~ s/::/./g;
$lfre .= "\\.pm\$";
my($lfl); # local file file
local $/ = "\n";
my(@mflines) = <$mfh>;
for (@mflines) {
s/^\s+//;
s/\s.*//s;
}
while (length($lfre)>5 and !$lfl) {
($lfl) = grep /$lfre/, @mflines;
CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
$lfre =~ s/.+?\.//;
}
$lfl =~ s/\s.*//; # remove comments
$lfl =~ s/\s+//g; # chomp would maybe be too system-specific
my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
# warn "lfl_abs[$lfl_abs]";
if (-f $lfl_abs) {
$manpage = $self->manpage_headline($lfl_abs);
}
}
}
$self->{MANPAGE} = $manpage if $manpage;
}
my($item);
for $item (qw/MANPAGE/) {
push @m, sprintf($sprintf, $item, $self->{$item})
if exists $self->{$item};
}
for $item (qw/CONTAINS/) {
push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
if exists $self->{$item} && @{$self->{$item}};
}
push @m, sprintf($sprintf, 'INST_FILE',
$local_file || "(not installed)");
push @m, sprintf($sprintf, 'INST_VERSION',
$self->inst_version) if $local_file;
if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow
my $available_file = $self->available_file;
if ($available_file && $available_file ne $local_file) {
push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
}
}
join "", @m, "\n";
}
#-> sub CPAN::Module::manpage_headline
sub manpage_headline {
my($self,$local_file) = @_;
my(@local_file) = $local_file;
$local_file =~ s/\.pm(?!\n)\Z/.pod/;
push @local_file, $local_file;
my(@result,$locf);
for $locf (@local_file) {
next unless -f $locf;
my $fh = FileHandle->new($locf)
or $Carp::Frontend->mydie("Couldn't open $locf: $!");
my $inpod = 0;
local $/ = "\n";
while (<$fh>) {
$inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
next unless $inpod;
next if /^=/;
next if /^\s+$/;
chomp;
push @result, $_;
}
close $fh;
last if @result;
}
for (@result) {
s/^\s+//;
s/\s+$//;
}
join " ", @result;
}
#-> sub CPAN::Module::cpan_file ;
# Note: also inherited by CPAN::Bundle
sub cpan_file {
my $self = shift;
# CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
unless ($self->ro) {
CPAN::Index->reload;
}
my $ro = $self->ro;
if ($ro && defined $ro->{CPAN_FILE}) {
return $ro->{CPAN_FILE};
} else {
my $userid = $self->userid;
if ( $userid ) {
if ($CPAN::META->exists("CPAN::Author",$userid)) {
my $author = $CPAN::META->instance("CPAN::Author",
$userid);
my $fullname = $author->fullname;
my $email = $author->email;
unless (defined $fullname && defined $email) {
return sprintf("Contact Author %s",
$userid,
);
}
return "Contact Author $fullname <$email>";
} else {
return "Contact Author $userid (Email address not available)";
}
} else {
return "N/A";
}
}
}
#-> sub CPAN::Module::cpan_version ;
sub cpan_version {
my $self = shift;
my $ro = $self->ro;
unless ($ro) {
# Can happen with modules that are not on CPAN
$ro = {};
}
$ro->{CPAN_VERSION} = 'undef'
unless defined $ro->{CPAN_VERSION};
$ro->{CPAN_VERSION};
}
#-> sub CPAN::Module::force ;
sub force {
my($self) = @_;
$self->{force_update} = 1;
}
#-> sub CPAN::Module::fforce ;
sub fforce {
my($self) = @_;
$self->{force_update} = 2;
}
#-> sub CPAN::Module::notest ;
sub notest {
my($self) = @_;
# $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
$self->{notest}++;
}
#-> sub CPAN::Module::rematein ;
sub rematein {
my($self,$meth) = @_;
$CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
$meth,
$self->id));
my $cpan_file = $self->cpan_file;
if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
$CPAN::Frontend->mywarn(sprintf qq{
The module %s isn\'t available on CPAN.
Either the module has not yet been uploaded to CPAN, or it is
temporary unavailable. Please contact the author to find out
more about the status. Try 'i %s'.
},
$self->id,
$self->id,
);
return;
}
my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
$pack->called_for($self->id);
if (exists $self->{force_update}) {
if ($self->{force_update} == 2) {
$pack->fforce($meth);
} else {
$pack->force($meth);
}
}
$pack->notest($meth) if exists $self->{notest} && $self->{notest};
$pack->{reqtype} ||= "";
CPAN->debug("dist-reqtype[$pack->{reqtype}]".
"self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
if ($pack->{reqtype}) {
if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
$pack->{reqtype} = $self->{reqtype};
if (
exists $pack->{install}
&&
(
UNIVERSAL::can($pack->{install},"failed") ?
$pack->{install}->failed :
$pack->{install} =~ /^NO/
)
) {
delete $pack->{install};
$CPAN::Frontend->mywarn
("Promoting $pack->{ID} from 'build_requires' to 'requires'");
}
}
} else {
$pack->{reqtype} = $self->{reqtype};
}
my $success = eval {
$pack->$meth();
};
my $err = $@;
$pack->unforce if $pack->can("unforce") && exists $self->{force_update};
$pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
delete $self->{force_update};
delete $self->{notest};
if ($err) {
die $err;
}
return $success;
}
#-> sub CPAN::Module::perldoc ;
sub perldoc { shift->rematein('perldoc') }
#-> sub CPAN::Module::readme ;
sub readme { shift->rematein('readme') }
#-> sub CPAN::Module::look ;
sub look { shift->rematein('look') }
#-> sub CPAN::Module::cvs_import ;
sub cvs_import { shift->rematein('cvs_import') }
#-> sub CPAN::Module::get ;
sub get { shift->rematein('get',@_) }
#-> sub CPAN::Module::make ;
sub make { shift->rematein('make') }
#-> sub CPAN::Module::test ;
sub test {
my $self = shift;
# $self->{badtestcnt} ||= 0;
$self->rematein('test',@_);
}
#-> sub CPAN::Module::deprecated_in_core ;
sub deprecated_in_core {
my ($self) = @_;
return unless $CPAN::META->has_inst('Module::CoreList') && Module::CoreList->can('is_deprecated');
return Module::CoreList::is_deprecated($self->{ID});
}
#-> sub CPAN::Module::inst_deprecated;
# Indicates whether the *installed* version of the module is a deprecated *and*
# installed as part of the Perl core library path
sub inst_deprecated {
my ($self) = @_;
my $inst_file = $self->inst_file or return;
return $self->deprecated_in_core && $self->_in_priv_or_arch($inst_file);
}
#-> sub CPAN::Module::uptodate ;
sub uptodate {
my ($self) = @_;
local ($_);
my $inst = $self->inst_version or return 0;
my $cpan = $self->cpan_version;
return 0 if CPAN::Version->vgt($cpan,$inst) || $self->inst_deprecated;
CPAN->debug
(join
("",
"returning uptodate. ",
"cpan[$cpan]inst[$inst]",
)) if $CPAN::DEBUG;
return 1;
}
# returns true if installed in privlib or archlib
sub _in_priv_or_arch {
my($self,$inst_file) = @_;
foreach my $pair (
[qw(sitearchexp archlibexp)],
[qw(sitelibexp privlibexp)]
) {
my ($site, $priv) = @Config::Config{@$pair};
if ($^O eq 'VMS') {
for my $d ($site, $priv) { $d = VMS::Filespec::unixify($d) };
}
s!/*$!!g foreach $site, $priv;
next if $site eq $priv;
if ($priv eq substr($inst_file,0,length($priv))) {
return 1;
}
}
return 0;
}
#-> sub CPAN::Module::install ;
sub install {
my($self) = @_;
my($doit) = 0;
if ($self->uptodate
&&
not exists $self->{force_update}
) {
$CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
$self->id,
$self->inst_version,
));
} else {
$doit = 1;
}
my $ro = $self->ro;
if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
$CPAN::Frontend->mywarn(qq{
\n\n\n ***WARNING***
The module $self->{ID} has no active maintainer (CPAN support level flag 'abandoned').\n\n\n
});
$CPAN::Frontend->mysleep(5);
}
return $doit ? $self->rematein('install') : 1;
}
#-> sub CPAN::Module::clean ;
sub clean { shift->rematein('clean') }
#-> sub CPAN::Module::inst_file ;
sub inst_file {
my($self) = @_;
$self->_file_in_path([@INC]);
}
#-> sub CPAN::Module::available_file ;
sub available_file {
my($self) = @_;
my $sep = $Config::Config{path_sep};
my $perllib = $ENV{PERL5LIB};
$perllib = $ENV{PERLLIB} unless defined $perllib;
my @perllib = split(/$sep/,$perllib) if defined $perllib;
my @cpan_perl5inc;
if ($CPAN::Perl5lib_tempfile) {
my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
@cpan_perl5inc = @{$yaml->[0]{inc} || []};
}
$self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
}
#-> sub CPAN::Module::file_in_path ;
sub _file_in_path {
my($self,$path) = @_;
my($dir,@packpath);
@packpath = split /::/, $self->{ID};
$packpath[-1] .= ".pm";
if (@packpath == 1 && $packpath[0] eq "readline.pm") {
unshift @packpath, "Term", "ReadLine"; # historical reasons
}
foreach $dir (@$path) {
my $pmfile = File::Spec->catfile($dir,@packpath);
if (-f $pmfile) {
return $pmfile;
}
}
return;
}
#-> sub CPAN::Module::xs_file ;
sub xs_file {
my($self) = @_;
my($dir,@packpath);
@packpath = split /::/, $self->{ID};
push @packpath, $packpath[-1];
$packpath[-1] .= "." . $Config::Config{'dlext'};
foreach $dir (@INC) {
my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
if (-f $xsfile) {
return $xsfile;
}
}
return;
}
#-> sub CPAN::Module::inst_version ;
sub inst_version {
my($self) = @_;
my $parsefile = $self->inst_file or return;
my $have = $self->parse_version($parsefile);
$have;
}
#-> sub CPAN::Module::inst_version ;
sub available_version {
my($self) = @_;
my $parsefile = $self->available_file or return;
my $have = $self->parse_version($parsefile);
$have;
}
#-> sub CPAN::Module::parse_version ;
sub parse_version {
my($self,$parsefile) = @_;
if (ALARM_IMPLEMENTED) {
my $timeout = (exists($CPAN::Config{'version_timeout'}))
? $CPAN::Config{'version_timeout'}
: 15;
alarm($timeout);
}
my $have = eval {
local $SIG{ALRM} = sub { die "alarm\n" };
MM->parse_version($parsefile);
};
if ($@) {
$CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
}
alarm(0) if ALARM_IMPLEMENTED;
my $leastsanity = eval { defined $have && length $have; };
$have = "undef" unless $leastsanity;
$have =~ s/^ //; # since the %vd hack these two lines here are needed
$have =~ s/ $//; # trailing whitespace happens all the time
$have = CPAN::Version->readable($have);
$have =~ s/\s*//g; # stringify to float around floating point issues
$have; # no stringify needed, \s* above matches always
}
#-> sub CPAN::Module::reports
sub reports {
my($self) = @_;
$self->distribution->reports;
}
1;

52
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Nox.pm Normal file
View file

@ -0,0 +1,52 @@
package CPAN::Nox;
use strict;
use vars qw($VERSION @EXPORT);
BEGIN{
$CPAN::Suppress_readline=1 unless defined $CPAN::term;
}
use Exporter ();
@CPAN::ISA = ('Exporter');
use CPAN;
$VERSION = "5.5001";
$CPAN::META->has_inst('Digest::MD5','no');
$CPAN::META->has_inst('LWP','no');
$CPAN::META->has_inst('Compress::Zlib','no');
@EXPORT = @CPAN::EXPORT;
*AUTOLOAD = \&CPAN::AUTOLOAD;
1;
__END__
=head1 NAME
CPAN::Nox - Wrapper around CPAN.pm without using any XS module
=head1 SYNOPSIS
Interactive mode:
perl -MCPAN::Nox -e shell;
=head1 DESCRIPTION
This package has the same functionality as CPAN.pm, but tries to
prevent the usage of compiled extensions during its own
execution. Its primary purpose is a rescue in case you upgraded perl
and broke binary compatibility somehow.
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<CPAN>
=cut

145
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Plugin.pm Normal file
View file

@ -0,0 +1,145 @@
package CPAN::Plugin;
use strict;
use warnings;
our $VERSION = '0.97';
require CPAN;
######################################################################
sub new { # ;
my ($class, %params) = @_;
my $self = +{
(ref $class ? (%$class) : ()),
%params,
};
$self = bless $self, ref $class ? ref $class : $class;
unless (ref $class) {
local $_;
no warnings 'once';
$CPAN::META->use_inst ($_) for $self->plugin_requires;
}
$self;
}
######################################################################
sub plugin_requires { # ;
}
######################################################################
sub distribution_object { # ;
my ($self) = @_;
$self->{distribution_object};
}
######################################################################
sub distribution { # ;
my ($self) = @_;
my $distribution = $self->distribution_object->id;
CPAN::Shell->expand("Distribution",$distribution)
or $self->frontend->mydie("Unknowns distribution '$distribution'\n");
}
######################################################################
sub distribution_info { # ;
my ($self) = @_;
CPAN::DistnameInfo->new ($self->distribution->id);
}
######################################################################
sub build_dir { # ;
my ($self) = @_;
my $build_dir = $self->distribution->{build_dir}
or $self->frontend->mydie("Distribution has not been built yet, cannot proceed");
}
######################################################################
sub is_xs { #
my ($self) = @_;
my @xs = glob File::Spec->catfile ($self->build_dir, '*.xs'); # quick try
unless (@xs) {
require ExtUtils::Manifest;
my $manifest_file = File::Spec->catfile ($self->build_dir, "MANIFEST");
my $manifest = ExtUtils::Manifest::maniread($manifest_file);
@xs = grep /\.xs$/, keys %$manifest;
}
scalar @xs;
}
######################################################################
package CPAN::Plugin;
1;
__END__
=pod
=head1 NAME
CPAN::Plugin - Base class for CPAN shell extensions
=head1 SYNOPSIS
package CPAN::Plugin::Flurb;
use parent 'CPAN::Plugin';
sub post_test {
my ($self, $distribution_object) = @_;
$self = $self->new (distribution_object => $distribution_object);
...;
}
=head1 DESCRIPTION
=head2 Alpha Status
The plugin system in the CPAN shell was introduced in version 2.07 and
is still considered experimental.
=head2 How Plugins work?
See L<CPAN/"Plugin support">.
=head1 METHODS
=head2 plugin_requires
returns list of packages given plugin requires for functionality.
This list is evaluated using C<< CPAN->use_inst >> method.
=head2 distribution_object
Get current distribution object.
=head2 distribution
=head2 distribution_info
=head2 build_dir
Simple delegatees for misc parameters derived from distribution
=head2 is_xs
Predicate to detect whether package contains XS.
=head1 AUTHOR
Branislav Zahradnik <barney@cpan.org>
=cut

263
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Plugin/Specfile.pm Normal file
View file

@ -0,0 +1,263 @@
=head1 NAME
CPAN::Plugin::Specfile - Proof of concept implementation of a trivial CPAN::Plugin
=head1 SYNOPSIS
# once in the cpan shell
o conf plugin_list push CPAN::Plugin::Specfile
# make permanent
o conf commit
# any time in the cpan shell to write a spec file
test Acme::Meta
# disable
# if it is the last in plugin_list:
o conf plugin_list pop
# otherwise, determine the index to splice:
o conf plugin_list
# and then use splice, e.g. to splice position 3:
o conf plugin_list splice 3 1
=head1 DESCRIPTION
Implemented as a post-test hook, this plugin writes a specfile after
every successful test run. The content is also written to the
terminal.
As a side effect, the timestamps of the written specfiles reflect the
linear order of all dependencies.
B<WARNING:> This code is just a small demo how to use the plugin
system of the CPAN shell, not a full fledged spec file writer. Do not
expect new features in this plugin.
=head2 OPTIONS
The target directory to store the spec files in can be set using C<dir>
as in
o conf plugin_list push CPAN::Plugin::Specfile=dir,/tmp/specfiles-000042
The default directory for this is the
C<plugins/CPAN::Plugin::Specfile> directory in the I<cpan_home>
directory.
=head1 AUTHOR
Andreas Koenig <andk@cpan.org>, Branislav Zahradnik <barney@cpan.org>
=cut
package CPAN::Plugin::Specfile;
our $VERSION = '0.02';
use File::Path;
use File::Spec;
sub __accessor {
my ($class, $key) = @_;
no strict 'refs';
*{$class . '::' . $key} = sub {
my $self = shift;
if (@_) {
$self->{$key} = shift;
}
return $self->{$key};
};
}
BEGIN { __PACKAGE__->__accessor($_) for qw(dir dir_default) }
sub new {
my($class, @rest) = @_;
my $self = bless {}, $class;
while (my($arg,$val) = splice @rest, 0, 2) {
$self->$arg($val);
}
$self->dir_default(File::Spec->catdir($CPAN::Config->{cpan_home},"plugins",__PACKAGE__));
$self;
}
sub post_test {
my $self = shift;
my $distribution_object = shift;
my $distribution = $distribution_object->pretty_id;
unless ($CPAN::META->has_inst("CPAN::DistnameInfo")){
$CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
}
my $d = CPAN::Shell->expand("Distribution",$distribution)
or $CPAN::Frontend->mydie("Unknowns distribution '$distribution'\n");
my $build_dir = $d->{build_dir} or $CPAN::Frontend->mydie("Distribution has not been built yet, cannot proceed");
my %contains = map {($_ => undef)} $d->containsmods;
my @m;
my $width = 16;
my $header = sub {
my($header,$value) = @_;
push @m, sprintf("%-s:%*s%s\n", $header, $width-length($header), "", $value);
};
my $dni = CPAN::DistnameInfo->new($distribution);
my $dist = $dni->dist;
my $summary = CPAN::Shell->_guess_manpage($d,\%contains,$dist);
$header->("Name", "perl-$dist");
my $version = $dni->version;
$header->("Version", $version);
$header->("Release", "1%{?dist}");
#Summary: Template processing system
#Group: Development/Libraries
#License: GPL+ or Artistic
#URL: http://www.template-toolkit.org/
#Source0: http://search.cpan.org/CPAN/authors/id/A/AB/ABW/Template-Toolkit-%{version}.tar.gz
#Patch0: Template-2.22-SREZIC-01.patch
#BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)
for my $h_tuple
([Summary => $summary],
[Group => "Development/Libraries"],
[License =>],
[URL =>],
[BuildRoot => "%{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)"],
[Requires => "perl(:MODULE_COMPAT_%(eval \"`%{__perl} -V:version`\"; echo \$version))"],
) {
my($h,$v) = @$h_tuple;
$v = "unknown" unless defined $v;
$header->($h, $v);
}
$header->("Source0", sprintf(
"http://search.cpan.org/CPAN/authors/id/%s/%s/%s",
substr($distribution,0,1),
substr($distribution,0,2),
$distribution
));
require POSIX;
my @xs = glob "$build_dir/*.xs"; # quick try
unless (@xs) {
require ExtUtils::Manifest;
my $manifest_file = "$build_dir/MANIFEST";
my $manifest = ExtUtils::Manifest::maniread($manifest_file);
@xs = grep /\.xs$/, keys %$manifest;
}
if (! @xs) {
$header->('BuildArch', 'noarch');
}
for my $k (sort keys %contains) {
my $m = CPAN::Shell->expand("Module",$k);
my $v = $contains{$k} = $m->cpan_version;
my $vspec = $v eq "undef" ? "" : " = $v";
$header->("Provides", "perl($k)$vspec");
}
if (my $prereq_pm = $d->{prereq_pm}) {
my %req;
for my $reqkey (keys %$prereq_pm) {
while (my($k,$v) = each %{$prereq_pm->{$reqkey}}) {
$req{$k} = $v;
}
}
if (-e "$build_dir/Build.PL" && ! exists $req{"Module::Build"}) {
$req{"Module::Build"} = 0;
}
for my $k (sort keys %req) {
next if $k eq "perl";
my $v = $req{$k};
my $vspec = defined $v && length $v && $v > 0 ? " >= $v" : "";
$header->(BuildRequires => "perl($k)$vspec");
next if $k =~ /^(Module::Build)$/; # MB is always only a
# BuildRequires; if we
# turn it into a
# Requires, then we
# would have to make it
# a BuildRequires
# everywhere we depend
# on *one* MB built
# module.
$header->(Requires => "perl($k)$vspec");
}
}
push @m, "\n%define _use_internal_dependency_generator 0
%define __find_requires %{nil}
%define __find_provides %{nil}
";
push @m, "\n%description\n%{summary}.\n";
push @m, "\n%prep\n%setup -q -n $dist-%{version}\n";
if (-e "$build_dir/Build.PL") {
# see http://www.redhat.com/archives/rpm-list/2002-July/msg00110.html about RPM_BUILD_ROOT vs %{buildroot}
push @m, <<'EOF';
%build
%{__perl} Build.PL --installdirs=vendor --libdoc installvendorman3dir
./Build
%install
rm -rf $RPM_BUILD_ROOT
./Build install destdir=$RPM_BUILD_ROOT create_packlist=0
find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null \;
%{_fixperms} $RPM_BUILD_ROOT/*
%check
./Build test
EOF
} elsif (-e "$build_dir/Makefile.PL") {
push @m, <<'EOF';
%build
%{__perl} Makefile.PL INSTALLDIRS=vendor
make %{?_smp_mflags}
%install
rm -rf $RPM_BUILD_ROOT
make pure_install DESTDIR=$RPM_BUILD_ROOT
find $RPM_BUILD_ROOT -type f -name .packlist -exec rm -f {} ';'
find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null ';'
%{_fixperms} $RPM_BUILD_ROOT/*
%check
make test
EOF
} else {
$CPAN::Frontend->mydie("'$distribution' has neither a Build.PL nor a Makefile.PL\n");
}
push @m, "\n%clean\nrm -rf \$RPM_BUILD_ROOT\n";
my $vendorlib = @xs ? "vendorarch" : "vendorlib";
my $date = POSIX::strftime("%a %b %d %Y", gmtime);
my @doc = grep { -e "$build_dir/$_" } qw(README Changes);
my $exe_stanza = "\n";
if (my $exe_files = $d->_exe_files) {
if (@$exe_files) {
$exe_stanza = "%{_mandir}/man1/*.1*\n";
for my $e (@$exe_files) {
unless (CPAN->has_inst("File::Basename")) {
$CPAN::Frontend->mydie("File::Basename not installed, cannot continue");
}
my $basename = File::Basename::basename($e);
$exe_stanza .= "/usr/bin/$basename\n";
}
}
}
push @m, <<EOF;
%files
%defattr(-,root,root,-)
%doc @doc
%{perl_$vendorlib}/*
%{_mandir}/man3/*.3*
$exe_stanza
%changelog
* $date <specfile\@specfile.cpan.org> - $version-1
- autogenerated by CPAN::Plugin::Specfile()
EOF
my $ret = join "", @m;
$CPAN::Frontend->myprint($ret);
my $target_dir = $self->dir || $self->dir_default;
File::Path::mkpath($target_dir);
my $outfile = File::Spec->catfile($target_dir, "perl-$dist.spec");
open my $specout, ">", $outfile
or $CPAN::Frontend->mydie("Could not open >$outfile: $!");
print $specout $ret;
$CPAN::Frontend->myprint("Wrote $outfile");
$ret;
}
1;

29
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Prompt.pm Normal file
View file

@ -0,0 +1,29 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Prompt;
use overload '""' => "as_string";
use vars qw($prompt);
use vars qw(
$VERSION
);
$VERSION = "5.5";
$prompt = "cpan> ";
$CPAN::CurrentCommandId ||= 0;
sub new {
bless {}, shift;
}
sub as_string {
my $word = "cpan";
unless ($CPAN::META->{LOCK}) {
$word = "nolock_cpan";
}
if ($CPAN::Config->{commandnumber_in_prompt}) {
sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
} else {
"$word> ";
}
}
1;

234
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Queue.pm Normal file
View file

@ -0,0 +1,234 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
use strict;
package CPAN::Queue::Item;
# CPAN::Queue::Item::new ;
sub new {
my($class,@attr) = @_;
my $self = bless { @attr }, $class;
return $self;
}
sub as_string {
my($self) = @_;
$self->{qmod};
}
# r => requires, b => build_requires, c => commandline
sub reqtype {
my($self) = @_;
$self->{reqtype};
}
sub optional {
my($self) = @_;
$self->{optional};
}
package CPAN::Queue;
# One use of the queue is to determine if we should or shouldn't
# announce the availability of a new CPAN module
# Now we try to use it for dependency tracking. For that to happen
# we need to draw a dependency tree and do the leaves first. This can
# easily be reached by running CPAN.pm recursively, but we don't want
# to waste memory and run into deep recursion. So what we can do is
# this:
# CPAN::Queue is the package where the queue is maintained. Dependencies
# often have high priority and must be brought to the head of the queue,
# possibly by jumping the queue if they are already there. My first code
# attempt tried to be extremely correct. Whenever a module needed
# immediate treatment, I either unshifted it to the front of the queue,
# or, if it was already in the queue, I spliced and let it bypass the
# others. This became a too correct model that made it impossible to put
# an item more than once into the queue. Why would you need that? Well,
# you need temporary duplicates as the manager of the queue is a loop
# that
#
# (1) looks at the first item in the queue without shifting it off
#
# (2) cares for the item
#
# (3) removes the item from the queue, *even if its agenda failed and
# even if the item isn't the first in the queue anymore* (that way
# protecting against never ending queues)
#
# So if an item has prerequisites, the installation fails now, but we
# want to retry later. That's easy if we have it twice in the queue.
#
# I also expect insane dependency situations where an item gets more
# than two lives in the queue. Simplest example is triggered by 'install
# Foo Foo Foo'. People make this kind of mistakes and I don't want to
# get in the way. I wanted the queue manager to be a dumb servant, not
# one that knows everything.
#
# Who would I tell in this model that the user wants to be asked before
# processing? I can't attach that information to the module object,
# because not modules are installed but distributions. So I'd have to
# tell the distribution object that it should ask the user before
# processing. Where would the question be triggered then? Most probably
# in CPAN::Distribution::rematein.
use vars qw{ @All $VERSION };
$VERSION = "5.5003";
# CPAN::Queue::queue_item ;
sub queue_item {
my($class,@attr) = @_;
my $item = "$class\::Item"->new(@attr);
$class->qpush($item);
return 1;
}
# CPAN::Queue::qpush ;
sub qpush {
my($class,$obj) = @_;
push @All, $obj;
CPAN->debug(sprintf("in new All[%s]",
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
)) if $CPAN::DEBUG;
}
# CPAN::Queue::first ;
sub first {
my $obj = $All[0];
$obj;
}
# CPAN::Queue::delete_first ;
sub delete_first {
my($class,$what) = @_;
my $i;
for my $i (0..$#All) {
if ( $All[$i]->{qmod} eq $what ) {
splice @All, $i, 1;
last;
}
}
CPAN->debug(sprintf("after delete_first mod[%s] All[%s]",
$what,
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
)) if $CPAN::DEBUG;
}
# CPAN::Queue::jumpqueue ;
sub jumpqueue {
my $class = shift;
my @what = @_;
CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @what),
)) if $CPAN::DEBUG;
unless (defined $what[0]{reqtype}) {
# apparently it was not the Shell that sent us this enquiry,
# treat it as commandline
$what[0]{reqtype} = "c";
}
my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b";
WHAT: for my $what_tuple (@what) {
my($qmod,$reqtype,$optional) = @$what_tuple{qw(qmod reqtype optional)};
if ($reqtype eq "r"
&&
$inherit_reqtype eq "b"
) {
$reqtype = "b";
}
my $jumped = 0;
for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
if ($All[$i]{qmod} eq $qmod) {
$jumped++;
}
}
# high jumped values are normal for popular modules when
# dealing with large bundles: XML::Simple,
# namespace::autoclean, UNIVERSAL::require
CPAN->debug("qmod[$qmod]jumped[$jumped]") if $CPAN::DEBUG;
my $obj = "$class\::Item"->new(
qmod => $qmod,
reqtype => $reqtype,
optional => !! $optional,
);
unshift @All, $obj;
}
CPAN->debug(sprintf("after jumpqueue All[%s]",
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
)) if $CPAN::DEBUG;
}
# CPAN::Queue::exists ;
sub exists {
my($self,$what) = @_;
my @all = map { $_->{qmod} } @All;
my $exists = grep { $_->{qmod} eq $what } @All;
# warn "in exists what[$what] all[@all] exists[$exists]";
$exists;
}
# CPAN::Queue::delete ;
sub delete {
my($self,$mod) = @_;
@All = grep { $_->{qmod} ne $mod } @All;
CPAN->debug(sprintf("after delete mod[%s] All[%s]",
$mod,
join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
)) if $CPAN::DEBUG;
}
# CPAN::Queue::nullify_queue ;
sub nullify_queue {
@All = ();
}
# CPAN::Queue::size ;
sub size {
return scalar @All;
}
sub reqtype_of {
my($self,$mod) = @_;
my $best = "";
for my $item (grep { $_->{qmod} eq $mod } @All) {
my $c = $item->{reqtype};
if ($c eq "c") {
$best = $c;
last;
} elsif ($c eq "r") {
$best = $c;
} elsif ($c eq "b") {
if ($best eq "") {
$best = $c;
}
} else {
die "Panic: in reqtype_of: reqtype[$c] seen, should never happen";
}
}
return $best;
}
sub iterator {
my $i = 0;
return sub {
until ($All[$i] || $i > $#All) {
$i++;
}
return if $i > $#All;
return $All[$i++]
};
}
1;
__END__
=head1 NAME
CPAN::Queue - internal queue support for CPAN.pm
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

2072
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Shell.pm Normal file
View file

File diff suppressed because it is too large Load diff

479
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Tarzip.pm Normal file
View file

@ -0,0 +1,479 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN::Tarzip;
use strict;
use vars qw($VERSION @ISA $BUGHUNTING);
use CPAN::Debug;
use File::Basename qw(basename);
$VERSION = "5.5013";
# module is internal to CPAN.pm
@ISA = qw(CPAN::Debug); ## no critic
$BUGHUNTING ||= 0; # released code must have turned off
# it's ok if file doesn't exist, it just matters if it is .gz or .bz2
sub new {
my($class,$file) = @_;
$CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file;
my $me = { FILE => $file };
if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) {
$me->{ISCOMPRESSED} = 1;
} else {
$me->{ISCOMPRESSED} = 0;
}
if (0) {
} elsif ($file =~ /\.(?:bz2|tbz)$/i) {
unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
my $bzip2 = _my_which("bzip2");
if ($bzip2) {
$me->{UNGZIPPRG} = $bzip2;
} else {
$CPAN::Frontend->mydie(qq{
CPAN.pm needs the external program bzip2 in order to handle '$file'.
Please install it now and run 'o conf init bzip2' from the
CPAN shell prompt to register it as external program.
});
}
}
} else {
$me->{UNGZIPPRG} = _my_which("gzip");
}
$me->{TARPRG} = _my_which("tar") || _my_which("gtar");
bless $me, $class;
}
sub _zlib_ok () {
$CPAN::META->has_inst("Compress::Zlib") or return;
Compress::Zlib->can('gzopen');
}
sub _my_which {
my($what) = @_;
if ($CPAN::Config->{$what}) {
return $CPAN::Config->{$what};
}
if ($CPAN::META->has_inst("File::Which")) {
return File::Which::which($what);
}
my @cand = MM->maybe_command($what);
return $cand[0] if @cand;
require File::Spec;
my $component;
PATH_COMPONENT: foreach $component (File::Spec->path()) {
next unless defined($component) && $component;
my($abs) = File::Spec->catfile($component,$what);
if (MM->maybe_command($abs)) {
return $abs;
}
}
return;
}
sub gzip {
my($self,$read) = @_;
my $write = $self->{FILE};
if (_zlib_ok) {
my($buffer,$fhw);
$fhw = FileHandle->new($read)
or $CPAN::Frontend->mydie("Could not open $read: $!");
my $cwd = `pwd`;
my $gz = Compress::Zlib::gzopen($write, "wb")
or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
binmode($fhw);
$gz->gzwrite($buffer)
while read($fhw,$buffer,4096) > 0 ;
$gz->gzclose() ;
$fhw->close;
return 1;
} else {
my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
system(qq{$command -c "$read" > "$write"})==0;
}
}
sub gunzip {
my($self,$write) = @_;
my $read = $self->{FILE};
if (_zlib_ok) {
my($buffer,$fhw);
$fhw = FileHandle->new(">$write")
or $CPAN::Frontend->mydie("Could not open >$write: $!");
my $gz = Compress::Zlib::gzopen($read, "rb")
or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
binmode($fhw);
$fhw->print($buffer)
while $gz->gzread($buffer) > 0 ;
$CPAN::Frontend->mydie("Error reading from $read: $!\n")
if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
$gz->gzclose() ;
$fhw->close;
return 1;
} else {
my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
system(qq{$command -d -c "$read" > "$write"})==0;
}
}
sub gtest {
my($self) = @_;
return $self->{GTEST} if exists $self->{GTEST};
defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
my $read = $self->{FILE};
my $success;
if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
my($buffer,$len);
$len = 0;
my $gz = Compress::Bzip2::bzopen($read, "rb")
or $CPAN::Frontend->mydie(sprintf("Cannot bzopen %s: %s\n",
$read,
$Compress::Bzip2::bzerrno));
while ($gz->bzread($buffer) > 0 ) {
$len += length($buffer);
$buffer = "";
}
my $err = $gz->bzerror;
$success = ! $err || $err == Compress::Bzip2::BZ_STREAM_END();
if ($len == -s $read) {
$success = 0;
CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
}
$gz->gzclose();
CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
} elsif ( $read=~/\.(?:gz|tgz)$/ && _zlib_ok ) {
# After I had reread the documentation in zlib.h, I discovered that
# uncompressed files do not lead to an gzerror (anymore?).
my($buffer,$len);
$len = 0;
my $gz = Compress::Zlib::gzopen($read, "rb")
or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
$read,
$Compress::Zlib::gzerrno));
while ($gz->gzread($buffer) > 0 ) {
$len += length($buffer);
$buffer = "";
}
my $err = $gz->gzerror;
$success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
if ($len == -s $read) {
$success = 0;
CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
}
$gz->gzclose();
CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
} elsif (!$self->{ISCOMPRESSED}) {
$success = 0;
} else {
my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
$success = 0==system(qq{$command -qdt "$read"});
}
return $self->{GTEST} = $success;
}
sub TIEHANDLE {
my($class,$file) = @_;
my $ret;
$class->debug("file[$file]");
my $self = $class->new($file);
if (0) {
} elsif (!$self->gtest) {
my $fh = FileHandle->new($file)
or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
binmode $fh;
$self->{FH} = $fh;
$class->debug("via uncompressed FH");
} elsif ($file =~ /\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
my $gz = Compress::Bzip2::bzopen($file,"rb") or
$CPAN::Frontend->mydie("Could not bzopen $file");
$self->{GZ} = $gz;
$class->debug("via Compress::Bzip2");
} elsif ($file =~/\.(?:gz|tgz)$/ && _zlib_ok) {
my $gz = Compress::Zlib::gzopen($file,"rb") or
$CPAN::Frontend->mydie("Could not gzopen $file");
$self->{GZ} = $gz;
$class->debug("via Compress::Zlib");
} else {
my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
my $pipe = "$gzip -d -c $file |";
my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
binmode $fh;
$self->{FH} = $fh;
$class->debug("via external $gzip");
}
$self;
}
sub READLINE {
my($self) = @_;
if (exists $self->{GZ}) {
my $gz = $self->{GZ};
my($line,$bytesread);
$bytesread = $gz->gzreadline($line);
return undef if $bytesread <= 0;
return $line;
} else {
my $fh = $self->{FH};
return scalar <$fh>;
}
}
sub READ {
my($self,$ref,$length,$offset) = @_;
$CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
if (exists $self->{GZ}) {
my $gz = $self->{GZ};
my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
return $byteread;
} else {
my $fh = $self->{FH};
return read($fh,$$ref,$length);
}
}
sub DESTROY {
my($self) = @_;
if (exists $self->{GZ}) {
my $gz = $self->{GZ};
$gz->gzclose() if defined $gz; # hard to say if it is allowed
# to be undef ever. AK, 2000-09
} else {
my $fh = $self->{FH};
$fh->close if defined $fh;
}
undef $self;
}
sub untar {
my($self) = @_;
my $file = $self->{FILE};
my($prefer) = 0;
my $exttar = $self->{TARPRG} || "";
$exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it
my $extgzip = $self->{UNGZIPPRG} || "";
$extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it
if (0) { # makes changing order easier
} elsif ($BUGHUNTING) {
$prefer=2;
} elsif ($CPAN::Config->{prefer_external_tar}) {
$prefer = 1;
} elsif (
$CPAN::META->has_usable("Archive::Tar")
&&
_zlib_ok ) {
my $prefer_external_tar = $CPAN::Config->{prefer_external_tar};
unless (defined $prefer_external_tar) {
if ($^O =~ /(MSWin32|solaris)/) {
$prefer_external_tar = 0;
} else {
$prefer_external_tar = 1;
}
}
$prefer = $prefer_external_tar ? 1 : 2;
} elsif ($exttar && $extgzip) {
# no modules and not bz2
$prefer = 1;
# but solaris binary tar is a problem
if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) {
$CPAN::Frontend->mywarn(<< 'END_WARN');
WARNING: Many CPAN distributions were archived with GNU tar and some of
them may be incompatible with Solaris tar. We respectfully suggest you
configure CPAN to use a GNU tar instead ("o conf init tar") or install
a recent Archive::Tar instead;
END_WARN
}
} else {
my $foundtar = $exttar ? "'$exttar'" : "nothing";
my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
my $foundAT;
if ($CPAN::META->has_usable("Archive::Tar")) {
$foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
} else {
$foundAT = "nothing";
}
my $foundCZ;
if (_zlib_ok) {
$foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
} elsif ($foundAT) {
$foundCZ = "nothing";
} else {
$foundCZ = "also nothing";
}
$CPAN::Frontend->mydie(qq{
CPAN.pm needs either the external programs tar and gzip -or- both
modules Archive::Tar and Compress::Zlib installed.
For tar I found $foundtar, for gzip $foundzip.
For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;
Can't continue cutting file '$file'.
});
}
my $tar_verb = "v";
if (defined $CPAN::Config->{tar_verbosity}) {
$tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
$CPAN::Config->{tar_verbosity};
}
if ($prefer==1) { # 1 => external gzip+tar
my($system);
my $is_compressed = $self->gtest();
my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
if ($is_compressed) {
my $command = CPAN::HandleConfig->safe_quote($extgzip);
$system = qq{$command -d -c }.
qq{< "$file" | $tarcommand x${tar_verb}f -};
} else {
$system = qq{$tarcommand x${tar_verb}f "$file"};
}
if (system($system) != 0) {
# people find the most curious tar binaries that cannot handle
# pipes
if ($is_compressed) {
(my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
$ungzf = basename $ungzf;
my $ct = CPAN::Tarzip->new($file);
if ($ct->gunzip($ungzf)) {
$CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
} else {
$CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
}
$file = $ungzf;
}
$system = qq{$tarcommand x${tar_verb}f "$file"};
$CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
my $ret = system($system);
if ($ret==0) {
$CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
} else {
if ($? == -1) {
$CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: '%s'\n},
$file, $!);
} elsif ($? & 127) {
$CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child died with signal %d, %s coredump\n},
$file, ($? & 127), ($? & 128) ? 'with' : 'without');
} else {
$CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child exited with value %d\n},
$file, $? >> 8);
}
}
return 1;
} else {
return 1;
}
} elsif ($prefer==2) { # 2 => modules
unless ($CPAN::META->has_usable("Archive::Tar")) {
$CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
}
# Make sure AT does not use uid/gid/permissions in the archive
# This leaves it to the user's umask instead
local $Archive::Tar::CHMOD = 1;
local $Archive::Tar::SAME_PERMISSIONS = 0;
# Make sure AT leaves current user as owner
local $Archive::Tar::CHOWN = 0;
my $tar = Archive::Tar->new($file,1);
my $af; # archive file
my @af;
if ($BUGHUNTING) {
# RCS 1.337 had this code, it turned out unacceptable slow but
# it revealed a bug in Archive::Tar. Code is only here to hunt
# the bug again. It should never be enabled in published code.
# GDGraph3d-0.53 was an interesting case according to Larry
# Virden.
warn(">>>Bughunting code enabled<<< " x 20);
for $af ($tar->list_files) {
if ($af =~ m!^(/|\.\./)!) {
$CPAN::Frontend->mydie("ALERT: Archive contains ".
"illegal member [$af]");
}
$CPAN::Frontend->myprint("$af\n");
$tar->extract($af); # slow but effective for finding the bug
return if $CPAN::Signal;
}
} else {
for $af ($tar->list_files) {
if ($af =~ m!^(/|\.\./)!) {
$CPAN::Frontend->mydie("ALERT: Archive contains ".
"illegal member [$af]");
}
if ($tar_verb eq "v" || $tar_verb eq "vv") {
$CPAN::Frontend->myprint("$af\n");
}
push @af, $af;
return if $CPAN::Signal;
}
$tar->extract(@af) or
$CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
}
Mac::BuildTools::convert_files([$tar->list_files], 1)
if ($^O eq 'MacOS');
return 1;
}
}
sub unzip {
my($self) = @_;
my $file = $self->{FILE};
if ($CPAN::META->has_inst("Archive::Zip")) {
# blueprint of the code from Archive::Zip::Tree::extractTree();
my $zip = Archive::Zip->new();
my $status;
$status = $zip->read($file);
$CPAN::Frontend->mydie("Read of file[$file] failed\n")
if $status != Archive::Zip::AZ_OK();
$CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
my @members = $zip->members();
for my $member ( @members ) {
my $af = $member->fileName();
if ($af =~ m!^(/|\.\./)!) {
$CPAN::Frontend->mydie("ALERT: Archive contains ".
"illegal member [$af]");
}
$status = $member->extractToFileNamed( $af );
$CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
$CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
$status != Archive::Zip::AZ_OK();
return if $CPAN::Signal;
}
return 1;
} elsif ( my $unzip = $CPAN::Config->{unzip} ) {
my @system = ($unzip, $file);
return system(@system) == 0;
}
else {
$CPAN::Frontend->mydie(<<"END");
Can't unzip '$file':
You have not configured an 'unzip' program and do not have Archive::Zip
installed. Please either install Archive::Zip or else configure 'unzip'
by running the command 'o conf init unzip' from the CPAN shell prompt.
END
}
}
1;
__END__
=head1 NAME
CPAN::Tarzip - internal handling of tar archives for CPAN.pm
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

31
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/URL.pm Normal file
View file

@ -0,0 +1,31 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::URL;
use overload '""' => "as_string", fallback => 1;
# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
# planned are things like age or quality
use vars qw(
$VERSION
);
$VERSION = "5.5";
sub new {
my($class,%args) = @_;
bless {
%args
}, $class;
}
sub as_string {
my($self) = @_;
$self->text;
}
sub text {
my($self,$set) = @_;
if (defined $set) {
$self->{TEXT} = $set;
}
$self->{TEXT};
}
1;

177
Agent-Windows/OGP64/usr/share/perl5/5.40/CPAN/Version.pm Normal file
View file

@ -0,0 +1,177 @@
package CPAN::Version;
use strict;
use vars qw($VERSION);
$VERSION = "5.5003";
# CPAN::Version::vcmp courtesy Jost Krieger
sub vcmp {
my($self,$l,$r) = @_;
local($^W) = 0;
CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
# treat undef as zero
$l = 0 if $l eq 'undef';
$r = 0 if $r eq 'undef';
return 0 if $l eq $r; # short circuit for quicker success
for ($l,$r) {
s/_//g;
}
CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
for ($l,$r) {
next unless tr/.// > 1 || /^v/;
s/^v?/v/;
1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
}
CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
if ($l=~/^v/ <=> $r=~/^v/) {
for ($l,$r) {
next if /^v/;
$_ = $self->float2vv($_);
}
}
CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
my $lvstring = "v0";
my $rvstring = "v0";
if ($] >= 5.006
&& $l =~ /^v/
&& $r =~ /^v/) {
$lvstring = $self->vstring($l);
$rvstring = $self->vstring($r);
CPAN->debug(sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring) if $CPAN::DEBUG;
}
return (
($l ne "undef") <=> ($r ne "undef")
||
$lvstring cmp $rvstring
||
$l <=> $r
||
$l cmp $r
);
}
sub vgt {
my($self,$l,$r) = @_;
$self->vcmp($l,$r) > 0;
}
sub vlt {
my($self,$l,$r) = @_;
$self->vcmp($l,$r) < 0;
}
sub vge {
my($self,$l,$r) = @_;
$self->vcmp($l,$r) >= 0;
}
sub vle {
my($self,$l,$r) = @_;
$self->vcmp($l,$r) <= 0;
}
sub vstring {
my($self,$n) = @_;
$n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
pack "U*", split /\./, $n;
}
# vv => visible vstring
sub float2vv {
my($self,$n) = @_;
my($rev) = int($n);
$rev ||= 0;
my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
# architecture influence
$mantissa ||= 0;
$mantissa .= "0" while length($mantissa)%3;
my $ret = "v" . $rev;
while ($mantissa) {
$mantissa =~ s/(\d{1,3})// or
die "Panic: length>0 but not a digit? mantissa[$mantissa]";
$ret .= ".".int($1);
}
# warn "n[$n]ret[$ret]";
$ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
$ret;
}
sub readable {
my($self,$n) = @_;
$n =~ /^([\w\-\+\.]+)/;
return $1 if defined $1 && length($1)>0;
# if the first user reaches version v43, he will be treated as "+".
# We'll have to decide about a new rule here then, depending on what
# will be the prevailing versioning behavior then.
if ($] < 5.006) { # or whenever v-strings were introduced
# we get them wrong anyway, whatever we do, because 5.005 will
# have already interpreted 0.2.4 to be "0.24". So even if he
# indexer sends us something like "v0.2.4" we compare wrongly.
# And if they say v1.2, then the old perl takes it as "v12"
if (defined $CPAN::Frontend) {
$CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
} else {
warn("Suspicious version string seen [$n]\n");
}
return $n;
}
my $better = sprintf "v%vd", $n;
CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
return $better;
}
1;
__END__
=head1 NAME
CPAN::Version - utility functions to compare CPAN versions
=head1 SYNOPSIS
use CPAN::Version;
CPAN::Version->vgt("1.1","1.1.1"); # 1 bc. 1.1 > 1.001001
CPAN::Version->vlt("1.1","1.1"); # 0 bc. 1.1 not < 1.1
CPAN::Version->vcmp("1.1","1.1.1"); # 1 bc. first is larger
CPAN::Version->vcmp("1.1.1","1.1"); # -1 bc. first is smaller
CPAN::Version->readable(v1.2.3); # "v1.2.3"
CPAN::Version->vstring("v1.2.3"); # v1.2.3
CPAN::Version->float2vv(1.002003); # "v1.2.3"
=head1 DESCRIPTION
This module mediates between some version that perl sees in a package
and the version that is published by the CPAN indexer.
It's only written as a helper module for both CPAN.pm and CPANPLUS.pm.
As it stands it predates version.pm but has the same goal: make
version strings visible and comparable.
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# End:

1072
Agent-Windows/OGP64/usr/share/perl5/5.40/Carp.pm Normal file
View file

File diff suppressed because it is too large Load diff

21
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/Compress/Zlib.pm Normal file
View file

File diff suppressed because it is too large Load diff

64
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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;
}

167
Agent-Windows/OGP64/usr/share/perl5/5.40/Encode/PerlIO.pod Normal file
View file

@ -0,0 +1,167 @@
=head1 NAME
Encode::PerlIO -- a detailed document on Encode and PerlIO
=head1 Overview
It is very common to want to do encoding transformations when
reading or writing files, network connections, pipes etc.
If Perl is configured to use the new 'perlio' IO system then
C<Encode> provides a "layer" (see L<PerlIO>) which can transform
data as it is read or written.
Here is how the blind poet would modernise the encoding:
use Encode;
open(my $iliad,'<:encoding(iso-8859-7)','iliad.greek');
open(my $utf8,'>:utf8','iliad.utf8');
my @epic = <$iliad>;
print $utf8 @epic;
close($utf8);
close($illiad);
In addition, the new IO system can also be configured to read/write
UTF-8 encoded characters (as noted above, this is efficient):
open(my $fh,'>:utf8','anything');
print $fh "Any \x{0021} string \N{SMILEY FACE}\n";
Either of the above forms of "layer" specifications can be made the default
for a lexical scope with the C<use open ...> pragma. See L<open>.
Once a handle is open, its layers can be altered using C<binmode>.
Without any such configuration, or if Perl itself is built using the
system's own IO, then write operations assume that the file handle
accepts only I<bytes> and will C<die> if a character larger than 255 is
written to the handle. When reading, each octet from the handle becomes
a byte-in-a-character. Note that this default is the same behaviour
as bytes-only languages (including Perl before v5.6) would have,
and is sufficient to handle native 8-bit encodings e.g. iso-8859-1,
EBCDIC etc. and any legacy mechanisms for handling other encodings
and binary data.
In other cases, it is the program's responsibility to transform
characters into bytes using the API above before doing writes, and to
transform the bytes read from a handle into characters before doing
"character operations" (e.g. C<lc>, C</\W+/>, ...).
You can also use PerlIO to convert larger amounts of data you don't
want to bring into memory. For example, to convert between ISO-8859-1
(Latin 1) and UTF-8 (or UTF-EBCDIC in EBCDIC machines):
open(F, "<:encoding(iso-8859-1)", "data.txt") or die $!;
open(G, ">:utf8", "data.utf") or die $!;
while (<F>) { print G }
# Could also do "print G <F>" but that would pull
# the whole file into memory just to write it out again.
More examples:
open(my $f, "<:encoding(cp1252)")
open(my $g, ">:encoding(iso-8859-2)")
open(my $h, ">:encoding(latin9)") # iso-8859-15
See also L<encoding> for how to change the default encoding of the
data in your script.
=head1 How does it work?
Here is a crude diagram of how filehandle, PerlIO, and Encode
interact.
filehandle <-> PerlIO PerlIO <-> scalar (read/printed)
\ /
Encode
When PerlIO receives data from either direction, it fills a buffer
(currently with 1024 bytes) and passes the buffer to Encode.
Encode tries to convert the valid part and passes it back to PerlIO,
leaving invalid parts (usually a partial character) in the buffer.
PerlIO then appends more data to the buffer, calls Encode again,
and so on until the data stream ends.
To do so, PerlIO always calls (de|en)code methods with CHECK set to 1.
This ensures that the method stops at the right place when it
encounters partial character. The following is what happens when
PerlIO and Encode tries to encode (from utf8) more than 1024 bytes
and the buffer boundary happens to be in the middle of a character.
A B C .... ~ \x{3000} ....
41 42 43 .... 7E e3 80 80 ....
<- buffer --------------->
<< encoded >>>>>>>>>>
<- next buffer ------
Encode converts from the beginning to \x7E, leaving \xe3 in the buffer
because it is invalid (partial character).
Unfortunately, this scheme does not work well with escape-based
encodings such as ISO-2022-JP.
=head1 Line Buffering
Now let's see what happens when you try to decode from ISO-2022-JP and
the buffer ends in the middle of a character.
JIS208-ESC \x{5f3e}
A B C .... ~ \e $ B |DAN | ....
41 42 43 .... 7E 1b 24 41 43 46 ....
<- buffer --------------------------->
<< encoded >>>>>>>>>>>>>>>>>>>>>>>
As you see, the next buffer begins with \x43. But \x43 is 'C' in
ASCII, which is wrong in this case because we are now in JISX 0208
area so it has to convert \x43\x46, not \x43. Unlike utf8 and EUC,
in escape-based encodings you can't tell if a given octet is a whole
character or just part of it.
Fortunately PerlIO also supports line buffer if you tell PerlIO to use
one instead of fixed buffer. Since ISO-2022-JP is guaranteed to revert to ASCII at the end of the line, partial
character will never happen when line buffer is used.
To tell PerlIO to use line buffer, implement -E<gt>needs_lines method
for your encoding object. See L<Encode::Encoding> for details.
Thanks to these efforts most encodings that come with Encode support
PerlIO but that still leaves following encodings.
iso-2022-kr
MIME-B
MIME-Header
MIME-Q
Fortunately iso-2022-kr is hardly used (according to Jungshik) and
MIME-* are very unlikely to be fed to PerlIO because they are for mail
headers. See L<Encode::MIME::Header> for details.
=head2 How can I tell whether my encoding fully supports PerlIO ?
As of this writing, any encoding whose class belongs to Encode::XS and
Encode::Unicode works. The Encode module has a C<perlio_ok> method
which you can use before applying PerlIO encoding to the filehandle.
Here is an example:
my $use_perlio = perlio_ok($enc);
my $layer = $use_perlio ? "<:raw" : "<:encoding($enc)";
open my $fh, $layer, $file or die "$file : $!";
while(<$fh>){
$_ = decode($enc, $_) unless $use_perlio;
# ....
}
=head1 SEE ALSO
L<Encode::Encoding>,
L<Encode::Supported>,
L<Encode::PerlIO>,
L<encoding>,
L<perlebcdic>,
L<perlfunc/open>,
L<perlunicode>,
L<utf8>,
the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt>
=cut

31
Agent-Windows/OGP64/usr/share/perl5/5.40/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.

901
Agent-Windows/OGP64/usr/share/perl5/5.40/Encode/Supported.pod Normal file
View file

@ -0,0 +1,901 @@
=head1 NAME
Encode::Supported -- Encodings supported by Encode
=head1 DESCRIPTION
=head2 Encoding Names
Encoding names are case insensitive. White space in names
is ignored. In addition, an encoding may have aliases.
Each encoding has one "canonical" name. The "canonical"
name is chosen from the names of the encoding by picking
the first in the following sequence (with a few exceptions).
=over 2
=item *
The name used by the Perl community. That includes 'utf8' and 'ascii'.
Unlike aliases, canonical names directly reach the method so such
frequently used words like 'utf8' don't need to do alias lookups.
=item *
The MIME name as defined in IETF RFCs. This includes all "iso-"s.
=item *
The name in the IANA registry.
=item *
The name used by the organization that defined it.
=back
In case I<de jure> canonical names differ from that of the Encode
module, they are always aliased if it ever be implemented. So you can
safely tell if a given encoding is implemented or not just by passing
the canonical name.
Because of all the alias issues, and because in the general case
encodings have state, "Encode" uses an encoding object internally
once an operation is in progress.
=head1 Supported Encodings
As of Perl 5.8.0, at least the following encodings are recognized.
Note that unless otherwise specified, they are all case insensitive
(via alias) and all occurrence of spaces are replaced with '-'.
In other words, "ISO 8859 1" and "iso-8859-1" are identical.
Encodings are categorized and implemented in several different modules
but you don't have to C<use Encode::XX> to make them available for
most cases. Encode.pm will automatically load those modules on demand.
=head2 Built-in Encodings
The following encodings are always available.
Canonical Aliases Comments & References
----------------------------------------------------------------
ascii US-ascii ISO-646-US [ECMA]
ascii-ctrl Special Encoding
iso-8859-1 latin1 [ISO]
null Special Encoding
utf8 UTF-8 [RFC2279]
----------------------------------------------------------------
I<null> and I<ascii-ctrl> are special. "null" fails for all character
so when you set fallback mode to PERLQQ, HTMLCREF or XMLCREF, ALL
CHARACTERS will fall back to character references. Ditto for
"ascii-ctrl" except for control characters. For fallback modes, see
L<Encode>.
=head2 Encode::Unicode -- other Unicode encodings
Unicode coding schemes other than native utf8 are supported by
Encode::Unicode, which will be autoloaded on demand.
----------------------------------------------------------------
UCS-2BE UCS-2, iso-10646-1 [IANA, UC]
UCS-2LE [UC]
UTF-16 [UC]
UTF-16BE [UC]
UTF-16LE [UC]
UTF-32 [UC]
UTF-32BE UCS-4 [UC]
UTF-32LE [UC]
UTF-7 [RFC2152]
----------------------------------------------------------------
To find how (UCS-2|UTF-(16|32))(LE|BE)? differ from one another,
see L<Encode::Unicode>.
UTF-7 is a special encoding which "re-encodes" UTF-16BE into a 7-bit
encoding. It is implemented separately by Encode::Unicode::UTF7.
=head2 Encode::Byte -- Extended ASCII
Encode::Byte implements most single-byte encodings except for
Symbols and EBCDIC. The following encodings are based on single-byte
encodings implemented as extended ASCII. Most of them map
\x80-\xff (upper half) to non-ASCII characters.
=over 2
=item ISO-8859 and corresponding vendor mappings
Since there are so many, they are presented in table format with
languages and corresponding encoding names by vendors. Note that
the table is sorted in order of ISO-8859 and the corresponding vendor
mappings are slightly different from that of ISO. See
L<http://czyborra.com/charsets/iso8859.html> for details.
Lang/Regions ISO/Other Std. DOS Windows Macintosh Others
----------------------------------------------------------------
N. America (ASCII) cp437 AdobeStandardEncoding
cp863 (DOSCanadaF)
W. Europe iso-8859-1 cp850 cp1252 MacRoman nextstep
hp-roman8
cp860 (DOSPortuguese)
Cntrl. Europe iso-8859-2 cp852 cp1250 MacCentralEurRoman
MacCroatian
MacRomanian
MacRumanian
Latin3[1] iso-8859-3
Latin4[2] iso-8859-4
Cyrillics iso-8859-5 cp855 cp1251 MacCyrillic
(See also next section) cp866 MacUkrainian
Arabic iso-8859-6 cp864 cp1256 MacArabic
cp1006 MacFarsi
Greek iso-8859-7 cp737 cp1253 MacGreek
cp869 (DOSGreek2)
Hebrew iso-8859-8 cp862 cp1255 MacHebrew
Turkish iso-8859-9 cp857 cp1254 MacTurkish
Nordics iso-8859-10 cp865
cp861 MacIcelandic
MacSami
Thai iso-8859-11[3] cp874 MacThai
(iso-8859-12 is nonexistent. Reserved for Indics?)
Baltics iso-8859-13 cp775 cp1257
Celtics iso-8859-14
Latin9 [4] iso-8859-15
Latin10 iso-8859-16
Vietnamese viscii cp1258 MacVietnamese
----------------------------------------------------------------
[1] Esperanto, Maltese, and Turkish. Turkish is now on 8859-9.
[2] Baltics. Now on 8859-10, except for Latvian.
[3] TIS 620 + Non-Breaking Space (0xA0 / U+00A0)
[4] Nicknamed Latin0; the Euro sign as well as French and Finnish
letters that are missing from 8859-1 were added.
All cp* are also available as ibm-*, ms-*, and windows-* . See also
L<http://czyborra.com/charsets/codepages.html>.
Macintosh encodings don't seem to be registered in such entities as
IANA. "Canonical" names in Encode are based upon Apple's Tech Note
1150. See L<http://developer.apple.com/technotes/tn/tn1150.html>
for details.
=item KOI8 - De Facto Standard for the Cyrillic world
Though ISO-8859 does have ISO-8859-5, the KOI8 series is far more
popular in the Net. L<Encode> comes with the following KOI charsets.
For gory details, see L<http://czyborra.com/charsets/cyrillic.html>
----------------------------------------------------------------
koi8-f
koi8-r cp878 [RFC1489]
koi8-u [RFC2319]
----------------------------------------------------------------
=back
=head2 gsm0338 - Hentai Latin 1
GSM0338 is for GSM handsets. Though it shares alphanumerals with
ASCII, control character ranges and other parts are mapped very
differently, mainly to store Greek characters. There are also escape
sequences (starting with 0x1B) to cover e.g. the Euro sign.
This was once handled by L<Encode::Bytes> but because of all those
unusual specifications, Encode 2.20 has relocated the support to
L<Encode::GSM0338>. See L<Encode::GSM0338> for details.
=over 2
=item gsm0338 support before 2.19
Some special cases like a trailing 0x00 byte or a lone 0x1B byte are not
well-defined and decode() will return an empty string for them.
One possible workaround is
$gsm =~ s/\x00\z/\x00\x00/;
$uni = decode("gsm0338", $gsm);
$uni .= "\xA0" if $gsm =~ /\x1B\z/;
Note that the Encode implementation of GSM0338 does not implement the
reuse of Latin capital letters as Greek capital letters (for example,
the 0x5A is U+005A (LATIN CAPITAL LETTER Z), not U+0396 (GREEK CAPITAL
LETTER ZETA).
The GSM0338 is also covered in Encode::Byte even though it is not
an "extended ASCII" encoding.
=back
=head2 CJK: Chinese, Japanese, Korean (Multibyte)
Note that Vietnamese is listed above. Also read "Encoding vs Charset"
below. Also note that these are implemented in distinct modules by
countries, due to the size concerns (simplified Chinese is mapped
to 'CN', continental China, while traditional Chinese is mapped to
'TW', Taiwan). Please refer to their respective documentation pages.
=over 2
=item Encode::CN -- Continental China
Standard DOS/Win Macintosh Comment/Reference
----------------------------------------------------------------
euc-cn [1] MacChineseSimp
(gbk) cp936 [2]
gb12345-raw { GB12345 without CES }
gb2312-raw { GB2312 without CES }
hz
iso-ir-165
----------------------------------------------------------------
[1] GB2312 is aliased to this. See L<Microsoft-related naming mess>
[2] gbk is aliased to this. See L<Microsoft-related naming mess>
=item Encode::JP -- Japan
Standard DOS/Win Macintosh Comment/Reference
----------------------------------------------------------------
euc-jp
shiftjis cp932 macJapanese
7bit-jis
iso-2022-jp [RFC1468]
iso-2022-jp-1 [RFC2237]
jis0201-raw { JIS X 0201 (roman + halfwidth kana) without CES }
jis0208-raw { JIS X 0208 (Kanji + fullwidth kana) without CES }
jis0212-raw { JIS X 0212 (Extended Kanji) without CES }
----------------------------------------------------------------
=item Encode::KR -- Korea
Standard DOS/Win Macintosh Comment/Reference
----------------------------------------------------------------
euc-kr MacKorean [RFC1557]
cp949 [1]
iso-2022-kr [RFC1557]
johab [KS X 1001:1998, Annex 3]
ksc5601-raw { KSC5601 without CES }
----------------------------------------------------------------
[1] ks_c_5601-1987, (x-)?windows-949, and uhc are aliased to this.
See below.
=item Encode::TW -- Taiwan
Standard DOS/Win Macintosh Comment/Reference
----------------------------------------------------------------
big5-eten cp950 MacChineseTrad {big5 aliased to big5-eten}
big5-hkscs
----------------------------------------------------------------
=item Encode::HanExtra -- More Chinese via CPAN
Due to the size concerns, additional Chinese encodings below are
distributed separately on CPAN, under the name Encode::HanExtra.
Standard DOS/Win Macintosh Comment/Reference
----------------------------------------------------------------
big5ext CMEX's Big5e Extension
big5plus CMEX's Big5+ Extension
cccii Chinese Character Code for Information Interchange
euc-tw EUC (Extended Unix Character)
gb18030 GBK with Traditional Characters
----------------------------------------------------------------
=item Encode::JIS2K -- JIS X 0213 encodings via CPAN
Due to size concerns, additional Japanese encodings below are
distributed separately on CPAN, under the name Encode::JIS2K.
Standard DOS/Win Macintosh Comment/Reference
----------------------------------------------------------------
euc-jisx0213
shiftjisx0123
iso-2022-jp-3
jis0213-1-raw
jis0213-2-raw
----------------------------------------------------------------
=back
=head2 Miscellaneous encodings
=over 2
=item Encode::EBCDIC
See L<perlebcdic> for details.
----------------------------------------------------------------
cp37
cp500
cp875
cp1026
cp1047
posix-bc
----------------------------------------------------------------
=item Encode::Symbol
For symbols and dingbats.
----------------------------------------------------------------
symbol
dingbats
MacDingbats
AdobeZdingbat
AdobeSymbol
----------------------------------------------------------------
=item Encode::MIME::Header
Strictly speaking, MIME header encoding documented in RFC 2047 is more
of encapsulation than encoding. However, their support in modern
world is imperative so they are supported.
----------------------------------------------------------------
MIME-Header [RFC2047]
MIME-B [RFC2047]
MIME-Q [RFC2047]
----------------------------------------------------------------
=item Encode::Guess
This one is not a name of encoding but a utility that lets you pick up
the most appropriate encoding for a data out of given I<suspects>. See
L<Encode::Guess> for details.
=back
=head1 Unsupported encodings
The following encodings are not supported as yet; some because they
are rarely used, some because of technical difficulties. They may
be supported by external modules via CPAN in the future, however.
=over 2
=item ISO-2022-JP-2 [RFC1554]
Not very popular yet. Needs Unicode Database or equivalent to
implement encode() (because it includes JIS X 0208/0212, KSC5601, and
GB2312 simultaneously, whose code points in Unicode overlap. So you
need to lookup the database to determine to what character set a given
Unicode character should belong).
=item ISO-2022-CN [RFC1922]
Not very popular. Needs CNS 11643-1 and -2 which are not available in
this module. CNS 11643 is supported (via euc-tw) in Encode::HanExtra.
Audrey Tang may add support for this encoding in her module in future.
=item Various HP-UX encodings
The following are unsupported due to the lack of mapping data.
'8' - arabic8, greek8, hebrew8, kana8, thai8, and turkish8
'15' - japanese15, korean15, and roi15
=item Cyrillic encoding ISO-IR-111
Anton Tagunov doubts its usefulness.
=item ISO-8859-8-1 [Hebrew]
None of the Encode team knows Hebrew enough (ISO-8859-8, cp1255 and
MacHebrew are supported because and just because there were mappings
available at L<http://www.unicode.org/>). Contributions welcome.
=item ISIRI 3342, Iran System, ISIRI 2900 [Farsi]
Ditto.
=item Thai encoding TCVN
Ditto.
=item Vietnamese encodings VPS
Though Jungshik Shin has reported that Mozilla supports this encoding,
it was too late before 5.8.0 for us to add it. In the future, it
may be available via a separate module. See
L<http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.uf>
and
L<http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.ut>
if you are interested in helping us.
=item Various Mac encodings
The following are unsupported due to the lack of mapping data.
MacArmenian, MacBengali, MacBurmese, MacEthiopic
MacExtArabic, MacGeorgian, MacKannada, MacKhmer
MacLaotian, MacMalayalam, MacMongolian, MacOriya
MacSinhalese, MacTamil, MacTelugu, MacTibetan
MacVietnamese
The rest which are already available are based upon the vendor mappings
at L<http://www.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> .
=item (Mac) Indic encodings
The maps for the following are available at L<http://www.unicode.org/>
but remain unsupported because those encodings need an algorithmical
approach, currently unsupported by F<enc2xs>:
MacDevanagari
MacGurmukhi
MacGujarati
For details, please see C<Unicode mapping issues and notes:> at
L<http://www.unicode.org/Public/MAPPINGS/VENDORS/APPLE/DEVANAGA.TXT> .
I believe this issue is prevalent not only for Mac Indics but also in
other Indic encodings, but the above were the only Indic encodings
maps that I could find at L<http://www.unicode.org/> .
=back
=head1 Encoding vs. Charset -- terminology
We are used to using the term (character) I<encoding> and I<character
set> interchangeably. But just as confusing the terms byte and
character is dangerous and the terms should be differentiated when
needed, we need to differentiate I<encoding> and I<character set>.
To understand that, here is a description of how we make computers
grok our characters.
=over 2
=item *
First we start with which characters to include. We call this
collection of characters I<character repertoire>.
=item *
Then we have to give each character a unique ID so your computer can
tell the difference between 'a' and 'A'. This itemized character
repertoire is now a I<character set>.
=item *
If your computer can grow the character set without further
processing, you can go ahead and use it. This is called a I<coded
character set> (CCS) or I<raw character encoding>. ASCII is used this
way for most cases.
=item *
But in many cases, especially multi-byte CJK encodings, you have to
tweak a little more. Your network connection may not accept any data
with the Most Significant Bit set, and your computer may not be able to
tell if a given byte is a whole character or just half of it. So you
have to I<encode> the character set to use it.
A I<character encoding scheme> (CES) determines how to encode a given
character set, or a set of multiple character sets. 7bit ISO-2022 is
an example of a CES. You switch between character sets via I<escape
sequences>.
=back
Technically, or mathematically, speaking, a character set encoded in
such a CES that maps character by character may form a CCS. EUC is such
an example. The CES of EUC is as follows:
=over 2
=item *
Map ASCII unchanged.
=item *
Map such a character set that consists of 94 or 96 powered by N
members by adding 0x80 to each byte.
=item *
You can also use 0x8e and 0x8f to indicate that the following sequence of
characters belongs to yet another character set. To each following byte
is added the value 0x80.
=back
By carefully looking at the encoded byte sequence, you can find that the
byte sequence conforms a unique number. In that sense, EUC is a CCS
generated by a CES above from up to four CCS (complicated?). UTF-8
falls into this category. See L<perlUnicode/"UTF-8"> to find out how
UTF-8 maps Unicode to a byte sequence.
You may also have found out by now why 7bit ISO-2022 cannot comprise
a CCS. If you look at a byte sequence \x21\x21, you can't tell if
it is two !'s or IDEOGRAPHIC SPACE. EUC maps the latter to \xA1\xA1
so you have no trouble differentiating between "!!". and S<" ">.
=head1 Encoding Classification (by Anton Tagunov and Dan Kogai)
This section tries to classify the supported encodings by their
applicability for information exchange over the Internet and to
choose the most suitable aliases to name them in the context of
such communication.
=over 2
=item *
To (en|de)code encodings marked by C<(**)>, you need
C<Encode::HanExtra>, available from CPAN.
=back
Encoding names
US-ASCII UTF-8 ISO-8859-* KOI8-R
Shift_JIS EUC-JP ISO-2022-JP ISO-2022-JP-1
EUC-KR Big5 GB2312
are registered with IANA as preferred MIME names and may
be used over the Internet.
C<Shift_JIS> has been officialized by JIS X 0208:1997.
L<Microsoft-related naming mess> gives details.
C<GB2312> is the IANA name for C<EUC-CN>.
See L<Microsoft-related naming mess> for details.
C<GB_2312-80> I<raw> encoding is available as C<gb2312-raw>
with Encode. See L<Encode::CN> for details.
EUC-CN
KOI8-U [RFC2319]
have not been registered with IANA (as of March 2002) but
seem to be supported by major web browsers.
The IANA name for C<EUC-CN> is C<GB2312>.
KS_C_5601-1987
is heavily misused.
See L<Microsoft-related naming mess> for details.
C<KS_C_5601-1987> I<raw> encoding is available as C<kcs5601-raw>
with Encode. See L<Encode::KR> for details.
UTF-16 UTF-16BE UTF-16LE
are IANA-registered C<charset>s. See [RFC 2781] for details.
Jungshik Shin reports that UTF-16 with a BOM is well accepted
by MS IE 5/6 and NS 4/6. Beware however that
=over 2
=item *
C<UTF-16> support in any software you're going to be
using/interoperating with has probably been less tested
then C<UTF-8> support
=item *
C<UTF-8> coded data seamlessly passes traditional
command piping (C<cat>, C<more>, etc.) while C<UTF-16> coded
data is likely to cause confusion (with its zero bytes,
for example)
=item *
it is beyond the power of words to describe the way HTML browsers
encode non-C<ASCII> form data. To get a general impression, visit
L<http://www.alanflavell.org.uk/charset/form-i18n.html>.
While encoding of form data has stabilized for C<UTF-8> encoded pages
(at least IE 5/6, NS 6, and Opera 6 behave consistently), be sure to
expect fun (and cross-browser discrepancies) with C<UTF-16> encoded
pages!
=back
The rule of thumb is to use C<UTF-8> unless you know what
you're doing and unless you really benefit from using C<UTF-16>.
ISO-IR-165 [RFC1345]
VISCII
GB 12345
GB 18030 (**) (see links below)
EUC-TW (**)
are totally valid encodings but not registered at IANA.
The names under which they are listed here are probably the
most widely-known names for these encodings and are recommended
names.
BIG5PLUS (**)
is a proprietary name.
=head2 Microsoft-related naming mess
Microsoft products misuse the following names:
=over 2
=item KS_C_5601-1987
Microsoft extension to C<EUC-KR>.
Proper names: C<CP949>, C<UHC>, C<x-windows-949> (as used by Mozilla).
See L<http://lists.w3.org/Archives/Public/ietf-charsets/2001AprJun/0033.html>
for details.
Encode aliases C<KS_C_5601-1987> to C<cp949> to reflect this common
misusage. I<Raw> C<KS_C_5601-1987> encoding is available as
C<kcs5601-raw>.
See L<Encode::KR> for details.
=item GB2312
Microsoft extension to C<EUC-CN>.
Proper names: C<CP936>, C<GBK>.
C<GB2312> has been registered in the C<EUC-CN> meaning at
IANA. This has partially repaired the situation: Microsoft's
C<GB2312> has become a superset of the official C<GB2312>.
Encode aliases C<GB2312> to C<euc-cn> in full agreement with
IANA registration. C<cp936> is supported separately.
I<Raw> C<GB_2312-80> encoding is available as C<gb2312-raw>.
See L<Encode::CN> for details.
=item Big5
Microsoft extension to C<Big5>.
Proper name: C<CP950>.
Encode separately supports C<Big5> and C<cp950>.
=item Shift_JIS
Microsoft's understanding of C<Shift_JIS>.
JIS has not endorsed the full Microsoft standard however.
The official C<Shift_JIS> includes only JIS X 0201 and JIS X 0208
character sets, while Microsoft has always used C<Shift_JIS>
to encode a wider character repertoire. See C<IANA> registration for
C<Windows-31J>.
As a historical predecessor, Microsoft's variant
probably has more rights for the name, though it may be objected
that Microsoft shouldn't have used JIS as part of the name
in the first place.
Unambiguous name: C<CP932>. C<IANA> name (also used by Mozilla, and
provided as an alias by Encode): C<Windows-31J>.
Encode separately supports C<Shift_JIS> and C<cp932>.
=back
=head1 Glossary
=over 2
=item character repertoire
A collection of unique characters. A I<character> set in the strictest
sense. At this stage, characters are not numbered.
=item coded character set (CCS)
A character set that is mapped in a way computers can use directly.
Many character encodings, including EUC, fall in this category.
=item character encoding scheme (CES)
An algorithm to map a character set to a byte sequence. You don't
have to be able to tell which character set a given byte sequence
belongs. 7-bit ISO-2022 is a CES but it cannot be a CCS. EUC is an
example of being both a CCS and CES.
=item charset (in MIME context)
has long been used in the meaning of C<encoding>, CES.
While the word combination C<character set> has lost this meaning
in MIME context since [RFC 2130], the C<charset> abbreviation has
retained it. This is how [RFC 2277] and [RFC 2278] bless C<charset>:
This document uses the term "charset" to mean a set of rules for
mapping from a sequence of octets to a sequence of characters, such
as the combination of a coded character set and a character encoding
scheme; this is also what is used as an identifier in MIME "charset="
parameters, and registered in the IANA charset registry ... (Note
that this is NOT a term used by other standards bodies, such as ISO).
[RFC 2277]
=item EUC
Extended Unix Character. See ISO-2022.
=item ISO-2022
A CES that was carefully designed to coexist with ASCII. There are a 7
bit version and an 8 bit version.
The 7 bit version switches character set via escape sequence so it
cannot form a CCS. Since this is more difficult to handle in programs
than the 8 bit version, the 7 bit version is not very popular except for
iso-2022-jp, the I<de facto> standard CES for e-mails.
The 8 bit version can form a CCS. EUC and ISO-8859 are two examples
thereof. Pre-5.6 perl could use them as string literals.
=item UCS
Short for I<Universal Character Set>. When you say just UCS, it means
I<Unicode>.
=item UCS-2
ISO/IEC 10646 encoding form: Universal Character Set coded in two
octets.
=item Unicode
A character set that aims to include all character repertoires of the
world. Many character sets in various national as well as industrial
standards have become, in a way, just subsets of Unicode.
=item UTF
Short for I<Unicode Transformation Format>. Determines how to map a
Unicode character into a byte sequence.
=item UTF-16
A UTF in 16-bit encoding. Can either be in big endian or little
endian. The big endian version is called UTF-16BE (equal to UCS-2 +
surrogate support) and the little endian version is called UTF-16LE.
=back
=head1 See Also
L<Encode>,
L<Encode::Byte>,
L<Encode::CN>, L<Encode::JP>, L<Encode::KR>, L<Encode::TW>,
L<Encode::EBCDIC>, L<Encode::Symbol>
L<Encode::MIME::Header>, L<Encode::Guess>
=head1 References
=over 2
=item ECMA
European Computer Manufacturers Association
L<http://www.ecma.ch>
=over 2
=item ECMA-035 (eq C<ISO-2022>)
L<http://www.ecma.ch/ecma1/STAND/ECMA-035.HTM>
The specification of ISO-2022 is available from the link above.
=back
=item IANA
Internet Assigned Numbers Authority
L<http://www.iana.org/>
=over 2
=item Assigned Charset Names by IANA
L<http://www.iana.org/assignments/character-sets>
Most of the C<canonical names> in Encode derive from this list
so you can directly apply the string you have extracted from MIME
header of mails and web pages.
=back
=item ISO
International Organization for Standardization
L<http://www.iso.ch/>
=item RFC
Request For Comments -- need I say more?
L<http://www.rfc-editor.org/>, L<http://www.ietf.org/rfc.html>,
L<http://www.faqs.org/rfcs/>
=item UC
Unicode Consortium
L<http://www.unicode.org/>
=over 2
=item Unicode Glossary
L<http://www.unicode.org/glossary/>
The glossary of this document is based upon this site.
=back
=back
=head2 Other Notable Sites
=over 2
=item czyborra.com
L<http://czyborra.com/>
Contains a lot of useful information, especially gory details of ISO
vs. vendor mappings.
=item CJK.inf
L<http://examples.oreilly.com/cjkvinfo/doc/cjk.inf>
Somewhat obsolete (last update in 1996), but still useful. Also try
L<ftp://ftp.oreilly.com/pub/examples/nutshell/cjkv/pdf/GB18030_Summary.pdf>
You will find brief info on C<EUC-CN>, C<GBK> and mostly on C<GB 18030>.
=item Jungshik Shin's Hangul FAQ
L<http://jshin.net/faq>
And especially its subject 8.
L<http://jshin.net/faq/qa8.html>
A comprehensive overview of the Korean (C<KS *>) standards.
=item debian.org: "Introduction to i18n"
A brief description for most of the mentioned CJK encodings is
contained in
L<http://www.debian.org/doc/manuals/intro-i18n/ch-codes.en.html>
=back
=head2 Offline sources
=over 2
=item C<CJKV Information Processing> by Ken Lunde
CJKV Information Processing
1999 O'Reilly & Associates, ISBN : 1-56592-224-7
The modern successor of C<CJK.inf>.
Features a comprehensive coverage of CJKV character sets and
encodings along with many other issues faced by anyone trying
to better support CJKV languages/scripts in all the areas of
information processing.
To purchase this book, visit
L<http://oreilly.com/catalog/9780596514471/>
or your favourite bookstore.
=back
=cut

23
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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!

1358
Agent-Windows/OGP64/usr/share/perl5/5.40/Encode/encode.h Normal file
View file

File diff suppressed because it is too large Load diff

237
Agent-Windows/OGP64/usr/share/perl5/5.40/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
Agent-Windows/OGP64/usr/share/perl5/5.40/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;

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