Consider:
#!/usr/bin/perl
use strict;
use warnings;
package base
{
sub new()
{
my $class = shift( #_ );
my $self = {};
bless( $self, $class );
}
}
package myclass
{
our #ISA = 'base';
}
package main;
my $classname = 'myclass';
print( ( $classname->can( 'new' ) ) ? "can" : "cannot" );
print( "\n" );
print( #myclass::ISA );
I know that having multiple packages in one file isn't exactly "clean Perl". Please let us ignore that issue for the scope of this question.
What I am interested in are the last couple of lines.
my $classname = 'myclass';
print( ( $classname->can( 'new' ) ) ? "can" : "cannot" );
Here, I can use the name of a package, stored in classname, to "inspect" that package without having instantiated the package / class.
print( #myclass::ISA );
Here I "inspect" a package's ISA array... but by naming the package directly.
Is there a way to refer to the package's ISA through $classname as well?
It's possible without strict refs:
say join ' ', do { no strict 'refs'; #{ "$classname" . '::ISA' } };
Or you can use mro::get_linear_isa to get all the ancestors (i.e. the transitive closure of the #ISA):
use mro;
say join ' ', #{ mro::get_linear_isa($classname) };
But that's not what you usually need. In practice, you want to know whether a class inherited from a given class or not, which is possible using the universal isa method:
say $classname->isa('base'); # 1
Again, this checks the transitive relation, not just the direct #ISA membership.
Related
I'm trying to use an alias with MooseX::Aliases and MooseX::Constructor::AllErrors
However, the two don't seem to play nicely together. Consider the following example:
package Alias
{
use Moose;
use MooseX::Aliases;
use MooseX::Constructor::AllErrors;
has foo => (
is => 'rw', isa => 'Str', required => 1, alias => 'bar'
);
}
use strict;
use warnings;
use Alias;
my $obj;
eval {
$obj = Alias->new( bar => 'alias_value' );
};
if ($#)
{
foreach my $error ( $#->errors )
{
print $error ."\n";
print $error->message ."\n";
}
exit 1;
}
print $obj->bar ."\n";
$obj->foo( 'new_alias_value' );
print $obj->foo."\n";
1;
This should allow me to create an Alias object using the 'bar' alias... shouldn't it? Does anyone know if MooseX::Constructor::AllErrors is supposed to support aliased attributes?
It's a bug, in that it violates expectations, but it's not easily resolvable -- the problem is that MooseX::Aliases modifies what arguments are allowed/accepted in the constructor, but MooseX::Constructor::AllErrors is not aware of this, so when it looks at the passed values at construction time, it errors out when there is no 'agency' field.
This gets around the situation by manually moving the aliased field before MooseX::Constructor::AllErrors sees it:
around BUILDARGS => sub {
my $orig = shift;
my $self = shift;
my %args = #_;
$args{agency} //= delete $args{company};
$self->$orig(%args);
};
The good news is that this has hope of working better in the future, because
there are plans for MooseX::Aliases to be cored, which would force all other
extensions (e.g. MXCAE) to support the alias feature properly.
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.
I have an OO design question. I've written the (pseudo)-pseudocode below to help illustrate my question. (I say "pseudo-pseudocode" because it's mostly correct, with only a few bits of nonsense...)
I'm using a Factory pattern to create objects of a class appropriate to the attributes I pass the Factory::new method. However, there are some attributes that I can only get after object creation which I want to then use to further subclass or "specialize" the type of object. I want to do this so I can use the same interface to all of the objects in main independent of the object class (I guess this is polymorphism).
First, the Factory class:
use strict;
use warnings;
package Vehicle::Factory;
sub new {
my ( $class, $args ) = #_;
if ( $args->{class} =~ /car/i ) {
return Vehicle::Car->new($args);
} else {
# other possible subclasses based on attributes
}
}
1;
Now for the associated classes:
package Vehicle;
sub new {
my ( $class, $args ) = #_;
bless $self, $class;
$self->color( $args->color );
}
sub color {
$_[1] ? $_[0]->{_color} = $_[1] : return $_[0]->{_color};
}
sub wheels {
$_[1] ? $_[0]->{_wheels} = $_[1] : return $_[0]->{_wheels};
}
1;
And a subclass:
package Vehicle::Car;
use base qw( Vehicle );
sub get_fueltype {
my ( $self, $args ) = #_;
$self->fueltype = check_fuel_type;
}
sub fueltype {
$_[1] ? $_[0]->{_fueltype} = $_[1] : return $_[0]->{_fueltype};
}
1;
Now for the "stage 2" subclasses. I can only create these when I know more about the object that's already been created...
package Vehicle::Car::Gas;
use base qw( Vehicle::Car );
sub fill_her_up {
# Make sure it's Gas.
# ...
}
1;
package Vehicle::Car::Diesel;
use base qw( Vehilce::Car );
sub fill_her_up {
# Make sure it's Diesel.
# ...
}
1;
package Vehicle::Car::Electric;
use base qw( Vehicle::Car );
sub fill_her_up {
# Find a socket.
# ...
}
1;
And the main body of code:
package main;
my $thing = Vehicle::Factory->new( color => "red", wheels => 4 );
$thing->get_fueltype;
# Somehow convert $thing to be an object of the appropriate subclass based on
# the "fueltype" attribute
$thing->fill_her_up;
(I hope my horribly contrived example makes sense!)
Now, I'm not sure... Should I create a new object using instance data from $thing?
Is there a way to subclass an object without destroying and recreating it?
Maybe I should I use the following approach, and re-use the Vehicle factory?
package Vehicle::Factory;
sub new {
my ( $class, $args ) = #_;
if ( $args->{class} =~ /car/i ) {
return Vehicle::Car->new($args);
}
if ( $self->fueltype eq "gas" ) {
return Vehicle::Car::Gas->new($args);
}
if ( $self->fueltype eq "diesel" ) {
return Vehicle::Car::Diesel->new($args);
}
if ( $self->fueltype eq "electric" ) {
return Vehicle::Car::Electric->new($args);
}
}
At this point in my real code - unlike my example - there's alot of instance data to then pass to a new object. I think it could be a little ugly if I need to pass all data between old and new object explicitly.
In my real code, there may be hundreds / thousands of such objects fed from a config file, all requiring the same treatment but with some differences on how to do it. It's the difference between using Expect and SSH to get data from a remote device, or using SNMP. The second "level" of info is based on information I get when I query a remote device and get it's device type (among other things)...
Final point is: I'm almost complete writing the software, but a very "late" and important requirement has come up which necessitates this change. I really want to accomodate the late req as simply and elegantly as possible. I don't want to "hack" it in and change the interface in main.
Thanks in advance for any pointers.
Changing the type of an object is very easy in Perl, even after it has been created (easy enough to get yourself in big trouble).
$car = Vehicle::Factory->new( ... );
... stuff happens to $car ...
# Oh! Now I have decided that $car should be a Vehicle::RustBucket::Fiat
bless $car, 'Vehicle::RustBucket::Fiat';
Feels like you want to create a separate inheritance hierarchy and delegate to that from the original class.
So your car.move method delegates to a propulsionmechanism.burnfuel method and propulsionmechanism can be electric, diesel or gas.
Basically, prefer polymorphic delegation to a different hierarchy, instead of trying to extend the same hierarchy.
Mob is right, but I make lightweight "interface" classes for things like this. For example, I might define the receptor class as "Reclassable" and all items that descend from Reclassable support a is_complete_candidate check. Or even a cast or as method.
package Reclassable;
sub _cast { Carp::croak ref( $_[1] ) . '::_cast unimplemented!' }
sub cast {
my ( $self, $inst, $newclass ) = #_;
$newclass = $self if $self ne __PACKAGE__;
return bless( $inst, $newclass ) if $inst->isa( $newclass );
return $newclass->_cast( $_[1] ) if $newclass->isa( __PACKAGE__ );
return;
}
package AutoReclass;
use parent 'Reclassable';
sub _cast { bless $_[1], $_[0]; }
You can do your verification in the _cast method. And the receiving class can decide how reckless it wants to be with casting.
Then you do your sanity checks in the class _cast method.
sub _cast {
my ( $cls, $cand ) = #_;
return unless ( $cand->{walks_like} eq 'duck'
and $cand->{talks_like} eq 'duck'
and $cand->{sound} eq 'quack'
);
$cand->{covering} = 'down' unless $cand->{covering} eq 'down';
$cand->{initialized} ||= 1;
return bless $cand, $cls;
}
Is there a way I can dynamically include a package based on whatever delegate is used rather than having to include all the various delegates?
I found this example on how to use delegates but it glosses over the details I'm trying to understand. The way this is written it's essentially all one file...
package Compare;
use Moose::Role;
requires 'compare';
package SpaceshipCompare;
use Moose;
with 'Compare';
sub compare { my ($a, $b) = #_; return $a <=> $b }
package Sort;
use Moose;
has 'comparer' => (
is => 'ro',
does => 'Compare',
handles => 'Compare',
required => 1,
);
sub my_sort {
my ($self, #list) = #_;
return sort { $self->compare($a, $b) } #list;
}
Usage:
my $sorter = Sort->new( comparer => SpaceshipCompare->new );
my #sorted = $sorter->my_sort("1one", "0", "43");
In my implementation of a delegate I'm using a different resource based on a parameter that's passed to the constructor.
sub BUILD{
my($this,$args) = #_;
if($args->{cachedDataSource} eq 'local'){
$this->setDataStore( Cache::LocalCache->new() );
}
if($args->{cachedDataSource} eq 'remote'){
$this->setDataStore( Cache::RemoteCache->new() );
}
if($args->{cachedDataSource} eq 'memd'){
$this->setDataStore( Cache::MemedCache->new() );
}
}
But in order for this to work I have to
use Cache::LocalCache;
use Cache::RemoteCache;
use Cache::MemedCache;
Is there a better way to do delegates without perhaps having to use all the packages (like some kind of lazy load)?
In your example, you can simply use require:
sub BUILD{
my($this,$args) = #_;
if($args->{cachedDataSource} eq 'local'){
require Cache::LocalCache;
$this->setDataStore( Cache::LocalCache->new() );
}
if($args->{cachedDataSource} eq 'remote'){
require Cache::RemoteCache;
$this->setDataStore( Cache::RemoteCache->new() );
}
if($args->{cachedDataSource} eq 'memd'){
require Cache::MemedCache;
$this->setDataStore( Cache::MemedCache->new() );
}
}
Since require is a run-time operation, the class won't be loaded until it's actually needed. If your users were passing in class names, then it gets a bit more complicated. You might want to use Module::Load for that.
OK. I have a problem trying to inherit constants set in a parent class for any of the child classes.
#!/usr/bin/perl
use strict;
use warnings;
package Car;
use Exporter qw( import );
our #EXPORT_OK = ( 'WHEELS', 'WINGS' );
use constant WHEELS => 4;
use constant WINGS => 0;
sub new {
my ( $class, %args ) = #_;
my $self = {
doors => $args{doors},
colour => $args{colour},
wheels => WHEELS,
wings => WINGS,
};
bless $self, $class;
return $self;
}
package Car::Sports;
use base qw( Car );
sub new {
my ( $class, %args ) = #_;
my $self = {
doors => $args{doors},
engine => $args{engine},
wheels => WHEELS,
wings => WINGS,
};
bless $self, $class;
return $self;
}
package main;
my $obj = Car->new( doors => 4, colour => "red" );
print Dumper $obj;
my $obj2 = Car::Sports->new( doors => 5, engine => "V8" );
print Dumper $obj2;
__END__
The error is:
Bareword "WHEELS" not allowed while "strict subs" in use at ./t.pl line 30.
Bareword "WINGS" not allowed while "strict subs" in use at ./t.pl line 30.
Execution of ./t.pl aborted due to compilation errors.
Now, I haven't come here to post without doing some research. I understand that one option would be to use Car qw( WHEELS WINGS) in Car::Sports. However, if I do that I get the following error, because the classes are all inline in the same file:
Can't locate Car.pm in #INC
For a variety of reasons, I need to keep my packages in one file. Is there a way around this? As constants are basically just subs, why do I have to import them when the same would not be true for a normal method?
Finally, I also know I can do this:
package Car::Sports;
use base qw( Car );
sub new {
my ( $class, %args ) = #_;
my $self = {
doors => $args{doors},
engine => $args{engine},
wheels => Car::WHEELS,
wings => Car::WINGS,
};
bless $self, $class;
return $self;
}
And it's fine... But I have a number of classes and want to make the inheritance of constants more generic that having to name the parent class explicitly (and sometimes it's not just the parent class, but the grandparent).
Many thanks in advance for any pointers!
Cheers
One workaround is to include the line
package Car::Sports;
use base qw( Car );
Car->import(qw(WHEELS WINGS));
AND use the sigils in the Car::Sports constructor:
...
wheels => &WHEELS,
wings => &WINGS,
...
Your Car class isn't defining its #EXPORTS_OK list until run-time. The sigils are required because the Car::Sports constructor is parsed at compile-time, and the compiler doesn't know there should be WHEELS and WINGS symbols in the Car::Sports namespace.
The only way to avoid the sigils is to define Car's exports at compile-time:
package Car;
our #EXPORT_OK;
BEGIN {#EXPORT_OK = qw(WHEELS WINGS)} # set at compile not run time
...
package Car::Sports;
use base qw(Car);
BEGIN {Car->import('WHEELS','WINGS')} # import before c'tor is parsed
You could also avoid these machinations by defining the Car class in its own Car.pm file. Then you would just say
use Car qw(WHEELS WINGS);
and everything in the Car.pm file would be parsed at compile time, AND the Exporter::import method (triggered by a call to Car::import) would automatically get run and import the desired symbols to your current namespace.
May this change suit your needs?
[...]
wheels => $class->SUPER::WHEELS,
wings => $class->SUPER::WINGS,
[...]
Using Data::Dumper you get:
$VAR1 = bless( {
'wings' => 0,
'colour' => 'red',
'doors' => 4,
'wheels' => 4
}, 'Car' );
$VAR1 = bless( {
'wings' => 0,
'engine' => 'V8',
'doors' => 5,
'wheels' => 4
}, 'Car::Sports' );
Alternative, you could do exactly what use does:
BEGIN {
package Car;
use Exporter qw( import );
#EXPORT_OK = qw( WHEELS );
...
$INC{'Car.pm'} = 1;
}
BEGIN {
package Car::Sports;
use Car qw( WHEELS );
#ISA = 'Car';
...
$INC{'Car/Sports.pm'} = 1;
}
Generally, exposing that something is a constant to any package other than the one defining it is actually a bad idea. This argues, among other things, against using unusual forms when referring to values that happen to be constant in other areas of your code.
The constant module actually supports an invocation form that hides the fact that we're talking about constants, inasmuch as calling constants as class methods works just fine:
package Car;
use constant default_wheel_count => 4;
package Car::Sports;
sub new {
my ($class) = #_;
return bless {
wheels => $class->default_wheel_count,
} => $class;
}
That's how one actually inherits constants, but it's still probably the wrong approach. Eliminating the copypasta by only using the constants from the classes that implement construction of those attributes is the actual right thing to do.