Perl: Pass on (Log4perl-)object to module - perl

I came to appreciate Log4perl and I would like to make use of it across the main Perl-script and (several) modules. How do I implement it, preferably in an OO-fashion?
Is it possible to hook up the logger-object (of the main script) with the object of the module in order to fully log events that happen in the main script as well as events of the module('s object)?
Say I've got something like this main-script:
use rotate_action;
use Log::Log4perl;
my $logger = get_logger();
my $appender_log = Log::Log4perl::Appender->new(
"Log::Dispatch::File",
filename => "action.log",
mode => "append"
);
$logger->add_appender($appender_log);
$logger->info("Logger activated");
use rotate_action;
my $ro = Rotation->new; # package in rotate_action.pm
#associate logger-object with ro-object here:
$ro->$logger; # pseudo-code!
my $file "somefile";
$logger->info("processing $file");
$ro->process_file("$file");
$logger->info("finished processing $file);
And a module rotate_action like this:
{
package Rotation;
sub new {
my $class = shift;
my $self = {};
bless $self, $class;
return $self;
}
sub process_file {
my $self = shift;
my $file = shift;
my $exec_string = "identify -format \"orientation: %[orientation]\ngeometry: %g\n\"";
$exec_string .= " $file";
my $exec_result = `$exec_string 2>&1`;
my $err_lvl = $?;
if ($err_lvl != 0) {
#put same logger-object from main script here:
$self->$logger->warn("$file is not an image"); # pseudo-code!
} else {
#put same logger-object from main script here:
$self->$logger->info("rotate $file"); # pseudo-code!
`rotate.sh $file`;
}
}
}
How do I pass the logger-object on to the module in order to write to the same logfile (as configured in the main-script)?

You can add a logger field to the object and store the logger there:
sub add_logger {
my ($self, $logger) = #_;
$self->{logger} = $logger;
}
Which would be called like
$ro->add_logger($logger);
And you can then
$self->{logger}->warn("$file is not an image");
Or you can provide the logger directly to the constructor.

Related

Is it possible to register a function to preprocess log messages with Log::Log4perl?

In this example:
$logger->debug({
filter => \&Data::Dumper::Dumper,
value => $ref
});
I can pretty print my references instead of ARRAY(0xFFDFKDJ). But it's too boring to type that long code every time. I just want:
$logger->preprocessor({
filter => \&Data::Dumper::Dumper,
value => $ref
});
$logger->debug( $ref, $ref2 );
$logger->info( $array );
And $ref, $ref2, and $array will be dumped by Data::Dumper.
It there a way to do this?
UPD
With help of your answers I do the patch
Now you just:
log4perl.appender.A1.layout=FallbackLayout
log4perl.appender.A1.layout.chain=PatternLayout
log4perl.appender.A1.layout.chain.ConversionPattern=%m%n
log4perl.appender.A1.warp_message = sub { $#_ = 2 if #_ > 3; \
return #_; }
# OR
log4perl.appender.A1.warp_message = main::warp_my_message
sub warp_my_message {
my( #chunks ) = #_;
use Data::Dump qw/ pp /;
for my $msg ( #chunks ) {
$msg = pp $msg if ref $msg;
}
return #chunks;
}
UPD2
Or you can use this small module
log4perl.appender.SomeAPP.warp_message = Preprocess::Messages::msg_filter
log4perl.appender.SomeAPP.layout = Preprocess::Messages
package Preprocess::Messages;
sub msg_filter {
my #chunks = #_;
for my $msg ( #chunks ) {
$msg = pp $msg if ref $msg;
}
return #chunks;
};
sub render {
my $self = shift;
my $layout = Log::Log4perl::Layout::PatternLayout->new(
'%d %P %p> %c %F:%L %M%n %m{indent=2}%n%n'
);
$_[-1] += 1; # increase level of the caller
return $layout->render( join $Log::Log4perl::JOIN_MSG_ARRAY_CHAR, #{ shift() }, #_ );
}
sub new {
my $class = shift;
$class = ref ($class) || $class;
return bless {}, $class;
}
1;
Yes, of course you can set 'warp_message = 0' and combine msg_filter and render together.
log4perl.appender.SomeAPP.warp_message = 0
log4perl.appender.SomeAPP.layout = Preprocess::Messages
sub render {
my($self, $message, $category, $priority, $caller_level) = #_;
my $layout = Log::Log4perl::Layout::PatternLayout->new(
'%d %P %p> %c %F:%L %M%n %m{indent=2}%n%n'
);
for my $item ( #{ $message } ) {
$item = pp $item if ref $item;
}
$message = join $Log::Log4perl::JOIN_MSG_ARRAY_CHAR, #$message;
return $layout->render( $message, $category, $priority, $caller_level+1 );
}
The easy way: use warp_message
The easiest way to do this is to create a custom appender and set the warp_message parameter so you can get the original references that were passed to the logger:
package DumpAppender;
use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Terse = 1;
sub new {
bless {}, $_[0];
}
sub log {
my($self, %params) = #_;
print ref($_) ? Dumper($_) : $_ for #{ $params{message} };
print "\n";
}
package main;
use strict;
use warnings;
use Log::Log4perl;
Log::Log4perl->init(\q{
log4perl.rootLogger=DEBUG,Dump
log4perl.appender.Dump=DumpAppender
log4perl.appender.Dump.layout=NoopLayout
log4perl.appender.Dump.warp_message=0
});
my $logger = Log::Log4perl->get_logger;
$logger->debug(
'This is a string, but this is a reference: ',
{ foo => 'bar' },
);
Output:
This is a string, but this is a reference: {'foo' => 'bar'}
Unfortunately, if you take this approach, you're stuck writing your own code to handle layouts, open files, etc. I wouldn't take this approach except for very simple projects that only need to print to screen.
A better way: composite appender
A better approach is to write your own composite appender. A composite appender forwards messages on to another appender after manipulating them somehow, e.g. filtering or caching them. With this approach, you can write only the code for dumping the references and let an existing appender do the heavy lifting.
The following shows how to write a composite appender. Some of this is explained in the docs for Log::Log4perl::Appender, but I copied much of it from Mike Schilli's Log::Log4perl::Appender::Limit:
package DumpAppender;
use strict;
use warnings;
our #ISA = qw(Log::Log4perl::Appender);
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Terse = 1;
sub new {
my ($class, %options) = #_;
my $self = {
appender => undef,
%options
};
# Pass back the appender to be limited as a dependency to the configuration
# file parser.
push #{ $options{l4p_depends_on} }, $self->{appender};
# Run our post_init method in the configurator after all appenders have been
# defined to make sure the appenders we're connecting to really exist.
push #{ $options{l4p_post_config_subs} }, sub { $self->post_init() };
bless $self, $class;
}
sub log {
my ($self, %params) = #_;
# Adjust call stack so messages are reported with the correct caller and
# file
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2;
# Dump all references with Data::Dumper
$_ = ref($_) ? Dumper($_) : $_ for #{ $params{message} };
$self->{app}->SUPER::log(
\%params,
$params{log4p_category},
$params{log4p_level}
);
}
sub post_init {
my ($self) = #_;
if(! exists $self->{appender}) {
die "No appender defined for " . __PACKAGE__;
}
my $appenders = Log::Log4perl->appenders();
my $appender = Log::Log4perl->appenders()->{$self->{appender}};
if(! defined $appender) {
die "Appender $self->{appender} not defined (yet) when " .
__PACKAGE__ . " needed it";
}
$self->{app} = $appender;
}
package main;
use strict;
use warnings;
use Log::Log4perl;
Log::Log4perl->init(\q{
log4perl.rootLogger=DEBUG, Dump
log4perl.appender.Dump=DumpAppender
log4perl.appender.Dump.appender=SCREEN
log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
log4perl.appender.SCREEN.layout=PatternLayout
log4perl.appender.SCREEN.layout.ConversionPattern=%d %p %m%n
});
my $logger = Log::Log4perl->get_logger;
$logger->debug(
'This is a string, but this is a reference: ',
{ foo => 'bar' },
);
Output:
2015/09/14 13:38:47 DEBUG This is a string, but this is a reference: {'foo' => 'bar'}
Note that you have to take some extra steps if you initialize Log::Log4perl via the API instead of via a file. This is documented in the composite appenders section of the Log::Log4perl::Appender documentation.

Link a variable to a class attribute in Perl

This question was born out of another (Completely destroy all traces of an object in Perl). After seeing some of the comments I believe I have narrowed the problem down to the "real" issue.
I'm looking for a simple way to link a variable to a class attribute in Perl so that whenever the attribute is modified, the variable will be automatically updated.
ex (some pseudo code):
# Create a file object
my $file = File->new();
# Get the text
my $text = $file->text();
# prints 'hello'
print $text;
# Set the text
$file->text('goodbye');
# prints 'goodbye'
print $text;
Also I want the $text variable to be read only so that you cannot inadvertently modify the text attribute of the file.
Use tie:
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{ package File;
sub new {
bless ['hello'], shift
}
sub text {
my $self = shift;
if (#_) {
$self->[0] = shift;
} else {
return $self->[0]
}
}
}
{ package FileVar;
use Tie::Scalar;
use parent qw( -norequire Tie::StdScalar );
sub TIESCALAR {
my ($class, $obj) = #_;
bless \$obj, $class
}
sub FETCH {
my $self = shift;
${$self}->text()
}
sub STORE {
die 'Read only!';
# Or, do you want to change the object by changing the var, too?
my ($self, $value) = #_;
${$self}->text($value);
}
}
my $file = 'File'->new();
tie my $text, 'FileVar', $file;
say $text;
$file->text('goodbye');
say $text;
# Die or change the object:
$text = 'Magic!';
say $file->text;

Object Oriented Perl: Calling another function within the same class

I have a to process some files in a directory.
So, I am using non-OO Perl code as below (just the important snippets are printed below):
#!/usr/bin/perl
use strict;
use warnings;
my $dnaFilesDirectory = "./projectGeneSequencingPfzr";
my %properties = &returnGeneticSequences($dnaFilesDirectory);
sub returnGeneticSequences {
my $dnaDirectory = shift;
my #dnaFiles = ();
opendir(DNADIR, $dnaFilesDirectory) or die "Cannot open directory:$!";
#dnaFiles = readdir(DIR);
foreach my $file (#dnaFiles) {
my $dnaFilePath = $dnaFilesDirectory."\/".$file;
if($file =~ /dna_file.*\.dnaPrj/) {
my %diseaseStages = &returnDiseasesStages($dnaFilePath);
## Do some data analysis on the %diseaseStages Hash;
}
}
}
sub returnDiseasesStages {
my $dnaFile = shift;
## Do something with DNA file and build a hash called %diseasesStagesHash;
return %diseasesStagesHash;
}
The above code works fine.
But we have to create the equivalent OO Perl code for the above functions.
I am trying to do the following, but it does not seem to work. Obviously, I am doing something wrong in calling the class method returnDiseasesStages from returnGeneticSequences.
#!/usr/bin/perl
use strict;
use warnings;
package main;
my $obj = GeneticSequences->new(dnaFilesDir => "./projectGeneSequencingPfzr");
$obj->returnGeneticSequences();
package GeneticSequences;
sub new {
my $class = shift;
my $self = {
dnaFilesDir => "dnaFilesDir",
#_,
};
return (bless($self,$class));
}
sub returnGeneticSequences {
my $self = shift;
my $dnaFilesDirectoryGS = $self->{dnaFilesDir};
my #dnaFiles = ();
opendir(DNADIR,$dnaFilesDirectoryGS) or die "Cannot open directory:$!";
#dnaFiles = readdir(DIR);
foreach my $file (#dnaFiles) {
my $dnaFilePath = $dnaFilesDirectory."\/".$file;
if($file =~ /dna_file.*\.dnaPrj/) {
my $gsObj = GeneticSequences->new();
my %diseaseStages = $gsObj->returnDiseasesStages($dnaFilePath);
## Do some data analysis on the %diseaseStages Hash;
}
}
}
sub returnDiseasesStages {
my $dnaFile = shift;
##Do something with DNA file and build a hash called %diseasesStagesHash;
return %diseasesStagesHash;
}
Please help me understand what I am doing wrong.
The syntax
$gsObj->returnDiseasesStages($dnaFilePath)
is equivalent to the syntax
returnDiseasesStages($gsObj, $dnaFilePath)
(with Perl checking the reference type of $gsObj to see what package to search for the returnDiseasesStages function in).
So your returnDiseasesStages function should expect two arguments:
sub returnDiseasesStages {
my ($self, $dnaFile) = #_;
...
}

Problems appending to a file in perl

I have problem with logging some messages in perl. I created simple log package. I still get just first row to the file. Seems like there is appending to file not working. Any ideas?
even when i run that script more times, there arent any changes in output log file. There is always just written "something". I need to append that "somethingElse" to the output file. Do I have some mistake in log?
package Logger;
sub new {
my $package = shift;
my $self = {};
bless $self , $package;
$self->initialize(#_);
return $self;
}
sub initialize {
my $self = shift;
$self->{logfile} = shift;
return;
}
sub logger {
my $self = shift;
my $message = shift;
my (undef,$script, $line) = caller;
open(LOG, ">>$self->{logfile}");
print LOG substr(scalar localtime(),4,15), " ", $message, "\n";
close(LOG);
return;
}
my $log = Logger->new('/usr/local/logs/test.log');
$log->logger("something");
$log->logger("somethingElse");
Thank you
This code works fine for me, so I can't be sure this is the correct solution, but often when some code doesn't print what you want it to, it's because of an autoflush problem. You could try adding this:
$| = 1
or if you prefer:
use English qw( -no_match_vars );
$OUTPUT_AUTOFLUSH = 1;
to the beginning of your program and see if that helps.

How do I insert new fields into $self in Perl, from a File::Find callback

In a Perl object, I'm trying to add a new field into $self from within a File::Find wanted() sub.
use File::Find;
sub _searchForXMLDocument {
my ($self) = #_;
if($_ =~ /[.]+\.xml/) {
$self->{_xmlDocumentPath} = $_;
}
}
sub runIt{
my ($self) = #_;
find (\&_searchForXMLDocument, $self->{_path});
print $self->{_xmlDocumentPath};
}
_searchForXMLDocument() searches for an XML Document within $self->{_path} and is supposed to append that XML path to $self->{_xmlDocumentPath} but when I try to print it, it remains uninitialized. How do I add the field in $self?
Use of uninitialized value in print at /home/scott/workspace/CCGet/XMLProcessor.pm line 51.
You aren't calling _searchForXMLDocument() in an OO manner, so your $self object isn't being passed to it. This should do the trick now. Use a closure for your method and you have access to $self;
sub runIt{
my ($self) = #_;
my $closure = sub {
if($_ !~ m/[.]+\.xml/) {
$self->{_xmlDocumentPath} = $_;
}
};
find(\&$closure, $self->{_path});
print $self->{_xmlDocumentPath};
}
The first argument to find() needs to carry two pieces of information: the test condition, and the object you're working with. The way to do this is with a closure. The sub { ... } creates a code ref, like you get from \&_searchForXMLDocument, but the closure has access to lexical variables in the enclosing scope, so the current object ($self) is associated with the closure.
sub _searchForXMLDocument {
my ($self) = #_;
if($_ =~ /[.]+\.xml/) {
$self->{_xmlDocumentPath} = $_;
}
}
sub runIt{
my ($self) = #_;
find (sub { $self->_searchForXMLDocument (#_) }, $self->{_path});
print $self->{_xmlDocumentPath};
}
I think you're looking for something like this:
package XMLDocThing;
use strict;
use warnings;
use English qw<$EVAL_ERROR>;
use File::Find qw<find>;
...
use constant MY_BREAK = do { \my $v = 133; };
sub find_XML_document {
my $self = shift;
eval {
find( sub {
return unless m/[.]+\.xml/;
$self->{_xmlDocumentPath} = $_;
die MY_BREAK;
}
, $self->{_path}
);
};
if ( my $error = $EVAL_ERROR ) {
die Carp::longmess( $EVAL_ERROR ) unless $error == MY_BREAK;
}
}
...
# meanwhile, in some other package...
$xmldocthing->find_XML_document;
You pass a closure to find and it can access $self from the containing scope. File::Find::find has no capacity to pass in baggage like objects.