#! /usr/bin/perl
# this is the object tester
{package Hate;
sub status {
my $class = shift;
print "-- $_[0] $_[1] $_[2]\n";
print "$class exists and ", $class->stats($_[0]), "and ", $class->type($_[1]), "and ", $class->location($_[2]);
}
}
{package Grudge;
#ISA = "Hate";
sub stats{"$_[0]\n"}
sub type{"$_[0]\n"}
sub location{"$_[0]\n"}
}
Hate::status("Grudge", #ARGV);
i ran ./program one two three
this output is what i expected
Grudge exists and one
and two
and three
this is what i got
Grudge exists and Grudge
and Grudge
and Grudge
However when i use this script
#! /usr/bin/perl
# this is the object tester
{package Hate;
sub status {
my $class = shift;
print "-- $_[0] $_[1] $_[2]\n";
print "$class exists and ", $class->stats($_[0]), "and ", $class->type($_[1]), "and ", $class->location($_[2]);
}
}
{package Grudge;
#ISA = "Hate";
sub stats{"$_[1]\n"}
sub type{"$_[1]\n"}
sub location{"$_[1]\n"}
}
Hate::status("Grudge", #ARGV);
This worked.
In your first example, $class->stats($_[0]) is called as a method and is passed an object as the first argument, which needs to be shifted away as you did in Hate::status. That's why $_[1] works: because the first argument to the method is actually the second item in #_ (after $self).
Things become a lot more clearer, and manageable, if you unpack arguments out of #_ at the beginning of the function, e.g.
{
package Hate;
sub status {
my ($class, $stats, $type, $location) = #_;
print "-- $stats $type $location\n";
print "$class exists and ", $class->stats($stats), ...;
}
}
{
package Grudge;
our #ISA = qw(Hate);
sub stats { my ($self, $stats) = #_; $stats; }
sub type { my ($self, $type) = #_; $type; }
sub location { my ($self, $location) = #_; $location; }
}
Hate::status('Grudge', #ARGV);
As a side note, your use of objects is not typical - if you provided more code, we may be able to provide a more idiomatic Perl solution. For example, none of your objects have constructors, and at the moment the three Grudge methods appear to do the same thing. It's also not clear why Grudge is a subclass of Hate (as indicated by the #ISA).
If you really don't want Grudge to be passed its own name as an argument you can call its methods as functions via &{$class . '::stats'}() but you will have to disable strict subs. It's generally better to call methods as you are doing now.
Related
In perl there is the shift function that can act on the #_(arguments of a function in scope of which it was called) if no arguments supplied.
Can I write a custom function in perl with the same behavior(some kind of my_shift)?
I tried this:
use Data::Dumper;
sub get_caller_args (;$) {
my $n = shift;
$n = defined $n? $n:1;
my $ret;
package DB {
my($t,$t1) = caller($n);
};
$ret = \#DB::args;
return $ret;
}
sub test ($#) {
my $self = shift;
print "Self: $self.\n";
print Dumper(get_caller_args()), "\n";
}
It kind of works, but
test(1,2,3)
outputs:
Self: 1.
$VAR1 = [
1,
2,
3
];
So it doesn't see changes made by shift (though it can see changes made by pop).
But I want it to act like this:
sub test {
my $self = shift;
print my_function;
}
Here the my_function called without arguments must act on the #_, in this case on the rest of the arguments, without the first as it was shifted(actually I need only to read arguments, not to do changes).
Ok, I found an answer:
use feature 'say';
sub my_shift {
say "Arguments before shift: ", #_;
shift;
say "Arguments after shift: ", #_;
}
sub test {
say "Arguments before my_shift: ", #_;
&my_shift;
say "Arguments after my_shift: ", #_;
}
The 'tricky' thing here is to call the my_shift with an ampersand(&) before the function name -- then the function gets arguments of the calling function as it's input.
However I'll not accept this self-answer, because I'm still interested if it possible to do this without that ampersand magic and what if i need to pass other arguments and access the calling function arguments at the same time, etc.
I want to use overloaded operators in a method which modifies an object. I also want to achieve it without duplicating the code.
To illustrate the problem, I will show a simplified version of what I am trying to do. In my original code, the add method overloads + and complicated_calculation method tries to update the object.
The add method creates a new Number object to avoid an expression like $n + 1 modifying the object.
package Number;
use overload
'0+' => 'get_value',
'+' => 'add';
sub new {
my ($class, $value) = #_;
my $self->{value} = $value;
return bless($self, $class);
}
sub get_value {
my ($self) = #_;
return $self->{value};
}
sub set_value {
my ($self, $value) = #_;
$self->{value} = $value;
}
# Actual class has more attributes and the logic of addition includes branches.
sub add {
my ($self, $other) = #_;
print "add $other\n";
return Number->new($self->get_value + $other);
}
sub complicated_calculation {
my ($self) = #_;
# Do something complicated.
$self += 10;
}
package main;
my $n = Number->new(1);
print $n + 1 . "\n";
$n++;
print $n . "\n";
$n->complicated_calculation;
print $n . "\n";
Will output
add 1
2
add 1
2
add 10
2
I want the result of complicated_calculation method (12) to be printed, but 2 is printed instead. The result of the complicated_calculation method is set to an object created by the add method, instead of to the object which called it.
I can make the complicated_calculation method update the object using an add_in_place method to add a number in-place, but this requires duplicated code in add and add_in_place which I was taught to avoid.
In the actual application the Number class will have many more attributes, and the code for addition will be much longer.
package Number;
use overload
'0+' => 'get_value',
'+' => 'add',
'+=' => 'add_in_place',
'fallback' => 1;
sub new {
my ($class, $value) = #_;
my $self->{value} = $value;
return bless($self, $class);
}
sub get_value {
my ($self) = #_;
return $self->{value};
}
sub set_value {
my ($self, $value) = #_;
$self->{value} = $value;
}
# Actual class has more attributes and the logic of addition includes branches.
sub add {
my ($self, $other) = #_;
print "add $other\n";
return Number->new($self->get_value + $other);
}
sub add_in_place {
my ($self, $other) = #_;
print "add_in_place $other\n";
$self->set_value($self->get_value + $other);
}
sub complicated_calculation {
my ($self) = #_;
# Do something complicated.
$self += 10;
}
package main;
my $n = Number->new(1);
print $n + 1 . "\n";
$n++;
print $n . "\n";
$n->complicated_calculation;
print $n . "\n";
Will output
add 1
2
add_in_place 1
2
add_in_place 10
12
I feel that there should be a better way and would like to have some advice from you guys.
First of all, you must always use strict and use warnings at the top of every Perl program file you write. This applies especially when you are asking for help with your code, as it is the first line of defence against bugs and really should be your first resort before troubling others.
This is happening because the add method is called to implement the += operator, which returns a new Number object as a result. That results in the value of $self within complicated_calculation being changed to refer to the new Number object that, correctly, has a value of 12. But the original value -- $n in the main code -- still points to an object with the value of 2.
To get it to work, you could arrange that complicated_calculation returns the new object, and the calling code assigns it to $n. Just changing that statement to
$n = $n->complicated_calculation
will get it working.
However, it is a little strange to write stuff like that as a method. The code in the Number class should be focused on making the object behave correctly, so all the methods should be operators. If you were writing complicated_calculation as a subroutine in the main package then you would be fine with
$n += 10;
print $n;
as the copying of $n would then work correctly and transparently. It is only when you are writing a method that reassigning $self makes no sense, because it then no longer refers to the object the calling code is using.
If you really consider complicated_calculation to be an operator, then it should mutate the object in-place rather than relying on overload to provide the mechanism. If you changed it to
sub complicated_calculation {
my ($self) = #_;
$self->{value} += 10;
}
then everything would work as it should.
Update
I strongly believe that you should write everything in terms of add_in_place, which should be a private method for use only internally by the class.
Both add and complicated_calculation can be very simply rewritten, and there is no longer any need to write $n = $n->complicated_calculation as the method modifies the object in-place.
This example code for the module demonstrates.
package Number;
use strict;
use warnings;
use 5.010;
use overload
'0+' => 'get_value',
'+' => 'add';
sub new {
my ($class, $value) = #_;
bless { value => $value };
}
sub get_value {
my ($self) = #_;
$self->{value};
}
sub set_value {
my ($self, $value) = #_;
$self->{value} = $value;
}
sub add {
my ($self, $other) = #_;
print "add $other\n";
Number->new($self->get_value)->add_in_place($other);
}
sub add_in_place {
my ($self, $other) = #_;
print "add_in_place $other\n";
$self->{value} += $other;
$self;
}
sub complicated_calculation {
my ($self) = #_;
$self->add_in_place(10);
}
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
Suppose i am having class
package Person;
# Class for storing data about a person
#person7.pm
use warnings;
use strict;
use Carp;
my #Everyone;
sub new {
my $class = shift;
my $self = {#_};
bless($self, $class);
push #Everyone, $self;
return $self;
}
# Object accessor methods
sub address { $_[0]->{address }=$_[1] if defined $_[1]; $_[0]->{address } }
sub surname { $_[0]->{surname }=$_[1] if defined $_[1]; $_[0]->{surname } }
sub forename { $_[0]->{forename}=$_[1] if defined $_[1]; $_[0]->{forename} }
sub phone_no { $_[0]->{phone_no}=$_[1] if defined $_[1]; $_[0]->{phone_no} }
sub occupation {
$_[0]->{occupation}=$_[1] if defined $_[1]; $_[0]->{occupation}
}
# Class accessor methods
sub headcount { scalar #Everyone }
sub everyone { #Everyone}
1;
And i am calling like this
#!/usr/bin/perl
# classatr2.plx
use warnings;
use strict;
use Person;
print "In the beginning: ", Person->headcount, "\n";
my $object = Person->new (
surname=> "Galilei",
forename=> "Galileo",
address=> "9.81 Pisa Apts.",
occupation => "Philosopher"
);
print "Population now: ", Person->headcount, "\n";
my $object2 = Person->new (
surname=> "Einstein",
forename=> "Albert",
address=> "9E16, Relativity Drive",
occupation => "Theoretical Physicist"
);
print "Population now: ", Person->headcount, "\n";
print "\nPeople we know:\n";
for my $person(Person->everyone) {
print $person->forename, " ", $person->surname, "\n";
}
Ouput
>perl classatr2.plx
In the beginning: 0
Population now: 1
Population now: 2
People we know:
Galileo Galilei
Albert Einstein
>
Doubt -> I am having doubt in this part of code
for my $person(Person->everyone) {
print $person->forename, " ", $person->surname, "\n";
}
Query -> here $person is a hash reference. Why we are calling like $person->forename . Whereas hash ref should be called as $person->{$forename}
$person is NOT JUST a hash reference; you had this line bless($self, $class); earlier. Per the bless perldoc;
bless REF,CLASSNAME
This function tells the thingy referenced by REF that it is now an object
in the CLASSNAME package.
Regarding the OP's doubts expressed in comments to Elliott Frisch's answer, the difference between $person->{surname} and $person->surname is:
$person->{surname} directly accesses the object's internal data. This violates encapsulation and many people consider it a poor practice as a result.
$person->surname runs sub surname on the $person object and returns the result. In this particular case, the only thing that sub does is return the value of $person->{surname}, but it could do other things. For instance, if your Person class included the Person's parents, then $person->surname would be able to first check whether the Person had a surname defined and, if not, return $person->father->surname (or, in some societies, $person->father->forename . 'sson') instead of undef.
I am writing a module and I want a specific piece of code to be executed before each of the functions in it.
How do I do that?
Is there no other way than to just have a function-call at the beginning of every function?
You can do this in Moose with method modifiers:
package Example;
use Moose;
sub foo {
print "foo\n";
}
before 'foo' => sub { print "about to call foo\n"; };
Wrapping a method is also possible with method attributes, but this route is not well-used in Perl and is still evolving, so I wouldn't recommend it. For normal use-cases, I would simply put the common code in another method and call it at the top of each of your functions:
Package MyApp::Foo;
sub do_common_stuff { ... }
sub method_one
{
my ($this, #args) = #_;
$this->do_common_stuff();
# ...
}
sub method_two
{
my ($this, #args) = #_;
$this->do_common_stuff();
# ...
}
And, in case someone is wondering how to achieve the effect of Hook* modules or Moose's "before" explicitly (e.g. what actual Perl mechanism can be used to do it), here's an example:
use strict;
package foo;
sub call_before { print "BEFORE\n"; } # This will be called before any sub
my $call_after = sub { print "AFTER - $_[0]\n"; };
sub fooBar { print "fooBar body\n\n"; }
sub fooBaz { print "fooBaz body\n\n"; }
no strict; # Wonder if we can get away without 'no strict'? Hate doing that!
foreach my $glob (keys %foo::) { # Iterate over symbol table of the package
next if not defined *{$foo::{$glob}}{CODE}; # Only subroutines needed
next if $glob eq "call_before" || $glob eq "import" || $glob =~ /^___OLD_/;
*{"foo::___OLD_$glob"} = \&{"foo::$glob"}; # Save original sub reference
*{"foo::$glob"} = sub {
call_before(#_); &{"foo::___OLD_$glob"}(#_); &$call_after(#_);
};
}
use strict;
1;
package main;
foo::fooBar();
foo::fooBaz();
The explanation for what we're excluding via "next" line:
"call_before" is of course the name I gave to our "before" example sub - only need this if it is actually defined as a real sub in the same package and not anonymously or code ref from outside the package.
import() has a special meaning and purpose and should generally be excluded from "run this before every sub" scenario. YMMV.
___OLD_ is a prefix we will give to "renamed" old subs - you don't need to include it here unless you're worried about this loop being execute twice. Better safe than sorry.
UPDATE: Below section about generalization is no longer relevant - at the end of the answer I pasted a general "before_after" package doing just that!!!
The loop above can obviously be easily generalized to be a separately-packaged subroutine which accepts, as arguments:
an arbitrary package
a code ref to arbitrary "before" subroutine (or as you can see, after)
and a list of sub names to exclude (or sub ref that checks if a name is to be excluded) aside from standard ones like "import").
... and/or a list of sub names to include (or sub ref that checks if a name is to be included) aside from standard ones like "import"). Mine just takes ALL subs in a package.
NOTE: I don't know whether Moose's "before" does it just this way. What I do know is that I'd obviously recommend going with a standard CPAN module than my own just-written snippet, unless:
Moose or any of the Hook modules can't be installed and/or are too heavy weight for you
You're good enough with Perl that you can read the code above and analyze it for flaws.
You like this code very much, AND the risk of using it over CPAN stuff is low IYHO :)
I supplied it more for informational "this is how the underlying work is done" purposes rather than practical "use this in your codebase" purposes, though feel free to use it if you wish :)
UPDATE
Here's a more generic version as mentioned before:
#######################################################################
package before_after;
# Generic inserter of before/after wrapper code to all subs in any package.
# See below package "foo" for example of how to use.
my $default_prefix = "___OLD_";
my %used_prefixes = (); # To prevent multiple calls from stepping on each other
sub insert_before_after {
my ($package, $prefix, $before_code, $after_code
, $before_filter, $after_filter) = #_;
# filters are subs taking 2 args - subroutine name and package name.
# How the heck do I get the caller package without import() for a defalut?
$prefix ||= $default_prefix; # Also, default $before/after to sub {} ?
while ($used_prefixes{$prefix}) { $prefix = "_$prefix"; }; # Uniqueness
no strict;
foreach my $glob (keys %{$package . "::"}) {
next if not defined *{$package. "::$glob"}{CODE};
next if $glob =~ /import|__ANON__|BEGIN/; # Any otrher standard subs?
next if $glob =~ /^$prefix/; # Already done.
$before = (ref($before_filter) ne "CODE"
|| &$before_filter($glob, $package));
$after = (ref($after_filter) ne "CODE"
|| &$after_filter($glob, $package));
*{$package."::$prefix$glob"} = \&{$package . "::$glob"};
if ($before && $after) { # We do these ifs for performance gain only.
# Else, could wrap before/after calls in "if"
*{$package."::$glob"} = sub {
my $retval;
&$before_code(#_); # We don't save returns from before/after.
if (wantarray) {
$retval = [ &{$package . "::$prefix$glob"}(#_) ];
} else {
$retval = &{$package . "::$prefix$glob"}(#_);
}
&$after_code(#_);
return (wantarray && ref $retval eq 'ARRAY')
? #$retval : $retval;
};
} elsif ($before && !$after) {
*{$package . "::$glob"} = sub {
&$before_code(#_);
&{$package . "::$prefix$glob"}(#_);
};
} elsif (!$before && $after) {
*{$package . "::$glob"} = sub {
my $retval;
if (wantarray) {
$retval = [ &{$package . "::$prefix$glob"}(#_) ];
} else {
$retval = &{$package . "::$prefix$glob"}(#_);
}
&$after_code(#_);
return (wantarray && ref $retval eq 'ARRAY')
? #$retval : $retval;
};
}
}
use strict;
}
# May be add import() that calls insert_before_after()?
# The caller will just need "use before_after qq(args)".
1;
#######################################################################
package foo;
use strict;
sub call_before { print "BEFORE - $_[0]\n"; };
my $call_after = sub { print "AFTER - $_[0]\n"; };
sub fooBar { print "fooBar body - $_[0]\n\n"; };
sub fooBaz { print "fooBaz body - $_[0]\n\n"; };
sub fooBazNoB { print "fooBazNoB body - $_[0]\n\n"; };
sub fooBazNoA { print "fooBazNoA body - $_[0]\n\n"; };
sub fooBazNoBNoA { print "fooBazNoBNoA body - $_[0]\n\n"; };
before_after::insert_before_after(__PACKAGE__, undef
, \&call_before, $call_after
, sub { return 0 if $_[0] eq "call_before"; $_[0] !~ /NoB(NoA)?$/ }
, sub { return 0 if $_[0] eq "call_before"; $_[0] !~ /NoA$/ } );
1;
#######################################################################
package main;
use strict;
foo::fooBar("ARG1");
foo::fooBaz("ARG2");
foo::fooBazNoB("ARG3");
foo::fooBazNoA("ARG4");
foo::fooBazNoBNoA("ARG5");
#######################################################################
If you search CPAN for 'hook', and then branch out from there, you'll find several options, such as:
Hook::WrapSub
Hook::PrePostCall
Hook::LexWrap
Sub::Prepend
Here's an example using Hook::LexWrap. I don't have experience with this module except for debugging. It worked fine for that purpose.
# In Frob.pm
package Frob;
sub new { bless {}, shift }
sub foo { print "foo()\n" }
sub bar { print "bar()\n" }
sub pre { print "pre()\n" }
use Hook::LexWrap qw(wrap);
my #wrappable_methods = qw(foo bar);
sub wrap_em {
wrap($_, pre => \&pre) for #wrappable_methods;
}
# In script.pl
use Frob;
my $frob = Frob->new;
print "\nOrig:\n";
$frob->foo;
$frob->bar;
print "\nWrapped:\n";
Frob->wrap_em();
$frob->foo;
$frob->bar;
See the Aspect package on CPAN for aspect-oriented computing.
before { Class->method; } qr/^Package::\w+$/;