File: //usr/local/lib64/perl5/Cpanel/Class.pm
package Cpanel::Class;
use strict;
use warnings;
use Scalar::Util 'blessed', 'reftype';
use Carp 'confess';
use Cpanel::Class::Meta::Class;
use XSLoader ();
our $VERSION = '1.0.5';
XSLoader::load 'Cpanel::Class', $VERSION;
# Utils
sub load_class {
my $class = shift;
return 1 if is_class_loaded($class);
my $file = $class . '.pm';
$file =~ s{::}{/}g;
eval { CORE::require($file) };
1;
}
sub is_class_loaded {
my $class = shift;
no strict 'refs';
return 1 if defined ${"${class}::VERSION"} || defined @{"${class}::ISA"};
foreach ( keys %{"${class}::"} ) {
next if substr( $_, -2, 2 ) eq '::';
return 1 if defined &{"${class}::$_"};
}
return 0;
}
my @exported_subs = qw{ has before around after extends };
sub import {
my $caller = caller;
my $meta = Cpanel::Class::Meta::Class->new( { package => $caller } );
foreach my $sub (@exported_subs) {
$meta->add_method( $sub => \&{$sub} );
}
Cpanel::Class::load_class('Cpanel::Class::Object');
$meta->superclasses('Cpanel::Class::Object') if !$meta->superclasses;
strict->import;
warnings->import;
}
sub unimport {
no strict 'refs';
my $class = caller();
foreach my $name (@exported_subs) {
if ( defined &{ $class . '::' . $name } ) {
my $keyword = \&{ $class . '::' . $name };
my ($pkg_name) = Cpanel::Class::get_code_info($keyword);
next if $@;
next if $pkg_name ne 'Cpanel::Class';
delete ${ $class . '::' }{$name};
}
}
}
sub extends {
my $caller = caller();
Cpanel::Class::load_class($_) foreach (@_);
$caller->meta->superclasses(@_);
}
sub has($;%) {
my ( $attr, %meta ) = @_;
my $caller = caller();
$caller->meta->add_attribute( $attr, %meta );
}
sub around(@) {
my $code = pop @_;
my $caller = caller();
$caller->meta->add_around_method_modifier( $_, $code ) foreach (@_);
}
sub after(@) {
my $code = pop @_;
my $caller = caller();
$caller->meta->add_after_method_modifier( $_, $code ) foreach (@_);
}
sub before(@) {
my $code = pop @_;
my $caller = caller();
$caller->meta->add_before_method_modifier( $_, $code ) foreach (@_);
}
1;
__END__
=head1 NAME
Cpanel::Class - Tool to help organize and build perl classes
=head2 Utility functions
=over 4
=item load_class ($class_name)
This will load a given C<$class_name> and if it does not have an
already initialized metaclass, then it will intialize one for it.
=item is_class_loaded ($class_name)
This will return a boolean depending on if the C<$class_name> has
been loaded.
These functions are not exported
=back
=head1 has - Create attributes
=over 4
=item has $name => %options
=back
is => ('rw'|'ro')
The is option accepts either rw (for read/write) or ro (for read only). These will
create either a read/write accessor or a read-only accessor respectively, using the
same name as the $name of the attribute.
default
Change the default value of an attribute.
lazy => (1|0)
This will tell the class to not create this slot until absolutely necessary. If an
attribute is marked as lazy it must have a default supplied.
handles => ARRAY | HASH
The handles option provides Cpanel::Class classes with automated delegation features.
ARRAY
This is the most common usage for handles. You basically pass a list of method names
to be delegated, and Cpanel::Class will install a delegation method for each one.
HASH
Instead of a list of method names, you pass a HASH ref where each key is the method
name you want installed locally, and its value is the name of the original method in
the class being delegated to.
auto_deref => (1|0)
This tells the accessor whether to automatically dereference the value returned. Only
works for arrayref or hashref.
weak_ref => (1|0)
This will tell the class to store the value of this attribute as a weakened reference.
trigger => $code_ref
The trigger option is a CODE reference which will be called after the value of the
attribute is set. The CODE ref will be passed the instance itself, the updated value
and the attribute meta-object (this is for more advanced fiddling and can typically
be ignored). You cannot have a trigger on a read-only attribute.
clearer => 'method_name'
Create a method that will delete/undefine an attribute
required => (1|0)
This marks the attribute as being required. This means a defined value must be supplied during class construction, and the attribute may never be set to undef with an accessor.
builder => 'method_name'
The value of this key is the name of the method that will be called to obtain the value used to initialize the attribute. This should be a method in the class associated with the attribute, not a method in the attribute class itself.
has is exported by default.
=head1 Method modifiers
=head3 before
When writing a "before" hook you can catch the call to an inherited method or a method in the same class,
and execute some code before the inherited method is called.
Example:
package Foo;
use Cpanel::Class;
sub method { return 4; }
package Bar;
use Cpanel::Class;
extends 'Foo';
before 'method' => sub {
my ($self, @args) = @_;
# ... here some stuff to do before Foo::method is called
};
=head3 after
When writing an "after" hook you can catch the call to an inherited method or a method in the same class and
execute some code after the original method is executed. You receive in your
hook the result of the mother's method.
Example:
package Foo;
use Cpanel::Class;
sub method { return 4; }
package Bar;
use Cpanel::Class;
extends 'Foo';
my $flag;
after 'method' => sub {
my ($self, @args) = @_;
$flag = 1;
};
=head3 around
When writing an "around" hook you can catch the call to an inherited method or a method in the same class and
actually redefine it on-the-fly.
You get the code reference to the parent's method and its arguments, and can
do what you want then.
Example:
package Foo;
use Cpanel::Class;
sub method { return 4; }
package Bar;
use Cpanel::Class;
extends 'Foo';
around 'method' => sub {
my $orig = shift;
my ($self, @args) = @_;
my $res = $self->$orig(@args);
return $res + 3;
}
=head1 meta
meta gives access to the Classes' Meta Object Protocal
=head2 Meta Object Protocal
A meta object protocol is an API to an object system.
To be more specific, it is a set of abstractions of the components of
an object system (typically things like; classes, object, methods,
object attributes, etc.). These abstractions can then be used to both
inspect and manipulate the object system which they describe.
=over 4
=item ->meta->get_attribute($attr_name)
Creates attributes just like the has key word
=item ->meta->get_method_map
Returns a hashref of all method and code from the class
=item ->meta->add_method($name => $coderef)
Add a method to the class
=item ->meta->get_method_list
Returns an array method names from the class
=item ->meta->get_method($method_name)
Returns coderef of a given method
=item ->meta->has_method($method_name)
Returns true if the method exists in the class otherwise false
=item ->meta->remove_method($method_name)
Remove the method from the class
=item ->meta->superclasses
Returns the @ISA list of superclasses
=item ->meta->class_precedence_list
Returns the list of all Classes in the Class hierarchy. Duplicates are possible.
=item ->meta->linearized_isa
Returns the list of all Classes in the Classes hierarchy. It removes duplicates
=item ->meta->subclasses
Returns the list of all Classes that inherit from the current class
=item ->meta->name
Returns the name of the current class
=item ->meta->version
Returns the VERSION of the class
=item ->meta->authority
Returns the Authority of the class
=item ->meta->identifier
Returns a concatenation of name, version and authority seperated by dashes
=back
meta is inherited from Cpanel::Class::Object
=cut