This is the mock module I'm using:
http://metacpan.org/pod/Test::MockModule
How to mock sub a to sub b,
where sub b just does something else before call sub a?
sub b {
#do something else
a(#_);
}
You can grab the un-mocked method with can ( UNIVERSAL::can ). After that you can either goto it or just use the ampersand calling style to pass the same arguments. That's what I did below.
my $old_a = Package::To::Be::Mocked->can( 'a' );
$pkg->mock( a => sub {
# do some stuff
&$old_a;
});
This of course assumes that your sub isn't AUTOLOAD or generated through AUTOLOAD without redefining can. (I learned years back that if you're going to mess with AUTOLOAD, it's probably best to do the work in can.)
You could also create your own utility that does this automatically, by invading modifying the Test::MockModule's namespace.
{ package Test::MockModule;
sub modify {
my ( $self, $name, $modfunc ) = #_;
my $mock_class = $self->get_package();
my $old_meth = $mock_class->can( $name );
croak( "Method $name not defined for $mock_class!" ) unless $old_meth;
return $self->mock( $name => $modfunc->( $old_meth ));
}
}
And you could call it like so:
$mock->modify( a => sub {
my $old_a = shift;
return sub {
my ( $self ) = #_;
# my stuff and I can mess with $self
local $Carp::CarpLevel += 1;
my #returns = &$old_a;
# do stuff with returns
return #returns;
};
});
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've built a module that uses Type::Tiny and it's working fine.
Now I have to write a TO_JSON subroutine and I'm hoping I don't have to write a deflate method for each piece of data. Is there a way to define a deflation method in the type definition with Type::Tiny? An 'uncoerce' so to speak. I haven't found anything in the docs but I may just not be looking for the right keyword.
I am not using an object frame like Moo or Moose, but I am using an object for the data.
A simplified example looks like
package My::Object::Types;
# the usual stuff, strict, etc.
my $meta = __PACKAGE__->meta;
my $_Date = Type::Tiny::Class->new( class => 'Time::Piece' );
my $_Due = $meta->add_type(
name => 'Due',
parent => $_Date,
);
package My::Object;
# again, the usual strict, warnings, etc.
sub new {
my ( $class, $args ) = #_;
my $self = bless {}, $class;
for my $attr ( keys %$args ) {
my $type = ucfirst $attr;
my $set_attribute = "set_$attr";
*$set_attribute = sub {
my ( $self, $value ) = #_;
$value = $self->$type->assert_coerce( $value ) if $self->$type->has_coercion;
my $invalid = $self->$type->validate( $value );
carp $invalid && return if $invalid;
$self->{data}{$attr} = $value;
};
$attr = sub { return $_[0]->{data}{$attr} };
}
return $self;
}
Answering my own question ... I must write my own deflate methods.
Is there any way to achieve partial application in Perl?
Suppose, I want to do something like:
sub each_file($arr, $op) {
$op->($_) for #{$arr};
...
}
sub each_line($op, $file) {
...
}
each_file($arr, each_line($op));
I want to partially apply each_line() to only $op, so it'll become a new function can be passed to $each_file, how do I express this in idiomatic Perl?
You can do this in Perl with two approaches combined:
A function which returns a function reference
Closures
Example:
sub each_file {
my ($arr, $line_fn) = #_;
$line_fn->($_) for #{$arr};
...
}
sub each_line {
my ($op, $file) = #_;
...
}
sub make_line_processor {
my ( $op ) = #_;
# This is closed over $op, which effectively becomes
# a constant for the returned function
my $fn = sub {
return each_line( $op, #_ );
};
return $fn;
}
# To call it:
each_file( $arr, make_line_processor($op) );
This can be an even more useful technique in cases where you don't want $op directly, but some expensive-to-fetch derivation of it. In which case you would calculate the derived value just once (in the make_line_processor function) and close over that instead.
# given some $op as implied by your code snippet
each_file($arr, sub { each_line($op, shift) });
# shift op will be applied when anonymous sub { … } is called
(Your code snippet doesn't make it entirely clear what you intend $op to be when you make the call to each_line. It's usually better to present small working programs.)
You can roll this functionality up into a class. Then you can overload the subroutine dereference operator to make it look like your class is really a code reference.
package Partial;
use overload '&{}' => \&call;
sub new {
my $class = shift;
my $code = shift;
bless {code => $code, args => \#_}, $class;
}
sub call {
my ($self) = #_;
return sub{ $self->{code}->(#{$self->{args}}, #_) }
}
You can then use it like this:
sub printArgs {
print join ", ", #_;
print "\n";
}
my $partial = Partial->new(\&printArgs, 'foo', 'bar');
$partial->('baz', 'bat');
# prints foo, bar, baz, bat
How can I pass a reference to a module's function as parameter in a function call of another module?
I tried the following (simple example):
This is the module that has a function (process_staff) that takes as a parameter a function reference (is_ok).
#!/usr/bin/perl
use strict;
use warnings;
package Objs::Processing;
sub new {
my ($class) = #_;
bless {} ;
}
sub process_staff {
my ($employee, $func) = #_;
if($func->is_ok($employee)) {
print "Is ok to process\n";
}
else {
print "Not ok to process\n";
}
}
1;
This is the module that implements the passed function (is_ok)
#!usr/bin/perl
use strict;
use warnings;
package Objs::Employee;
my $started;
sub new {
my ($class) = #_;
my $cur_time = localtime;
my $self = {
started => $cur_time,
};
print "Time: $cur_time \n";
bless $self;
}
sub get_started {
my ($class) = #_;
return $class->{started};
}
sub set_started {
my ($class, $value) = #_;
$class->{started} = $value;
}
sub is_ok {
my ($emp) = #_;
print "In is ok I received:\n";
use Data::Dumper;
print Dumper($emp);
return 1;
}
This is my test script that I run:
#!/usr/bin/perl
use strict;
use warnings;
use Objs::Manager;
use Objs::Processing;
my $emp = Objs::Manager->new('John Smith');
use Data::Dumper;
print Dumper($emp);
my $processor = Objs::Processing->new();
$processor->process_staff(\&$emp->is_ok); #error is here
I get a:
Not a CODE reference at testScript.pl line 14.
I also tried: $processor->process_staff(\&$emp->is_ok()); but also still does not work.
What am I doing wrong here
You appear to want to pass an object and a method to call on it; the easiest way to do that would be:
$processor->process_staff( sub { $emp->is_ok } );
where process_staff looks like:
sub process_staff {
my ($self, $func) = #_;
if ( $func->() ) {
...
or you can pass the reference and the object separately:
sub process_staff {
my ($self, $emp, $method) = #_;
if ( $emp->$method() ) {
...
$processor->process_staff( $emp, $emp->can('is_ok') );
I think this could work with:
$processor->process_staff(\&Objs::Employee::is_ok);
where you pass in the method ref.
and where you currently have
if( $func->is_ok($employee) ) {
you need
if( $func->( $employee ) ) {
This is because you cannot reference named methods simply from an object, by the syntax \&$obj->method.
However, in your example code it is not at all clear why you don't do this instead:
if( $employee->is_ok() ) {
in which case you would not need to reference the method to call in process_staff at all. There are also other ways to achieve the same method indirection that might give you better encapsulation in future.
In this expression:
$processor->process_staff(\&$emp->is_ok);
You are saying "call the method $emp->is_ok, take the return value, treat it as a CODE reference, dereference it, and return a reference to that. That doesn't work, since the return value from that sub is not a CODE reference.
To do what you want, you can use a reference to an anonymous sub to wrap the call to your object method:
$processor->process_staff( sub { $emp->is_ok } );
You can pass anonymous coderef which returns result from desired method,
$processor->process_staff(sub{ $emp->is_ok(#_) });
#_ can be dropped as is_ok method doesn't take any arguments.
It's not specifically what you asked for, but I think you simply need the following:
sub process_staff {
my ($self, $emp) = #_;
if ($emp->is_ok()) {
print "Is ok to process\n";
}
else {
print "Not ok to process\n";
}
}
$processor->process_staff($emp);
Assume you have a module (eg Foo.pm) with package Foo. Inside it exists many subroutine definitions, including ones for foo and default.
package Foo;
sub foo { ... }
sub default { ... }
Inside your main perl program (eg test.pl) what is the proper way to assign a value to a subref and call it, or otherwise call default?
sub call_proc {
my $args = shift;
my $subref = $args->{proc_name} // 'default';
&$Foo::subref(); # <====== Wrong
}
call_proc({ proc_name => q{foo} }); # make the call
I've done this with UNIVERSAL::can:
sub call_proc {
my $args = shift;
my $subref = Foo->can($args->{proc_name}) // 'default';
if ($subref) {
&$subref();
}
}
call_proc({ proc_name => q{foo} });
\&$name isn't caught by strict refs, so:
sub call_proc {
my $args = shift;
my $sub_name = $args->{proc_name} // 'default';
my $sub_ref = \&{ "Foo::" . $sub_name };
#die if !defined(&$sub_ref);
return $sub_ref->();
}
If we're talking about methods, then it would be:
sub call_method {
my $args = shift;
my $method_name = $args->{method_name} // 'default';
#die if !Foo->can($method_name);
return Foo->$method_name();
}
If $subref is some_method_name, then &$subref (or $subref->()) will try to call a function called some_method_name in the current package. Depending on how your program is set up, you may want to pass a fully qualified subroutine name
call_proc( { proc_name => 'Foo::foo' });
or put some logic into call_proc to qualify it. See the qualify_sub_name function in Forks::Super::Util for an idea about how to do this.
You can also safely use a reference to the function
call_proc( { proc_name => \&foo } ); # works if &foo is avail in current pkg