Perl: library to log on specific files - perl

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
$

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.

Search file in directory structure

Does anybody know a method to search for a file in a directory structure without using File::Find? I know step-by-step how to do it but if it is possible to make it smoother that will be helpful.
File::Find is a core module since perl 5.000 so I don't see a reason for not using it.
But if you still want to take your crazy way you could call the find command.
From one File::Find hater to another: DirWalk.pm, inspired by the Python's os.walk().
package DirWalk;
use strict;
use warnings;
sub new {
my ($class, #dirs) = #_;
my #odirs = #dirs;
#dirs = qw/./ unless #dirs;
s!/+$!! for #dirs;
s!/+\.$!! for #dirs;
my $self = { _odirs => [#odirs], _dirs => [#dirs], _dhstack => [], _dnstack => [] };
opendir my($dirh), $dirs[0];
return undef unless $dirh;
shift #{ $self->{_dirs} };
unshift #{ $self->{_dhstack} }, $dirh;
unshift #{ $self->{_dnstack} }, $dirs[0];
return bless $self, $class;
}
sub _walk_op {
my ($self) = #_;
if (wantarray) {
my #ret;
while (defined(my $x = $self->next())) {
push #ret, $x;
}
return #ret;
}
elsif (defined wantarray) {
return $self->next();
}
return undef;
}
sub next
{
my ($self) = #_;
my $dstack = $self->{_dhstack};
my $nstack = $self->{_dnstack};
if (#$dstack) {
my $x;
do {
$x = readdir $dstack->[0];
} while (defined($x) && ($x eq '.' || $x eq '..'));
if (defined $x) {
my $nm = $nstack->[0].'/'.$x;
if (-d $nm) {
# open dir, and put the handle on the stack
opendir my($dh), $nm;
if (defined $dh) {
unshift #{ $self->{_dhstack} }, $dh;
unshift #{ $self->{_dnstack} }, $nm;
}
else {
warn "can't walk into $nm!"
}
$nm .= '/';
}
# return the name
return $nm;
}
else {
closedir $dstack->[0];
shift #$dstack;
shift #$nstack;
unless (#$dstack) {
while (#{ $self->{_dirs} }) {
my $dir = shift #{ $self->{_dirs} };
opendir my($dirh), $dir;
next unless defined $dirh;
unshift #{ $self->{_dhstack} }, $dirh;
unshift #{ $self->{_dnstack} }, $dir;
last;
}
}
return $self->next();
}
}
else {
return undef;
}
}
use overload '<>' => \&_walk_op;
use overload '""' => sub { 'DirWalk('.join(', ', #{$_[0]->{_odirs}}).')'; };
1;
Example:
# prepare test structure
mkdir aaa
touch aaa/bbb
mkdir aaa/ccc
touch aaa/ccc/ddd
# example invocation:
perl -mDirWalk -E '$dw=DirWalk->new("aaa"); say while <$dw>;'
#output
aaa/ccc/
aaa/ccc/ddd
aaa/bbb
Another example:
use strict;
use warnings;
use DirWalk;
# iteration:
my $dw = DirWalk->new("aaa");
while (<$dw>) {
print "$_\n";
}
# or as a list:
$dw = DirWalk->new("aaa");
my #list = <$dw>;
for (#list) {
print "$_\n";
}
The method I've been inplamenting is utilizing three commands: opendir, readdir, and closedir. See below for an example:
opendir my $dir1, $cwd or die "cannot read the directory $cwd: $!";
#cwd= readdir $dir1;
closedir $dir1;
shift #cwd; shift #cwd;
foreach(#cwd){if ($_=~/$file_search_name/){print "I have found the file in $_\n!";}}
The directory will be stored in #cwd, which includes . and .. For windows, shift #cwd will remove these. I unfortunately am tight for time, but utilize this idea with an anon array to store the directory handles as well as another array for storing the directory paths. Perhaps utilize -d to check if it is a directory. There might be file permission issues, so perhaps unless(opendir ...) would be a great option.
Best of luck.
I'm sure I will be flayed alive for this answer but you could always use either system() or backticks `` to execute the regular linux find command. Or do some sort of ls...
#files = `ls $var/folder/*.logfile`
#files = `find . -name $file2find`
I expect some seasoned perlers have many good reasons not to do this.
yon can also try some stuff like this!!!
# I want to find file xyz.txt in $dir (say C:\sandbox)
Findfile("xyz.txt", $dir);
sub Findfile ()
{
my $file = shift;
my $Searchdir = shift;
my #content = <$Searchdir/*>;
foreach my $element (#content)
{
if($element =~ /.*$file$/)
{
print "found";
last;
}
elsif (-d $element)
{
Findfile($file, $element); #recursive search
}
}
}
File::Find::Rule is "smoother".
use File::Find::Rule qw( );
say for File::Fine::Rule->in(".");

Preserve local context across nested subroutines

Let's consider the wanted code below. I have recursive calls to process and for each recursion I use a local %context. In this way I can get my context back when I return from a call.
sub process {
my %context; # Local context
process() if rerun();
job1();
job2();
sub job1() {print $context{foo}}
sub job2() {print $context{bar}}
}
Unfortunately perl does not manage nested subroutines as I expected. By moving my subroutines outside from the process subroutine I will get a problem because I won't be able to access %context anymore. So I need to make it global and use a stack as follow:
my %context; # Local context
my #context_stack;
sub process {
push #context_stack, %context;
%context = undef;
process() if rerun();
job1();
job2();
%context = pop #context_stack;
}
sub job1() {print $context{foo}}
sub job2() {print $context{bar}}
The third solution is to pass the context to all subroutines which can be annoying for very small subroutines. Also %context become global to all my program. So I loose the privacy of this variable.
my %context; # Local context
my #context_stack;
sub process {
push #context_stack, %context;
%context = undef;
process() if rerun(\%context);
job1(\%context);
job2(\%context);
%context = pop #context_stack;
}
sub job1() {$context = shift; print $context->{foo}}
sub job2() {$context = shift; print $context->{bar}}
What would be the best approach?
EDIT
For a better understanding of my specific, I provide another example:
process(#ARGV);
exit 0;
sub process {
my $infile = shift;
my $outfile = shift;
open my $fp_in, '<', $infile;
open my $fp_out, '>', $outfile;
LINE: while(<$fp_in>) {
remove_c_comment();
say STDERR "File is $infile";
process($1, "$1.processed") if /#include "(.*?)";
warning("Huh raisin, no!") if /\braisin/;
say STDERR "Fill is still $infile";
print $fp_out $_;
}
sub remove_c_comment { s|//.*$|| }
sub warning { say "[Warning] $infile:$. ".shift() }
}
The thing you're looking for - but you may not know it - is called a closure. (see also: perlref)
{
my %context;
sub job1 { print $context{foo} };
sub job2 { print $context{bar} };
sub init_context{ $context{foo} = 1 };
}
Context remains private within this block, but accessible to all the subroutines.
As an alternative - you can return a code reference from a subroutine - like this:
use strict;
use warnings;
sub make_sub_with_context {
my %context;
$context{"bar"} = 1;
return sub { print $context{"bar"}++ };
}
my $job1_with_context = make_sub_with_context();
my $another_job_with_context = make_sub_with_context();
$job1_with_context->();
$job1_with_context->();
$another_job_with_context->();
$another_job_with_context->();
$another_job_with_context->();
Which may be a better example.
Edit:
Following on from your updated example it looks like your problem spec is to iterate a set of files, and (recursively) traverse referenced files.
Sort of like a find but following include directives. I would point out that by doing it that way, what you're doing is potentially going to end up with a loop, which isn't ideal.
Can I suggest instead taking a different approach? Don't recurse:
use strict;
use warnings;
my #files_to_process = #ARGV;
my %done;
while ( my $infile = pop #files_to_process ) {
next if $done{$infile}++;
open my $fp_in, '<', $infile or die $!;
open my $fp_out, '>', $infile . ".processed" or die $!;
while ( my $line = <$fp_in> ) {
$line =~ s|\/\/.*$||;
if ( my ($include) = ( $line =~ m/#include "(.*?)"/ ) ) {
push #files_to_process, $include;
}
print {$fp_out} $line;
}
close($fp_out);
close($fp_in);
}
With a bit more thought, and the expansion that this task needs to process stuff in declaration order - I'd offer instead - perhaps taking an OO approach would help. Something like:
use strict;
use warnings;
package parser;
sub new {
my ($class) = #_;
my $self = {};
bless $self, $class;
return $self;
}
sub process {
my ( $self, $infile, $outfile ) = #_;
open my $fp_in, '<', $infile;
open my $fp_out, '>', $outfile;
LINE: while ( my $line = <$fp_in> ) {
$line =~ s|\/\/.*$||;
say STDERR "File is $infile";
if ( my ($includefile) = ( $line =~ m/#include "(.*?)"/ ) ) {
my $processor = parser->new();
$processor -> process( $includefile, "$includefile.processed" );
}
$self->warning("Huh raisin, no!") if /\braisin/;
say STDERR "Fill is still $infile";
print $fp_out $line;
}
}
package main;
my $processor = parser->new()->process(#ARGV);

How can I modify the output of the PRINT function using Tie with a Moose implementation?

I can't exactly wrap my head around TIE just yet but the examples ( example-1 example-2 example-3 ) I've seen so far use a non-Moosy implementation, is there anyway to do this:
package MY_STDOUT;
use strict;
my $c = 0;
my $malformed_header = 0;
open(TRUE_STDOUT, '>', '/dev/stdout');
tie *STDOUT, __PACKAGE__, (*STDOUT);
sub TIEHANDLE {
my $class = shift;
my $handles = [#_];
bless $handles, $class;
return $handles;
}
sub PRINT {
my $class = shift;
if (!$c++ && #_[0] !~ /^content-type/) {
my (undef, $file, $line) = caller;
print STDERR "Missing content-type in $file at line $line!!\n";
$malformed_header = 1;
}
return 0 if ($malformed_header);
return print TRUE_STDOUT #_;
}
1;
use MY_STDOUT;
print "content-type: text/html\n\n"; #try commenting out this line
print "<html>\n";
print "</html>\n";
In a more Perl-Moosy way?
For example should I do
open(TRUE_STDOUT, '>', '/dev/stdout');
tie *STDOUT, __PACKAGE__, (*STDOUT);
in a BUILD{} function?
Would it make more sense to implement this as a Moosy class or as Moose::Role?
And finally, would I have to do something like
my $MY_STDOUT = MY_STDOUT->new();
to use it?
I've figured out how to do it with IO::Scalar
https://gist.github.com/1250048
Now I just need to figure out how to do it for STDOUT!

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

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.