Initial Commit
This commit is contained in:
Riley Schneider
311
database/perl/vendor/lib/Module/Build/Tiny.pm
vendored
Normal file
311
database/perl/vendor/lib/Module/Build/Tiny.pm
vendored
Normal file
@@ -0,0 +1,311 @@
|
||||
package Module::Build::Tiny;
|
||||
$Module::Build::Tiny::VERSION = '0.039';
|
||||
use strict;
|
||||
use warnings;
|
||||
use Exporter 5.57 'import';
|
||||
our @EXPORT = qw/Build Build_PL/;
|
||||
|
||||
use CPAN::Meta;
|
||||
use ExtUtils::Config 0.003;
|
||||
use ExtUtils::Helpers 0.020 qw/make_executable split_like_shell man1_pagename man3_pagename detildefy/;
|
||||
use ExtUtils::Install qw/pm_to_blib install/;
|
||||
use ExtUtils::InstallPaths 0.002;
|
||||
use File::Basename qw/basename dirname/;
|
||||
use File::Find ();
|
||||
use File::Path qw/mkpath rmtree/;
|
||||
use File::Spec::Functions qw/catfile catdir rel2abs abs2rel splitdir curdir/;
|
||||
use Getopt::Long 2.36 qw/GetOptionsFromArray/;
|
||||
use JSON::PP 2 qw/encode_json decode_json/;
|
||||
|
||||
sub write_file {
|
||||
my ($filename, $content) = @_;
|
||||
open my $fh, '>', $filename or die "Could not open $filename: $!\n";
|
||||
print $fh $content;
|
||||
}
|
||||
sub read_file {
|
||||
my ($filename, $mode) = @_;
|
||||
open my $fh, '<', $filename or die "Could not open $filename: $!\n";
|
||||
return do { local $/; <$fh> };
|
||||
}
|
||||
|
||||
sub get_meta {
|
||||
my ($metafile) = grep { -e $_ } qw/META.json META.yml/ or die "No META information provided\n";
|
||||
return CPAN::Meta->load_file($metafile);
|
||||
}
|
||||
|
||||
sub manify {
|
||||
my ($input_file, $output_file, $section, $opts) = @_;
|
||||
return if -e $output_file && -M $input_file <= -M $output_file;
|
||||
my $dirname = dirname($output_file);
|
||||
mkpath($dirname, $opts->{verbose}) if not -d $dirname;
|
||||
require Pod::Man;
|
||||
Pod::Man->new(section => $section)->parse_from_file($input_file, $output_file);
|
||||
print "Manifying $output_file\n" if $opts->{verbose} && $opts->{verbose} > 0;
|
||||
return;
|
||||
}
|
||||
|
||||
sub process_xs {
|
||||
my ($source, $options) = @_;
|
||||
|
||||
die "Can't build xs files under --pureperl-only\n" if $options->{'pureperl-only'};
|
||||
my (undef, @parts) = splitdir(dirname($source));
|
||||
push @parts, my $file_base = basename($source, '.xs');
|
||||
my $archdir = catdir(qw/blib arch auto/, @parts);
|
||||
my $tempdir = 'temp';
|
||||
|
||||
my $c_file = catfile($tempdir, "$file_base.c");
|
||||
require ExtUtils::ParseXS;
|
||||
mkpath($tempdir, $options->{verbose}, oct '755');
|
||||
ExtUtils::ParseXS::process_file(filename => $source, prototypes => 0, output => $c_file);
|
||||
|
||||
my $version = $options->{meta}->version;
|
||||
require ExtUtils::CBuilder;
|
||||
my $builder = ExtUtils::CBuilder->new(config => $options->{config}->values_set);
|
||||
my $ob_file = $builder->compile(source => $c_file, defines => { VERSION => qq/"$version"/, XS_VERSION => qq/"$version"/ }, include_dirs => [ curdir, dirname($source) ]);
|
||||
|
||||
require DynaLoader;
|
||||
my $mod2fname = defined &DynaLoader::mod2fname ? \&DynaLoader::mod2fname : sub { return $_[0][-1] };
|
||||
|
||||
mkpath($archdir, $options->{verbose}, oct '755') unless -d $archdir;
|
||||
my $lib_file = catfile($archdir, $mod2fname->(\@parts) . '.' . $options->{config}->get('dlext'));
|
||||
return $builder->link(objects => $ob_file, lib_file => $lib_file, module_name => join '::', @parts);
|
||||
}
|
||||
|
||||
sub find {
|
||||
my ($pattern, $dir) = @_;
|
||||
my @ret;
|
||||
File::Find::find(sub { push @ret, $File::Find::name if /$pattern/ && -f }, $dir) if -d $dir;
|
||||
return @ret;
|
||||
}
|
||||
|
||||
my %actions = (
|
||||
build => sub {
|
||||
my %opt = @_;
|
||||
for my $pl_file (find(qr/\.PL$/, 'lib')) {
|
||||
(my $pm = $pl_file) =~ s/\.PL$//;
|
||||
system $^X, $pl_file, $pm and die "$pl_file returned $?\n";
|
||||
}
|
||||
my %modules = map { $_ => catfile('blib', $_) } find(qr/\.p(?:m|od)$/, 'lib');
|
||||
my %scripts = map { $_ => catfile('blib', $_) } find(qr//, 'script');
|
||||
my %shared = map { $_ => catfile(qw/blib lib auto share dist/, $opt{meta}->name, abs2rel($_, 'share')) } find(qr//, 'share');
|
||||
pm_to_blib({ %modules, %scripts, %shared }, catdir(qw/blib lib auto/));
|
||||
make_executable($_) for values %scripts;
|
||||
mkpath(catdir(qw/blib arch/), $opt{verbose});
|
||||
process_xs($_, \%opt) for find(qr/.xs$/, 'lib');
|
||||
|
||||
if ($opt{install_paths}->install_destination('bindoc') && $opt{install_paths}->is_default_installable('bindoc')) {
|
||||
manify($_, catfile('blib', 'bindoc', man1_pagename($_)), $opt{config}->get('man1ext'), \%opt) for keys %scripts;
|
||||
}
|
||||
if ($opt{install_paths}->install_destination('libdoc') && $opt{install_paths}->is_default_installable('libdoc')) {
|
||||
manify($_, catfile('blib', 'libdoc', man3_pagename($_)), $opt{config}->get('man3ext'), \%opt) for keys %modules;
|
||||
}
|
||||
},
|
||||
test => sub {
|
||||
my %opt = @_;
|
||||
die "Must run `./Build build` first\n" if not -d 'blib';
|
||||
require TAP::Harness::Env;
|
||||
my %test_args = (
|
||||
(verbosity => $opt{verbose}) x!! exists $opt{verbose},
|
||||
(jobs => $opt{jobs}) x!! exists $opt{jobs},
|
||||
(color => 1) x !!-t STDOUT,
|
||||
lib => [ map { rel2abs(catdir(qw/blib/, $_)) } qw/arch lib/ ],
|
||||
);
|
||||
my $tester = TAP::Harness::Env->create(\%test_args);
|
||||
$tester->runtests(sort +find(qr/\.t$/, 't'))->has_errors and exit 1;
|
||||
},
|
||||
install => sub {
|
||||
my %opt = @_;
|
||||
die "Must run `./Build build` first\n" if not -d 'blib';
|
||||
install($opt{install_paths}->install_map, @opt{qw/verbose dry_run uninst/});
|
||||
},
|
||||
clean => sub {
|
||||
my %opt = @_;
|
||||
rmtree($_, $opt{verbose}) for qw/blib temp/;
|
||||
},
|
||||
realclean => sub {
|
||||
my %opt = @_;
|
||||
rmtree($_, $opt{verbose}) for qw/blib temp Build _build_params MYMETA.yml MYMETA.json/;
|
||||
},
|
||||
);
|
||||
|
||||
sub Build {
|
||||
my $action = @ARGV && $ARGV[0] =~ /\A\w+\z/ ? shift @ARGV : 'build';
|
||||
die "No such action '$action'\n" if not $actions{$action};
|
||||
my($env, $bargv) = @{ decode_json(read_file('_build_params')) };
|
||||
my %opt;
|
||||
GetOptionsFromArray($_, \%opt, qw/install_base=s install_path=s% installdirs=s destdir=s prefix=s config=s% uninst:1 verbose:1 dry_run:1 pureperl-only:1 create_packlist=i jobs=i/) for ($env, $bargv, \@ARGV);
|
||||
$_ = detildefy($_) for grep { defined } @opt{qw/install_base destdir prefix/}, values %{ $opt{install_path} };
|
||||
@opt{ 'config', 'meta' } = (ExtUtils::Config->new($opt{config}), get_meta());
|
||||
$actions{$action}->(%opt, install_paths => ExtUtils::InstallPaths->new(%opt, dist_name => $opt{meta}->name));
|
||||
}
|
||||
|
||||
sub Build_PL {
|
||||
my $meta = get_meta();
|
||||
printf "Creating new 'Build' script for '%s' version '%s'\n", $meta->name, $meta->version;
|
||||
my $dir = $meta->name eq 'Module-Build-Tiny' ? "use lib 'lib';" : '';
|
||||
write_file('Build', "#!perl\n$dir\nuse Module::Build::Tiny;\nBuild();\n");
|
||||
make_executable('Build');
|
||||
my @env = defined $ENV{PERL_MB_OPT} ? split_like_shell($ENV{PERL_MB_OPT}) : ();
|
||||
write_file('_build_params', encode_json([ \@env, \@ARGV ]));
|
||||
$meta->save(@$_) for ['MYMETA.json'], [ 'MYMETA.yml' => { version => 1.4 } ];
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
#ABSTRACT: A tiny replacement for Module::Build
|
||||
|
||||
|
||||
# vi:et:sts=2:sw=2:ts=2
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Build::Tiny - A tiny replacement for Module::Build
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.039
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Module::Build::Tiny;
|
||||
Build_PL();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Many Perl distributions use a Build.PL file instead of a Makefile.PL file
|
||||
to drive distribution configuration, build, test and installation.
|
||||
Traditionally, Build.PL uses Module::Build as the underlying build system.
|
||||
This module provides a simple, lightweight, drop-in replacement.
|
||||
|
||||
Whereas Module::Build has over 6,700 lines of code; this module has less
|
||||
than 120, yet supports the features needed by most distributions.
|
||||
|
||||
=head2 Supported
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Pure Perl distributions
|
||||
|
||||
=item * Building XS or C
|
||||
|
||||
=item * Recursive test files
|
||||
|
||||
=item * MYMETA
|
||||
|
||||
=item * Man page generation
|
||||
|
||||
=item * Generated code from PL files
|
||||
|
||||
=back
|
||||
|
||||
=head2 Not Supported
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Dynamic prerequisites
|
||||
|
||||
=item * HTML documentation generation
|
||||
|
||||
=item * Extending Module::Build::Tiny
|
||||
|
||||
=item * Module sharedirs
|
||||
|
||||
=back
|
||||
|
||||
=head2 Directory structure
|
||||
|
||||
Your .pm and .pod files must be in F<lib/>. Any executables must be in
|
||||
F<script/>. Test files must be in F<t/>. Dist sharedirs must be in F<share/>.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
These all work pretty much like their Module::Build equivalents.
|
||||
|
||||
=head2 perl Build.PL
|
||||
|
||||
=head2 Build [ build ]
|
||||
|
||||
=head2 Build test
|
||||
|
||||
=head2 Build install
|
||||
|
||||
This supports the following options:
|
||||
|
||||
=over
|
||||
|
||||
=item * verbose
|
||||
|
||||
=item * install_base
|
||||
|
||||
=item * installdirs
|
||||
|
||||
=item * prefix
|
||||
|
||||
=item * install_path
|
||||
|
||||
=item * destdir
|
||||
|
||||
=item * uninst
|
||||
|
||||
=item * config
|
||||
|
||||
=item * pure-perl
|
||||
|
||||
=item * create_packlist
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORING
|
||||
|
||||
This module doesn't support authoring. To develop modules using Module::Build::Tiny, usage of L<Dist::Zilla::Plugin::ModuleBuildTiny> or L<App::ModuleBuildTiny> is recommended.
|
||||
|
||||
=head1 CONFIG FILE AND ENVIRONMENT
|
||||
|
||||
Options can be provided in the C<PERL_MB_OPT> environment variable the same way they can with Module::Build. This should be done during the configuration stage.
|
||||
|
||||
=head2 Incompatibilities
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Argument parsing
|
||||
|
||||
Module::Build has an extremely permissive way of argument handling, Module::Build::Tiny only supports a (sane) subset of that. In particular, C<./Build destdir=/foo> does not work, you will need to pass it as C<./Build --destdir=/foo>.
|
||||
|
||||
=item * .modulebuildrc
|
||||
|
||||
Module::Build::Tiny does not support .modulebuildrc files. In particular, this means that versions of local::lib older than 1.006008 may break with C<ERROR: Can't create /usr/local/somepath>. If the output of C<perl -Mlocal::lib> contains C<MODULEBUILDRC> but not C<PERL_MB_OPT >, you will need to upgrade it to resolve this issue.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Module::Build>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Leon Timmermans <leont@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
David Golden <dagolden@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2011 by Leon Timmermans, David Golden.
|
||||
|
||||
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
|
||||
290
database/perl/vendor/lib/Module/Implementation.pm
vendored
Normal file
290
database/perl/vendor/lib/Module/Implementation.pm
vendored
Normal file
@@ -0,0 +1,290 @@
|
||||
package Module::Implementation;
|
||||
# git description: v0.08-2-gd599347
|
||||
$Module::Implementation::VERSION = '0.09';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Module::Runtime 0.012 qw( require_module );
|
||||
use Try::Tiny;
|
||||
|
||||
# This is needed for the benefit of Test::CleanNamespaces, which in turn loads
|
||||
# Package::Stash, which in turn loads this module and expects a minimum
|
||||
# version.
|
||||
unless ( exists $Module::Implementation::{VERSION}
|
||||
&& ${ $Module::Implementation::{VERSION} } ) {
|
||||
|
||||
$Module::Implementation::{VERSION} = \42;
|
||||
}
|
||||
|
||||
my %Implementation;
|
||||
|
||||
sub build_loader_sub {
|
||||
my $caller = caller();
|
||||
|
||||
return _build_loader( $caller, @_ );
|
||||
}
|
||||
|
||||
sub _build_loader {
|
||||
my $package = shift;
|
||||
my %args = @_;
|
||||
|
||||
my @implementations = @{ $args{implementations} };
|
||||
my @symbols = @{ $args{symbols} || [] };
|
||||
|
||||
my $implementation;
|
||||
my $env_var = uc $package;
|
||||
$env_var =~ s/::/_/g;
|
||||
$env_var .= '_IMPLEMENTATION';
|
||||
|
||||
return sub {
|
||||
my ( $implementation, $loaded ) = _load_implementation(
|
||||
$package,
|
||||
$ENV{$env_var},
|
||||
\@implementations,
|
||||
);
|
||||
|
||||
$Implementation{$package} = $implementation;
|
||||
|
||||
_copy_symbols( $loaded, $package, \@symbols );
|
||||
|
||||
return $loaded;
|
||||
};
|
||||
}
|
||||
|
||||
sub implementation_for {
|
||||
my $package = shift;
|
||||
|
||||
return $Implementation{$package};
|
||||
}
|
||||
|
||||
sub _load_implementation {
|
||||
my $package = shift;
|
||||
my $env_value = shift;
|
||||
my $implementations = shift;
|
||||
|
||||
if ($env_value) {
|
||||
die "$env_value is not a valid implementation for $package"
|
||||
unless grep { $_ eq $env_value } @{$implementations};
|
||||
|
||||
my $requested = "${package}::$env_value";
|
||||
|
||||
# Values from the %ENV hash are tainted. We know it's safe to untaint
|
||||
# this value because the value was one of our known implementations.
|
||||
($requested) = $requested =~ /^(.+)$/;
|
||||
|
||||
try {
|
||||
require_module($requested);
|
||||
}
|
||||
catch {
|
||||
require Carp;
|
||||
Carp::croak("Could not load $requested: $_");
|
||||
};
|
||||
|
||||
return ( $env_value, $requested );
|
||||
}
|
||||
else {
|
||||
my $err;
|
||||
for my $possible ( @{$implementations} ) {
|
||||
my $try = "${package}::$possible";
|
||||
|
||||
my $ok;
|
||||
try {
|
||||
require_module($try);
|
||||
$ok = 1;
|
||||
}
|
||||
catch {
|
||||
$err .= $_ if defined $_;
|
||||
};
|
||||
|
||||
return ( $possible, $try ) if $ok;
|
||||
}
|
||||
|
||||
require Carp;
|
||||
if ( defined $err && length $err ) {
|
||||
Carp::croak(
|
||||
"Could not find a suitable $package implementation: $err");
|
||||
}
|
||||
else {
|
||||
Carp::croak(
|
||||
'Module::Runtime failed to load a module but did not throw a real error. This should never happen. Something is very broken'
|
||||
);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _copy_symbols {
|
||||
my $from_package = shift;
|
||||
my $to_package = shift;
|
||||
my $symbols = shift;
|
||||
|
||||
for my $sym ( @{$symbols} ) {
|
||||
my $type = $sym =~ s/^([\$\@\%\&\*])// ? $1 : '&';
|
||||
|
||||
my $from = "${from_package}::$sym";
|
||||
my $to = "${to_package}::$sym";
|
||||
|
||||
{
|
||||
no strict 'refs';
|
||||
no warnings 'once';
|
||||
|
||||
# Copied from Exporter
|
||||
*{$to}
|
||||
= $type eq '&' ? \&{$from}
|
||||
: $type eq '$' ? \${$from}
|
||||
: $type eq '@' ? \@{$from}
|
||||
: $type eq '%' ? \%{$from}
|
||||
: $type eq '*' ? *{$from}
|
||||
: die
|
||||
"Can't copy symbol from $from_package to $to_package: $type$sym";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# ABSTRACT: Loads one of several alternate underlying implementations for a module
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Implementation - Loads one of several alternate underlying implementations for a module
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.09
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Foo::Bar;
|
||||
|
||||
use Module::Implementation;
|
||||
|
||||
BEGIN {
|
||||
my $loader = Module::Implementation::build_loader_sub(
|
||||
implementations => [ 'XS', 'PurePerl' ],
|
||||
symbols => [ 'run', 'check' ],
|
||||
);
|
||||
|
||||
$loader->();
|
||||
}
|
||||
|
||||
package Consumer;
|
||||
|
||||
# loads the first viable implementation
|
||||
use Foo::Bar;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module abstracts out the process of choosing one of several underlying
|
||||
implementations for a module. This can be used to provide XS and pure Perl
|
||||
implementations of a module, or it could be used to load an implementation for
|
||||
a given OS or any other case of needing to provide multiple implementations.
|
||||
|
||||
This module is only useful when you know all the implementations ahead of
|
||||
time. If you want to load arbitrary implementations then you probably want
|
||||
something like a plugin system, not this module.
|
||||
|
||||
=head1 API
|
||||
|
||||
This module provides two subroutines, neither of which are exported.
|
||||
|
||||
=head2 Module::Implementation::build_loader_sub(...)
|
||||
|
||||
This subroutine takes the following arguments.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * implementations
|
||||
|
||||
This should be an array reference of implementation names. Each name should
|
||||
correspond to a module in the caller's namespace.
|
||||
|
||||
In other words, using the example in the L</SYNOPSIS>, this module will look
|
||||
for the C<Foo::Bar::XS> and C<Foo::Bar::PurePerl> modules.
|
||||
|
||||
This argument is required.
|
||||
|
||||
=item * symbols
|
||||
|
||||
A list of symbols to copy from the implementation package to the calling
|
||||
package.
|
||||
|
||||
These can be prefixed with a variable type: C<$>, C<@>, C<%>, C<&>, or
|
||||
C<*)>. If no prefix is given, the symbol is assumed to be a subroutine.
|
||||
|
||||
This argument is optional.
|
||||
|
||||
=back
|
||||
|
||||
This subroutine I<returns> the implementation loader as a sub reference.
|
||||
|
||||
It is up to you to call this loader sub in your code.
|
||||
|
||||
I recommend that you I<do not> call this loader in an C<import()> sub. If a
|
||||
caller explicitly requests no imports, your C<import()> sub will not be run at
|
||||
all, which can cause weird breakage.
|
||||
|
||||
=head2 Module::Implementation::implementation_for($package)
|
||||
|
||||
Given a package name, this subroutine returns the implementation that was
|
||||
loaded for the package. This is not a full package name, just the suffix that
|
||||
identifies the implementation. For the L</SYNOPSIS> example, this subroutine
|
||||
would be called as C<Module::Implementation::implementation_for('Foo::Bar')>,
|
||||
and it would return "XS" or "PurePerl".
|
||||
|
||||
=head1 HOW THE IMPLEMENTATION LOADER WORKS
|
||||
|
||||
The implementation loader works like this ...
|
||||
|
||||
First, it checks for an C<%ENV> var specifying the implementation to load. The
|
||||
env var is based on the package name which loads the implementations. The
|
||||
C<::> package separator is replaced with C<_>, and made entirely
|
||||
upper-case. Finally, we append "_IMPLEMENTATION" to this name.
|
||||
|
||||
So in our L</SYNOPSIS> example, the corresponding C<%ENV> key would be
|
||||
C<FOO_BAR_IMPLEMENTATION>.
|
||||
|
||||
If this is set, then the loader will B<only> try to load this one
|
||||
implementation.
|
||||
|
||||
If the env var requests an implementation which doesn't match one of the
|
||||
implementations specified when the loader was created, an error is thrown.
|
||||
|
||||
If this one implementation fails to load then loader throws an error. This is
|
||||
useful for testing. You can request a specific implementation in a test file
|
||||
by writing something like this:
|
||||
|
||||
BEGIN { $ENV{FOO_BAR_IMPLEMENTATION} = 'XS' }
|
||||
use Foo::Bar;
|
||||
|
||||
If the environment variable is I<not> set, then the loader simply tries the
|
||||
implementations originally passed to C<Module::Implementation>. The
|
||||
implementations are tried in the order in which they were originally passed.
|
||||
|
||||
The loader will use the first implementation that loads without an error. It
|
||||
will copy any requested symbols from this implementation.
|
||||
|
||||
If none of the implementations can be loaded, then the loader throws an
|
||||
exception.
|
||||
|
||||
The loader returns the name of the package it loaded.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2014 by Dave Rolsky.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Artistic License 2.0 (GPL Compatible)
|
||||
|
||||
=cut
|
||||
471
database/perl/vendor/lib/Module/Pluggable.pm
vendored
Normal file
471
database/perl/vendor/lib/Module/Pluggable.pm
vendored
Normal file
@@ -0,0 +1,471 @@
|
||||
package Module::Pluggable;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION $FORCE_SEARCH_ALL_PATHS);
|
||||
use Module::Pluggable::Object;
|
||||
|
||||
use if $] > 5.017, 'deprecate';
|
||||
|
||||
# ObQuote:
|
||||
# Bob Porter: Looks like you've been missing a lot of work lately.
|
||||
# Peter Gibbons: I wouldn't say I've been missing it, Bob!
|
||||
|
||||
|
||||
$VERSION = '5.2';
|
||||
$FORCE_SEARCH_ALL_PATHS = 0;
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
my %opts = @_;
|
||||
|
||||
my ($pkg, $file) = caller;
|
||||
# the default name for the method is 'plugins'
|
||||
my $sub = $opts{'sub_name'} || 'plugins';
|
||||
# get our package
|
||||
my ($package) = $opts{'package'} || $pkg;
|
||||
$opts{filename} = $file;
|
||||
$opts{package} = $package;
|
||||
$opts{force_search_all_paths} = $FORCE_SEARCH_ALL_PATHS unless exists $opts{force_search_all_paths};
|
||||
|
||||
|
||||
my $finder = Module::Pluggable::Object->new(%opts);
|
||||
my $subroutine = sub { my $self = shift; return $finder->plugins(@_) };
|
||||
|
||||
my $searchsub = sub {
|
||||
my $self = shift;
|
||||
my ($action,@paths) = @_;
|
||||
|
||||
$finder->{'search_path'} = ["${package}::Plugin"] if ($action eq 'add' and not $finder->{'search_path'} );
|
||||
push @{$finder->{'search_path'}}, @paths if ($action eq 'add');
|
||||
$finder->{'search_path'} = \@paths if ($action eq 'new');
|
||||
return $finder->{'search_path'};
|
||||
};
|
||||
|
||||
|
||||
my $onlysub = sub {
|
||||
my ($self, $only) = @_;
|
||||
|
||||
if (defined $only) {
|
||||
$finder->{'only'} = $only;
|
||||
};
|
||||
|
||||
return $finder->{'only'};
|
||||
};
|
||||
|
||||
my $exceptsub = sub {
|
||||
my ($self, $except) = @_;
|
||||
|
||||
if (defined $except) {
|
||||
$finder->{'except'} = $except;
|
||||
};
|
||||
|
||||
return $finder->{'except'};
|
||||
};
|
||||
|
||||
|
||||
no strict 'refs';
|
||||
no warnings qw(redefine prototype);
|
||||
|
||||
*{"$package\::$sub"} = $subroutine;
|
||||
*{"$package\::search_path"} = $searchsub;
|
||||
*{"$package\::only"} = $onlysub;
|
||||
*{"$package\::except"} = $exceptsub;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Pluggable - automatically give your module the ability to have plugins
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
|
||||
Simple use Module::Pluggable -
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable;
|
||||
|
||||
|
||||
and then later ...
|
||||
|
||||
use MyClass;
|
||||
my $mc = MyClass->new();
|
||||
# returns the names of all plugins installed under MyClass::Plugin::*
|
||||
my @plugins = $mc->plugins();
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
Why would you want to do this? Say you have something that wants to pass an
|
||||
object to a number of different plugins in turn. For example you may
|
||||
want to extract meta-data from every email you get sent and do something
|
||||
with it. Plugins make sense here because then you can keep adding new
|
||||
meta data parsers and all the logic and docs for each one will be
|
||||
self contained and new handlers are easy to add without changing the
|
||||
core code. For that, you might do something like ...
|
||||
|
||||
package Email::Examiner;
|
||||
|
||||
use strict;
|
||||
use Email::Simple;
|
||||
use Module::Pluggable require => 1;
|
||||
|
||||
sub handle_email {
|
||||
my $self = shift;
|
||||
my $email = shift;
|
||||
|
||||
foreach my $plugin ($self->plugins) {
|
||||
$plugin->examine($email);
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
|
||||
.. and all the plugins will get a chance in turn to look at it.
|
||||
|
||||
This can be trivially extended so that plugins could save the email
|
||||
somewhere and then no other plugin should try and do that.
|
||||
Simply have it so that the C<examine> method returns C<1> if
|
||||
it has saved the email somewhere. You might also want to be paranoid
|
||||
and check to see if the plugin has an C<examine> method.
|
||||
|
||||
foreach my $plugin ($self->plugins) {
|
||||
next unless $plugin->can('examine');
|
||||
last if $plugin->examine($email);
|
||||
}
|
||||
|
||||
|
||||
And so on. The sky's the limit.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Provides a simple but, hopefully, extensible way of having 'plugins' for
|
||||
your module. Obviously this isn't going to be the be all and end all of
|
||||
solutions but it works for me.
|
||||
|
||||
Essentially all it does is export a method into your namespace that
|
||||
looks through a search path for .pm files and turn those into class names.
|
||||
|
||||
Optionally it instantiates those classes for you.
|
||||
|
||||
=head1 ADVANCED USAGE
|
||||
|
||||
Alternatively, if you don't want to use 'plugins' as the method ...
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable sub_name => 'foo';
|
||||
|
||||
|
||||
and then later ...
|
||||
|
||||
my @plugins = $mc->foo();
|
||||
|
||||
|
||||
Or if you want to look in another namespace
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable search_path => ['Acme::MyClass::Plugin', 'MyClass::Extend'];
|
||||
|
||||
or directory
|
||||
|
||||
use Module::Pluggable search_dirs => ['mylibs/Foo'];
|
||||
|
||||
|
||||
Or if you want to instantiate each plugin rather than just return the name
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable instantiate => 'new';
|
||||
|
||||
and then
|
||||
|
||||
# whatever is passed to 'plugins' will be passed
|
||||
# to 'new' for each plugin
|
||||
my @plugins = $mc->plugins(@options);
|
||||
|
||||
|
||||
alternatively you can just require the module without instantiating it
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable require => 1;
|
||||
|
||||
since requiring automatically searches inner packages, which may not be desirable, you can turn this off
|
||||
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable require => 1, inner => 0;
|
||||
|
||||
|
||||
You can limit the plugins loaded using the except option, either as a string,
|
||||
array ref or regex
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable except => 'MyClass::Plugin::Foo';
|
||||
|
||||
or
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable except => ['MyClass::Plugin::Foo', 'MyClass::Plugin::Bar'];
|
||||
|
||||
or
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable except => qr/^MyClass::Plugin::(Foo|Bar)$/;
|
||||
|
||||
|
||||
and similarly for only which will only load plugins which match.
|
||||
|
||||
Remember you can use the module more than once
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable search_path => 'MyClass::Filters' sub_name => 'filters';
|
||||
use Module::Pluggable search_path => 'MyClass::Plugins' sub_name => 'plugins';
|
||||
|
||||
and then later ...
|
||||
|
||||
my @filters = $self->filters;
|
||||
my @plugins = $self->plugins;
|
||||
|
||||
=head1 PLUGIN SEARCHING
|
||||
|
||||
Every time you call 'plugins' the whole search path is walked again. This allows
|
||||
for dynamically loading plugins even at run time. However this can get expensive
|
||||
and so if you don't expect to want to add new plugins at run time you could do
|
||||
|
||||
|
||||
package Foo;
|
||||
use strict;
|
||||
use Module::Pluggable sub_name => '_plugins';
|
||||
|
||||
our @PLUGINS;
|
||||
sub plugins { @PLUGINS ||= shift->_plugins }
|
||||
1;
|
||||
|
||||
=head1 INNER PACKAGES
|
||||
|
||||
If you have, for example, a file B<lib/Something/Plugin/Foo.pm> that
|
||||
contains package definitions for both C<Something::Plugin::Foo> and
|
||||
C<Something::Plugin::Bar> then as long as you either have either
|
||||
the B<require> or B<instantiate> option set then we'll also find
|
||||
C<Something::Plugin::Bar>. Nifty!
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
You can pass a hash of options when importing this module.
|
||||
|
||||
The options can be ...
|
||||
|
||||
=head2 sub_name
|
||||
|
||||
The name of the subroutine to create in your namespace.
|
||||
|
||||
By default this is 'plugins'
|
||||
|
||||
=head2 search_path
|
||||
|
||||
An array ref of namespaces to look in.
|
||||
|
||||
=head2 search_dirs
|
||||
|
||||
An array ref of directories to look in before @INC.
|
||||
|
||||
=head2 instantiate
|
||||
|
||||
Call this method on the class. In general this will probably be 'new'
|
||||
but it can be whatever you want. Whatever arguments are passed to 'plugins'
|
||||
will be passed to the method.
|
||||
|
||||
The default is 'undef' i.e just return the class name.
|
||||
|
||||
=head2 require
|
||||
|
||||
Just require the class, don't instantiate (overrides 'instantiate');
|
||||
|
||||
=head2 inner
|
||||
|
||||
If set to 0 will B<not> search inner packages.
|
||||
If set to 1 will override C<require>.
|
||||
|
||||
=head2 only
|
||||
|
||||
Takes a string, array ref or regex describing the names of the only plugins to
|
||||
return. Whilst this may seem perverse ... well, it is. But it also
|
||||
makes sense. Trust me.
|
||||
|
||||
=head2 except
|
||||
|
||||
Similar to C<only> it takes a description of plugins to exclude
|
||||
from returning. This is slightly less perverse.
|
||||
|
||||
=head2 package
|
||||
|
||||
This is for use by extension modules which build on C<Module::Pluggable>:
|
||||
passing a C<package> option allows you to place the plugin method in a
|
||||
different package other than your own.
|
||||
|
||||
=head2 file_regex
|
||||
|
||||
By default C<Module::Pluggable> only looks for I<.pm> files.
|
||||
|
||||
By supplying a new C<file_regex> then you can change this behaviour e.g
|
||||
|
||||
file_regex => qr/\.plugin$/
|
||||
|
||||
=head2 include_editor_junk
|
||||
|
||||
By default C<Module::Pluggable> ignores files that look like they were
|
||||
left behind by editors. Currently this means files ending in F<~> (~),
|
||||
the extensions F<.swp> or F<.swo>, or files beginning with F<.#>.
|
||||
|
||||
Setting C<include_editor_junk> changes C<Module::Pluggable> so it does
|
||||
not ignore any files it finds.
|
||||
|
||||
=head2 follow_symlinks
|
||||
|
||||
Whether, when searching directories, to follow symlinks.
|
||||
|
||||
Defaults to 1 i.e do follow symlinks.
|
||||
|
||||
=head2 min_depth, max_depth
|
||||
|
||||
This will allow you to set what 'depth' of plugin will be allowed.
|
||||
|
||||
So, for example, C<MyClass::Plugin::Foo> will have a depth of 3 and
|
||||
C<MyClass::Plugin::Foo::Bar> will have a depth of 4 so to only get the former
|
||||
(i.e C<MyClass::Plugin::Foo>) do
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable max_depth => 3;
|
||||
|
||||
and to only get the latter (i.e C<MyClass::Plugin::Foo::Bar>)
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable min_depth => 4;
|
||||
|
||||
|
||||
=head1 TRIGGERS
|
||||
|
||||
Various triggers can also be passed in to the options.
|
||||
|
||||
If any of these triggers return 0 then the plugin will not be returned.
|
||||
|
||||
=head2 before_require <plugin>
|
||||
|
||||
Gets passed the plugin name.
|
||||
|
||||
If 0 is returned then this plugin will not be required either.
|
||||
|
||||
=head2 on_require_error <plugin> <err>
|
||||
|
||||
Gets called when there's an error on requiring the plugin.
|
||||
|
||||
Gets passed the plugin name and the error.
|
||||
|
||||
The default on_require_error handler is to C<carp> the error and return 0.
|
||||
|
||||
=head2 on_instantiate_error <plugin> <err>
|
||||
|
||||
Gets called when there's an error on instantiating the plugin.
|
||||
|
||||
Gets passed the plugin name and the error.
|
||||
|
||||
The default on_instantiate_error handler is to C<carp> the error and return 0.
|
||||
|
||||
=head2 after_require <plugin>
|
||||
|
||||
Gets passed the plugin name.
|
||||
|
||||
If 0 is returned then this plugin will be required but not returned as a plugin.
|
||||
|
||||
=head1 METHODs
|
||||
|
||||
=head2 search_path
|
||||
|
||||
The method C<search_path> is exported into you namespace as well.
|
||||
You can call that at any time to change or replace the
|
||||
search_path.
|
||||
|
||||
$self->search_path( add => "New::Path" ); # add
|
||||
$self->search_path( new => "New::Path" ); # replace
|
||||
|
||||
=head1 BEHAVIOUR UNDER TEST ENVIRONMENT
|
||||
|
||||
In order to make testing reliable we exclude anything not from blib if blib.pm is
|
||||
in %INC.
|
||||
|
||||
However if the module being tested used another module that itself used C<Module::Pluggable>
|
||||
then the second module would fail. This was fixed by checking to see if the caller
|
||||
had (^|/)blib/ in their filename.
|
||||
|
||||
There's an argument that this is the wrong behaviour and that modules should explicitly
|
||||
trigger this behaviour but that particular code has been around for 7 years now and I'm
|
||||
reluctant to change the default behaviour.
|
||||
|
||||
You can now (as of version 4.1) force Module::Pluggable to look outside blib in a test environment by doing either
|
||||
|
||||
require Module::Pluggable;
|
||||
$Module::Pluggable::FORCE_SEARCH_ALL_PATHS = 1;
|
||||
import Module::Pluggable;
|
||||
|
||||
or
|
||||
|
||||
use Module::Pluggable force_search_all_paths => 1;
|
||||
|
||||
=head1 @INC hooks and App::FatPacker
|
||||
|
||||
If a module's @INC has a hook and that hook is an object which has a C<files()> method then we will
|
||||
try and require those files too. See C<t/26inc_hook.t> for an example.
|
||||
|
||||
This has allowed L<App::FatPacker> (as of version 0.10.0) to provide support for Module::Pluggable.
|
||||
|
||||
This should also, theoretically, allow someone to modify PAR to do the same thing.
|
||||
|
||||
=head1 Module::Require recommended
|
||||
|
||||
Up until version 5.2 L<Module::Pluggable> used a string C<eval> to require plugins.
|
||||
|
||||
This has now been changed to optionally use L<Module::Runtime> and it's C<require_module> method when
|
||||
available and fall back to using a path based C<require> when not.
|
||||
|
||||
It's recommended, but not required, that you install Module::Runtime.
|
||||
|
||||
=head1 FUTURE PLANS
|
||||
|
||||
This does everything I need and I can't really think of any other
|
||||
features I want to add. Famous last words of course (not least
|
||||
because we're up to version 5.0 at the time of writing).
|
||||
|
||||
However suggestions (and patches) are always welcome.
|
||||
|
||||
=head1 DEVELOPMENT
|
||||
|
||||
The master repo for this module is at
|
||||
|
||||
https://github.com/simonwistow/Module-Pluggable
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Simon Wistow <simon@thegestalt.org>
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
Copyright, 2006 Simon Wistow
|
||||
|
||||
Distributed under the same terms as Perl itself.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
None known.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Spec>, L<File::Find>, L<File::Basename>, L<Class::Factory::Util>, L<Module::Pluggable::Ordered>
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
429
database/perl/vendor/lib/Module/Pluggable/Object.pm
vendored
Normal file
429
database/perl/vendor/lib/Module/Pluggable/Object.pm
vendored
Normal file
@@ -0,0 +1,429 @@
|
||||
package Module::Pluggable::Object;
|
||||
|
||||
use strict;
|
||||
use File::Find ();
|
||||
use File::Basename;
|
||||
use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
|
||||
use Carp qw(croak carp confess);
|
||||
use Devel::InnerPackage;
|
||||
use vars qw($VERSION $MR);
|
||||
|
||||
use if $] > 5.017, 'deprecate';
|
||||
|
||||
$VERSION = '5.2';
|
||||
|
||||
BEGIN {
|
||||
eval { require Module::Runtime };
|
||||
unless ($@) {
|
||||
Module::Runtime->import('require_module');
|
||||
} else {
|
||||
*require_module = sub {
|
||||
my $module = shift;
|
||||
my $path = $module . ".pm";
|
||||
$path =~ s{::}{/}g;
|
||||
require $path;
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %opts = @_;
|
||||
|
||||
return bless \%opts, $class;
|
||||
|
||||
}
|
||||
|
||||
### Eugggh, this code smells
|
||||
### This is what happens when you keep adding patches
|
||||
### *sigh*
|
||||
|
||||
|
||||
sub plugins {
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
|
||||
# override 'require'
|
||||
$self->{'require'} = 1 if $self->{'inner'};
|
||||
|
||||
my $filename = $self->{'filename'};
|
||||
my $pkg = $self->{'package'};
|
||||
|
||||
# Get the exception params instantiated
|
||||
$self->_setup_exceptions;
|
||||
|
||||
# automatically turn a scalar search path or namespace into a arrayref
|
||||
for (qw(search_path search_dirs)) {
|
||||
$self->{$_} = [ $self->{$_} ] if exists $self->{$_} && !ref($self->{$_});
|
||||
}
|
||||
|
||||
# default search path is '<Module>::<Name>::Plugin'
|
||||
$self->{'search_path'} ||= ["${pkg}::Plugin"];
|
||||
|
||||
# default error handler
|
||||
$self->{'on_require_error'} ||= sub { my ($plugin, $err) = @_; carp "Couldn't require $plugin : $err"; return 0 };
|
||||
$self->{'on_instantiate_error'} ||= sub { my ($plugin, $err) = @_; carp "Couldn't instantiate $plugin: $err"; return 0 };
|
||||
|
||||
# default whether to follow symlinks
|
||||
$self->{'follow_symlinks'} = 1 unless exists $self->{'follow_symlinks'};
|
||||
|
||||
# check to see if we're running under test
|
||||
my @SEARCHDIR = exists $INC{"blib.pm"} && defined $filename && $filename =~ m!(^|/)blib/! && !$self->{'force_search_all_paths'} ? grep {/blib/} @INC : @INC;
|
||||
|
||||
# add any search_dir params
|
||||
unshift @SEARCHDIR, @{$self->{'search_dirs'}} if defined $self->{'search_dirs'};
|
||||
|
||||
# set our @INC up to include and prefer our search_dirs if necessary
|
||||
my @tmp = @INC;
|
||||
unshift @tmp, @{$self->{'search_dirs'} || []};
|
||||
local @INC = @tmp if defined $self->{'search_dirs'};
|
||||
|
||||
my @plugins = $self->search_directories(@SEARCHDIR);
|
||||
push(@plugins, $self->handle_inc_hooks($_, @SEARCHDIR)) for @{$self->{'search_path'}};
|
||||
push(@plugins, $self->handle_innerpackages($_)) for @{$self->{'search_path'}};
|
||||
|
||||
# return blank unless we've found anything
|
||||
return () unless @plugins;
|
||||
|
||||
# remove duplicates
|
||||
# probably not necessary but hey ho
|
||||
my %plugins;
|
||||
for(@plugins) {
|
||||
next unless $self->_is_legit($_);
|
||||
$plugins{$_} = 1;
|
||||
}
|
||||
|
||||
# are we instantiating or requiring?
|
||||
if (defined $self->{'instantiate'}) {
|
||||
my $method = $self->{'instantiate'};
|
||||
my @objs = ();
|
||||
foreach my $package (sort keys %plugins) {
|
||||
next unless $package->can($method);
|
||||
my $obj = eval { $package->$method(@_) };
|
||||
$self->{'on_instantiate_error'}->($package, $@) if $@;
|
||||
push @objs, $obj if $obj;
|
||||
}
|
||||
return @objs;
|
||||
} else {
|
||||
# no? just return the names
|
||||
my @objs= sort keys %plugins;
|
||||
return @objs;
|
||||
}
|
||||
}
|
||||
|
||||
sub _setup_exceptions {
|
||||
my $self = shift;
|
||||
|
||||
my %only;
|
||||
my %except;
|
||||
my $only;
|
||||
my $except;
|
||||
|
||||
if (defined $self->{'only'}) {
|
||||
if (ref($self->{'only'}) eq 'ARRAY') {
|
||||
%only = map { $_ => 1 } @{$self->{'only'}};
|
||||
} elsif (ref($self->{'only'}) eq 'Regexp') {
|
||||
$only = $self->{'only'}
|
||||
} elsif (ref($self->{'only'}) eq '') {
|
||||
$only{$self->{'only'}} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (defined $self->{'except'}) {
|
||||
if (ref($self->{'except'}) eq 'ARRAY') {
|
||||
%except = map { $_ => 1 } @{$self->{'except'}};
|
||||
} elsif (ref($self->{'except'}) eq 'Regexp') {
|
||||
$except = $self->{'except'}
|
||||
} elsif (ref($self->{'except'}) eq '') {
|
||||
$except{$self->{'except'}} = 1;
|
||||
}
|
||||
}
|
||||
$self->{_exceptions}->{only_hash} = \%only;
|
||||
$self->{_exceptions}->{only} = $only;
|
||||
$self->{_exceptions}->{except_hash} = \%except;
|
||||
$self->{_exceptions}->{except} = $except;
|
||||
|
||||
}
|
||||
|
||||
sub _is_legit {
|
||||
my $self = shift;
|
||||
my $plugin = shift;
|
||||
my %only = %{$self->{_exceptions}->{only_hash}||{}};
|
||||
my %except = %{$self->{_exceptions}->{except_hash}||{}};
|
||||
my $only = $self->{_exceptions}->{only};
|
||||
my $except = $self->{_exceptions}->{except};
|
||||
my $depth = () = split '::', $plugin, -1;
|
||||
|
||||
return 0 if (keys %only && !$only{$plugin} );
|
||||
return 0 unless (!defined $only || $plugin =~ m!$only! );
|
||||
|
||||
return 0 if (keys %except && $except{$plugin} );
|
||||
return 0 if (defined $except && $plugin =~ m!$except! );
|
||||
|
||||
return 0 if defined $self->{max_depth} && $depth>$self->{max_depth};
|
||||
return 0 if defined $self->{min_depth} && $depth<$self->{min_depth};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub search_directories {
|
||||
my $self = shift;
|
||||
my @SEARCHDIR = @_;
|
||||
|
||||
my @plugins;
|
||||
# go through our @INC
|
||||
foreach my $dir (@SEARCHDIR) {
|
||||
push @plugins, $self->search_paths($dir);
|
||||
}
|
||||
return @plugins;
|
||||
}
|
||||
|
||||
|
||||
sub search_paths {
|
||||
my $self = shift;
|
||||
my $dir = shift;
|
||||
my @plugins;
|
||||
|
||||
my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
|
||||
|
||||
|
||||
# and each directory in our search path
|
||||
foreach my $searchpath (@{$self->{'search_path'}}) {
|
||||
# create the search directory in a cross platform goodness way
|
||||
my $sp = catdir($dir, (split /::/, $searchpath));
|
||||
|
||||
# if it doesn't exist or it's not a dir then skip it
|
||||
next unless ( -e $sp && -d _ ); # Use the cached stat the second time
|
||||
|
||||
my @files = $self->find_files($sp);
|
||||
|
||||
# foreach one we've found
|
||||
foreach my $file (@files) {
|
||||
# untaint the file; accept .pm only
|
||||
next unless ($file) = ($file =~ /(.*$file_regex)$/);
|
||||
# parse the file to get the name
|
||||
my ($name, $directory, $suffix) = fileparse($file, $file_regex);
|
||||
|
||||
next if (!$self->{include_editor_junk} && $self->_is_editor_junk($name));
|
||||
|
||||
$directory = abs2rel($directory, $sp);
|
||||
|
||||
# If we have a mixed-case package name, assume case has been preserved
|
||||
# correctly. Otherwise, root through the file to locate the case-preserved
|
||||
# version of the package name.
|
||||
my @pkg_dirs = ();
|
||||
if ( $name eq lc($name) || $name eq uc($name) ) {
|
||||
my $pkg_file = catfile($sp, $directory, "$name$suffix");
|
||||
open PKGFILE, "<$pkg_file" or die "search_paths: Can't open $pkg_file: $!";
|
||||
my $in_pod = 0;
|
||||
while ( my $line = <PKGFILE> ) {
|
||||
$in_pod = 1 if $line =~ m/^=\w/;
|
||||
$in_pod = 0 if $line =~ /^=cut/;
|
||||
next if ($in_pod || $line =~ /^=cut/); # skip pod text
|
||||
next if $line =~ /^\s*#/; # and comments
|
||||
if ( $line =~ m/^\s*package\s+(.*::)?($name)\s*;/i ) {
|
||||
@pkg_dirs = split /::/, $1 if defined $1;;
|
||||
$name = $2;
|
||||
last;
|
||||
}
|
||||
}
|
||||
close PKGFILE;
|
||||
}
|
||||
|
||||
# then create the class name in a cross platform way
|
||||
$directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/); # remove volume
|
||||
my @dirs = ();
|
||||
if ($directory) {
|
||||
($directory) = ($directory =~ /(.*)/);
|
||||
@dirs = grep(length($_), splitdir($directory))
|
||||
unless $directory eq curdir();
|
||||
for my $d (reverse @dirs) {
|
||||
my $pkg_dir = pop @pkg_dirs;
|
||||
last unless defined $pkg_dir;
|
||||
$d =~ s/\Q$pkg_dir\E/$pkg_dir/i; # Correct case
|
||||
}
|
||||
} else {
|
||||
$directory = "";
|
||||
}
|
||||
my $plugin = join '::', $searchpath, @dirs, $name;
|
||||
|
||||
next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]*!i;
|
||||
|
||||
$self->handle_finding_plugin($plugin, \@plugins)
|
||||
}
|
||||
|
||||
# now add stuff that may have been in package
|
||||
# NOTE we should probably use all the stuff we've been given already
|
||||
# but then we can't unload it :(
|
||||
push @plugins, $self->handle_innerpackages($searchpath);
|
||||
} # foreach $searchpath
|
||||
|
||||
return @plugins;
|
||||
}
|
||||
|
||||
sub _is_editor_junk {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
|
||||
# Emacs (and other Unix-y editors) leave temp files ending in a
|
||||
# tilde as a backup.
|
||||
return 1 if $name =~ /~$/;
|
||||
# Emacs makes these files while a buffer is edited but not yet
|
||||
# saved.
|
||||
return 1 if $name =~ /^\.#/;
|
||||
# Vim can leave these files behind if it crashes.
|
||||
return 1 if $name =~ /\.sw[po]$/;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub handle_finding_plugin {
|
||||
my $self = shift;
|
||||
my $plugin = shift;
|
||||
my $plugins = shift;
|
||||
my $no_req = shift || 0;
|
||||
|
||||
return unless $self->_is_legit($plugin);
|
||||
unless (defined $self->{'instantiate'} || $self->{'require'}) {
|
||||
push @$plugins, $plugin;
|
||||
return;
|
||||
}
|
||||
|
||||
$self->{before_require}->($plugin) || return if defined $self->{before_require};
|
||||
unless ($no_req) {
|
||||
my $tmp = $@;
|
||||
my $res = eval { require_module($plugin) };
|
||||
my $err = $@;
|
||||
$@ = $tmp;
|
||||
if ($err) {
|
||||
if (defined $self->{on_require_error}) {
|
||||
$self->{on_require_error}->($plugin, $err) || return;
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
$self->{after_require}->($plugin) || return if defined $self->{after_require};
|
||||
push @$plugins, $plugin;
|
||||
}
|
||||
|
||||
sub find_files {
|
||||
my $self = shift;
|
||||
my $search_path = shift;
|
||||
my $file_regex = $self->{'file_regex'} || qr/\.pm$/;
|
||||
|
||||
|
||||
# find all the .pm files in it
|
||||
# this isn't perfect and won't find multiple plugins per file
|
||||
#my $cwd = Cwd::getcwd;
|
||||
my @files = ();
|
||||
{ # for the benefit of perl 5.6.1's Find, localize topic
|
||||
local $_;
|
||||
File::Find::find( { no_chdir => 1,
|
||||
follow => $self->{'follow_symlinks'},
|
||||
wanted => sub {
|
||||
# Inlined from File::Find::Rule C< name => '*.pm' >
|
||||
return unless $File::Find::name =~ /$file_regex/;
|
||||
(my $path = $File::Find::name) =~ s#^\\./##;
|
||||
push @files, $path;
|
||||
}
|
||||
}, $search_path );
|
||||
}
|
||||
#chdir $cwd;
|
||||
return @files;
|
||||
|
||||
}
|
||||
|
||||
sub handle_inc_hooks {
|
||||
my $self = shift;
|
||||
my $path = shift;
|
||||
my @SEARCHDIR = @_;
|
||||
|
||||
my @plugins;
|
||||
for my $dir ( @SEARCHDIR ) {
|
||||
next unless ref $dir && eval { $dir->can( 'files' ) };
|
||||
|
||||
foreach my $plugin ( $dir->files ) {
|
||||
$plugin =~ s/\.pm$//;
|
||||
$plugin =~ s{/}{::}g;
|
||||
next unless $plugin =~ m!^${path}::!;
|
||||
$self->handle_finding_plugin( $plugin, \@plugins );
|
||||
}
|
||||
}
|
||||
return @plugins;
|
||||
}
|
||||
|
||||
sub handle_innerpackages {
|
||||
my $self = shift;
|
||||
return () if (exists $self->{inner} && !$self->{inner});
|
||||
|
||||
my $path = shift;
|
||||
my @plugins;
|
||||
|
||||
foreach my $plugin (Devel::InnerPackage::list_packages($path)) {
|
||||
$self->handle_finding_plugin($plugin, \@plugins, 1);
|
||||
}
|
||||
return @plugins;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Pluggable::Object - automatically give your module the ability to have plugins
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
|
||||
Simple use Module::Pluggable -
|
||||
|
||||
package MyClass;
|
||||
use Module::Pluggable::Object;
|
||||
|
||||
my $finder = Module::Pluggable::Object->new(%opts);
|
||||
print "My plugins are: ".join(", ", $finder->plugins)."\n";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Provides a simple but, hopefully, extensible way of having 'plugins' for
|
||||
your module. Obviously this isn't going to be the be all and end all of
|
||||
solutions but it works for me.
|
||||
|
||||
Essentially all it does is export a method into your namespace that
|
||||
looks through a search path for .pm files and turn those into class names.
|
||||
|
||||
Optionally it instantiates those classes for you.
|
||||
|
||||
This object is wrapped by C<Module::Pluggable>. If you want to do something
|
||||
odd or add non-general special features you're probably best to wrap this
|
||||
and produce your own subclass.
|
||||
|
||||
=head1 OPTIONS
|
||||
|
||||
See the C<Module::Pluggable> docs.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Simon Wistow <simon@thegestalt.org>
|
||||
|
||||
=head1 COPYING
|
||||
|
||||
Copyright, 2006 Simon Wistow
|
||||
|
||||
Distributed under the same terms as Perl itself.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
None known.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Module::Pluggable>
|
||||
|
||||
=cut
|
||||
|
||||
515
database/perl/vendor/lib/Module/Runtime.pm
vendored
Normal file
515
database/perl/vendor/lib/Module/Runtime.pm
vendored
Normal file
@@ -0,0 +1,515 @@
|
||||
=head1 NAME
|
||||
|
||||
Module::Runtime - runtime module handling
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Module::Runtime qw(
|
||||
$module_name_rx is_module_name check_module_name
|
||||
module_notional_filename require_module);
|
||||
|
||||
if($module_name =~ /\A$module_name_rx\z/o) { ...
|
||||
if(is_module_name($module_name)) { ...
|
||||
check_module_name($module_name);
|
||||
|
||||
$notional_filename = module_notional_filename($module_name);
|
||||
require_module($module_name);
|
||||
|
||||
use Module::Runtime qw(use_module use_package_optimistically);
|
||||
|
||||
$bi = use_module("Math::BigInt", 1.31)->new("1_234");
|
||||
$widget = use_package_optimistically("Local::Widget")->new;
|
||||
|
||||
use Module::Runtime qw(
|
||||
$top_module_spec_rx $sub_module_spec_rx
|
||||
is_module_spec check_module_spec
|
||||
compose_module_name);
|
||||
|
||||
if($spec =~ /\A$top_module_spec_rx\z/o) { ...
|
||||
if($spec =~ /\A$sub_module_spec_rx\z/o) { ...
|
||||
if(is_module_spec("Standard::Prefix", $spec)) { ...
|
||||
check_module_spec("Standard::Prefix", $spec);
|
||||
|
||||
$module_name = compose_module_name("Standard::Prefix", $spec);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The functions exported by this module deal with runtime handling of
|
||||
Perl modules, which are normally handled at compile time. This module
|
||||
avoids using any other modules, so that it can be used in low-level
|
||||
infrastructure.
|
||||
|
||||
The parts of this module that work with module names apply the same syntax
|
||||
that is used for barewords in Perl source. In principle this syntax
|
||||
can vary between versions of Perl, and this module applies the syntax of
|
||||
the Perl on which it is running. In practice the usable syntax hasn't
|
||||
changed yet. There's some intent for Unicode module names to be supported
|
||||
in the future, but this hasn't yet amounted to any consistent facility.
|
||||
|
||||
The functions of this module whose purpose is to load modules include
|
||||
workarounds for three old Perl core bugs regarding C<require>. These
|
||||
workarounds are applied on any Perl version where the bugs exist, except
|
||||
for a case where one of the bugs cannot be adequately worked around in
|
||||
pure Perl.
|
||||
|
||||
=head2 Module name syntax
|
||||
|
||||
The usable module name syntax has not changed from Perl 5.000 up to
|
||||
Perl 5.19.8. The syntax is composed entirely of ASCII characters.
|
||||
From Perl 5.6 onwards there has been some attempt to allow the use of
|
||||
non-ASCII Unicode characters in Perl source, but it was fundamentally
|
||||
broken (like the entirety of Perl 5.6's Unicode handling) and remained
|
||||
pretty much entirely unusable until it got some attention in the Perl
|
||||
5.15 series. Although Unicode is now consistently accepted by the
|
||||
parser in some places, it remains broken for module names. Furthermore,
|
||||
there has not yet been any work on how to map Unicode module names into
|
||||
filenames, so in that respect also Unicode module names are unusable.
|
||||
|
||||
The module name syntax is, precisely: the string must consist of one or
|
||||
more segments separated by C<::>; each segment must consist of one or more
|
||||
identifier characters (ASCII alphanumerics plus "_"); the first character
|
||||
of the string must not be a digit. Thus "C<IO::File>", "C<warnings>",
|
||||
and "C<foo::123::x_0>" are all valid module names, whereas "C<IO::>"
|
||||
and "C<1foo::bar>" are not. C<'> separators are not permitted by this
|
||||
module, though they remain usable in Perl source, being translated to
|
||||
C<::> in the parser.
|
||||
|
||||
=head2 Core bugs worked around
|
||||
|
||||
The first bug worked around is core bug [perl #68590], which causes
|
||||
lexical state in one file to leak into another that is C<require>d/C<use>d
|
||||
from it. This bug is present from Perl 5.6 up to Perl 5.10, and is
|
||||
fixed in Perl 5.11.0. From Perl 5.9.4 up to Perl 5.10.0 no satisfactory
|
||||
workaround is possible in pure Perl. The workaround means that modules
|
||||
loaded via this module don't suffer this pollution of their lexical
|
||||
state. Modules loaded in other ways, or via this module on the Perl
|
||||
versions where the pure Perl workaround is impossible, remain vulnerable.
|
||||
The module L<Lexical::SealRequireHints> provides a complete workaround
|
||||
for this bug.
|
||||
|
||||
The second bug worked around causes some kinds of failure in module
|
||||
loading, principally compilation errors in the loaded module, to be
|
||||
recorded in C<%INC> as if they were successful, so later attempts to load
|
||||
the same module immediately indicate success. This bug is present up
|
||||
to Perl 5.8.9, and is fixed in Perl 5.9.0. The workaround means that a
|
||||
compilation error in a module loaded via this module won't be cached as
|
||||
a success. Modules loaded in other ways remain liable to produce bogus
|
||||
C<%INC> entries, and if a bogus entry exists then it will mislead this
|
||||
module if it is used to re-attempt loading.
|
||||
|
||||
The third bug worked around causes the wrong context to be seen at
|
||||
file scope of a loaded module, if C<require> is invoked in a location
|
||||
that inherits context from a higher scope. This bug is present up to
|
||||
Perl 5.11.2, and is fixed in Perl 5.11.3. The workaround means that
|
||||
a module loaded via this module will always see the correct context.
|
||||
Modules loaded in other ways remain vulnerable.
|
||||
|
||||
=cut
|
||||
|
||||
package Module::Runtime;
|
||||
|
||||
# Don't "use 5.006" here, because Perl 5.15.6 will load feature.pm if
|
||||
# the version check is done that way.
|
||||
BEGIN { require 5.006; }
|
||||
# Don't "use warnings" here, to avoid dependencies. Do standardise the
|
||||
# warning status by lexical override; unfortunately the only safe bitset
|
||||
# to build in is the empty set, equivalent to "no warnings".
|
||||
BEGIN { ${^WARNING_BITS} = ""; }
|
||||
# Don't "use strict" here, to avoid dependencies.
|
||||
|
||||
our $VERSION = "0.016";
|
||||
|
||||
# Don't use Exporter here, to avoid dependencies.
|
||||
our @EXPORT_OK = qw(
|
||||
$module_name_rx is_module_name is_valid_module_name check_module_name
|
||||
module_notional_filename require_module
|
||||
use_module use_package_optimistically
|
||||
$top_module_spec_rx $sub_module_spec_rx
|
||||
is_module_spec is_valid_module_spec check_module_spec
|
||||
compose_module_name
|
||||
);
|
||||
my %export_ok = map { ($_ => undef) } @EXPORT_OK;
|
||||
sub import {
|
||||
my $me = shift;
|
||||
my $callpkg = caller(0);
|
||||
my $errs = "";
|
||||
foreach(@_) {
|
||||
if(exists $export_ok{$_}) {
|
||||
# We would need to do "no strict 'refs'" here
|
||||
# if we had enabled strict at file scope.
|
||||
if(/\A\$(.*)\z/s) {
|
||||
*{$callpkg."::".$1} = \$$1;
|
||||
} else {
|
||||
*{$callpkg."::".$_} = \&$_;
|
||||
}
|
||||
} else {
|
||||
$errs .= "\"$_\" is not exported by the $me module\n";
|
||||
}
|
||||
}
|
||||
if($errs ne "") {
|
||||
die "${errs}Can't continue after import errors ".
|
||||
"at @{[(caller(0))[1]]} line @{[(caller(0))[2]]}.\n";
|
||||
}
|
||||
}
|
||||
|
||||
# Logic duplicated from Params::Classify. Duplicating it here avoids
|
||||
# an extensive and potentially circular dependency graph.
|
||||
sub _is_string($) {
|
||||
my($arg) = @_;
|
||||
return defined($arg) && ref(\$arg) eq "SCALAR";
|
||||
}
|
||||
|
||||
=head1 REGULAR EXPRESSIONS
|
||||
|
||||
These regular expressions do not include any anchors, so to check
|
||||
whether an entire string matches a syntax item you must supply the
|
||||
anchors yourself.
|
||||
|
||||
=over
|
||||
|
||||
=item $module_name_rx
|
||||
|
||||
Matches a valid Perl module name in bareword syntax.
|
||||
|
||||
=cut
|
||||
|
||||
our $module_name_rx = qr/[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/;
|
||||
|
||||
=item $top_module_spec_rx
|
||||
|
||||
Matches a module specification for use with L</compose_module_name>,
|
||||
where no prefix is being used.
|
||||
|
||||
=cut
|
||||
|
||||
my $qual_module_spec_rx =
|
||||
qr#(?:/|::)[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*#;
|
||||
|
||||
my $unqual_top_module_spec_rx =
|
||||
qr#[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*#;
|
||||
|
||||
our $top_module_spec_rx = qr/$qual_module_spec_rx|$unqual_top_module_spec_rx/o;
|
||||
|
||||
=item $sub_module_spec_rx
|
||||
|
||||
Matches a module specification for use with L</compose_module_name>,
|
||||
where a prefix is being used.
|
||||
|
||||
=cut
|
||||
|
||||
my $unqual_sub_module_spec_rx = qr#[0-9A-Z_a-z]+(?:(?:/|::)[0-9A-Z_a-z]+)*#;
|
||||
|
||||
our $sub_module_spec_rx = qr/$qual_module_spec_rx|$unqual_sub_module_spec_rx/o;
|
||||
|
||||
=back
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 Basic module handling
|
||||
|
||||
=over
|
||||
|
||||
=item is_module_name(ARG)
|
||||
|
||||
Returns a truth value indicating whether I<ARG> is a plain string
|
||||
satisfying Perl module name syntax as described for L</$module_name_rx>.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_module_name($) { _is_string($_[0]) && $_[0] =~ /\A$module_name_rx\z/o }
|
||||
|
||||
=item is_valid_module_name(ARG)
|
||||
|
||||
Deprecated alias for L</is_module_name>.
|
||||
|
||||
=cut
|
||||
|
||||
*is_valid_module_name = \&is_module_name;
|
||||
|
||||
=item check_module_name(ARG)
|
||||
|
||||
Check whether I<ARG> is a plain string
|
||||
satisfying Perl module name syntax as described for L</$module_name_rx>.
|
||||
Return normally if it is, or C<die> if it is not.
|
||||
|
||||
=cut
|
||||
|
||||
sub check_module_name($) {
|
||||
unless(&is_module_name) {
|
||||
die +(_is_string($_[0]) ? "`$_[0]'" : "argument").
|
||||
" is not a module name\n";
|
||||
}
|
||||
}
|
||||
|
||||
=item module_notional_filename(NAME)
|
||||
|
||||
Generates a notional relative filename for a module, which is used in
|
||||
some Perl core interfaces.
|
||||
The I<NAME> is a string, which should be a valid module name (one or
|
||||
more C<::>-separated segments). If it is not a valid name, the function
|
||||
C<die>s.
|
||||
|
||||
The notional filename for the named module is generated and returned.
|
||||
This filename is always in Unix style, with C</> directory separators
|
||||
and a C<.pm> suffix. This kind of filename can be used as an argument to
|
||||
C<require>, and is the key that appears in C<%INC> to identify a module,
|
||||
regardless of actual local filename syntax.
|
||||
|
||||
=cut
|
||||
|
||||
sub module_notional_filename($) {
|
||||
&check_module_name;
|
||||
my($name) = @_;
|
||||
$name =~ s!::!/!g;
|
||||
return $name.".pm";
|
||||
}
|
||||
|
||||
=item require_module(NAME)
|
||||
|
||||
This is essentially the bareword form of C<require>, in runtime form.
|
||||
The I<NAME> is a string, which should be a valid module name (one or
|
||||
more C<::>-separated segments). If it is not a valid name, the function
|
||||
C<die>s.
|
||||
|
||||
The module specified by I<NAME> is loaded, if it hasn't been already,
|
||||
in the manner of the bareword form of C<require>. That means that a
|
||||
search through C<@INC> is performed, and a byte-compiled form of the
|
||||
module will be used if available.
|
||||
|
||||
The return value is as for C<require>. That is, it is the value returned
|
||||
by the module itself if the module is loaded anew, or C<1> if the module
|
||||
was already loaded.
|
||||
|
||||
=cut
|
||||
|
||||
# Don't "use constant" here, to avoid dependencies.
|
||||
BEGIN {
|
||||
*_WORK_AROUND_HINT_LEAKAGE =
|
||||
"$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001)
|
||||
? sub(){1} : sub(){0};
|
||||
*_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0};
|
||||
}
|
||||
|
||||
BEGIN { if(_WORK_AROUND_BROKEN_MODULE_STATE) { eval q{
|
||||
sub Module::Runtime::__GUARD__::DESTROY {
|
||||
delete $INC{$_[0]->[0]} if @{$_[0]};
|
||||
}
|
||||
1;
|
||||
}; die $@ if $@ ne ""; } }
|
||||
|
||||
sub require_module($) {
|
||||
# Localise %^H to work around [perl #68590], where the bug exists
|
||||
# and this is a satisfactory workaround. The bug consists of
|
||||
# %^H state leaking into each required module, polluting the
|
||||
# module's lexical state.
|
||||
local %^H if _WORK_AROUND_HINT_LEAKAGE;
|
||||
if(_WORK_AROUND_BROKEN_MODULE_STATE) {
|
||||
my $notional_filename = &module_notional_filename;
|
||||
my $guard = bless([ $notional_filename ],
|
||||
"Module::Runtime::__GUARD__");
|
||||
my $result = CORE::require($notional_filename);
|
||||
pop @$guard;
|
||||
return $result;
|
||||
} else {
|
||||
return scalar(CORE::require(&module_notional_filename));
|
||||
}
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head2 Structured module use
|
||||
|
||||
=over
|
||||
|
||||
=item use_module(NAME[, VERSION])
|
||||
|
||||
This is essentially C<use> in runtime form, but without the importing
|
||||
feature (which is fundamentally a compile-time thing). The I<NAME> is
|
||||
handled just like in C<require_module> above: it must be a module name,
|
||||
and the named module is loaded as if by the bareword form of C<require>.
|
||||
|
||||
If a I<VERSION> is specified, the C<VERSION> method of the loaded module is
|
||||
called with the specified I<VERSION> as an argument. This normally serves to
|
||||
ensure that the version loaded is at least the version required. This is
|
||||
the same functionality provided by the I<VERSION> parameter of C<use>.
|
||||
|
||||
On success, the name of the module is returned. This is unlike
|
||||
L</require_module>, and is done so that the entire call to L</use_module>
|
||||
can be used as a class name to call a constructor, as in the example in
|
||||
the synopsis.
|
||||
|
||||
=cut
|
||||
|
||||
sub use_module($;$) {
|
||||
my($name, $version) = @_;
|
||||
require_module($name);
|
||||
$name->VERSION($version) if @_ >= 2;
|
||||
return $name;
|
||||
}
|
||||
|
||||
=item use_package_optimistically(NAME[, VERSION])
|
||||
|
||||
This is an analogue of L</use_module> for the situation where there is
|
||||
uncertainty as to whether a package/class is defined in its own module
|
||||
or by some other means. It attempts to arrange for the named package to
|
||||
be available, either by loading a module or by doing nothing and hoping.
|
||||
|
||||
An attempt is made to load the named module (as if by the bareword form
|
||||
of C<require>). If the module cannot be found then it is assumed that
|
||||
the package was actually already loaded by other means, and no error
|
||||
is signalled. That's the optimistic bit.
|
||||
|
||||
I<Warning:> this optional module loading is liable to cause unreliable
|
||||
behaviour, including security problems. It interacts especially badly
|
||||
with having C<.> in C<@INC>, which was the default state of affairs in
|
||||
Perls prior to 5.25.11. If a package is actually defined by some means
|
||||
other than a module, then applying this function to it causes a spurious
|
||||
attempt to load a module that is expected to be non-existent. If a
|
||||
module actually exists under that name then it will be unintentionally
|
||||
loaded. If C<.> is in C<@INC> and this code is ever run with the current
|
||||
directory being one writable by a malicious user (such as F</tmp>), then
|
||||
the malicious user can easily cause the victim to run arbitrary code, by
|
||||
creating a module file under the predictable spuriously-loaded name in the
|
||||
writable directory. Generally, optional module loading should be avoided.
|
||||
|
||||
This is mostly the same operation that is performed by the L<base> pragma
|
||||
to ensure that the specified base classes are available. The behaviour
|
||||
of L<base> was simplified in version 2.18, and later improved in version
|
||||
2.20, and on both occasions this function changed to match.
|
||||
|
||||
If a I<VERSION> is specified, the C<VERSION> method of the loaded package is
|
||||
called with the specified I<VERSION> as an argument. This normally serves
|
||||
to ensure that the version loaded is at least the version required.
|
||||
On success, the name of the package is returned. These aspects of the
|
||||
function work just like L</use_module>.
|
||||
|
||||
=cut
|
||||
|
||||
sub use_package_optimistically($;$) {
|
||||
my($name, $version) = @_;
|
||||
my $fn = module_notional_filename($name);
|
||||
eval { local $SIG{__DIE__}; require_module($name); };
|
||||
die $@ if $@ ne "" &&
|
||||
($@ !~ /\ACan't locate \Q$fn\E .+ at \Q@{[__FILE__]}\E line/s ||
|
||||
$@ =~ /^Compilation\ failed\ in\ require
|
||||
\ at\ \Q@{[__FILE__]}\E\ line/xm);
|
||||
$name->VERSION($version) if @_ >= 2;
|
||||
return $name;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head2 Module name composition
|
||||
|
||||
=over
|
||||
|
||||
=item is_module_spec(PREFIX, SPEC)
|
||||
|
||||
Returns a truth value indicating
|
||||
whether I<SPEC> is valid input for L</compose_module_name>.
|
||||
See below for what that entails. Whether a I<PREFIX> is supplied affects
|
||||
the validity of I<SPEC>, but the exact value of the prefix is unimportant,
|
||||
so this function treats I<PREFIX> as a truth value.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_module_spec($$) {
|
||||
my($prefix, $spec) = @_;
|
||||
return _is_string($spec) &&
|
||||
$spec =~ ($prefix ? qr/\A$sub_module_spec_rx\z/o :
|
||||
qr/\A$top_module_spec_rx\z/o);
|
||||
}
|
||||
|
||||
=item is_valid_module_spec(PREFIX, SPEC)
|
||||
|
||||
Deprecated alias for L</is_module_spec>.
|
||||
|
||||
=cut
|
||||
|
||||
*is_valid_module_spec = \&is_module_spec;
|
||||
|
||||
=item check_module_spec(PREFIX, SPEC)
|
||||
|
||||
Check whether I<SPEC> is valid input for L</compose_module_name>.
|
||||
Return normally if it is, or C<die> if it is not.
|
||||
|
||||
=cut
|
||||
|
||||
sub check_module_spec($$) {
|
||||
unless(&is_module_spec) {
|
||||
die +(_is_string($_[1]) ? "`$_[1]'" : "argument").
|
||||
" is not a module specification\n";
|
||||
}
|
||||
}
|
||||
|
||||
=item compose_module_name(PREFIX, SPEC)
|
||||
|
||||
This function is intended to make it more convenient for a user to specify
|
||||
a Perl module name at runtime. Users have greater need for abbreviations
|
||||
and context-sensitivity than programmers, and Perl module names get a
|
||||
little unwieldy. I<SPEC> is what the user specifies, and this function
|
||||
translates it into a module name in standard form, which it returns.
|
||||
|
||||
I<SPEC> has syntax approximately that of a standard module name: it
|
||||
should consist of one or more name segments, each of which consists
|
||||
of one or more identifier characters. However, C</> is permitted as a
|
||||
separator, in addition to the standard C<::>. The two separators are
|
||||
entirely interchangeable.
|
||||
|
||||
Additionally, if I<PREFIX> is not C<undef> then it must be a module
|
||||
name in standard form, and it is prefixed to the user-specified name.
|
||||
The user can inhibit the prefix addition by starting I<SPEC> with a
|
||||
separator (either C</> or C<::>).
|
||||
|
||||
=cut
|
||||
|
||||
sub compose_module_name($$) {
|
||||
my($prefix, $spec) = @_;
|
||||
check_module_name($prefix) if defined $prefix;
|
||||
&check_module_spec;
|
||||
if($spec =~ s#\A(?:/|::)##) {
|
||||
# OK
|
||||
} else {
|
||||
$spec = $prefix."::".$spec if defined $prefix;
|
||||
}
|
||||
$spec =~ s#/#::#g;
|
||||
return $spec;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
On Perl versions 5.7.2 to 5.8.8, if C<require> is overridden by the
|
||||
C<CORE::GLOBAL> mechanism, it is likely to break the heuristics used by
|
||||
L</use_package_optimistically>, making it signal an error for a missing
|
||||
module rather than assume that it was already loaded. From Perl 5.8.9
|
||||
onwards, and on 5.7.1 and earlier, this module can avoid being confused
|
||||
by such an override. On the affected versions, a C<require> override
|
||||
might be installed by L<Lexical::SealRequireHints>, if something requires
|
||||
its bugfix but for some reason its XS implementation isn't available.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Lexical::SealRequireHints>,
|
||||
L<base>,
|
||||
L<perlfunc/require>,
|
||||
L<perlfunc/use>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Andrew Main (Zefram) <zefram@fysh.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (C) 2004, 2006, 2007, 2009, 2010, 2011, 2012, 2014, 2017
|
||||
Andrew Main (Zefram) <zefram@fysh.org>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
105
database/perl/vendor/lib/Module/Runtime/Conflicts.pm
vendored
Normal file
105
database/perl/vendor/lib/Module/Runtime/Conflicts.pm
vendored
Normal file
@@ -0,0 +1,105 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
package Module::Runtime::Conflicts; # git description: v0.002-9-gc4cd9f2
|
||||
# vim: set ts=8 sts=4 sw=4 tw=115 et :
|
||||
# ABSTRACT: Provide information on conflicts for Module::Runtime
|
||||
# KEYWORDS: conflicts breaks modules prerequisites upgrade
|
||||
|
||||
our $VERSION = '0.003';
|
||||
|
||||
use Module::Runtime ();
|
||||
use Dist::CheckConflicts
|
||||
-dist => 'Module::Runtime',
|
||||
-conflicts => {
|
||||
# listed modules are the highest *non-working* version when used in
|
||||
# combination with the indicated version of Module::Runtime
|
||||
|
||||
eval { Module::Runtime->VERSION('0.014'); 1 } ? (
|
||||
'Moose' => '2.1202',
|
||||
'MooseX::NonMoose' => '0.24',
|
||||
'Elasticsearch' => '1.00',
|
||||
) : (),
|
||||
},
|
||||
-also => [
|
||||
'Package::Stash::Conflicts',
|
||||
'Moose::Conflicts',
|
||||
];
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Module::Runtime::Conflicts - Provide information on conflicts for Module::Runtime
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.003
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
`moose-outdated`
|
||||
|
||||
or
|
||||
|
||||
use Module::Runtime::Conflicts;
|
||||
Module::Runtime::Conflicts->check_conflicts;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides conflicts checking for L<Module::Runtime>, which had a
|
||||
recent release that broke some versions of L<Moose>. It is called from
|
||||
L<Moose::Conflicts> and C<moose-outdated>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
L<Dist::CheckConflicts>
|
||||
|
||||
=item *
|
||||
|
||||
L<Moose::Conflicts>
|
||||
|
||||
=item *
|
||||
|
||||
L<Dist::Zilla::Plugin::Breaks>
|
||||
|
||||
=item *
|
||||
|
||||
L<Dist::Zilla::Plugin::Test::CheckBreaks>
|
||||
|
||||
=back
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Runtime-Conflicts>
|
||||
(or L<bug-Module-Runtime-Conflicts@rt.cpan.org|mailto:bug-Module-Runtime-Conflicts@rt.cpan.org>).
|
||||
|
||||
There is also a mailing list available for users of this distribution, at
|
||||
L<http://lists.perl.org/list/cpan-workers.html>.
|
||||
|
||||
There is also an irc channel available for users of this distribution, at
|
||||
L<C<#toolchain> on C<irc.perl.org>|irc://irc.perl.org/#toolchain>.
|
||||
|
||||
I am also usually active on irc, as 'ether' at C<irc.perl.org>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENCE
|
||||
|
||||
This software is copyright (c) 2014 by Karen Etheridge.
|
||||
|
||||
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
|
||||
Reference in New Issue
Block a user