I am debugging a test in MPEG::Audio::Frame. If I run this test, I get:
$ cpan -g MPEG::Audio::Frame
$ tar zxvf MPEG-Audio-Frame-0.09.tar.gz
$ cd MPEG-Audio-Frame-0.09
$ perl Makefile.PL
$ make
$ perl -I./blib/lib t/04-tie.t
1..5
ok 1 - use MPEG::Audio::Frame;
ok 2 - 'tie' isa 'MPEG::Audio::Frame'
Not a HASH reference at blib/lib/MPEG/Audio/Frame.pm line 273, <DATA> line 1.
# Looks like your test exited with 255 just after 2.
I narrowed down the problem to the following minimal example:
package My::Module;
use feature qw(say);
use strict;
use warnings;
use overload '""' => \&asbin;
sub asbin {
my $self = shift;
$self->{binhead} # $self is not yet a hash, so execution stops here.
}
sub TIEHANDLE {
bless \$_[1], $_[0]
}
sub READLINE {}
sub read {
say "reading..";
my $pkg = shift;
my $fh = shift || 0; # Why is the stringification operator called here?
}
package main;
use feature qw(say);
use strict;
use warnings;
tie *FH, 'My::Module', *DATA;
My::Module->read(\*DATA);
<FH>;
__DATA__
abc
Why is the stringification operator called for the statement My::Module->read(\*DATA) ?
shift || 0 will want to coerce the argument in shift to a scalar. There is no boolify or numify function overloads defined for My::Module, so Perl will use your stringify function.
To avoid evaluating the object in scalar context, you could rephrase it as
my $fh = #_ ? shift : 0;
$fh = shift;
$fh = 0 unless ref($fh) || $fh;
or define a bool function overload.
Related
Today I saw this piece of code:
if ( not defined($reply_address)
or not defined($from_name)
or not defined($subject)
or not defined($date) )
{
die "couldn’t glean the required information!";
}
(Jeffrey Friedl, "Mastering Regular Expressions", p. 59, 3rd ed.)
and I thought "How can I know which variable misfired?"
Of course, if there are only 4 variables to test, as in the example above, one could come up with:
if ( not defined $reply_address )
{
die "\$reply_address is not defined"
}
elsif ( not defined $from_name )
{
die "\$from_name is not defined"
}
elsif ...
But what if there are 14 variables? Or 40...?
One still needs to go through all of them, manually testing each and every one?
Isn't there a shorter, more "magical" way of telling which variable was left undefined?
You could create a table to simplify a little bit:
use strict;
use warnings;
my $reply_address = "xyz";
my $from_name;
my $subject = "test";
my $date;
my #checks = (
[\$reply_address, '$reply_adress'],
[\$from_name, '$from_name'],
[\$subject, '$subject'],
[\$date, '$date'],
);
for my $check (#checks) {
if (not defined ${$check->[0]}) {
die $check->[1] . " is not defined";
}
}
You can do what you want with symbolic references, though using them is generally not a great idea, and it can only be done with package variables, not lexically scoped variables (and lexically scoped variables are preferred to package variables -- see this answer for a brief comparison of the two).
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
our($foo1) = 1;
our($bar1) = undef;
our($baz1) = 3;
foreach my $name (qw(foo1 bar1 baz1)) {
{
no strict 'refs';
my($value) = $$name;
warn "$name: is not defined" unless defined $value;
say "$name: <$value>";
}
}
Using warn instead of die for illustrative purposes.
</tmp> $ ./test.pl
foo1: <1>
bar1: is not defined at ./test.pl line 16.
Use of uninitialized value $value in concatenation (.) or string at ./test.pl line 17.
bar1: <>
baz1: <3>
You can also just loop through all of the variables using common code to check them:
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
my($foo2) = 1;
my($bar2) = undef;
my($baz2) = 3;
foreach my $vardef (["foo2", $foo2], ["bar2", $bar2], ["baz2", $baz2]) {
my($name) = $vardef->[0];
my($value) = $vardef->[1];
warn "$name: is not defined" unless defined $value;
say "$name: <$value>";
}
which gives similar output:
foo2: <1>
bar2: is not defined at ./test.pl line 29.
Use of uninitialized value $value in concatenation (.) or string at ./test.pl line 30.
bar2: <>
baz2: <3>
Finally, if you can manage to get the variables into a hash, you can loop through the keys of the hash and test them that way:
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
my($vars) = {
foo3 => 1,
bar3 => undef,
baz3 => 3,
};
foreach my $name (sort keys %$vars) {
my($value) = $vars->{$name};
warn "$name: is not defined" unless defined $value;
say "$name: <$value>";
}
I threw the sort in there because I like deterministic behavior...
bar3: is not defined at ./test.pl line 42.
Use of uninitialized value $value in concatenation (.) or string at ./test.pl line 43.
bar3: <>
baz3: <3>
foo3: <1>
If the test really was as simple as die if ! defined then I would probably just list them out:
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
my($foo4) = 1;
my($bar4) = undef;
my($baz4) = 3;
die qq([ERROR] \$foo4 not defined\n) unless defined $foo4;
die qq([ERROR] \$bar4 not defined\n) unless defined $bar4;
die qq([ERROR] \$baz4 not defined\n) unless defined $baz4;
which just gives us:
[ERROR] $bar4 not defined
The last approach is just very straightforward and unambiguous. If the test is not as dead simple as this, then I'd go with the second approach. If you're worried about a list of 40 (or even 14) checks of this nature, then I'd look at the design.
See also this PadWalker code example for a very complicated version of the first option, but allowing lexically scoped variables.
Could be done with a string-eval:
use strict;
use warnings;
my ($reply_address, $from_name, $subject, $date) = ('', '', undef, '');
for my $var (qw(reply_address from_name subject date)) {
my $defined;
eval "\$defined = defined \$$var";
die "eval failed: $#" if $#;
die "\$$var is not defined" unless $defined;
}
I have a main setup script which sets up the test env and stores data in some variables:
package main;
use Test::Harness;
our $foo, $xyz, $pqr;
($foo, $xyz, $pqr) = &subroutinesetup();
# ^ here
#test_files = glob "t/*";
print "Executing test #test\n";
runtests(#test_files);
In the test folder I have a testsuite (t/testsuite1.t, testsuite2.t etc.).
How can I access the value of $foo inside the testsuite1.t?
package main;
use Test::More;
$actual = getActual();
is($foo, $actual, passfoor);
# ^ here
done_testing();
Use Storable to store data in first script and retrieve it from other.
main.pl
($foo, $xyz, $pqr) = &subroutinesetup();
store ($foo, "/home/chankey/testsuite.$$") or die "could not store";
system("perl", "testsuite.pl", $$) == 0 or die "error";
testsuite.pl
my $parentpid = shift;
my $ref = retrieve("/home/chankey/testsuite.$parentpid") or die "couldn't retrieve";
print Dumper $ref;
You've received the $foo in $ref. Now use it the way you want.
You can't share a variable directly, because a new Perl process is started for each test file.
As noted in the documentation of Test::Harness, you should switch to TAP::Harness. It's more flexible: for example, it provides the test_args mechanism to pass arguments to test scripts.
$ cat 1.pl
#!/usr/bin/perl
use warnings;
use strict;
use TAP::Harness;
my $harness = 'TAP::Harness'->new({
test_args => [ qw( propagate secret ) ]
});
$harness->runtests('1.t');
__END__
$ cat 1.t
#!/usr/bin/perl
use warnings;
use strict;
use Test::More;
my %args = #ARGV;
is($args{propagate}, 'secret', 'propagated');
done_testing();
I would like to dynamically get a list of either function names (as strings) or function references from any arbitrary Perl module available on my system. This would include modules that may or may not have, e.g., a global #EXPORT_OK array in its namespace. Is such a feat possible? How does one pull it off if so?
Edit: From reading perlmod, I see that %Some::Module:: serves as a symbol table for Some::Module. Is this the correct place to be looking? If so, how can I whittle the table down to just the function names in Some::Module?
You're on the right track. To wittle down the full symbol table to just the subs, something like this can be done (Hat tip "Mastering Perl", ch 8, for main package version of this):
use strict; # need to turn off refs when needed
package X;
sub x {1;};
sub y {1;};
our $y = 1;
our $z = 2;
package main;
foreach my $entry ( keys %X:: ) {
no strict 'refs';
if (defined &{"X::$entry"}) {
print "sub $entry is defined\n" ;
}
}
# OUTPUT
sub y is defined
sub x is defined
You may find this simple script handy:
#!/usr/bin/env perl
use strict;
use warnings;
use Data::Dumper;
# dump of object's symbol table:
foreach my $className (#ARGV)
{
print "symbols in $className:";
eval "require $className";
die "Can't load $className: $#" if $#;
no strict 'refs';
print Dumper(\%{"main::${className}::"});
}
But, if you're doing this in production code, I'd use Package::Stash instead:
my #subs_in_foo = Package::Stash->new('Foo')->list_all_symbols('CODE');
I'm using Perl 5.20. This works on my machine:
use strict;
package foo;
our $some_var;
sub func1 { return 'func1'}
sub func2 { return 'func2'}
package main;
sub callable {
my ($x) = #_;
return defined(&$x);
}
while (my ($k, $v) = each(%foo::)) {
if (callable($v)) {
print("$k\n");
}
}
# output:
# func1
# func2
I tried to catch a carp-warning:
carp "$start is > $end" if (warnings::enabled()); )
with eval {} but it didn't work, so I looked in the eval documentation and I discovered, that eval catches only syntax-errors, run-time-errors or executed die-statements.
How could I catch a carp warning?
#!/usr/bin/env perl
use warnings;
use strict;
use 5.012;
use List::Util qw(max min);
use Number::Range;
my #array;
my $max = 20;
print "Input (max $max): ";
my $in = <>;
$in =~ s/\s+//g;
$in =~ s/(?<=\d)-/../g;
eval {
my $range = new Number::Range( $in );
#array = sort { $a <=> $b } $range->range;
};
if ( $# =~ /\d+ is > \d+/ ) { die $# }; # catch the carp-warning doesn't work
die "Input greater than $max not allowed $!" if defined $max and max( #array ) > $max;
die "Input '0' or less not allowed $!" if min( #array ) < 1;
say "#array";
Based on your comments, my understanding is that you would like to make carp into a fatal warning.
If it is acceptable to make all carp warnings in your target package into fatal errors you can monkey-patch carp.
Carping Package:
package Foo;
use Carp;
sub annoying_sub {
carp "Whine whine whine";
}
Main program:
use Foo;
*Foo::carp = \&Foo::croak;
Foo::annoying_sub();
If you want to limit the monkey patch to a dynamic scope, you can use local:
use Foo;
Foo::annoying_sub(); # non-fatal
{ local *Foo::carp = \&Foo::croak;
Foo::annoying_sub(); # Fatal
}
carp does not die but just prints a warning, so there's nothing to catch with eval or whatever. You can, however, overwrite the warn handler locally to prevent the warning from being sent to stderr:
#!/usr/bin/env perl
use warnings;
use strict;
use Carp;
carp "Oh noes!";
{
local $SIG{__WARN__} = sub {
my ($warning) = #_;
# Replace some warnings:
if($warning =~ /replaceme/) {
print STDERR "My new warning.\n";
}
else {
print STDERR $warning;
}
# Or do nothing to silence the warning.
};
carp "Wh00t!";
carp "replaceme";
}
carp "Arrgh!";
Output:
Oh noes! at foo.pl line 8
Wh00t! at foo.pl line 25
My new warning.
Arrgh! at foo.pl line 29
In almost all cases you should prefer fixing the cause of the carp instead.
I want to do two things:
In production code, I want to redefine the open command to enable me to add automagic file logging. I work on data processing applications/flows and as part of that, it's important for the user to know exactly what files are being processed. If they are using an old version of a file, one way for them to find out is by reading through the list of files being processed.
I could just create a new sub that does this logging and returns a file pointer and use that in place of open in my code.
It would be really nice if I could just redefine open and have pre-existing code benefit from this behavior. Can I do this?
In debug code, I'd like to redefine the printf command to insert comments along with the written output indicating which code generated that line. Again, I have a sub that will optionally do this, but converting my existing code is tedious.
If a CORE subroutine has a prototype* it can be replaced. Replacing a function in the current namespace is simple enough.
#!/usr/bin/perl
use strict;
use warnings;
use subs 'chdir';
sub chdir(;$) {
my $dir = shift;
$dir = $ENV{HOME} unless defined $dir;
print "changing dir to $dir\n";
CORE::chdir $dir;
}
chdir("/tmp");
chdir;
If you want to override the function for all modules as well you can read the docs.
* Here is code to test every function in Perl 5.10 (it will work on earlier versions as well). Note, some functions can be overridden that this program will tell you can't be, but the overridden function will not behave in the same way as the original function.
from perldoc -f prototype
If the builtin is not overridable
(such as qw//) or if its arguments
cannot be adequately expressed by a
prototype (such as system),
prototype() returns undef, because the
builtin does not really behave like a
Perl function
#!/usr/bin/perl
use strict;
use warnings;
for my $func (map { split } <DATA>) {
my $proto;
#skip functions not in this version of Perl
next unless eval { $proto = prototype "CORE::$func"; 1 };
if ($proto) {
print "$func has a prototype of $proto\n";
} else {
print "$func cannot be overridden\n";
}
}
__DATA__
abs accept alarm atan2 bind
binmode bless break caller chdir
chmod chomp chop chown chr
chroot close closedir connect continue
cos crypt dbmclose defined delete
die do dump each endgrent
endhostent endnetent endprotoent endpwent endservent
eof eval exec exists exit
exp fcntl fileno flock fork
format formline getc getgrent getgrgid
getgrnam gethostbyaddr gethostbyname gethostent getlogin
getnetbyaddr getnetbyhost getnetent getpeername getpgrp
getppid getpriority getprotobyname getprotobynumber getprotoent
getpwent getpwnam getpwuid getservbyname getservbyport
getservent getsockname getsockopt glob gmtime
goto grep hex import index
int ioctl join keys kill
last lc lcfirst length link
listen local localtime lock log
lstat m map mkdir msgctl
msgget msgrcv msgsnd my next
no oct open opendir ord
our pack package pipe pop
pos print printf prototype push
q qq qr quotemeta qw
qx rand read readdir readline
readlink readpipe recv redo ref
rename require reset return reverse
rewinddir rindex rmdir s say
scalar seek seekdir select semctl
semget semop send setgrent sethostent
setnetent setpgrp setpriority setprotoent setpwent
setservent setsockopt shift shmctl shmget
shmread shmwrite shutdown sin sleep
socket socketpair sort splice split
sprintf sqrt srand stat state
study sub substr symlink syscall
sysopen sysread sysseek system syswrite
tell telldir tie tied time
times tr truncate uc ucfirst
umask undef unlink unpack unshift
untie use utime values vec
wait waitpid wantarray warn write
y -r -w -x -o
-R -W -X -O -e
-z -s -f -d -l
-p -S -b -c -t
-u -g -k -T -B
-M -A -C
For open: This worked for me.
use 5.010;
use strict;
use warnings;
use subs 'open';
use Symbol qw<geniosym>;
sub open (*$;#) {
say "Opening $_[-1]";
my ( $symb_arg ) = #_;
my $symb;
if ( defined $symb_arg ) {
no strict;
my $caller = caller();
$symb = \*{$symb_arg};
}
else {
$_[0] = geniosym;
}
given ( scalar #_ ) {
when ( 2 ) { return CORE::open( $symb // $_[0], $_[1] ); }
when ( 3 ) { return CORE::open( $symb // $_[0], $_[1], $_[2] ); }
}
return $symb;
}
open PERL4_FH, '<', 'D:\temp\TMP24FB.sql';
open my $lex_fh, '<', 'D:\temp\TMP24FB.sql';
For Printf: Did you check out this question? -> How can I hook into Perl’s print?