I'm just trying to do this: http://modernperlbooks.com/mt/2011/08/youre-already-using-dependency-injection.html. Really not deviating too much at all from that example code.
Here's what I've got:
package M;
use Moose;
use Exporter;
use Data::Dumper;
sub new {
print "M::new!\n";
my $class = shift;
return bless {}, $class;
}
sub x {
my ($self, $stuff) = #_;
print Dumper($stuff);
}
#################################
package Foo;
use Moose;
use Exporter;
our #ISA = qw(Exporter);
our #EXPORT = ();
has 'mS', is => 'ro', default => sub { M->new };
sub new {
my $class = shift;
return bless {}, $class;
}
sub bar {
my ($self, $data) = #_;
# do stuff here...
# ...
my $foo = $self->mS;
# this...
$foo->x($data);
# ...causes "Can't call method "x" on an undefined value at Foo.pm line 45."
}
1;
It's worth noting that the M::new! message never appears, so I'm guessing that it's never reached. What's going on?
With Moose, you shouldn't write sub new. Moose provides the constructor for you.
Also, using Exporter makes no sense with object-oriented modules. The following program works for me:
#!/usr/bin/perl
{ package M;
use Moose;
use Data::Dumper;
sub x {
my ($self, $stuff) = #_;
print Dumper($stuff);
}
}
{ package Foo;
use Moose;
has mS => ( is => 'ro', default => sub { 'M'->new } );
sub bar {
my ($self, $data) = #_;
my $foo = $self->mS;
$foo->x($data);
}
}
my $foo = 'Foo'->new;
$foo->bar('test');
You have a solution - don't write your own new() method when you're using Moose. But there's one other little point that might be worth making.
The constructor that Moose will give you for your Foo class will work pretty well as a drop-in replacement for your new() method. But the one that Moose gives you for your M class will be missing a feature - it won't print your "M::new!\n" message. How do we get round that?
In Moose, you can define a BUILD() method which will be called immediately after new() has returned a new object. That's a good place to put any extra initialisation that your new object needs. It would also be be a good place for your print() call (although it happens after object construction, not before - so it's not an exact replacement).
Related
I'm writing a subclass that encapsulates multiple objects of the parent class so I can call functions sort-of like a vector, something like this:
package OriginalClass;
sub new { return bless {bar => 123}, 'OriginalClass' }
sub foo { return shift->{bar}; }
1;
package NewClass;
use parent OriginalClass;
# Return a blessed arrayref of "OriginalClass" objects.
# new() would be called NewClass->new(OriginalClass->new(), ...)
sub new {
my $class = shift;
return bless \#_, 'NewClass';
}
# Vectorized foo(), returns a list of SUPER::foo() results:
sub foo
{
my $self = shift;
my #ret;
push #ret, $_->SUPER::foo() foreach #$self;
return #ret;
}
1;
I don't want to write a new vectorized function in NewClass for each function in OriginalClass, particularly for when OriginalClass adds new functions to be maintained (vectorized) in NewClass.
Question:
As I understand AUTOLOAD is slow, so is there a way to vectorize calls OriginalClass via something like NewClass without AUTOLOAD?
As I understand AUTOLOAD is slow
If AUTOLOAD generates the missing sub, then only the first call is "slow" since subsequent calls of the same method don't result in AUTOLOAD being called at all.
package NewClass;
use strict;
use warnings;
sub new {
my $class = shift;
return bless( \#_, $class );
}
sub AUTOLOAD {
my $method_name = our $AUTOLOAD =~ s/^.*:://sr;
my $method = sub {
my $self = shift;
return map { $_->$method_name( #_ ) } #$self;
};
{
no strict 'refs';
*$method_name = $method;
}
goto &$method;
}
1
Note that I didn't use parent and SUPER::. This isn't an inheritance relationship. And it would prevent AUTOLOAD from getting called since AUTOLOAD is only called when a method doesn't exist.
You can use Sub::Name to "name the sub" for better diagnostics.
use Sub::Name qw( subname );
my $method = subname $method_name => sub { ... };
But yes, AUTOLOAD can be avoided here, as long as you can get a list of the method names in advance.
package NewClass;
use strict;
use warnings;
sub new {
my $class = shift;
return bless( \#_, $class );
}
for my $method_name (qw( foo ... )) {
my $method = sub {
my $self = shift;
return map { $_->$method_name( #_ ) } #$self;
};
no strict 'refs';
*$method_name = $method;
}
1
The above uses a hardcoded list, but more dynamic solutions are possible. For example, the list could be obtained from inspecting the contents of the OriginalClass namespace for subs (filtering out new and anything else inappropriate such as names starting with _).
Module https://metacpan.org/pod/Array::Delegate could be helpful : it delegates method calls to an array of objects.
I'd like to be able to "inject" methods in a class on the fly, similarly to what happens with Mojolicious helpers. Something like this:
my $s = SomeThing->new;
$s->helper(do_this => sub {
my $self = shift;
$foo = shift;
});
$s->do_this('bar');
I've made it some distance, but I would like the subs that get injected to be operating in the namespace of the class they get injected into, not in the main one. In other words this currently works as follows:
$s->do_this('bar');
print 'in main: ', $foo;
this prints "bar" - and I'd like it not to, while I'd like this
print 'in SomeThing: ', $SomeThing::foo;
to print "bar" instead
while this works but seems clunky to me
$s->helper(do_this => sub {
my $self = shift;
${(ref $self) . '::foo'} = shift;
});
$s->do_this('foo');
print 'in SomeThing: ', $SomeThing::foo; # now this prints "foo"
The package where all this happens looks like this:
package SomeThing {
use Mojo::Base -base;
use Carp;
sub helper {
my $self = shift;
my $name = shift || croak "The helper name is required";
my $sub = shift || sub {};
my $namespace = __PACKAGE__;
no strict 'refs';
{
*{"$namespace\::$name"} = $sub
}
}
};
Is there a way to do this? I suspect I'd be messing up strictness real bad - but I kind of don't want to give up just yet (and it'd be a nice trick to learn).
You are asking to change the package associated with an already-compiled anon sub for the purpose of variable lookups. I don't know if that's possible.
Even if it was possible, it's not something you want to do because your code still wouldn't work. You'd have to add use vars qw( foo ); to the file in which the sub { } literal is found. And that's in addition to using our $foo; or use vars qw( $foo ); in Something.pm if you accessed it there.
That's pretty magical and messy. And it's easily avoided by using accessors. Simple replace
$s->helper(
do_this => sub {
my $self = shift;
$foo = shift;
},
);
with
$s->helper(
do_this => sub {
my $self = shift;
$self->foo(shift);
},
);
If you also need to add the accessor, you can use the following:
$s->helper(
foo => sub {
shift;
state $foo;
$foo = shift if #_;
$foo
},
do_this => sub {
my $self = shift;
$self->foo(shift);
},
);
As an aside, monkey_patch from Mojo::Util can be used as a replacement for helper. (Credit to #brian d foy for bringing it up.) It does the same thing, but it has the two added benefits:
You don't need to support it.
It sets the name of the anon sub so that stack traces use a meaningful name instead of __ANON__.
Switching to monkey_patch doesn't address your problem, but I do recommend using it (or similar) in addition to the change of approach I mentioned above.
use Mojo::Util qw( );
sub helper { shift; Mojo::Util::monkey_patch(__PACKAGE__, #_); }
Consider roles.
# role module
package SomeThing::Role::Foo;
use Role::Tiny;
sub foo { 42 }
1;
# user
use strict;
use warnings;
use SomeThing;
use With::Roles;
my $something_with_foo = SomeThing->with::roles('+Foo');
# new subclass of SomeThing, doesn't affect other usage of SomeThing
my $obj = $something_with_foo->new;
# can also dynamically apply to an existing object
my $obj = SomeThing->new->with::roles('+Foo');
print $obj->foo;
I want to create a hash reference with code references mapped to scalars (strings) as its members.
So far I have a map reference that looks something like this:
my $object;
$object = {
'code1' => sub {
print $_[0];
},
'code2' => sub {
return 'Hello, World!';
},
'code3' => sub {
$object->{code1}->($object->{code2}->());
}
};
$object->{code3}->();
I would like to be able to "bless" the 'code3' reference in $object with $object, so I can do something like:
my $object;
$object = {
'code1' => sub {
print $_[0];
},
'code2' => sub {
return 'Hello, World!';
},
'code3' => sub {
$self = shift;
$self->{code1}->($self->{code2}->());
}
};
$object->{code3}->();
However, bless only works with packages, rather than hash tables.
Is there a way to do this in Perl 5 version 22?
Note: now that I think of it, it's better to pass $object to the method explicitly, as it solves JavaScript's "this" problem. I am just too used to Java's "this" which makes sense in Java where everything is a class and therefore all methods have a "this", but in scripting, it really helps to know if the "this" is actually passed, or is it just called as a function(and you end up accidentally polluting global scope or triggering strict warning) passing $self explicitly makes it clear that you are not calling it as a function, but as a method.
You are doing sub calls (not method calls), so you simply forgot to pass $self as a parameter.
my $object = {
code1 => sub {
print $_[0];
},
code2 => sub {
return 'Hello, World!';
},
code3 => sub {
my $self = shift;
$self->{code1}->( $self, $self->{code2}->($self) );
}
};
$object->{code3}->($object);
But I think you're trying to create JavaScript-like objects. You can start with the following:
package PrototypeObject;
sub new {
my $class = shift;
my $self = bless({}, $class);
%$self = #_;
return $self;
}
sub AUTOLOAD {
my $self = shift;
( my $method = our $AUTOLOAD ) =~ s/^.*:://s;
return $self->{$method}->($self, #_);
}
1;
use PrototypeObject qw( );
my $object = PrototypeObject->new(
code1 => sub {
print $_[1];
},
code2 => sub {
return 'Hello, World!';
},
code3 => sub {
my $self = shift;
$self->code1( $self->code2() );
}
);
$object->code3();
Note that this will slow down your method calls as it must call AUTOLOAD before calling your method. This could be addressed by overloading the method call operator.
Check on CPAN. Someone might already have a more complete implementation.
This is not the exact syntax you want, but Perl 5 supports many ways of making method calls, including method calls via strings. So you could say:
#!/usr/bin/perl
{ package Foo;
use strict;
use warnings;
sub new { bless {}, shift }
sub code1 { my $self = shift; print "$_[0]\n" };
sub code2 { "Hello, World!" }
sub code3 {
my $self = shift;
my $method1 = "code1";
my $method2 = "code2";
$self->$method1($self->$method2);
}
}
use strict;
use warnings;
my $o = Foo->new;
print "normal call\n";
$o->code3;
print "via string\n";
my $method = "code3";
$o->$method;
Also, remember that a package's symbol table is a hash: %Foo::, so you can always go spelunking in there yourself:
#!/usr/bin/perl
{ package Foo;
use strict;
use warnings;
sub new { bless {}, shift }
sub code1 { my $self = shift; print "$_[0]\n" };
sub code2 { "Hello, World!" }
sub code3 {
my $self = shift;
my $method1 = "code1";
my $method2 = "code2";
$self->$method1($self->$method2);
}
}
use strict;
use warnings;
print $Foo::{code2}->(), "\n";
However, I would suggest having a really code reason for these techniques as it can make maintenance a nightmare (eg imaging trying to find all of the code calling Foo::approved, you can't just grep for "->approved" because the actual call is ->$state()).
I just read the comments and noticed you said
my concern with packages is that I can't seem to create packages at runtime, but I can create hash tables at runtime
Perl 5 does allow you to create packages at runtime. In fact, depending on how you define runtime, you can do anything at runtime with string eval as it reenters compile time when it is called. But there is also a pure-runtime method of manipulating the symbol tables with typeglobs:
#!/usr/bin/perl
{ package Foo;
use strict;
use warnings;
sub new { bless {}, shift }
}
use strict;
use warnings;
my $o = Foo->new;
# here we add functions at runtime to the package Foo
{
no warnings "once";
*Foo::code1 = sub { my $self = shift; print "$_[0]\n" };
*Foo::code2 = sub { "Hello, World!" };
*Foo::code3 = sub {
my $self = shift;
my $method1 = "code1";
my $method2 = "code2";
$self->$method1($self->$method2);
};
}
$o->code3;
Because Perl 5 is object oriented (and not object based like JavaScript) these methods are attached to all Foo objects. If you want individual objects have their own symbol tables, then I am there are certainly ways to do that. Off the top of my head, AUTOLOAD comes to mind:
#!/usr/bin/perl
{ package Foo;
use strict;
use Carp;
use warnings;
sub new {
bless {
symtab => {}
}, shift
}
sub AUTOLOAD {
my $self = shift;
our $AUTOLOAD;
my $method = $AUTOLOAD =~ s/.*:://r;
my (undef, $file, $line) = caller();
die "$method does not exist at $file line $line"
unless exists $self->{symtab}{$method};
$self->{symtab}{$method}->($self, #_);
}
sub DESTROY {} # prevent DESTROY method from being hijacked by AUTOLOAD
}
use v5.22;
use warnings;
my $o1 = Foo->new;
my $o2 = Foo->new;
$o1->{symtab}{inc} = sub { my $self = shift; $self->{i}++; };
$o1->inc;
$o1->inc;
$o1->inc;
say "inc called on o1 $o1->{i} times";
$o2->inc; #dies because we haven't defined inc for $o2 yet
Perl 5 is very flexible and will let you do just about anything you want (after all the motto is TIMTOWTDI), but you should always keep in mind the future programmer tasked with maintaining your code who may want to hunt you down and wear your skin for doing some of these tricks.
This question has a definite XY problem feel. It seems like you are trying to solve a problem in Perl 5 the same way you would have solved it in JavaScript. While Perl 5 will let you do that (as I have demonstrated), there may be a more idiomatic way of achieving the same effect. Can you describe what you are trying to do (not how you want to do it) in a different question and we can suggest the ways in which we would solve your problem.
I'd like to check on every call to my object's methods some value (in this case: token's age). Is it possible to set it to all methods at once? Like in constructor? I have such simple constructor:
sub new {
my $class = shift;
my %args = #_;
my $self = {};
$self->{key} = $args{key};
bless($self, $class);
($self->{token}, $self->{token_start}) = $self->_get_authorized_token();
return $self;
}
And bunch of methods, which depends of tokens age, like this:
sub add_item {
my $self = shift;
my %args = #_;
...
}
I'd like to avoid including age-checking in every method, so i look for more general way to implement it. Has there some?
All I can think of is to hide all your 'real' methods - either in the classical way with a preceding underscore, or in a hash of subroutines - and use AUTOLOAD to direct the call properly.
The example below shos the idea
module MyClass.pm
package MyClass;
use strict;
use warnings;
sub new {
bless {}, __PACKAGE__;
}
sub _method1 {
print "In method1\n";
}
sub _method2 {
print "In method2\n";
}
sub AUTOLOAD {
our $AUTOLOAD;
my ($class, $method) = $AUTOLOAD =~ /(.+)::(.+)/;
return if $method eq 'DESTROY';
my $newmethod = "${class}::_$method";
unless (exists &$newmethod) {
die qq(Can't locate object method "$method" via package "$class");
}
print "Preprocessing...\n";
goto &$newmethod
}
1;
program
use strict;
use warnings;
use MyClass;
my $thing = MyClass->new;
$thing->method1;
$thing->method2;
$thing->method3;
output
Preprocessing...
In method1
Preprocessing...
In method2
Can't locate object method "method3" via package "MyClass" at MyClass.pm line 23.
See Class::Method::Modifiers or Class::Method::Modifiers::Fast module.
I honestly think that if you're doing OO in Perl and you want to deal with things like attributes, method modifiers and deferred resource loading without the boilerplate, it's worth investing in learning Moose. To illustrate, this is one way to write what you want using Moose:
use Moose;
has key => (isa => 'Str', is => 'ro');
has token => (isa => 'HashRef', is => 'ro', lazy_build => 1);
before [qw(add_item method2 method3)] => sub {
my $self = shift;
if (do something with $self->token) {
# return, die, etc.
}
};
sub _build_token {
my $self = shift;
my $key = $self->key;
return { token => 'foo', token_start => time };
}
These might be helpful:
Moose::Manual::MethodModifiers
Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild
So I am toying with some black magic in Perl (eventually we all do :-) and I am a little confused as to exactly how I am supposed to be doing all of this. Here is what I'm starting with:
use strict;
use warnings;
use feature ':5.10';
my $classname = 'Frew';
my $foo = bless({ foo => 'bar' }, $classname);
no strict;
*{"$classname\::INC"} = sub {
use strict;
my $data = qq[
package $classname
warn 'test';
sub foo {
print "test?";
}
];
open my $fh, '<', \$data;
return $fh;
};
use strict;
unshift #INC, $foo;
require $foo;
use Data::Dumper;
warn Dumper(\#INC);
$classname->foo;
I get the following errors (depending on whether my require line is commented out):
With require:
Recursive call to Perl_load_module in PerlIO_find_layer at crazy.pl line 16.
BEGIN failed--compilation aborted.
without:
$VAR1 = [
bless( {
'foo' => 'bar'
}, 'Frew' ),
'C:/usr/site/lib',
'C:/usr/lib',
'.'
];
Can't locate object method "foo" via package "Frew" at crazy.pl line 24.
Any wizards who know some of this black magic already: please answer! I'd love to learn more of this arcana :-)
Also note: I know that I can do this kind of stuff with Moose and other lighter helper modules, I am mostly trying to learn, so recommendations to use such-and-such a module will not get my votes :-)
Update: Ok, I guess I wasn't quite clear originally with my question. I basically want to generate a Perl class with a string (that I will manipulate and do interpolation into) based on an external data structure. I imagine that going from what I have here (once it works) to that shouldn't be too hard.
Here is a version which works:
#!/usr/bin/perl
use strict;
use warnings;
my $class = 'Frew';
{
no strict 'refs';
*{ "${class}::INC" } = sub {
my ($self, $req) = #_;
return unless $req eq $class;
my $data = qq{
package $class;
sub foo { print "test!\n" };
1;
};
open my $fh, '<', \$data;
return $fh;
};
}
my $foo = bless { }, $class;
unshift #INC, $foo;
require $class;
$class->foo;
The #INC hook gets the name of the file (or string passed to require) as the second argument, and it gets called every time there is a require or use. So you have to check to make sure we're trying to load $classname and ignore all other cases, in which case perl continues down along #INC. Alternatively, you can put the hook at the end of #INC. This was the cause of your recursion errors.
ETA: IMHO, a much better way to achieve this would be to simply build the symbol table dynamically, rather than generating code as a string. For example:
no strict 'refs';
*{ "${class}::foo" } = sub { print "test!\n" };
*{ "${class}::new" } = sub { return bless { }, $class };
my $foo = $class->new;
$foo->foo;
No use or require is necessary, nor messing with evil #INC hooks.
I do this:
use MooseX::Declare;
my $class = class {
has 'foo' => (is => 'ro', isa => 'Str', required => 1);
method bar() {
say "Hello, world; foo is ", $self->foo;
}
};
Then you can use $class like any other metaclass:
my $instance = $class->name->new( foo => 'foo bar' );
$instance->foo; # foo-bar
$instance->bar; # Hello, world; foo is foo-bar
etc.
If you want to dynamically generate classes at runtime, you need to create the proper metaclass, instantiate it, and then use the metaclass instance to generate instances. Basic OO. Class::MOP handles all the details for you:
my $class = Class::MOP::Class->create_anon_class;
$class->add_method( foo => sub { say "Hello from foo" } );
my $instance = $class->new_object;
...
If you want to do it yourself so that you can waste your time debugging something, perhaps try:
sub generate_class_name {
state $i = 0;
return '__ANON__::'. $i++;
}
my $classname = generate_class_name();
eval qq{
package $classname;
sub new { my \$class = shift; bless {} => \$class }
...
};
my $instance = $classname->new;
For a simple example of how to do this, read the source of Class::Struct.
However, if I needed the ability to dynamically build classes for some production code, I'd look at MooseX::Declare, as suggested by jrockway.
A Perl class is little more than a data structure (usually a hashref)
that has been blessed into a package in which one or more class
methods are defined.
It is certainly possible to define multiple package namespaces in one
file; I don't see why this wouldn't be possible in an eval construct
that is compiled at run-time (see perlfunc for the two different
eval forms).
#!/usr/bin/perl
use 5.010;
use strict;
use warnings;
use Data::Dumper;
eval q[
package Foo;
sub new {
my ( $class, %args ) = #_;
my $self = bless { %args }, $class;
return $self;
}
1;
];
die $# if $#;
my $foo = Foo->new(bar => 1, baz => 2) or die;
say Dumper $foo;