I'm working my way through Higher Order Perl, and want to try to execute some of its code, in this case FlatDB.pm.
I tried to simulate the calling method outlined in the answers to this question (2621225), but it's not working for me. To wit:
## HOP Chapter 4 section 3.4, p.140
my $FIELDSEP = qr/:/;
package FlatDB;
sub new {
my $class = shift;
my $file = shift;
open my $fh, "< $file" or return;
chomp(my $schema = <$fh>);
my #field = split $FIELDSEP, $schema;
my %fieldnum = map { uc $field[$_] => $_ } (0..$#field);
print "\nfieldnum=",%fieldnum;
bless { FH => $fh, FIELDS => \#field, FIELDNUM => \%fieldnum,
FIELDSEP => $FIELDSEP } => $class;
}
# More subs here - snipped
What I added to try to run the package:
package main;
print "\nat 89";
$obj= FlatDB->new("FlatDB","SampleDB.txt");
print "\nat 91";
The prints at 89 & 91 are executed, but the print in the 'new' subroutine is not. The 'new' subroutine works if I pull it out of the package, so the problem must be in how I'm trying to call it.
I'm afraid it's something very simple, but I don't see it.
The only way that method can exit without executing the print statement is through the line
open my $fh, "< $file" or return;
So I imagine the open is failing for some reason. Replace that line with
open my $fh, '<', $file or die qq{Unable to open "$file" for input: $!};
and you will see the reason for the failure
When I do:
print $fh 'text';
I need a some &sub to be called.
It there a way to do that?
You can tie a filehandle and customize the behavior for printing to that filehandle or for any other operation on that filehandle.
sub PrintNotifier::TIEHANDLE {
my ($pkg, $orignalHandle) = #_;
bless { glob => $orignalHandle }, $pkg;
}
sub PrintNotifier::PRINT {
my ($self,#msg) = #_;
... do whatever you want with #msg here ...
return print {$self->{glob}} #msg;
}
sub PrintNotifier::CLOSE { return close $_[0]->{glob} }
open my $fh, '>', 'some-file';
tie *$fh, 'PrintNotifier', $fh;
print $fh "something"; # calls PrintNotifier::PRINT
You can tie the handle, as mob suggested. Or, if you can change the code and your Perl is new enough, you can replace
print $fh 'text';
with
$fh->print('text');
which you might consider cleaner syntax; then you can sub-class IO::File:
package MyFH {
use parent qw/ IO::File /;
use mro; # Get next::method
sub print {
my ($self, #args) = #_;
warn 'Printing ', #args;
$self->next::method(#args);
}
}
my $fh = MyFH->new();
$fh->open('file', '>') or die $!;
However, this doesn't capture the old-fashioned
print $fh 'text';
style.
Depending on your preference, you might find the new style cleaner anyway, since if your file handle is an expression it allows
$obj->method()->print('text');
instead of
print {$obj->method()} 'text';
It works transparently for Perl 5.14 and up, and can be made to work for older Perls back to (at least) 5.8 by adding
use IO::Handle;
to the top of the files you want to use it in (just to be on the safe side).
In is not documented in perl but has usefull usage
If you want to process print'ing on your object in your class you can tie into itself:
tie *$self, $self;
print $self 'text';
$self->print( 'text' );
I am trying to make an extensible system whereby I can code up a new module to be a handler. I want the program to automatically load any new .pm file that is put into the Handlers directory and conforms to a Moose::Role interface.
I'm wondering whether there is a Perl module or a more Moose sanctioned way to do this automatically? Here is what I have built so far, but it seems a little verbose and there has got to be a simpler way to do it.
handler.pl contains:
#!/usr/bin/perl
use Handler;
use Data::Dumper;
my $base_handler = Handler->new();
$base_handler->load_modules('SysG/Handler');
print Dumper($base_handler);
Handler.pm contains:
package Handler;
use Moose;
has 'handlers' => ( traits => ['Array'], handles => { add_handler => 'push' } );
sub load_modules {
my ($self,$dir) = #_;
push(#INC, $dir);
my #modules = find_modules_to_load($dir);
eval {
# Note that this sort is important. The processing order will be critically important.
# The sort implies the sort order
foreach my $module ( sort #modules) {
(my $file = $module) =~ s|::|/|g;
print "About to load $file.pm for module $module\n" ;
require $file . '.pm';
$module->import();
my $obj = $module->new();
$self->add_handler($obj);
1;
}
} or do {
my $error = $#;
print "Error loading modules: $error" if $error;
};
}
sub find_modules_to_load {
my ($dir) = #_;
my #files = glob("$dir/*.pm");
my $namespace = $dir;
$namespace =~ s/\//::/g;
# Get the leaf name and add the System::Module namespace to it
my #modules = map { s/.*\/(.*).pm//g; "${namespace}::$1"; } #files;
die "ERROR: No classifier modules found in $dir\n" unless #modules;
return #modules;
}
1;
Then I have made a directory called SysG/Handler and added two .pm files which ordinarily will conform to a Moose::Role (as if to define an interface that must be adhered too).
The SysG::Handler::0001_HandleX.pm stub contains:
package SysG::Handler::0001_HandleX;
use Moose;
1;
The SysG::Handler::0002_HandleX.pm stub contains:
package SysG::Handler::0002_HandleY;
use Moose;
1;
Put all this together and the Data::Dumper result is:
$VAR1 = bless( {
'handlers' => [
bless( {}, 'SysG::Handler::0001_HandleX' ),
bless( {}, 'SysG::Handler::0002_HandleY' )
]
}, 'Handler' );
So, now I repeat my original question: There must be a simpler way, or a module or a Moose way to automatically load any modules in a specific directory.
Any Moose experts able to help out here?
MooseX::Object::Pluggable
When I run the code below I get
Can't use string ("F") as a symbol ref while "strict refs" in use at ./T.pl line 21.
where line 21 is
flock($fh, LOCK_EX);
What am I doing wrong?
#!/usr/bin/perl
use strict;
use warnings;
use Fcntl ':flock', 'SEEK_SET'; # file locking
use Data::Dumper;
# use xx;
my $file = "T.yaml";
my $fh = "F";
my $obj = open_yaml_with_lock($file, $fh);
$obj->{a} = 1;
write_yaml_with_lock($obj, $fh);
sub open_yaml_with_lock {
my ($file, $fh) = #_;
open $fh, '+<', $file;
flock($fh, LOCK_EX);
my $obj = YAML::Syck::LoadFile($fh);
return $obj;
}
sub write_yaml_with_lock {
my ($obj, $fh) = #_;
my $yaml = YAML::Syck::Dump($obj);
$YAML::Syck::ImplicitUnicode = 1;
seek $fh,0, SEEK_SET; # seek back to the beginning of file
print $fh $yaml . "---\n";
close $fh;
}
What you're doing wrong is using the string "F" as a filehandle. This
has never been something that's worked; you could use a bareword as a
filehandle (open FH, ...; print FH ...), or you could pass in an
empty scalar and perl would assign a new open file object to that
variable. But if you pass in the string F, then you need to refer to
then handle as F, not $fh. But, don't do that.
Do this instead:
sub open_yaml_with_lock {
my ($file) = #_;
open my $fh, '+<', $file or die $!;
flock($fh, LOCK_EX) or die $!;
my $obj = YAML::Syck::LoadFile($fh); # this dies on failure
return ($obj, $fh);
}
We're doing several things here. One, we're not storing the
filehandle in a global. Global state makes your program extremely
difficult to understand -- I had a hard time with your 10 line post --
and should be avoided. Just return the filehandle, if you want to
keep it around. Or, you can alias it like open does:
sub open_yaml_with_lock {
open $_[0], '+<', $_[1] or die $!;
...
}
open_yaml_with_lock(my $fh, 'filename');
write_yaml_with_lock($fh);
But really, this is a mess. Put this stuff in an object. Make new
open and lock the file. Add a write method. Done. Now you can
reuse this code (and let others do the same) without worrying about
getting something wrong. Less stress.
The other thing we're doing here is checking errors. Yup, disks can
fail. Files can be typo'd. If you blissfully ignore the return value
of open and flock, then your program may not be doing what you think
it's doing. The file might not be opened. The file might not be
locked properly. One day, your program is not going to work properly
because you spelled "file" as "flie" and the file can't be opened.
You will scratch your head for hours wondering what's going on.
Eventually, you'll give up, go home, and try again later. This time,
you won't typo the file name, and it will work. Several hours will
have been wasted. You'll die several years earlier than you should
because of the accumulated stress. So just use autodie or write or
die $! after your system calls so that you get an error message when
something goes wrong!
Your script would be correct if you wrote use autodie qw/open flock
seek close/ at the top. (Actually, you should also check that
"print" worked or use
File::Slurp or
syswrite, since autodie can't detect a failing print statement.)
So anyway, to summarize:
Don't open $fh when $fh is defined. Write open my $fh to
avoid thinking about this.
Always check the return values of system calls. Make autodie do
this for you.
Don't keep global state. Don't write a bunch of functions that
are meant to be used together but rely on implicit preconditions
like an open file. If functions have preconditions, put them in
a class and make the constructor satisfy the preconditions.
This way, you can't accidentally write buggy code!
Update
OK, here's how to make this more OO. First we'll do "pure Perl" OO
and then use Moose. Moose is
what I would use for any real work; the "pure Perl" is just for the
sake of making it easy to understand for someone new to both OO and
Perl.
package LockedYAML;
use strict;
use warnings;
use Fcntl ':flock', 'SEEK_SET';
use YAML::Syck;
use autodie qw/open flock sysseek syswrite/;
sub new {
my ($class, $filename) = #_;
open my $fh, '+<', $filename;
flock $fh, LOCK_EX;
my $self = { obj => YAML::Syck::LoadFile($fh), fh => $fh };
bless $self, $class;
return $self;
}
sub object { $_[0]->{obj} }
sub write {
my ($self, $obj) = #_;
my $yaml = YAML::Syck::Dump($obj);
local $YAML::Syck::ImplicitUnicode = 1; # ensure that this is
# set for us only
my $fh = $self->{fh};
# use system seek/write to ensure this really does what we
# mean. optional.
sysseek $fh, 0, SEEK_SET;
syswrite $fh, $yaml;
$self->{obj} = $obj; # to keep things consistent
}
Then, we can use the class in our main program:
use LockedYAML;
my $resource = LockedYAML->new('filename');
print "Our object looks like: ". Dumper($resource->object);
$resource->write({ new => 'stuff' });
Errors will throw exceptions, which can be handled with
Try::Tiny, and the YAML
file will stay locked as long as the instance exists. You can, of
course, have many LockedYAML objects around at once, that's why we
made it OO.
And finally, the Moose version:
package LockedYAML;
use Moose;
use autodie qw/flock sysseek syswrite/;
use MooseX::Types::Path::Class qw(File);
has 'file' => (
is => 'ro',
isa => File,
handles => ['open'],
required => 1,
coerce => 1,
);
has 'fh' => (
is => 'ro',
isa => 'GlobRef',
lazy_build => 1,
);
has 'obj' => (
is => 'rw',
isa => 'HashRef', # or ArrayRef or ArrayRef|HashRef, or whatever
lazy_build => 1,
trigger => sub { shift->_update_obj(#_) },
);
sub _build_fh {
my $self = shift;
my $fh = $self->open('rw');
flock $fh, LOCK_EX;
return $fh;
}
sub _build_obj {
my $self = shift;
return YAML::Syck::LoadFile($self->fh);
}
sub _update_obj {
my ($self, $new, $old) = #_;
return unless $old; # only run if we are replacing something
my $yaml = YAML::Syck::Dump($new);
local $YAML::Syck::ImplicitUnicode = 1;
my $fh = $self->fh;
sysseek $fh, 0, SEEK_SET;
syswrite $fh, $yaml;
return;
}
This is used similarly:
use LockedYAML;
my $resource = LockedYAML->new( file => 'filename' );
$resource->obj; # the object
$resource->obj( { new => 'object' }); # automatically saved to disk
The Moose version is longer, but does a lot more runtime consistency
checking and is easier to enhance. YMMV.
From the documentation:
open FILEHANDLE,EXPR
If FILEHANDLE is an undefined scalar variable (or array or hash
element) the variable is assigned a reference to a new anonymous
filehandle, otherwise if FILEHANDLE is an expression, its value is
used as the name of the real filehandle wanted. (This is considered a
symbolic reference, so "use strict 'refs'" should
not be in effect.)
Filehandle here is an expression ("F") so itsvalue is used as the name of the real filehandle you want. (A filehandle called F). And then... the documentation says "use strict 'refs'" should not be in effect, because you're using F as a symbolic reference.
(use strict; on line 1 includes strict 'refs'.)
Had you just said at the beginning:
my $fh;
This would have worked, because then $fh would become a reference to a new anonymous filehandle and Perl won't try to use it as a symbolic reference.
This works:
#!/usr/bin/perl
my $global_fh;
open_filehandle(\$global_fh);
use_filehandle(\$global_fh);
sub open_filehandle {
my ($fh)=#_;
open($$fh, ">c:\\temp\\testfile") || die;
}
sub use_filehandle {
my($fh) = #_;
# Print is pecular that it expects the next token to be the filehandle
# or a simple scalar. Thus, print $$fh "Hello, world!" will not work.
my $lfh = $$fh;
print $lfh "Hello, world!";
close($$fh);
}
Or you can do what the other poster suggested and use $_[1] directly, but that's a bit harder to read.
If you use the value directly in the sub, it will work:
use strict;
use warnings;
use autodie;
my $fh;
yada($fh);
print $fh "testing, testing";
sub yada {
open $_[0], '>', 'yada.gg';
}
Or as a reference:
yada(\$fh);
sub yada {
my $handle = shift;
open $$handle, '>', 'yada.gg';
}
Or better yet, return a filehandle:
my $fh = yada($file);
sub yada {
my $inputfile = shift;
open my $gg, '>', $inputfile;
return $gg;
}
Replace
my $fh = "F"; # text and also a ref in nonstrict mode
with
my $fh = \*F; # a reference, period
Of course, it's better yet to use lexical filehandles, as in open my $fd, ... or die ..., but that's not always possible, e.g. you have STDIN that's predefined. In such cases, use \*FD wherever $fd fits.
There's also a case with old scripts, you have to watch out where a global FD is opened and closed.
I'm writing a System::Wrapper module to abstract away from CORE::system and the qx operator. I have a serial method that attempts to connect command1's output to command2's input. I've made some progress using named pipes, but POSIX::mkfifo is not cross-platform.
Here's part of what I have so far (the run method at the bottom basically calls system):
package main;
my $obj1 = System::Wrapper->new(
interpreter => 'perl',
arguments => [-pe => q{''}],
input => ['input.txt'],
description => 'Concatenate input.txt to STDOUT',
);
my $obj2 = System::Wrapper->new(
interpreter => 'perl',
arguments => [-pe => q{'$_ = reverse $_}'}],
description => 'Reverse lines of input input',
output => { '>' => 'output' },
);
$obj1->serial( $obj2 );
package System::Wrapper;
#...
sub serial {
my ($self, #commands) = #_;
eval {
require POSIX; POSIX->import();
require threads;
};
my $tmp_dir = File::Spec->tmpdir();
my $last = $self;
my #threads;
push #commands, $self;
for my $command (#commands) {
croak sprintf
"%s::serial: type of args to serial must be '%s', not '%s'",
ref $self, ref $self, ref $command || $command
unless ref $command eq ref $self;
my $named_pipe = File::Spec->catfile( $tmp_dir, int \$command );
POSIX::mkfifo( $named_pipe, 0777 )
or croak sprintf
"%s::serial: couldn't create named pipe %s: %s",
ref $self, $named_pipe, $!;
$last->output( { '>' => $named_pipe } );
$command->input( $named_pipe );
push #threads, threads->new( sub{ $last->run } );
$last = $command;
}
$_->join for #threads;
}
#...
My specific questions:
Is there an alternative to POSIX::mkfifo that is cross-platform? Win32 named pipes don't work, as you can't open those as regular files, neither do sockets, for the same reasons.
2. The above doesn't quite work; the two threads get spawned correctly, but nothing flows across the pipe. I suppose that might have something to do with pipe deadlocking or output buffering. What throws me off is that when I run those two commands in the actual shell, everything works as expected.
Point 2 is solved; a -p fifo file test was not testing the correct file.
Out of interest, why do you need a FIFO? Couldn't you just set up a regular pipe (e.g. with pipe?) And why use threads when you can use the much more strongly supported fork?
In fact, you could instead use a CPAN module to do most of your work for you. IPC::Run for example:
use IPC::Run qw(run);
run ['perl', '-pe', ''], '<', 'input.txt', '|', ['perl', '-pe', '$_ = reverse $_}'], '>', 'output';
...should work as you expect, on Linux or Windows.