percona-toolkit/lib/Lmo.pm

# This program is copyright 2012-2013 Percona Inc.
# Feedback and improvements are welcome.
#
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# This program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
# licenses.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
# Place, Suite 330, Boston, MA  02111-1307  USA.
# ###########################################################################
# Lmo package
# ###########################################################################
{
# Package: Lmo
# Lmo provides a little meta object system like Moose and Moo.
# This code was derived from Mo 0.30.
package Lmo;

our $VERSION = '0.01'; 

use strict;
use warnings qw( FATAL all );

use Carp ();
use Scalar::Util qw(blessed);

eval {
   require Lmo::Meta;
   require Lmo::Object;
   require Lmo::Types;
};

{
   # Gets the glob from a given string.
   no strict 'refs';
   sub _glob_for {
      return \*{shift()}
   }

   # Gets the stash from a given string.
   # A stash is a symbol table hash; rough explanation on
   # http://perldoc.perl.org/perlguts.html#Stashes-and-Globs
   # But the gist of it is that we can use a hash-like thing to
   # refer to a class and modify it.
   sub _stash_for {
      return \%{ shift() . "::" };
   }
}

my %export_for;
sub import {
    # Set warnings and strict for the caller.
    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 = (
        extends => \&extends,
        has     => \&has,
    );

    # We keep this so code doing 'no Mo;' actually does a cleanup.
    $export_for{$caller} = [ keys %exports ];

    # Export has, extends and sosuch.
    for my $keyword ( keys %exports ) {
      *{ _glob_for "${caller}::$keyword" } = $exports{$keyword}
    }

    # Set up our caller's ISA, unless they already set it manually themselves,
    # in which case we assume they know what they are doing.
    # XXX weird syntax here because we want to call the classes' extends at
    # least once, to avoid warnings.
    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) = @_;
   
   # Try loading the class, but don't croak if we fail.
   (my $file = $class) =~ s{::|'}{/}g;
   $file .= '.pm';
   { local $@; eval { require "$file" } } # or warn $@;
   return;
}

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} = ();

      # isa => Constaint,
      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;
         };
      }

      # XXX TODO: Inline builder and default into the actual method, for speed.
      # builder => '_builder_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
         };
      }

      # default => CodeRef,
      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
         };
      }

      # does => 'Role',
      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
         };
      }

      # coerce => CodeRef,
      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;
         }
      }

      # Actually put the attribute's accessor in the class
      *{ _glob_for "${caller}::$attribute" } = $method;

      if ( $args{required} ) {
         $class_metadata->{$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}) {
         $class_metadata->{$attribute}{init_arg} = $args{init_arg};
      }
   }
}

# handles handles
sub _has_handles {
   my ($caller, $attribute, $args) = @_;
   my $handles = $args->{handles};

   my $ref = ref $handles;
   my $kv;
   if ( $ref eq ref [] ) {
         # handles => [ ... list of methods ... ],
         $kv = { map { $_,$_ } @{$handles} };
   }
   elsif ( $ref eq ref {} ) {
         # handles => { 'method_to_install' => 'original_method' | [ 'original_method', ... curried arguments ... ], },
         $kv = $handles;
   }
   elsif ( $ref eq ref qr// ) {
         # handles => qr/PAT/,
         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  { $_ ne 'has' && $_ ne 'extends' }
            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;

         # If we have an arrayref, they are currying some arguments.
         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, @_);
         }
   }
}

# Sets a package's @ISA to the list passed in. Overwrites any previous values.
sub _set_package_isa {
   my ($package, @new_isa) = @_;
   my $package_isa  = \*{ _glob_for "${package}::ISA" };
   # This somewhat weirder syntax is here to work around a Perl 5.10.0 bug;
   # For whatever reason, some other variants weren't setting ISA.
   @{*$package_isa} = @new_isa;
}

# Each class has its own metadata. When a class inhyerits attributes,
# it should also inherit the attribute metadata.
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;

   # Walk @ISA in reverse, grabbing the metadata for each
   # class. Attributes with the same name defined in more
   # specific classes override their parent's attributes.
   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 $stash  = _stash_for( $caller );

   delete $stash->{$_} for @{$export_for{$caller}};
}

BEGIN {
   # mro is the method resolution order. The module itself is core in
   # recent Perls; In older Perls it's available from MRO::Compat from
   # CPAN, and in case that isn't available to us, we inline the barest
   # funcionality.
   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;
         };
      }
   }
}

1;
}
# ###########################################################################
# End Lmo package
# ###########################################################################