Perl Classes :: Can not write output - perl

I am new to Object oriented programming in perl. So, I have a silly question.
What --
I am writing a script which will do something and write result to stream ( STDOUT or NETWORK ).
How --
[main.pl]
#!/usr/bin/perl
use strict;
require const::StreamTypes;
require output;
my $out = output->new("output");
$out->writeLine("Sample output");
[output.pm]
#!/usr/bin/perl
use strict;
require const::StreamTypes;
package output;
my $OUTSTR;
sub new{
my $class = shift();
my $stream = shift();
if($stream eq const::StreamTypes->STDNET){
}elsif($stream eq const::StreamTypes->STDWEB){
}else{
*OUTSTR = *STDOUT;
}
my $self = {
"_outStream" => $stream,
"_outStreamPtr" => $OUTSTR
};
bless($self, $class);
}
sub writeLine{
my $msg = shift();
print(OUTSTR "$msg\n");
}
return 1;
So, can anyone help me understand what is going wrong here? 'cas program runs without error but with no output.
Thanks!

I changed a couple of things here:
the first parameter of a methd is the invocant (instance or class) itself
indirect file handles are globals!
the autodie module comes in handy, if using open
consider using strict in your modules, too
I would not recommend the use of package global variable ( my $OUTSTR; ), because that's going to be messy with multiple instances, which want to have different streams.
And I definitely got into the habit of using accessors for all attributes. You can use a lightweight system like Class::Accessor or perhaps you are even lucky enough to use Moose our Mouse. Of course there are a couple of other modules also providing accessors in different ways.
package output;
use strict;
use warnings;
use autodie;
use Class::Accessor "moose-like";
has "outStream" => ( is => 'rw' );
sub new{
my ( $class, $stream ) = #_;
my $self = bless( {}, $class );
if ( 0 ) {
# ...
} else {
open( my $outStream, '>&', \*STDOUT );
$self->outStream( $outStream );
}
return $self;
}
sub writeLine{
my ( $self, $msg ) = #_;
print { $self->outStream } "$msg\n";
}
return 1;
Moose would create a constructor for you, but you can insert your parameter processing as easy as follows:
use Moose;
has "outStream" => ( is => 'rw' );
sub BUILDARGS {
my ( $class, $stream ) = #_;
open( my $outStream, '>&', \*STDOUT );
return {
outStream => $outStream,
};
}

$OUTSTR and *OUTSTR are very different things -- you should clear up your misunderstanding about this before you worry about object oriented programming.
That said, you can probably fix this script by getting everything to refer to $OUTSTR:
...
}else{
$OUTSTR = *STDOUT;
}
...
print $OUTSTR "$msg\n";

How about just passing a file handle directly into the object's constructor?
package output;
sub new {
my ($class, $fh) = #_;
bless { file_handle => $fh }, $class;
}
sub writeLine {
my $self = shift;
my $line = shift;
print {$self->{file_handle}} $line;
}
1;
Example usage:
my $output = output->new(\*STDOUT); # write to stdout
my $socket = IO::Socket::INET->new('www.perl.org', PeerPort => 'http(80)', Proto => 'tcp');
my $output = output->new($socket); # write to a socket

Please don't use barenames for file handles. Use lexical file handles.
The following lines assume that there is a hash %type_handlers somewhere that looks something like this:
{ const::StreamTypes->STDNET => \&constructor_for_stdnet_handles
, const::StreamTypes->STDWEB => \&constructor_for_stdweb_handles
}
Then you can replace the bottom of your constructor with:
my $handler = $type_handlers{ $stream };
my $outstr
= $handler ? $handler->()
: do { my $h; open( $h, '>&', \*::STDOUT ) and $h; }
;
return bless( {
_outStream => $stream
, _outStreamPtr => $outstr
}
, $class
);
Then writeLine becomes:
sub writeLine {
my ( $self, $msg ) = #_;
( $self->{_outStreamPtr} || *::STDOUT{IO} )->say( $msg );
}
The method is a little more robust in cases where somebody just blessed themselves into your class.
my $q_and_d = bless {}, 'output';
If you don't want to allow "quick & dirty" instances, and want more precise messages from possible failures, you could do this:
Carp::croak( 'No outstream!' )
unless my $h = Params::Util::_HANDLE( $self->{_outStreamPtr} )
;

Related

How can a perl constructor return a value not just a hashref

I want to create a Perl OO module to return a value like DateTime does, but don't know how to it right now. Anyone's help on this will be appreciated.
Below looks like what I wanted:
use DateTime;
use Data::Printer;
my $time = DateTime->now();
print $time . "\n";
print ref $time;
# p $time;
Output:
2022-11-23T13:22:39
DateTime
What I got:
package Com::Mfg::Address;
use strict;
use warnings;
#constructor
sub new {
my ($class) = #_;
my $self = {
_street => shift || "undefined",
_city => shift || "undefined",
_las_state => shift || "undefined",
_zip => shift || "undefined",
};
bless $self, $class;
return $self;
}
#accessor method for street
sub street {
my ( $self, $street ) = #_;
$self->{_street} = $street if defined($street);
return ( $self->{_street} );
}
#accessor method for city
sub city {
my ( $self, $city ) = #_;
$self->{_city} = $city if defined($city);
return ( $self->{_city} );
}
#accessor method for state
sub state {
my ( $self, $state ) = #_;
$self->{_state} = $state if defined($state);
return ( $self->{_state} );
}
#accessor method for zip
sub zip {
my ( $self, $zip ) = #_;
$self->{_zip} = $zip if defined($zip);
return ( $self->{_zip} );
}
sub print {
my ($self) = #_;
printf( "Address:%s\n%s, %s %s\n\n",
$self->street, $self->city, $self->state, $self->zip );
}
1;
# test.pl
#!/usr/bin/perl -w
use strict;
use Data::Printer;
BEGIN {
use FindBin qw($Bin);
use lib "$Bin/../lib";
}
use Com::Mfg::Address;
my $homeAddr = Com::Mfg::Address->new('#101 Road', 'LA', 'CA', '111111');
print $homeAddr;
# $homeAddr->print();
# p $homeAddr;
But this only gives me:
Com::Mfg::Address=HASH(0xb89ad0)
I am curious if print $homeAddr can give me:
something like #101Road-LA-CA-111111 and it really is object like above print $time . "\n";.
I tried to review DateTime source but still have no clue right now.
You're asking how to provide a custom stringification for the object. Use the following in your module:
use overload '""' => \&to_string;
sub to_string {
my $self = shift;
return
join ", ",
$self->street,
$self->city,
$self->state,
$self->zip;
}
This makes
print $homeAddr;
equivalent to
print $homeAddr->to_string();

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.

Perl OOP method returns array I cannot loop

Here is what my module looks like:
#!/usr/bin/perl
package Page;
use strict;
use warnings;
use base qw/DBObj/;
our %fields = (
id => undef,
title => '$',
content => '$'
);
sub get_field_names {
my #names = sort keys \%fields;
return \#names;
}
for my $field ( keys %fields ) {
my $slot = __PACKAGE__ ."::$field";
no strict "refs";
*$field = sub {
my $self = shift;
$self->{$slot} = shift if #_;
return $self->{$slot};
}
}
1;
Here the parent module where the strange behaviour occurs
#!/usr/bin/perl
package DBObj;
use strict;
use warnings;
use Data::Dumper;
use DBConn;
sub new {
my $me = shift;
my $class = ref $me || $me;
my $self = {
dbh => new DBConn->new(
dns => '/db.sql',
user => '',
pass => '',
)
};
return bless $self, $class;
}
sub save {
my $self = shift;
my #field_names = #{$self->get_field_names};
print Dumper #field_names;
foreach my $item ( reverse #field_names ) {
print $item;
}
}
sub fill {
my ( $self, $args ) = #_;
foreach my $key ( keys $args ) {
$self->$key( $args->{$key} );
}
}
1;
here is what I am experiencing. This snippet
my #field_names = $self->get_field_names;
print Dumper #field_names;
foreach my $item ( reverse #field_names ) {
print $item;
}
Data::Dumper shows
$VAR1 = [
'content',
'id',
'title'
];
But the foreach loop returns
ARRAY(0x7fc750a26470)
I have a Test::Simple test case where I perform the following test
ok( shift $page->get_field_names eq 'content', 'Page has field content');
so I can shift off an item from the array, but I cannot loop through it which is a puzzle to me.
And please; before you tell me that I shouldn't be doing this and that there is a ton of modules out there I should pick instead, I want to point out; I am doing this our of pure fun, I have been away from Perl for ~10 years and thought it would be fun to play around with it again.
You have made get_field_names return a reference to an array, but you are then putting that reference into an array variable.
Try:
my $field_names = $self->get_field_names;
print Dumper $field_names;
foreach my $item ( reverse #$field_names ) {
print $item;
}
get_field_names returns an arrayref, not an array. Either change its return type by removing the backslash from return \#names; or "cast" its return type to an array by writing:
my #field_names = #{$self->get_field_names};

Moose trigger caller

Is there any way of knowing the trigger caller attribute in Moose ?
For example, taking the example from Moose::Manual::Attributes:
has 'size' => (
is => 'rw',
trigger => \&_size_set,
);
sub _size_set {
my ( $self, $size, $old_size ) = #_;
my $msg = $self->name;
if ( #_ > 2 ) {
$msg .= " - old size was $old_size";
}
$msg .= " - size is now $size";
warn $msg;
}
Is it possible in _set_size to know that the attribute size called it, without needing to specify the name of the caller attribute explicitly?
EDIT: updated per comment.
It might be simpler to create a wrapper that adds one argument:
sub make_trigger {
my ($name, $sub) = #_;
return sub {
my $self = shift;
$self->$sub($name, #_);
};
}
has 'size' => (
is => 'rw',
trigger => make_trigger(size => \&_size_set),
);
sub _size_set {
my ( $self, $name, $size, $old_size ) = #_;
...
}
Here's what #RsrchBoy refers to as the "proper way"...
use v5.14;
use strict;
use warnings;
BEGIN {
package MooseX::WhatTheTrig::Trait::Attribute
{
use Moose::Role;
use Scope::Guard qw(guard);
after _process_trigger_option => sub
{
my $class = shift;
my ($name, $opts) = #_;
return unless exists $opts->{trigger};
my $orig = delete $opts->{trigger};
$opts->{trigger} = sub
{
my $self = shift;
my $guard = guard {
$self->meta->_set_triggered_attribute(undef);
};
$self->meta->_set_triggered_attribute($name);
$self->$orig(#_);
};
}
}
package MooseX::WhatTheTrig::Trait::Class
{
use Moose::Role;
has triggered_attribute => (
is => 'ro',
writer => '_set_triggered_attribute',
);
}
}
package Example
{
use Moose -traits => ['MooseX::WhatTheTrig::Trait::Class'];
has [qw(foo bar)] => (
traits => ['MooseX::WhatTheTrig::Trait::Attribute'],
is => 'rw',
trigger => sub {
my ($self, $new, $old) = #_;
$_ //= 'undef' for $old, $new;
my $attr = $self->meta->triggered_attribute;
say "Changed $attr for $self from $old to $new!";
}
);
}
my $obj = Example->new(foo => 1, bar => 2);
$obj->foo(3);
$obj->bar(4);
You'll notice that the "foo" and "bar" attributes share a trigger, but that the trigger is able to differentiate between the two attributes.
Moose::Exporter has some sugar for making this a little less ugly. I might have a play at turning this into a CPAN module some time.
The proper way to do this would be to employ an attribute trait of some sort; one that passes the name, or (preferably) the metaclass instance of the attribute the trigger belongs to. One could even create a trait that allows the class' metaclass to be asked if we're in an attribute trigger, and if so, which one. (This would be transparent and not break anyone's expectations as to how trigger works.)
The easiest would be to curry your triggers as shown in another example.

Open a closure as a handle in Perl

So I had this crazy idea. Right now, I'm generating a table in Word using Text::CSV_XS like so:
use Win32::OLE;
use Win32::OLE::Const 'Microsoft Word';
use Text::CSV_XS;
# instantiation of word and Text::CSV_XS omitted for clarity
my $select = $word->Selection;
foreach my $row (#rows) { # #rows is an array of arrayrefs
$csv->combine(#{$row});
$select->InsertAfter($csv->string);
$select->InsertParagraphAfter;
}
$select->convertToTable(({'Separator' => wdSeparateByCommas});
But it would be cooler if I could do something like this:
use Win32::OLE;
use Win32::OLE::Const 'Microsoft Word';
use Text::CSV_XS;
# instantiation of word and Text::CSV_XS omitted for clarity
my $select = $word->Selection;
foreach my $row (#rows) { # #rows is an array of arrayrefs
$csv->bind_columns($row);
$csv->print(
sub {
my $something; # Should be the combine()'d string
$select->InsertAfter($something);
$select->InsertParagraphAfter;
},
undef
);
}
$select->convertToTable(({'Separator' => wdSeparateByCommas});
My questions, then, are how do I get the $something out of my second code sample, and what do I need to do to make the closure look like a handle?
Text::CSV::print doesn't necessarily need a handle. The documentation just says it needs something with a print method.
{
package Print::After::Selection;
sub new {
my ($pkg, $selection) = #_;
my $self = { selection => $selection };
return bless $self, $pkg;
}
sub print {
my ($self, $string) = #_;
my $selection = $self->{selection};
$selection->InsertAfter($string);
$selection->InsertParagraphAfter;
return 1; # return true or Text::CSV will think print failed
}
}
...
$csv->print( Print::After::Selection->new( $word->Selection ), undef );
...
(not tested)
I believe you are actually asking how to make data end up in Word using the following interface:
my $fh = SelectionHandle->new($selection);
my $csv = Text::CSV_XS->new({ binary => 1 });
$csv->print($fh, $_) for #rows;
(I think that's a bad idea. It's inside out. Create an object that formats using an encapsulated CSV object instead.)
If you want to given an object the interface of a variable (scalar, array, hash, file handle), you want tie. When you do, you end up with
use SelectionHandle qw( );
use Text::CSV_XS qw( );
my $selection = ...;
my #rows = ...;
my $fh = SelectionHandle->new($selection);
my $csv = Text::CSV_XS->new({ binary => 1 });
$csv->print($fh, $_) for #rows;
And the module looks like:
package SelectionHandle;
use strict;
use warnings;
use Symbol qw( gensym );
use Tie::Handle qw( );
our #ISA = qw( Tie::Handle );
sub new {
my ($class, $selection) = #_;
my $fh = gensym();
tie(*$fh, $class, $selection);
return $fh;
}
sub TIEHANDLE {
my ($class, $selection) = #_;
return bless({
selection => $selection,
}, $class);
}
sub PRINT {
my ($self, $str) = #_;
my $selection = $self->{selection};
$selection->InsertAfter($str);
$selection->InsertParagraphAfter();
return 1;
}
1;