Is there a proper way to get a line number wherecroak was called?
In the following example I get into $stack :
line 22, where last subroutine (l) was called
line 44, where try-block is terminated
all the other calls in the stack
but I'd like to know the line 28, where I call the croak (or confess);
#!/usr/bin/env perl
{
package Module;
use strict; use warnings;
use Carp qw(croak confess longmess);
our #CARP_NOT = qw(Try::Tiny);
use Try::Tiny;
sub i {
my ($x) = #_;
j($x);
}
sub j {
my ($x) = #_;
k($x);
}
sub k {
my ($x) = #_;
l($x);
}
sub l {
my ($x) = #_;
my $stack = longmess();
croak( { data => 1, stack => $stack } ) if $x =~ /\D/; # or confess
return $x;
}
1;
}
use strict; use warnings; use 5.014;
import Module;
use Try::Tiny;
use Data::Dumper;
try {
Module::i("x");
} catch {
say Dumper $_;
};
sub _lm { longmess() }
sub l {
my ($x) = #_;
die( { data => 1, stack => _lm() } ) if $x =~ /\D/;
return $x;
}
or
sub l {
my ($x) = #_;
local $Carp::CarpLevel = $Carp::CarpLevel - 1;
die( { data => 1, stack => longmess() } ) if $x =~ /\D/;
return $x;
}
or
sub mycroak { die( { #_, stack => longmess() } ); }
sub l {
my ($x) = #_;
mycroak( data => 1 ) if $x =~ /\D/;
return $x;
}
(Replaced croak with die because you didn't take advantage of any of croak's functionality.)
From the BUGS section of Carp documentation:
The Carp routines don't handle exception objects currently. If called with a first argument that is a reference, they simply call die() or warn(), as appropriate.
If you simply call confess() without an arg, the line number will be reported.
Related
I have a weird problem I can't figure out. I created a simple sequence in Perl with anonymous functions.
sub{($data, sub{($data, sub{($data, sub{($data, empty)})})})};
And it works but I tired to implement tail optimizing and got some weird behaviour. Example. The iter function below works.
sub iter {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
$func->($data);
#_ = ($func, $next);#This #_ update works fine
goto &iter;
}
}
while this implementation of iter fails.
sub iter {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
$func->($data);
$_[1] = $next; #This #_ update fails
goto &iter;
}
}
Both updates of #_ yield the same values for #_ but the code behaves differently when it continues.. To see what I'm talking about try running the complete code below.
#! /usr/bin/env perl
package Seq;
use 5.006;
use strict;
use warnings;
sub empty {
sub{undef};
}
sub add {
my ($data, $seq) = #_;
sub{($data, $seq)};
}
sub iter {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
$func->($data);
#_ = ($func, $next);#This works fine
#$_[1] = $next; #This fails
goto &iter;
}
}
sub smap {
my ($func, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
sub{($func->($data), Seq::smap($func, $next))};
}else {
empty();
}
}
sub fold {
my ($func, $acc, $seq) = #_;
my ($data, $next) = $seq->();
if (defined $data) {
#_ = ($func, $func->($acc, $data), $next);
goto &Seq::fold;
}else {
$acc;
}
}
1;
package main;
use warnings;
use strict;
use utf8;
use List::Util qw(reduce);
my $seq =
reduce
{Seq::add($b, $a)}
Seq::empty,
(4143, 1234, 4321, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10);
Seq::iter(sub{my ($data) = #_; STDOUT->print("$data\n")}, $seq);
my $seq2 = Seq::smap(sub{my ($data) = #_; $data * 2}, $seq);
STDOUT->print("\n\n");
Seq::iter(sub{my ($data) = #_; STDOUT->print("$data\n")}, $seq2);
STDOUT->print("\n\n");
my $ans = Seq::fold(sub{my ($acc, $data) = #_; $acc + $data}, 0, $seq);
my $ans2 = Seq::fold(sub{my ($acc, $data) = #_; $acc + $data}, 0, $seq2);
STDOUT->print("$ans\n");
STDOUT->print("$ans2\n");
exit (0);
The code should work for both examples of iter but it doesn't.. Any pointers why?
Writing to $_[1] writes to the second scalar passed to the sub.
$ perl -E'$x = "abc"; say $x; sub { $_[0] = "def"; say $_[0]; }->($x); say $x;'
abc
def
def
So you are clobbering the caller's variables. Assigning to #_ replaces the scalars it contains rather than writing to them.
$ perl -E'$x = "abc"; say $x; sub { #_ = "def"; say $_[0]; }->($x); say $x;'
abc
def
abc
You can replace a specific element using splice.
$ perl -E'$x = "abc"; say $x; sub { splice(#_, 0, 1, "def"); say $_[0]; }->($x); say $x;'
abc
def
abc
It's far more convenient for iterators to return an empty list when they are exhausted. For starters, it allows them to return undef.
Furthermore, I'd remove the expensive recursive calls with quicker loops. These loops can be made particularly simple because of the change mentioned above.
The module becomes:
package Seq;
use strict;
use warnings;
sub empty { sub { } }
sub add {
my ($data, $seq) = #_;
return sub { $data, $seq };
}
sub iter {
my ($func, $seq) = #_;
while ( (my $data, $seq) = $seq->() ) {
$func->($data);
}
}
sub smap {
my ($func, $seq) = #_;
if ( (my $data, $seq) = $seq->() ) {
return sub { $func->($data), smap($func, $seq) };
} else {
return sub { };
}
}
sub fold {
my ($func, $acc, $seq) = #_;
while ( (my $data, $seq) = $seq->() ) {
$acc = $func->($acc, $data);
}
return $acc;
}
1;
Also, for speed reasons, replace
sub { my ($data) = #_; $data * 2 }
sub { my ($acc, $data) = #_; $acc + $data }
with
sub { $_[0] * 2 }
sub { $_[0] + $_[1] }
I'm to learn Perl for a job interview over weekend. In order to get a deeper understanding I'm trying to implement a tree class.
#use strict;
#use warnings;
package Tree;
sub new {
my $class = shift #_;
my $content = shift #_;
my #array = shift #_;
return bless { "content" => $content, "array" => #array }, $class;
}
sub num_children {
my $self = shift #_;
my #array = $self->{"array"};
return scalar #array;
}
return 1;
To test the (faulty) tree class I have implemented the following test script.
#!/usr/bin/perl
require Tree;
my $t = Tree->new("#", undef);
my $tt = Tree->new("*", undef);
my $tttt = Tree->new("-", undef);
my $ttttt = Tree->new(".", undef);
my #list = ();
push #list, $tt;
push #list, $t;
push #list, $tttt;
push #list, $ttttt;
my $ttt = Tree->new("+", #list);
print $ttt->num_children();
Unfortunately the output is 1 instead of my expection of 4. I assume the array is somehow cut off or unvoluntarily converted to a scalar. Any Ideas?
The main problem is that you can't pass arrays as a single value—you have to pass a reference instead.
Also, you should never comment out use strict and use warnings. They are valuable debugging tools, and if you are getting error messages with them enabled you should fix the errors that they are flagging instead.
Here's a working Tree.pm
use strict;
use warnings;
package Tree;
sub new {
my $class = shift;
my ($content, $array) = #_;
return bless { content => $content, array => $array }, $class;
}
sub num_children {
my $self = shift;
my $array = $self->{array};
return scalar #$array;
}
1;
and the calling program tree_test.pl. Note that you should use rather than require a module.
#!/usr/bin/perl
use strict;
use warnings;
use Tree;
my #list = map { Tree->new($_) } ('#', '*', '-', '.');
my $ttt = Tree->new('+', \#list);
print $ttt->num_children, "\n";
output
4
shift only removes one element from an array. Populate #array without it:
my #array = #_;
But, you can't store an array in a hash directly, you have to use a reference:
return bless { content => $content,
array => \#array,
}, $class;
which you then have to dereference:
my #array = #{ $self->{array} };
return scalar #array
I would like to sort my module subroutines alphabetically (I have a lot of subroutines, and I think it will be easier to edit the file if the subroutines are ordered in the file). For example given A.pm:
package A;
use warnings;
use strict;
sub subA {
print "A\n";
}
sub subC {
print "C\n";
}
sub subB {
print "B\n";
}
1;
I would like to run a sortSub A.pm the gives:
package A;
use warnings;
use strict;
sub subA {
print "A\n";
}
sub subB {
print "B\n";
}
sub subC {
print "C\n";
}
1;
Is there any CPAN resource that can help with this task?
To parse and reformat Perl code, you should use PPI.
This is the same tool that Perl::Critic and Perl::Tidy use to accomplish all of their feats.
In this case, I studied the code for PPI::Dumper to get a sense of how to navigate the Document Tree that PPI returns.
The following will parse source code and separate out sections containing subroutines and comments. It will tie the comments, pod, and whitespace before a subroutine with it, and then it will sort all the neighboring subs by their names.
use strict;
use warnings;
use PPI;
use Data::Dump;
my $src = do { local $/; <DATA> };
# Load a document
my $doc = PPI::Document->new( \$src );
# Save Sub locations for later sorting
my #group = ();
my #subs = ();
for my $i ( 0 .. $#{ $doc->{children} } ) {
my $child = $doc->{children}[$i];
my ( $subtype, $subname )
= $child->isa('PPI::Statement::Sub')
? grep { $_->isa('PPI::Token::Word') } #{ $child->{children} }
: ( '', '' );
# Look for grouped subs, whitespace and comments. Sort each group separately.
my $is_related = ($subtype eq 'sub') || grep { $child->isa("PPI::Token::$_") } qw(Whitespace Comment Pod);
# State change or end of stream
if ( my $range = $is_related .. ( !$is_related || ( $i == $#{ $doc->{children} } ) ) ) {
if ($is_related) {
push #group, $child;
if ( $subtype ) {
push #subs, { name => "$subname", children => [#group] };
#group = ();
}
}
if ( $range =~ /E/ ) {
#group = ();
if (#subs) {
# Sort and Flatten
my #sorted = map { #{ $_->{children} } } sort { $a->{name} cmp $b->{name} } #subs;
# Assign back to document, and then reset group
my $min_index = $i - $range + 1;
#{ $doc->{children} }[ $min_index .. $min_index + $#sorted ] = #sorted;
#subs = ();
}
}
}
}
print $doc->serialize;
1;
__DATA__
package A;
use warnings;
use strict;
=comment
Pod describing subC
=cut
sub subC {
print "C\n";
}
INIT {
print "Hello World";
}
sub subB {
print "B\n";
}
# Hello subA comment
sub subA {
print "A\n";
}
1;
Output:
package A;
use warnings;
use strict;
=comment
Pod describing subC
=cut
sub subC {
print "C\n";
}
INIT {
print "Hello World";
}
# Hello subA comment
sub subA {
print "A\n";
}
sub subB {
print "B\n";
}
1;
First, here's my solution;
#!/bin/sh
TOKEN=sub
gsed -e ':a;N;$!ba;s/\n/__newline__/g' "$1" > "$1.out"
gsed -i "s/__newline__\\s*$TOKEN\W/\\nsub /g" "$1.out"
sort $1.out -o $1.out
gsed -i 's/__newline__/\n/g' $1.out
Usage: token_sort.sh myfile.pl
This is how it works;
Replace all newlines with a placeholder, __newline__
break out all $TOKENS, in this case subs, to their own line
Sort the lines using unix sort
Replace back all the newlines
You should now have a sorted copy of your file in myfile.pl.out
A few caveats;
Add a comment, "# Something", or "#!/usr/bin/env perl" to the top of the file; this will ensure that the header block remains sorted at the top.
The sorted block will be the start of the current sub to the next sub - comments at above the sub will get sorted with the previous sub.
You need to use gnu-sed for this to work, on a mac this means doing a "brew install gnu-sed"
I'm writing a download sub module, I would like it looks like this:
Download.pm
Download/Wget.pm
Download/LWP.pm
Download/Curl.pm
Download/Socket.pm
My Download.pm should provide an api sub download($url). It will look for LWP module, then wget command, then curl command, if non of these exist, it will use Socket.
How can I write wrapper module?
Here is some example, how i did it:
How it works? It checks for some condition, and creates object depends on this condition. And subroutine also checks for reference type and calls the right method
file /tmp/Adapt/Base.pm (base module):
#!/usr/bin/perl
package Adapt::Base;
use strict;
use warnings;
sub new {
my $class = shift;
my $self;
if ( time % 3 ) {
require "/tmp/Adapt/First.pm";
$self = \Adapt::First->new(#_);
}
elsif ( time % 2 ){
require "/tmp/Adapt/Second.pm";
$self = \Adapt::Second->new(#_);
}
else {
require "/tmp/Adapt/Default.pm";
$self = \Adapt::Default->new(#_);
}
bless( $self, $class );
}
sub somesub {
my $s = shift;
my $self = $$s;
if ( ref( $self ) eq 'Adapt::First' ) {
$self->firstsub();
}
elsif ( ref( $self ) eq 'Adapt::Second' ) {
$self->secondsub();
}
else {
$self->defaultsub();
}
}
1;
file /tmp/Adapt/First.pm (some module):
#!/usr/bin/perl
package Adapt::First;
use strict;
use warnings;
sub new {
my $class = shift;
my $self = {};
bless( $self, $class );
}
sub firstsub {
print "I am 1st sub.\n";
}
1;
file /tmp/Adapt/Second.pm (another module):
#!/usr/bin/perl
package Adapt::Second;
use strict;
use warnings;
sub new {
my $class = shift;
my $self = {};
bless( $self, $class );
}
sub secondsub {
print "I am 2nd sub.\n";
}
1;
and file /tmp/Adapt/Default.pm (default module):
#!/usr/bin/perl
package Adapt::Default;
use strict;
use warnings;
sub new {
my $class = shift;
my $self = {};
bless( $self, $class );
}
sub defaultsub {
print "I am default sub.\n";
}
1;
and test script:
#!/usr/bin/perl
use strict;
use warnings;
require '/tmp/Adapt/Base.pm';
for (0..10) {
my $test = Adapt::Base->new;
$test->somesub;
sleep 1;
}
output:
dev# perl /tmp/adapt.pl
I am default sub.
I am 1st sub.
I am 1st sub.
I am 2nd sub.
I am 1st sub.
I am 1st sub.
I am default sub.
I am 1st sub.
I am 1st sub.
I am 2nd sub.
I am 1st sub.
dev#
I'm not sure why perl isn't recognizing the Heap's method add. Getting message given in question title. Here are the most relevant files.
#!/usr/bin/perl -w
use strict;
use Util;
use Heap;
use HuffTree;
my $heap = Heap->new;
my $test = 3;
$heap->add($test); # <--------ERROR HERE-----------
package Heap;
use strict;
use warnings;
use POSIX ();
sub new {
my $class = shift;
my $self = { "aref" => [""],
"next" => 1,
#_};
bless $self, $class;
}
sub print {
my $self = shift;
my $next = $self->{"next"};
my $aref = $self->{"aref"};
print "array => #$aref\n";
print "next => $next\n";
}
sub compare {
my ($self, $i, $j) = #_;
my $x = $self->{"aref"}[$i];
my $y = $self->{"aref"}[$j];
if (!defined $x) {
if (!defined $y) {
return 0;
} else {
return -1;
}
}
return 1 if !defined $y;
return $x->priority <=> $y->priority;
}
sub swap {
my ($self, $i, $j) = #_;
my $aref = $self->{"aref"};
($aref->[$i], $aref->[$j]) = ($aref->[$j], $aref->[$i]);
}
sub add {
my ($self, $value) = #_;
my $i = $self->{"next"};
$self->{"aref"}[$i] = $value;
while ($i > 1) {
my $parent = POSIX::floor($i/2);
last if $self->compare($i, $parent) <= 0;
$self->swap($i, $parent);
$i = $parent;
}
$self->{"next"}++;
}
sub reheapify {
my ($self, $i) = #_;
my $left = 2 * $i;
my $right = 2 * $i + 1;
my $winleft = $self->compare($i, $left) >= 0;
my $winright = $self->compare($i, $right) >= 0;
return if $winleft and $winright;
if ($self->compare ($left, $right) > 0) {
$self->swap($i, $left);
$self->reheapify($left);
} else {
$self->swap($i, $right);
$self->reheapify($right);
}
}
sub remove {
my $self = shift;
my $aref = $self->{"aref"};
my $result = $aref->[1];
$aref->[1] = pop #$aref;
$self->{"next"}--;
$self->reheapify(1);
return $result;
}
sub empty {
my $self = shift;
return $self->{"next"} == 1;
}
1;
package HuffTree;
use warnings;
use strict;
use Pair;
our #ISA = "Pair";
sub priority {
my $self = shift;
# lowest count highest priority
return -$self->{frequency};
}
sub left {
my $self = shift;
return $self->{left};
}
sub right {
my $self = shift;
return $self->{right};
}
1;
package Pair;
use warnings;
use strict;
sub new {
my $class = shift;
my $self = { #_ };
bless $self, $class;
}
sub letter {
my $self = shift;
return $self->{letter};
}
sub frequency {
my $self = shift;
return $self->{frequency};
}
sub priority {
my $self = shift;
return $self->{frequency};
}
1;
package Util;
use strict;
use warnings;
sub croak { die "$0: #_: $!\n"; }
sub load_arg_file {
my $path_name = shift #ARGV;
my $fh;
open($fh, $path_name) || croak "File not found.\n";
return $fh;
}
1;
You have a Heap.pm installed from CPAN. That's what gets loaded, not your own Heap.pm. The new sub in the Heap.pm from CPAN looks like this:
sub new {
use Heap::Fibonacci;
return &Heap::Fibonacci::new;
}
Which is actually a bug in said module, because Heap::Fibonacci uses the
standard bless \$h, $class; thing in its new sub,
so the reference is blessed into the Heap package, which
does indeed not have a sub called add (Heap::Fibonacci does).
To solve your immediate problem, you can:
make sure that your module is picked up before the "other" Heap (by modifying #INC with use lib, for example;
or not reinvent the wheel and actually use Heap::Fibonacci).
At any rate, it might be a good idea to report this problem
to the Heap module author - because even if you did not have
your own Heap.pm, your code would still fail with the same message.