mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-09-11 21:51:21 +00:00
Merged use-lmo.
This commit renames our fork of Mo to Lmo, since the two have diverged a huge deal. The merged branch streamlined Lmo a great deal as well, for maintainability.
This commit is contained in:
Brian Fraser
@@ -14,7 +14,11 @@ use warnings FATAL => 'all';
|
||||
BEGIN {
|
||||
$INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
|
||||
Percona::Toolkit
|
||||
Mo
|
||||
Lmo::Utils
|
||||
Lmo::Meta
|
||||
Lmo::Object
|
||||
Lmo::Types
|
||||
Lmo
|
||||
OptionParser
|
||||
DSNParser
|
||||
Cxn
|
||||
@@ -48,18 +52,24 @@ our $VERSION = '2.1.8';
|
||||
# ###########################################################################
|
||||
|
||||
# ###########################################################################
|
||||
# Mo package
|
||||
# Lmo::Utils package
|
||||
# This package is a copy without comments from the original. The original
|
||||
# with comments and its test file can be found in the Bazaar repository at,
|
||||
# lib/Mo.pm
|
||||
# t/lib/Mo.t
|
||||
# lib/Lmo/Utils.pm
|
||||
# t/lib/Lmo/Utils.t
|
||||
# See https://launchpad.net/percona-toolkit for more information.
|
||||
# ###########################################################################
|
||||
{
|
||||
package Lmo::Utils;
|
||||
use strict;
|
||||
use warnings qw( FATAL all );
|
||||
require Exporter;
|
||||
our (@ISA, @EXPORT, @EXPORT_OK);
|
||||
|
||||
BEGIN {
|
||||
$INC{"Mo.pm"} = __FILE__;
|
||||
package Mo;
|
||||
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = @EXPORT_OK = qw(_install_coderef _unimport_coderefs _glob_for _stash_for);
|
||||
}
|
||||
|
||||
{
|
||||
no strict 'refs';
|
||||
@@ -72,6 +82,194 @@ our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
|
||||
}
|
||||
}
|
||||
|
||||
sub _install_coderef {
|
||||
my ($to, $code) = @_;
|
||||
|
||||
return *{ _glob_for $to } = $code;
|
||||
}
|
||||
|
||||
sub _unimport_coderefs {
|
||||
my ($target, @names) = @_;
|
||||
return unless @names;
|
||||
my $stash = _stash_for($target);
|
||||
foreach my $name (@names) {
|
||||
if ($stash->{$name} and defined(&{$stash->{$name}})) {
|
||||
delete $stash->{$name};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
# End Lmo::Utils package
|
||||
# ###########################################################################
|
||||
|
||||
# ###########################################################################
|
||||
# Lmo::Meta package
|
||||
# This package is a copy without comments from the original. The original
|
||||
# with comments and its test file can be found in the Bazaar repository at,
|
||||
# lib/Lmo/Meta.pm
|
||||
# t/lib/Lmo/Meta.t
|
||||
# See https://launchpad.net/percona-toolkit for more information.
|
||||
# ###########################################################################
|
||||
{
|
||||
package Lmo::Meta;
|
||||
use strict;
|
||||
use warnings qw( FATAL all );
|
||||
|
||||
my %metadata_for;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
return bless { @_ }, $class
|
||||
}
|
||||
|
||||
sub metadata_for {
|
||||
my $self = shift;
|
||||
my ($class) = @_;
|
||||
|
||||
return $metadata_for{$class} ||= {};
|
||||
}
|
||||
|
||||
sub class { shift->{class} }
|
||||
|
||||
sub attributes {
|
||||
my $self = shift;
|
||||
return keys %{$self->metadata_for($self->class)}
|
||||
}
|
||||
|
||||
sub attributes_for_new {
|
||||
my $self = shift;
|
||||
my @attributes;
|
||||
|
||||
my $class_metadata = $self->metadata_for($self->class);
|
||||
while ( my ($attr, $meta) = each %$class_metadata ) {
|
||||
if ( exists $meta->{init_arg} ) {
|
||||
push @attributes, $meta->{init_arg}
|
||||
if defined $meta->{init_arg};
|
||||
}
|
||||
else {
|
||||
push @attributes, $attr;
|
||||
}
|
||||
}
|
||||
return @attributes;
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
# End Lmo::Meta package
|
||||
# ###########################################################################
|
||||
|
||||
# ###########################################################################
|
||||
# Lmo::Object package
|
||||
# This package is a copy without comments from the original. The original
|
||||
# with comments and its test file can be found in the Bazaar repository at,
|
||||
# lib/Lmo/Object.pm
|
||||
# t/lib/Lmo/Object.t
|
||||
# See https://launchpad.net/percona-toolkit for more information.
|
||||
# ###########################################################################
|
||||
{
|
||||
package Lmo::Object;
|
||||
|
||||
use strict;
|
||||
use warnings qw( FATAL all );
|
||||
|
||||
use Carp ();
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use Lmo::Meta;
|
||||
use Lmo::Utils qw(_glob_for);
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $args = $class->BUILDARGS(@_);
|
||||
|
||||
my $class_metadata = Lmo::Meta->metadata_for($class);
|
||||
|
||||
my @args_to_delete;
|
||||
while ( my ($attr, $meta) = each %$class_metadata ) {
|
||||
next unless exists $meta->{init_arg};
|
||||
my $init_arg = $meta->{init_arg};
|
||||
|
||||
if ( defined $init_arg ) {
|
||||
$args->{$attr} = delete $args->{$init_arg};
|
||||
}
|
||||
else {
|
||||
push @args_to_delete, $attr;
|
||||
}
|
||||
}
|
||||
|
||||
delete $args->{$_} for @args_to_delete;
|
||||
|
||||
for my $attribute ( keys %$args ) {
|
||||
if ( my $coerce = $class_metadata->{$attribute}{coerce} ) {
|
||||
$args->{$attribute} = $coerce->($args->{$attribute});
|
||||
}
|
||||
if ( my $isa_check = $class_metadata->{$attribute}{isa} ) {
|
||||
my ($check_name, $check_sub) = @$isa_check;
|
||||
$check_sub->($args->{$attribute});
|
||||
}
|
||||
}
|
||||
|
||||
while ( my ($attribute, $meta) = each %$class_metadata ) {
|
||||
next unless $meta->{required};
|
||||
Carp::confess("Attribute ($attribute) is required for $class")
|
||||
if ! exists $args->{$attribute}
|
||||
}
|
||||
|
||||
my $self = bless $args, $class;
|
||||
|
||||
my @build_subs;
|
||||
my $linearized_isa = mro::get_linear_isa($class);
|
||||
|
||||
for my $isa_class ( @$linearized_isa ) {
|
||||
unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE};
|
||||
}
|
||||
my @args = %$args;
|
||||
for my $sub (grep { defined($_) && exists &$_ } @build_subs) {
|
||||
$sub->( $self, @args);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub BUILDARGS {
|
||||
shift; # No need for the classname
|
||||
if ( @_ == 1 && ref($_[0]) ) {
|
||||
Carp::confess("Single parameters to new() must be a HASH ref, not $_[0]")
|
||||
unless ref($_[0]) eq ref({});
|
||||
return {%{$_[0]}} # We want a new reference, always
|
||||
}
|
||||
else {
|
||||
return { @_ };
|
||||
}
|
||||
}
|
||||
|
||||
sub meta {
|
||||
my $class = shift;
|
||||
$class = Scalar::Util::blessed($class) || $class;
|
||||
return Lmo::Meta->new(class => $class);
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
# End Lmo::Object package
|
||||
# ###########################################################################
|
||||
|
||||
# ###########################################################################
|
||||
# Lmo::Types package
|
||||
# This package is a copy without comments from the original. The original
|
||||
# with comments and its test file can be found in the Bazaar repository at,
|
||||
# lib/Lmo/Types.pm
|
||||
# t/lib/Lmo/Types.t
|
||||
# See https://launchpad.net/percona-toolkit for more information.
|
||||
# ###########################################################################
|
||||
{
|
||||
package Lmo::Types;
|
||||
|
||||
use strict;
|
||||
use warnings qw( FATAL all );
|
||||
|
||||
@@ -93,243 +291,277 @@ our %TYPES = (
|
||||
} qw(Array Code Hash Regexp Glob Scalar)
|
||||
);
|
||||
|
||||
our %metadata_for;
|
||||
{
|
||||
package Mo::Object;
|
||||
sub check_type_constaints {
|
||||
my ($attribute, $type_check, $check_name, $val) = @_;
|
||||
( ref($type_check) eq 'CODE'
|
||||
? $type_check->($val)
|
||||
: (ref $val eq $type_check
|
||||
|| ($val && $val eq $type_check)
|
||||
|| (exists $TYPES{$type_check} && $TYPES{$type_check}->($val)))
|
||||
)
|
||||
|| Carp::confess(
|
||||
qq<Attribute ($attribute) does not pass the type constraint because: >
|
||||
. qq<Validation failed for '$check_name' with value >
|
||||
. (defined $val ? Lmo::Dumper($val) : 'undef') )
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $args = $class->BUILDARGS(@_);
|
||||
sub _nested_constraints {
|
||||
my ($attribute, $aggregate_type, $type) = @_;
|
||||
|
||||
my @args_to_delete;
|
||||
while ( my ($attr, $meta) = each %{$metadata_for{$class}} ) {
|
||||
next unless exists $meta->{init_arg};
|
||||
my $init_arg = $meta->{init_arg};
|
||||
|
||||
if ( defined $init_arg ) {
|
||||
$args->{$attr} = delete $args->{$init_arg};
|
||||
}
|
||||
else {
|
||||
push @args_to_delete, $attr;
|
||||
}
|
||||
}
|
||||
|
||||
delete $args->{$_} for @args_to_delete;
|
||||
|
||||
for my $attribute ( keys %$args ) {
|
||||
if ( my $coerce = $metadata_for{$class}{$attribute}{coerce} ) {
|
||||
$args->{$attribute} = $coerce->($args->{$attribute});
|
||||
}
|
||||
if ( my $I = $metadata_for{$class}{$attribute}{isa} ) {
|
||||
( (my $I_name), $I ) = @{$I};
|
||||
Mo::_check_type_constaints($attribute, $I, $I_name, $args->{$attribute});
|
||||
}
|
||||
}
|
||||
|
||||
while ( my ($attribute, $meta) = each %{$metadata_for{$class}} ) {
|
||||
next unless $meta->{required};
|
||||
Carp::confess("Attribute ($attribute) is required for $class")
|
||||
if ! exists $args->{$attribute}
|
||||
}
|
||||
|
||||
@_ = %$args;
|
||||
my $self = bless $args, $class;
|
||||
|
||||
my @build_subs;
|
||||
my $linearized_isa = mro::get_linear_isa($class);
|
||||
|
||||
for my $isa_class ( @$linearized_isa ) {
|
||||
unshift @build_subs, *{ Mo::_glob_for "${isa_class}::BUILD" }{CODE};
|
||||
}
|
||||
exists &$_ && $_->( $self, @_ ) for grep { defined } @build_subs;
|
||||
return $self;
|
||||
my $inner_types;
|
||||
if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
|
||||
$inner_types = _nested_constraints($1, $2);
|
||||
}
|
||||
else {
|
||||
$inner_types = $TYPES{$type};
|
||||
}
|
||||
|
||||
sub BUILDARGS {
|
||||
shift;
|
||||
my $ref;
|
||||
if ( @_ == 1 && ref($_[0]) ) {
|
||||
Carp::confess("Single parameters to new() must be a HASH ref")
|
||||
unless ref($_[0]) eq ref({});
|
||||
$ref = {%{$_[0]}} # We want a new reference, always
|
||||
if ( $aggregate_type eq 'ArrayRef' ) {
|
||||
return sub {
|
||||
my ($val) = @_;
|
||||
return unless ref($val) eq ref([]);
|
||||
|
||||
if ($inner_types) {
|
||||
for my $value ( @{$val} ) {
|
||||
return unless $inner_types->($value)
|
||||
}
|
||||
}
|
||||
else {
|
||||
for my $value ( @{$val} ) {
|
||||
return unless $value && ($value eq $type
|
||||
|| (Scalar::Util::blessed($value) && $value->isa($type)));
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
};
|
||||
}
|
||||
elsif ( $aggregate_type eq 'Maybe' ) {
|
||||
return sub {
|
||||
my ($value) = @_;
|
||||
return 1 if ! defined($value);
|
||||
if ($inner_types) {
|
||||
return unless $inner_types->($value)
|
||||
}
|
||||
else {
|
||||
return unless $value eq $type
|
||||
|| (Scalar::Util::blessed($value) && $value->isa($type));
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
$ref = { @_ };
|
||||
}
|
||||
return $ref;
|
||||
}
|
||||
else {
|
||||
Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
# End Lmo::Types package
|
||||
# ###########################################################################
|
||||
|
||||
# ###########################################################################
|
||||
# Lmo package
|
||||
# This package is a copy without comments from the original. The original
|
||||
# with comments and its test file can be found in the Bazaar repository at,
|
||||
# lib/Lmo.pm
|
||||
# t/lib/Lmo.t
|
||||
# See https://launchpad.net/percona-toolkit for more information.
|
||||
# ###########################################################################
|
||||
{
|
||||
BEGIN {
|
||||
$INC{"Lmo.pm"} = __FILE__;
|
||||
package Lmo;
|
||||
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
|
||||
|
||||
|
||||
use strict;
|
||||
use warnings qw( FATAL all );
|
||||
|
||||
use Carp ();
|
||||
use Scalar::Util qw(looks_like_number blessed);
|
||||
|
||||
use Lmo::Meta;
|
||||
use Lmo::Object;
|
||||
use Lmo::Types;
|
||||
|
||||
use Lmo::Utils;
|
||||
|
||||
my %export_for;
|
||||
%Mo::Internal::Keyword = map { $_ => 1 } qw(has extends override);
|
||||
sub import {
|
||||
warnings->import(qw(FATAL all));
|
||||
strict->import();
|
||||
|
||||
sub Mo::import {
|
||||
warnings->import(qw(FATAL all));
|
||||
strict->import();
|
||||
|
||||
my $caller = scalar caller(); # Caller's package
|
||||
my $caller_pkg = $caller . "::"; # Caller's package with :: at the end
|
||||
my (%exports, %options);
|
||||
my $caller = scalar caller(); # Caller's package
|
||||
my %exports = (
|
||||
extends => \&extends,
|
||||
has => \&has,
|
||||
with => \&with,
|
||||
override => \&override,
|
||||
confess => \&Carp::confess,
|
||||
);
|
||||
|
||||
my (undef, @features) = @_;
|
||||
my %ignore = ( map { $_ => 1 } qw( is isa init_arg builder buildargs clearer predicate build handles default required ) );
|
||||
for my $feature (grep { !$ignore{$_} } @features) {
|
||||
{ local $@; require "Mo/$feature.pm"; }
|
||||
{
|
||||
no strict 'refs';
|
||||
&{"Mo::${feature}::e"}(
|
||||
$caller_pkg,
|
||||
\%exports,
|
||||
\%options,
|
||||
\@_
|
||||
);
|
||||
$export_for{$caller} = \%exports;
|
||||
|
||||
for my $keyword ( keys %exports ) {
|
||||
_install_coderef "${caller}::$keyword" => $exports{$keyword};
|
||||
}
|
||||
|
||||
if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
|
||||
@_ = "Lmo::Object";
|
||||
goto *{ _glob_for "${caller}::extends" }{CODE};
|
||||
}
|
||||
}
|
||||
|
||||
sub extends {
|
||||
my $caller = scalar caller();
|
||||
for my $class ( @_ ) {
|
||||
_load_module($class);
|
||||
}
|
||||
_set_package_isa($caller, @_);
|
||||
_set_inherited_metadata($caller);
|
||||
}
|
||||
|
||||
sub _load_module {
|
||||
my ($class) = @_;
|
||||
|
||||
(my $file = $class) =~ s{::|'}{/}g;
|
||||
$file .= '.pm';
|
||||
{ local $@; eval { require "$file" } } # or warn $@;
|
||||
return;
|
||||
}
|
||||
|
||||
sub with {
|
||||
my $package = scalar caller();
|
||||
require Role::Tiny;
|
||||
for my $role ( @_ ) {
|
||||
_load_module($role);
|
||||
_role_attribute_metadata($package, $role);
|
||||
}
|
||||
Role::Tiny->apply_roles_to_package($package, @_);
|
||||
}
|
||||
|
||||
sub _role_attribute_metadata {
|
||||
my ($package, $role) = @_;
|
||||
|
||||
my $package_meta = Lmo::Meta->metadata_for($package);
|
||||
my $role_meta = Lmo::Meta->metadata_for($role);
|
||||
|
||||
%$package_meta = (%$role_meta, %$package_meta);
|
||||
}
|
||||
|
||||
sub has {
|
||||
my $names = shift;
|
||||
my $caller = scalar caller();
|
||||
|
||||
my $class_metadata = Lmo::Meta->metadata_for($caller);
|
||||
|
||||
for my $attribute ( ref $names ? @$names : $names ) {
|
||||
my %args = @_;
|
||||
my $method = ($args{is} || '') eq 'ro'
|
||||
? sub {
|
||||
Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
|
||||
if $#_;
|
||||
return $_[0]{$attribute};
|
||||
}
|
||||
: sub {
|
||||
return $#_
|
||||
? $_[0]{$attribute} = $_[1]
|
||||
: $_[0]{$attribute};
|
||||
};
|
||||
|
||||
$class_metadata->{$attribute} = ();
|
||||
|
||||
if ( my $type_check = $args{isa} ) {
|
||||
my $check_name = $type_check;
|
||||
|
||||
if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
|
||||
$type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type);
|
||||
}
|
||||
|
||||
my $check_sub = sub {
|
||||
my ($new_val) = @_;
|
||||
Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
|
||||
};
|
||||
|
||||
$class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
|
||||
my $orig_method = $method;
|
||||
$method = sub {
|
||||
$check_sub->($_[1]) if $#_;
|
||||
goto &$orig_method;
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
return if $exports{M};
|
||||
if ( my $builder = $args{builder} ) {
|
||||
my $original_method = $method;
|
||||
$method = sub {
|
||||
$#_
|
||||
? goto &$original_method
|
||||
: ! exists $_[0]{$attribute}
|
||||
? $_[0]{$attribute} = $_[0]->$builder
|
||||
: goto &$original_method
|
||||
};
|
||||
}
|
||||
|
||||
%exports = (
|
||||
extends => sub {
|
||||
for my $class ( map { "$_" } @_ ) {
|
||||
$class =~ s{::|'}{/}g;
|
||||
{ local $@; eval { require "$class.pm" } } # or warn $@;
|
||||
if ( my $code = $args{default} ) {
|
||||
Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
|
||||
unless ref($code) eq 'CODE';
|
||||
my $original_method = $method;
|
||||
$method = sub {
|
||||
$#_
|
||||
? goto &$original_method
|
||||
: ! exists $_[0]{$attribute}
|
||||
? $_[0]{$attribute} = $_[0]->$code
|
||||
: goto &$original_method
|
||||
};
|
||||
}
|
||||
|
||||
if ( my $role = $args{does} ) {
|
||||
my $original_method = $method;
|
||||
$method = sub {
|
||||
if ( $#_ ) {
|
||||
Carp::confess(qq<Attribute ($attribute) doesn't consume a '$role' role">)
|
||||
unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
|
||||
}
|
||||
_set_package_isa($caller, @_);
|
||||
_set_inherited_metadata($caller);
|
||||
},
|
||||
override => \&override,
|
||||
has => sub {
|
||||
my $names = shift;
|
||||
for my $attribute ( ref $names ? @$names : $names ) {
|
||||
my %args = @_;
|
||||
my $method = ($args{is} || '') eq 'ro'
|
||||
? sub {
|
||||
Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller_pkg}${attribute}")
|
||||
if $#_;
|
||||
return $_[0]{$attribute};
|
||||
}
|
||||
: sub {
|
||||
return $#_
|
||||
? $_[0]{$attribute} = $_[1]
|
||||
: $_[0]{$attribute};
|
||||
};
|
||||
goto &$original_method
|
||||
};
|
||||
}
|
||||
|
||||
$metadata_for{$caller}{$attribute} = ();
|
||||
|
||||
if ( my $I = $args{isa} ) {
|
||||
my $orig_I = $I;
|
||||
my $type;
|
||||
if ( $I =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
|
||||
$I = _nested_constraints($attribute, $1, $2);
|
||||
}
|
||||
$metadata_for{$caller}{$attribute}{isa} = [$orig_I, $I];
|
||||
my $orig_method = $method;
|
||||
$method = sub {
|
||||
if ( $#_ ) {
|
||||
Mo::_check_type_constaints($attribute, $I, $orig_I, $_[1]);
|
||||
}
|
||||
goto &$orig_method;
|
||||
};
|
||||
}
|
||||
|
||||
if ( my $builder = $args{builder} ) {
|
||||
my $original_method = $method;
|
||||
$method = sub {
|
||||
$#_
|
||||
? goto &$original_method
|
||||
: ! exists $_[0]{$attribute}
|
||||
? $_[0]{$attribute} = $_[0]->$builder
|
||||
: goto &$original_method
|
||||
};
|
||||
}
|
||||
|
||||
if ( my $code = $args{default} ) {
|
||||
Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
|
||||
unless ref($code) eq 'CODE';
|
||||
my $original_method = $method;
|
||||
$method = sub {
|
||||
$#_
|
||||
? goto &$original_method
|
||||
: ! exists $_[0]{$attribute}
|
||||
? $_[0]{$attribute} = $_[0]->$code
|
||||
: goto &$original_method
|
||||
};
|
||||
}
|
||||
|
||||
if ( my $role = $args{does} ) {
|
||||
my $original_method = $method;
|
||||
$method = sub {
|
||||
if ( $#_ ) {
|
||||
Carp::confess(qq<Attribute ($attribute) doesn't consume a '$role' role">)
|
||||
unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
|
||||
}
|
||||
goto &$original_method
|
||||
};
|
||||
}
|
||||
|
||||
if ( my $coercion = $args{coerce} ) {
|
||||
$metadata_for{$caller}{$attribute}{coerce} = $coercion;
|
||||
my $original_method = $method;
|
||||
$method = sub {
|
||||
if ( $#_ ) {
|
||||
return $original_method->($_[0], $coercion->($_[1]))
|
||||
}
|
||||
goto &$original_method;
|
||||
}
|
||||
}
|
||||
|
||||
$method = $options{$_}->($method, $attribute, @_)
|
||||
for sort keys %options;
|
||||
|
||||
*{ _glob_for "${caller}::$attribute" } = $method;
|
||||
|
||||
if ( $args{required} ) {
|
||||
$metadata_for{$caller}{$attribute}{required} = 1;
|
||||
}
|
||||
|
||||
if ($args{clearer}) {
|
||||
*{ _glob_for "${caller}::$args{clearer}" }
|
||||
= sub { delete shift->{$attribute} }
|
||||
}
|
||||
|
||||
if ($args{predicate}) {
|
||||
*{ _glob_for "${caller}::$args{predicate}" }
|
||||
= sub { exists shift->{$attribute} }
|
||||
}
|
||||
|
||||
if ($args{handles}) {
|
||||
_has_handles($caller, $attribute, \%args);
|
||||
}
|
||||
|
||||
if (exists $args{init_arg}) {
|
||||
$metadata_for{$caller}{$attribute}{init_arg} = $args{init_arg};
|
||||
}
|
||||
if ( my $coercion = $args{coerce} ) {
|
||||
$class_metadata->{$attribute}{coerce} = $coercion;
|
||||
my $original_method = $method;
|
||||
$method = sub {
|
||||
if ( $#_ ) {
|
||||
return $original_method->($_[0], $coercion->($_[1]))
|
||||
}
|
||||
},
|
||||
%exports,
|
||||
);
|
||||
goto &$original_method;
|
||||
}
|
||||
}
|
||||
|
||||
$export_for{$caller} = [ keys %exports ];
|
||||
_install_coderef "${caller}::$attribute" => $method;
|
||||
|
||||
for my $keyword ( keys %exports ) {
|
||||
*{ _glob_for "${caller}::$keyword" } = $exports{$keyword}
|
||||
}
|
||||
*{ _glob_for "${caller}::extends" }{CODE}->( "Mo::Object" )
|
||||
unless @{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] };
|
||||
};
|
||||
if ( $args{required} ) {
|
||||
$class_metadata->{$attribute}{required} = 1;
|
||||
}
|
||||
|
||||
sub _check_type_constaints {
|
||||
my ($attribute, $I, $I_name, $val) = @_;
|
||||
( ref($I) eq 'CODE'
|
||||
? $I->($val)
|
||||
: (ref $val eq $I
|
||||
|| ($val && $val eq $I)
|
||||
|| (exists $TYPES{$I} && $TYPES{$I}->($val)))
|
||||
)
|
||||
|| Carp::confess(
|
||||
qq<Attribute ($attribute) does not pass the type constraint because: >
|
||||
. qq<Validation failed for '$I_name' with value >
|
||||
. (defined $val ? Mo::Dumper($val) : 'undef') )
|
||||
if ($args{clearer}) {
|
||||
_install_coderef "${caller}::$args{clearer}"
|
||||
=> sub { delete shift->{$attribute} }
|
||||
}
|
||||
|
||||
if ($args{predicate}) {
|
||||
_install_coderef "${caller}::$args{predicate}"
|
||||
=> sub { exists shift->{$attribute} }
|
||||
}
|
||||
|
||||
if ($args{handles}) {
|
||||
_has_handles($caller, $attribute, \%args);
|
||||
}
|
||||
|
||||
if (exists $args{init_arg}) {
|
||||
$class_metadata->{$attribute}{init_arg} = $args{init_arg};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _has_handles {
|
||||
@@ -351,8 +583,8 @@ sub _has_handles {
|
||||
$kv = {
|
||||
map { $_, $_ }
|
||||
grep { $_ =~ $handles }
|
||||
grep { !exists $Mo::Object::{$_} && $target_class->can($_) }
|
||||
grep { !$Mo::Internal::Keyword{$_} }
|
||||
grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
|
||||
grep { !$export_for{$target_class}->{$_} }
|
||||
keys %{ _stash_for $target_class }
|
||||
};
|
||||
}
|
||||
@@ -378,80 +610,32 @@ sub _has_handles {
|
||||
}
|
||||
}
|
||||
|
||||
sub _nested_constraints {
|
||||
my ($attribute, $aggregate_type, $type) = @_;
|
||||
|
||||
my $inner_types;
|
||||
if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
|
||||
$inner_types = _nested_constraints($1, $2);
|
||||
}
|
||||
else {
|
||||
$inner_types = $TYPES{$type};
|
||||
}
|
||||
|
||||
if ( $aggregate_type eq 'ArrayRef' ) {
|
||||
return sub {
|
||||
my ($val) = @_;
|
||||
return unless ref($val) eq ref([]);
|
||||
|
||||
if ($inner_types) {
|
||||
for my $value ( @{$val} ) {
|
||||
return unless $inner_types->($value)
|
||||
}
|
||||
}
|
||||
else {
|
||||
for my $value ( @{$val} ) {
|
||||
return unless $value && ($value eq $type
|
||||
|| (Scalar::Util::blessed($value) && $value->isa($type)));
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
};
|
||||
}
|
||||
elsif ( $aggregate_type eq 'Maybe' ) {
|
||||
return sub {
|
||||
my ($value) = @_;
|
||||
return 1 if ! defined($value);
|
||||
if ($inner_types) {
|
||||
return unless $inner_types->($value)
|
||||
}
|
||||
else {
|
||||
return unless $value eq $type
|
||||
|| (Scalar::Util::blessed($value) && $value->isa($type));
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
|
||||
}
|
||||
}
|
||||
|
||||
sub _set_package_isa {
|
||||
my ($package, @new_isa) = @_;
|
||||
|
||||
*{ _glob_for "${package}::ISA" } = [@new_isa];
|
||||
my $package_isa = \*{ _glob_for "${package}::ISA" };
|
||||
@{*$package_isa} = @new_isa;
|
||||
}
|
||||
|
||||
sub _set_inherited_metadata {
|
||||
my $class = shift;
|
||||
my $class_metadata = Lmo::Meta->metadata_for($class);
|
||||
my $linearized_isa = mro::get_linear_isa($class);
|
||||
my %new_metadata;
|
||||
|
||||
for my $isa_class (reverse @$linearized_isa) {
|
||||
my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
|
||||
%new_metadata = (
|
||||
%new_metadata,
|
||||
%{ $metadata_for{$isa_class} || {} },
|
||||
%$isa_metadata,
|
||||
);
|
||||
}
|
||||
$metadata_for{$class} = \%new_metadata;
|
||||
%$class_metadata = %new_metadata;
|
||||
}
|
||||
|
||||
sub unimport {
|
||||
my $caller = scalar caller();
|
||||
my $stash = _stash_for( $caller );
|
||||
|
||||
delete $stash->{$_} for @{$export_for{$caller}};
|
||||
my $target = caller;
|
||||
_unimport_coderefs($target, keys %{$export_for{$caller}});
|
||||
}
|
||||
|
||||
sub Dumper {
|
||||
@@ -508,7 +692,7 @@ sub override {
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
# End Mo package
|
||||
# End Lmo package
|
||||
# ###########################################################################
|
||||
|
||||
# ###########################################################################
|
||||
@@ -3106,7 +3290,7 @@ sub _d {
|
||||
{
|
||||
package ReportFormatter;
|
||||
|
||||
use Mo;
|
||||
use Lmo;
|
||||
use English qw(-no_match_vars);
|
||||
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
||||
|
||||
@@ -3509,6 +3693,7 @@ sub _d {
|
||||
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
|
||||
}
|
||||
|
||||
no Lmo;
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
|
||||
Reference in New Issue
Block a user