I've made a "bundle" module which does a bunch of things: imports Moose, imports true, namespace::autoclean, makes the caller's class immutable (taken from MooseX::AutoImmute). The one thing I haven't been able to figure out is how to include MooseX::Method::Signatures.
Here's what I've got so far:
package My::OO;
use Moose::Exporter;
use Hook::AfterRuntime;
use Moose ();
use true ();
use namespace::autoclean ();
my ($import, $unimport, $init_meta) = Moose::Exporter->build_import_methods(
also => ['Moose'],
);
sub import {
true->import();
my $caller = scalar caller;
after_runtime { $caller->meta->make_immutable };
namespace::autoclean->import(-cleanee => $caller);
goto &$import;
}
sub unimport {
goto &$unimport;
}
1;
The idea is that in my code, I can now do things like this:
package My::Class; {
use My::OO;
extends 'My::Parent';
method foo() { ... }
}
but right now I still have to include an extra use MooseX::Method::Signatures;. How can I include that into my OO module?
First off, please note that the implementation of Hook::AfterRuntime is quite fragile. While it works for many simple things, it's extremely easy to end up with very hard to debug errors. I'd recommend just writing the ->meta->make_immutable yourself, or using other approaches to get around writing it, like MooseX::Declare, for example.
To answer your actual question:
MooseX::Method::Signatures->setup_for($your_caller);
Related
I am currently writing my first XS-module (just a wrapper around the C math-library) with ok-ish success. The biggest issue is the documentation that is quite hard to understand and/or is incomplete.
I have successfully written a constructor in XS and implemented some functions out of the library as method calls. That works fine.
Now I want to implement a procedural interface, too. For this reason I need to know if its a method call or not. If its a method call the number to compute with the function is stored in the instance, if its a procedural call to a function its a number given as the first argument.
This is the current code for the cosine-function:
double
cos(...)
CODE:
SV *arg = newSVsv(ST(0));
if (sv_isobject(arg)) {
HV *self_hv = MUTABLE_HV(SvRV(arg));
SV **callback_ptr = hv_fetchs(self_hv, "Number", 0);
SV *zahl = *callback_ptr;
}
else {
SV *zahl = newSVnv(arg);
}
double x = SvNV(zahl);
RETVAL = cos(x);
OUTPUT:
RETVAL
Generally speaking, writing subs which are intended to be called as either methods or functions is a bad idea. There are one or two well known modules that do this (CGI.pm springs to mind), but for the most part this is confusing for end users, and unnecessarily complicates your own code. Nobody will thank you for it. Pick one style and stick with it.
Let's assume you've chosen to stick with OO programming. Then, once your module is working and tested, you can write a second module, offering exportable functions instead of an OO interface. The second module can probably be written in plain old Perl, just acting as a wrapper around your OO module.
As an example, using pure Perl (and not XS) for readability:
use v5.14;
package MyStuff::Maths::OO {
use Class::Tiny qw(number);
sub cosine {
my $self = shift;
my $number = $self->number;
...;
return $cosine;
}
}
package MyStuff::Maths::Functional {
use Exporter::Shiny qw(cosine);
sub cosine {
my $obj = ref($_[0]) ? $_[0] : MyStuff::Maths::OO->new(number => $_[0]);
return $obj->cosine;
}
}
Now end users can choose to use your OO interface like this:
use v5.14;
use MyStuff::Maths::OO;
my $obj = MyStuff::Maths::OO->new(number => 0.5);
say $obj->cosine;
Or use the functional interface:
use v5.14;
use MyStuff::Maths::Functional -all;
say cosine(0.5);
In my case it was a simple problem, and I simply didn't see it. The declaration of the SV *zahl inside the if-else-statement was the problem. Predeclaration before the if was the key to the solution.
But I agree with tobyinks solution for modules that get used by other people or published somewhere.
I have a Moose BaseDBModel which has different subclasses mapping to my tables in the database. All the methods in the subclasses are like "get_xxx" or "update_xxx" which refers to the different DB operations.
Now i want to implement a cache system for all these methods, so my idea is "before" all methods named like "get_xxx", I will search the name of the method as key in my memcache pool for value. If i found the value, then I will return the value directly instead of method.
ideally, my code is like this
BaseDBModel
package Speed::Module::BaseDBModel;
use Moose;
sub BUILD {
my $self = shift;
for my $method ($self->meta->get_method_list()){
if($method =~ /^get_/){
$self->meta->add_before_method_modifier($method,sub {
warn $method;
find_value_by_method_name($method);
[return_value_if_found_value]
});
}
}
}
SubClasses Example 1
package Speed::Module::Character;
use Moose;
extends 'Speed::Module::BaseDBModel';
method get_character_by_id {
xxxx
}
Now my problem is that when my program is running, it's repeatedly modify the methods, for example:
restart apache
visit the page which will call get_character_by_id, so I can see one warning message
Codes:
my $db_character = Speed::Module::Character->new(glr => $self->glr);
$character_state = $db_character->get_character_by_id($cid);
Warnings:
get_character_by_id at /Users/dyk/Sites/speed/lib/Speed/Module/BaseDBModel.pm line 60.
but if I refresh the page, I saw 2 warning messages
Warnings:
get_character_by_id at /Users/dyk/Sites/speed/lib/Speed/Module/BaseDBModel.pm line 60.
get_character_by_id at /Users/dyk/Sites/speed/lib/Speed/Module/BaseDBModel.pm line 60.
I am using mod_perl 2.0 with apache, every time i refresh the page, my get_character_by_id method will be modified which I don't want
Isn't your BUILD doing the add_before every time you construct a new instance? I'm not sure that's what you want.
Well, the simple/clunky way would be to set some package-level flag so you only do it once.
Otherwise, I think you want to hook into Moose's own attribute building. Have a look at this: http://www.perlmonks.org/?node_id=948231
The problem is BUILD runs every time your create an object (i.e. after every ->new() call), but add_before_method_modifier adds modifier to class, i.e. to all objects.
Simple solution
Mind, that use calls import function from used package every time. That is the place where you want to add modifiers.
Parent:
package Parent;
use Moose;
sub import {
my ($class) = #_;
foreach my $method ($class->meta->get_method_list) {
if ($method =~ /^get_/) {
$class->meta->add_before_method_modifier($method, sub {
warn $method
});
}
}
}
1;
Child1:
package Child1;
use Moose;
extends 'Parent';
sub get_a { 'a' }
1;
Child2:
package Child2;
use Moose;
extends 'Parent';
sub get_b { 'b' }
1;
So now it works as expected:
$ perl -e 'use Child1; use Child2; Child1->new->get_a; Child2->new->get_b; Child1->new->get_a;'
get_a at Parent.pm line 11.
get_b at Parent.pm line 11.
get_a at Parent.pm line 11.
Cleaner solution
Since you can't be 100% sure import will be called (since you can't be sure use will be used) the more cleaner and straightforward solution is just add something like use My::Getter::Cacher in every derived class.
package My::Getter::Cacher;
sub import {
my $class = [caller]->[0];
# ...
}
In this case every derived class should contain both extends 'Parent' and use My::Getter::Cacher since the first line is about inheritance while the second is about adding before modifier. You may count it a bit redundant, but as I said I believe it's more cleaner and straightforward.
P. S.
Maybe you should give a glance at Memoize module.
Is it possible to replace a method of a Moose object at runtime ?
By looking at the source code of Class::MOP::Method (which Moose::Meta::Method inherits from) I concluded that by doing
$method->{body} = sub{ my stuff }
I would be able to replace at runtime a method of an object.
I can get the method using
$object->meta->find_method_by_name(<method_name>);
However, this didn't quite work out.
Is it conceivable to modify methods at run time? And, what is the way to do it with Moose?
Moose or not, that does not sound like a good idea.
Instead, design your object to have an accessor for the method. For example, users of your class can use My::Frobnicator->frobnicator->() to get and invoke the frobnicator method and use My::Frobnicator->frobnicator(sub { } ) to set it.
Sinan's idea is a great start.
But with an little extra tweak, you can make using your method accessor just like using a normal method.
#!/usr/bin/perl
use strict;
use warnings;
use Carp;
my $f = Frob->new;
$f->frob(
sub {
my $self = shift;
print "$self was frobbed\n";
print Carp::longmess('frob')
}
);
print "\nCall frob as normal sub\n";
$f->frobit;
print "\nGoto frob\n";
$f->goto_frob;
BEGIN {
package Frob;
use Moose;
has 'frob' => (
is => 'rw',
isa => 'CodeRef',
);
sub frobit {
&{$_[0]->frob};
}
sub goto_frob {
goto $_[0]->frob;
}
}
The two methods in Frob are very similar.
frobit passes all arguments, including the invocant to the code ref.
goto_frob passes all arguments, including the invocant to the code ref, and replaces goto_frob's stack frame with the code refs.
Which to use depends on what you want in the stack.
Regarding munging the body storage of a Class::MOP::Method object, like so $method->{body} = sub { 'foo' }:
It's never a good idea to violate encapsulation when you are doing OOP. Especially not when you are working with complex object systems like Moose and Class::MOP. It's asking for trouble. Sometimes, there is no other way to get what you want, but even then, violating encapsulation is still a bad idea.
Using the previously mentioned MooseX::SingletonMethod you can replace an objects method.
For example:
{
package Foo;
use MooseX::SingletonMethod;
sub foo { say 'bar' };
}
my $bar = Foo->new;
my $baz = Foo->new;
# replace foo method just in $baz object
$baz->add_singleton_method( foo => sub { say 'baz' } );
$bar->foo; # => bar
$baz->foo; # => baz
Also see this SO answer to What should I do with an object that should no longer be used in Perl?, which shows how this can be achieved using Moose roles.
/I3az/
I simply hate how CGI::Application's accessor for the CGI object is called query.
I would like my instance classes to be able to use an accessor named cgi to get the CGI object associated with the current instance of my CGI::Application subclass.
Here is a self-contained example of what I am doing:
package My::Hello;
sub hello {
my $self =shift;
print "Hello #_\n";
}
package My::Merhaba;
use base 'My::Hello';
sub merhaba {
goto sub { shift->hello(#_) };
}
package main;
My::Merhaba->merhaba('StackOverflow');
This is working as I think it should and I cannot see any problems (say, if I wanted to inherit from My::Merhaba: Subclasses need not know anything about merhaba).
Would it have been better/more correct to write
sub merhaba {
my $self = shift;
return $self->hello(#_);
}
What are the advantages/disadvantages of using goto &NAME for the purpose of aliasing a method name? Is there a better way?
Note: If you have an urge to respond with goto is evil don't do it because this use of Perl's goto is different than what you have in mind.
Your approach with goto is the right one, because it will ensure that caller / wantarray and the like keep working properly.
I would setup the new method like this:
sub merhaba {
if (my $method = eval {$_[0]->can('hello')}) {
goto &$method
} else {
# error code here
}
}
Or if you don't want to use inheritance, you can add the new method to the existing package from your calling code:
*My::Hello::merhaba = \&My::Hello::hello;
# or you can use = My::Hello->can('hello');
then you can call:
My::Hello->merhaba('StackOverflow');
and get the desired result.
Either way would work, the inheritance route is more maintainable, but adding the method to the existing package would result in faster method calls.
Edit:
As pointed out in the comments, there are a few cases were the glob assignment will run afoul with inheritance, so if in doubt, use the first method (creating a new method in a sub package).
Michael Carman suggested combining both techniques into a self redefining function:
sub merhaba {
if (my $method = eval { $_[0]->can('hello') }) {
no warnings 'redefine';
*merhaba = $method;
goto &merhaba;
}
die "Can't make 'merhaba' an alias for 'hello'";
}
You can alias the subroutines by manipulating the symbol table:
*My::Merhaba::merhaba = \&My::Hello::hello;
Some examples can be found here.
I'm not sure what the right way is, but Adam Kennedy uses your second method (i.e. without goto) in Method::Alias (click here to go directly to the source code).
This is sort of a combination of Quick-n-Dirty with a modicum of indirection using UNIVERSAL::can.
package My::Merhaba;
use base 'My::Hello';
# ...
*merhaba = __PACKAGE__->can( 'hello' );
And you'll have a sub called "merhaba" in this package that aliases My::Hello::hello. You are simply saying that whatever this package would otherwise do under the name hello it can do under the name merhaba.
However, this is insufficient in the possibility that some code decorator might change the sub that *My::Hello::hello{CODE} points to. In that case, Method::Alias might be the appropriate way to specify a method, as molecules suggests.
However, if it is a rather well-controlled library where you control both the parent and child categories, then the method above is slimmmer.
some time ago, I asked This question about overriding building perl functions.
How do I do this in a way that allows multiple overrides? The following code yields an infinite recursion.
What's the proper way to do this? If I redefine a function, I don't want to step on someone else's redefinition.
package first;
my $orig_system1;
sub mysystem {
my #args = #_;
print("in first mysystem\n");
return &{$orig_system1}(#args);
}
BEGIN {
if (defined(my $orig = \&CORE::GLOBAL::system)) {
$orig_system1 = $orig;
*CORE::GLOBAL::system = \&first::mysystem;
printf("first defined\n");
} else {
printf("no orig for first\n");
}
}
package main;
system("echo hello world");
The proper way to do it is not to do it. Find some other way to accomplish what you're doing. This technique has all the problems of a global variable, squared. Unless you get your rewrite of the function exactly right, you could break all sorts of code you never even knew existed. And while you might be polite in not blowing over an existing override, somebody else probably will not be.
Overriding system is particularly touchy because it does not have a proper prototype. This is because it does things not expressible in the prototype system. This means your override cannot do some things that system can. Namely...
system {$program} #args;
This is a valid way to call system, though you need to read the exec docs to do it. You might think "oh, well I just won't do that then", but if any module that you use does it, or any module it uses does it, then you're out of luck.
That said, there's little different from overriding any other function politely. You have to trap the existing function and be sure you call it in your new one. Whether you do it before or after is up to you.
The problem in your code is that the proper way to check if a function is defined is defined &function. Taking a code ref, even of an undefined function, will always return a true code ref. I'm not sure why, maybe its like how \undef will return a scalar ref. Why calling this code ref is causing mysystem() to go infinitely recursive is anyone's guess.
There's an additional complexity in that you can't take a reference to a core function. \&CORE::system doesn't do what you mean. Nor can you get at it with a symbolic reference. So if you want to call CORE::system or an existing override depending on which is defined you can't just assign one or the other to a code ref. You have to split your logic.
Here is one way to do it.
package first;
use strict;
use warnings;
sub override_system {
my $after = shift;
my $code;
if( defined &CORE::GLOBAL::system ) {
my $original = \&CORE::GLOBAL::system;
$code = sub {
my $exit = $original->(#_);
return $after->($exit, #_);
};
}
else {
$code = sub {
my $exit = CORE::system(#_);
return $after->($exit, #_);
};
}
no warnings 'redefine';
*CORE::GLOBAL::system = $code;
}
sub mysystem {
my($exit, #args) = #_;
print("in first mysystem, got $exit and #args\n");
}
BEGIN { override_system(\&mysystem) }
package main;
system("echo hello world");
Note that I've changed mysystem() to merely be a hook that runs after the real system. It gets all the arguments and the exit code, and it can change the exit code, but it doesn't change what system() actually does. Adding before/after hooks is the only thing you can do if you want to honor an existing override. Its quite a bit safer anyway. The mess of overriding system is now in a subroutine to keep BEGIN from getting too cluttered.
You should be able to modify this for your needs.