I'm trying to set default values to some variables. I know how to do it but I would like to do this task using a subroutine and I'm having problems.
I have this three variables: $t, $insize, $libtype.
And this is the simple function to set default values to them if they're undefined:
sub SetUnlessDefined {
my $t = 1 if !( defined $t );
my $insize = 300 if !( defined $insize );
my $libtype = 0 if !( defined $libtype );
return( $t, $insize, $libtype );
}
I execute the function like this:
( $t, $insize, $libtype ) = SetUnlessDefined( $t, $insize, $libtype );
If all my variables are undefined the function runs OK, but if I have a value for any of them its not working.
Anyone can suggest me a solution? Or a correct way to check if a variables are defined and if they not set a value?
Thanks in advance
You don't read the parameters in the subroutine body:
sub defaults {
my ($t, $insize, $libtype) = #_; # <--- HERE
$t = 1 unless defined $t;
$insize = 300 unless defined $insize;
$libtype = 0 unless defined $libtype;
return ($t, $insize, $libtype);
}
There are other ways how to approach the task, though:
sub defaults {
my #defaults = (1, 300, 0);
for my $i (0 .. $#defaults) {
$_[$i] //= $defaults[$i]; # Perl 5.10 needed
}
}
No assignment is needed in the subroutine call anymore, as the arguments are aliased to the members of #_:
defaults($t, $insize, $libtype);
The my $t part of the code is always running, so in the case where global $t is defined, the local $t is instantiated as undefined, and is returned.
A solution is to use something like this
if (! defined $t ) {
my $t = 1 ;
}
Or maybe just
if (! defined $t ) {
$t = 1 ;
}
and don't return anything.
You are also sending parameters to the function, which are being ignored... maybe the whole thing could be redone without the parameters, and without the second assignment, like this
sub SetUnlessDefined {
if (! defined $t ) {
$t = 1 ;
}
if (! defined $insize ) {
$insize = 3000;
}
if (! defined $libtype ) {
$libtype = 0;
}
}
SetUnlessDefined();
Related
I am vaguely confused a bit on different methods of passing certain arguments to the constructor type. I want to only pass a hash reference \%hash, or a list foo => 1, bar => 1 but not both and croak if anything else is passed i.e ( single elements, array reference ).
For example, I pass my reference or list.. (This works for the way I do this)
my $obj = foo->new;
my $data = $obj->dump( \%hash );
my $data = $obj->dump( foo => 1, bar => 1 );
or
my $obj = foo->dump( \%hash );
my $obj = foo->dump( foo => 1, bar => 1 );
Package module:
package foo;
use strict;
use Carp;
use Scalar::Util qw/reftype/;
sub new { return bless {}, shift }
sub dump {
my $class = shift;
my $self = shift;
unless ( reftype( $self ) eq reftype {} ) {
croak("Constructor method not a hash type!");
}
}
1;
I've also thought about using the conditional operator ? : here, but I can't get it to error properly.
my $self = reftype($_[0]) eq reftype {} ? shift : {#_};
Is there a better preferred way to do this?
We can look at the various ways your dump method can be called.
If we pass a "hash list", the number of elements is even (#_ % 2 == 0). Also, if at least one key-value pair is present, the first argument (a key) is a string, so not defined reftype $_[0] holds.
If we pass a hash reference, then the argument list should only hold this reference, and no other values: #_ == 1. The first argument will be a hash: reftype($_[0]) eq 'HASH'.
So to put the arguments in a hash reference, one could do something like:
sub dump {
my $invocant = shift;
my $hashref;
if (#_ == 1 and reftype $_[0] eq 'HASH') {
$hashref = $_[0];
} elsif (#_ % 2 == 0 and (#_ == 0 or not defined reftype $_[0])) {
$hashref = +{ #_ };
} else {
croak "Unknown argument format: either pass a hashref, or an even-valued list";
}
...; # do something with $hashref
}
To find out if the $invocant is the class name or an object, just ask it if it is blessed:
if (defined Scalar::Util::blessed $invocant) {
say "Yep, it is an object";
} else {
say "Nope, it is a package name";
}
There's no such thing as a "hash list". foo => 1, bar => 1, is just a four element list. Sounds like you want to accept hash refs and even numbers of args.
sub dump {
my $self = shift;
my %args;
if (#_ == 1) {
croak("...") if (ref($_[0]) // '') ne 'HASH';
%args = %{ $_[0] };
} else {
croak("...") if #_ % 2 != 0;
%args = #_;
}
...
}
What is the more elegant way to write the next?
sub depend {
my($x,$y) = #_;
die "only one allowed" if( defined($x) && defined($y) );
die "one must be defined" unless ( defined($x) || defined($y) );
if( defined($x) ) {
$y = somefunc($x);
} else {
$x = somefunc($y);
}
return($x,$y);
}
The function should get exactly only one argument. If get defined both = error, if defined none = error. And the undefined arg is calculated based on the defined one.
Use xor, i.e. the "exclusive or":
sub depend {
my ($x, $y) = #_;
die "Exactly one must be defined.\n" unless defined $x xor defined $y;
if (defined $x) {
$y = somefunc($x);
} else {
$x = somefunc($y);
}
return($x, $y);
}
Update: You can shorten the rest of the sub, too. Instead of the if part, just put
return ($x // somefunc($y), $y // somefunc($x));
I might define the subroutine to take two arguments, but treat them as a key-value pair. To use the width/height example from your comment:
sub depend {
my $key = shift;
my $value = shift;
die "One parameter only" if #_;
return ($value, calc_height($value)) if $key eq "width";
return (calc_width($value), $value) if $key eq "height";
die "Must specify either height or width, not $key";
}
my ($w1, $h1) = depend( width => 5 );
my ($w2, $h2) = depend( height => 10 );
my ($w3, $h3) = depend(); # ERROR Must specify either height or width
my ($w4, $h4) = depend( other=>3 ); # ERROR Must specify either height or width, not other
my ($w5, $h5) = depend( foo => bar, 7); # ERROR, One parameter only
Try this:
sub f
{
my ($x, $y) = #_;
die "BOOM" if (defined $x ? 1 : 0) +
(defined $y ? 1 : 0) != 1;
}
Using xor might not be intuitive, and solution below could easily be extended to more input arguments,
sub depend {
my($x,$y) = #_;
die "There should be only one!" if (grep defined, $x,$y) != 1;
if( defined($x) ) {
$y = somefunc($x);
}
else {
$x = somefunc($y);
}
return($x,$y);
}
Can I use both ways to localize $| or should I use one in favor of the other?
Way 1: backup old value of $| in "_init_scr" and set back $| to the old value when "_end_win" is called.
Way 2: calling local $| = 1 after "_init_scr" is called.
package Package_name
# ...
sub _init_scr {
my ( $arg ) = #_;
$arg->{old_handle} = select( $arg->{handle_out} );
#$arg->{backup_flush} = $|; # way 1
$| = 1;
# ...
}
sub _end_win {
my ( $arg ) = #_;
# ...
#$| = $arg->{backup_flush}; # way 1
select( $arg->{old_handle} );
}
sub choose {
my $arg = ...;
# ...
_init_scr( $arg );
# way 2 - instead of setting `$|` in "_init_scr" set it here:
#local $| = 1;
# ...
while ( 1 ) {
my $c = _getch( $arg );
# ...;
given ( $c ) {
# ...
when ( $c == CONTROL_C ) {
_end_win( $arg );
print "^C";
kill( 'INT', $$ );
return;
}
when ( $c == KEY_ENTER ) {
# ...
_end_win( $arg );
return $result;
}
}
}
}
Use local. That way, $| is restored no matter how the sub is exited (exception, early return, etc).
By the way, you could use select()->flush; instead of toggling $| back and forth.
use IO::Handle qw( ); # Required in older versions of Perl.
print "^C";
select()->flush();
That said, the advantage of local $| is gone since you need to call _end_win to clean up anyway. So let's get rid of the need for _end_win.
use Sub::ScopeFinalizer qw( scope_finalizer );
sub _local_scr {
my ( $arg ) = #_;
my $old_autoflush = $|;
my $old_handle = select( $arg->{handle_out} );
$| = 1;
return scope_finalizer {
$| = $old_autoflush;
select($old_handle);
};
}
sub choose {
my $arg = ...;
my $guard = _local_scr( $arg );
while ( 1 ) {
...
print "^C";
kill( 'INT', $$ );
return;
...
}
}
If you want to localize the value, just use local. It will handle restoring the original value when the scope where it was localized is exited without any additional effort (or chance for mistakes) on your part.
Third way:
use IO::Handle;
# ...
$arg->{handle_out}->autoflush(1);
# ...
$arg->{handle_out}->autoflush(0);
There are various other convenient methods available in IO::Handle.
You should use local $| = 1;, as this is the idiomatic Perl way of doing this. It's simpler than keeping track of the value in another variable.
Use an extra set of braces (if needed) to create a scope so that it only applies to the part of the program that should have it set.
{
#Buffering is turned off only in here.
local $| = 1;
unbuffered_commands();
}
buffered_commands();
I have one function sub _where(\# \&) which takes 2 arguments: the first is an array, and the second should be another function. This other function returns a boolean value, and I want to call it inside my for loop of sub _where(\# \&) function.
I am having trouble extracting the function I am passing in into a custom local name. I think I do need some local name for it, because it should be possible to pass different boolean functions to my where function.
where:
sub _where(\# \&)
{
my #stud = #{$_[0]};
my $student;
my $function = shift;
my $bool = 0;
my $i;
for $i(0..$#stud)
{
my $student = $stud[$i];
function $student;
}
}
Function1 that should be passed:
sub name_starts_with($)
{
my $letter = 'B';
my $student = shift;
my $first;
$first = substr($student -> name, 0, 1);
if($first eq $letter)
{
return 1;
}
}
Function2 that should be passed to where:
sub points_greater_than($)
{
my $sum_pts = 5;
my $student = shift;
my $pts;
$pts = $student -> points;
if($pts > $sum_pts)
{
return 1;
}
}
Hope you guys could help me out here. Cheers
You shouldn't use prototypes. They work differently in Perl from other languages and are almost never a good choice.
You should also avoid making a local copy of the passed-in array unless you want to modify it without affecting the external data.
Finally, a subroutine name beginning with an underscore usually indicates that it is a private method of a class. It doesn't look like that's the case here.
Your code should look like this
sub _where {
my ($stud, $function) = #_;
my $student;
my $bool = 0;
for my $i (0..$#stud) {
my $student = $stud->[$i];
$function->($student);
}
}
Then you can call it as
_where(\#student, \&function);
One problem is in how you get parameters:
my #stud = #{$_[0]}; # <-- this doesn't remove first parameter from list
my $student;
my $function = shift; # <-- therefore you'll still get first parameter, not second
Try this fix:
my $function = $_[1]; # always get second parameter
Update
Adding example of how to pass reference to function into other function:
_where(\#stud, \&name_starts_with);
You seem to be trying to write another language in Perl. Ick. Try this:
sub _where
{
my $students = shift;
my $function = shift;
$function->($_) for #$students;
}
sub name_starts_with
{
my $student = shift;
my $letter = 'B';
my $first = substr($student->name, 0, 1);
return $first eq $letter; # same as 'return $first eq $letter ? 1 : undef;'
}
sub points_greater_than
{
my $student = shift;
my $sum_pts = 5;
my $pts = $student->points;
return $pts > $sum_pts;
}
And you would call it like _where(\#students, \&name_starts_with).
But I'm not exactly what the purpose of your _where function is, as it does not return anything (except the last statement evaluated, which doesn't seem too useful in this context).
Maybe you just want grep?
my #students_b = grep { substr($_->name, 0, 1) eq 'B' } #students;
You have bug in argument handling in function _where. You are putting array reference into $function variable. You have to do
my #stud = #{shift()};
my $student;
my $function = shift();
or
my #stud = #{$_[0]};
my $student;
my $function = $_[1];
or which I would prefer
sub _where(\# \&)
{
my ($stud, $function) = #_;
for my $student (#$stud)
{
$function->($student);
}
}
but don't mix those methods.
After you fix the problem with grabbing the first argument, here are three ways to call a subroutine from a code reference:
&$function($student); # uses the fewest characters!
&{$function}($student); # the style you're using for the array ref
$function->($student); # my favorite style
You can find a lot more detailed information by reading the perlref man page.
If you change the order of the arguments so that the coderef is first, your code will be a little bit more Perlish.
sub _where(\&#){
my $func = shift;
my #return;
for(#_){
push #return, $_ if $func->($_);
}
return #return;
}
If you were well versed in Perl, you would notice that I just re-implemented grep (poorly).
sub name_starts_with{
'B' eq substr($_->name, 0, 1);
}
sub points_greater_than{
$_->points > 5;
}
my #b_students = _where( &name_starts_with, #students );
my $count_of_students_above_5 = _where( &points_greater_than, #students );
Since those subroutines now rely on $_, we should just use grep.
my #b_students = grep( &name_starts_with, #students );
my $count_of_students_above_5 = grep( &points_greater_than, #students );
Since those subroutines are also very short, how about just using a block.
my #b_students = grep {
'B' eq substr($_->name, 0, 1)
} #students;
my $count_of_students_above_5 = grep {
$_->points > 5;
} #students;
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;
};
});