mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-09-04 11:37:16 +00:00
Lmo in pt-visual-explain
This commit is contained in:
Sveta Smirnova
@@ -19,6 +19,7 @@ BEGIN {
|
||||
DSNParser
|
||||
Daemon
|
||||
VersionParser
|
||||
Lmo
|
||||
));
|
||||
}
|
||||
|
||||
@@ -2719,6 +2720,341 @@ no Lmo;
|
||||
# End VersionParser 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 GitHub repository at,
|
||||
# lib/Lmo.pm
|
||||
# t/lib/Lmo.t
|
||||
# See https://github.com/percona/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;
|
||||
sub import {
|
||||
warnings->import(qw(FATAL all));
|
||||
strict->import();
|
||||
|
||||
my $caller = scalar caller(); # Caller's package
|
||||
my %exports = (
|
||||
extends => \&extends,
|
||||
has => \&has,
|
||||
with => \&with,
|
||||
override => \&override,
|
||||
confess => \&Carp::confess,
|
||||
);
|
||||
|
||||
$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_constraints($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;
|
||||
};
|
||||
}
|
||||
|
||||
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} ) {
|
||||
$class_metadata->{$attribute}{coerce} = $coercion;
|
||||
my $original_method = $method;
|
||||
$method = sub {
|
||||
if ( $#_ ) {
|
||||
return $original_method->($_[0], $coercion->($_[1]))
|
||||
}
|
||||
goto &$original_method;
|
||||
}
|
||||
}
|
||||
|
||||
_install_coderef "${caller}::$attribute" => $method;
|
||||
|
||||
if ( $args{required} ) {
|
||||
$class_metadata->{$attribute}{required} = 1;
|
||||
}
|
||||
|
||||
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 {
|
||||
my ($caller, $attribute, $args) = @_;
|
||||
my $handles = $args->{handles};
|
||||
|
||||
my $ref = ref $handles;
|
||||
my $kv;
|
||||
if ( $ref eq ref [] ) {
|
||||
$kv = { map { $_,$_ } @{$handles} };
|
||||
}
|
||||
elsif ( $ref eq ref {} ) {
|
||||
$kv = $handles;
|
||||
}
|
||||
elsif ( $ref eq ref qr// ) {
|
||||
Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
|
||||
unless $args->{isa};
|
||||
my $target_class = $args->{isa};
|
||||
$kv = {
|
||||
map { $_, $_ }
|
||||
grep { $_ =~ $handles }
|
||||
grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
|
||||
grep { !$export_for{$target_class}->{$_} }
|
||||
keys %{ _stash_for $target_class }
|
||||
};
|
||||
}
|
||||
else {
|
||||
Carp::confess("handles for $ref not yet implemented");
|
||||
}
|
||||
|
||||
while ( my ($method, $target) = each %{$kv} ) {
|
||||
my $name = _glob_for "${caller}::$method";
|
||||
Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
|
||||
if defined &$name;
|
||||
|
||||
my ($target, @curried_args) = ref($target) ? @$target : $target;
|
||||
*$name = sub {
|
||||
my $self = shift;
|
||||
my $delegate_to = $self->$attribute();
|
||||
my $error = "Cannot delegate $method to $target because the value of $attribute";
|
||||
Carp::confess("$error is not defined") unless $delegate_to;
|
||||
Carp::confess("$error is not an object (got '$delegate_to')")
|
||||
unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
|
||||
return $delegate_to->$target(@curried_args, @_);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _set_package_isa {
|
||||
my ($package, @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,
|
||||
%$isa_metadata,
|
||||
);
|
||||
}
|
||||
%$class_metadata = %new_metadata;
|
||||
}
|
||||
|
||||
sub unimport {
|
||||
my $caller = scalar caller();
|
||||
my $target = caller;
|
||||
_unimport_coderefs($target, keys %{$export_for{$caller}});
|
||||
}
|
||||
|
||||
sub Dumper {
|
||||
require Data::Dumper;
|
||||
local $Data::Dumper::Indent = 0;
|
||||
local $Data::Dumper::Sortkeys = 0;
|
||||
local $Data::Dumper::Quotekeys = 0;
|
||||
local $Data::Dumper::Terse = 1;
|
||||
|
||||
Data::Dumper::Dumper(@_)
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
if ($] >= 5.010) {
|
||||
{ local $@; require mro; }
|
||||
}
|
||||
else {
|
||||
local $@;
|
||||
eval {
|
||||
require MRO::Compat;
|
||||
} or do {
|
||||
*mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
|
||||
no strict 'refs';
|
||||
|
||||
my $classname = shift;
|
||||
|
||||
my @lin = ($classname);
|
||||
my %stored;
|
||||
foreach my $parent (@{"$classname\::ISA"}) {
|
||||
my $plin = mro::get_linear_isa_dfs($parent);
|
||||
foreach (@$plin) {
|
||||
next if exists $stored{$_};
|
||||
push(@lin, $_);
|
||||
$stored{$_} = 1;
|
||||
}
|
||||
}
|
||||
return \@lin;
|
||||
};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub override {
|
||||
my ($methods, $code) = @_;
|
||||
my $caller = scalar caller;
|
||||
|
||||
for my $method ( ref($methods) ? @$methods : $methods ) {
|
||||
my $full_method = "${caller}::${method}";
|
||||
*{_glob_for $full_method} = $code;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
1;
|
||||
}
|
||||
# ###########################################################################
|
||||
# End Lmo package
|
||||
# ###########################################################################
|
||||
|
||||
# ###########################################################################
|
||||
# This is a combination of modules and programs in one -- a runnable module.
|
||||
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
|
||||
|
||||
Reference in New Issue
Block a user