1
# This program is copyright 2007-2011 Baron Schwartz, 2012 Percona Ireland Ltd.
2
# Feedback and improvements are welcome.
4
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
5
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
6
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
8
# This program is free software; you can redistribute it and/or modify it under
9
# the terms of the GNU General Public License as published by the Free Software
10
# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
11
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
14
# You should have received a copy of the GNU General Public License along with
15
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
16
# Place, Suite 330, Boston, MA 02111-1307 USA.
17
# ###########################################################################
19
# ###########################################################################
21
# Lmo provides a miniature object system in the style of Moose and Moo.
23
$INC{"Lmo.pm"} = __FILE__;
25
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
29
use warnings qw( FATAL all );
32
use Scalar::Util qw(looks_like_number blessed);
42
# Set warnings and strict for the caller.
43
warnings->import(qw(FATAL all));
46
my $caller = scalar caller(); # Caller's package
51
override => \&override,
52
confess => \&Carp::confess,
55
# We keep this so code doing 'no Mo;' actually does a cleanup.
56
$export_for{$caller} = \%exports;
58
# Export has, extends and sosuch.
59
for my $keyword ( keys %exports ) {
60
_install_coderef "${caller}::$keyword" => $exports{$keyword};
63
# Set up our caller's ISA, unless they already set it manually themselves,
64
# in which case we assume they know what they are doing.
65
# XXX weird syntax here because we want to call the classes' extends at
66
# least once, to avoid warnings.
67
if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
69
goto *{ _glob_for "${caller}::extends" }{CODE};
74
my $caller = scalar caller();
75
for my $class ( @_ ) {
78
_set_package_isa($caller, @_);
79
_set_inherited_metadata($caller);
85
# Try loading the class, but don't croak if we fail.
86
(my $file = $class) =~ s{::|'}{/}g;
88
{ local $@; eval { require "$file" } } # or warn $@;
93
my $package = scalar caller();
97
_role_attribute_metadata($package, $role);
99
Role::Tiny->apply_roles_to_package($package, @_);
102
sub _role_attribute_metadata {
103
my ($package, $role) = @_;
105
my $package_meta = Lmo::Meta->metadata_for($package);
106
my $role_meta = Lmo::Meta->metadata_for($role);
108
# The role metadata always comes first, since it shouldn't redefine
109
# metadata defined in the class itself.
110
%$package_meta = (%$role_meta, %$package_meta);
115
my $caller = scalar caller();
117
my $class_metadata = Lmo::Meta->metadata_for($caller);
119
for my $attribute ( ref $names ? @$names : $names ) {
121
my $method = ($args{is} || '') eq 'ro'
123
Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
125
return $_[0]{$attribute};
129
? $_[0]{$attribute} = $_[1]
133
$class_metadata->{$attribute} = ();
136
if ( my $type_check = $args{isa} ) {
137
my $check_name = $type_check;
139
if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
140
$type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type);
143
my $check_sub = sub {
145
Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
148
$class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
149
my $orig_method = $method;
151
$check_sub->($_[1]) if $#_;
156
# XXX TODO: Inline builder and default into the actual method, for speed.
157
# builder => '_builder_method',
158
if ( my $builder = $args{builder} ) {
159
my $original_method = $method;
162
? goto &$original_method
163
: ! exists $_[0]{$attribute}
164
? $_[0]{$attribute} = $_[0]->$builder
165
: goto &$original_method
169
# default => CodeRef,
170
if ( my $code = $args{default} ) {
171
Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
172
unless ref($code) eq 'CODE';
173
my $original_method = $method;
176
? goto &$original_method
177
: ! exists $_[0]{$attribute}
178
? $_[0]{$attribute} = $_[0]->$code
179
: goto &$original_method
184
if ( my $role = $args{does} ) {
185
my $original_method = $method;
188
Carp::confess(qq<Attribute ($attribute) doesn't consume a '$role' role">)
189
unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
191
goto &$original_method
196
if ( my $coercion = $args{coerce} ) {
197
$class_metadata->{$attribute}{coerce} = $coercion;
198
my $original_method = $method;
201
return $original_method->($_[0], $coercion->($_[1]))
203
goto &$original_method;
207
# Actually put the attribute's accessor in the class
208
_install_coderef "${caller}::$attribute" => $method;
210
if ( $args{required} ) {
211
$class_metadata->{$attribute}{required} = 1;
214
if ($args{clearer}) {
215
_install_coderef "${caller}::$args{clearer}"
216
=> sub { delete shift->{$attribute} }
219
if ($args{predicate}) {
220
_install_coderef "${caller}::$args{predicate}"
221
=> sub { exists shift->{$attribute} }
224
if ($args{handles}) {
225
_has_handles($caller, $attribute, \%args);
228
if (exists $args{init_arg}) {
229
$class_metadata->{$attribute}{init_arg} = $args{init_arg};
236
my ($caller, $attribute, $args) = @_;
237
my $handles = $args->{handles};
239
my $ref = ref $handles;
241
if ( $ref eq ref [] ) {
242
# handles => [ ... list of methods ... ],
243
$kv = { map { $_,$_ } @{$handles} };
245
elsif ( $ref eq ref {} ) {
246
# handles => { 'method_to_install' => 'original_method' | [ 'original_method', ... curried arguments ... ], },
249
elsif ( $ref eq ref qr// ) {
250
# handles => qr/PAT/,
251
Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
253
my $target_class = $args->{isa};
256
grep { $_ =~ $handles }
257
grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
258
grep { !$export_for{$target_class}->{$_} }
259
keys %{ _stash_for $target_class }
263
Carp::confess("handles for $ref not yet implemented");
266
while ( my ($method, $target) = each %{$kv} ) {
267
my $name = _glob_for "${caller}::$method";
268
Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
271
# If we have an arrayref, they are currying some arguments.
272
my ($target, @curried_args) = ref($target) ? @$target : $target;
275
my $delegate_to = $self->$attribute();
276
my $error = "Cannot delegate $method to $target because the value of $attribute";
277
Carp::confess("$error is not defined") unless $delegate_to;
278
Carp::confess("$error is not an object (got '$delegate_to')")
279
unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
280
return $delegate_to->$target(@curried_args, @_);
285
# Sets a package's @ISA to the list passed in. Overwrites any previous values.
286
sub _set_package_isa {
287
my ($package, @new_isa) = @_;
288
my $package_isa = \*{ _glob_for "${package}::ISA" };
289
# This somewhat weirder syntax is here to work around a Perl 5.10.0 bug;
290
# For whatever reason, some other variants weren't setting ISA.
291
@{*$package_isa} = @new_isa;
294
# Each class has its own metadata. When a class inhyerits attributes,
295
# it should also inherit the attribute metadata.
296
sub _set_inherited_metadata {
298
my $class_metadata = Lmo::Meta->metadata_for($class);
299
my $linearized_isa = mro::get_linear_isa($class);
302
# Walk @ISA in reverse, grabbing the metadata for each
303
# class. Attributes with the same name defined in more
304
# specific classes override their parent's attributes.
305
for my $isa_class (reverse @$linearized_isa) {
306
my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
312
%$class_metadata = %new_metadata;
316
my $caller = scalar caller();
318
_unimport_coderefs($target, keys %{$export_for{$caller}});
322
require Data::Dumper;
323
local $Data::Dumper::Indent = 0;
324
local $Data::Dumper::Sortkeys = 0;
325
local $Data::Dumper::Quotekeys = 0;
326
local $Data::Dumper::Terse = 1;
328
Data::Dumper::Dumper(@_)
332
# mro is the method resolution order. The module itself is core in
333
# recent Perls; In older Perls it's available from MRO::Compat from
334
# CPAN, and in case that isn't available to us, we inline the barest
337
{ local $@; require mro; }
344
*mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
347
my $classname = shift;
349
my @lin = ($classname);
351
foreach my $parent (@{"$classname\::ISA"}) {
352
my $plin = mro::get_linear_isa_dfs($parent);
354
next if exists $stored{$_};
366
my ($methods, $code) = @_;
367
my $caller = scalar caller;
369
for my $method ( ref($methods) ? @$methods : $methods ) {
370
my $full_method = "${caller}::${method}";
371
*{_glob_for $full_method} = $code;
377
# ###########################################################################
379
# ###########################################################################
added
removed
lib/Lmo.pm
