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
Related
I'm writing a tool that must import a number of other perl config files. The files are not wrapped w/packages and may have similar or conflicting variables/functions. I don't have the ability to change the format of these files, so I must work around what they are. What I was thinking to do was import each into a unique name space, but I've not found a way to do that using do, require, or use. If I don't use dynamic names, just a hardcoded name, I can do it.
Want something like this:
sub sourceTheFile {
my ($namespace, $file) = #_;
package $namespace;
do $file;
1;
return;
}
That doesn't work because the package command requires a constant for the name. So then I try something like this:
sub sourceTheFile {
my ($namespace, $file) = #_;
eval "package $namespace;do $file;1;"
return;
}
But the contents of the file read by do are placed in the main:: scope not the one I want. The target scope is created, just not populated by the
do. (I tried require, and just a straight cat $file inside the eval as well.)
I'm using Devel::Symdump to verify that the namespaces are built correctly or not.
example input file:
my $xyz = "some var";
%all_have_this = ( common=>"stuff" );
ADDITIONAL CHALLENGE
Using the answer that does the temp file build and do call, I can make this work dynamically as I require. BUT, big but, how do I now reference the data inside this new namespace? Perl doesn't seem to have the lose ability to build a variable name from a string and use that as the variable.
I am not sure why the eval did not work. Maybe a bug? Here is a workaround using a temp file. This works for me:
use strict;
use warnings;
use Devel::Symdump;
use File::Temp;
my $file = './test.pl';
my $namespace = 'TEST';
{
my $fh = File::Temp->new();
print $fh "package $namespace;\n";
print $fh "do '$file';\n";
print $fh "1;\n";
close $fh;
do $fh->filename;
}
Perl's use and require facilities make use of any hooks you might have installed in #INC. You can simply install a hook which looks in a specific location to load modules with a prefix you choose:
package MyIncHook;
use strict;
use warnings;
use autouse Carp => qw( croak );
use File::Spec::Functions qw( catfile );
sub import {
my ($class, $prefix, $location) = #_;
unshift #INC, _loader_for($prefix, $location);
return;
}
sub _loader_for {
my $prefix = shift;
my $location = shift;
$prefix =~ s{::}{/}g;
return sub {
my $self = shift;
my $wanted = shift;
return unless $wanted =~ /^\Q$prefix/;
my $path = catfile($location, $wanted);
my ($is_done);
open my $fh, '<', $path
or croak "Failed to open '$path' for reading: $!";
my $loader = sub {
if ($is_done) {
close $fh
or croak "Failed to close '$path': $!";
return 0;
}
if (defined (my $line = <$fh>)) {
$_ = $line;
return 1;
}
else {
$_ = "1\n";
$is_done = 1;
return 1;
}
};
(my $package = $wanted) =~ s{/}{::}g;
$package =~ s/[.]pm\z//;
my #ret = (\"package $package;", $loader);
return #ret;
}
}
__PACKAGE__;
__END__
Obviously, modify the construction of $path according to your requirements.
You can use it like this:
#!/usr/bin/env perl
use strict;
use warnings;
use MyIncHook ('My::Namespace', "$ENV{TEMP}/1");
use My::Namespace::Rand;
print $My::Namespace::Rand::settings{WARNING_LEVEL}, "\n";
where $ENV{TEMP}/1/My/Namespace/Rand.pm contains:
%settings = (
WARNING_LEVEL => 'critical',
);
Output:
C:\Temp> perl t.pl
critical
You can, obviously, define your own mapping from made up module names to file names.
I realise there are several questions like this out in the ether, but I can't a solution for my problem. Maybe I should improve my lateral thinking.
I have a module which I am testing. This module looks something like:
package MyModule;
use strict;
use warnings;
... # a bunch of 'use/use lib' etc.
sub new {
my $class = shift;
my ($name,$options) = #_;
my $self = {
_name => $name,
_features => $options,
_ids => undef,
_groups => undef,
_status => undef,
};
bless $self,$class;
return $self;
}
sub init {
my ($self) = #_;
my ($ids,$groups,$status) = ...; # these are from a working module
$self->{_ids} = $ids;
$self->{_groups} = $groups;
$self->{_status} = $status;
return $self;
}
This is my test file:
#!/usr/bin/perl -w
use strict;
use MyModule;
use Test::More tests => 1;
use Data::Dumper;
print "Name: ";
my $name;
chomp($name = <STDIN>);
print "chosen name: $name\n";
my %options = (
option1 => 'blah blah blah',
option2 => 'blu blu blu',
);
my $name_object = MyModule->new($name,\%options);
print Dumper($name_object);
isa_ok($name_object,'MyModule');
$name_object->init;
print Dumper($name_object);
Now it works down to the isa_ok, but then comes up with:
Can't locate object method "init" via package "MyModule" at test_MyModule.t line 31, <STDIN> line 1.
This has only occurred now that I'm trying (and somewhat failing it seems) to use objects. So thus I reckon I'm misunderstanding the applications of objects in Perl! Any help would be appreciated...
I think you're loading a different file than the one you think you are loading.
print($INC{"MyModule.pm"}, "\n");
will tell you which file you actually loaded. (If the module name is really of the form Foo::Bar, use $INC{"Foo/Bar.pm"}.) Make sure the capitalisation of the package and the file name match.
There's several way to list all subs in a package:
sub list_methods {
my $package = shift;
no strict 'refs';
return grep { defined &{"$package\::$_"} } keys %{"$package\::"}
}
But, if the package 'use' other packages such as 'File::Basename', the subs like 'fileparse' will be listed as well.
I tried to 'require' packages instead of 'use' them, the problem can be resolved. On the other hand, if I 'require' packages, I have to specify the full path of the subs.
Do you have any thoughts?
use B qw( svref_2object );
sub list_nonimported_subs {
my ($pkg_name) = #_;
my $pkg = do { no strict 'refs'; *{ $pkg_name . '::' } };
my #nonimported_subs;
for my $name (keys %$pkg) {
my $glob = $pkg->{$name};
my $code = *$glob{CODE}
or next;
my $cv = svref_2object($code);
my $orig_pkg_name = $cv->GV->STASH->NAME;
next if $orig_pkg_name ne $pkg_name;
push #nonimported_subs, $name;
}
return #nonimported_subs;
}
There's a flag that will tell whether the CV in a glob is imported or not, but I can't find how to get that using B, so I check the __PACKAGE__ of the sub against the package being inspected.
It's impossible to tell whether something is a method or not, so I generalised the name of the sub.
PPI will parse the source, so the module doesn't even need to be loaded:
use PPI;
my $source = $INC{'Some/Module.pm'}; # or whatever
my $Document = PPI::Document->new($source) or die "oops";
for my $sub ( #{ $Document->find('PPI::Statement::Sub') || [] } ) {
unless ( $sub->forward ) {
print $sub->name, "\n";
}
}
I'm following up on this question about perl web services. I've managed to get modules loading and executing from a main program. Each of the modules is something like this:
#!/usr/bin/perl
package NiMbox::perlet::skeleton;
use strict;
use warnings;
require Exporter;
our #ISA = qw(Exporter);
our #EXPORT_OK = qw(%DEFINITION main secondary);
our %DEFINITION;
$DEFINITION{'main'} = {
summary => 'skeleton main',
description => 'long skeleton main description',
args => { 'box' => {}, 'other' => {} }
};
$DEFINITION{'secondary'} = {
summary => 'skeleton secondary',
description => 'long skeleton secondary description'
};
sub main {
print "main...\n";
}
sub secondary {
print "secondary...\n"
}
1;
And invocation of these modules can then be done like this:
use NiMbox::perlet::skeleton;
my %DEFINITION = %NiMbox::perlet::skeleton::DEFINITION;
foreach my $s (keys %DEFINITION) {
print "calling sub '$s'\n";
NiMbox::perlet::skeleton->$s();
}
How would I get rid of the direct invocation of NiMbox::perlet:skeleton in a way in which I could do something that looks like this (which does not work but illustrates what I need to do):
my $perlet = 'skeleton';
use NiMbox::perlet::$perlet;
my %DEFINITION = %NiMbox::perlet::$perlet::DEFINITION;
foreach my $s (keys %DEFINITION) {
print "calling sub '$s'\n";
NiMbox::perlet::$perlet->$s();
}
Since I'm very close I would rather see what is missing in this example rather than use another library. Any ideas?
If you want to make the class name dynamic, you can do something like this:
my $class = 'NiMbox::perlet::' . $perlet;
my $class_file = $class;
$class_file =~ s{::}{/};
$class_file .= '.pm';
require $class_file;
$class->import;
(Or even better, use Module::Load as #Schwern suggests.
Getting the %DEFINITION class is a bit tricky since it would involve symbolic references. A better way would be to provide a class method that returns it, e.g.
package NiMbox::perlet::skeleton;
...
sub definition {
my %definition;
$definition{main} = { summary => 'skeleton main', ... };
return %definition;
}
Then you could do something like:
my %DEFINITION = $class->definition;
foreach my $s( keys %DEFINITION ) {
print "calling sub '$s'\n";
$class->$s;
}
I believe what you're looking for is Exporter or its many follow on modules. I see you're already using it in your module, but you're not using it to get %DEFINITION. You'd do that like so:
use NiMbox::perlet::skeleton qw(%DEFINITION);
foreach my $s (keys %DEFINITION) {
print "calling sub '$s'\n";
NiMbox::perlet::skeleton->$s();
}
That aliases %NiMbox::perlet::skeleton::DEFINITION to %DEFINITION and saves a bunch of typing.
To be able to use a variable definition of %DEFINITION you could use "symbolic references" to refer to the variable by name... but those are fraught with peril. Also, exporting global variables means you can only have one at a time in a given namespace. We can do better.
What I would suggest is instead changing the %DEFINITION hash into the definition() class method which returns a reference to %DEFINITION. You could return a hash, but the reference avoids wasting time copying.
package NiMbox::perlet::skeleton;
use strict;
use warnings;
my %DEFINITION = ...;
sub definition {
return \%DEFINITION;
}
Now you can call that method and get the hash ref.
use NiMbox::perlet::skeleton;
my $definition = NiMbox::perlet::skeleton->definition;
foreach my $s (keys %$definition) {
print "calling sub '$s'\n";
NiMbox::perlet::skeleton->$s();
}
Doing it dynamically, the only trick is to load the class. You can eval "require $class" or die $# but that has security implications. UNIVERSAL::require or Module::Load can handle that better for you.
use Module::Load;
my $class = 'NiMbox::perlet::skeleton';
load $class;
my $definition = $class->definition;
foreach my $s (keys %$definition) {
print "calling sub '$s'\n";
$class->$s();
}
So I am toying with some black magic in Perl (eventually we all do :-) and I am a little confused as to exactly how I am supposed to be doing all of this. Here is what I'm starting with:
use strict;
use warnings;
use feature ':5.10';
my $classname = 'Frew';
my $foo = bless({ foo => 'bar' }, $classname);
no strict;
*{"$classname\::INC"} = sub {
use strict;
my $data = qq[
package $classname
warn 'test';
sub foo {
print "test?";
}
];
open my $fh, '<', \$data;
return $fh;
};
use strict;
unshift #INC, $foo;
require $foo;
use Data::Dumper;
warn Dumper(\#INC);
$classname->foo;
I get the following errors (depending on whether my require line is commented out):
With require:
Recursive call to Perl_load_module in PerlIO_find_layer at crazy.pl line 16.
BEGIN failed--compilation aborted.
without:
$VAR1 = [
bless( {
'foo' => 'bar'
}, 'Frew' ),
'C:/usr/site/lib',
'C:/usr/lib',
'.'
];
Can't locate object method "foo" via package "Frew" at crazy.pl line 24.
Any wizards who know some of this black magic already: please answer! I'd love to learn more of this arcana :-)
Also note: I know that I can do this kind of stuff with Moose and other lighter helper modules, I am mostly trying to learn, so recommendations to use such-and-such a module will not get my votes :-)
Update: Ok, I guess I wasn't quite clear originally with my question. I basically want to generate a Perl class with a string (that I will manipulate and do interpolation into) based on an external data structure. I imagine that going from what I have here (once it works) to that shouldn't be too hard.
Here is a version which works:
#!/usr/bin/perl
use strict;
use warnings;
my $class = 'Frew';
{
no strict 'refs';
*{ "${class}::INC" } = sub {
my ($self, $req) = #_;
return unless $req eq $class;
my $data = qq{
package $class;
sub foo { print "test!\n" };
1;
};
open my $fh, '<', \$data;
return $fh;
};
}
my $foo = bless { }, $class;
unshift #INC, $foo;
require $class;
$class->foo;
The #INC hook gets the name of the file (or string passed to require) as the second argument, and it gets called every time there is a require or use. So you have to check to make sure we're trying to load $classname and ignore all other cases, in which case perl continues down along #INC. Alternatively, you can put the hook at the end of #INC. This was the cause of your recursion errors.
ETA: IMHO, a much better way to achieve this would be to simply build the symbol table dynamically, rather than generating code as a string. For example:
no strict 'refs';
*{ "${class}::foo" } = sub { print "test!\n" };
*{ "${class}::new" } = sub { return bless { }, $class };
my $foo = $class->new;
$foo->foo;
No use or require is necessary, nor messing with evil #INC hooks.
I do this:
use MooseX::Declare;
my $class = class {
has 'foo' => (is => 'ro', isa => 'Str', required => 1);
method bar() {
say "Hello, world; foo is ", $self->foo;
}
};
Then you can use $class like any other metaclass:
my $instance = $class->name->new( foo => 'foo bar' );
$instance->foo; # foo-bar
$instance->bar; # Hello, world; foo is foo-bar
etc.
If you want to dynamically generate classes at runtime, you need to create the proper metaclass, instantiate it, and then use the metaclass instance to generate instances. Basic OO. Class::MOP handles all the details for you:
my $class = Class::MOP::Class->create_anon_class;
$class->add_method( foo => sub { say "Hello from foo" } );
my $instance = $class->new_object;
...
If you want to do it yourself so that you can waste your time debugging something, perhaps try:
sub generate_class_name {
state $i = 0;
return '__ANON__::'. $i++;
}
my $classname = generate_class_name();
eval qq{
package $classname;
sub new { my \$class = shift; bless {} => \$class }
...
};
my $instance = $classname->new;
For a simple example of how to do this, read the source of Class::Struct.
However, if I needed the ability to dynamically build classes for some production code, I'd look at MooseX::Declare, as suggested by jrockway.
A Perl class is little more than a data structure (usually a hashref)
that has been blessed into a package in which one or more class
methods are defined.
It is certainly possible to define multiple package namespaces in one
file; I don't see why this wouldn't be possible in an eval construct
that is compiled at run-time (see perlfunc for the two different
eval forms).
#!/usr/bin/perl
use 5.010;
use strict;
use warnings;
use Data::Dumper;
eval q[
package Foo;
sub new {
my ( $class, %args ) = #_;
my $self = bless { %args }, $class;
return $self;
}
1;
];
die $# if $#;
my $foo = Foo->new(bar => 1, baz => 2) or die;
say Dumper $foo;