OO-Perl Aliasing Class Attributes - perl

I have a module that I'm working on. I am setting up a few attributes like this:
$self->{FOO};
$self->{BAR};
$self->{FOOBAR};
And, I want to use AUTOLOAD to help create methods for accessing these attributes. For example, $foo->Bar() returns the value of $self->{BAR}. No problem. Everything is standard.
Now, I want to create alias Methods. For example, if someone says $obj->Fu();, I'll return $self->{FOO}. What I'd like to do is create a $self->{FU} that points to the same memory location as $self->{FOO}. That way, when I set the value of $self->{FOO}, $self-{FU} is also set. This way, I don't have to make all sorts of changes in the way AUTOLOAD works or remember to set $self->{FU} whenever I set $self->{FOO}.
Any easy way of doing this?

Yes, use Moose, rather than attempting to make explicit mapping between hash
keys. Writing your own accessors, or using AUTOLOAD, is not necessary and has
a much higher chance of error:
package MyClass;
use Moose;
use MooseX::Aliases;
has foo => (
is => 'rw', isa => 'Str',
alias => 'fu',
);
has bar => (
is => 'rw', isa => 'Str',
);
__PACKAGE__->meta->make_immutable;
no Moose;
1;
package main;
use strict;
use warnings;
use MyClass;
my $obj = MyClass->new;
$obj->foo("value");
$obj->fu("a new value");
# prints "foo has the value 'a new value'"
print "foo has the value '", $obj->foo, "'\n";

I would recommend Moose over what you're doing, but the easiest way to accomplish what you're asking is probably this:
sub Fu { shift->Foo(#_) }
This way, it doesn't matter if Foo is autoloaded or not.

The non-Moose solution is to just create an alias in the symbol table. It's not a common thing to do, and I suspect that whatever you are trying to do has a better way, Moose or otherwise. Don't use any of this if you can avoid it with a better design or interface, which are often the superior solutions to things like this.
In this AUTOLOAD routine, I look at a %Aliases hash to figure out other methods else I have to define. When I have aliases, I make proper aliases in the symbol table. It's a bit ugly, but it avoids adding another actual method in the call stack:
#!perl
use 5.010;
{
package SomeClass;
use Carp;
use vars qw($AUTOLOAD);
sub new {
return bless {
map { $_, undef } qw(FOO BAR FOOBAR)
}, $_[0];
};
my %Aliases = (
FOO => [ qw(fu) ],
);
sub AUTOLOAD {
our $method = $AUTOLOAD;
$method =~ s/.*:://;
carp "Autoloading $method";
{
no strict 'refs';
*{"$method"} = sub {
#_ > 1
?
$_[0]->{"\U$method"} = $_[1]
:
$_[0]->{"\U$method"}
};
foreach my $alias ( #{ $Aliases{"\U$method"} } ) {
*{"$alias"} = *{"$method"};
}
goto &{"$method"};
}
}
sub DESTROY { 1 }
}
my $object = SomeClass->new;
$object->foo(5);
say "Foo is now ", $object->foo;
say "Foo is now ", $object->foo(9);
say "Fu is now ", $object->fu;
say "Fu is set to ", $object->fu(17);
say "Foo is now ", $object->foo;
Now foo and fu access the same thing:
Foo is now 5
Foo is now 9
Fu is now 9
Fu is set to 17
Foo is now 17

Related

How to add a new syntax feature for perl?

I want to add a new feature for Perl language, in order to type less $self->.
For example, Translate:
use Moo;
has a_attr => (is=>'rw');
sub XXX {
print $self->a_attr;
}
To:
use Moo;
use MyFeatureModule;
has a_attr => (is=>'rw');
sub XXX {
print _a_attr;
}
How-to?
This doesn't require any changes to Perl's syntax, only to its semantics. Luckily, that's not too hard.
What you want can be achieved by providing an AUTOLOAD sub for your package, which will kick in automatically whenever you call a sub that hasn't been defined yet (i.e. _a_attr in your example). This AUTOLOAD method can then use Devel::Caller to grab $_[0] (i.e. $self) from its caller, inject it onto #_ and then goto the original method.
use v5.14;
use strictures;
package Foo {
use Moo;
has xyzzy => (is => 'ro', default => 42);
sub sayit {
say _xyzzy();
}
sub AUTOLOAD {
require Devel::Caller;
my ($invocant) = Devel::Caller::caller_args(1);
unshift #_, $invocant;
my ($method) = (our $AUTOLOAD =~ /::_(\w+)\z/)
or die "Method not found!";
my $coderef = $invocant->can($method)
or die "Method not found!";
goto $coderef;
};
}
my $obj = Foo->new;
$obj->sayit;
Is this a good idea? Well, I certainly wouldn't do it. As well as introducing an unnecessary level of slow-down to your code, and breaking inheritance, it is likely to confuse anybody who has to maintain your code after you. (And that might be your future self if you take a break from the project, and come back to it in 6 months.)

How can I apply a Moose method modifier to a method based on a method attribute?

I want to apply a Moose 'before' method modifier to a number of methods in my class. I want to provide the modifier method in a role. I can do it a bit like this:
package MyApp::Role;
use Moose::Role
before [qw(foo bar)] => sub {
...
};
package MyApp;
use Moose;
with (MyApp::Role);
sub foo { ... }
sub bar { ... }
sub baz { ... } # this method is unaffected
However, having to maintain the list of relevant methods in the role ties it to the consuming class and that just seems wrong. I would like to do it a smarter way, like with method attributes:
package MyApp;
use Moose;
with (MyApp::Role);
sub foo :SomeFlag { ... }
sub bar :SomeFlag { ... }
sub baz { ... } # this method is unaffected
I'm not familiar with how to identify method attributes or how I would dynamically apply method modifiers to them.
Or, maybe there is a better way of doing this?
Let's use Attribute::Handlers for this – a fairly sane way to use attributes. We must define a function in a base class which itself has the attribute :ATTR(CODE). This takes a number of arguments:
The package where the sub (or other variable) comes from.
A globref, or the string ANON.
A reference to the value (here: coderef).
The name of the attribute.
Optional data for the attribute.
The (compilation) phase where the attribute was invoked.
The filename where the sub was declared.
The line number where the sub was declared.
So what we can do is to write a handler that applies a before:
use strict; use warnings; use feature 'say';
BEGIN {
package MyRole;
use Moose::Role;
use Attribute::Handlers;
sub SomeFlag :ATTR(CODE) {
my ($package, $globref, $code, $attr, $data, $phase, $filename, $line) = #_;
ref($globref) eq 'GLOB'
or die "Only global subroutines can be decorated with :SomeFlag"
. " at $filename line $line.\n";
# use the MOP to install the method modifier
$package->meta->add_before_method_modifier(
*$globref{NAME} => sub {
warn "Just about to call a flagged sub!";
},
);
}
}
BEGIN {
package MyApp;
use Moose;
# important: SomeFlag must be available before the attrs are handled (CHECK phase)
BEGIN { with 'MyRole' };
sub foo :SomeFlag { say "Hi from foo sub!" }
sub bar :SomeFlag { say "Hi from bar sub!" }
sub baz { say "Hi from baz sub!" }
}
package main;
my $o = MyApp->new;
$o->$_ for qw/foo bar baz/;
I stuffed all of this into a single file, but that obviously isn't neccessary (just add the required uses).
Output:
Just about to call a flagged sub! at so.pl line 16.
Hi from foo sub!
Just about to call a flagged sub! at so.pl line 16.
Hi from bar sub!
Hi from baz sub!

Using a Moose alias with MooseX::Constructor::AllErrors

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.

How can I create internal (private) Moose object variables (attributes)?

I would like some attributes (perhaps this is the wrong term in this context) to be private, that is, only internal for the object use - can't be read or written from the outside.
For example, think of some internal variable that counts the number of times any of a set of methods was called.
Where and how should I define such a variable?
The Moose::Manual::Attributes shows the following way to create private attributes:
has '_genetic_code' => (
is => 'ro',
lazy => 1,
builder => '_build_genetic_code',
init_arg => undef,
);
Setting init_arg means this attribute cannot be set at the constructor. Make it a rw or add writer if you need to update it.
/I3az/
You can try something like this:
has 'call_counter' => (
is => 'ro',
writer => '_set_call_counter',
);
is => 'ro' makes the attribute read only. Moose generates a getter. Your methods will use the getter for incrementing the value, like so:
sub called {
my $self = shift;
$self->_set_call_counter( $self->call_counter + 1 );
...
}
writer => '_set_call_counter' generates a setter named _set_call_counter. Moose does not support true private attributes. Outside code can, technically, call _set_call_counter. By convention, though, applications do not call methods beginning with an underscore.
I think you want MooseX::Privacy.
The perldoc tells you all you should need - it adds a new trait to your attributes allowing you to declare them as private or protected:
has config => (
is => 'rw',
isa => 'Some::Config',
traits => [qw/Private/],
);
I haven't been able to figure out a way to make Moose attributes completely private. Whenever I use has 'name' => (...); to create an attribute, it is always exposed to reading at a minimum. For items I want to be truly private, I'm using standard "my" variables inside the Moose package. For a quick example, take the following module "CountingObject.pm".
package CountingObject;
use Moose;
my $cntr = 0;
sub add_one { $cntr++; }
sub get_count { return $cntr; }
1;
Scripts that use that module have no direct access to the $cntr variable. They must use the "add_one" and "get_count" methods which act as an interface to the outside world. For example:
#!/usr/bin/perl
### Call and create
use CountingObject;
my $co = CountingObject->new();
### This works: prints 0
printf( "%s\n", $co->get_count() );
### This works to update $cntr through the method
for (1..10) { $co->add_one(); }
### This works: prints 10
printf( "%s\n", $co->get_count() );
### Direct access won't work. These would fail:
# say $cntr;
# say $co->cntr;
I'm new to Moose, but as far as I can tell, this approach provides completely private variables.
Alan W. Smith provided a private class variable with a lexical variable, but it is shared by all objects in the class. Try adding a new object to the end of the example script:
my $c1 = CountingObject->new();
printf( "%s\n", $c1->get_count() );
# also shows a count of 10, same as $co
Using MooseX:Privacy is a good answer, though if you can't, you can borrow a trick from the inside-out object camp:
package CountingObject;
use Moose;
my %cntr;
sub BUILD { my $self = shift; $cntr{$self} = 0 }
sub add_one { my $self = shift; $cntr{$self}++; }
sub get_count { my $self = shift; return $cntr{$self}; }
1;
With that, each object's counter is stored as an entry in a lexical hash. The above can be implemented a little more tersely thus:
package CountingObject;
use Moose;
my %cntr;
sub add_one { $cntr{$_[0]}++ }
sub get_count { return $cntr{$_[0]}||0 }
1;

How can I import global variables from a base module?

I created a module Foo::Prototype with the global variables $A and $B. I want the package Foo::Bar that uses Foo::Prototype as a base to import the global variable $A and $B. I could not figure how to do that.
I understand that using global variables is not a good practice in general, but in this case I want to use them.
The code looks like this:
package Foo:Prototype;
my ($A, $B);
our #EXPORT = qw($A $B);
sub new {
[...]
$A = 1;
$B = 2;
}
1;
package Foo:Bar;
use base Foo:Prototype qw($A $B);
sub test {
print $A, "\n";
print $B, "\n";
}
1;
# test.pl
Foo:Bar->new();
Foo:Bar->test();
Edit:
I want to make writing sub classes of Foo::Prototype as compact as possible for other people. Instead of having to write $self->{A}->foo(), I'd rather let people write $A->foo().
Well, there are a few of issues:
As brian points out, your problem can probably be solved better without using global variables. If you describe what you are trying to achieve rather than how, we may be able to provide better answers.
If you are going to export stuff, you either need a sub import or you need to inherit from Exporter. See perldoc Exporter.
It is not clear where you want the call to new to occur.
As Greg points out in a comment below, variables declared with my at package scope cannot be exported. Therefore, I declared $A and $B using our.
Here is something that "works" but you are going to have to do some reading and thinking before deciding if this is the way you want to go.
T.pm:
package T;
use strict;
use warnings;
use base 'Exporter';
our ($A, $B);
our #EXPORT = qw($A $B);
sub new {
$A = 1;
$B = 2;
}
"EOF T.pm"
U.pm:
package U;
use strict;
use warnings;
use base 'T';
use T;
sub test {
my $self = shift;
print "$_\n" for $A, $B;
}
"EOF U.pm"
t.pl:
#!/usr/perl/bin
use strict;
use warnings;
use U;
U->new;
U->test;
C:\Temp> t.pl
1
2
The trick is to not have to export variables. That's a very poor way to program.
Maybe there's a better way to accomplish whatever you want to do. You just have to tell us why you're trying to do that.
Based on your edit, $A and $B will be used to call methods on.
So, I assume that they are singleton objects stored as class data for the base class.
If you expose them as variables, they can be easily altered and all kinds of problems can occur.
Why not use an accessor?
package Foo::Proto;
my $A;
my $B;
sub A {
return $A;
}
sub B {
return $B;
}
package Foo::Child;
our #ISA= qw(Foo::Prototype);
sub test {
my $self = shift;
$self->A->blah();
# Or if I am doing many things with A, and want to type less:
my $A = $self->A;
$A->blah();
}
package Foo::Kid;
our #ISA= qw(Foo::Prototype);
# If you will never change $A in the prototype, you could do this:
my $A = __PACKAGE__->A;
sub test {
$A->blah();
}
But all this seems like a lot of mucking about.
To solve this problem in my code I would use Moose, and then create a role to bring in A and B related methods.
my $m = Foo::Mooseling->new();
$m->test_A();
$m->test_B();
BEGIN { # This is going to be $A, I needed something to call $A->foo on.
package Thing1;
sub new { bless {}, __PACKAGE__; }
sub foo { print __PACKAGE__."::foo()\n"; }
sub blah { print __PACKAGE__."::blah()\n"; }
}
BEGIN { # This is going to be B. It is not interesting either.
package Thing2;
sub new { bless {}, __PACKAGE__; }
sub bar { print __PACKAGE__."::bar()\n"; }
sub bluh { print __PACKAGE__."::bluh()\n"; }
}
# This is the interesting part:
BEGIN { # This ROLE will provide A and B methods to any objects that include it.
package Foo::ProtoMoose;
use Moose::Role;
has 'A' => (
is => 'ro',
isa => 'Thing1',
handles => [qw( foo blah )], # Delegate calls to foo and blah for consuming object to this A.
default => sub { Thing1->new(); }, # Create a Thing1 to be A.
);
has 'B' => (
is => 'ro',
isa => 'Thing2',
handles => [qw( bar bluh )],
default => sub { Thing2->new(); },
);
}
BEGIN { # This method consumes the ProtoMoose Role.
package Foo::Mooseling;
use Moose;
with 'Foo::ProtoMoose';
sub test_A {
my $class = shift;
$class->foo;
$class->blah;
}
sub test_B {
my $class = shift;
$class->bar;
$class->bluh;
}
}
If you want Thing1 and Thing2 to be singletons, use MooseX::Singleton.