KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

944
database/perl/vendor/lib/Class/Accessor/Grouped.pm vendored Normal file
View File

@@ -0,0 +1,944 @@
package Class::Accessor::Grouped;
use strict;
use warnings;
use Carp ();
use Scalar::Util ();
use Module::Runtime ();
BEGIN {
# use M::R to work around the 5.8 require bugs
if ($] < 5.009_005) {
Module::Runtime::require_module('MRO::Compat');
}
else {
require mro;
}
}
our $VERSION = '0.10014';
$VERSION =~ tr/_//d; # numify for warning-free dev releases
# when changing minimum version don't forget to adjust Makefile.PL as well
our $__minimum_xsa_version;
BEGIN { $__minimum_xsa_version = '1.19' }
our $USE_XS;
# the unless defined is here so that we can override the value
# before require/use, *regardless* of the state of $ENV{CAG_USE_XS}
$USE_XS = $ENV{CAG_USE_XS}
unless defined $USE_XS;
BEGIN {
package # hide from PAUSE
__CAG_ENV__;
die "Huh?! No minimum C::XSA version?!\n"
unless $__minimum_xsa_version;
local $@;
require constant;
# individual (one const at a time) imports so we are 5.6.2 compatible
# if we can - why not ;)
constant->import( NO_SUBNAME => eval {
Module::Runtime::require_module('Sub::Name')
} ? 0 : "$@" );
my $found_cxsa;
constant->import( NO_CXSA => ( NO_SUBNAME() || ( eval {
Module::Runtime::require_module('Class::XSAccessor');
$found_cxsa = Class::XSAccessor->VERSION;
Class::XSAccessor->VERSION($__minimum_xsa_version);
} ? 0 : "$@" ) ) );
if (NO_CXSA() and $found_cxsa and !$ENV{CAG_OLD_XS_NOWARN}) {
warn(
'The installed version of Class::XSAccessor is too old '
. "(v$found_cxsa < v$__minimum_xsa_version). Please upgrade "
. "to instantly quadruple the performance of 'simple' accessors. "
. 'Set $ENV{CAG_OLD_XS_NOWARN} if you wish to disable this '
. "warning.\n"
);
}
constant->import( BROKEN_GOTO => ($] < '5.008009') ? 1 : 0 );
constant->import( UNSTABLE_DOLLARAT => ($] < '5.013002') ? 1 : 0 );
constant->import( TRACK_UNDEFER_FAIL => (
$INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'}
and
$0 =~ m{ ^ (?: \. \/ )? x?t / .+ \.t $}x
) ? 1 : 0 );
sub perlstring ($) { q{"}. quotemeta( shift ). q{"} };
}
# Yes this method is undocumented
# Yes it should be a private coderef like all the rest at the end of this file
# No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
# %$*@!?&!&#*$!!!
my $illegal_accessors_warned;
sub _mk_group_accessors {
my($self, $maker, $group, @fields) = @_;
my $class = length (ref ($self) ) ? ref ($self) : $self;
no strict 'refs';
no warnings 'redefine';
# So we don't have to do lots of lookups inside the loop.
$maker = $self->can($maker) unless ref $maker;
for (@fields) {
my ($name, $field) = (ref $_) ? (@$_) : ($_, $_);
if ($name !~ /\A[A-Z_a-z][0-9A-Z_a-z]*\z/) {
if ($name =~ /\0/) {
Carp::croak(sprintf
"Illegal accessor name %s - nulls should never appear in stash keys",
__CAG_ENV__::perlstring($name),
);
}
elsif (! $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} ) {
Carp::croak(
"Illegal accessor name '$name'. If you want CAG to attempt creating "
. 'it anyway (possible if Sub::Name is available) set '
. '$ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK}'
);
}
elsif (__CAG_ENV__::NO_SUBNAME) {
Carp::croak(
"Unable to install accessor with illegal name '$name': "
. 'Sub::Name not available'
);
}
elsif (
# Because one of the former maintainers of DBIC::SL is a raging
# idiot, there is now a ton of DBIC code out there that attempts
# to create column accessors with illegal names. In the interest
# of not cluttering the logs of unsuspecting victims (unsuspecting
# because these accessors are unusable anyway) we provide an
# explicit "do not warn at all" escape, until all such code is
# fixed (this will be a loooooong time >:(
$ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} ne 'DO_NOT_WARN'
and
! $illegal_accessors_warned->{$class}++
) {
Carp::carp(
"Installing illegal accessor '$name' into $class, see "
. 'documentation for more details'
);
}
}
Carp::carp("Having a data accessor named '$name' in '$class' is unwise.")
if $name =~ /\A(?: DESTROY | AUTOLOAD | CLONE )\z/x;
my $alias = "_${name}_accessor";
for ($name, $alias) {
# the maker may elect to not return anything, meaning it already
# installed the coderef for us (e.g. lack of Sub::Name)
my $cref = $self->$maker($group, $field, $_)
or next;
my $fq_meth = "${class}::$_";
*$fq_meth = Sub::Name::subname($fq_meth, $cref);
#unless defined &{$class."\:\:$field"}
}
}
};
# $gen_accessor coderef is setup at the end for clarity
my $gen_accessor;
=head1 NAME
Class::Accessor::Grouped - Lets you build groups of accessors
=head1 SYNOPSIS
use base 'Class::Accessor::Grouped';
# make basic accessors for objects
__PACKAGE__->mk_group_accessors(simple => qw(id name email));
# make accessor that works for objects and classes
__PACKAGE__->mk_group_accessors(inherited => 'awesome_level');
# make an accessor which calls a custom pair of getters/setters
sub get_column { ... this will be called when you do $obj->name() ... }
sub set_column { ... this will be called when you do $obj->name('foo') ... }
__PACKAGE__->mk_group_accessors(column => 'name');
=head1 DESCRIPTION
This class lets you build groups of accessors that will call different
getters and setters. The documentation of this module still requires a lot
of work (B<< volunteers welcome >.> >>), but in the meantime you can refer to
L<this post|http://lo-f.at/glahn/2009/08/WritingPowerfulAccessorsForPerlClasses.html>
for more information.
=head2 Notes on accessor names
In general method names in Perl are considered identifiers, and as such need to
conform to the identifier specification of C<qr/\A[A-Z_a-z][0-9A-Z_a-z]*\z/>.
While it is rather easy to invoke methods with non-standard names
(C<< $obj->${\"anything goes"} >>), it is not possible to properly declare such
methods without the use of L<Sub::Name>. Since this module must be able to
function identically with and without its optional dependencies, starting with
version C<0.10008> attempting to declare an accessor with a non-standard name
is a fatal error (such operations would silently succeed since version
C<0.08004>, as long as L<Sub::Name> is present, or otherwise would result in a
syntax error during a string eval).
Unfortunately in the years since C<0.08004> a rather large body of code
accumulated in the wild that does attempt to declare accessors with funny
names. One notable perpetrator is L<DBIx::Class::Schema::Loader>, which under
certain conditions could create accessors of the C<column> group which start
with numbers and/or some other punctuation (the proper way would be to declare
columns with the C<accessor> attribute set to C<undef>).
Therefore an escape mechanism is provided via the environment variable
C<CAG_ILLEGAL_ACCESSOR_NAME_OK>. When set to a true value, one warning is
issued B<per class> on attempts to declare an accessor with a non-conforming
name, and as long as L<Sub::Name> is available all accessors will be properly
created. Regardless of this setting, accessor names containing nulls C<"\0">
are disallowed, due to various deficiencies in perl itself.
If your code base has too many instances of illegal accessor declarations, and
a fix is not feasible due to time constraints, it is possible to disable the
warnings altogether by setting C<$ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK}> to
C<DO_NOT_WARN> (observe capitalization).
=head1 METHODS
=head2 mk_group_accessors
__PACKAGE__->mk_group_accessors(simple => 'hair_length', [ hair_color => 'hc' ]);
=over 4
=item Arguments: $group, @fieldspec
Returns: none
=back
Creates a set of accessors in a given group.
$group is the name of the accessor group for the generated accessors; they
will call get_$group($field) on get and set_$group($field, $value) on set.
If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
to tell Class::Accessor::Grouped to use its own get_simple and set_simple
methods.
@fieldspec is a list of field/accessor names; if a fieldspec is a scalar
this is used as both field and accessor name, if a listref it is expected to
be of the form [ $accessor, $field ].
=cut
sub mk_group_accessors {
my ($self, $group, @fields) = @_;
$self->_mk_group_accessors('make_group_accessor', $group, @fields);
return;
}
=head2 mk_group_ro_accessors
__PACKAGE__->mk_group_ro_accessors(simple => 'birthdate', [ social_security_number => 'ssn' ]);
=over 4
=item Arguments: $group, @fieldspec
Returns: none
=back
Creates a set of read only accessors in a given group. Identical to
L</mk_group_accessors> but accessors will throw an error if passed a value
rather than setting the value.
=cut
sub mk_group_ro_accessors {
my($self, $group, @fields) = @_;
$self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
return;
}
=head2 mk_group_wo_accessors
__PACKAGE__->mk_group_wo_accessors(simple => 'lie', [ subject => 'subj' ]);
=over 4
=item Arguments: $group, @fieldspec
Returns: none
=back
Creates a set of write only accessors in a given group. Identical to
L</mk_group_accessors> but accessors will throw an error if not passed a
value rather than getting the value.
=cut
sub mk_group_wo_accessors {
my($self, $group, @fields) = @_;
$self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
return;
}
=head2 get_simple
=over 4
=item Arguments: $field
Returns: $value
=back
Simple getter for hash-based objects which returns the value for the field
name passed as an argument.
=cut
sub get_simple {
$_[0]->{$_[1]};
}
=head2 set_simple
=over 4
=item Arguments: $field, $new_value
Returns: $new_value
=back
Simple setter for hash-based objects which sets and then returns the value
for the field name passed as an argument.
=cut
sub set_simple {
$_[0]->{$_[1]} = $_[2];
}
=head2 get_inherited
=over 4
=item Arguments: $field
Returns: $value
=back
Simple getter for Classes and hash-based objects which returns the value for
the field name passed as an argument. This behaves much like
L<Class::Data::Accessor> where the field can be set in a base class,
inherited and changed in subclasses, and inherited and changed for object
instances.
=cut
sub get_inherited {
if ( length (ref ($_[0]) ) ) {
if (Scalar::Util::reftype $_[0] eq 'HASH') {
return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
# everything in @_ is aliased, an assignment won't work
splice @_, 0, 1, ref($_[0]);
}
else {
Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
}
}
# if we got this far there is nothing in the instance
# OR this is a class call
# in any case $_[0] contains the class name (see splice above)
no strict 'refs';
no warnings 'uninitialized';
my $cag_slot = '::__cag_'. $_[1];
return ${$_[0].$cag_slot} if defined(${$_[0].$cag_slot});
do { return ${$_.$cag_slot} if defined(${$_.$cag_slot}) }
for $_[0]->get_super_paths;
return undef;
}
=head2 set_inherited
=over 4
=item Arguments: $field, $new_value
Returns: $new_value
=back
Simple setter for Classes and hash-based objects which sets and then returns
the value for the field name passed as an argument. When called on a hash-based
object it will set the appropriate hash key value. When called on a class, it
will set a class level variable.
B<Note:>: This method will die if you try to set an object variable on a non
hash-based object.
=cut
sub set_inherited {
if (length (ref ($_[0]) ) ) {
if (Scalar::Util::reftype $_[0] eq 'HASH') {
return $_[0]->{$_[1]} = $_[2];
} else {
Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
};
}
no strict 'refs';
${$_[0].'::__cag_'.$_[1]} = $_[2];
}
=head2 get_component_class
=over 4
=item Arguments: $field
Returns: $value
=back
Gets the value of the specified component class.
__PACKAGE__->mk_group_accessors('component_class' => 'result_class');
$self->result_class->method();
## same as
$self->get_component_class('result_class')->method();
=cut
sub get_component_class {
$_[0]->get_inherited($_[1]);
};
=head2 set_component_class
=over 4
=item Arguments: $field, $class
Returns: $new_value
=back
Inherited accessor that automatically loads the specified class before setting
it. This method will die if the specified class could not be loaded.
__PACKAGE__->mk_group_accessors('component_class' => 'result_class');
__PACKAGE__->result_class('MyClass');
$self->result_class->method();
=cut
sub set_component_class {
if (defined $_[2] and length $_[2]) {
# disable warnings, and prevent $_ being eaten away by a behind-the-scenes
# module loading
local ($^W, $_);
if (__CAG_ENV__::UNSTABLE_DOLLARAT) {
my $err;
{
local $@;
eval { Module::Runtime::use_package_optimistically($_[2]) }
or $err = $@;
}
Carp::croak("Could not load $_[1] '$_[2]': $err") if defined $err;
}
else {
eval { Module::Runtime::use_package_optimistically($_[2]) }
or Carp::croak("Could not load $_[1] '$_[2]': $@");
}
};
$_[0]->set_inherited($_[1], $_[2]);
};
=head1 INTERNAL METHODS
These methods are documented for clarity, but are never meant to be called
directly, and are not really meant for overriding either.
=head2 get_super_paths
Returns a list of 'parent' or 'super' class names that the current class
inherited from. This is what drives the traversal done by L</get_inherited>.
=cut
sub get_super_paths {
# get_linear_isa returns the class itself as the 1st element
# use @_ as a pre-allocated scratch array
(undef, @_) = @{mro::get_linear_isa( length( ref($_[0]) ) ? ref($_[0]) : $_[0] )};
@_;
};
=head2 make_group_accessor
__PACKAGE__->make_group_accessor('simple', 'hair_length', 'hair_length');
__PACKAGE__->make_group_accessor('simple', 'hc', 'hair_color');
=over 4
=item Arguments: $group, $field, $accessor
Returns: \&accessor_coderef ?
=back
Called by mk_group_accessors for each entry in @fieldspec. Either returns
a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
C<undef> if it elects to install the coderef on its own.
=cut
sub make_group_accessor { $gen_accessor->('rw', @_) }
=head2 make_group_ro_accessor
__PACKAGE__->make_group_ro_accessor('simple', 'birthdate', 'birthdate');
__PACKAGE__->make_group_ro_accessor('simple', 'ssn', 'social_security_number');
=over 4
=item Arguments: $group, $field, $accessor
Returns: \&accessor_coderef ?
=back
Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
C<undef> if it elects to install the coderef on its own.
=cut
sub make_group_ro_accessor { $gen_accessor->('ro', @_) }
=head2 make_group_wo_accessor
__PACKAGE__->make_group_wo_accessor('simple', 'lie', 'lie');
__PACKAGE__->make_group_wo_accessor('simple', 'subj', 'subject');
=over 4
=item Arguments: $group, $field, $accessor
Returns: \&accessor_coderef ?
=back
Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
C<undef> if it elects to install the coderef on its own.
=cut
sub make_group_wo_accessor { $gen_accessor->('wo', @_) }
=head1 PERFORMANCE
To provide total flexibility L<Class::Accessor::Grouped> calls methods
internally while performing get/set actions, which makes it noticeably
slower than similar modules. To compensate, this module will automatically
use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
accessors if this module is available on your system.
=head2 Benchmark
This is the benchmark of 200 get/get/set/get/set cycles on perl 5.16.2 with
thread support, showcasing how this modules L<simple (CAG_S)|/get_simple>,
L<inherited (CAG_INH)|/get_inherited> and L<inherited with parent-class data
(CAG_INHP)|/get_inherited> accessors stack up against most popular accessor
builders: L<Moose>, L<Moo>, L<Mo>, L<Mouse> (both pure-perl and XS variant),
L<Object::Tiny::RW (OTRW)|Object::Tiny::RW>,
L<Class::Accessor (CA)|Class::Accessor>,
L<Class::Accessor::Lite (CAL)|Class::Accessor::Lite>,
L<Class::Accessor::Fast (CAF)|Class::Accessor::Fast>,
L<Class::Accessor::Fast::XS (CAF_XS)|Class::Accessor::Fast::XS>
and L<Class::XSAccessor (XSA)|Class::XSAccessor>
Rate CAG_INHP CAG_INH CA CAG_S CAF moOse OTRW CAL mo moUse HANDMADE moo CAF_XS moUse_XS XSA
CAG_INHP 287.021+-0.02/s -- -0.3% -10.0% -37.1% -53.1% -53.6% -53.7% -54.1% -56.9% -59.0% -59.6% -59.8% -78.7% -81.9% -83.5%
CAG_INH 288.025+-0.031/s 0.3% -- -9.7% -36.9% -52.9% -53.5% -53.5% -53.9% -56.7% -58.8% -59.5% -59.7% -78.6% -81.9% -83.5%
CA 318.967+-0.047/s 11.1% 10.7% -- -30.1% -47.9% -48.5% -48.5% -49.0% -52.1% -54.4% -55.1% -55.3% -76.3% -79.9% -81.7%
CAG_S 456.107+-0.054/s 58.9% 58.4% 43.0% -- -25.4% -26.3% -26.4% -27.0% -31.5% -34.8% -35.8% -36.1% -66.1% -71.3% -73.9%
CAF 611.745+-0.099/s 113.1% 112.4% 91.8% 34.1% -- -1.2% -1.2% -2.1% -8.1% -12.6% -14.0% -14.3% -54.5% -61.5% -64.9%
moOse 619.051+-0.059/s 115.7% 114.9% 94.1% 35.7% 1.2% -- -0.1% -1.0% -7.0% -11.6% -12.9% -13.3% -54.0% -61.0% -64.5%
OTRW 619.475+-0.1/s 115.8% 115.1% 94.2% 35.8% 1.3% 0.1% -- -0.9% -6.9% -11.5% -12.9% -13.2% -54.0% -61.0% -64.5%
CAL 625.106+-0.085/s 117.8% 117.0% 96.0% 37.1% 2.2% 1.0% 0.9% -- -6.1% -10.7% -12.1% -12.5% -53.5% -60.6% -64.2%
mo 665.44+-0.12/s 131.8% 131.0% 108.6% 45.9% 8.8% 7.5% 7.4% 6.5% -- -4.9% -6.4% -6.8% -50.5% -58.1% -61.9%
moUse 699.9+-0.15/s 143.9% 143.0% 119.4% 53.5% 14.4% 13.1% 13.0% 12.0% 5.2% -- -1.6% -2.0% -48.0% -55.9% -59.9%
HANDMADE 710.98+-0.16/s 147.7% 146.8% 122.9% 55.9% 16.2% 14.9% 14.8% 13.7% 6.8% 1.6% -- -0.4% -47.2% -55.2% -59.2%
moo 714.04+-0.13/s 148.8% 147.9% 123.9% 56.6% 16.7% 15.3% 15.3% 14.2% 7.3% 2.0% 0.4% -- -46.9% -55.0% -59.1%
CAF_XS 1345.55+-0.051/s 368.8% 367.2% 321.8% 195.0% 120.0% 117.4% 117.2% 115.3% 102.2% 92.2% 89.3% 88.4% -- -15.3% -22.9%
moUse_XS 1588+-0.036/s 453.3% 451.3% 397.9% 248.2% 159.6% 156.5% 156.3% 154.0% 138.6% 126.9% 123.4% 122.4% 18.0% -- -9.0%
XSA 1744.67+-0.052/s 507.9% 505.7% 447.0% 282.5% 185.2% 181.8% 181.6% 179.1% 162.2% 149.3% 145.4% 144.3% 29.7% 9.9% --
Benchmarking program is available in the root of the
L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
=head2 Notes on Class::XSAccessor
You can force (or disable) the use of L<Class::XSAccessor> before creating a
particular C<simple> accessor by either manipulating the global variable
C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with
L<localization|perlfunc/local>, or you can do so before runtime via the
C<CAG_USE_XS> environment variable.
Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
L</set_simple> this module does its best to detect if you are overriding
one of these methods and will fall back to using the perl version of the
accessor in order to maintain consistency. However be aware that if you
enable use of C<Class::XSAccessor> (automatically or explicitly), create
an object, invoke a simple accessor on that object, and B<then> manipulate
the symbol table to install a C<get/set_simple> override - you get to keep
all the pieces.
=head1 AUTHORS
Matt S. Trout <mst@shadowcatsystems.co.uk>
Christopher H. Laco <claco@chrislaco.com>
=head1 CONTRIBUTORS
Caelum: Rafael Kitover <rkitover@cpan.org>
frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
groditi: Guillermo Roditi <groditi@cpan.org>
Jason Plum <jason.plum@bmmsi.com>
ribasushi: Peter Rabbitson <ribasushi@cpan.org>
=head1 COPYRIGHT & LICENSE
Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
This program is free software; you can redistribute it and/or modify
it under the same terms as perl itself.
=cut
########################################################################
########################################################################
########################################################################
#
# Here be many angry dragons
# (all code is in private coderefs since everything inherits CAG)
#
########################################################################
########################################################################
# Autodetect unless flag supplied
my $xsa_autodetected;
if (! defined $USE_XS) {
$USE_XS = __CAG_ENV__::NO_CXSA ? 0 : 1;
$xsa_autodetected++;
}
my $maker_templates = {
rw => {
cxsa_call => 'accessors',
pp_generator => sub {
# my ($group, $fieldname) = @_;
my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]);
sprintf <<'EOS', ($_[0], $quoted_fieldname) x 2;
@_ > 1
? shift->set_%s(%s, @_)
: shift->get_%s(%s)
EOS
},
},
ro => {
cxsa_call => 'getters',
pp_generator => sub {
# my ($group, $fieldname) = @_;
my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]);
sprintf <<'EOS', $_[0], $quoted_fieldname;
@_ > 1
? do {
my ($meth) = (caller(0))[3] =~ /([^\:]+)$/;
my $class = length( ref($_[0]) ) ? ref($_[0]) : $_[0];
Carp::croak(
"'$meth' cannot alter its value (read-only attribute of class $class)"
);
}
: shift->get_%s(%s)
EOS
},
},
wo => {
cxsa_call => 'setters',
pp_generator => sub {
# my ($group, $fieldname) = @_;
my $quoted_fieldname = __CAG_ENV__::perlstring($_[1]);
sprintf <<'EOS', $_[0], $quoted_fieldname;
@_ > 1
? shift->set_%s(%s, @_)
: do {
my ($meth) = (caller(0))[3] =~ /([^\:]+)$/;
my $class = length( ref($_[0]) ) ? ref($_[0]) : $_[0];
Carp::croak(
"'$meth' cannot access its value (write-only attribute of class $class)"
);
}
EOS
},
},
};
my $cag_eval = sub {
#my ($src, $no_warnings, $err_msg) = @_;
my $src = sprintf "{ %s warnings; use strict; no strict 'refs'; %s }",
$_[1] ? 'no' : 'use',
$_[0],
;
my (@rv, $err);
{
local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT;
wantarray
? @rv = eval $src
: $rv[0] = eval $src
;
$err = $@ if $@ ne '';
}
Carp::croak(join ': ', ($_[2] || 'String-eval failed'), "$err\n$src\n" )
if defined $err;
wantarray ? @rv : $rv[0];
};
my ($accessor_maker_cache, $no_xsa_warned_classes);
# can't use pkg_gen to track this stuff, as it doesn't
# detect superclass mucking
my $original_simple_getter = __PACKAGE__->can ('get_simple');
my $original_simple_setter = __PACKAGE__->can ('set_simple');
my ($resolved_methods, $cag_produced_crefs);
sub CLONE {
my @crefs = grep { defined $_ } values %{$cag_produced_crefs||{}};
$cag_produced_crefs = @crefs
? { map { $_ => $_ } @crefs }
: undef
;
}
# Note!!! Unusual signature
$gen_accessor = sub {
my ($type, $class, $group, $field, $methname) = @_;
$class = ref $class if length ref $class;
# When installing an XSA simple accessor, we need to make sure we are not
# short-circuiting a (compile or runtime) get_simple/set_simple override.
# What we do here is install a lazy first-access check, which will decide
# the ultimate coderef being placed in the accessor slot
#
# Also note that the *original* class will always retain this shim, as
# different branches inheriting from it may have different overrides.
# Thus the final method (properly labeled and all) is installed in the
# calling-package's namespace
if ($USE_XS and $group eq 'simple') {
die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_ENV__::NO_CXSA )
if __CAG_ENV__::NO_CXSA;
my $ret = sub {
my $current_class = length (ref ($_[0] ) ) ? ref ($_[0]) : $_[0];
my $resolved_implementation = $resolved_methods->{$current_class}{$methname} ||= do {
if (
($current_class->can('get_simple')||0) == $original_simple_getter
&&
($current_class->can('set_simple')||0) == $original_simple_setter
) {
# nothing has changed, might as well use the XS crefs
#
# note that by the time this code executes, we already have
# *objects* (since XSA works on 'simple' only by definition).
# If someone is mucking with the symbol table *after* there
# are some objects already - look! many, shiny pieces! :)
#
# The weird breeder thingy is because XSA does not have an
# interface returning *just* a coderef, without installing it
# anywhere :(
Class::XSAccessor->import(
replace => 1,
class => '__CAG__XSA__BREEDER__',
$maker_templates->{$type}{cxsa_call} => {
$methname => $field,
},
);
__CAG__XSA__BREEDER__->can($methname);
}
else {
if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) {
# not using Carp since the line where this happens doesn't mean much
warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class '
. "'$current_class' inheriting from '$class' due to an overriden get_simple and/or "
. "set_simple\n";
}
do {
# that's faster than local
$USE_XS = 0;
my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);
$USE_XS = 1;
$c;
};
}
};
# if after this shim was created someone wrapped it with an 'around',
# we can not blindly reinstall the method slot - we will destroy the
# wrapper. Silently chain execution further...
if ( ! $cag_produced_crefs->{ $current_class->can($methname) || 0 } ) {
# older perls segfault if the cref behind the goto throws
# http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
goto $resolved_implementation;
}
if (__CAG_ENV__::TRACK_UNDEFER_FAIL) {
my $deferred_calls_seen = do {
no strict 'refs';
\%{"${current_class}::__cag_deferred_xs_shim_invocations"}
};
my @cframe = caller(0);
if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) {
Carp::carp (
"Deferred version of method $cframe[3] invoked more than once (originally "
. "invoked at $already_seen). This is a strong indication your code has "
. 'cached the original ->can derived method coderef, and is using it instead '
. 'of the proper method re-lookup, causing minor performance regressions'
);
}
else {
$deferred_calls_seen->{$cframe[3]} = "$cframe[1] line $cframe[2]";
}
}
# install the resolved implementation into the code slot so we do not
# come here anymore (hopefully)
# since XSAccessor was available - so is Sub::Name
{
no strict 'refs';
no warnings 'redefine';
my $fq_name = "${current_class}::${methname}";
*$fq_name = Sub::Name::subname($fq_name, $resolved_implementation);
}
# now things are installed - one ref less to carry
delete $resolved_methods->{$current_class}{$methname};
# but need to record it in the expectation registry *in case* it
# was cached via ->can for some moronic reason
Scalar::Util::weaken( $cag_produced_crefs->{$resolved_implementation} = $resolved_implementation );
# older perls segfault if the cref behind the goto throws
# http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
goto $resolved_implementation;
};
Scalar::Util::weaken($cag_produced_crefs->{$ret} = $ret);
$ret; # returning shim
}
# no Sub::Name - just install the coderefs directly (compiling every time)
elsif (__CAG_ENV__::NO_SUBNAME) {
my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
$maker_templates->{$type}{pp_generator}->($group, $field);
$cag_eval->(
"no warnings 'redefine'; sub ${class}::${methname} { $src }; 1",
);
undef; # so that no further attempt will be made to install anything
}
# a coderef generator with a variable pad (returns a fresh cref on every invocation)
else {
($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do {
my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
$maker_templates->{$type}{pp_generator}->($group, $field);
$cag_eval->( "sub { my \$dummy; sub { \$dummy if 0; $src } }" );
})->()
}
};
1;

246
database/perl/vendor/lib/Class/Accessor/Lite.pm vendored Normal file
View File

@@ -0,0 +1,246 @@
package Class::Accessor::Lite;
use strict;
our $VERSION = '0.08';
sub croak {require Carp; Carp::croak(@_)}
sub import {
shift;
my %args = @_;
my $pkg = caller(0);
my %key_ctor = (
rw => \&_mk_accessors,
ro => \&_mk_ro_accessors,
wo => \&_mk_wo_accessors,
);
for my $key (sort keys %key_ctor) {
if (defined $args{$key}) {
croak("value of the '$key' parameter should be an arrayref")
unless ref($args{$key}) eq 'ARRAY';
$key_ctor{$key}->($pkg, @{$args{$key}});
}
}
_mk_new($pkg)
if $args{new};
1;
}
sub mk_new_and_accessors {
(undef, my @properties) = @_;
my $pkg = caller(0);
_mk_new($pkg);
_mk_accessors($pkg, @properties);
}
sub mk_new {
my $pkg = caller(0);
_mk_new($pkg);
}
sub mk_accessors {
(undef, my @properties) = @_;
my $pkg = caller(0);
_mk_accessors($pkg, @properties);
}
sub mk_ro_accessors {
(undef, my @properties) = @_;
my $pkg = caller(0);
_mk_ro_accessors($pkg, @properties);
}
sub mk_wo_accessors {
(undef, my @properties) = @_;
my $pkg = caller(0);
_mk_wo_accessors($pkg, @properties);
}
sub _mk_new {
my $pkg = shift;
no strict 'refs';
*{$pkg . '::new'} = __m_new($pkg);
}
sub _mk_accessors {
my $pkg = shift;
no strict 'refs';
for my $n (@_) {
*{$pkg . '::' . $n} = __m($n);
}
}
sub _mk_ro_accessors {
my $pkg = shift;
no strict 'refs';
for my $n (@_) {
*{$pkg . '::' . $n} = __m_ro($pkg, $n);
}
}
sub _mk_wo_accessors {
my $pkg = shift;
no strict 'refs';
for my $n (@_) {
*{$pkg . '::' . $n} = __m_wo($pkg, $n);
}
}
sub __m_new {
my $pkg = shift;
no strict 'refs';
return sub {
my $klass = shift;
bless {
(@_ == 1 && ref($_[0]) eq 'HASH' ? %{$_[0]} : @_),
}, $klass;
};
}
sub __m {
my $n = shift;
sub {
return $_[0]->{$n} if @_ == 1;
return $_[0]->{$n} = $_[1] if @_ == 2;
shift->{$n} = \@_;
};
}
sub __m_ro {
my ($pkg, $n) = @_;
sub {
if (@_ == 1) {
return $_[0]->{$n} if @_ == 1;
} else {
my $caller = caller(0);
croak("'$caller' cannot access the value of '$n' on objects of class '$pkg'");
}
};
}
sub __m_wo {
my ($pkg, $n) = @_;
sub {
if (@_ == 1) {
my $caller = caller(0);
croak("'$caller' cannot alter the value of '$n' on objects of class '$pkg'")
} else {
return $_[0]->{$n} = $_[1] if @_ == 2;
shift->{$n} = \@_;
}
};
}
1;
__END__
=head1 NAME
Class::Accessor::Lite - a minimalistic variant of Class::Accessor
=head1 SYNOPSIS
package MyPackage;
use Class::Accessor::Lite (
new => 1,
rw => [ qw(foo bar) ],
ro => [ qw(baz) ],
wo => [ qw(hoge) ],
);
=head1 DESCRIPTION
The module is a variant of C<Class::Accessor>. It is fast and requires less typing, has no dependencies to other modules, and does not mess up the @ISA.
=head1 THE USE STATEMENT
The use statement (i.e. the C<import> function) of the module takes a single hash as an argument that specifies the types and the names of the properties. Recognises the following keys.
=over 4
=item new => $true_or_false
the default constructor is created if the value evaluates to true, otherwise nothing is done (the default behaviour)
=item rw => \@name_of_the_properties
creates a read / write accessor for the name of the properties passed through as an arrayref
=item ro => \@name_of_the_properties
creates a read-only accessor for the name of the properties passed through as an arrayref
=item wo => \@name_of_the_properties
creates a write-only accessor for the name of the properties passed through as an arrayref
=back
For more detailed explanation read the following section describing the behaviour of each function that actually creates the accessors.
=head1 FUNCTIONS
As of version 0.04 the properties can be specified as the arguments to the C<use> statement (as can be seen in the SYNOPSIS) which is now the recommended way of using the module, but for compatibility the following functions are provided as well.
=head2 Class::Accessor::Lite->mk_accessors(@name_of_the_properties)
Creates an accessor in current package under the name specified by the arguments that access the properties (of a hashref) with the same name.
=head2 Class::Accessor::Lite->mk_ro_accessors(@name_of_the_properties)
Same as mk_accessors() except it will generate read-only accessors (i.e. true accessors). If you attempt to set a value with these accessors it will throw an exception.
=head2 Class::Accessor::Lite->mk_wo_accessors(@name_of_the_properties)
Same as mk_accessors() except it will generate write-only accessors (i.e. mutators). If you attempt to read a value with these accessors it will throw an exception.
=head2 Class::Accessor::Lite->mk_new()
Creates the C<new> function that accepts a hash or a hashref as the initial properties of the object.
=head2 Class::Accessor::Lite->mk_new_and_accessors(@name_of_the_properties)
DEPRECATED. Use the new "use Class::Accessor::Lite (...)" style.
=head1 FAQ
=head2 Can I use C<Class::Accessor::Lite> in an inherited module?
Yes in most cases, when the class object in the super class is implemented using a hashref. However you _should_ _not_ create the constructor for the inherited class by calling C<<Class::Accessor::Lite->new()>> or by C<<use Class::Accessor::Lite (new => 1)>>. The only other thing that C<Class::Accessor::Lite> does is to set up the accessor functions for given property names through a blessed hashref.
=head2 What happens when passing more than one arguments to the accessor?
When the accessor built by Class::Accessor::Lite is given more than one arguments, a reference to the arguments will be saved as an arrayref. This behaviour might not be necessary but is implemented as is to maintain compatibility with L<Class::Accessor::Fast>.
my @data = (1, 2, 3);
$obj->someproperty(@data);
$obj->someproperty->[2]++; # $data[3] is incremented
In general, you should pass an arrayref to set an arrayref to a property.
my @data = (1, 2, 3);
$obj->someproperty([ @data ]); # save a copy using arrayref
$obj->someproper->[2]++; # @data is not modified
=head1 SEE ALSO
L<Class::Accessor>
L<Class::Accessor::Lite>
=head1 AUTHORS
Copyright (C) 2008 - 2010 Kazuho Oku
=head1 LICENSE
This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.6 or, at your option, any later version of Perl 5 you may have available.
=cut

591
database/perl/vendor/lib/Class/C3.pm vendored Normal file
View File

@@ -0,0 +1,591 @@
package Class::C3;
use strict;
use warnings;
our $VERSION = '0.35';
our $C3_IN_CORE;
our $C3_XS;
BEGIN {
if($] > 5.009_004) {
$C3_IN_CORE = 1;
require mro;
}
elsif($C3_XS or not defined $C3_XS) {
my $error = do {
local $@;
eval { require Class::C3::XS };
$@;
};
if ($error) {
die $error if $error !~ /\blocate\b/;
if ($C3_XS) {
require Carp;
Carp::croak( "XS explicitly requested but Class::C3::XS is not available" );
}
require Algorithm::C3;
require Class::C3::next;
}
else {
$C3_XS = 1;
}
}
}
# this is our global stash of both
# MRO's and method dispatch tables
# the structure basically looks like
# this:
#
# $MRO{$class} = {
# MRO => [ <class precedence list> ],
# methods => {
# orig => <original location of method>,
# code => \&<ref to original method>
# },
# has_overload_fallback => (1 | 0)
# }
#
our %MRO;
# use these for debugging ...
sub _dump_MRO_table { %MRO }
our $TURN_OFF_C3 = 0;
# state tracking for initialize()/uninitialize()
our $_initialized = 0;
sub import {
my $class = caller();
# skip if the caller is main::
# since that is clearly not relevant
return if $class eq 'main';
return if $TURN_OFF_C3;
mro::set_mro($class, 'c3') if $C3_IN_CORE;
# make a note to calculate $class
# during INIT phase
$MRO{$class} = undef unless exists $MRO{$class};
}
## initializers
# This prevents silly warnings when Class::C3 is
# used explicitly along with MRO::Compat under 5.9.5+
{ no warnings 'redefine';
sub initialize {
%next::METHOD_CACHE = ();
# why bother if we don't have anything ...
return unless keys %MRO;
if($C3_IN_CORE) {
mro::set_mro($_, 'c3') for keys %MRO;
}
else {
if($_initialized) {
uninitialize();
$MRO{$_} = undef foreach keys %MRO;
}
_calculate_method_dispatch_tables();
_apply_method_dispatch_tables();
$_initialized = 1;
}
}
sub uninitialize {
# why bother if we don't have anything ...
%next::METHOD_CACHE = ();
return unless keys %MRO;
if($C3_IN_CORE) {
mro::set_mro($_, 'dfs') for keys %MRO;
}
else {
_remove_method_dispatch_tables();
$_initialized = 0;
}
}
sub reinitialize { goto &initialize }
} # end of "no warnings 'redefine'"
## functions for applying C3 to classes
sub _calculate_method_dispatch_tables {
return if $C3_IN_CORE;
my %merge_cache;
foreach my $class (keys %MRO) {
_calculate_method_dispatch_table($class, \%merge_cache);
}
}
sub _calculate_method_dispatch_table {
return if $C3_IN_CORE;
my ($class, $merge_cache) = @_;
no strict 'refs';
my @MRO = calculateMRO($class, $merge_cache);
$MRO{$class} = { MRO => \@MRO };
my $has_overload_fallback;
my %methods;
# NOTE:
# we do @MRO[1 .. $#MRO] here because it
# makes no sense to interrogate the class
# which you are calculating for.
foreach my $local (@MRO[1 .. $#MRO]) {
# if overload has tagged this module to
# have use "fallback", then we want to
# grab that value
$has_overload_fallback = ${"${local}::()"}
if !defined $has_overload_fallback && defined ${"${local}::()"};
foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
# skip if already overridden in local class
next unless !defined *{"${class}::$method"}{CODE};
$methods{$method} = {
orig => "${local}::$method",
code => \&{"${local}::$method"}
} unless exists $methods{$method};
}
}
# now stash them in our %MRO table
$MRO{$class}->{methods} = \%methods;
$MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
}
sub _apply_method_dispatch_tables {
return if $C3_IN_CORE;
foreach my $class (keys %MRO) {
_apply_method_dispatch_table($class);
}
}
sub _apply_method_dispatch_table {
return if $C3_IN_CORE;
my $class = shift;
no strict 'refs';
${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
if !defined &{"${class}::()"}
&& defined $MRO{$class}->{has_overload_fallback};
foreach my $method (keys %{$MRO{$class}->{methods}}) {
if ( $method =~ /^\(/ ) {
my $orig = $MRO{$class}->{methods}->{$method}->{orig};
${"${class}::$method"} = $$orig if defined $$orig;
}
*{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
}
}
sub _remove_method_dispatch_tables {
return if $C3_IN_CORE;
foreach my $class (keys %MRO) {
_remove_method_dispatch_table($class);
}
}
sub _remove_method_dispatch_table {
return if $C3_IN_CORE;
my $class = shift;
no strict 'refs';
delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
foreach my $method (keys %{$MRO{$class}->{methods}}) {
delete ${"${class}::"}{$method}
if defined *{"${class}::${method}"}{CODE} &&
(*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
}
}
sub calculateMRO {
my ($class, $merge_cache) = @_;
return Algorithm::C3::merge($class, sub {
no strict 'refs';
@{$_[0] . '::ISA'};
}, $merge_cache);
}
# Method overrides to support 5.9.5+ or Class::C3::XS
sub _core_calculateMRO { @{mro::get_linear_isa($_[0], 'c3')} }
if($C3_IN_CORE) {
no warnings 'redefine';
*Class::C3::calculateMRO = \&_core_calculateMRO;
}
elsif($C3_XS) {
no warnings 'redefine';
*Class::C3::calculateMRO = \&Class::C3::XS::calculateMRO;
*Class::C3::_calculate_method_dispatch_table
= \&Class::C3::XS::_calculate_method_dispatch_table;
}
1;
__END__
=pod
=head1 NAME
Class::C3 - A pragma to use the C3 method resolution order algorithm
=head1 SYNOPSIS
# NOTE - DO NOT USE Class::C3 directly as a user, use MRO::Compat instead!
package ClassA;
use Class::C3;
sub hello { 'A::hello' }
package ClassB;
use base 'ClassA';
use Class::C3;
package ClassC;
use base 'ClassA';
use Class::C3;
sub hello { 'C::hello' }
package ClassD;
use base ('ClassB', 'ClassC');
use Class::C3;
# Classic Diamond MI pattern
# <A>
# / \
# <B> <C>
# \ /
# <D>
package main;
# initializez the C3 module
# (formerly called in INIT)
Class::C3::initialize();
print join ', ' => Class::C3::calculateMRO('ClassD'); # prints ClassD, ClassB, ClassC, ClassA
print ClassD->hello(); # prints 'C::hello' instead of the standard p5 'A::hello'
ClassD->can('hello')->(); # can() also works correctly
UNIVERSAL::can('ClassD', 'hello'); # as does UNIVERSAL::can()
=head1 DESCRIPTION
This is pragma to change Perl 5's standard method resolution order from depth-first left-to-right
(a.k.a - pre-order) to the more sophisticated C3 method resolution order.
B<NOTE:> YOU SHOULD NOT USE THIS MODULE DIRECTLY - The feature provided
is integrated into perl version >= 5.9.5, and you should use L<MRO::Compat>
instead, which will use the core implementation in newer perls, but fallback
to using this implementation on older perls.
=head2 What is C3?
C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
inheritance. It was first introduced in the language Dylan (see links in the L<SEE ALSO> section),
and then later adopted as the preferred MRO (Method Resolution Order) for the new-style classes in
Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
default MRO for Parrot objects as well.
=head2 How does C3 work.
C3 works by always preserving local precedence ordering. This essentially means that no class will
appear before any of its subclasses. Take the classic diamond inheritance pattern for instance:
<A>
/ \
<B> <C>
\ /
<D>
The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even
though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO
(D, B, C, A), which does not have this same issue.
This example is fairly trivial, for more complex examples and a deeper explanation, see the links in
the L<SEE ALSO> section.
=head2 How does this module work?
This module uses a technique similar to Perl 5's method caching. When C<Class::C3::initialize> is
called, this module calculates the MRO of all the classes which called C<use Class::C3>. It then
gathers information from the symbol tables of each of those classes, and builds a set of method
aliases for the correct dispatch ordering. Once all these C3-based method tables are created, it
then adds the method aliases into the local classes symbol table.
The end result is actually classes with pre-cached method dispatch. However, this caching does not
do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
your classes to be effectively closed. See the L<CAVEATS> section for more details.
=head1 OPTIONAL LOWERCASE PRAGMA
This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in
the regular install since lowercase module names are considered I<"bad"> by some people. However I
think that code looks much nicer like this:
package MyClass;
use c3;
This is more clunky:
package MyClass;
use Class::C3;
But hey, it's your choice, that's why it is optional.
=head1 FUNCTIONS
=over 4
=item B<calculateMRO ($class)>
Given a C<$class> this will return an array of class names in the proper C3 method resolution order.
=item B<initialize>
This B<must be called> to initialize the C3 method dispatch tables, this module B<will not work> if
you do not do this. It is advised to do this as soon as possible B<after> loading any classes which
use C3. Here is a quick code example:
package Foo;
use Class::C3;
# ... Foo methods here
package Bar;
use Class::C3;
use base 'Foo';
# ... Bar methods here
package main;
Class::C3::initialize(); # now it is safe to use Foo and Bar
This function used to be called automatically for you in the INIT phase of the perl compiler, but
that lead to warnings if this module was required at runtime. After discussion with my user base
(the L<DBIx::Class> folks), we decided that calling this in INIT was more of an annoyance than a
convenience. I apologize to anyone this causes problems for (although I would be very surprised if I had
any other users other than the L<DBIx::Class> folks). The simplest solution of course is to define
your own INIT method which calls this function.
NOTE:
If C<initialize> detects that C<initialize> has already been executed, it will L</uninitialize> and
clear the MRO cache first.
=item B<uninitialize>
Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5
style dispatch order (depth-first, left-to-right).
=item B<reinitialize>
This is an alias for L</initialize> above.
=back
=head1 METHOD REDISPATCHING
It is always useful to be able to re-dispatch your method call to the "next most applicable method". This
module provides a pseudo package along the lines of C<SUPER::> or C<NEXT::> which will re-dispatch the
method along the C3 linearization. This is best shown with an example.
# a classic diamond MI pattern ...
# <A>
# / \
# <B> <C>
# \ /
# <D>
package ClassA;
use Class::C3;
sub foo { 'ClassA::foo' }
package ClassB;
use base 'ClassA';
use Class::C3;
sub foo { 'ClassB::foo => ' . (shift)->next::method() }
package ClassC;
use base 'ClassA';
use Class::C3;
sub foo { 'ClassC::foo => ' . (shift)->next::method() }
package ClassD;
use base ('ClassB', 'ClassC');
use Class::C3;
sub foo { 'ClassD::foo => ' . (shift)->next::method() }
print ClassD->foo; # prints out "ClassD::foo => ClassB::foo => ClassC::foo => ClassA::foo"
A few things to note. First, we do not require you to add on the method name to the C<next::method>
call (this is unlike C<NEXT::> and C<SUPER::> which do require that). This helps to enforce the rule
that you cannot dispatch to a method of a different name (this is how C<NEXT::> behaves as well).
The next thing to keep in mind is that you will need to pass all arguments to C<next::method>. It can
not automatically use the current C<@_>.
If C<next::method> cannot find a next method to re-dispatch the call to, it will throw an exception.
You can use C<next::can> to see if C<next::method> will succeed before you call it like so:
$self->next::method(@_) if $self->next::can;
Additionally, you can use C<maybe::next::method> as a shortcut to only call the next method if it exists.
The previous example could be simply written as:
$self->maybe::next::method(@_);
There are some caveats about using C<next::method>, see below for those.
=head1 CAVEATS
This module used to be labeled as I<experimental>, however it has now been pretty heavily tested by
the good folks over at L<DBIx::Class> and I am confident this module is perfectly usable for
whatever your needs might be.
But there are still caveats, so here goes ...
=over 4
=item Use of C<SUPER::>.
The idea of C<SUPER::> under multiple inheritance is ambiguous, and generally not recommended anyway.
However, its use in conjunction with this module is very much not recommended, and in fact very
discouraged. The recommended approach is to instead use the supplied C<next::method> feature, see
more details on its usage above.
=item Changing C<@ISA>.
It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people
do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this
module, and therefore probably won't even show up. If you do this, you will need to call C<reinitialize>
in order to recalculate B<all> method dispatch tables. See the C<reinitialize> documentation and an example
in F<t/20_reinitialize.t> for more information.
=item Adding/deleting methods from class symbol tables.
This module calculates the MRO for each requested class by interrogating the symbol tables of said classes.
So any symbol table manipulation which takes place after our INIT phase is run will not be reflected in
the calculated MRO. Just as with changing the C<@ISA>, you will need to call C<reinitialize> for any
changes you make to take effect.
=item Calling C<next::method> from methods defined outside the class
There is an edge case when using C<next::method> from within a subroutine which was created in a different
module than the one it is called from. It sounds complicated, but it really isn't. Here is an example which
will not work correctly:
*Foo::foo = sub { (shift)->next::method(@_) };
The problem exists because the anonymous subroutine being assigned to the glob C<*Foo::foo> will show up
in the call stack as being called C<__ANON__> and not C<foo> as you might expect. Since C<next::method>
uses C<caller> to find the name of the method it was called in, it will fail in this case.
But fear not, there is a simple solution. The module C<Sub::Name> will reach into the perl internals and
assign a name to an anonymous subroutine for you. Simply do this:
use Sub::Name 'subname';
*Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
and things will Just Work. Of course this is not always possible to do, but to be honest, I just can't
manage to find a workaround for it, so until someone gives me a working patch this will be a known
limitation of this module.
=back
=head1 COMPATIBILITY
If your software requires Perl 5.9.5 or higher, you do not need L<Class::C3>, you can simply C<use mro 'c3'>, and not worry about C<initialize()>, avoid some of the above caveats, and get the best possible performance. See L<mro> for more details.
If your software is meant to work on earlier Perls, use L<Class::C3> as documented here. L<Class::C3> will detect Perl 5.9.5+ and take advantage of the core support when available.
=head1 Class::C3::XS
This module will load L<Class::C3::XS> if it's installed and you are running on a Perl version older than 5.9.5. The optional module will be automatically installed for you if a C compiler is available, as it results in significant performance improvements (but unlike the 5.9.5+ core support, it still has all of the same caveats as L<Class::C3>).
=head1 CODE COVERAGE
L<Devel::Cover> was reporting 94.4% overall test coverage earlier in this module's life. Currently, the test suite does things that break under coverage testing, but it is fair to assume the coverage is still close to that value.
=head1 SEE ALSO
=head2 The original Dylan paper
=over 4
=item L<https://web.archive.org/web/20000817033012id_/http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
=back
=head2 The prototype Perl 6 Object Model uses C3
=over 4
=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
=back
=head2 Parrot now uses C3
=over 4
=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
=item L<http://use.perl.org/~autrijus/journal/25768>
=back
=head2 Python 2.3 MRO related links
=over 4
=item L<http://www.python.org/2.3/mro.html>
=item L<http://www.python.org/2.2.2/descrintro.html#mro>
=back
=head2 C3 for TinyCLOS
=over 4
=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
=back
=head1 ACKNOWLEGEMENTS
=over 4
=item Thanks to Matt S. Trout for using this module in his module L<DBIx::Class>
and finding many bugs and providing fixes.
=item Thanks to Justin Guenther for making C<next::method> more robust by handling
calls inside C<eval> and anon-subs.
=item Thanks to Robert Norris for adding support for C<next::can> and
C<maybe::next::method>.
=back
=head1 AUTHOR
Stevan Little, <stevan@iinteractive.com>
Brandon L. Black, <blblack@gmail.com>
=head1 COPYRIGHT AND LICENSE
Copyright 2005, 2006 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

260
database/perl/vendor/lib/Class/C3/Componentised.pm vendored Normal file
View File

@@ -0,0 +1,260 @@
package Class::C3::Componentised;
=head1 NAME
Class::C3::Componentised - Load mix-ins or components to your C3-based class
=head1 SYNOPSIS
package MyModule;
use strict;
use warnings;
use base 'Class::C3::Componentised';
sub component_base_class { "MyModule::Component" }
package main;
MyModule->load_components( qw/Foo Bar/ );
# Will load MyModule::Component::Foo and MyModule::Component::Bar
=head1 DESCRIPTION
This will inject base classes to your module using the L<Class::C3> method
resolution order.
Please note: these are not plugins that can take precedence over methods
declared in MyModule. If you want something like that, consider
L<MooseX::Object::Pluggable>.
=head1 METHODS
=cut
use strict;
use warnings;
# This will prime the Class::C3 namespace (either by loading it proper on 5.8
# or by installing compat shims on 5.10+). A user might have a reasonable
# expectation that using Class::C3::<something> will give him access to
# Class::C3 itself, and this module has been providing this historically.
# Therefore leaving it in indefinitely.
use MRO::Compat;
use Carp ();
use List::Util ();
our $VERSION = '1.001002';
$VERSION =~ tr/_//d;
my $invalid_class = qr/(?: \b:\b | \:{3,} | \:\:$ )/x;
=head2 load_components( @comps )
Loads the given components into the current module. If a module begins with a
C<+> character, it is taken to be a fully qualified class name, otherwise
C<< $class->component_base_class >> is prepended to it.
Calling this will call C<Class::C3::reinitialize>.
=cut
sub load_components {
my $class = shift;
$class->_load_components( map {
/^\+(.*)$/
? $1
: join ('::', $class->component_base_class, $_)
} grep { $_ !~ /^#/ } @_
);
}
=head2 load_own_components( @comps )
Similar to L<load_components|/load_components( @comps )>, but assumes every
class is C<"$class::$comp">.
=cut
sub load_own_components {
my $class = shift;
$class->_load_components( map { "${class}::$_" } grep { $_ !~ /^#/ } @_ );
}
sub _load_components {
my $class = shift;
return unless @_;
$class->ensure_class_loaded($_) for @_;
$class->inject_base($class => @_);
Class::C3::reinitialize();
}
=head2 load_optional_components
As L<load_components|/load_components( @comps )>, but will silently ignore any
components that cannot be found.
=cut
sub load_optional_components {
my $class = shift;
$class->_load_components( grep
{ $class->load_optional_class( $_ ) }
( map
{ /^\+(.*)$/
? $1
: join ('::', $class->component_base_class, $_)
}
grep { $_ !~ /^#/ } @_
)
);
}
=head2 ensure_class_loaded
Given a class name, tests to see if it is already loaded or otherwise
defined. If it is not yet loaded, the package is require'd, and an exception
is thrown if the class is still not loaded.
BUG: For some reason, packages with syntax errors are added to %INC on
require
=cut
sub ensure_class_loaded {
my ($class, $f_class) = @_;
no strict 'refs';
# ripped from Class::Inspector for speed
# note that the order is important (faster items are first)
return if ${"${f_class}::VERSION"};
return if @{"${f_class}::ISA"};
my $file = (join ('/', split ('::', $f_class) ) ) . '.pm';
return if $INC{$file};
for ( keys %{"${f_class}::"} ) {
return if ( *{"${f_class}::$_"}{CODE} );
}
# require always returns true on success
# ill-behaved modules might very well obliterate $_
eval { local $_; require($file) } or do {
$@ = "Invalid class name '$f_class'" if $f_class =~ $invalid_class;
if ($class->can('throw_exception')) {
$class->throw_exception($@);
} else {
Carp::croak $@;
}
};
return;
}
=head2 ensure_class_found
Returns true if the specified class is installed or already loaded, false
otherwise.
=cut
sub ensure_class_found {
#my ($class, $f_class) = @_;
require Class::Inspector;
return Class::Inspector->loaded($_[1]) ||
Class::Inspector->installed($_[1]);
}
=head2 inject_base
Does the actual magic of adjusting C<@ISA> on the target module.
=cut
sub inject_base {
my $class = shift;
my $target = shift;
mro::set_mro($target, 'c3');
for my $comp (reverse @_) {
my $apply = do {
no strict 'refs';
sub { unshift ( @{"${target}::ISA"}, $comp ) };
};
unless ($target eq $comp || $target->isa($comp)) {
our %APPLICATOR_FOR;
if (my $apply_class
= List::Util::first { $APPLICATOR_FOR{$_} } @{mro::get_linear_isa($comp)}
) {
$APPLICATOR_FOR{$apply_class}->_apply_component_to_class($comp,$target,$apply);
} else {
$apply->();
}
}
}
}
=head2 load_optional_class
Returns a true value if the specified class is installed and loaded
successfully, throws an exception if the class is found but not loaded
successfully, and false if the class is not installed
=cut
sub load_optional_class {
my ($class, $f_class) = @_;
# ensure_class_loaded either returns a () (*not* true) or throws
eval {
$class->ensure_class_loaded($f_class);
1;
} && return 1;
my $err = $@; # so we don't lose it
if ($f_class =~ $invalid_class) {
$err = "Invalid class name '$f_class'";
}
else {
my $fn = quotemeta( (join ('/', split ('::', $f_class) ) ) . '.pm' );
return 0 if ($err =~ /Can't locate ${fn} in \@INC/ );
}
if ($class->can('throw_exception')) {
$class->throw_exception($err);
}
else {
die $err;
}
}
=head1 AUTHORS
Matt S. Trout and the L<DBIx::Class team|DBIx::Class/CONTRIBUTORS>
Pulled out into separate module by Ash Berlin C<< <ash@cpan.org> >>
Optimizations and overall bolt-tightening by Peter "ribasushi" Rabbitson
C<< <ribasushi@cpan.org> >>
=head1 COPYRIGHT
Copyright (c) 2006 - 2011 the Class::C3::Componentised L</AUTHORS> as listed
above.
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
1;

156
database/perl/vendor/lib/Class/C3/Componentised/ApplyHooks.pm vendored Normal file
View File

@@ -0,0 +1,156 @@
package Class::C3::Componentised::ApplyHooks;
use strict;
use warnings;
our %Before;
our %After;
sub BEFORE_APPLY (&) {
push @{$Before{scalar caller}}, $_[0];
$Class::C3::Componentised::APPLICATOR_FOR{scalar caller} = __PACKAGE__;
}
sub AFTER_APPLY (&) {
push @{$After {scalar caller}}, $_[0];
$Class::C3::Componentised::APPLICATOR_FOR{scalar caller} = __PACKAGE__;
}
sub _apply_component_to_class {
my ($me, $comp, $target, $apply) = @_;
my @heritage = @{mro::get_linear_isa($comp)};
my @before = map {
my $to_run = $Before{$_};
($to_run?[$_,$to_run]:())
} @heritage;
for my $todo (@before) {
my ($parent, $fn) = @$todo;
for my $f (reverse @$fn) {
$target->$f($parent)
}
}
$apply->();
my @after = map {
my $to_run = $After{$_};
($to_run?[$_,$to_run]:())
} @heritage;
for my $todo (reverse @after) {
my ($parent, $fn) = @$todo;
for my $f (@$fn) {
$target->$f($parent)
}
}
}
{
no strict 'refs';
sub import {
my ($from, @args) = @_;
my $to = caller;
my $default = 1;
my $i = 0;
my $skip = 0;
my @import;
for my $arg (@args) {
if ($skip) {
$skip--;
$i++;
next
}
if ($arg eq '-before_apply') {
$default = 0;
$skip = 1;
push @{$Before{$to}}, $args[$i + 1];
$Class::C3::Componentised::APPLICATOR_FOR{$to} = $from;
} elsif ($arg eq '-after_apply') {
$default = 0;
$skip = 1;
push @{$After{$to}}, $args[$i + 1];
$Class::C3::Componentised::APPLICATOR_FOR{$to} = $from;
} elsif ($arg =~ /^BEFORE_APPLY|AFTER_APPLY$/) {
$default = 0;
push @import, $arg
}
$i++;
}
@import = qw(BEFORE_APPLY AFTER_APPLY)
if $default;
*{"$to\::$_"} = \&{"$from\::$_"} for @import
}
}
1;
=head1 NAME
Class::C3::Componentised::ApplyHooks - Run methods before or after components are injected
=head1 SYNOPSIS
package MyComponent;
our %statistics;
use Class::C3::Componentised::ApplyHooks
-before_apply => sub {
my ($class, $component) = @_;
push @{$statistics{$class}}, '-before_apply';
},
-after_apply => sub {
my ($class, $component) = @_;
push @{$statistics{$class}}, '-after_apply';
}, qw(BEFORE_APPLY AFTER_APPLY);
BEFORE_APPLY { push @{$statistics{$class}}, 'BEFORE_APPLY' };
AFTER_APPLY { push @{$statistics{$class}}, 'AFTER_APPLY' };
AFTER_APPLY { use Devel::Dwarn; Dwarn %statistics };
1;
=head1 DESCRIPTION
This package allows a given component to run methods on the class that is being
injected into before or after the component is injected. Note from the
L</SYNOPSIS> that all C<Load Actions> may be run more than once.
=head1 IMPORT ACTION
Both import actions simply run a list of coderefs that will be passed the class
that is being acted upon and the component that is being added to the class.
=head1 IMPORT OPTIONS
=head2 -before_apply
Adds a before apply action for the current component without importing
any subroutines into your namespace.
=head2 -after_apply
Adds an after apply action for the current component without importing
any subroutines into your namespace.
=head1 EXPORTED SUBROUTINES
=head2 BEFORE_APPLY
BEFORE_APPLY { warn "about to apply $_[1] to class $_[0]" };
Adds a before apply action for the current component.
=head2 AFTER_APPLY
AFTER_APPLY { warn "just applied $_[1] to class $_[0]" };
Adds an after apply action for the current component.
=cut

106
database/perl/vendor/lib/Class/C3/next.pm vendored Normal file
View File

@@ -0,0 +1,106 @@
package # hide me from PAUSE
next;
use strict;
use warnings;
no warnings 'redefine'; # for 00load.t w/ core support
use Scalar::Util 'blessed';
our $VERSION = '0.35';
our %METHOD_CACHE;
sub method {
my $self = $_[0];
my $class = blessed($self) || $self;
my $indirect = caller() =~ /^(?:next|maybe::next)$/;
my $level = $indirect ? 2 : 1;
my ($method_caller, $label, @label);
while ($method_caller = (caller($level++))[3]) {
@label = (split '::', $method_caller);
$label = pop @label;
last unless
$label eq '(eval)' ||
$label eq '__ANON__';
}
my $method;
my $caller = join '::' => @label;
$method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
my @MRO = Class::C3::calculateMRO($class);
my $current;
while ($current = shift @MRO) {
last if $caller eq $current;
}
no strict 'refs';
my $found;
foreach my $class (@MRO) {
next if (defined $Class::C3::MRO{$class} &&
defined $Class::C3::MRO{$class}{methods}{$label});
last if (defined ($found = *{$class . '::' . $label}{CODE}));
}
$found;
};
return $method if $indirect;
die "No next::method '$label' found for $self" if !$method;
goto &{$method};
}
sub can { method($_[0]) }
package # hide me from PAUSE
maybe::next;
use strict;
use warnings;
no warnings 'redefine'; # for 00load.t w/ core support
our $VERSION = '0.35';
sub method { (next::method($_[0]) || return)->(@_) }
1;
__END__
=pod
=head1 NAME
Class::C3::next - Pure-perl next::method and friends
=head1 DESCRIPTION
This module is used internally by L<Class::C3> when
necessary, and shouldn't be used (or required in
distribution dependencies) directly. It
defines C<next::method>, C<next::can>, and
C<maybe::next::method> in pure perl.
=head1 AUTHOR
Stevan Little, <stevan@iinteractive.com>
Brandon L. Black, <blblack@gmail.com>
=head1 COPYRIGHT AND LICENSE
Copyright 2005, 2006 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

150
database/perl/vendor/lib/Class/Data/Inheritable.pm vendored Normal file
View File

@@ -0,0 +1,150 @@
package Class::Data::Inheritable;
use strict qw(vars subs);
use vars qw($VERSION);
$VERSION = '0.08';
sub mk_classdata {
my ($declaredclass, $attribute, $data) = @_;
if( ref $declaredclass ) {
require Carp;
Carp::croak("mk_classdata() is a class method, not an object method");
}
my $accessor = sub {
my $wantclass = ref($_[0]) || $_[0];
return $wantclass->mk_classdata($attribute)->(@_)
if @_>1 && $wantclass ne $declaredclass;
$data = $_[1] if @_>1;
return $data;
};
my $alias = "_${attribute}_accessor";
*{$declaredclass.'::'.$attribute} = $accessor;
*{$declaredclass.'::'.$alias} = $accessor;
}
1;
__END__
=head1 NAME
Class::Data::Inheritable - Inheritable, overridable class data
=head1 SYNOPSIS
package Stuff;
use base qw(Class::Data::Inheritable);
# Set up DataFile as inheritable class data.
Stuff->mk_classdata('DataFile');
# Declare the location of the data file for this class.
Stuff->DataFile('/etc/stuff/data');
# Or, all in one shot:
Stuff->mk_classdata(DataFile => '/etc/stuff/data');
=head1 DESCRIPTION
Class::Data::Inheritable is for creating accessor/mutators to class
data. That is, if you want to store something about your class as a
whole (instead of about a single object). This data is then inherited
by your subclasses and can be overriden.
For example:
Pere::Ubu->mk_classdata('Suitcase');
will generate the method Suitcase() in the class Pere::Ubu.
This new method can be used to get and set a piece of class data.
Pere::Ubu->Suitcase('Red');
$suitcase = Pere::Ubu->Suitcase;
The interesting part happens when a class inherits from Pere::Ubu:
package Raygun;
use base qw(Pere::Ubu);
# Raygun's suitcase is Red.
$suitcase = Raygun->Suitcase;
Raygun inherits its Suitcase class data from Pere::Ubu.
Inheritance of class data works analogous to method inheritance. As
long as Raygun does not "override" its inherited class data (by using
Suitcase() to set a new value) it will continue to use whatever is set
in Pere::Ubu and inherit further changes:
# Both Raygun's and Pere::Ubu's suitcases are now Blue
Pere::Ubu->Suitcase('Blue');
However, should Raygun decide to set its own Suitcase() it has now
"overridden" Pere::Ubu and is on its own, just like if it had
overriden a method:
# Raygun has an orange suitcase, Pere::Ubu's is still Blue.
Raygun->Suitcase('Orange');
Now that Raygun has overridden Pere::Ubu futher changes by Pere::Ubu
no longer effect Raygun.
# Raygun still has an orange suitcase, but Pere::Ubu is using Samsonite.
Pere::Ubu->Suitcase('Samsonite');
=head1 Methods
=head2 mk_classdata
Class->mk_classdata($data_accessor_name);
Class->mk_classdata($data_accessor_name => $value);
This is a class method used to declare new class data accessors.
A new accessor will be created in the Class using the name from
$data_accessor_name, and optionally initially setting it to the given
value.
To facilitate overriding, mk_classdata creates an alias to the
accessor, _field_accessor(). So Suitcase() would have an alias
_Suitcase_accessor() that does the exact same thing as Suitcase().
This is useful if you want to alter the behavior of a single accessor
yet still get the benefits of inheritable class data. For example.
sub Suitcase {
my($self) = shift;
warn "Fashion tragedy" if @_ and $_[0] eq 'Plaid';
$self->_Suitcase_accessor(@_);
}
=head1 AUTHOR
Original code by Damian Conway.
Maintained by Michael G Schwern until September 2005.
Now maintained by Tony Bowden.
=head1 BUGS and QUERIES
Please direct all correspondence regarding this module to:
bug-Class-Data-Inheritable@rt.cpan.org
=head1 COPYRIGHT and LICENSE
Copyright (c) 2000-2005, Damian Conway and Michael G Schwern.
All Rights Reserved.
This module is free software. It may be used, redistributed and/or
modified under the same terms as Perl itself.
=head1 SEE ALSO
L<perltooc> has a very elaborate discussion of class data in Perl.

101
database/perl/vendor/lib/Class/ErrorHandler.pm vendored Normal file
View File

@@ -0,0 +1,101 @@
# $Id: ErrorHandler.pm,v 1.1.1.1 2004/08/15 14:55:43 btrott Exp $
package Class::ErrorHandler;
use strict;
use vars qw( $VERSION $ERROR );
$VERSION = '0.04';
sub error {
my $msg = $_[1] || '';
if (ref($_[0])) {
$_[0]->{_errstr} = $msg;
} else {
$ERROR = $msg;
}
return;
}
sub errstr {
ref($_[0]) ? $_[0]->{_errstr} : $ERROR
}
1;
__END__
=for stopwords errstr
=head1 NAME
Class::ErrorHandler - Base class for error handling
=head1 SYNOPSIS
package Foo;
use base qw( Class::ErrorHandler );
sub class_method {
my $class = shift;
...
return $class->error("Help!")
unless $continue;
}
sub object_method {
my $obj = shift;
...
return $obj->error("I am no more")
unless $continue;
}
package main;
use Foo;
Foo->class_method or die Foo->errstr;
my $foo = Foo->new;
$foo->object_method or die $foo->errstr;
=head1 DESCRIPTION
I<Class::ErrorHandler> provides an error-handling mechanism that's generic
enough to be used as the base class for a variety of OO classes. Subclasses
inherit its two error-handling methods, I<error> and I<errstr>, to
communicate error messages back to the calling program.
On failure (for whatever reason), a subclass should call I<error> and return
to the caller; I<error> itself sets the error message internally, then
returns C<undef>. This has the effect of the method that failed returning
C<undef> to the caller. The caller should check for errors by checking for a
return value of C<undef>, and calling I<errstr> to get the value of the
error message on an error.
As demonstrated in the L<SYNOPSIS>, I<error> and I<errstr> work as both class
methods and object methods.
=head1 USAGE
=head2 Class->error($message)
=head2 $object->error($message)
Sets the error message for either the class I<Class> or the object
I<$object> to the message I<$message>. Returns C<undef>.
=head2 Class->errstr
=head2 $object->errstr
Accesses the last error message set in the class I<Class> or the
object I<$object>, respectively, and returns that error message.
=head1 LICENSE
This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
=head1 AUTHOR & COPYRIGHT
Except where otherwise noted, I<Class::ErrorHandler> is Copyright 2004
Benjamin Trott, cpan@stupidfool.org. All rights reserved.
=cut

662
database/perl/vendor/lib/Class/Inspector.pm vendored Normal file
View File

@@ -0,0 +1,662 @@
package Class::Inspector;
use 5.006;
# We don't want to use strict refs anywhere in this module, since we do a
# lot of things in here that aren't strict refs friendly.
use strict qw{vars subs};
use warnings;
use File::Spec ();
# ABSTRACT: Get information about a class and its structure
our $VERSION = '1.36'; # VERSION
# If Unicode is available, enable it so that the
# pattern matches below match unicode method names.
# We can safely ignore any failure here.
BEGIN {
local $@;
eval {
require utf8;
utf8->import;
};
}
# Predefine some regexs
our $RE_IDENTIFIER = qr/\A[^\W\d]\w*\z/s;
our $RE_CLASS = qr/\A[^\W\d]\w*(?:(?:\'|::)\w+)*\z/s;
# Are we on something Unix-like?
our $UNIX = !! ( $File::Spec::ISA[0] eq 'File::Spec::Unix' );
#####################################################################
# Basic Methods
sub _resolved_inc_handler {
my $class = shift;
my $filename = $class->_inc_filename(shift) or return undef;
foreach my $inc ( @INC ) {
my $ref = ref $inc;
if($ref eq 'CODE') {
my @ret = $inc->($inc, $filename);
if(@ret == 1 && ! defined $ret[0]) {
# do nothing.
} elsif(@ret) {
return 1;
}
}
elsif($ref eq 'ARRAY' && ref($inc->[0]) eq 'CODE') {
my @ret = $inc->[0]->($inc, $filename);
if(@ret) {
return 1;
}
}
elsif($ref && eval { $inc->can('INC') }) {
my @ret = $inc->INC($filename);
if(@ret) {
return 1;
}
}
}
'';
}
sub installed {
my $class = shift;
!! ($class->loaded_filename($_[0]) or $class->resolved_filename($_[0]) or $class->_resolved_inc_handler($_[0]));
}
sub loaded {
my $class = shift;
my $name = $class->_class(shift) or return undef;
$class->_loaded($name);
}
sub _loaded {
my $class = shift;
my $name = shift;
# Handle by far the two most common cases
# This is very fast and handles 99% of cases.
return 1 if defined ${"${name}::VERSION"};
return 1 if @{"${name}::ISA"};
# Are there any symbol table entries other than other namespaces
foreach ( keys %{"${name}::"} ) {
next if substr($_, -2, 2) eq '::';
return 1 if defined &{"${name}::$_"};
}
# No functions, and it doesn't have a version, and isn't anything.
# As an absolute last resort, check for an entry in %INC
my $filename = $class->_inc_filename($name);
return 1 if defined $INC{$filename};
'';
}
sub filename {
my $class = shift;
my $name = $class->_class(shift) or return undef;
File::Spec->catfile( split /(?:\'|::)/, $name ) . '.pm';
}
sub resolved_filename {
my $class = shift;
my $filename = $class->_inc_filename(shift) or return undef;
my @try_first = @_;
# Look through the @INC path to find the file
foreach ( @try_first, @INC ) {
my $full = "$_/$filename";
next unless -e $full;
return $UNIX ? $full : $class->_inc_to_local($full);
}
# File not found
'';
}
sub loaded_filename {
my $class = shift;
my $filename = $class->_inc_filename(shift);
$UNIX ? $INC{$filename} : $class->_inc_to_local($INC{$filename});
}
#####################################################################
# Sub Related Methods
sub functions {
my $class = shift;
my $name = $class->_class(shift) or return undef;
return undef unless $class->loaded( $name );
# Get all the CODE symbol table entries
my @functions = sort grep { /$RE_IDENTIFIER/o }
grep { defined &{"${name}::$_"} }
keys %{"${name}::"};
\@functions;
}
sub function_refs {
my $class = shift;
my $name = $class->_class(shift) or return undef;
return undef unless $class->loaded( $name );
# Get all the CODE symbol table entries, but return
# the actual CODE refs this time.
my @functions = map { \&{"${name}::$_"} }
sort grep { /$RE_IDENTIFIER/o }
grep { defined &{"${name}::$_"} }
keys %{"${name}::"};
\@functions;
}
sub function_exists {
my $class = shift;
my $name = $class->_class( shift ) or return undef;
my $function = shift or return undef;
# Only works if the class is loaded
return undef unless $class->loaded( $name );
# Does the GLOB exist and its CODE part exist
defined &{"${name}::$function"};
}
sub methods {
my $class = shift;
my $name = $class->_class( shift ) or return undef;
my @arguments = map { lc $_ } @_;
# Process the arguments to determine the options
my %options = ();
foreach ( @arguments ) {
if ( $_ eq 'public' ) {
# Only get public methods
return undef if $options{private};
$options{public} = 1;
} elsif ( $_ eq 'private' ) {
# Only get private methods
return undef if $options{public};
$options{private} = 1;
} elsif ( $_ eq 'full' ) {
# Return the full method name
return undef if $options{expanded};
$options{full} = 1;
} elsif ( $_ eq 'expanded' ) {
# Returns class, method and function ref
return undef if $options{full};
$options{expanded} = 1;
} else {
# Unknown or unsupported options
return undef;
}
}
# Only works if the class is loaded
return undef unless $class->loaded( $name );
# Get the super path ( not including UNIVERSAL )
# Rather than using Class::ISA, we'll use an inlined version
# that implements the same basic algorithm.
my @path = ();
my @queue = ( $name );
my %seen = ( $name => 1 );
while ( my $cl = shift @queue ) {
push @path, $cl;
unshift @queue, grep { ! $seen{$_}++ }
map { s/^::/main::/; s/\'/::/g; $_ } ## no critic
map { "$_" }
( @{"${cl}::ISA"} );
}
# Find and merge the function names across the entire super path.
# Sort alphabetically and return.
my %methods = ();
foreach my $namespace ( @path ) {
my @functions = grep { ! $methods{$_} }
grep { /$RE_IDENTIFIER/o }
grep { defined &{"${namespace}::$_"} }
keys %{"${namespace}::"};
foreach ( @functions ) {
$methods{$_} = $namespace;
}
}
# Filter to public or private methods if needed
my @methodlist = sort keys %methods;
@methodlist = grep { ! /^\_/ } @methodlist if $options{public};
@methodlist = grep { /^\_/ } @methodlist if $options{private};
# Return in the correct format
@methodlist = map { "$methods{$_}::$_" } @methodlist if $options{full};
@methodlist = map {
[ "$methods{$_}::$_", $methods{$_}, $_, \&{"$methods{$_}::$_"} ]
} @methodlist if $options{expanded};
\@methodlist;
}
#####################################################################
# Search Methods
sub subclasses {
my $class = shift;
my $name = $class->_class( shift ) or return undef;
# Prepare the search queue
my @found = ();
my @queue = grep { $_ ne 'main' } $class->_subnames('');
while ( @queue ) {
my $c = shift(@queue); # c for class
if ( $class->_loaded($c) ) {
# At least one person has managed to misengineer
# a situation in which ->isa could die, even if the
# class is real. Trap these cases and just skip
# over that (bizarre) class. That would at limit
# problems with finding subclasses to only the
# modules that have broken ->isa implementation.
local $@;
eval {
if ( $c->isa($name) ) {
# Add to the found list, but don't add the class itself
push @found, $c unless $c eq $name;
}
};
}
# Add any child namespaces to the head of the queue.
# This keeps the queue length shorted, and allows us
# not to have to do another sort at the end.
unshift @queue, map { "${c}::$_" } $class->_subnames($c);
}
@found ? \@found : '';
}
sub _subnames {
my ($class, $name) = @_;
return sort
grep { ## no critic
substr($_, -2, 2, '') eq '::'
and
/$RE_IDENTIFIER/o
}
keys %{"${name}::"};
}
#####################################################################
# Children Related Methods
# These can go undocumented for now, until I decide if its best to
# just search the children in namespace only, or if I should do it via
# the file system.
# Find all the loaded classes below us
sub children {
my $class = shift;
my $name = $class->_class(shift) or return ();
# Find all the Foo:: elements in our symbol table
no strict 'refs';
map { "${name}::$_" } sort grep { s/::$// } keys %{"${name}::"}; ## no critic
}
# As above, but recursively
sub recursive_children {
my $class = shift;
my $name = $class->_class(shift) or return ();
my @children = ( $name );
# Do the search using a nicer, more memory efficient
# variant of actual recursion.
my $i = 0;
no strict 'refs';
while ( my $namespace = $children[$i++] ) {
push @children, map { "${namespace}::$_" }
grep { ! /^::/ } # Ignore things like ::ISA::CACHE::
grep { s/::$// } ## no critic
keys %{"${namespace}::"};
}
sort @children;
}
#####################################################################
# Private Methods
# Checks and expands ( if needed ) a class name
sub _class {
my $class = shift;
my $name = shift or return '';
# Handle main shorthand
return 'main' if $name eq '::';
$name =~ s/\A::/main::/;
# Check the class name is valid
$name =~ /$RE_CLASS/o ? $name : '';
}
# Create a INC-specific filename, which always uses '/'
# regardless of platform.
sub _inc_filename {
my $class = shift;
my $name = $class->_class(shift) or return undef;
join( '/', split /(?:\'|::)/, $name ) . '.pm';
}
# Convert INC-specific file name to local file name
sub _inc_to_local {
# Shortcut in the Unix case
return $_[1] if $UNIX;
# On other places, we have to deal with an unusual path that might look
# like C:/foo/bar.pm which doesn't fit ANY normal pattern.
# Putting it through splitpath/dir and back again seems to normalise
# it to a reasonable amount.
my $class = shift;
my $inc_name = shift or return undef;
my ($vol, $dir, $file) = File::Spec->splitpath( $inc_name );
$dir = File::Spec->catdir( File::Spec->splitdir( $dir || "" ) );
File::Spec->catpath( $vol, $dir, $file || "" );
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::Inspector - Get information about a class and its structure
=head1 VERSION
version 1.36
=head1 SYNOPSIS
use Class::Inspector;
# Is a class installed and/or loaded
Class::Inspector->installed( 'Foo::Class' );
Class::Inspector->loaded( 'Foo::Class' );
# Filename related information
Class::Inspector->filename( 'Foo::Class' );
Class::Inspector->resolved_filename( 'Foo::Class' );
# Get subroutine related information
Class::Inspector->functions( 'Foo::Class' );
Class::Inspector->function_refs( 'Foo::Class' );
Class::Inspector->function_exists( 'Foo::Class', 'bar' );
Class::Inspector->methods( 'Foo::Class', 'full', 'public' );
# Find all loaded subclasses or something
Class::Inspector->subclasses( 'Foo::Class' );
=head1 DESCRIPTION
Class::Inspector allows you to get information about a loaded class. Most or
all of this information can be found in other ways, but they aren't always
very friendly, and usually involve a relatively high level of Perl wizardry,
or strange and unusual looking code. Class::Inspector attempts to provide
an easier, more friendly interface to this information.
=head1 METHODS
=head2 installed
my $bool = Class::Inspector->installed($class);
The C<installed> static method tries to determine if a class is installed
on the machine, or at least available to Perl. It does this by wrapping
around C<resolved_filename>.
Returns true if installed/available, false if the class is not installed,
or C<undef> if the class name is invalid.
=head2 loaded
my $bool = Class::Inspector->loaded($class);
The C<loaded> static method tries to determine if a class is loaded by
looking for symbol table entries.
This method it uses to determine this will work even if the class does not
have its own file, but is contained inside a single file with multiple
classes in it. Even in the case of some sort of run-time loading class
being used, these typically leave some trace in the symbol table, so an
L<Autoload> or L<Class::Autouse>-based class should correctly appear
loaded.
Returns true if the class is loaded, false if not, or C<undef> if the
class name is invalid.
=head2 filename
my $filename = Class::Inspector->filename($class);
For a given class, returns the base filename for the class. This will NOT
be a fully resolved filename, just the part of the filename BELOW the
C<@INC> entry.
print Class->filename( 'Foo::Bar' );
> Foo/Bar.pm
This filename will be returned with the right separator for the local
platform, and should work on all platforms.
Returns the filename on success or C<undef> if the class name is invalid.
=head2 resolved_filename
my $filename = Class::Inspector->resolved_filename($class);
my $filename = Class::Inspector->resolved_filename($class, @try_first);
For a given class, the C<resolved_filename> static method returns the fully
resolved filename for a class. That is, the file that the class would be
loaded from.
This is not necessarily the file that the class WAS loaded from, as the
value returned is determined each time it runs, and the C<@INC> include
path may change.
To get the actual file for a loaded class, see the C<loaded_filename>
method.
Returns the filename for the class, or C<undef> if the class name is
invalid.
=head2 loaded_filename
my $filename = Class::Inspector->loaded_filename($class);
For a given loaded class, the C<loaded_filename> static method determines
(via the C<%INC> hash) the name of the file that it was originally loaded
from.
Returns a resolved file path, or false if the class did not have it's own
file.
=head2 functions
my $arrayref = Class::Inspector->functions($class);
For a loaded class, the C<functions> static method returns a list of the
names of all the functions in the classes immediate namespace.
Note that this is not the METHODS of the class, just the functions.
Returns a reference to an array of the function names on success, or C<undef>
if the class name is invalid or the class is not loaded.
=head2 function_refs
my $arrayref = Class::Inspector->function_refs($class);
For a loaded class, the C<function_refs> static method returns references to
all the functions in the classes immediate namespace.
Note that this is not the METHODS of the class, just the functions.
Returns a reference to an array of C<CODE> refs of the functions on
success, or C<undef> if the class is not loaded.
=head2 function_exists
my $bool = Class::Inspector->function_exists($class, $functon);
Given a class and function name the C<function_exists> static method will
check to see if the function exists in the class.
Note that this is as a function, not as a method. To see if a method
exists for a class, use the C<can> method for any class or object.
Returns true if the function exists, false if not, or C<undef> if the
class or function name are invalid, or the class is not loaded.
=head2 methods
my $arrayref = Class::Inspector->methods($class, @options);
For a given class name, the C<methods> static method will returns ALL
the methods available to that class. This includes all methods available
from every class up the class' C<@ISA> tree.
Returns a reference to an array of the names of all the available methods
on success, or C<undef> if the class name is invalid or the class is not
loaded.
A number of options are available to the C<methods> method that will alter
the results returned. These should be listed after the class name, in any
order.
# Only get public methods
my $method = Class::Inspector->methods( 'My::Class', 'public' );
=over 4
=item public
The C<public> option will return only 'public' methods, as defined by the Perl
convention of prepending an underscore to any 'private' methods. The C<public>
option will effectively remove any methods that start with an underscore.
=item private
The C<private> options will return only 'private' methods, as defined by the
Perl convention of prepending an underscore to an private methods. The
C<private> option will effectively remove an method that do not start with an
underscore.
B<Note: The C<public> and C<private> options are mutually exclusive>
=item full
C<methods> normally returns just the method name. Supplying the C<full> option
will cause the methods to be returned as the full names. That is, instead of
returning C<[ 'method1', 'method2', 'method3' ]>, you would instead get
C<[ 'Class::method1', 'AnotherClass::method2', 'Class::method3' ]>.
=item expanded
The C<expanded> option will cause a lot more information about method to be
returned. Instead of just the method name, you will instead get an array
reference containing the method name as a single combined name, a la C<full>,
the separate class and method, and a CODE ref to the actual function ( if
available ). Please note that the function reference is not guaranteed to
be available. C<Class::Inspector> is intended at some later time, to work
with modules that have some kind of common run-time loader in place ( e.g
C<Autoloader> or C<Class::Autouse> for example.
The response from C<methods( 'Class', 'expanded' )> would look something like
the following.
[
[ 'Class::method1', 'Class', 'method1', \&Class::method1 ],
[ 'Another::method2', 'Another', 'method2', \&Another::method2 ],
[ 'Foo::bar', 'Foo', 'bar', \&Foo::bar ],
]
=back
=head2 subclasses
my $arrayref = Class::Inspector->subclasses($class);
The C<subclasses> static method will search then entire namespace (and thus
B<all> currently loaded classes) to find all classes that are subclasses
of the class provided as a the parameter.
The actual test will be done by calling C<isa> on the class as a static
method. (i.e. C<My::Class-E<gt>isa($class)>.
Returns a reference to a list of the loaded classes that match the class
provided, or false is none match, or C<undef> if the class name provided
is invalid.
=head1 SEE ALSO
L<http://ali.as/>, L<Class::Handle>, L<Class::Inspector::Functions>
=head1 AUTHOR
Original author: Adam Kennedy E<lt>adamk@cpan.orgE<gt>
Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
Contributors:
Tom Wyant
Steffen Müller
Kivanc Yazan (KYZN)
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2002-2019 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

136
database/perl/vendor/lib/Class/Inspector/Functions.pm vendored Normal file
View File

@@ -0,0 +1,136 @@
package Class::Inspector::Functions;
use 5.006;
use strict;
use warnings;
use Exporter ();
use Class::Inspector ();
use base qw( Exporter );
# ABSTRACT: Get information about a class and its structure
our $VERSION = '1.36'; # VERSION
BEGIN {
our @EXPORT = qw(
installed
loaded
filename
functions
methods
subclasses
);
our @EXPORT_OK = qw(
resolved_filename
loaded_filename
function_refs
function_exists
);
#children
#recursive_children
our %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] );
foreach my $meth (@EXPORT, @EXPORT_OK) {
my $sub = Class::Inspector->can($meth);
no strict 'refs';
*{$meth} = sub {&$sub('Class::Inspector', @_)};
}
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::Inspector::Functions - Get information about a class and its structure
=head1 VERSION
version 1.36
=head1 SYNOPSIS
use Class::Inspector::Functions;
# Class::Inspector provides a non-polluting,
# method based interface!
# Is a class installed and/or loaded
installed( 'Foo::Class' );
loaded( 'Foo::Class' );
# Filename related information
filename( 'Foo::Class' );
resolved_filename( 'Foo::Class' );
# Get subroutine related information
functions( 'Foo::Class' );
function_refs( 'Foo::Class' );
function_exists( 'Foo::Class', 'bar' );
methods( 'Foo::Class', 'full', 'public' );
# Find all loaded subclasses or something
subclasses( 'Foo::Class' );
=head1 DESCRIPTION
Class::Inspector::Functions is a function based interface of
L<Class::Inspector>. For a thorough documentation of the available
functions, please check the manual for the main module.
=head2 Exports
The following functions are exported by default.
installed
loaded
filename
functions
methods
subclasses
The following functions are exported only by request.
resolved_filename
loaded_filename
function_refs
function_exists
All the functions may be imported using the C<:ALL> tag.
=head1 SEE ALSO
L<http://ali.as/>, L<Class::Handle>, L<Class::Inspector>
=head1 AUTHOR
Original author: Adam Kennedy E<lt>adamk@cpan.orgE<gt>
Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
Contributors:
Tom Wyant
Steffen Müller
Kivanc Yazan (KYZN)
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2002-2019 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

420
database/perl/vendor/lib/Class/Load.pm vendored Normal file
View File

@@ -0,0 +1,420 @@
use strict;
use warnings;
package Class::Load; # git description: v0.24-5-g22a44fd
# ABSTRACT: A working (require "Class::Name") and more
# KEYWORDS: class module load require use runtime
our $VERSION = '0.25';
use base 'Exporter';
use Data::OptList 0.110 ();
use Module::Implementation 0.04;
use Module::Runtime 0.012 ();
use Try::Tiny;
{
my $loader = Module::Implementation::build_loader_sub(
implementations => [ 'XS', 'PP' ],
symbols => ['is_class_loaded'],
);
$loader->();
}
our @EXPORT_OK = qw/load_class load_optional_class try_load_class is_class_loaded load_first_existing_class/;
our %EXPORT_TAGS = (
all => \@EXPORT_OK,
);
our $ERROR;
sub load_class {
my $class = shift;
my $options = shift;
my ($res, $e) = try_load_class($class, $options);
return $class if $res;
_croak($e);
}
sub load_first_existing_class {
my $classes = Data::OptList::mkopt(\@_)
or return;
foreach my $class (@{$classes}) {
Module::Runtime::check_module_name($class->[0]);
}
for my $class (@{$classes}) {
my ($name, $options) = @{$class};
# We need to be careful not to pass an undef $options to this sub,
# since the XS version will blow up if that happens.
return $name if is_class_loaded($name, ($options ? $options : ()));
my ($res, $e) = try_load_class($name, $options);
return $name if $res;
my $file = Module::Runtime::module_notional_filename($name);
next if $e =~ /^Can't locate \Q$file\E in \@INC/;
next
if $options
&& defined $options->{-version}
&& $e =~ _version_fail_re($name, $options->{-version});
_croak("Couldn't load class ($name) because: $e");
}
my @list = map {
$_->[0]
. ( $_->[1] && defined $_->[1]{-version}
? " (version >= $_->[1]{-version})"
: q{} )
} @{$classes};
my $err
.= q{Can't locate }
. _or_list(@list)
. " in \@INC (\@INC contains: @INC).";
_croak($err);
}
sub _version_fail_re {
my $name = shift;
my $vers = shift;
return qr/\Q$name\E version \Q$vers\E required--this is only version/;
}
sub _nonexistent_fail_re {
my $name = shift;
my $file = Module::Runtime::module_notional_filename($name);
return qr/Can't locate \Q$file\E in \@INC/;
}
sub _or_list {
return $_[0] if @_ == 1;
return join ' or ', @_ if @_ ==2;
my $last = pop;
my $list = join ', ', @_;
$list .= ', or ' . $last;
return $list;
}
sub load_optional_class {
my $class = shift;
my $options = shift;
Module::Runtime::check_module_name($class);
my ($res, $e) = try_load_class($class, $options);
return 1 if $res;
return 0
if $options
&& defined $options->{-version}
&& $e =~ _version_fail_re($class, $options->{-version});
return 0
if $e =~ _nonexistent_fail_re($class);
_croak($e);
}
sub try_load_class {
my $class = shift;
my $options = shift;
Module::Runtime::check_module_name($class);
local $@;
undef $ERROR;
if (is_class_loaded($class)) {
# We need to check this here rather than in is_class_loaded() because
# we want to return the error message for a failed version check, but
# is_class_loaded just returns true/false.
return 1 unless $options && defined $options->{-version};
return try {
$class->VERSION($options->{-version});
1;
}
catch {
_error($_);
};
}
my $file = Module::Runtime::module_notional_filename($class);
# This says "our diagnostics of the package
# say perl's INC status about the file being loaded are
# wrong", so we delete it from %INC, so when we call require(),
# perl will *actually* try reloading the file.
#
# If the file is already in %INC, it won't retry,
# And on 5.8, it won't fail either!
#
# The extra benefit of this trick, is it helps even on
# 5.10, as instead of dying with "Compilation failed",
# it will die with the actual error, and that's a win-win.
delete $INC{$file};
return try {
local $SIG{__DIE__} = 'DEFAULT';
if ($options && defined $options->{-version}) {
Module::Runtime::use_module($class, $options->{-version});
}
else {
Module::Runtime::require_module($class);
}
1;
}
catch {
_error($_);
};
}
sub _error {
my $e = shift;
$e =~ s/ at .+?Runtime\.pm line [0-9]+\.$//;
chomp $e;
$ERROR = $e;
return 0 unless wantarray;
return 0, $ERROR;
}
sub _croak {
require Carp;
local $Carp::CarpLevel = $Carp::CarpLevel + 2;
Carp::croak(shift);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::Load - A working (require "Class::Name") and more
=head1 VERSION
version 0.25
=head1 SYNOPSIS
use Class::Load ':all';
try_load_class('Class::Name')
or plan skip_all => "Class::Name required to run these tests";
load_class('Class::Name');
is_class_loaded('Class::Name');
my $baseclass = load_optional_class('Class::Name::MightExist')
? 'Class::Name::MightExist'
: 'Class::Name::Default';
=head1 DESCRIPTION
C<require EXPR> only accepts C<Class/Name.pm> style module names, not
C<Class::Name>. How frustrating! For that, we provide
C<load_class 'Class::Name'>.
It's often useful to test whether a module can be loaded, instead of throwing
an error when it's not available. For that, we provide
C<try_load_class 'Class::Name'>.
Finally, sometimes we need to know whether a particular class has been loaded.
Asking C<%INC> is an option, but that will miss inner packages and any class
for which the filename does not correspond to the package name. For that, we
provide C<is_class_loaded 'Class::Name'>.
=head1 FUNCTIONS
=head2 load_class Class::Name, \%options
C<load_class> will load C<Class::Name> or throw an error, much like C<require>.
If C<Class::Name> is already loaded (checked with C<is_class_loaded>) then it
will not try to load the class. This is useful when you have inner packages
which C<require> does not check.
The C<%options> hash currently accepts one key, C<-version>. If you specify a
version, then this subroutine will call C<< Class::Name->VERSION(
$options{-version} ) >> internally, which will throw an error if the class's
version is not equal to or greater than the version you requested.
This method will return the name of the class on success.
=head2 try_load_class Class::Name, \%options -> (0|1, error message)
Returns 1 if the class was loaded, 0 if it was not. If the class was not
loaded, the error will be returned as a second return value in list context.
Again, if C<Class::Name> is already loaded (checked with C<is_class_loaded>)
then it will not try to load the class. This is useful when you have inner
packages which C<require> does not check.
Like C<load_class>, you can pass a C<-version> in C<%options>. If the version
is not sufficient, then this subroutine will return false.
=head2 is_class_loaded Class::Name, \%options -> 0|1
This uses a number of heuristics to determine if the class C<Class::Name> is
loaded. There heuristics were taken from L<Class::MOP>'s old pure-perl
implementation.
Like C<load_class>, you can pass a C<-version> in C<%options>. If the version
is not sufficient, then this subroutine will return false.
=head2 load_first_existing_class Class::Name, \%options, ...
This attempts to load the first loadable class in the list of classes
given. Each class name can be followed by an options hash reference.
If any one of the classes loads and passes the optional version check, that
class name will be returned. If I<none> of the classes can be loaded (or none
pass their version check), then an error will be thrown.
If, when attempting to load a class, it fails to load because of a syntax
error, then an error will be thrown immediately.
=head2 load_optional_class Class::Name, \%options -> 0|1
C<load_optional_class> is a lot like C<try_load_class>, but also a lot like
C<load_class>.
If the class exists, and it works, then it will return 1. If you specify a
version in C<%options>, then the version check must succeed or it will return
0.
If the class doesn't exist, and it appears to not exist on disk either, it
will return 0.
If the class exists on disk, but loading from disk results in an error
(e.g.: a syntax error), then it will C<croak> with that error.
This is useful for using if you want a fallback module system, i.e.:
my $class = load_optional_class($foo) ? $foo : $default;
That way, if $foo does exist, but can't be loaded due to error, you won't
get the behaviour of it simply not existing.
=head1 CAVEATS
Because of some of the heuristics that this module uses to infer whether a
module has been loaded, some false positives may occur in C<is_class_loaded>
checks (which are also performed internally in other interfaces) -- if a class
has started to be loaded but then dies, it may appear that it has already been
loaded, which can cause other things to make the wrong decision.
L<Module::Runtime> doesn't have this issue, but it also doesn't do some things
that this module does -- for example gracefully handle packages that have been
defined inline in the same file as another package.
=head1 SEE ALSO
=over 4
=item L<http://blog.fox.geek.nz/2010/11/searching-design-spec-for-ultimate.html>
This blog post is a good overview of the current state of the existing modules
for loading other modules in various ways.
=item L<http://blog.fox.geek.nz/2010/11/handling-optional-requirements-with.html>
This blog post describes how to handle optional modules with L<Class::Load>.
=item L<http://d.hatena.ne.jp/tokuhirom/20110202/1296598578>
This Japanese blog post describes why L<DBIx::Skinny> now uses L<Class::Load>
over its competitors.
=item L<Moose>, L<Jifty>, L<Prophet>, etc
This module was designed to be used anywhere you have
C<if (eval "require $module"; 1)>, which occurs in many large projects.
=item L<Module::Runtime>
A leaner approach to loading modules
=back
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Class-Load>
(or L<bug-Class-Load@rt.cpan.org|mailto:bug-Class-Load@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Shawn M Moore <sartak at bestpractical.com>
=head1 CONTRIBUTORS
=for stopwords Dave Rolsky Karen Etheridge Shawn Moore Jesse Luehrs Kent Fredric Paul Howarth Olivier Mengué Caleb Cushing
=over 4
=item *
Dave Rolsky <autarch@urth.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Shawn Moore <sartak@bestpractical.com>
=item *
Jesse Luehrs <doy@tozt.net>
=item *
Kent Fredric <kentfredric@gmail.com>
=item *
Paul Howarth <paul@city-fan.org>
=item *
Olivier Mengué <dolmen@cpan.org>
=item *
Caleb Cushing <xenoterracide@gmail.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Shawn M Moore.
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

59
database/perl/vendor/lib/Class/Load/PP.pm vendored Normal file
View File

@@ -0,0 +1,59 @@
use strict;
use warnings;
package Class::Load::PP;
our $VERSION = '0.25';
use Module::Runtime ();
use Package::Stash 0.14;
use Scalar::Util ();
use Try::Tiny;
sub is_class_loaded {
my $class = shift;
my $options = shift;
my $loaded = _is_class_loaded($class);
return $loaded if ! $loaded;
return $loaded unless $options && $options->{-version};
return try {
$class->VERSION($options->{-version});
1;
}
catch {
0;
};
}
sub _is_class_loaded {
my $class = shift;
return 0 unless Module::Runtime::is_module_name($class);
my $stash = Package::Stash->new($class);
if ($stash->has_symbol('$VERSION')) {
my $version = ${ $stash->get_symbol('$VERSION') };
if (defined $version) {
return 1 if ! ref $version;
# Sometimes $VERSION ends up as a reference to undef (weird)
return 1 if ref $version && Scalar::Util::reftype $version eq 'SCALAR' && defined ${$version};
# a version object
return 1 if Scalar::Util::blessed $version;
}
}
if ($stash->has_symbol('@ISA')) {
return 1 if @{ $stash->get_symbol('@ISA') };
}
# check for any method
return 1 if $stash->list_all_symbols('CODE');
# fail
return 0;
}
1;

89
database/perl/vendor/lib/Class/Load/XS.pm vendored Normal file
View File

@@ -0,0 +1,89 @@
package Class::Load::XS; # git description: v0.09-19-g9364900
use strict;
use warnings;
our $VERSION = '0.10';
use Class::Load 0.20;
use XSLoader;
XSLoader::load(
__PACKAGE__,
$VERSION,
);
1;
# ABSTRACT: XS implementation of parts of Class::Load
# KEYWORDS: class module load require use runtime XS
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::Load::XS - XS implementation of parts of Class::Load
=head1 VERSION
version 0.10
=head1 SYNOPSIS
use Class::Load;
=head1 DESCRIPTION
This module provides an XS implementation for portions of L<Class::Load>. See
L<Class::Load> for API details.
=for Pod::Coverage is_class_loaded
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Class-Load-XS>
(or L<bug-Class-Load-XS@rt.cpan.org|mailto:bug-Class-Load-XS@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 CONTRIBUTORS
=for stopwords Karen Etheridge Jesse Luehrs hurricup
=over 4
=item *
Karen Etheridge <ether@cpan.org>
=item *
Jesse Luehrs <doy@tozt.net>
=item *
hurricup <hurricup@gmail.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2011 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

221
database/perl/vendor/lib/Class/Loader.pm vendored Normal file
View File

@@ -0,0 +1,221 @@
#!/usr/bin/perl -sw
##
## Class::Loader
##
## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
## This code is free software; you can redistribute it and/or modify
## it under the same terms as Perl itself.
##
## $Id: Loader.pm,v 2.2 2001/07/18 20:21:39 vipul Exp $
package Class::Loader;
use Data::Dumper;
use vars qw($VERSION);
($VERSION) = '$Revision: 2.03 $' =~ /\s(\d+\.\d+)\s/;
my %MAPS = ();
sub new {
return bless {}, shift;
}
sub _load {
my ($self, $field, @source) = @_;
if ((scalar @source) % 2) {
unshift @source, $field;
$field = ""
}
local ($name, $module, $constructor, $args);
my %source = @source;
my $class = ref $self || $self;
my $object;
for (keys %source) { ${lc($_)} = $source{$_} }
if ($name) {
my $classmap = $self->_retrmap ($class) || return;
my $map = $$classmap{$name} || return;
for (keys %$map) { ${lc($_)} = $$map{$_} };
}
if ($module) {
unless (eval "require $module") {
if ($source{CPAN}) {
require CPAN; CPAN->import;
my $obj = CPAN::Shell->expand ('Module', $module);
return unless $obj;
$obj->install;
eval "require $module" || return;
} else { return }
}
$constructor ||= 'new';
if ($args) {
my $topass = __prepare_args ($args);
$object = eval "$module->$constructor($topass)" or return;
undef $topass; undef $args;
} else { $object = eval "$module->$constructor" or return }
} else { return }
return $field ? $$self{$field} = $object : $object
}
sub _storemap {
my ($self, %map) = @_;
my $class = ref $self;
for (keys %map) { $MAPS{$class}{$_} = $map{$_} }
}
sub _retrmap {
my ($self) = @_;
my $class = ref $self;
return $MAPS{$class} if $MAPS{$class};
return;
}
sub __prepare_args {
my $topass = Dumper shift;
$topass =~ s/\$VAR1 = \[//;
$topass =~ s/];\s*//g;
$topass =~ m/(.*)/s;
$topass = $1;
return $topass;
}
1;
=head1 NAME
Class::Loader - Load modules and create objects on demand.
=head1 VERSION
$Revision: 2.2 $
$Date: 2001/07/18 20:21:39 $
=head1 SYNOPSIS
package Web::Server;
use Class::Loader;
@ISA = qw(Class::Loader);
$self->_load( 'Content_Handler', {
Module => "Filter::URL",
Constructor => "new",
Args => [ ],
}
);
=head1 DESCRIPTION
Certain applications like to defer the decision to use a particular module
till runtime. This is possible in perl, and is a useful trick in
situations where the type of data is not known at compile time and the
application doesn't wish to pre-compile modules to handle all types of
data it can work with. Loading modules at runtime can also provide
flexible interfaces for perl modules. Modules can let the programmer
decide what modules will be used by it instead of hard-coding their names.
Class::Loader is an inheritable class that provides a method, _load(),
to load a module from disk and construct an object by calling its
constructor. It also provides a way to map modules names and
associated metadata with symbolic names that can be used in place of
module names at _load().
=head1 METHODS
=over 4
=item B<new()>
A basic constructor. You can use this to create an object of
Class::Loader, in case you don't want to inherit Class::Loader.
=item B<_load()>
_load() loads a module and calls its constructor. It returns the newly
constructed object on success or a non-true value on failure. The first
argument can be the name of the key in which the returned object is
stored. This argument is optional. The second (or the first) argument is a
hash which can take the following keys:
=over 4
=item B<Module>
This is name of the class to load. (It is not the module's filename.)
=item B<Name>
Symbolic name of the module defined with _storemap(). Either one of Module
or Name keys must be present in a call to _load().
=item B<Constructor>
Name of the Module constructor. Defaults to "new".
=item B<Args>
A reference to the list of arguments for the constructor. _load() calls
the constructor with this list. If no Args are present, _load() will call
the constructor without any arguments.
=item B<CPAN>
If the Module is not installed on the local system, _load() can fetch &
install it from CPAN provided the CPAN key is present. This functionality
assumes availability of a pre-configured CPAN shell.
=back
=item B<_storemap()>
Class::Loader maintains a class table that maps symbolic names to
parameters accepted by _load(). It takes a hash as argument whose keys are
symbolic names and value are hash references that contain a set of _load()
arguments. Here's an example:
$self->_storemap ( "URL" => { Module => "Filter::URL",
Constructor => "foo",
Args => [qw(bar baz)],
}
);
# time passes...
$self->{handler} = $self->_load ( Name => 'URL' );
=item B<_retrmap()>
_retrmap() returns the entire map stored with Class::Loader. Class::Loader
maintains separate maps for different classes, and _retrmap() returns the
map valid in the caller class.
=back
=head1 SEE ALSO
AnyLoader(3)
=head1 AUTHOR
Vipul Ved Prakash, E<lt>mail@vipul.netE<gt>
=head1 LICENSE
Copyright (c) 2001, Vipul Ved Prakash. All rights reserved. This code is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.
=cut

41
database/perl/vendor/lib/Class/LoaderTest.pm vendored Normal file
View File

@@ -0,0 +1,41 @@
#!/usr/bin/perl -sw
##
##
##
## Copyright (c) 2001, Vipul Ved Prakash. All rights reserved.
## This code is free software; you can redistribute it and/or modify
## it under the same terms as Perl itself.
##
## $Id: LoaderTest.pm,v 1.2 2001/05/01 00:09:12 vipul Exp $
package Class::LoaderTest;
use Data::Dumper;
sub new {
my $self = { Method => 'new' };
return bless $self, shift;
}
sub foo {
my ($class, $embed) = @_;
$embed ||= 'foo';
my $self = { Method => $embed };
return bless $self, shift;
}
sub blah {
my ($class, %params) = @_;
my $self = { %params };
return bless $self, $class;
}
1;

1222
database/perl/vendor/lib/Class/MOP.pm vendored Normal file
View File

File diff suppressed because it is too large Load Diff

1100
database/perl/vendor/lib/Class/MOP/Attribute.pm vendored Normal file
View File

File diff suppressed because it is too large Load Diff

2312
database/perl/vendor/lib/Class/MOP/Class.pm vendored Normal file
View File

File diff suppressed because it is too large Load Diff

172
database/perl/vendor/lib/Class/MOP/Class/Immutable/Trait.pm vendored Normal file
View File

@@ -0,0 +1,172 @@
package Class::MOP::Class::Immutable::Trait;
our $VERSION = '2.2014';
use strict;
use warnings;
use MRO::Compat;
use Module::Runtime 'use_module';
# the original class of the metaclass instance
sub _get_mutable_metaclass_name { $_[0]{__immutable}{original_class} }
sub is_mutable { 0 }
sub is_immutable { 1 }
sub _immutable_metaclass { ref $_[1] }
sub _immutable_read_only {
my $name = shift;
__throw_exception( CallingReadOnlyMethodOnAnImmutableInstance => method_name => $name );
}
sub _immutable_cannot_call {
my $name = shift;
__throw_exception( CallingMethodOnAnImmutableInstance => method_name => $name );
}
for my $name (qw/superclasses/) {
no strict 'refs';
*{__PACKAGE__."::$name"} = sub {
my $orig = shift;
my $self = shift;
_immutable_read_only($name) if @_;
$self->$orig;
};
}
for my $name (qw/add_method alias_method remove_method add_attribute remove_attribute remove_package_symbol add_package_symbol/) {
no strict 'refs';
*{__PACKAGE__."::$name"} = sub { _immutable_cannot_call($name) };
}
sub class_precedence_list {
my $orig = shift;
my $self = shift;
@{ $self->{__immutable}{class_precedence_list}
||= [ $self->$orig ] };
}
sub linearized_isa {
my $orig = shift;
my $self = shift;
@{ $self->{__immutable}{linearized_isa} ||= [ $self->$orig ] };
}
sub get_all_methods {
my $orig = shift;
my $self = shift;
@{ $self->{__immutable}{get_all_methods} ||= [ $self->$orig ] };
}
sub get_all_method_names {
my $orig = shift;
my $self = shift;
@{ $self->{__immutable}{get_all_method_names} ||= [ $self->$orig ] };
}
sub get_all_attributes {
my $orig = shift;
my $self = shift;
@{ $self->{__immutable}{get_all_attributes} ||= [ $self->$orig ] };
}
sub get_meta_instance {
my $orig = shift;
my $self = shift;
$self->{__immutable}{get_meta_instance} ||= $self->$orig;
}
sub _method_map {
my $orig = shift;
my $self = shift;
$self->{__immutable}{_method_map} ||= $self->$orig;
}
# private method, for this file only -
# if we declare a method here, it will behave differently depending on what
# class this trait is applied to, so we won't have a reliable parameter list.
sub __throw_exception {
my ($exception_type, @args_to_exception) = @_;
die use_module( "Moose::Exception::$exception_type" )->new( @args_to_exception );
}
1;
# ABSTRACT: Implements immutability for metaclass objects
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Class::Immutable::Trait - Implements immutability for metaclass objects
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This class provides a pseudo-trait that is applied to immutable metaclass
objects. In reality, it is simply a parent class.
It implements caching and read-only-ness for various metaclass methods.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

95
database/perl/vendor/lib/Class/MOP/Deprecated.pm vendored Normal file
View File

@@ -0,0 +1,95 @@
package Class::MOP::Deprecated;
our $VERSION = '2.2014';
use strict;
use warnings;
use Package::DeprecationManager -deprecations => {
'Class::Load wrapper functions' => '2.1100',
};
1;
# ABSTRACT: Manages deprecation warnings for Class::MOP
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Deprecated - Manages deprecation warnings for Class::MOP
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
use Class::MOP::Deprecated -api_version => $version;
=head1 FUNCTIONS
This module manages deprecation warnings for features that have been
deprecated in Class::MOP.
If you specify C<< -api_version => $version >>, you can use deprecated features
without warnings. Note that this special treatment is limited to the package
that loads C<Class::MOP::Deprecated>.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

533
database/perl/vendor/lib/Class/MOP/Instance.pm vendored Normal file
View File

@@ -0,0 +1,533 @@
package Class::MOP::Instance;
our $VERSION = '2.2014';
use strict;
use warnings;
use Scalar::Util 'isweak', 'weaken', 'blessed';
use parent 'Class::MOP::Object';
# make this not a valid method name, to avoid (most) attribute conflicts
my $RESERVED_MOP_SLOT = '<<MOP>>';
sub BUILDARGS {
my ($class, @args) = @_;
if ( @args == 1 ) {
unshift @args, "associated_metaclass";
} elsif ( @args >= 2 && blessed($args[0]) && $args[0]->isa("Class::MOP::Class") ) {
# compat mode
my ( $meta, @attrs ) = @args;
@args = ( associated_metaclass => $meta, attributes => \@attrs );
}
my %options = @args;
# FIXME lazy_build
$options{slots} ||= [ map { $_->slots } @{ $options{attributes} || [] } ];
$options{slot_hash} = { map { $_ => undef } @{ $options{slots} } }; # FIXME lazy_build
return \%options;
}
sub new {
my $class = shift;
my $options = $class->BUILDARGS(@_);
# FIXME replace with a proper constructor
my $instance = $class->_new(%$options);
# FIXME weak_ref => 1,
weaken($instance->{'associated_metaclass'});
return $instance;
}
sub _new {
my $class = shift;
return Class::MOP::Class->initialize($class)->new_object(@_)
if $class ne __PACKAGE__;
my $params = @_ == 1 ? $_[0] : {@_};
return bless {
# NOTE:
# I am not sure that it makes
# sense to pass in the meta
# The ideal would be to just
# pass in the class name, but
# that is placing too much of
# an assumption on bless(),
# which is *probably* a safe
# assumption,.. but you can
# never tell <:)
'associated_metaclass' => $params->{associated_metaclass},
'attributes' => $params->{attributes},
'slots' => $params->{slots},
'slot_hash' => $params->{slot_hash},
} => $class;
}
sub _class_name { $_[0]->{_class_name} ||= $_[0]->associated_metaclass->name }
sub create_instance {
my $self = shift;
bless {}, $self->_class_name;
}
sub clone_instance {
my ($self, $instance) = @_;
my $clone = $self->create_instance;
for my $attr ($self->get_all_attributes) {
next unless $attr->has_value($instance);
for my $slot ($attr->slots) {
my $val = $self->get_slot_value($instance, $slot);
$self->set_slot_value($clone, $slot, $val);
$self->weaken_slot_value($clone, $slot)
if $self->slot_value_is_weak($instance, $slot);
}
}
$self->_set_mop_slot($clone, $self->_get_mop_slot($instance))
if $self->_has_mop_slot($instance);
return $clone;
}
# operations on meta instance
sub get_all_slots {
my $self = shift;
return @{$self->{'slots'}};
}
sub get_all_attributes {
my $self = shift;
return @{$self->{attributes}};
}
sub is_valid_slot {
my ($self, $slot_name) = @_;
exists $self->{'slot_hash'}->{$slot_name};
}
# operations on created instances
sub get_slot_value {
my ($self, $instance, $slot_name) = @_;
$instance->{$slot_name};
}
sub set_slot_value {
my ($self, $instance, $slot_name, $value) = @_;
$instance->{$slot_name} = $value;
}
sub initialize_slot {
my ($self, $instance, $slot_name) = @_;
return;
}
sub deinitialize_slot {
my ( $self, $instance, $slot_name ) = @_;
delete $instance->{$slot_name};
}
sub initialize_all_slots {
my ($self, $instance) = @_;
foreach my $slot_name ($self->get_all_slots) {
$self->initialize_slot($instance, $slot_name);
}
}
sub deinitialize_all_slots {
my ($self, $instance) = @_;
foreach my $slot_name ($self->get_all_slots) {
$self->deinitialize_slot($instance, $slot_name);
}
}
sub is_slot_initialized {
my ($self, $instance, $slot_name, $value) = @_;
exists $instance->{$slot_name};
}
sub weaken_slot_value {
my ($self, $instance, $slot_name) = @_;
weaken $instance->{$slot_name};
}
sub slot_value_is_weak {
my ($self, $instance, $slot_name) = @_;
isweak $instance->{$slot_name};
}
sub strengthen_slot_value {
my ($self, $instance, $slot_name) = @_;
$self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
}
sub rebless_instance_structure {
my ($self, $instance, $metaclass) = @_;
# we use $_[1] here because of t/cmop/rebless_overload.t regressions
# on 5.8.8
bless $_[1], $metaclass->name;
}
sub is_dependent_on_superclasses {
return; # for meta instances that require updates on inherited slot changes
}
sub _get_mop_slot {
my ($self, $instance) = @_;
$self->get_slot_value($instance, $RESERVED_MOP_SLOT);
}
sub _has_mop_slot {
my ($self, $instance) = @_;
$self->is_slot_initialized($instance, $RESERVED_MOP_SLOT);
}
sub _set_mop_slot {
my ($self, $instance, $value) = @_;
$self->set_slot_value($instance, $RESERVED_MOP_SLOT, $value);
}
sub _clear_mop_slot {
my ($self, $instance) = @_;
$self->deinitialize_slot($instance, $RESERVED_MOP_SLOT);
}
# inlinable operation snippets
sub is_inlinable { 1 }
sub inline_create_instance {
my ($self, $class_variable) = @_;
'bless {} => ' . $class_variable;
}
sub inline_slot_access {
my ($self, $instance, $slot_name) = @_;
sprintf q[%s->{"%s"}], $instance, quotemeta($slot_name);
}
sub inline_get_is_lvalue { 1 }
sub inline_get_slot_value {
my ($self, $instance, $slot_name) = @_;
$self->inline_slot_access($instance, $slot_name);
}
sub inline_set_slot_value {
my ($self, $instance, $slot_name, $value) = @_;
$self->inline_slot_access($instance, $slot_name) . " = $value",
}
sub inline_initialize_slot {
my ($self, $instance, $slot_name) = @_;
return '';
}
sub inline_deinitialize_slot {
my ($self, $instance, $slot_name) = @_;
"delete " . $self->inline_slot_access($instance, $slot_name);
}
sub inline_is_slot_initialized {
my ($self, $instance, $slot_name) = @_;
"exists " . $self->inline_slot_access($instance, $slot_name);
}
sub inline_weaken_slot_value {
my ($self, $instance, $slot_name) = @_;
sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
}
sub inline_strengthen_slot_value {
my ($self, $instance, $slot_name) = @_;
$self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
}
sub inline_rebless_instance_structure {
my ($self, $instance, $class_variable) = @_;
"bless $instance => $class_variable";
}
sub _inline_get_mop_slot {
my ($self, $instance) = @_;
$self->inline_get_slot_value($instance, $RESERVED_MOP_SLOT);
}
sub _inline_set_mop_slot {
my ($self, $instance, $value) = @_;
$self->inline_set_slot_value($instance, $RESERVED_MOP_SLOT, $value);
}
sub _inline_clear_mop_slot {
my ($self, $instance) = @_;
$self->inline_deinitialize_slot($instance, $RESERVED_MOP_SLOT);
}
1;
# ABSTRACT: Instance Meta Object
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Instance - Instance Meta Object
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
The Instance Protocol controls the creation of object instances, and
the storage of attribute values in those instances.
Using this API directly in your own code violates encapsulation, and
we recommend that you use the appropriate APIs in L<Class::MOP::Class>
and L<Class::MOP::Attribute> instead. Those APIs in turn call the
methods in this class as appropriate.
This class also participates in generating inlined code by providing
snippets of code to access an object instance.
=head1 METHODS
=head2 Object construction
=over 4
=item B<< Class::MOP::Instance->new(%options) >>
This method creates a new meta-instance object.
It accepts the following keys in C<%options>:
=over 8
=item * associated_metaclass
The L<Class::MOP::Class> object for which instances will be created.
=item * attributes
An array reference of L<Class::MOP::Attribute> objects. These are the
attributes which can be stored in each instance.
=back
=back
=head2 Creating and altering instances
=over 4
=item B<< $metainstance->create_instance >>
This method returns a reference blessed into the associated
metaclass's class.
The default is to use a hash reference. Subclasses can override this.
=item B<< $metainstance->clone_instance($instance) >>
Given an instance, this method creates a new object by making
I<shallow> clone of the original.
=back
=head2 Introspection
=over 4
=item B<< $metainstance->associated_metaclass >>
This returns the L<Class::MOP::Class> object associated with the
meta-instance object.
=item B<< $metainstance->get_all_slots >>
This returns a list of slot names stored in object instances. In
almost all cases, slot names correspond directly attribute names.
=item B<< $metainstance->is_valid_slot($slot_name) >>
This will return true if C<$slot_name> is a valid slot name.
=item B<< $metainstance->get_all_attributes >>
This returns a list of attributes corresponding to the attributes
passed to the constructor.
=back
=head2 Operations on Instance Structures
It's important to understand that the meta-instance object is a
different entity from the actual instances it creates. For this
reason, any operations on the C<$instance_structure> always require
that the object instance be passed to the method.
=over 4
=item B<< $metainstance->get_slot_value($instance_structure, $slot_name) >>
=item B<< $metainstance->set_slot_value($instance_structure, $slot_name, $value) >>
=item B<< $metainstance->initialize_slot($instance_structure, $slot_name) >>
=item B<< $metainstance->deinitialize_slot($instance_structure, $slot_name) >>
=item B<< $metainstance->initialize_all_slots($instance_structure) >>
=item B<< $metainstance->deinitialize_all_slots($instance_structure) >>
=item B<< $metainstance->is_slot_initialized($instance_structure, $slot_name) >>
=item B<< $metainstance->weaken_slot_value($instance_structure, $slot_name) >>
=item B<< $metainstance->slot_value_is_weak($instance_structure, $slot_name) >>
=item B<< $metainstance->strengthen_slot_value($instance_structure, $slot_name) >>
=item B<< $metainstance->rebless_instance_structure($instance_structure, $new_metaclass) >>
The exact details of what each method does should be fairly obvious
from the method name.
=back
=head2 Inlinable Instance Operations
=over 4
=item B<< $metainstance->is_inlinable >>
This is a boolean that indicates whether or not slot access operations
can be inlined. By default it is true, but subclasses can override
this.
=item B<< $metainstance->inline_create_instance($class_variable) >>
This method expects a string that, I<when inlined>, will become a
class name. This would literally be something like C<'$class'>, not an
actual class name.
It returns a snippet of code that creates a new object for the
class. This is something like C< bless {}, $class_name >.
=item B<< $metainstance->inline_get_is_lvalue >>
Returns whether or not C<inline_get_slot_value> is a valid lvalue. This can be
used to do extra optimizations when generating inlined methods.
=item B<< $metainstance->inline_slot_access($instance_variable, $slot_name) >>
=item B<< $metainstance->inline_get_slot_value($instance_variable, $slot_name) >>
=item B<< $metainstance->inline_set_slot_value($instance_variable, $slot_name, $value) >>
=item B<< $metainstance->inline_initialize_slot($instance_variable, $slot_name) >>
=item B<< $metainstance->inline_deinitialize_slot($instance_variable, $slot_name) >>
=item B<< $metainstance->inline_is_slot_initialized($instance_variable, $slot_name) >>
=item B<< $metainstance->inline_weaken_slot_value($instance_variable, $slot_name) >>
=item B<< $metainstance->inline_strengthen_slot_value($instance_variable, $slot_name) >>
These methods all expect two arguments. The first is the name of a
variable, than when inlined, will represent the object
instance. Typically this will be a literal string like C<'$_[0]'>.
The second argument is a slot name.
The method returns a snippet of code that, when inlined, performs some
operation on the instance.
=item B<< $metainstance->inline_rebless_instance_structure($instance_variable, $class_variable) >>
This takes the name of a variable that will, when inlined, represent the object
instance, and the name of a variable that will represent the class to rebless
into, and returns code to rebless an instance into a class.
=back
=head2 Introspection
=over 4
=item B<< Class::MOP::Instance->meta >>
This will return a L<Class::MOP::Class> instance for this class.
It should also be noted that L<Class::MOP> will actually bootstrap
this module by installing a number of attribute meta-objects into its
metaclass.
=back
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

356
database/perl/vendor/lib/Class/MOP/Method.pm vendored Normal file
View File

@@ -0,0 +1,356 @@
package Class::MOP::Method;
our $VERSION = '2.2014';
use strict;
use warnings;
use Scalar::Util 'weaken', 'reftype', 'blessed';
use parent 'Class::MOP::Object';
# NOTE:
# if poked in the right way,
# they should act like CODE refs.
use overload
'&{}' => sub { $_[0]->body },
'bool' => sub { 1 },
'""' => sub { overload::StrVal($_[0]) },
fallback => 1;
# construction
sub wrap {
my ( $class, @args ) = @_;
unshift @args, 'body' if @args % 2 == 1;
my %params = @args;
my $code = $params{body};
if (blessed($code) && $code->isa(__PACKAGE__)) {
my $method = $code->clone;
delete $params{body};
Class::MOP::class_of($class)->rebless_instance($method, %params);
return $method;
}
elsif (!ref $code || 'CODE' ne reftype($code)) {
$class->_throw_exception( WrapTakesACodeRefToBless => params => \%params,
class => $class,
code => $code
);
}
($params{package_name} && $params{name})
|| $class->_throw_exception( PackageNameAndNameParamsNotGivenToWrap => params => \%params,
class => $class,
code => $code
);
my $self = $class->_new(\%params);
weaken($self->{associated_metaclass}) if $self->{associated_metaclass};
return $self;
}
sub _new {
my $class = shift;
return Class::MOP::Class->initialize($class)->new_object(@_)
if $class ne __PACKAGE__;
my $params = @_ == 1 ? $_[0] : {@_};
return bless {
'body' => $params->{body},
'associated_metaclass' => $params->{associated_metaclass},
'package_name' => $params->{package_name},
'name' => $params->{name},
'original_method' => $params->{original_method},
} => $class;
}
## accessors
sub associated_metaclass { shift->{'associated_metaclass'} }
sub attach_to_class {
my ( $self, $class ) = @_;
$self->{associated_metaclass} = $class;
weaken($self->{associated_metaclass});
}
sub detach_from_class {
my $self = shift;
delete $self->{associated_metaclass};
}
sub fully_qualified_name {
my $self = shift;
$self->package_name . '::' . $self->name;
}
sub original_method { (shift)->{'original_method'} }
sub _set_original_method { $_[0]->{'original_method'} = $_[1] }
# It's possible that this could cause a loop if there is a circular
# reference in here. That shouldn't ever happen in normal
# circumstances, since original method only gets set when clone is
# called. We _could_ check for such a loop, but it'd involve some sort
# of package-lexical variable, and wouldn't be terribly subclassable.
sub original_package_name {
my $self = shift;
$self->original_method
? $self->original_method->original_package_name
: $self->package_name;
}
sub original_name {
my $self = shift;
$self->original_method
? $self->original_method->original_name
: $self->name;
}
sub original_fully_qualified_name {
my $self = shift;
$self->original_method
? $self->original_method->original_fully_qualified_name
: $self->fully_qualified_name;
}
sub execute {
my $self = shift;
$self->body->(@_);
}
# We used to go through use Class::MOP::Class->clone_instance to do this, but
# this was awfully slow. This method may be called a number of times when
# classes are loaded (especially during Moose role application), so it is
# worth optimizing. - DR
sub clone {
my $self = shift;
my $clone = bless { %{$self}, @_ }, blessed($self);
weaken($clone->{associated_metaclass}) if $clone->{associated_metaclass};
$clone->_set_original_method($self);
return $clone;
}
sub _inline_throw_exception {
my ( $self, $exception_type, $throw_args ) = @_;
return
'die Module::Runtime::use_module("Moose::Exception::'
. $exception_type
. '")->new('
. ( $throw_args || '' ) . ')';
}
1;
# ABSTRACT: Method Meta Object
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Method - Method Meta Object
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
The Method Protocol is very small, since methods in Perl 5 are just
subroutines in a specific package. We provide a very basic
introspection interface.
=head1 METHODS
=over 4
=item B<< Class::MOP::Method->wrap($code, %options) >>
This is the constructor. It accepts a method body in the form of
either a code reference or a L<Class::MOP::Method> instance, followed
by a hash of options.
The options are:
=over 8
=item * name
The method name (without a package name). This is required if C<$code>
is a coderef.
=item * package_name
The package name for the method. This is required if C<$code> is a
coderef.
=item * associated_metaclass
An optional L<Class::MOP::Class> object. This is the metaclass for the
method's class.
=back
=item B<< $metamethod->clone(%params) >>
This makes a shallow clone of the method object. In particular,
subroutine reference itself is shared between all clones of a given
method.
When a method is cloned, the original method object will be available
by calling C<original_method> on the clone.
=item B<< $metamethod->body >>
This returns a reference to the method's subroutine.
=item B<< $metamethod->name >>
This returns the method's name.
=item B<< $metamethod->package_name >>
This returns the method's package name.
=item B<< $metamethod->fully_qualified_name >>
This returns the method's fully qualified name (package name and
method name).
=item B<< $metamethod->associated_metaclass >>
This returns the L<Class::MOP::Class> object for the method, if one
exists.
=item B<< $metamethod->original_method >>
If this method object was created as a clone of some other method
object, this returns the object that was cloned.
=item B<< $metamethod->original_name >>
This returns the method's original name, wherever it was first
defined.
If this method is a clone of a clone (of a clone, etc.), this method
returns the name from the I<first> method in the chain of clones.
=item B<< $metamethod->original_package_name >>
This returns the method's original package name, wherever it was first
defined.
If this method is a clone of a clone (of a clone, etc.), this method
returns the package name from the I<first> method in the chain of
clones.
=item B<< $metamethod->original_fully_qualified_name >>
This returns the method's original fully qualified name, wherever it
was first defined.
If this method is a clone of a clone (of a clone, etc.), this method
returns the fully qualified name from the I<first> method in the chain
of clones.
=item B<< $metamethod->is_stub >>
Returns true if the method is just a stub:
sub foo;
=item B<< $metamethod->attach_to_class($metaclass) >>
Given a L<Class::MOP::Class> object, this method sets the associated
metaclass for the method. This will overwrite any existing associated
metaclass.
=item B<< $metamethod->detach_from_class >>
Removes any associated metaclass object for the method.
=item B<< $metamethod->execute(...) >>
This executes the method. Any arguments provided will be passed on to
the method itself.
=item B<< Class::MOP::Method->meta >>
This will return a L<Class::MOP::Class> instance for this class.
It should also be noted that L<Class::MOP> will actually bootstrap
this module by installing a number of attribute meta-objects into its
metaclass.
=back
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

404
database/perl/vendor/lib/Class/MOP/Method/Accessor.pm vendored Normal file
View File

@@ -0,0 +1,404 @@
package Class::MOP::Method::Accessor;
our $VERSION = '2.2014';
use strict;
use warnings;
use Scalar::Util 'blessed', 'weaken';
use Try::Tiny;
use parent 'Class::MOP::Method::Generated';
sub new {
my $class = shift;
my %options = @_;
(exists $options{attribute})
|| $class->_throw_exception( MustSupplyAnAttributeToConstructWith => params => \%options,
class => $class,
);
(exists $options{accessor_type})
|| $class->_throw_exception( MustSupplyAnAccessorTypeToConstructWith => params => \%options,
class => $class,
);
(blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
|| $class->_throw_exception( MustSupplyAClassMOPAttributeInstance => params => \%options,
class => $class
);
($options{package_name} && $options{name})
|| $class->_throw_exception( MustSupplyPackageNameAndName => params => \%options,
class => $class
);
my $self = $class->_new(\%options);
# we don't want this creating
# a cycle in the code, if not
# needed
weaken($self->{'attribute'});
$self->_initialize_body;
return $self;
}
sub _new {
my $class = shift;
return Class::MOP::Class->initialize($class)->new_object(@_)
if $class ne __PACKAGE__;
my $params = @_ == 1 ? $_[0] : {@_};
return bless {
# inherited from Class::MOP::Method
body => $params->{body},
associated_metaclass => $params->{associated_metaclass},
package_name => $params->{package_name},
name => $params->{name},
original_method => $params->{original_method},
# inherit from Class::MOP::Generated
is_inline => $params->{is_inline} || 0,
definition_context => $params->{definition_context},
# defined in this class
attribute => $params->{attribute},
accessor_type => $params->{accessor_type},
} => $class;
}
## accessors
sub associated_attribute { (shift)->{'attribute'} }
sub accessor_type { (shift)->{'accessor_type'} }
## factory
sub _initialize_body {
my $self = shift;
my $method_name = join "_" => (
'_generate',
$self->accessor_type,
'method',
($self->is_inline ? 'inline' : ())
);
$self->{'body'} = $self->$method_name();
}
## generators
sub _generate_accessor_method {
my $self = shift;
my $attr = $self->associated_attribute;
return sub {
if (@_ >= 2) {
$attr->set_value($_[0], $_[1]);
}
$attr->get_value($_[0]);
};
}
sub _generate_accessor_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
return try {
$self->_compile_code([
'sub {',
'if (@_ > 1) {',
$attr->_inline_set_value('$_[0]', '$_[1]'),
'}',
$attr->_inline_get_value('$_[0]'),
'}',
]);
}
catch {
$self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
error => $_,
option => "accessor"
);
};
}
sub _generate_reader_method {
my $self = shift;
my $attr = $self->associated_attribute;
my $class = $attr->associated_class;
return sub {
$self->_throw_exception( CannotAssignValueToReadOnlyAccessor => class_name => $class->name,
value => $_[1],
attribute => $attr
)
if @_ > 1;
$attr->get_value($_[0]);
};
}
sub _generate_reader_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
return try {
$self->_compile_code([
'sub {',
'if (@_ > 1) {',
$self->_inline_throw_exception( CannotAssignValueToReadOnlyAccessor =>
'class_name => ref $_[0],'.
'value => $_[1],'.
"attribute_name => '".$attr_name."'",
) . ';',
'}',
$attr->_inline_get_value('$_[0]'),
'}',
]);
}
catch {
$self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
error => $_,
option => "reader"
);
};
}
sub _generate_writer_method {
my $self = shift;
my $attr = $self->associated_attribute;
return sub {
$attr->set_value($_[0], $_[1]);
};
}
sub _generate_writer_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
return try {
$self->_compile_code([
'sub {',
$attr->_inline_set_value('$_[0]', '$_[1]'),
'}',
]);
}
catch {
$self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
error => $_,
option => "writer"
);
};
}
sub _generate_predicate_method {
my $self = shift;
my $attr = $self->associated_attribute;
return sub {
$attr->has_value($_[0])
};
}
sub _generate_predicate_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
return try {
$self->_compile_code([
'sub {',
$attr->_inline_has_value('$_[0]'),
'}',
]);
}
catch {
$self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
error => $_,
option => "predicate"
);
};
}
sub _generate_clearer_method {
my $self = shift;
my $attr = $self->associated_attribute;
return sub {
$attr->clear_value($_[0])
};
}
sub _generate_clearer_method_inline {
my $self = shift;
my $attr = $self->associated_attribute;
return try {
$self->_compile_code([
'sub {',
$attr->_inline_clear_value('$_[0]'),
'}',
]);
}
catch {
$self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
error => $_,
option => "clearer"
);
};
}
1;
# ABSTRACT: Method Meta Object for accessors
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Method::Accessor - Method Meta Object for accessors
=head1 VERSION
version 2.2014
=head1 SYNOPSIS
use Class::MOP::Method::Accessor;
my $reader = Class::MOP::Method::Accessor->new(
attribute => $attribute,
is_inline => 1,
accessor_type => 'reader',
);
$reader->body->execute($instance); # call the reader method
=head1 DESCRIPTION
This is a subclass of C<Class::MOP::Method> which is used by
C<Class::MOP::Attribute> to generate accessor code. It handles
generation of readers, writers, predicates and clearers. For each type
of method, it can either create a subroutine reference, or actually
inline code by generating a string and C<eval>'ing it.
=head1 METHODS
=over 4
=item B<< Class::MOP::Method::Accessor->new(%options) >>
This returns a new C<Class::MOP::Method::Accessor> based on the
C<%options> provided.
=over 4
=item * attribute
This is the C<Class::MOP::Attribute> for which accessors are being
generated. This option is required.
=item * accessor_type
This is a string which should be one of "reader", "writer",
"accessor", "predicate", or "clearer". This is the type of method
being generated. This option is required.
=item * is_inline
This indicates whether or not the accessor should be inlined. This
defaults to false.
=item * name
The method name (without a package name). This is required.
=item * package_name
The package name for the method. This is required.
=back
=item B<< $metamethod->accessor_type >>
Returns the accessor type which was passed to C<new>.
=item B<< $metamethod->is_inline >>
Returns a boolean indicating whether or not the accessor is inlined.
=item B<< $metamethod->associated_attribute >>
This returns the L<Class::MOP::Attribute> object which was passed to
C<new>.
=item B<< $metamethod->body >>
The method itself is I<generated> when the accessor object is
constructed.
=back
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

251
database/perl/vendor/lib/Class/MOP/Method/Constructor.pm vendored Normal file
View File

@@ -0,0 +1,251 @@
package Class::MOP::Method::Constructor;
our $VERSION = '2.2014';
use strict;
use warnings;
use Scalar::Util 'blessed', 'weaken';
use Try::Tiny;
use parent 'Class::MOP::Method::Inlined';
sub new {
my $class = shift;
my %options = @_;
(blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class'))
|| $class->_throw_exception( MustSupplyAMetaclass => params => \%options,
class => $class
)
if $options{is_inline};
($options{package_name} && $options{name})
|| $class->_throw_exception( MustSupplyPackageNameAndName => params => \%options,
class => $class
);
my $self = $class->_new(\%options);
# we don't want this creating
# a cycle in the code, if not
# needed
weaken($self->{'associated_metaclass'});
$self->_initialize_body;
return $self;
}
sub _new {
my $class = shift;
return Class::MOP::Class->initialize($class)->new_object(@_)
if $class ne __PACKAGE__;
my $params = @_ == 1 ? $_[0] : {@_};
return bless {
# inherited from Class::MOP::Method
body => $params->{body},
# associated_metaclass => $params->{associated_metaclass}, # overridden
package_name => $params->{package_name},
name => $params->{name},
original_method => $params->{original_method},
# inherited from Class::MOP::Generated
is_inline => $params->{is_inline} || 0,
definition_context => $params->{definition_context},
# inherited from Class::MOP::Inlined
_expected_method_class => $params->{_expected_method_class},
# defined in this subclass
options => $params->{options} || {},
associated_metaclass => $params->{metaclass},
}, $class;
}
## accessors
sub options { (shift)->{'options'} }
sub associated_metaclass { (shift)->{'associated_metaclass'} }
## method
sub _initialize_body {
my $self = shift;
my $method_name = '_generate_constructor_method';
$method_name .= '_inline' if $self->is_inline;
$self->{'body'} = $self->$method_name;
}
sub _eval_environment {
my $self = shift;
return $self->associated_metaclass->_eval_environment;
}
sub _generate_constructor_method {
return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
}
sub _generate_constructor_method_inline {
my $self = shift;
my $meta = $self->associated_metaclass;
my @source = (
'sub {',
$meta->_inline_new_object,
'}',
);
warn join("\n", @source) if $self->options->{debug};
my $code = try {
$self->_compile_code(\@source);
}
catch {
my $source = join("\n", @source);
$self->_throw_exception( CouldNotEvalConstructor => constructor_method => $self,
source => $source,
error => $_
);
};
return $code;
}
1;
# ABSTRACT: Method Meta Object for constructors
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Method::Constructor - Method Meta Object for constructors
=head1 VERSION
version 2.2014
=head1 SYNOPSIS
use Class::MOP::Method::Constructor;
my $constructor = Class::MOP::Method::Constructor->new(
metaclass => $metaclass,
options => {
debug => 1, # this is all for now
},
);
# calling the constructor ...
$constructor->body->execute($metaclass->name, %params);
=head1 DESCRIPTION
This is a subclass of L<Class::MOP::Method> which generates
constructor methods.
=head1 METHODS
=over 4
=item B<< Class::MOP::Method::Constructor->new(%options) >>
This creates a new constructor object. It accepts a hash reference of
options.
=over 8
=item * metaclass
This should be a L<Class::MOP::Class> object. It is required.
=item * name
The method name (without a package name). This is required.
=item * package_name
The package name for the method. This is required.
=item * is_inline
This indicates whether or not the constructor should be inlined. This
defaults to false.
=back
=item B<< $metamethod->is_inline >>
Returns a boolean indicating whether or not the constructor is
inlined.
=item B<< $metamethod->associated_metaclass >>
This returns the L<Class::MOP::Class> object for the method.
=back
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

142
database/perl/vendor/lib/Class/MOP/Method/Generated.pm vendored Normal file
View File

@@ -0,0 +1,142 @@
package Class::MOP::Method::Generated;
our $VERSION = '2.2014';
use strict;
use warnings;
use Eval::Closure;
use parent 'Class::MOP::Method';
## accessors
sub new {
$_[0]->_throw_exception( CannotCallAnAbstractBaseMethod => package_name => __PACKAGE__ );
}
sub _initialize_body {
$_[0]->_throw_exception( NoBodyToInitializeInAnAbstractBaseClass => package_name => __PACKAGE__ );
}
sub _generate_description {
my ( $self, $context ) = @_;
$context ||= $self->definition_context;
my $desc = "generated method";
my $origin = "unknown origin";
if (defined $context) {
if (defined $context->{description}) {
$desc = $context->{description};
}
if (defined $context->{file} || defined $context->{line}) {
$origin = "defined at "
. (defined $context->{file}
? $context->{file} : "<unknown file>")
. " line "
. (defined $context->{line}
? $context->{line} : "<unknown line>");
}
}
return "$desc ($origin)";
}
sub _compile_code {
my ( $self, @args ) = @_;
unshift @args, 'source' if @args % 2;
my %args = @args;
my $context = delete $args{context};
my $environment = $self->can('_eval_environment')
? $self->_eval_environment
: {};
return eval_closure(
environment => $environment,
description => $self->_generate_description($context),
%args,
);
}
1;
# ABSTRACT: Abstract base class for generated methods
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Method::Generated - Abstract base class for generated methods
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This is a C<Class::MOP::Method> subclass which is subclassed by
C<Class::MOP::Method::Accessor> and
C<Class::MOP::Method::Constructor>.
It is not intended to be used directly.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

191
database/perl/vendor/lib/Class/MOP/Method/Inlined.pm vendored Normal file
View File

@@ -0,0 +1,191 @@
package Class::MOP::Method::Inlined;
our $VERSION = '2.2014';
use strict;
use warnings;
use Scalar::Util 'refaddr';
use parent 'Class::MOP::Method::Generated';
sub _uninlined_body {
my $self = shift;
my $super_method
= $self->associated_metaclass->find_next_method_by_name( $self->name )
or return;
if ( $super_method->isa(__PACKAGE__) ) {
return $super_method->_uninlined_body;
}
else {
return $super_method->body;
}
}
sub can_be_inlined {
my $self = shift;
my $metaclass = $self->associated_metaclass;
my $class = $metaclass->name;
# If we don't find an inherited method, this is a rather weird
# case where we have no method in the inheritance chain even
# though we're expecting one to be there
my $inherited_method
= $metaclass->find_next_method_by_name( $self->name );
if ( $inherited_method
&& $inherited_method->isa('Class::MOP::Method::Wrapped') ) {
warn "Not inlining '"
. $self->name
. "' for $class since it "
. "has method modifiers which would be lost if it were inlined\n";
return 0;
}
my $expected_class = $self->_expected_method_class
or return 1;
# if we are shadowing a method we first verify that it is
# compatible with the definition we are replacing it with
my $expected_method = $expected_class->can( $self->name );
if ( ! $expected_method ) {
warn "Not inlining '"
. $self->name
. "' for $class since ${expected_class}::"
. $self->name
. " is not defined\n";
return 0;
}
my $actual_method = $class->can( $self->name )
or return 1;
# the method is what we wanted (probably Moose::Object::new)
return 1
if refaddr($expected_method) == refaddr($actual_method);
# otherwise we have to check that the actual method is an inlined
# version of what we're expecting
if ( $inherited_method->isa(__PACKAGE__) ) {
if ( $inherited_method->_uninlined_body
&& refaddr( $inherited_method->_uninlined_body )
== refaddr($expected_method) ) {
return 1;
}
}
elsif ( refaddr( $inherited_method->body )
== refaddr($expected_method) ) {
return 1;
}
my $warning
= "Not inlining '"
. $self->name
. "' for $class since it is not"
. " inheriting the default ${expected_class}::"
. $self->name . "\n";
if ( $self->isa("Class::MOP::Method::Constructor") ) {
# FIXME kludge, refactor warning generation to a method
$warning
.= "If you are certain you don't need to inline your"
. " constructor, specify inline_constructor => 0 in your"
. " call to $class->meta->make_immutable\n";
}
warn $warning;
return 0;
}
1;
# ABSTRACT: Method base class for methods which have been inlined
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Method::Inlined - Method base class for methods which have been inlined
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This is a L<Class::MOP::Method::Generated> subclass for methods which
can be inlined.
=head1 METHODS
=head2 $metamethod->can_be_inlined
This method returns true if the method in question can be inlined in
the associated metaclass.
If it cannot be inlined, it spits out a warning and returns false.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

169
database/perl/vendor/lib/Class/MOP/Method/Meta.pm vendored Normal file
View File

@@ -0,0 +1,169 @@
package Class::MOP::Method::Meta;
our $VERSION = '2.2014';
use strict;
use warnings;
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0;
use parent 'Class::MOP::Method';
sub _is_caller_mop_internal {
my $self = shift;
my ($caller) = @_;
return $caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/;
}
sub _generate_meta_method {
my $method_self = shift;
my $metaclass = shift;
weaken($metaclass);
sub {
# this will be compiled out if the env var wasn't set
if (DEBUG_NO_META) {
confess "'meta' method called by MOP internals"
# it's okay to call meta methods on metaclasses, since we
# explicitly ask for them
if !$_[0]->isa('Class::MOP::Object')
&& !$_[0]->isa('Class::MOP::Mixin')
# it's okay if the test itself calls ->meta, we only care about
# if the mop internals call ->meta
&& $method_self->_is_caller_mop_internal(scalar caller);
}
# we must re-initialize so that it
# works as expected in subclasses,
# since metaclass instances are
# singletons, this is not really a
# big deal anyway.
$metaclass->initialize(blessed($_[0]) || $_[0])
};
}
sub wrap {
my ($class, @args) = @_;
unshift @args, 'body' if @args % 2 == 1;
my %params = @args;
$class->_throw_exception( CannotOverrideBodyOfMetaMethods => params => \%params,
class => $class
)
if $params{body};
my $metaclass_class = $params{associated_metaclass}->meta;
$params{body} = $class->_generate_meta_method($metaclass_class);
return $class->SUPER::wrap(%params);
}
sub _make_compatible_with {
my $self = shift;
my ($other) = @_;
# XXX: this is pretty gross. the issue here is that CMOP::Method::Meta
# objects are subclasses of CMOP::Method, but when we get to moose, they'll
# need to be compatible with Moose::Meta::Method, which isn't possible. the
# right solution here is to make ::Meta into a role that gets applied to
# whatever the method_metaclass happens to be and get rid of
# _meta_method_metaclass entirely, but that's not going to happen until
# we ditch cmop and get roles into the bootstrapping, so. i'm not
# maintaining the previous behavior of turning them into instances of the
# new method_metaclass because that's equally broken, and at least this way
# any issues will at least be detectable and potentially fixable. -doy
return $self unless $other->_is_compatible_with($self->_real_ref_name);
return $self->SUPER::_make_compatible_with(@_);
}
1;
# ABSTRACT: Method Meta Object for C<meta> methods
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Method::Meta - Method Meta Object for C<meta> methods
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This is a L<Class::MOP::Method> subclass which represents C<meta>
methods installed into classes by Class::MOP.
=head1 METHODS
=over 4
=item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
This is the constructor. It accepts a L<Class::MOP::Method> object and
a hash of options. The options accepted are identical to the ones
accepted by L<Class::MOP::Method>, except that C<body> cannot be passed
(it will be generated automatically).
=back
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

331
database/perl/vendor/lib/Class/MOP/Method/Wrapped.pm vendored Normal file
View File

@@ -0,0 +1,331 @@
package Class::MOP::Method::Wrapped;
our $VERSION = '2.2014';
use strict;
use warnings;
use Scalar::Util 'blessed';
use Sub::Name 'subname';
use parent 'Class::MOP::Method';
# NOTE:
# this ugly beast is the result of trying
# to micro optimize this as much as possible
# while not completely loosing maintainability.
# At this point it's "fast enough", after all
# you can't get something for nothing :)
my $_build_wrapped_method = sub {
my $modifier_table = shift;
my ($before, $after, $around) = (
$modifier_table->{before},
$modifier_table->{after},
$modifier_table->{around},
);
if (@$before && @$after) {
$modifier_table->{cache} = sub {
for my $c (@$before) { $c->(@_) };
my @rval;
((defined wantarray) ?
((wantarray) ?
(@rval = $around->{cache}->(@_))
:
($rval[0] = $around->{cache}->(@_)))
:
$around->{cache}->(@_));
for my $c (@$after) { $c->(@_) };
return unless defined wantarray;
return wantarray ? @rval : $rval[0];
}
}
elsif (@$before) {
$modifier_table->{cache} = sub {
for my $c (@$before) { $c->(@_) };
return $around->{cache}->(@_);
}
}
elsif (@$after) {
$modifier_table->{cache} = sub {
my @rval;
((defined wantarray) ?
((wantarray) ?
(@rval = $around->{cache}->(@_))
:
($rval[0] = $around->{cache}->(@_)))
:
$around->{cache}->(@_));
for my $c (@$after) { $c->(@_) };
return unless defined wantarray;
return wantarray ? @rval : $rval[0];
}
}
else {
$modifier_table->{cache} = $around->{cache};
}
};
sub wrap {
my ( $class, $code, %params ) = @_;
(blessed($code) && $code->isa('Class::MOP::Method'))
|| $class->_throw_exception( CanOnlyWrapBlessedCode => params => \%params,
class => $class,
code => $code
);
my $modifier_table = {
cache => undef,
orig => $code->body,
before => [],
after => [],
around => {
cache => $code->body,
methods => [],
},
};
$_build_wrapped_method->($modifier_table);
# get these from the original unless explicitly overridden
my $pkg_name = $params{package_name} || $code->package_name;
my $method_name = $params{name} || $code->name;
return $class->SUPER::wrap(
sub {
my $wrapped = subname "${pkg_name}::_wrapped_${method_name}" => $modifier_table->{cache};
return $wrapped->(@_) ;
},
package_name => $pkg_name,
name => $method_name,
original_method => $code,
modifier_table => $modifier_table,
);
}
sub _new {
my $class = shift;
return Class::MOP::Class->initialize($class)->new_object(@_)
if $class ne __PACKAGE__;
my $params = @_ == 1 ? $_[0] : {@_};
return bless {
# inherited from Class::MOP::Method
'body' => $params->{body},
'associated_metaclass' => $params->{associated_metaclass},
'package_name' => $params->{package_name},
'name' => $params->{name},
'original_method' => $params->{original_method},
# defined in this class
'modifier_table' => $params->{modifier_table}
} => $class;
}
sub get_original_method {
my $code = shift;
$code->original_method;
}
sub add_before_modifier {
my $code = shift;
my $modifier = shift;
unshift @{$code->{'modifier_table'}->{before}} => $modifier;
$_build_wrapped_method->($code->{'modifier_table'});
}
sub before_modifiers {
my $code = shift;
return @{$code->{'modifier_table'}->{before}};
}
sub add_after_modifier {
my $code = shift;
my $modifier = shift;
push @{$code->{'modifier_table'}->{after}} => $modifier;
$_build_wrapped_method->($code->{'modifier_table'});
}
sub after_modifiers {
my $code = shift;
return @{$code->{'modifier_table'}->{after}};
}
{
# NOTE:
# this is another possible candidate for
# optimization as well. There is an overhead
# associated with the currying that, if
# eliminated might make around modifiers
# more manageable.
my $compile_around_method = sub {{
my $f1 = pop;
return $f1 unless @_;
my $f2 = pop;
push @_, sub { $f2->( $f1, @_ ) };
redo;
}};
sub add_around_modifier {
my $code = shift;
my $modifier = shift;
unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
$code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
@{$code->{'modifier_table'}->{around}->{methods}},
$code->{'modifier_table'}->{orig}
);
$_build_wrapped_method->($code->{'modifier_table'});
}
}
sub around_modifiers {
my $code = shift;
return @{$code->{'modifier_table'}->{around}->{methods}};
}
sub _make_compatible_with {
my $self = shift;
my ($other) = @_;
# XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped
# objects are subclasses of CMOP::Method, but when we get to moose, they'll
# need to be compatible with Moose::Meta::Method, which isn't possible. the
# right solution here is to make ::Wrapped into a role that gets applied to
# whatever the method_metaclass happens to be and get rid of
# wrapped_method_metaclass entirely, but that's not going to happen until
# we ditch cmop and get roles into the bootstrapping, so. i'm not
# maintaining the previous behavior of turning them into instances of the
# new method_metaclass because that's equally broken, and at least this way
# any issues will at least be detectable and potentially fixable. -doy
return $self unless $other->_is_compatible_with($self->_real_ref_name);
return $self->SUPER::_make_compatible_with(@_);
}
1;
# ABSTRACT: Method Meta Object for methods with before/after/around modifiers
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Method::Wrapped - Method Meta Object for methods with before/after/around modifiers
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This is a L<Class::MOP::Method> subclass which implements before,
after, and around method modifiers.
=head1 METHODS
=head2 Class::MOP::Method::Wrapped->wrap($metamethod, %options)
This is the constructor. It accepts a L<Class::MOP::Method> object and
a hash of options.
The options are:
=over 4
=item * name
The method name (without a package name). This will be taken from the
provided L<Class::MOP::Method> object if it is not provided.
=item * package_name
The package name for the method. This will be taken from the provided
L<Class::MOP::Method> object if it is not provided.
=item * associated_metaclass
An optional L<Class::MOP::Class> object. This is the metaclass for the
method's class.
=back
=head2 $metamethod->get_original_method
This returns the L<Class::MOP::Method> object that was passed to the
constructor.
=head2 $metamethod->add_before_modifier($code)
=head2 $metamethod->add_after_modifier($code)
=head2 $metamethod->add_around_modifier($code)
These methods all take a subroutine reference and apply it as a
modifier to the original method.
=head2 $metamethod->before_modifiers
=head2 $metamethod->after_modifiers
=head2 $metamethod->around_modifiers
These methods all return a list of subroutine references which are
acting as the specified type of modifier.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

113
database/perl/vendor/lib/Class/MOP/MiniTrait.pm vendored Normal file
View File

@@ -0,0 +1,113 @@
package Class::MOP::MiniTrait;
our $VERSION = '2.2014';
use strict;
use warnings;
use Module::Runtime 'use_package_optimistically';
sub apply {
my ( $to_class, $trait ) = @_;
for ( grep { !ref } $to_class, $trait ) {
use_package_optimistically($_);
$_ = Class::MOP::Class->initialize($_);
}
for my $meth ( grep { $_->package_name ne 'UNIVERSAL' } $trait->get_all_methods ) {
my $meth_name = $meth->name;
next if index($meth_name, '__') == 0; # skip private subs
if ( $to_class->find_method_by_name($meth_name) ) {
$to_class->add_around_method_modifier( $meth_name, $meth->body );
}
else {
$to_class->add_method( $meth_name, $meth->clone );
}
}
}
# We can't load this with use, since it may be loaded and used from Class::MOP
# (via Class::MOP::Class, etc). However, if for some reason this module is loaded
# _without_ first loading Class::MOP we need to require Class::MOP so we can
# use it and Class::MOP::Class.
require Class::MOP;
1;
# ABSTRACT: Extremely limited trait application
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::MiniTrait - Extremely limited trait application
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This package provides a single function, C<apply>, which does a half-assed job
of applying a trait to a class. It exists solely for use inside Class::MOP and
L<Moose> core classes.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

107
database/perl/vendor/lib/Class/MOP/Mixin.pm vendored Normal file
View File

@@ -0,0 +1,107 @@
package Class::MOP::Mixin;
our $VERSION = '2.2014';
use strict;
use warnings;
use Scalar::Util 'blessed';
use Module::Runtime 'use_module';
sub meta {
require Class::MOP::Class;
Class::MOP::Class->initialize( blessed( $_[0] ) || $_[0] );
}
sub _throw_exception {
my ($class, $exception_type, @args_to_exception) = @_;
die use_module( "Moose::Exception::$exception_type" )->new( @args_to_exception );
}
1;
# ABSTRACT: Base class for mixin classes
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Mixin - Base class for mixin classes
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This class provides a few methods which are useful in all metaclasses.
=head1 METHODS
=head2 Class::MOP::Mixin->meta
This returns a L<Class::MOP::Class> object for the mixin class.
=head2 Class::MOP::Mixin->_throw_exception
Throws an exception in the L<Moose::Exception> family. This should ONLY be
used internally -- any callers outside Class::MOP::* should be using the
version in L<Moose::Util> instead.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

125
database/perl/vendor/lib/Class/MOP/Mixin/AttributeCore.pm vendored Normal file
View File

@@ -0,0 +1,125 @@
package Class::MOP::Mixin::AttributeCore;
our $VERSION = '2.2014';
use strict;
use warnings;
use Scalar::Util 'blessed';
use parent 'Class::MOP::Mixin';
sub has_accessor { defined $_[0]->{'accessor'} }
sub has_reader { defined $_[0]->{'reader'} }
sub has_writer { defined $_[0]->{'writer'} }
sub has_predicate { defined $_[0]->{'predicate'} }
sub has_clearer { defined $_[0]->{'clearer'} }
sub has_builder { defined $_[0]->{'builder'} }
sub has_init_arg { defined $_[0]->{'init_arg'} }
sub has_default { exists $_[0]->{'default'} }
sub has_initializer { defined $_[0]->{'initializer'} }
sub has_insertion_order { defined $_[0]->{'insertion_order'} }
sub _set_insertion_order { $_[0]->{'insertion_order'} = $_[1] }
sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor }
sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
sub is_default_a_coderef {
# Uber hack because it is called from CMOP::Attribute constructor as
# $class->is_default_a_coderef(\%options)
my ($value) = ref $_[0] ? $_[0]->{'default'} : $_[1]->{'default'};
return unless ref($value);
return ref($value) eq 'CODE'
|| ( blessed($value) && $value->isa('Class::MOP::Method') );
}
sub default {
my ( $self, $instance ) = @_;
if ( defined $instance && $self->is_default_a_coderef ) {
# if the default is a CODE ref, then we pass in the instance and
# default can return a value based on that instance. Somewhat crude,
# but works.
return $self->{'default'}->($instance);
}
$self->{'default'};
}
1;
# ABSTRACT: Core attributes shared by attribute metaclasses
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Mixin::AttributeCore - Core attributes shared by attribute metaclasses
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This class implements the core attributes (aka properties) shared by all
attributes. See the L<Class::MOP::Attribute> documentation for API details.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

171
database/perl/vendor/lib/Class/MOP/Mixin/HasAttributes.pm vendored Normal file
View File

@@ -0,0 +1,171 @@
package Class::MOP::Mixin::HasAttributes;
our $VERSION = '2.2014';
use strict;
use warnings;
use Scalar::Util 'blessed';
use parent 'Class::MOP::Mixin';
sub add_attribute {
my $self = shift;
my $attribute
= blessed( $_[0] ) ? $_[0] : $self->attribute_metaclass->new(@_);
( $attribute->isa('Class::MOP::Mixin::AttributeCore') )
|| $self->_throw_exception( AttributeMustBeAnClassMOPMixinAttributeCoreOrSubclass => attribute => $attribute,
class_name => $self->name,
);
$self->_attach_attribute($attribute);
my $attr_name = $attribute->name;
$self->remove_attribute($attr_name)
if $self->has_attribute($attr_name);
my $order = ( scalar keys %{ $self->_attribute_map } );
$attribute->_set_insertion_order($order);
$self->_attribute_map->{$attr_name} = $attribute;
# This method is called to allow for installing accessors. Ideally, we'd
# use method overriding, but then the subclass would be responsible for
# making the attribute, which would end up with lots of code
# duplication. Even more ideally, we'd use augment/inner, but this is
# Class::MOP!
$self->_post_add_attribute($attribute)
if $self->can('_post_add_attribute');
return $attribute;
}
sub has_attribute {
my ( $self, $attribute_name ) = @_;
( defined $attribute_name )
|| $self->_throw_exception( MustDefineAnAttributeName => class_name => $self->name );
exists $self->_attribute_map->{$attribute_name};
}
sub get_attribute {
my ( $self, $attribute_name ) = @_;
( defined $attribute_name )
|| $self->_throw_exception( MustDefineAnAttributeName => class_name => $self->name );
return $self->_attribute_map->{$attribute_name};
}
sub remove_attribute {
my ( $self, $attribute_name ) = @_;
( defined $attribute_name )
|| $self->_throw_exception( MustDefineAnAttributeName => class_name => $self->name );
my $removed_attribute = $self->_attribute_map->{$attribute_name};
return unless defined $removed_attribute;
delete $self->_attribute_map->{$attribute_name};
return $removed_attribute;
}
sub get_attribute_list {
my $self = shift;
keys %{ $self->_attribute_map };
}
sub _restore_metaattributes_from {
my $self = shift;
my ($old_meta) = @_;
for my $attr (sort { $a->insertion_order <=> $b->insertion_order }
map { $old_meta->get_attribute($_) }
$old_meta->get_attribute_list) {
$attr->_make_compatible_with($self->attribute_metaclass);
$self->add_attribute($attr);
}
}
1;
# ABSTRACT: Methods for metaclasses which have attributes
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Mixin::HasAttributes - Methods for metaclasses which have attributes
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This class implements methods for metaclasses which have attributes
(L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for
API details.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

304
database/perl/vendor/lib/Class/MOP/Mixin/HasMethods.pm vendored Normal file
View File

@@ -0,0 +1,304 @@
package Class::MOP::Mixin::HasMethods;
our $VERSION = '2.2014';
use strict;
use warnings;
use Class::MOP::Method::Meta;
use Scalar::Util 'blessed', 'reftype';
use Sub::Name 'subname';
use parent 'Class::MOP::Mixin';
sub _meta_method_class { 'Class::MOP::Method::Meta' }
sub _add_meta_method {
my $self = shift;
my ($name) = @_;
my $existing_method = $self->can('find_method_by_name')
? $self->find_method_by_name($name)
: $self->get_method($name);
return if $existing_method
&& $existing_method->isa($self->_meta_method_class);
$self->add_method(
$name => $self->_meta_method_class->wrap(
name => $name,
package_name => $self->name,
associated_metaclass => $self,
)
);
}
sub wrap_method_body {
my ( $self, %args ) = @_;
( $args{body} && 'CODE' eq reftype $args{body} )
|| $self->_throw_exception( CodeBlockMustBeACodeRef => instance => $self,
params => \%args
);
$self->method_metaclass->wrap(
package_name => $self->name,
%args,
);
}
sub add_method {
my ( $self, $method_name, $method ) = @_;
( defined $method_name && length $method_name )
|| $self->_throw_exception( MustDefineAMethodName => instance => $self );
my $package_name = $self->name;
my $body;
if ( blessed($method) && $method->isa('Class::MOP::Method') ) {
$body = $method->body;
if ( $method->package_name ne $package_name ) {
$method = $method->clone(
package_name => $package_name,
name => $method_name,
);
}
$method->attach_to_class($self);
}
else {
# If a raw code reference is supplied, its method object is not created.
# The method object won't be created until required.
$body = $method;
}
$self->_method_map->{$method_name} = $method;
my ($current_package, $current_name) = Class::MOP::get_code_info($body);
subname($package_name . '::' . $method_name, $body)
unless defined $current_name && $current_name !~ /^__ANON__/;
$self->add_package_symbol("&$method_name", $body);
# we added the method to the method map too, so it's still valid
$self->update_package_cache_flag;
}
sub _code_is_mine {
my ( $self, $code ) = @_;
my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
return ( $code_package && $code_package eq $self->name )
|| ( $code_package eq 'constant' && $code_name eq '__ANON__' );
}
sub has_method {
my ( $self, $method_name ) = @_;
( defined $method_name && length $method_name )
|| $self->_throw_exception( MustDefineAMethodName => instance => $self );
my $method = $self->_get_maybe_raw_method($method_name);
return if not $method;
return defined($self->_method_map->{$method_name} = $method);
}
sub get_method {
my ( $self, $method_name ) = @_;
( defined $method_name && length $method_name )
|| $self->_throw_exception( MustDefineAMethodName => instance => $self );
my $method = $self->_get_maybe_raw_method($method_name);
return if not $method;
return $method if blessed($method) && $method->isa('Class::MOP::Method');
return $self->_method_map->{$method_name} = $self->wrap_method_body(
body => $method,
name => $method_name,
associated_metaclass => $self,
);
}
sub _get_maybe_raw_method {
my ( $self, $method_name ) = @_;
my $map_entry = $self->_method_map->{$method_name};
return $map_entry if defined $map_entry;
my $code = $self->get_package_symbol("&$method_name");
return unless $code && $self->_code_is_mine($code);
return $code;
}
sub remove_method {
my ( $self, $method_name ) = @_;
( defined $method_name && length $method_name )
|| $self->_throw_exception( MustDefineAMethodName => instance => $self );
my $removed_method = delete $self->_method_map->{$method_name};
$self->remove_package_symbol("&$method_name");
$removed_method->detach_from_class
if blessed($removed_method) && $removed_method->isa('Class::MOP::Method');
# still valid, since we just removed the method from the map
$self->update_package_cache_flag;
return $removed_method;
}
sub get_method_list {
my $self = shift;
return keys %{ $self->_full_method_map };
}
sub _get_local_methods {
my $self = shift;
return values %{ $self->_full_method_map };
}
sub _restore_metamethods_from {
my $self = shift;
my ($old_meta) = @_;
my $package_name = $self->name;
# Check if Perl debugger is enabled
my $debugger_enabled = ($^P & 0x10);
my $debug_method_info;
for my $method ($old_meta->_get_local_methods) {
my $method_name = $method->name;
# Track DB::sub information for this method if debugger is enabled.
# This contains original method filename and line numbers.
$debug_method_info = '';
if ($debugger_enabled) {
$debug_method_info = $DB::sub{$package_name . "::" . $method_name}
}
$method->_make_compatible_with($self->method_metaclass);
$self->add_method($method_name => $method);
# Restore method debug information, which can be clobbered by add_method.
# Note that we handle this here instead of in add_method, because we
# only want to preserve the original debug info in cases where we are
# restoring a method, not overwriting a method.
if ($debugger_enabled && $debug_method_info) {
$DB::sub{$package_name . "::" . $method_name} = $debug_method_info;
}
}
}
sub reset_package_cache_flag { (shift)->{'_package_cache_flag'} = undef }
sub update_package_cache_flag {
my $self = shift;
# NOTE:
# we can manually update the cache number
# since we are actually adding the method
# to our cache as well. This avoids us
# having to regenerate the method_map.
# - SL
$self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name);
}
sub _full_method_map {
my $self = shift;
my $pkg_gen = Class::MOP::check_package_cache_flag($self->name);
if (($self->{_package_cache_flag_full} || -1) != $pkg_gen) {
# forcibly reify all method map entries
$self->get_method($_)
for $self->list_all_package_symbols('CODE');
$self->{_package_cache_flag_full} = $pkg_gen;
}
return $self->_method_map;
}
1;
# ABSTRACT: Methods for metaclasses which have methods
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Mixin::HasMethods - Methods for metaclasses which have methods
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This class implements methods for metaclasses which have methods
(L<Class::MOP::Class> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for
API details.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

243
database/perl/vendor/lib/Class/MOP/Mixin/HasOverloads.pm vendored Normal file
View File

@@ -0,0 +1,243 @@
package Class::MOP::Mixin::HasOverloads;
our $VERSION = '2.2014';
use strict;
use warnings;
use Class::MOP::Overload;
use Devel::OverloadInfo 0.005 'overload_info', 'overload_op_info';
use Scalar::Util 'blessed';
use overload ();
use parent 'Class::MOP::Mixin';
sub is_overloaded {
my $self = shift;
Devel::OverloadInfo::is_overloaded($self->name);
}
sub get_overload_list {
my $self = shift;
my $info = $self->_overload_info;
return grep { $_ ne 'fallback' } keys %{$info}
}
sub get_all_overloaded_operators {
my $self = shift;
return map { $self->_overload_for($_) } $self->get_overload_list;
}
sub has_overloaded_operator {
my $self = shift;
my ($op) = @_;
return defined $self->_overload_info_for($op);
}
sub _overload_map {
$_[0]->{_overload_map} ||= {};
}
sub get_overloaded_operator {
my $self = shift;
my ($op) = @_;
return $self->_overload_map->{$op} ||= $self->_overload_for($op);
}
use constant _SET_FALLBACK_EACH_TIME => "$]" < 5.120;
sub add_overloaded_operator {
my $self = shift;
my ( $op, $overload ) = @_;
my %p = ( associated_metaclass => $self );
if ( !ref $overload ) {
%p = (
%p,
operator => $op,
method_name => $overload,
associated_metaclass => $self,
);
$p{method} = $self->get_method($overload)
if $self->has_method($overload);
$overload = Class::MOP::Overload->new(%p);
}
elsif ( !blessed $overload) {
my ($coderef_package, $coderef_name) = Class::MOP::get_code_info($overload);
$overload = Class::MOP::Overload->new(
operator => $op,
coderef => $overload,
coderef_name => $coderef_name,
coderef_package => $coderef_package,
%p,
);
}
$overload->attach_to_class($self);
$self->_overload_map->{$op} = $overload;
my %overload = (
$op => $overload->has_coderef
? $overload->coderef
: $overload->method_name
);
# Perl 5.10 and earlier appear to have a bug where setting a new
# overloading operator wipes out the fallback value unless we pass it each
# time.
if (_SET_FALLBACK_EACH_TIME) {
$overload{fallback} = $self->get_overload_fallback_value;
}
$self->name->overload::OVERLOAD(%overload);
}
sub remove_overloaded_operator {
my $self = shift;
my ($op) = @_;
delete $self->_overload_map->{$op};
# overload.pm provides no api for this - but the problem that makes this
# necessary has been fixed in 5.18
$self->get_or_add_package_symbol('%OVERLOAD')->{dummy}++
if "$]" < 5.017000;
$self->remove_package_symbol('&(' . $op);
}
sub get_overload_fallback_value {
my $self = shift;
return ($self->_overload_info_for('fallback') || {})->{value};
}
sub set_overload_fallback_value {
my $self = shift;
my $value = shift;
$self->name->overload::OVERLOAD( fallback => $value );
}
# We could cache this but we'd need some logic to clear it at all the right
# times, which seems more tedious than it's worth.
sub _overload_info {
my $self = shift;
return overload_info( $self->name ) || {};
}
sub _overload_info_for {
my $self = shift;
my $op = shift;
return overload_op_info( $self->name, $op );
}
sub _overload_for {
my $self = shift;
my $op = shift;
my $map = $self->_overload_map;
return $map->{$op} if $map->{$op};
my $info = $self->_overload_info_for($op);
return unless $info;
my %p = (
operator => $op,
associated_metaclass => $self,
);
if ( $info->{code} && !$info->{method_name} ) {
$p{coderef} = $info->{code};
@p{ 'coderef_package', 'coderef_name' }
= $info->{code_name} =~ /(.+)::([^:]+)/;
}
else {
$p{method_name} = $info->{method_name};
if ( $self->has_method( $p{method_name} ) ) {
$p{method} = $self->get_method( $p{method_name} );
}
}
return $map->{$op} = Class::MOP::Overload->new(%p);
}
1;
# ABSTRACT: Methods for metaclasses which have overloads
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Mixin::HasOverloads - Methods for metaclasses which have overloads
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This class implements methods for metaclasses which have overloads
(L<Class::MOP::Clas> and L<Moose::Meta::Role>). See L<Class::MOP::Class> for
API details.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

209
database/perl/vendor/lib/Class/MOP/Module.pm vendored Normal file
View File

@@ -0,0 +1,209 @@
package Class::MOP::Module;
our $VERSION = '2.2014';
use strict;
use warnings;
use parent 'Class::MOP::Package';
sub _new {
my $class = shift;
return Class::MOP::Class->initialize($class)->new_object(@_)
if $class ne __PACKAGE__;
my $params = @_ == 1 ? $_[0] : {@_};
return bless {
# Need to quote package to avoid a problem with PPI mis-parsing this
# as a package statement.
# from Class::MOP::Package
'package' => $params->{package},
namespace => \undef,
# attributes
version => \undef,
authority => \undef
} => $class;
}
sub version {
my $self = shift;
${$self->get_or_add_package_symbol('$VERSION')};
}
sub authority {
my $self = shift;
${$self->get_or_add_package_symbol('$AUTHORITY')};
}
sub identifier {
my $self = shift;
join '-' => (
$self->name,
($self->version || ()),
($self->authority || ()),
);
}
sub create {
my $class = shift;
my @args = @_;
unshift @args, 'package' if @args % 2 == 1;
my %options = @args;
my $package = delete $options{package};
my $version = delete $options{version};
my $authority = delete $options{authority};
my $meta = $class->SUPER::create($package => %options);
$meta->_instantiate_module($version, $authority);
return $meta;
}
sub _anon_package_prefix { 'Class::MOP::Module::__ANON__::SERIAL::' }
sub _anon_cache_key {
my $class = shift;
my %options = @_;
$class->_throw_exception( PackagesAndModulesAreNotCachable => class_name => $class,
params => \%options,
is_module => 1
);
}
sub _instantiate_module {
my($self, $version, $authority) = @_;
my $package_name = $self->name;
$self->add_package_symbol('$VERSION' => $version)
if defined $version;
$self->add_package_symbol('$AUTHORITY' => $authority)
if defined $authority;
return;
}
1;
# ABSTRACT: Module Meta Object
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Module - Module Meta Object
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
A module is essentially a L<Class::MOP::Package> with metadata, in our
case the version and authority.
=head1 INHERITANCE
B<Class::MOP::Module> is a subclass of L<Class::MOP::Package>.
=head1 METHODS
=head2 Class::MOP::Module->create($package, %options)
Overrides C<create> from L<Class::MOP::Package> to provide these additional
options:
=over 4
=item C<version>
A version number, to be installed in the C<$VERSION> package global variable.
=item C<authority>
An authority, to be installed in the C<$AUTHORITY> package global variable.
This is a legacy field and its use is not recommended.
=back
=head2 $metamodule->version
This is a read-only attribute which returns the C<$VERSION> of the
package, if one exists.
=head2 $metamodule->authority
This is a read-only attribute which returns the C<$AUTHORITY> of the
package, if one exists.
=head2 $metamodule->identifier
This constructs a string which combines the name, version and
authority.
=head2 Class::MOP::Module->meta
This will return a L<Class::MOP::Class> instance for this class.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

196
database/perl/vendor/lib/Class/MOP/Object.pm vendored Normal file
View File

@@ -0,0 +1,196 @@
package Class::MOP::Object;
our $VERSION = '2.2014';
use strict;
use warnings;
use parent 'Class::MOP::Mixin';
use Scalar::Util 'blessed';
use Module::Runtime;
# introspection
sub throw_error {
shift->_throw_exception( Legacy => message => join('', @_) );
}
sub _inline_throw_error {
my ( $self, $message ) = @_;
return 'die Module::Runtime::use_module("Moose::Exception::Legacy")->new(message => ' . $message. ')';
}
sub _new {
Class::MOP::class_of(shift)->new_object(@_);
}
# RANT:
# Cmon, how many times have you written
# the following code while debugging:
#
# use Data::Dumper;
# warn Dumper $obj;
#
# It can get seriously annoying, so why
# not just do this ...
sub dump {
my $self = shift;
require Data::Dumper;
local $Data::Dumper::Maxdepth = shift || 1;
Data::Dumper::Dumper $self;
}
sub _real_ref_name {
my $self = shift;
return blessed($self);
}
sub _is_compatible_with {
my $self = shift;
my ($other_name) = @_;
return $self->isa($other_name);
}
sub _can_be_made_compatible_with {
my $self = shift;
return !$self->_is_compatible_with(@_)
&& defined($self->_get_compatible_metaclass(@_));
}
sub _make_compatible_with {
my $self = shift;
my ($other_name) = @_;
my $new_metaclass = $self->_get_compatible_metaclass($other_name);
unless ( defined $new_metaclass ) {
$self->_throw_exception( CannotMakeMetaclassCompatible => superclass_name => $other_name,
class => $self,
);
}
# can't use rebless_instance here, because it might not be an actual
# subclass in the case of, e.g. moose role reconciliation
$new_metaclass->meta->_force_rebless_instance($self)
if blessed($self) ne $new_metaclass;
return $self;
}
sub _get_compatible_metaclass {
my $self = shift;
my ($other_name) = @_;
return $self->_get_compatible_metaclass_by_subclassing($other_name);
}
sub _get_compatible_metaclass_by_subclassing {
my $self = shift;
my ($other_name) = @_;
my $meta_name = blessed($self) ? $self->_real_ref_name : $self;
if ($meta_name->isa($other_name)) {
return $meta_name;
}
elsif ($other_name->isa($meta_name)) {
return $other_name;
}
return;
}
1;
# ABSTRACT: Base class for metaclasses
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Object - Base class for metaclasses
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
This class is a very minimal base class for metaclasses.
=head1 METHODS
This class provides a few methods which are useful in all metaclasses.
=head2 Class::MOP::???->meta
This returns a L<Class::MOP::Class> object.
=head2 $metaobject->dump($max_depth)
This method uses L<Data::Dumper> to dump the object. You can pass an
optional maximum depth, which will set C<$Data::Dumper::Maxdepth>. The
default maximum depth is 1.
=head2 $metaclass->throw_error($message)
This method calls L<Class::MOP::Mixin/_throw_exception> internally, with an object
of class L<Moose::Exception::Legacy>.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

340
database/perl/vendor/lib/Class/MOP/Overload.pm vendored Normal file
View File

@@ -0,0 +1,340 @@
package Class::MOP::Overload;
our $VERSION = '2.2014';
use strict;
use warnings;
use overload ();
use Scalar::Util qw( blessed weaken );
use Try::Tiny;
use parent 'Class::MOP::Object';
my %Operators = (
map { $_ => 1 }
grep { $_ ne 'fallback' }
map { split /\s+/ } values %overload::ops
);
sub new {
my ( $class, %params ) = @_;
unless ( defined $params{operator} ) {
$class->_throw_exception('OverloadRequiresAnOperator');
}
unless ( $Operators{ $params{operator} } ) {
$class->_throw_exception(
'InvalidOverloadOperator',
operator => $params{operator},
);
}
unless ( defined $params{method_name} || $params{coderef} ) {
$class->_throw_exception(
'OverloadRequiresAMethodNameOrCoderef',
operator => $params{operator},
);
}
if ( $params{coderef} ) {
unless ( defined $params{coderef_package}
&& defined $params{coderef_name} ) {
$class->_throw_exception('OverloadRequiresNamesForCoderef');
}
}
if ( $params{method}
&& !try { $params{method}->isa('Class::MOP::Method') } ) {
$class->_throw_exception('OverloadRequiresAMetaMethod');
}
if ( $params{associated_metaclass}
&& !try { $params{associated_metaclass}->isa('Class::MOP::Module') } )
{
$class->_throw_exception('OverloadRequiresAMetaClass');
}
my @optional_attrs
= qw( method_name coderef coderef_package coderef_name method associated_metaclass );
return bless {
operator => $params{operator},
map { defined $params{$_} ? ( $_ => $params{$_} ) : () }
@optional_attrs
},
$class;
}
sub operator { $_[0]->{operator} }
sub method_name { $_[0]->{method_name} }
sub has_method_name { exists $_[0]->{method_name} }
sub method { $_[0]->{method} }
sub has_method { exists $_[0]->{method} }
sub coderef { $_[0]->{coderef} }
sub has_coderef { exists $_[0]->{coderef} }
sub coderef_package { $_[0]->{coderef_package} }
sub has_coderef_package { exists $_[0]->{coderef_package} }
sub coderef_name { $_[0]->{coderef_name} }
sub has_coderef_name { exists $_[0]->{coderef_name} }
sub associated_metaclass { $_[0]->{associated_metaclass} }
sub is_anonymous {
my $self = shift;
return $self->has_coderef && $self->coderef_name eq '__ANON__';
}
sub attach_to_class {
my ( $self, $class ) = @_;
$self->{associated_metaclass} = $class;
weaken $self->{associated_metaclass};
}
sub clone {
my $self = shift;
my $clone = bless { %{$self}, @_ }, blessed($self);
weaken $clone->{associated_metaclass} if $clone->{associated_metaclass};
$clone->_set_original_overload($self);
return $clone;
}
sub original_overload { $_[0]->{original_overload} }
sub _set_original_overload { $_[0]->{original_overload} = $_[1] }
sub _is_equal_to {
my $self = shift;
my $other = shift;
if ( $self->has_coderef ) {
return unless $other->has_coderef;
return $self->coderef == $other->coderef;
}
else {
return $self->method_name eq $other->method_name;
}
}
1;
# ABSTRACT: Overload Meta Object
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Overload - Overload Meta Object
=head1 VERSION
version 2.2014
=head1 SYNOPSIS
my $meta = Class->meta;
my $overload = $meta->get_overloaded_operator('+');
if ( $overload->has_method_name ) {
print 'Method for + is ', $overload->method_name, "\n";
}
else {
print 'Overloading for + is implemented by ',
$overload->coderef_name, " sub\n";
}
=head1 DESCRIPTION
This class provides meta information for overloading in classes and roles.
=head1 INHERITANCE
C<Class::MOP::Overload> is a subclass of L<Class::MOP::Object>.
=head1 METHODS
=head2 Class::MOP::Overload->new(%options)
This method creates a new C<Class::MOP::Overload> object. It accepts a number
of options:
=over 4
=item * operator
This is a string that matches an operator known by the L<overload> module,
such as C<""> or C<+>. This is required.
=item * method_name
The name of the method which implements the overloading. Note that this does
not need to actually correspond to a real method, since it's okay to declare a
not-yet-implemented overloading.
Either this or the C<coderef> option must be passed.
=item * method
A L<Class::MOP::Method> object for the method which implements the
overloading.
This is optional.
=item * coderef
A coderef which implements the overloading.
Either this or the C<method_name> option must be passed.
=item * coderef_package
The package where the coderef was defined.
This is required if C<coderef> is passed.
=item * coderef_name
The name of the coderef. This can be "__ANON__".
This is required if C<coderef> is passed.
=item * associated_metaclass
A L<Class::MOP::Module> object for the associated class or role.
This is optional.
=back
=head2 $overload->operator
Returns the operator for this overload object.
=head2 $overload->method_name
Returns the method name that implements overloading, if it has one.
=head2 $overload->has_method_name
Returns true if the object has a method name.
=head2 $overload->method
Returns the L<Class::MOP::Method> that implements overloading, if it has one.
=head2 $overload->has_method
Returns true if the object has a method.
=head2 $overload->coderef
Returns the coderef that implements overloading, if it has one.
=head2 $overload->has_coderef
Returns true if the object has a coderef.
=head2 $overload->coderef_package
Returns the package for the coderef that implements overloading, if it has
one.
=head2 $overload->has_coderef
Returns true if the object has a coderef package.
=head2 $overload->coderef_name
Returns the sub name for the coderef that implements overloading, if it has
one.
=head2 $overload->has_coderef_name
Returns true if the object has a coderef name.
=head2 $overload->is_anonymous
Returns true if the overloading is implemented by an anonymous coderef.
=head2 $overload->associated_metaclass
Returns the L<Class::MOP::Module> (class or role) that is associated with the
overload object.
=head2 $overload->clone
Clones the overloading object, setting C<original_overload> in the process.
=head2 $overload->original_overload
For cloned objects, this returns the L<Class::MOP::Overload> object from which
they were cloned. This can be used to determine the source of an overloading
in a class that came from a role, for example.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

460
database/perl/vendor/lib/Class/MOP/Package.pm vendored Normal file
View File

@@ -0,0 +1,460 @@
package Class::MOP::Package;
our $VERSION = '2.2014';
use strict;
use warnings;
use Scalar::Util 'blessed', 'weaken';
use Devel::GlobalDestruction 'in_global_destruction';
use Module::Runtime 'module_notional_filename';
use Package::Stash;
use parent 'Class::MOP::Object';
# creation ...
sub initialize {
my ( $class, @args ) = @_;
unshift @args, "package" if @args % 2;
my %options = @args;
my $package_name = delete $options{package};
# we hand-construct the class until we can bootstrap it
if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
return $meta;
} else {
my $meta = ( ref $class || $class )->_new({
'package' => $package_name,
%options,
});
Class::MOP::store_metaclass_by_name($package_name, $meta);
Class::MOP::weaken_metaclass($package_name) if $options{weaken};
return $meta;
}
}
sub reinitialize {
my ( $class, @args ) = @_;
unshift @args, "package" if @args % 2;
my %options = @args;
my $package_name = delete $options{package};
(defined $package_name && $package_name
&& (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
|| $class->_throw_exception( MustPassAPackageNameOrAnExistingClassMOPPackageInstance => params => \%options,
class => $class
);
$package_name = $package_name->name
if blessed $package_name;
Class::MOP::remove_metaclass_by_name($package_name);
$class->initialize($package_name, %options); # call with first arg form for compat
}
sub create {
my $class = shift;
my @args = @_;
my $meta = $class->initialize(@args);
my $filename = module_notional_filename($meta->name);
$INC{$filename} = '(set by Moose)'
unless exists $INC{$filename};
return $meta;
}
## ANON packages
{
# NOTE:
# this should be sufficient, if you have a
# use case where it is not, write a test and
# I will change it.
my $ANON_SERIAL = 0;
my %ANON_PACKAGE_CACHE;
# NOTE:
# we need a sufficiently annoying prefix
# this should suffice for now, this is
# used in a couple of places below, so
# need to put it up here for now.
sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' }
sub is_anon {
my $self = shift;
no warnings 'uninitialized';
my $prefix = $self->_anon_package_prefix;
$self->name =~ /^\Q$prefix/;
}
sub create_anon {
my ($class, %options) = @_;
my $cache_ok = delete $options{cache};
$options{weaken} = !$cache_ok unless exists $options{weaken};
my $cache_key;
if ($cache_ok) {
$cache_key = $class->_anon_cache_key(%options);
undef $cache_ok if !defined($cache_key);
}
if ($cache_ok) {
if (defined $ANON_PACKAGE_CACHE{$cache_key}) {
return $ANON_PACKAGE_CACHE{$cache_key};
}
}
my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
my $meta = $class->create($package_name, %options);
if ($cache_ok) {
$ANON_PACKAGE_CACHE{$cache_key} = $meta;
weaken($ANON_PACKAGE_CACHE{$cache_key});
}
return $meta;
}
sub _anon_cache_key {
my $class = shift;
my %options = @_;
$class->_throw_exception( PackagesAndModulesAreNotCachable => class_name => $class,
params => \%options,
is_module => 0
);
}
sub DESTROY {
my $self = shift;
return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
$self->_free_anon
if $self->is_anon;
}
sub _free_anon {
my $self = shift;
my $name = $self->name;
# Moose does a weird thing where it replaces the metaclass for
# class when fixing metaclass incompatibility. In that case,
# we don't want to clean out the namespace now. We can detect
# that because Moose will explicitly update the singleton
# cache in Class::MOP using store_metaclass_by_name, which
# means that the new metaclass will already exist in the cache
# by this point.
# The other options here are that $current_meta can be undef if
# remove_metaclass_by_name is called explicitly (since the hash
# entry is removed first, and then this destructor is called),
# or that $current_meta can be the same as $self, which happens
# when the metaclass goes out of scope (since the weak reference
# in the metaclass cache won't be freed until after this
# destructor runs).
my $current_meta = Class::MOP::get_metaclass_by_name($name);
return if defined($current_meta) && $current_meta ne $self;
my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
no strict 'refs';
# clear @ISA first, to avoid a memory leak
# see https://rt.perl.org/rt3/Public/Bug/Display.html?id=92708
@{$name . '::ISA'} = ();
%{$name . '::'} = ();
delete ${$first_fragments . '::'}{$last_fragment . '::'};
Class::MOP::remove_metaclass_by_name($name);
delete $INC{module_notional_filename($name)};
}
}
sub _new {
my $class = shift;
return Class::MOP::Class->initialize($class)->new_object(@_)
if $class ne __PACKAGE__;
my $params = @_ == 1 ? $_[0] : {@_};
return bless {
# Need to quote package to avoid a problem with PPI mis-parsing this
# as a package statement.
'package' => $params->{package},
# NOTE:
# because of issues with the Perl API
# to the typeglob in some versions, we
# need to just always grab a new
# reference to the hash in the accessor.
# Ideally we could just store a ref and
# it would Just Work, but oh well :\
namespace => \undef,
} => $class;
}
# Attributes
# NOTE:
# all these attribute readers will be bootstrapped
# away in the Class::MOP bootstrap section
sub _package_stash {
$_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
}
sub namespace {
$_[0]->_package_stash->namespace
}
# Class attributes
# ... these functions have to touch the symbol table itself,.. yuk
sub add_package_symbol {
my $self = shift;
$self->_package_stash->add_symbol(@_);
}
sub remove_package_glob {
my $self = shift;
$self->_package_stash->remove_glob(@_);
}
# ... these functions deal with stuff on the namespace level
sub has_package_symbol {
my $self = shift;
$self->_package_stash->has_symbol(@_);
}
sub get_package_symbol {
my $self = shift;
$self->_package_stash->get_symbol(@_);
}
sub get_or_add_package_symbol {
my $self = shift;
$self->_package_stash->get_or_add_symbol(@_);
}
sub remove_package_symbol {
my $self = shift;
$self->_package_stash->remove_symbol(@_);
}
sub list_all_package_symbols {
my $self = shift;
$self->_package_stash->list_all_symbols(@_);
}
sub get_all_package_symbols {
my $self = shift;
$self->_package_stash->get_all_symbols(@_);
}
1;
# ABSTRACT: Package Meta Object
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::MOP::Package - Package Meta Object
=head1 VERSION
version 2.2014
=head1 DESCRIPTION
The Package Protocol provides an abstraction of a Perl 5 package. A
package is basically namespace, and this module provides methods for
looking at and changing that namespace's symbol table.
=head1 METHODS
=head2 Class::MOP::Package->initialize($package_name, %options)
This method creates a new C<Class::MOP::Package> instance which
represents specified package. If an existing metaclass object exists
for the package, that will be returned instead. No options are valid at the
package level.
=head2 Class::MOP::Package->reinitialize($package, %options)
This method forcibly removes any existing metaclass for the package
before calling C<initialize>. In contrast to C<initialize>, you may
also pass an existing C<Class::MOP::Package> instance instead of just
a package name as C<$package>.
Do not call this unless you know what you are doing.
=head2 Class::MOP::Package->create($package, %options)
Creates a new C<Class::MOP::Package> instance which represents the specified
package, and also does some initialization of that package. Currently, this
just does the same thing as C<initialize>, but is overridden in subclasses,
such as C<Class::MOP::Class>.
=head2 Class::MOP::Package->create_anon(%options)
Creates a new anonymous package. Valid keys for C<%options> are:
=over 4
=item C<cache>
If this will be C<true> (the default is C<false>), the instance will be cached
in C<Class::MOP>'s metaclass cache.
=item C<weaken>
If this is C<true> (the default C<true> when L<cache> is C<false>), the instance
stored in C<Class::MOP>'s metaclass cache will be weakened, so that the
anonymous package will be garbage collected when the returned instance goes out
of scope.
=back
=head2 $metapackage->is_anon
Returns true if the package is an anonymous package.
=head2 $metapackage->name
This is returns the package's name, as passed to the constructor.
=head2 $metapackage->namespace
This returns a hash reference to the package's symbol table. The keys
are symbol names and the values are typeglob references.
=head2 $metapackage->add_package_symbol($variable_name, $initial_value)
This method accepts a variable name and an optional initial value. The
C<$variable_name> must contain a leading sigil.
This method creates the variable in the package's symbol table, and
sets it to the initial value if one was provided.
=head2 $metapackage->get_package_symbol($variable_name)
Given a variable name, this method returns the variable as a reference
or undef if it does not exist. The C<$variable_name> must contain a
leading sigil.
=head2 $metapackage->get_or_add_package_symbol($variable_name)
Given a variable name, this method returns the variable as a reference.
If it does not exist, a default value will be generated if possible. The
C<$variable_name> must contain a leading sigil.
=head2 $metapackage->has_package_symbol($variable_name)
Returns true if there is a package variable defined for
C<$variable_name>. The C<$variable_name> must contain a leading sigil.
=head2 $metapackage->remove_package_symbol($variable_name)
This will remove the package variable specified C<$variable_name>. The
C<$variable_name> must contain a leading sigil.
=head2 $metapackage->remove_package_glob($glob_name)
Given the name of a glob, this will remove that glob from the
package's symbol table. Glob names do not include a sigil. Removing
the glob removes all variables and subroutines with the specified
name.
=head2 $metapackage->list_all_package_symbols($type_filter)
This will list all the glob names associated with the current
package. These names do not have leading sigils.
You can provide an optional type filter, which should be one of
'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
=head2 $metapackage->get_all_package_symbols($type_filter)
This works much like C<list_all_package_symbols>, but it returns a
hash reference. The keys are glob names and the values are references
to the value for that name.
=head2 Class::MOP::Package->meta
This will return a L<Class::MOP::Class> instance for this class.
=head1 AUTHORS
=over 4
=item *
Stevan Little <stevan@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@cpan.org>
=item *
Shawn M Moore <sartak@cpan.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Chris Prather <chris@prather.org>
=item *
Matt S Trout <mstrout@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2006 by Infinity Interactive, Inc.
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

567
database/perl/vendor/lib/Class/Method/Modifiers.pm vendored Normal file
View File

@@ -0,0 +1,567 @@
use strict;
use warnings;
package Class::Method::Modifiers; # git description: v2.12-17-gbc38636
# ABSTRACT: Provides Moose-like method modifiers
# KEYWORDS: method wrap modification patch
# vim: set ts=8 sts=4 sw=4 tw=115 et :
our $VERSION = '2.13';
use base 'Exporter';
our @EXPORT = qw(before after around);
our @EXPORT_OK = (@EXPORT, qw(fresh install_modifier));
our %EXPORT_TAGS = (
moose => [qw(before after around)],
all => \@EXPORT_OK,
);
BEGIN {
*_HAS_READONLY = $] >= 5.008 ? sub(){1} : sub(){0};
}
our %MODIFIER_CACHE;
# for backward compatibility
sub _install_modifier; # -w
*_install_modifier = \&install_modifier;
sub install_modifier {
my $into = shift;
my $type = shift;
my $code = pop;
my @names = @_;
@names = @{ $names[0] } if ref($names[0]) eq 'ARRAY';
return _fresh($into, $code, @names) if $type eq 'fresh';
for my $name (@names) {
my $hit = $into->can($name) or do {
require Carp;
Carp::confess("The method '$name' is not found in the inheritance hierarchy for class $into");
};
my $qualified = $into.'::'.$name;
my $cache = $MODIFIER_CACHE{$into}{$name} ||= {
before => [],
after => [],
around => [],
};
# this must be the first modifier we're installing
if (!exists($cache->{"orig"})) {
no strict 'refs';
# grab the original method (or undef if the method is inherited)
$cache->{"orig"} = *{$qualified}{CODE};
# the "innermost" method, the one that "around" will ultimately wrap
$cache->{"wrapped"} = $cache->{"orig"} || $hit; #sub {
# # we can't cache this, because new methods or modifiers may be
# # added between now and when this method is called
# for my $package (@{ mro::get_linear_isa($into) }) {
# next if $package eq $into;
# my $code = *{$package.'::'.$name}{CODE};
# goto $code if $code;
# }
# require Carp;
# Carp::confess("$qualified\::$name disappeared?");
#};
}
# keep these lists in the order the modifiers are called
if ($type eq 'after') {
push @{ $cache->{$type} }, $code;
}
else {
unshift @{ $cache->{$type} }, $code;
}
# wrap the method with another layer of around. much simpler than
# the Moose equivalent. :)
if ($type eq 'around') {
my $method = $cache->{wrapped};
my $attrs = _sub_attrs($code);
# a bare "sub :lvalue {...}" will be parsed as a label and an
# indirect method call. force it to be treated as an expression
# using +
$cache->{wrapped} = eval "package $into; +sub $attrs { \$code->(\$method, \@_); };";
}
# install our new method which dispatches the modifiers, but only
# if a new type was added
if (@{ $cache->{$type} } == 1) {
# avoid these hash lookups every method invocation
my $before = $cache->{"before"};
my $after = $cache->{"after"};
# this is a coderef that changes every new "around". so we need
# to take a reference to it. better a deref than a hash lookup
my $wrapped = \$cache->{"wrapped"};
my $attrs = _sub_attrs($cache->{wrapped});
my $generated = "package $into;\n";
$generated .= "sub $name $attrs {";
# before is easy, it doesn't affect the return value(s)
if (@$before) {
$generated .= '
for my $method (@$before) {
$method->(@_);
}
';
}
if (@$after) {
$generated .= '
my $ret;
if (wantarray) {
$ret = [$$wrapped->(@_)];
'.(_HAS_READONLY ? 'Internals::SvREADONLY(@$ret, 1);' : '').'
}
elsif (defined wantarray) {
$ret = \($$wrapped->(@_));
}
else {
$$wrapped->(@_);
}
for my $method (@$after) {
$method->(@_);
}
wantarray ? @$ret : $ret ? $$ret : ();
'
}
else {
$generated .= '$$wrapped->(@_);';
}
$generated .= '}';
no strict 'refs';
no warnings 'redefine';
no warnings 'closure';
eval $generated;
};
}
}
sub before {
_install_modifier(scalar(caller), 'before', @_);
}
sub after {
_install_modifier(scalar(caller), 'after', @_);
}
sub around {
_install_modifier(scalar(caller), 'around', @_);
}
sub fresh {
my $code = pop;
my @names = @_;
@names = @{ $names[0] } if ref($names[0]) eq 'ARRAY';
_fresh(scalar(caller), $code, @names);
}
sub _fresh {
my ($into, $code, @names) = @_;
for my $name (@names) {
if ($name !~ /\A [a-zA-Z_] [a-zA-Z0-9_]* \z/xms) {
require Carp;
Carp::confess("Invalid method name '$name'");
}
if ($into->can($name)) {
require Carp;
Carp::confess("Class $into already has a method named '$name'");
}
# We need to make sure that the installed method has its CvNAME in
# the appropriate package; otherwise, it would be subject to
# deletion if callers use namespace::autoclean. If $code was
# compiled in the target package, we can just install it directly;
# otherwise, we'll need a different approach. Using Sub::Name would
# be fine in all cases, at the cost of introducing a dependency on
# an XS-using, non-core module. So instead we'll use string-eval to
# create a new subroutine that wraps $code.
if (_is_in_package($code, $into)) {
no strict 'refs';
*{"$into\::$name"} = $code;
}
else {
no warnings 'closure'; # for 5.8.x
my $attrs = _sub_attrs($code);
eval "package $into; sub $name $attrs { \$code->(\@_) }";
}
}
}
sub _sub_attrs {
my ($coderef) = @_;
local *_sub = $coderef;
local $@;
# this assignment will fail to compile if it isn't an lvalue sub. we
# never want to actually call the sub though, so we return early.
(eval 'return 1; &_sub = 1') ? ':lvalue' : '';
}
sub _is_in_package {
my ($coderef, $package) = @_;
require B;
my $cv = B::svref_2object($coderef);
return $cv->GV->STASH->NAME eq $package;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::Method::Modifiers - Provides Moose-like method modifiers
=head1 VERSION
version 2.13
=head1 SYNOPSIS
package Child;
use parent 'MyParent';
use Class::Method::Modifiers;
sub new_method { }
before 'old_method' => sub {
carp "old_method is deprecated, use new_method";
};
around 'other_method' => sub {
my $orig = shift;
my $ret = $orig->(@_);
return $ret =~ /\d/ ? $ret : lc $ret;
};
after 'private', 'protected' => sub {
debug "finished calling a dangerous method";
};
use Class::Method::Modifiers qw(fresh);
fresh 'not_in_hierarchy' => sub {
warn "freshly added method\n";
};
=head1 DESCRIPTION
=for stopwords CLOS
Method modifiers are a convenient feature from the CLOS (Common Lisp Object
System) world.
In its most basic form, a method modifier is just a method that calls
C<< $self->SUPER::foo(@_) >>. I for one have trouble remembering that exact
invocation, so my classes seldom re-dispatch to their base classes. Very bad!
C<Class::Method::Modifiers> provides three modifiers: C<before>, C<around>, and
C<after>. C<before> and C<after> are run just before and after the method they
modify, but can not really affect that original method. C<around> is run in
place of the original method, with a hook to easily call that original method.
See the L</MODIFIERS> section for more details on how the particular modifiers
work.
One clear benefit of using C<Class::Method::Modifiers> is that you can define
multiple modifiers in a single namespace. These separate modifiers don't need
to know about each other. This makes top-down design easy. Have a base class
that provides the skeleton methods of each operation, and have plugins modify
those methods to flesh out the specifics.
Parent classes need not know about C<Class::Method::Modifiers>. This means you
should be able to modify methods in I<any> subclass. See
L<Term::VT102::ZeroBased> for an example of subclassing with
C<Class::Method::Modifiers>.
In short, C<Class::Method::Modifiers> solves the problem of making sure you
call C<< $self->SUPER::foo(@_) >>, and provides a cleaner interface for it.
As of version 1.00, C<Class::Method::Modifiers> is faster in some cases than
L<Moose>. See F<benchmark/method_modifiers.pl> in the L<Moose> distribution.
C<Class::Method::Modifiers> also provides an additional "modifier" type,
C<fresh>; see below.
=head1 MODIFIERS
All modifiers let you modify one or multiple methods at a time. The names of
multiple methods can be provided as a list or as an array-reference. Examples:
before 'method' => sub { ... };
before 'method1', 'method2' => sub { ... };
before [ 'method1', 'method2' ] => sub { ... };
=head2 before method(s) => sub { ... };
C<before> is called before the method it is modifying. Its return value is
totally ignored. It receives the same C<@_> as the method it is modifying
would have received. You can modify the C<@_> the original method will receive
by changing C<$_[0]> and friends (or by changing anything inside a reference).
This is a feature!
=head2 after method(s) => sub { ... };
C<after> is called after the method it is modifying. Its return value is
totally ignored. It receives the same C<@_> as the method it is modifying
received, mostly. The original method can modify C<@_> (such as by changing
C<$_[0]> or references) and C<after> will see the modified version. If you
don't like this behavior, specify both a C<before> and C<after>, and copy the
C<@_> during C<before> for C<after> to use.
=head2 around method(s) => sub { ... };
C<around> is called instead of the method it is modifying. The method you're
overriding is passed in as the first argument (called C<$orig> by convention).
Watch out for contextual return values of C<$orig>.
You can use C<around> to:
=over 4
=item Pass C<$orig> a different C<@_>
around 'method' => sub {
my $orig = shift;
my $self = shift;
$orig->($self, reverse @_);
};
=item Munge the return value of C<$orig>
around 'method' => sub {
my $orig = shift;
ucfirst $orig->(@_);
};
=item Avoid calling C<$orig> -- conditionally
around 'method' => sub {
my $orig = shift;
return $orig->(@_) if time() % 2;
return "no dice, captain";
};
=back
=head2 fresh method(s) => sub { ... };
(Available since version 2.00)
Unlike the other modifiers, this does not modify an existing method.
Ordinarily, C<fresh> merely installs the coderef as a method in the
appropriate class; but if the class hierarchy already contains a method of
the same name, an exception is thrown. The idea of this "modifier" is to
increase safety when subclassing. Suppose you're writing a subclass of a
class Some::Base, and adding a new method:
package My::Subclass;
use base 'Some::Base';
sub foo { ... }
If a later version of Some::Base also adds a new method named C<foo>, your
method will shadow that method. Alternatively, you can use C<fresh>
to install the additional method into your subclass:
package My::Subclass;
use base 'Some::Base';
use Class::Method::Modifiers 'fresh';
fresh 'foo' => sub { ... };
Now upgrading Some::Base to a version with a conflicting C<foo> method will
cause an exception to be thrown; seeing that error will give you the
opportunity to fix the problem (perhaps by picking a different method name
in your subclass, or similar).
Creating fresh methods with C<install_modifier> (see below) provides a way
to get similar safety benefits when adding local monkeypatches to existing
classes; see L<http://aaroncrane.co.uk/talks/monkey_patching_subclassing/>.
For API compatibility reasons, this function is exported only when you ask
for it specifically, or for C<:all>.
=head2 install_modifier $package, $type, @names, sub { ... }
C<install_modifier> is like C<before>, C<after>, C<around>, and C<fresh> but
it also lets you dynamically select the modifier type ('before', 'after',
'around', 'fresh')
and package that the method modifiers are installed into. This expert-level
function is exported only when you ask for it specifically, or for C<:all>.
=head1 NOTES
All three normal modifiers; C<before>, C<after>, and C<around>; are exported
into your namespace by default. You may C<use Class::Method::Modifiers ()> to
avoid modifying your namespace. I may steal more features from L<Moose>, namely
C<super>, C<override>, C<inner>, C<augment>, and whatever the L<Moose> folks
come up with next.
Note that the syntax and semantics for these modifiers is directly borrowed
from L<Moose> (the implementations, however, are not).
L<Class::Trigger> shares a few similarities with C<Class::Method::Modifiers>,
and they even have some overlap in purpose -- both can be used to implement
highly pluggable applications. The difference is that L<Class::Trigger>
provides a mechanism for easily letting parent classes to invoke hooks defined
by other code. C<Class::Method::Modifiers> provides a way of
overriding/augmenting methods safely, and the parent class need not know about
it.
=head2 :lvalue METHODS
When adding C<before> or C<after> modifiers, the wrapper method will be
an lvalue method if the wrapped sub is, and assigning to the method
will propagate to the wrapped method as expected. For C<around>
modifiers, it is the modifier sub that determines if the wrapper
method is an lvalue method.
=head1 CAVEATS
It is erroneous to modify a method that doesn't exist in your class's
inheritance hierarchy. If this occurs, an exception will be thrown when
the modifier is defined.
It doesn't yet play well with C<caller>. There are some C<TODO> tests for this.
Don't get your hopes up though!
Applying modifiers to array lvalue methods is not fully supported. Attempting
to assign to an array lvalue method that has an C<after> modifier applied will
result in an error. Array lvalue methods are not well supported by perl in
general, and should be avoided.
=head1 MAJOR VERSION CHANGES
=for stopwords reimplementation
This module was bumped to 1.00 following a complete reimplementation, to
indicate breaking backwards compatibility. The "guard" modifier was removed,
and the internals are completely different.
The new version is a few times faster with half the code. It's now even faster
than Moose.
Any code that just used modifiers should not change in behavior, except to
become more correct. And, of course, faster. :)
=head1 SEE ALSO
=over 4
=item *
L<Class::Method::Modifiers::Fast>
=item *
L<Moose>
=item *
L<Class::Trigger>
=item *
L<Class::MOP::Method::Wrapped>
=item *
L<MRO::Compat>
=item *
L<CLOS|https://en.wikipedia.org/wiki/Common_Lisp_Object_System>
=back
=head1 ACKNOWLEDGEMENTS
=for stopwords Stevan
Thanks to Stevan Little for L<Moose>, I would never have known about
method modifiers otherwise.
Thanks to Matt Trout and Stevan Little for their advice.
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Class-Method-Modifiers>
(or L<bug-Class-Method-Modifiers@rt.cpan.org|mailto:bug-Class-Method-Modifiers@rt.cpan.org>).
=head1 AUTHOR
Shawn M Moore <sartak@gmail.com>
=head1 CONTRIBUTORS
=for stopwords Karen Etheridge Shawn M Moore Graham Knop Aaron Crane Peter Rabbitson Justin Hunter David Steinbrunner gfx mannih
=over 4
=item *
Karen Etheridge <ether@cpan.org>
=item *
Shawn M Moore <code@sartak.org>
=item *
Graham Knop <haarg@haarg.org>
=item *
Aaron Crane <arc@cpan.org>
=item *
Peter Rabbitson <ribasushi@cpan.org>
=item *
Justin Hunter <justin.d.hunter@gmail.com>
=item *
David Steinbrunner <dsteinbrunner@pobox.com>
=item *
gfx <gfuji@cpan.org>
=item *
mannih <github@lxxi.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2007 by Shawn M Moore.
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

403
database/perl/vendor/lib/Class/Singleton.pm vendored Normal file
View File

@@ -0,0 +1,403 @@
#============================================================================
#
# Class::Singleton.pm
#
# Implementation of a "singleton" module which ensures that a class has
# only one instance and provides global access to it. For a description
# of the Singleton class, see "Design Patterns", Gamma et al, Addison-
# Wesley, 1995, ISBN 0-201-63361-2
#
# Written by Andy Wardley <abw@wardley.org>
#
# Copyright (C) 1998 Canon Research Centre Europe Ltd.
# Copyright (C) 1998-2008 Andy Wardley. All rights reserved.
# Copyright (C) 2014 Steve Hay. All rights reserved.
#
# This module is free software; you can redistribute it and/or modify it under
# the same terms as Perl itself, i.e. under the terms of either the GNU General
# Public License or the Artistic License, as specified in the F<LICENCE> file.
#
#============================================================================
package Class::Singleton;
use 5.008001;
use strict;
use warnings;
our $VERSION = 1.6;
my %_INSTANCES = ();
#========================================================================
#
# instance()
#
# Module constructor. Creates an Class::Singleton (or derived) instance
# if one doesn't already exist. The instance reference is stored in the
# %_INSTANCES hash of the Class::Singleton package. The impact of this is
# that you can create any number of classes derived from Class::Singleton
# and create a single instance of each one. If the instance reference
# was stored in a scalar $_INSTANCE variable, you could only instantiate
# *ONE* object of *ANY* class derived from Class::Singleton. The first
# time the instance is created, the _new_instance() constructor is called
# which simply returns a reference to a blessed hash. This can be
# overloaded for custom constructors. Any additional parameters passed to
# instance() are forwarded to _new_instance().
#
# Returns a reference to the existing, or a newly created Class::Singleton
# object. If the _new_instance() method returns an undefined value
# then the constructer is deemed to have failed.
#
#========================================================================
sub instance {
my $class = shift;
# already got an object
return $class if ref $class;
# we store the instance against the $class key of %_INSTANCES
my $instance = $_INSTANCES{$class};
unless(defined $instance) {
$_INSTANCES{$class} = $instance = $class->_new_instance(@_);
}
return $instance;
}
#=======================================================================
# has_instance()
#
# Public method to return the current instance if it exists.
#=======================================================================
sub has_instance {
my $class = shift;
$class = ref $class || $class;
return $_INSTANCES{$class};
}
#========================================================================
# _new_instance(...)
#
# Simple constructor which returns a hash reference blessed into the
# current class. May be overloaded to create non-hash objects or
# handle any specific initialisation required.
#========================================================================
sub _new_instance {
my $class = shift;
my %args = @_ && ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;
bless { %args }, $class;
}
#========================================================================
# END()
#
# END block to explicitly destroy all Class::Singleton objects since
# destruction order at program exit is not predictable. See CPAN RT
# bugs #23568 and #68526 for examples of what can go wrong without this.
#========================================================================
END {
# dereferences and causes orderly destruction of all instances
undef(%_INSTANCES);
}
1;
__END__
=head1 NAME
Class::Singleton - Implementation of a "Singleton" class
=head1 SYNOPSIS
use Class::Singleton;
my $one = Class::Singleton->instance(); # returns a new instance
my $two = Class::Singleton->instance(); # returns same instance
=head1 DESCRIPTION
This is the C<Class::Singleton> module. A Singleton describes an object class
that can have only one instance in any system. An example of a Singleton
might be a print spooler or system registry. This module implements a
Singleton class from which other classes can be derived. By itself, the
C<Class::Singleton> module does very little other than manage the instantiation
of a single object. In deriving a class from C<Class::Singleton>, your module
will inherit the Singleton instantiation method and can implement whatever
specific functionality is required.
For a description and discussion of the Singleton class, see
"Design Patterns", Gamma et al, Addison-Wesley, 1995, ISBN 0-201-63361-2.
=head2 Using the Class::Singleton Module
To import and use the C<Class::Singleton> module the following line should
appear in your Perl program:
use Class::Singleton;
The L<instance()> method is used to create a new C<Class::Singleton> instance,
or return a reference to an existing instance. Using this method, it is only
possible to have a single instance of the class in any system.
my $highlander = Class::Singleton->instance();
Assuming that no C<Class::Singleton> object currently exists, this first call
to L<instance()> will create a new C<Class::Singleton> and return a reference
to it. Future invocations of L<instance()> will return the same reference.
my $macleod = Class::Singleton->instance();
In the above example, both C<$highlander> and C<$macleod> contain the same
reference to a C<Class::Singleton> instance. There can be only one.
=head2 Deriving Singleton Classes
A module class may be derived from C<Class::Singleton> and will inherit the
L<instance()> method that correctly instantiates only one object.
package PrintSpooler;
use base 'Class::Singleton';
# derived class specific code
sub submit_job {
...
}
sub cancel_job {
...
}
The C<PrintSpooler> class defined above could be used as follows:
use PrintSpooler;
my $spooler = PrintSpooler->instance();
$spooler->submit_job(...);
The L<instance()> method calls the L<_new_instance()> constructor method the
first and only time a new instance is created. All parameters passed to the
L<instance()> method are forwarded to L<_new_instance()>. In the base class
the L<_new_instance()> method returns a blessed reference to a hash array
containing any arguments passed as either a hash reference or list of named
parameters.
package MyConfig;
use base 'Class::Singleton';
sub foo {
shift->{ foo };
}
sub bar {
shift->{ bar };
}
package main;
# either: hash reference of named parameters
my $config = MyConfig->instance({ foo => 10, bar => 20 });
# or: list of named parameters
my $config = MyConfig->instance( foo => 10, bar => 20 );
print $config->foo(); # 10
print $config->bar(); # 20
Derived classes may redefine the L<_new_instance()> method to provide more
specific object initialisation or change the underlying object type (to a list
reference, for example).
package MyApp::Database;
use base 'Class::Singleton';
use DBI;
# this only gets called the first time instance() is called
sub _new_instance {
my $class = shift;
my $self = bless { }, $class;
my $db = shift || "myappdb";
my $host = shift || "localhost";
$self->{ DB } = DBI->connect("DBI:mSQL:$db:$host")
|| die "Cannot connect to database: $DBI::errstr";
# any other initialisation...
return $self;
}
The above example might be used as follows:
use MyApp::Database;
# first use - database gets initialised
my $database = MyApp::Database->instance();
Some time later on in a module far, far away...
package MyApp::FooBar
use MyApp::Database;
# this FooBar object needs access to the database; the Singleton
# approach gives a nice wrapper around global variables.
sub new {
my $class = shift;
bless {
database => MyApp::Database->instance(),
}, $class;
}
The C<Class::Singleton> L<instance()> method uses a private hash to store
a reference to any existing instance of the object, keyed against the derived
class package name.
This allows different classes to be derived from C<Class::Singleton> that can
co-exist in the same system, while still allowing only one instance of any one
class to exist. For example, it would be possible to derive both
'C<PrintSpooler>' and 'C<MyApp::Database>' from C<Class::Singleton> and have a
single instance of I<each> in a system, rather than a single instance of
I<either>.
You can use the L<has_instance()> method to find out if a particular class
already has an instance defined. A reference to the instance is returned or
C<undef> if none is currently defined.
my $instance = MyApp::Database->has_instance()
|| warn "No instance is defined yet";
=head2 Methods
=over 4
=item instance()
This method is called to return a current object instance or create a new
one by calling L<_new_instance()>.
=item has_instance()
This method returns a reference to any existing instance or C<undef> if none
is defined.
my $testing = MySingleton1->has_instance()
|| warn "No instance defined for MySingleton1";
=item _new_instance()
This "private" method is called by L<instance()> to create a new object
instance if one doesn't already exist. It is not intended to be called
directly (although there's nothing to stop you from calling it if you're
really determined to do so).
It creates a blessed hash reference containing any arguments passed to the
method as either a hash reference or list of named parameters.
# either: hash reference of named parameters
my $example1 = MySingleton1->new({ pi => 3.14, e => 2.718 });
# or: list of named parameters
my $example2 = MySingleton2->new( pi => 3.14, e => 2.718 );
It is important to remember that the L<instance()> method will I<only> call
the I<_new_instance()> method once, so any arguments you pass may be silently
ignored if an instance already exists. You can use the L<has_instance()>
method to determine if an instance is already defined.
=back
=head1 EXPORTS
I<None>.
=head1 KNOWN BUGS
I<None>.
=head1 FEEDBACK
Patches, bug reports, suggestions or any other feedback is welcome.
Patches can be sent as GitHub pull requests at
L<https://github.com/steve-m-hay/Class-Singleton/pulls>.
Bug reports and suggestions can be made on the CPAN Request Tracker at
L<https://rt.cpan.org/Public/Bug/Report.html?Queue=Class-Singleton>.
Currently active requests on the CPAN Request Tracker can be viewed at
L<https://rt.cpan.org/Public/Dist/Display.html?Status=Active;Queue=Class-Singleton>.
Please test this distribution. See CPAN Testers Reports at
L<https://www.cpantesters.org/> for details of how to get involved.
Previous test results on CPAN Testers Reports can be viewed at
L<https://www.cpantesters.org/distro/C/Class-Singleton.html>.
Please rate this distribution on CPAN Ratings at
L<https://cpanratings.perl.org/rate/?distribution=Class-Singleton>.
=head1 AVAILABILITY
The latest version of this module is available from CPAN (see
L<perlmodlib/"CPAN"> for details) at
L<https://metacpan.org/release/Class-Singleton> or
L<https://www.cpan.org/authors/id/S/SH/SHAY/> or
L<https://www.cpan.org/modules/by-module/Class/>.
The latest source code is available from GitHub at
L<https://github.com/steve-m-hay/Class-Singleton>.
=head1 INSTALLATION
See the F<INSTALL> file.
=head1 AUTHOR
Andy Wardley E<lt>L<abw@wardley.org|mailto:abw@wardley.org>E<gt>
L<http://wardley.org/>.
Thanks to Andreas Koenig for providing some significant speedup patches and
other ideas.
Steve Hay E<lt>L<shay@cpan.org|mailto:shay@cpan.org>E<gt> is now maintaining
Class::Singleton as of version 1.5.
=head1 COPYRIGHT
Copyright (C) 1998 Canon Research Centre Europe Ltd.
Copyright (C) 1998-2008 Andy Wardley. All rights reserved.
Copyright (C) 2014, 2020 Steve Hay. All rights reserved.
=head1 LICENCE
This module is free software; you can redistribute it and/or modify it under the
same terms as Perl itself, i.e. under the terms of either the GNU General Public
License or the Artistic License, as specified in the F<LICENCE> file.
=head1 VERSION
Version 1.6
=head1 DATE
02 Dec 2020
=head1 HISTORY
See the F<Changes> file.
=cut

612
database/perl/vendor/lib/Class/Tiny.pm vendored Normal file
View File

@@ -0,0 +1,612 @@
use 5.006;
use strict;
no strict 'refs';
use warnings;
package Class::Tiny;
# ABSTRACT: Minimalist class construction
our $VERSION = '1.008';
use Carp ();
# load as .pm to hide from min version scanners
require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" ); ## no critic:
my %CLASS_ATTRIBUTES;
sub import {
my $class = shift;
my $pkg = caller;
$class->prepare_class($pkg);
$class->create_attributes( $pkg, @_ ) if @_;
}
sub prepare_class {
my ( $class, $pkg ) = @_;
@{"${pkg}::ISA"} = "Class::Tiny::Object" unless @{"${pkg}::ISA"};
}
# adapted from Object::Tiny and Object::Tiny::RW
sub create_attributes {
my ( $class, $pkg, @spec ) = @_;
my %defaults = map { ref $_ eq 'HASH' ? %$_ : ( $_ => undef ) } @spec;
my @attr = grep {
defined and !ref and /^[^\W\d]\w*$/s
or Carp::croak "Invalid accessor name '$_'"
} keys %defaults;
$CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr;
$class->_gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr;
Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
}
sub _gen_accessor {
my ( $class, $pkg, $name ) = @_;
my $outer_default = $CLASS_ATTRIBUTES{$pkg}{$name};
my $sub =
$class->__gen_sub_body( $name, defined($outer_default), ref($outer_default) );
# default = outer_default avoids "won't stay shared" bug
eval "package $pkg; my \$default=\$outer_default; $sub"; ## no critic
Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
}
# NOTE: overriding __gen_sub_body in a subclass of Class::Tiny is risky and
# could break if the internals of Class::Tiny need to change for any
# reason. That said, I currently see no reason why this would be likely to
# change.
#
# The generated sub body should assume that a '$default' variable will be
# in scope (i.e. when the sub is evaluated) with any default value/coderef
sub __gen_sub_body {
my ( $self, $name, $has_default, $default_type ) = @_;
if ( $has_default && $default_type eq 'CODE' ) {
return << "HERE";
sub $name {
return (
( \@_ == 1 && exists \$_[0]{$name} )
? ( \$_[0]{$name} )
: ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default->( \$_[0] ) )
);
}
HERE
}
elsif ($has_default) {
return << "HERE";
sub $name {
return (
( \@_ == 1 && exists \$_[0]{$name} )
? ( \$_[0]{$name} )
: ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default )
);
}
HERE
}
else {
return << "HERE";
sub $name {
return \@_ == 1 ? \$_[0]{$name} : ( \$_[0]{$name} = \$_[1] );
}
HERE
}
}
sub get_all_attributes_for {
my ( $class, $pkg ) = @_;
my %attr =
map { $_ => undef }
map { keys %{ $CLASS_ATTRIBUTES{$_} || {} } } @{ mro::get_linear_isa($pkg) };
return keys %attr;
}
sub get_all_attribute_defaults_for {
my ( $class, $pkg ) = @_;
my $defaults = {};
for my $p ( reverse @{ mro::get_linear_isa($pkg) } ) {
while ( my ( $k, $v ) = each %{ $CLASS_ATTRIBUTES{$p} || {} } ) {
$defaults->{$k} = $v;
}
}
return $defaults;
}
package Class::Tiny::Object;
# ABSTRACT: Base class for classes built with Class::Tiny
our $VERSION = '1.008';
my ( %HAS_BUILDARGS, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE );
my $_PRECACHE = sub {
no warnings 'once'; # needed to avoid downstream warnings
my ($class) = @_;
my $linear_isa =
@{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object"
? [$class]
: mro::get_linear_isa($class);
$DEMOLISH_CACHE{$class} = [
map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
map { "$_\::DEMOLISH" } @$linear_isa
];
$BUILD_CACHE{$class} = [
map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
map { "$_\::BUILD" } reverse @$linear_isa
];
$HAS_BUILDARGS{$class} = $class->can("BUILDARGS");
return $ATTR_CACHE{$class} =
{ map { $_ => 1 } Class::Tiny->get_all_attributes_for($class) };
};
sub new {
my $class = shift;
my $valid_attrs = $ATTR_CACHE{$class} || $_PRECACHE->($class);
# handle hash ref or key/value arguments
my $args;
if ( $HAS_BUILDARGS{$class} ) {
$args = $class->BUILDARGS(@_);
}
else {
if ( @_ == 1 && ref $_[0] ) {
my %copy = eval { %{ $_[0] } }; # try shallow copy
Carp::croak("Argument to $class->new() could not be dereferenced as a hash") if $@;
$args = \%copy;
}
elsif ( @_ % 2 == 0 ) {
$args = {@_};
}
else {
Carp::croak("$class->new() got an odd number of elements");
}
}
# create object and invoke BUILD (unless we were given __no_BUILD__)
my $self =
bless { map { $_ => $args->{$_} } grep { exists $valid_attrs->{$_} } keys %$args },
$class;
$self->BUILDALL($args) if !delete $args->{__no_BUILD__} && @{ $BUILD_CACHE{$class} };
return $self;
}
sub BUILDALL { $_->(@_) for @{ $BUILD_CACHE{ ref $_[0] } } }
# Adapted from Moo and its dependencies
require Devel::GlobalDestruction unless defined ${^GLOBAL_PHASE};
sub DESTROY {
my $self = shift;
my $class = ref $self;
my $in_global_destruction =
defined ${^GLOBAL_PHASE}
? ${^GLOBAL_PHASE} eq 'DESTRUCT'
: Devel::GlobalDestruction::in_global_destruction();
for my $demolisher ( @{ $DEMOLISH_CACHE{$class} } ) {
my $e = do {
local ( $?, $@ );
eval { $demolisher->( $self, $in_global_destruction ) };
$@;
};
no warnings 'misc'; # avoid (in cleanup) warnings
die $e if $e; # rethrow
}
}
1;
# vim: ts=4 sts=4 sw=4 et:
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::Tiny - Minimalist class construction
=head1 VERSION
version 1.008
=head1 SYNOPSIS
In F<Person.pm>:
package Person;
use Class::Tiny qw( name );
1;
In F<Employee.pm>:
package Employee;
use parent 'Person';
use Class::Tiny qw( ssn ), {
timestamp => sub { time } # attribute with default
};
1;
In F<example.pl>:
use Employee;
my $obj = Employee->new( name => "Larry", ssn => "111-22-3333" );
# unknown attributes are ignored
my $obj = Employee->new( name => "Larry", OS => "Linux" );
# $obj->{OS} does not exist
=head1 DESCRIPTION
This module offers a minimalist class construction kit in around 120 lines of
code. Here is a list of features:
=over 4
=item *
defines attributes via import arguments
=item *
generates read-write accessors
=item *
supports lazy attribute defaults
=item *
supports custom accessors
=item *
superclass provides a standard C<new> constructor
=item *
C<new> takes a hash reference or list of key/value pairs
=item *
C<new> supports providing C<BUILDARGS> to customize constructor options
=item *
C<new> calls C<BUILD> for each class from parent to child
=item *
superclass provides a C<DESTROY> method
=item *
C<DESTROY> calls C<DEMOLISH> for each class from child to parent
=back
Multiple-inheritance is possible, with superclass order determined via
L<mro::get_linear_isa|mro/Functions>.
It uses no non-core modules for any recent Perl. On Perls older than v5.10 it
requires L<MRO::Compat>. On Perls older than v5.14, it requires
L<Devel::GlobalDestruction>.
=head1 USAGE
=head2 Defining attributes
Define attributes as a list of import arguments:
package Foo::Bar;
use Class::Tiny qw(
name
id
height
weight
);
For each attribute, a read-write accessor is created unless a subroutine of that
name already exists:
$obj->name; # getter
$obj->name( "John Doe" ); # setter
Attribute names must be valid subroutine identifiers or an exception will
be thrown.
You can specify lazy defaults by defining attributes with a hash reference.
Keys define attribute names and values are constants or code references that
will be evaluated when the attribute is first accessed if no value has been
set. The object is passed as an argument to a code reference.
package Foo::WithDefaults;
use Class::Tiny qw/name id/, {
title => 'Peon',
skills => sub { [] },
hire_date => sub { $_[0]->_build_hire_date },
};
When subclassing, if multiple accessors of the same name exist in different
classes, any default (or lack of default) is determined by standard
method resolution order.
To make your own custom accessors, just pre-declare the method name before
loading Class::Tiny:
package Foo::Bar;
use subs 'id';
use Class::Tiny qw( name id );
sub id { ... }
Even if you pre-declare a method name, you must include it in the attribute
list for Class::Tiny to register it as a valid attribute.
If you set a default for a custom accessor, your accessor will need to retrieve
the default and do something with it:
package Foo::Bar;
use subs 'id';
use Class::Tiny qw( name ), { id => sub { int(rand(2*31)) } };
sub id {
my $self = shift;
if (@_) {
return $self->{id} = shift;
}
elsif ( exists $self->{id} ) {
return $self->{id};
}
else {
my $defaults =
Class::Tiny->get_all_attribute_defaults_for( ref $self );
return $self->{id} = $defaults->{id}->();
}
}
=head2 Class::Tiny::Object is your base class
If your class B<does not> already inherit from some class, then
Class::Tiny::Object will be added to your C<@ISA> to provide C<new> and
C<DESTROY>.
If your class B<does> inherit from something, then no additional inheritance is
set up. If the parent subclasses Class::Tiny::Object, then all is well. If
not, then you'll get accessors set up but no constructor or destructor. Don't
do that unless you really have a special need for it.
Define subclasses as normal. It's best to define them with L<base>, L<parent>
or L<superclass> before defining attributes with Class::Tiny so the C<@ISA>
array is already populated at compile-time:
package Foo::Bar::More;
use parent 'Foo::Bar';
use Class::Tiny qw( shoe_size );
=head2 Object construction
If your class inherits from Class::Tiny::Object (as it should if you followed
the advice above), it provides the C<new> constructor for you.
Objects can be created with attributes given as a hash reference or as a list
of key/value pairs:
$obj = Foo::Bar->new( name => "David" );
$obj = Foo::Bar->new( { name => "David" } );
If a reference is passed as a single argument, it must be able to be
dereferenced as a hash or an exception is thrown.
Unknown attributes in the constructor arguments will be ignored. Prior to
version 1.000, unknown attributes were an error, but this made it harder for
people to cleanly subclass Class::Tiny classes so this feature was removed.
You can define a C<BUILDARGS> method to change how arguments to new are
handled. It will receive the constructor arguments as they were provided and
must return a hash reference of key/value pairs (or else throw an
exception).
sub BUILDARGS {
my $class = shift;
my $name = shift || "John Doe";
return { name => $name };
};
Foo::Bar->new( "David" );
Foo::Bar->new(); # "John Doe"
Unknown attributes returned from C<BUILDARGS> will be ignored.
=head2 BUILD
If your class or any superclass defines a C<BUILD> method, it will be called
by the constructor from the furthest parent class down to the child class after
the object has been created.
It is passed the constructor arguments as a hash reference. The return value
is ignored. Use C<BUILD> for validation, checking required attributes or
setting default values that depend on other attributes.
sub BUILD {
my ($self, $args) = @_;
for my $req ( qw/name age/ ) {
croak "$req attribute required" unless defined $self->$req;
}
croak "Age must be non-negative" if $self->age < 0;
$self->msg( "Hello " . $self->name );
}
The argument reference is a copy, so deleting elements won't affect data in the
original (but changes will be passed to other BUILD methods in C<@ISA>).
=head2 DEMOLISH
Class::Tiny provides a C<DESTROY> method. If your class or any superclass
defines a C<DEMOLISH> method, they will be called from the child class to the
furthest parent class during object destruction. It is provided a single
boolean argument indicating whether Perl is in global destruction. Return
values are ignored. Errors are caught and rethrown.
sub DEMOLISH {
my ($self, $global_destruct) = @_;
$self->cleanup();
}
=head2 Introspection and internals
You can retrieve an unsorted list of valid attributes known to Class::Tiny
for a class and its superclasses with the C<get_all_attributes_for> class
method.
my @attrs = Class::Tiny->get_all_attributes_for("Employee");
# returns qw/name ssn timestamp/
Likewise, a hash reference of all valid attributes and default values (or code
references) may be retrieved with the C<get_all_attribute_defaults_for> class
method. Any attributes without a default will be C<undef>.
my $def = Class::Tiny->get_all_attribute_defaults_for("Employee");
# returns {
# name => undef,
# ssn => undef
# timestamp => $coderef
# }
The C<import> method uses two class methods, C<prepare_class> and
C<create_attributes> to set up the C<@ISA> array and attributes. Anyone
attempting to extend Class::Tiny itself should use these instead of mocking up
a call to C<import>.
When the first object is created, linearized C<@ISA>, the valid attribute list
and various subroutine references are cached for speed. Ensure that all
inheritance and methods are in place before creating objects. (You don't want
to be changing that once you create objects anyway, right?)
=for Pod::Coverage new get_all_attributes_for get_all_attribute_defaults_for
prepare_class create_attributes
=head1 RATIONALE
=head2 Why this instead of Object::Tiny or Class::Accessor or something else?
I wanted something so simple that it could potentially be used by core Perl
modules I help maintain (or hope to write), most of which either use
L<Class::Struct> or roll-their-own OO framework each time.
L<Object::Tiny> and L<Object::Tiny::RW> were close to what I wanted, but
lacking some features I deemed necessary, and their maintainers have an even
more strict philosophy against feature creep than I have.
I also considered L<Class::Accessor>, which has been around a long time and is
heavily used, but it, too, lacked features I wanted and did things in ways I
considered poor design.
I looked for something else on CPAN, but after checking a dozen class creators
I realized I could implement exactly what I wanted faster than I could search
CPAN for something merely sufficient.
In general, compared to most things on CPAN (other than Object::Tiny),
Class::Tiny is smaller in implementation and simpler in API.
Specifically, here is how Class::Tiny ("C::T") compares to Object::Tiny
("O::T") and Class::Accessor ("C::A"):
FEATURE C::T O::T C::A
--------------------------------------------------------------
attributes defined via import yes yes no
read/write accessors yes no yes
lazy attribute defaults yes no no
provides new yes yes yes
provides DESTROY yes no no
new takes either hashref or list yes no (list) no (hash)
Moo(se)-like BUILD/DEMOLISH yes no no
Moo(se)-like BUILDARGS yes no no
no extraneous methods via @ISA yes yes no
=head2 Why this instead of Moose or Moo?
L<Moose> and L<Moo> are both excellent OO frameworks. Moose offers a powerful
meta-object protocol (MOP), but is slow to start up and has about 30 non-core
dependencies including XS modules. Moo is faster to start up and has about 10
pure Perl dependencies but provides no true MOP, relying instead on its ability
to transparently upgrade Moo to Moose when Moose's full feature set is
required.
By contrast, Class::Tiny has no MOP and has B<zero> non-core dependencies for
Perls in the L<support window|perlpolicy>. It has far less code, less
complexity and no learning curve. If you don't need or can't afford what Moo or
Moose offer, this is intended to be a reasonable fallback.
That said, Class::Tiny offers Moose-like conventions for things like C<BUILD>
and C<DEMOLISH> for some minimal interoperability and an easier upgrade path.
=head1 AUTHOR
David Golden <dagolden@cpan.org>
=head1 CONTRIBUTORS
=for stopwords Dagfinn Ilmari Mannsåker David Golden Gelu Lupas Karen Etheridge Matt S Trout Olivier Mengué Toby Inkster
=over 4
=item *
Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
=item *
David Golden <xdg@xdg.me>
=item *
Gelu Lupas <gelu@devnull.ro>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Matt S Trout <mstrout@cpan.org>
=item *
Olivier Mengué <dolmen@cpan.org>
=item *
Toby Inkster <tobyink@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2013 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut