Can't locate object method "add" via package "Heap" - perl

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.

Related

How to get right line number when Carp::croaked?

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.

Tail call Recursion "Optimising"

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] }

Perl - data retrieval with hash of objects

I have a class with getter and setter methods. I am creating a hash of objects of this class.
my %hash;
$hash{'foo'} = Myclass->new();
$hash{'bar'} = Myclass->new();
...
With a created object I am trying to set the data to a particular attribute of the package. It is successful and doesn't show any issues. But if I try to retrieve the data, the last value that is set is returned.
Code:
#!/usr/bin/perl
package Metadata;
my $myname = "";
sub new {
my $type = shift;
my $self = {};
bless $self, $type;
return $self;
}
sub setMyname {
my ($self, $tempName) = #_;
$myname = $tempName;
}
sub getMyname {
return $myname;
}
package main;
use YAML::XS 'LoadFile';
use Data::Dumper;
my %objHash = ();
my #list;
my $myname;
my $i = 0;
my #conf = LoadFile('input.yml');
my $config = \#conf;
foreach ( #conf ) {
$list[$i] = $config->[$i]->{mykey};
$objHash{$list[$i]} = Metadata->new();
$myname = $config->[$i]->{myname};
$objHash{$list[$i]}->setMyname($myname);
my $host = $objHash{$list[$i]}->getMyname();
$i++;
}
my $host = $objHash{$list[0]}->getMyname();
print $host;
print "\n";
my $host = $objHash{$list[1]}->getMyname();
print $host;
print "\n";
my $host = $objHash{$list[2]}->getMyname();
print $host;
print "\n";
YAML:
---
mykey: 1
myname: John
---
mykey: 2
myname: Doe
----
mykey: 3
myname: Chris
...
Expected output
John
Doe
Chris
Actual output
Chris
Chris
Chris
Am I missing anything?
You're storing the names of every object in $myname instead of in the object!
package Metadata;
use strict;
use warnings qw( all );
sub new {
my ($class) = #_;
my $self = bless({}, $class);
$self->{name} = undef;
return $self;
}
sub set_name {
my ($self, $name) = #_;
$self->{name} = $name;
}
sub get_name {
my ($self) = #_;
return $self->{name};
}
1;

Perl: library to log on specific files

I'm creating a library for my stuffs where I want to log errors on a specific file. Unfortunately, while it works if I initiate only one single instance of the library, it doesn't if I initiate more than one instance.
The results in that case is that the output is logged all in the last file and not half and half as I was expecting.
This is the main.pl
eval 'exec /usr/bin/perl -I `pwd` -S $0 ${1+"$#"}'
if 0;
use strict;
use MyLibrary;
my ($rc, $test_2, $test_1);
# The output is not going into this file
exit $test_1 if (($test_1 = MyLibrary->new("/tmp", "test_1")) !~ "HASH");
# It is going all into this file
exit $test_2 if (($test_2 = MyLibrary->new("/tmp", "test_2")) !~ "HASH");
exit $rc if ( $rc = $test_1->test() );
exit $rc if ( $rc = $test_2->test() );
and this is MyLibrary.pm
package MyLibrary;
use strict;
use Symbol;
use vars qw($VERSION #ISA #EXPORT %default);
#EXPORT = qw(
);
$VERSION = '1.00';
require 5.000;
%default;
my $fh;
sub new
{
my $rc;
my ($proto, $log_dir, $log_file) = #_;
my $class = ref($proto) || $proto;
my $self = { %default };
bless($self, $class);
$fh = gensym;
($self->{'log_dir'}, $self->{'log_file'}) = ($log_dir, $log_file);
return $rc if ( $rc = $self->open_log_file() );
return $self;
}
sub destroy
{
my $rc;
my $self = shift;
return $rc if ( $rc = $self->close_log_file() );
}
sub open_log_file
{
my $self = shift;
open $fh, ">>$self->{'log_dir'}/$self->{'log_file'}" or die "cannot open file $self->{'log_dir'}/$self->{'log_file'}";
return 0;
}
sub close_log_file
{
my $self = shift;
close($fh) or die "cannot close $self->{'log_dir'}/$self->{'log_file'}";
return 0;
}
sub test
{
my $self = shift;
print $fh "[$self->{'log_file'}]\n";
return 0;
}
1;
One more thing ... In this example, I'm using $fh as a global variable, while I would like to have this variable part of the %default hash. However, if I try to make it part of the hash replacing all the $fh occurences with $self->{'fh'}, I get the following error:
String found where operator expected at MyLibrary.pm line 75, near "} "[$self->{'log_file'}]\n""
(Missing operator before "[$self->{'log_file'}]\n"?)
syntax error at MyLibrary.pm line 75, near "} "[$self->{'log_file'}]\n""
Row 75 in this case will be the following:
sub test
{
my $self = shift;
Row 75 =>>> print $self->{'fh'} "[$self->{'log_file'}]\n";
return 0;
}
While the full library reviewed accordingly is:
package MyLibrary;
use strict;
use Symbol;
use vars qw($VERSION #ISA #EXPORT %default);
#EXPORT = qw(
);
$VERSION = '1.00';
require 5.000;
%default;
sub new
{
my $rc;
my ($proto, $log_dir, $log_file) = #_;
my $class = ref($proto) || $proto;
my $self = { %default };
bless($self, $class);
$self->{'fh'} = gensym;
($self->{'log_dir'}, $self->{'log_file'}) = ($log_dir, $log_file);
return $rc if ( $rc = $self->open_log_file() );
return $self;
}
sub destroy
{
my $rc;
my $self = shift;
return $rc if ( $rc = $self->close_log_file() );
}
sub open_log_file
{
my $self = shift;
open $self->{'fh'}, ">>$self->{'log_dir'}/$self->{'log_file'}" or die "cannot open file $self->{'log_dir'}/$self->{'log_file'}";
return 0;
}
sub close_log_file
{
my $self = shift;
close($self->{'fh'}) or die "cannot close $self->{'log_dir'}/$self->{'log_file'}";
return 0;
}
sub test
{
my $self = shift;
print $self->{'fh'} "[$self->{'log_file'}]\n";
return 0;
}
1;
Empirically, it seems that the file handle in a print statement cannot be an arbitrary expression. This is really only a minor modification of your code, but to get MyLibrary.pm to compile, I replaced:
print $self->{'fh'} "[$self->{'log_file'}]\n";
with:
my $fh = $self->{'fh'};
print $fh "[$self->{'log_file'}]\n";
There are some other minor tweaks, but this code worked for me:
MyLibrary.pm
package MyLibrary;
use warnings;
use strict;
use vars qw($VERSION #ISA #EXPORT %default);
#EXPORT = qw();
$VERSION = '1.00';
require 5.000;
sub new
{
my ($proto, $log_dir, $log_file) = #_;
my $class = ref($proto) || $proto;
my $self = { %default };
bless($self, $class);
$self->{'log_dir'} = $log_dir;
$self->{'log_file'} = $log_file;
$self->open_log_file();
return $self;
}
sub destroy
{
my $rc;
my $self = shift;
return $rc if ( $rc = $self->close_log_file() );
}
sub open_log_file
{
my $self = shift;
my $log_file = "$self->{log_dir}/$self->{log_file}";
open $self->{'fh'}, ">>", $log_file or die "cannot open file $log_file";
return;
}
sub close_log_file
{
my $self = shift;
close($self->{'fh'}) or die "cannot close $self->{'log_dir'}/$self->{'log_file'}";
return;
}
sub print_data
{
my $self = shift;
my $fh = $self->{fh};
print $fh #_, "\n";
}
sub test
{
my $self = shift;
my $fh = $self->{'fh'};
print $fh "[$self->{'log_file'}]\n";
return 0;
}
1;
I'm not convinced that the use 5.000; buys you very much. The chances of finding a Perl 4.x still running are pretty remote. These days, anything earlier than Perl 5.8 is long dead (or, if it isn't, it should be).
There are many minor improvements that could be made in the code that are not shown above.
testcase.pl
#!/usr/bin/env perl
use warnings;
use strict;
use MyLibrary;
my ($rc, $test_2, $test_1);
my $counter = 0;
sub counter
{
printf"OK %d\n", ++$counter;
}
counter;
# The output is not going into this file
exit $test_1 if (($test_1 = MyLibrary->new("/tmp", "test_1")) !~ "HASH");
counter;
# It is going all into this file
exit $test_2 if (($test_2 = MyLibrary->new("/tmp", "test_2")) !~ "HASH");
counter;
exit $rc if ( $rc = $test_1->test() );
counter;
exit $rc if ( $rc = $test_2->test() );
counter;
$test_1->print_data("Extra information");
$test_2->print_data("Missing syncopation");
print "Finished\n";
Nth Sample Run
It looks like I ran a previous edition of testcase.pl once, before adding the print_data function, and four times since adding the print_data function.
$ perl -I$PWD testcase.pl
OK 1
OK 2
OK 3
OK 4
OK 5
Finished
$ cat /tmp/test_1
[test_1]
[test_1]
Extra information
[test_1]
Extra information
[test_1]
Extra information
[test_1]
Extra information
$ cat /tmp/test_2
[test_2]
[test_2]
Missing syncopation
[test_2]
Missing syncopation
[test_2]
Missing syncopation
[test_2]
Missing syncopation
$

OOP design suggestion

I have set of files that needs to either emailed or FTPed(read from config). Before doing either of these I need to so some common operation on the files, like changing filenames, sanity check, so on.
package Class::Foo::Partners;
use Carp;
use Data::Dumper;
# Sanity check and Blessing
sub new ($) {
my $class = shift;
my %attr = #_;
Carp::confess('Config undefined') unless defined $attr{cfg};
my $self = bless({}, $class);
%$self = #_;
return $self;
}
sub process {
my $self = shift;
my %filestoupload = ();
if ($self->{dbh}->sql($sql, \%filestoupload)) {
my $stats;
if (defined $self->{cfg}->{$self->{section}}->{pdf_email_rcpt}) {
$stats = Class::Foo::Email->new(section => $self->{cfg}->{$self->{section}}, filestoupload => \%filestoupload);
$stats->sendfiles;
} else {
$stats = Class::Foo::FTP->new(section => $self->{cfg}->{$self->{section}}, filestoupload => \%filestoupload);
$stats->sendfiles;
}
} elsif ($self->{dbh}->{_error}) {
Carp::confess($self->{dbh}->{_error});
} else {
print "NO FILES";
}
}
package Class::Foo::FTP;
use Carp;
use Data::Dumper;
use POSIX qw( strftime );
use File::Temp qw (tempdir) ;
use File::Copy;
use Net::FTP;
# Sanity check and Blessing
sub new ($) {
my $class = shift;
my %attr = #_;
Carp::confess('Section undefined') unless defined $attr{section};
Carp::confess('undefined ftp_host') unless defined $attr{section}->{ftp_host};
my $self = bless({}, $class);
%$self = #_;
return $self;
}
sub sendfiles {
my $self = shift;
return unless(keys %{$self->{filestoupload}});
#DO SOME COMMON TASK
..
$self->ftp_connect();
..
..
}
package Class::Foo::Email;
use Data::Dumper;
use Mail::Sender;
use POSIX qw( strftime );
use File::Temp qw (tempdir) ;
use File::Copy;
sub new ($) {
my $class = shift;
my %attr = #_;
Carp::confess('Config: undefined pdf_email_subject') unless defined $attr{section}->{pdf_email_subject};
Carp::confess('Config: undefined pdf_email_from') unless defined $attr{section}->{pdf_email_from};
my $self = bless({}, $class);
%$self = #_;
return $self;
}
sub sendfiles {
my $self = shift;
return unless(keys %{$self->{filestoupload}});
#DO SOME COMMON TASK
..
my $mailrcpt = $self->{section}->{pdf_email_rcpt};
my $sender = new Mail::Sender {smtp => 'localhost', from => $self->{section}->{pdf_email_from}};
$sender->MailFile({ to => $mailrcpt,
subject => $self->{section}->{pdf_email_subject},
msg => "Attached is A1 of today's WSJE. ",
ctype => 'application/pdf',
file => #files } );
$self->{uploaded_count} = #files;
}
Where to do the common operation and when and how to call respective child classes?
Should I use abstraction?
thanks for your help
Check out the implementation of MT::FileMgr:
https://github.com/openmelody/melody/tree/master/lib/MT
It should give you a lot of ideas on how to do Perl OOP for something like this.