I've been trying to do this a number of ways, but none of them seem graceful enough. (I'm also wondering if CPAN or Moose already has this. The dozens of searches I've done over time have shown nothing that quite matches.)
I want to create a type of class that
is a Base + Facade + Factory for other classes which load themselves as destination types.
The "factory" is just Base->new( %params ) and this creates types based on policies registered by the individual subclass.
Each subclass knows basic things about the domain of the Base class, but I'm trying to keep it minimal. See the example below: UnresolvedPath just knows that we should check for existence first.
The obvious example for this is file system directories and files:
package Path;
use Moose;
...
sub BUILD {
my ( $self, $params ) = #_;
my $path = $params->{path};
my $class_name;
foreach my $test_sub ( #tests ) {
$class_name = $test_sub->( $path );
last if $class_name;
}
croak "No valid class for $path!" unless defined $class_name;
$class_name->BUILD( $self, $params );
}
package Folder;
use Moose;
extends 'Path';
use Path register => selector => sub { -d $_[0] };
sub BUILD { ... }
package UnresolvedPath;
extends 'Path';
use Path register position => 1, selector => sub { !-e $_[0] };
Question: Does Moose provide a graceful solution to this? Or would I have to go into Class::MOP for the bulk?
Have a peek at http://code2.0beta.co.uk/moose/svn/MooseX-AbstractFactory/ and feel free to steal. (Mine.)
If you truely want to do the Builder Pattern or the Abstract Factory Pattern then you can do that, and there is nothing stopping you. But perhaps what you really need is some Inversion of Control / Dependency Injection? For that, you can checkout Bread Board
Related
I am new to perl and still learning oop in perl. I usually code in C, C++. It is required to bless an object to notify perl to search for methods in that package first. That's what bless does. And then every function call made with help of -> passes the instance itself as first parameter. Now I have a doubt in writing the constructor for a new object. Normally a constructor would normally look like:
sub new {
my %hash = {};
return bless {%hash}; #will automatically take this package as the class
}
Now I want to have two data members in my class so I can do something like this:
sub new {
my %hash = {};
$hash->{"table_header"} = shift #_; #add element to hash
$hash->{"body_content"} = shift #_;
return bless {%hash}; #will automatically take this package as the class
}
My question is that is this the only possible way. Can't we have multiple data members like in C and C++ and we do have to use strings like "table_header" and "body_content".
EDIT:
In C or C++ we can directly reference the data member(assume its public for now). Here there is one extra reference which has to be made. I wanted to know if there is any way we can have a C like object.
sub new {
my $table_header = shift #_;
my $body_content = shift #_;
#bless somehow
}
Hope this clears some confusion.
There are modules that make OOP in Perl easier. The most important is Moose:
use strict; use warnings;
package SomeObject;
use Moose; # this is now a Moose class
# declare some members. Note that everything is "public"
has table_header => (
is => 'ro', # read-only access
);
has body_content => (
is => 'rw', # read-write access
);
# a "new" method is autogenerated
# some method that uses these fields.
# Note that the members can only be accessed via methods.
# This guards against typos that can't be easily caught with hashes.
sub display {
my ($self) = #_;
my $underline = "=" x (length $self->table_header);
return $self->table_header . "\n" . $underline . "\n\n" . $self->body_content . "\n";
}
package main;
# the "new" takes keyword arguments
my $instance = SomeObject->new(
table_header => "This is a header",
body_content => "Some body content",
);
$instance->body_content("Different content"); # set a member
print $instance->display;
# This is a header
# ================
#
# Different content
If you get to know Moose, you will find an object system that is far more flexible than that in Java or C++, as it takes ideas from Perl6 and the Common Lisp Object System. Of course, this is fairly ugly, but it works well in practice.
Because of the way Perl OOP works, it isn't possible to have the instance members accessible as variables on their own. Well, almost. There is the experimental mop module which does exactly that.
use strict; use warnings;
use mop;
class SomeObject {
# Instance variables start with $!..., and behave like ordinary variables
# If you make them externally accessible with "is ro" or "is rw", then
# appropriate accessor methods are additionally generated.
# a private member with public read-only accessor,
# which has to be initialized in the constructor.
has $!table_header is ro = die 'Please specify a "table_header"!';
# a private member with public read-write accessor,
# which is optional.
has $!body_content is rw = "";
# new is autogenerated, as in Moose
method display() {
# arguments are handled automatically, so we could also do $self->table_header.
my $underline = "=" x (length $!table_header);
return "$!table_header\n$underline\n\n$!body_content\n";
}
}
# as seen in Moose
my $instance = SomeObject->new(
table_header => "This is a header",
body_content => "Some body content",
);
$instance->body_content("Different content"); # set a member, as in Moose
print $instance->display;
# This is a header
# ================
#
# Different content
Although it has pretty syntax, don't use mop right now for serious projects and stick to Moose instead. If Moose is too heavyweight for you, then you might enjoy lighter alternatives like Mouse or Moo (these three object systems are mostly compatible with each other).
You are getting confused between hashes and hash references. You are also forgetting that the first parameter to any method is the object reference or the name of the package. Perl constructors are inherited like any other method, so you must bless the new object into the correct package for polymorphism to work properly. This code is what you intended
sub new {
my $package = shift;
my %self;
$self{table_header} = shift;
$self{body_content} = shift;
bless \%self, $package;
}
I am not clear what you mean by “directly reference the data member”, but if you hoped that you could avoid writing $self everywhere so that every variable was implicitly an element of the hash then you cannot. Perl is far more flexible than most languages, and can use any blessed reference as an object instance. It is most common to use a hash, but occasionally a reference to an array, a scalar, or even a file handle is more appropriate. The cost of this flexibility is specifying exactly when you are referring to a member of the blessed hash. I don't see that it's too great a burden.
You can always write your code more concisely. The method above can be written
sub new {
my $package = shift;
my %self;
#self{qw/ table_header body_content /} = #_;
bless \%self, $package;
}
I have a class called Question, and a bunch of sub-classes depending on the type of question. I can create objects against the sub-classes, but I shouldn't be able to create an object of class Question itself:
#! /usr/bin/env perl
use strict;
use warnings;
#
# LOAD IN YOUR QUESTIONS HERE
#
my #list_of_questions;
for my $question_type qw(Science Math English Dumb) {
my $class = "Question::$question_type";
my $question = $class->new;
push #list_of_questions, $question;
}
package Question;
use Carp;
sub new {
my $class = shift;
my $self = {};
if ( $class = eq "Question" ) {
carp qq(Need to make object a sub-class of "Question");
return;
}
bless $self, $class;
return $self;
}
yadda, yadda, yadda...
package Question::Math;
use parent qw(Question);
yadda, yadda, yadda...
package Question::Science;
use parent qw(Question);
yadda, yadda, yadda...
package Question::English;
use parent qw(Question);
yadda, yadda, yadda...
Notice these are not modules, but merely classes I've defined to be used in my program. Thus, I can't test module loading at runtime.
When I run the above, I get:
Can't locate object method "new" via package "Question::Dumb" (perhaps you forgot to load "Question::Dumb"?)
Is there any way to catch for this particular error, so I can handle it myself? I know I could create an array of valid types, but I was hoping someway of being able to add new question type without having to remember to update my array.
AFAICT what you want to do is check the symbol table to see if your "class" (aka "package") has been defined or not. Doing it manually is no hardship, but Class::Load provides slightly more readable sugar and applies "heuristics" - whatever that means. If you don't want to use this module then the source code for is_class_loaded will lead you to whatever answer you're actually seeking.
use Class::Load qw(is_class_loaded);
for my $question_type (qw(Math English Science Dumb)) {
my $class = "Question::$question_type";
if(!is_class_loaded($class)) {
# construct your new package at runtime, then
}
new_question($class);
}
Your variable name ("class_type") was weird, so I fixed it. I also don't know whether Module::Load is better, but we use Class::Load for this at work.
Edit: bare qw()s are deprecated in one of the newer Perls (5.14?). It's a stupid deprecation, but it's there, so we all have to learn to wrap our qw() foreachs in parens now.
You can't have an expression like Invalid::Class->new() not throw an exception in the calling code, but you can wrap it in exception handling and wrap that inside a method. The standard pattern is to supply a 'type' argument describing the subclass you which to create to a factory method. A common anti-pattern is to put that factory method on the base class, creating a circular dependency and having to do more work than should be required.
It is usual to have the factory method on the interface class and to have it construct sub-classes of an unrelated, dedicated base class, possibly warning or throwing when it fails. In code, that looks pretty much like so:
package Question;
use Try::Tiny;
use Carp qw/carp/;
sub new {
my ($class, $type, #args) = #_;
# could do some munging on $type to make it a class name here
my $real_class = "Question::$type";
return try {
$real_class->new(#args);
} catch {
# could differentiate exception types here
carp qq(Invalid Question type "$type");
};
}
package Question::Base;
sub new {
my ($class) = #_;
return bless {} => $class;
}
package Question::Math;
use base 'Question::Base'; # `use parent` expects to load a module
package main;
use Test::More tests => 2;
use Test::Warn;
isa_ok(Question->new('Math'), 'Question::Math');
warning_like(
sub { Question->new('Dumb') }, # I hear there's no such thing
qr/^Invalid Question/
);
Here's what I finally did:
package Question;
use Carp;
sub new {
my $class = shift;
my %params = #_;
#
# Standardize the Parameters
# Remove the dash, double-dash in front of the parameter and
# lowercase the name. Thus, -Question, --question, and question
# are all the same parameter.
#
my %option_hash;
my $question_type;
for my $key (keys %params) {
my $value = $params{$key};
$key =~ s/^-*//; #Remove leading dashes
$key = ucfirst ( lc $key ); #Make Key look like Method Name
if ( $key eq "Type" ) {
$question_type = ucfirst (lc $value);
}
else {
$option_hash{$key} = $value;
}
}
if ( not defined $question_type ) {
carp qq(Parameter "type" required for creating a new question.);
return;
}
#
# The real "class" of this question includes the question type
#
my $self = {};
$class .= "::$question_type";
bless $self, $class;
#
# All _real does is return a _true_ value. This method is in this
# class, so all sub-classes automatically inherit it. If the eval
# fails, this isn't a subclass, or someone wrote their own `_real_
# method in their sub-class.
#
eval { $self->_real; };
if ( $# ) {
carp qq(Invalid question type of $question_type);
return;
}
#
# Everything looks good! Let's fill up our question object
#
for my $method ( keys %option_hash ) {
my $method_set;
eval { $method_set = $self->$method( $option_hash{$method} ) };
if ( $# or not $method_set ) {
carp qq(Can't set "$method" for question type "$question_type");
return;
}
}
return $self;
}
Now, I'm setting my question like this:
my $question = Question->new(
--type => Integer,
--question => "Pick a number between 1 and 10.",
--help => "Try using the top row of your keyboard...",
--from => "1",
--to => "10",
);
if ( not defined $question ) {
die qq(The question is invalid!);
}
Darch use of the Try::Tiny is nice. It looks way better than wrapping everything in an eval. Unfortunately, it's not a standard module. This program is going on almost 100 separate systems, and using CPAN modules is too difficult. This is especially true since these systems are behind a firewall and can't access the CPAN website.
I basically use Darch's method except I create a _real method in my super-class that I try after I bless the object. If it executes (that's all I really care), then this is a sub-class of my super-class.
This does what I really want: Hide my sub-classes behind my superclass -- much like File::Spec does. Most of my classes have the same methods, and a few have one or two extra methods. For example, my Regex question type has a Pattern method that allows me to make sure the answer given matches a given pattern.
Aloha!
I have a role that I'm busy defining in a Moose class called Authable that is essentially composed into any class that might potentially require some form of authentication in the future; it's a rather simple role, here's the entirety:
package Trello::API::Roles::Authable;
use Moose::Role;
#authentication information
has key => (
is => "rw",
isa => "Str",
);
has token => (
is => "rw",
isa => "Str",
);
1;
For whatever reason, when I attempt to compose it into a class using multiple different statements, i.e.,
with "Trello::API::Roles::Authable";
or
with "Roles::Authable";
I consistently get this same error message: You can only consume roles, Roles::Authable is not a Moose role.
Any idea why this might be happening?
Edit!
Just a side note, I checked the actual source for Moose::Role, and saw this bit:
unless ($meta && $meta->isa('Moose::Meta::Role') ) {
require Moose;
Moose->throw_error( "You can only consume roles, "
. $role->[0]
. " is not a Moose role" );
}
This seems to be where the error is occuring, so it almost seems that for some reason, the role I'm implementing isn't stating that it's a role in the metaclass. Though I could be mistaken! Any help would be appreciated.
Another convenient EDIT!
Bonus: Code context wherein the with routine is called.
package Trello::API::Resource;
use Moose;
use URI::Escape;
use LWP::UserAgent;
with 'Roles::Authable';
which when I do this, it intelligently knows to try and consume Roles/Authable.pm but for whatever reason, it just fails to function!
First of all, I have to agree with Piers that technically, you really should be calling it as with 'Trello::API::Roles::Authable'.
So, you're asking for something that I don't find to be implemented in basic Moose.
I have used the ideas of generic namespace pools before. They are sort of universal namespaces to which you can offer your
semi-anonymous services--without the lock-in of a fixed namespace. I refined my basic idea of the namespace pool with Moose (really MOP) support.
In the Wild West days of Perl, all you would have to do is assign one stash to the symbol for the other, like so:
{ no strict 'refs';
*{$short_pkg_name.'::'} = \*{$full_pkg_name.'::'};
};
And, those two packages were exactly the same things!
But now, we guard our data with lexicals a bit more. And because Class::MOP jealously guards its meta objects in a lexical hash, you have to add something else:
Class::MOP::store_metaclass_by_name(
$short_pkg_name
, Class::MOP::get_metaclass_by_name( $full_pkg_name )
);
Now they are the exact same thing to Perl and to MOP.
Thus you can create packages that are simply a namespace repository for other packages
-- Now with MOP support!
package Namespace::Pool;
use strict;
use warnings;
use Params::Util qw<_POSINT>;
sub import {
shift; # It's just me.
my $full_pkg_name = caller();
Carp::croak( "'$full_pkg_name' is short enough!" )
unless my $pool_name
= shift // [ split /::/, $full_pkg_name ]->[-2]
;
Carp::croak( "'::$pool_name\::' not found in '$full_pkg_name'" )
unless ( _POSINT( my $pos = rindex( $full_pkg_name, "::$pool_name\::" ))
or my $is_short = _POSINT( index( $pool_name, '::' ))
);
my $short_pkg_name
= $is_short ? $poll_name
: substr( $full_pkg_name, $pos + 2 )
;
{ no strict 'refs';
if ( %{$short_pkg_name.'::'} ) {
Carp::croak( "You have already defined $short_pkg_name!" );
}
*{$short_pkg_name.'::'} = \*{$full_pkg_name.'::'};
};
if ( my $meta = Class::MOP::get_metaclass_by_name( $full_pkg_name )) {
Class::MOP::store_metaclass_by_name( $short_pkg_name, $meta );
}
return;
}
Thus in your Role package you can do the following:
package Trello::API::Roles::Authable;
use strict;
use warnings;
use Moose::Role;
use Namespace::Pool 'Roles';
...
And know that it will be available from the namespace of 'Roles'.
In my case I'd simply accidentally named my role 'Test', but there was already an installed module on my system called 'Test' and so Moose thought I wanted to consume that module rather than the new Moose role I'd created. Once I renamed by role to 'Testable' it all worked fine.
I have a class built with Moose that's essentially a data container for an article list. All the attributes - like name, number, price, quantity - are data. "Well, what else?", I can hear you say. So what else?
An evil conspiration of unfortunate circumstances now forces external functionality into that package: Tax calculation of the data in this class has to be performed by an external component. This external component is tightly coupled to an entire application including database and dependencies that ruin the component's testability, dragging it into the everything-coupled-together stew. (Even thinking about refactoring the tax component out of the stew is completely out of the question.)
So my idea is to have the class accept a coderef wrapping the tax calculation component. The class would then remain independent of the tax calculation implementation (and its possible nightmare of dependencies), and at the same time it would allow integration with the application environment.
has 'tax_calculator', is => 'ro', isa => 'CodeRef';
But then, I'd have added a non-data component to my class. Why is that a problem? Because I'm (ab)using $self->meta->get_attribute_list to assemble a data export for my class:
my %data; # need a plain hash, no objects
my #attrs = $self->meta->get_attribute_list;
$data{ $_ } = $self->$_ for #attrs;
return %data;
Now the coderef is part of the attribute list. I could filter it out, of course. But I'm unsure any of what I'm doing here is a sound way to proceed. So how would you handle this problem, perceived as the need to separate data attributes and behaviour attributes?
A possible half thought out solution: use inheritance. Create your class as you do today but with a calculate_tax method that dies if called (i.e. a virtual function). Then create subclass that overrides that method to call into the external system. You can test the base class and use the child class.
Alternate solution: use a role to add the calculate_tax method. You can create two roles: Calculate::Simple::Tax and Calculate::Real::Tax. When testing you add the simple role, in production you add the real role.
I whipped up this example, but I don't use Moose, so I may be crazy with respect to how to apply the role to the class. There may be some more Moosey way of doing this:
#!/usr/bin/perl
use warnings;
{
package Simple::Tax;
use Moose::Role;
requires 'price';
sub calculate_tax {
my $self = shift;
return int($self->price * 0.05);
}
}
{
package A;
use Moose;
use Moose::Util qw( apply_all_roles );
has price => ( is => "rw", isa => 'Int' ); #price in pennies
sub new_with_simple_tax {
my $class = shift;
my $obj = $class->new(#_);
apply_all_roles( $obj, "Simple::Tax" );
}
}
my $o = A->new_with_simple_tax(price => 100);
print $o->calculate_tax, " cents\n";
It appears as if the right way to do it in Moose is to use two roles. The first is applied to the class and contains the production code. The second is applied to an object you want to use in testing. It subverts the first method using an around method and never calls the original method:
#!/usr/bin/perl
use warnings;
{
package Complex::Tax;
use Moose::Role;
requires 'price';
sub calculate_tax {
my $self = shift;
print "complex was called\n";
#pretend this is more complex
return int($self->price * 0.15);
}
}
{
package Simple::Tax;
use Moose::Role;
requires 'price';
around calculate_tax => sub {
my ($orig_method, $self) = #_;
return int($self->price * 0.05);
}
}
{
package A;
use Moose;
has price => ( is => "rw", isa => 'Int' ); #price in pennies
with "Complex::Tax";
}
my $prod = A->new(price => 100);
print $prod->calculate_tax, " cents\n";
use Moose::Util qw/ apply_all_roles /;
my $test = A->new(price => 100);
apply_all_roles($test, 'Simple::Tax');
print $test->calculate_tax, " cents\n";
A couple of things come to mind:
Implement the tax calculation logic in a separate TaxCalculation class that has the article list and the tax calculator as attributes.
Use a mock object as the tax calculator when you test. The tax calculator could be stored in an attribute that by default creates the real tax calculator. The test passes in a mock object that has the same interface but doesn't do anything.
Actually that's not really an abuse of get_attribute_list since that's rather exactly how MooseX::Storage works[^1]. IF you are going to continue to use get_attribute_list to build your straight data you'll want to do what MooseX::Storage does and set up an attribute trait for "DoNotSerialize"[^2]:
package MyApp::Meta::Attribute::Trait::DoNotSerialize;
use Moose::Role;
# register this alias ...
package Moose::Meta::Attribute::Custom::Trait::DoNotSerialize;
sub register_implementation { 'MyApp::Meta::Attribute::Trait::DoNotSerialize' }
1;
__END__
You then can use this in your class like so:
has 'tax_calculator' => ( is => 'ro', isa => 'CodeRef', traits => ['DoNotSerialize'] );
and in your serialization code like so:
my %data; # need a plain hash, no objects
my #attrs = grep { !$_->does('MyApp::Meta::Attribute::Trait::DoNotSerialize') } $self->meta->get_all_attributes; # note the change from get_attribute_list
$data{ $_ } = $_->get_value($self) for #attrs; # note the inversion here too
return %data;
Ultimately though you will end up in a solution similar to the Role one that Chas proposes, and I just answered his follow up question regarding it here: How to handle mocking roles in Moose?.
Hope this helps.
[^1]: And since the most basic use-case for MooseX::Storage is doing exactly what you describe, I highly suggest looking at it to do what you're doing by hand here.
[^2]: Or simply re-use the one from MooseX::Storage creates.
I have a module which is defining exceptions for the package of which it is a part. The exceptions are being declared with Exception::Class::Nested.
For purposes of discussion, let's say that this module is named Foo::Bar::Exception, and that all of the exceptions it defines are first-level subclasses of that (e.g., Foo::Bar::Exception:DoNotDoThat). All of the exceptions I care about are defined in this module file; I'm not interested in any additional subclassing any other module does of me.
For my import method, I want to construct a list of all the exceptions being defined, and I'd like to do it by traversing the symbol table somehow rather than keeping a hard-coded list that can get out of sync with the definitions and has to be manually maintained.
So, how can Foo::Bar::Exception->import iterate through Foo::Bar::Exception's symbol table to find all the exceptions (first-level subclasses) that have been declared in the module? It's just the active loaded symbol table I'm interested in; no filesystem searches or the like.
Thanks!
[addendum]
Since all of my exception subclass names end with Exception or Error, this looks like it's getting close to what I want:
my %symtable = eval("'%' . __PACKAGE__ . '::'");
my #shortnames = grep(m!(?:Error|Exception)::$!, keys(%symtable));
#shortnames = ( map { $_ =~ s/::$//; $_; } #shortnames );
my #longnames = ( map { __PACKAGE__ . '::' . $_ } #shortnames );
Some of the parenthesisation is unnecessary, but I added it for clarity about the array context.
The symbol table for Foo::Bar::Exception is %Foo::Bar::Exception::, so you could write:
sub import {
for my $key (keys %Foo::Bar::Exception::) {
if (my ($name) = $key =~ /(.+)::$/) {
my $pkg = 'Foo::Bar::Exception::'.$name;
no strict 'refs';
*{caller()."::$name"} = sub () {$pkg};
}
}
}
use MRO::Compat;
my #classes = #{ mro::get_isarev("Foo::Bar::Exception") };
#classes = grep $_->isa("Foo::Bar::Exception"), #classes;
MRO::Compat enables the mro API on pre-5.10 perls that otherwise wouldn't have it (although get_isarev is much faster on 5.10+), get_isarev returns classes that inherit (directly or indirectly) from the named class, and the final grep is because get_isarev is a heuristic sort of function -- it will never miss a class that does inherit the one you specified, but in the face of runtime #ISA modification it might report a class that actually doesn't inherit your class anymore. So the ->isa check makes sure that the class is still there and still a subclass.
Edit: just noticed the part where you're only interested in packages that are under the namespace as well, but I still think that using the mro API is a good foundation for finding them -- just tack on a grep /^Foo::Bar::Exception::/ as well :)
Due to the inheritance issues (apparently introduced by Exception::Class or Exception::Class::Nested), I've gone with the pure symbol-table route.
Both the longnames (e.g., Foo::Bar::Exception:DoNotDoThat) and the shortnames (DoNotDoThat) are exportable; the longnames are exported by default. (Unclear if that's necessary, but it seems to do no harm.)
If the shortnames are being exported, this does the trick:
my $caller = caller();
$caller ||= 'main';
my #snames = #{$EXPORT_TAGS{shortnames}};
for my $short (#snames) {
my $exc = __PACKAGE__ . '::' . $short;
no strict 'refs';
*{"$caller\::$short"} = sub () { $exc };
}
which is quite close to #Eric's answer, but derived before I saw his.
Thanks, everyone!