/usr/share/perl5/Lmo/Object.pm is in percona-toolkit 3.0.6+dfsg-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | # This program is copyright 2013 Percona Ireland Ltd.
# 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::Object package
# ###########################################################################
# Lmo::Object is the parent of every Mo-derived object. Here's where new
# and BUILDARGS gets inherited from.
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 init_arg is defined, then we
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 ) {
# coerce
if ( my $coerce = $class_metadata->{$attribute}{coerce} ) {
$args->{$attribute} = $coerce->($args->{$attribute});
}
# isa
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;
# BUILD
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};
}
# If &class::BUILD exists, for every class in
# the linearized ISA, call it.
# XXX I _think_ that this uses exists correctly, since
# a class could define a stub for BUILD and then AUTOLOAD
# the body. Should check what Moose does.
my @args = %$args;
for my $sub (grep { defined($_) && exists &$_ } @build_subs) {
# @args must be defined outside of this loop,
# as changes to @_ in one BUILD should propagate to another
$sub->( $self, @args);
}
return $self;
}
# Base BUILDARGS.
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
# ###########################################################################
|