[perl script]
perl_script.pl -b "HELLO" -v
use package1;
use package2;
my $argb = GetPackage1Option;
my $argv = GetPackage2Option;
print "$argb\n"; # Print -b argument
print "v is found!\n" if ( GetPackage2Option ); # Print
[package1.pm]
use Getopt::Std;
require Exporter;
#ISA = qw(Exporter);
#EXPORT = qw( GetPackage1Option );
sub GetPackage1Option {
getopt('b');
our ($opt_b);
my $argb = $opt_b || '';
return $argb;
}
[package2.pm]
use Getopt::Std;
require Exporter;
#ISA = qw(Exporter);
#EXPORT = qw( GetPackage2Option );
sub GetPackage2Option {
my $bool = 0;
my %opt;
getopts('v', \%opt);
return ( defined $optHash{v} ) ? $optHash{v} : $bool;
}
I am calling 2 functions from 2 separate packages and each function uses a different option.
I tried this but I am only getting the option for -b. The -v option works if I remove the functions that use -b.
Apologies this only sort of a summary of my original code.
Please let me know if my question is confusing. Thanks :)
Getopt::Std operates on and "consumes" the global #ARGV array. To run getopt or getopts multiple times, you could use local to make a temporary copy of #ARGV.
sub GetPackage1Option {
local #ARGV = #ARGV;
getopt('b');
our ($opt_b);
my $argb = $opt_b || '';
return $argb;
} # end of scope, original #ARGV restored
Though like Sinan and simbabque say, this is an unorthodox design that you should probably reconsider.
The easiest way out of the conundrum is for command line argument parsing to happen at the entry point of your program where the values of the arguments can be saved in a hash, where you can provide default values for those not specified on the command line etc. Then, you can decide how to communicate the values each module is interested in (e.g. package variables or constructor arguments).
I would strongly recommend against this kind of action at a distance, but here's how one might go about automating the setting of values of package variables in different modules in response to values given on the command line. Each package is responsible for declaring the command line switches in which it is interested.
#!/usr/bin/env perl
use strict;
use warnings;
package X;
our #PACKAGE_OPTS = qw( v x: );
our ($OPT_V, $OPT_X);
sub func {
print "$OPT_V\t$OPT_X\n";
}
package Y;
our #PACKAGE_OPTS = qw( t y: z);
our ($OPT_T, $OPT_Y, $OPT_Z);
sub func {
print join("\t", $OPT_T, $OPT_Y, $OPT_Z), "\n";
}
package main;
use Getopt::Std;
main();
sub main {
init_opts(qw( X Y ));
X::func();
Y::func();
}
sub init_opts {
my %opts;
my $opt_string;
my %opt_to_package;
for my $pkg ( #_ ) {
my #opts = eval "\#${pkg}::PACKAGE_OPTS";
$opt_string .= join '', #opts;
for my $opt ( #opts ) {
(my $var = $opt) =~ s/[^A-Za-z]+//g;
$opts{$var} = '-not provided-';
$opt_to_package{$var} = $pkg;
}
}
getopts($opt_string, \%opts);
for my $opt (keys %opts) {
my $pkg = $opt_to_package{$opt};
my $var = 'OPT_' . uc $opt;
eval "\$${pkg}::${var} = \$opts{\$opt}"
}
return;
}
Output:
C:\...\Temp> perl tt.pl -zvx a -y b
1 a
-not provided- b 1
Related
So I want something like:
module0.pl
sub fun {
print "fun $_[0] from 0\n"
}
1
module1.pl
sub fun {
print "fun $_[0] from 1\n"
}
1
main.pl
BEGIN{push #INC, "."};
require "module0.pl";
require "module1.pl";
fun("test")
Which will print (in any order - I don't care) :
fun test from 0
fun test from 1
Is it possible - and what is the most elegant syntax to do it?
So you want to call a list of subs from various packages (here equally named) ?
One way, using normal packages
package Pack1;
use warnings;
use strict;
use feature 'say';
sub fun { say "fun $_[0] from ", __PACKAGE__ }
1;
The calling program, in the same directory with this package (and its counterpart Pack2)
use warnings;
use strict;
use feature 'say';
use FindBin qw($RealBin);
use lib $RealBin;
use Pack1;
use Pack2;
for my $packname (qw(Pack1 Pack2)) {
MAKENAME: {
no strict 'refs';
my $fun_name = $packname . '::' . 'fun';
$fun_name->("hi") if exists &{$fun_name};
}
}
I put that scoped no strict 'refs' in another block, and name the block, just so; if this is all that is done in the loop there is no need to introduce another scope.† We need the refs stricture off for using it as a subroutine reference but then it makes sense to scope the name itself as well.
A few notes
I don't know why those are .pl files which are require-ed; they should be packages and I wrote them that way. Let me know if there is actually a specific (and unbeatable) reason for them to be require-ed programs
Add directories to #INC using the lib pragma with $FindBin::RealBin, not by hacking #INC
† Or copy the coderef
for my $packname (qw(Pack1 Pack2)) {
my $fun = \&{ $packname . '::' . 'fun' };
$fun->('hi');
}
But if we do need to check for existence that should rather be
for my $packname (qw(Pack1 Pack2)) {
my $fun_name = $packname . '::' . 'fun';
next if not exists &{$fun_name};
my $fun = \&{$fun_name};
$fun->('hi');
}
A fairly robust way would be to use a registry for callbacks.
# main.pl
{
package MyApp;
my %callbacks;
sub register_callback {
my ( $class, $event, #callbacks ) = #_;
push #{ $callbacks{$event} ||= [] }, #callbacks;
return scalar #{ $callbacks{$event} || [] };
}
sub run_callbacks {
my ( $class, $event, #args ) = #_;
$_->( #args ) for #{ $callbacks{$event} || [] };
return;
}
}
BEGIN { push #INC, "." };
require 'module0.pl';
require 'module1.pl';
MyApp->run_callbacks(
fun => ( 'test' ),
);
MyApp->run_callbacks(
boredom => (),
);
# module0.pl
MyApp->register_callback( fun => sub {
print "fun $_[0] from 0\n"
} );
MyApp->register_callback( boredom => sub {
print "boredom from 0\n"
} );
# module1.pl
MyApp->register_callback( fun => sub {
print "fun $_[0] from 1\n"
} );
Let's take something very simple,
# Foo.pm
package Foo {
my $baz = bar();
sub bar { 42 }; ## Overwrite this
print $baz; ## Before this is executed
}
Is there anyway that I can from test.pl run code that changes what $baz is set to and causes Foo.pm to print something else to the screen?
# maybe something here.
use Foo;
# maybe something here
Is it possible with the compiler phases to force the above to print 7?
A hack is required because require (and thus use) both compiles and executes the module before returning.
Same goes for eval. eval can't be used to compile code without also executing it.
The least intrusive solution I've found would be to override DB::postponed. This is called before evaluating a compiled required file. Unfortunately, it's only called when debugging (perl -d).
Another solution would be to read the file, modify it and evaluate the modified file, kinda like the following does:
use File::Slurper qw( read_binary );
eval(read_binary("Foo.pm") . <<'__EOS__') or die $#;
package Foo {
no warnings qw( redefine );
sub bar { 7 }
}
__EOS__
The above doesn't properly set %INC, it messes up the file name used by warnings and such, it doesn't call DB::postponed, etc. The following is a more robust solution:
use IO::Unread qw( unread );
use Path::Class qw( dir );
BEGIN {
my $preamble = '
UNITCHECK {
no warnings qw( redefine );
*Foo::bar = sub { 7 };
}
';
my #libs = #INC;
unshift #INC, sub {
my (undef, $fn) = #_;
return undef if $_[1] ne 'Foo.pm';
for my $qfn (map dir($_)->file($fn), #libs) {
open(my $fh, '<', $qfn)
or do {
next if $!{ENOENT};
die $!;
};
unread $fh, "$preamble\n#line 1 $qfn\n";
return $fh;
}
return undef;
};
}
use Foo;
I used UNITCHECK (which is called after compilation but before execution) because I prepended the override (using unread) rather than reading in the whole file in and appending the new definition. If you want to use that approach, you can get a file handle to return using
open(my $fh_for_perl, '<', \$modified_code);
return $fh_for_perl;
Kudos to #Grinnz for mentioning #INC hooks.
Since the only options here are going to be deeply hacky, what we really want here is to run code after the subroutine has been added to the %Foo:: stash:
use strict;
use warnings;
# bless a coderef and run it on destruction
package RunOnDestruct {
sub new { my $class = shift; bless shift, $class }
sub DESTROY { my $self = shift; $self->() }
}
use Variable::Magic 0.58 qw(wizard cast dispell);
use Scalar::Util 'weaken';
BEGIN {
my $wiz;
$wiz = wizard(store => sub {
return undef unless $_[2] eq 'bar';
dispell %Foo::, $wiz; # avoid infinite recursion
# Variable::Magic will destroy returned object *after* the store
return RunOnDestruct->new(sub { no warnings 'redefine'; *Foo::bar = sub { 7 } });
});
cast %Foo::, $wiz;
weaken $wiz; # avoid memory leak from self-reference
}
use lib::relative '.';
use Foo;
This will emit some warnings, but prints 7:
sub Foo::bar {}
BEGIN {
$SIG{__WARN__} = sub {
*Foo::bar = sub { 7 };
};
}
First, we define Foo::bar. It's value will be redefined by the declaration in Foo.pm, but the "Subroutine Foo::bar redefined" warning will be triggered, which will call the signal handler that redefines the subroutine again to return 7.
Here is a solution that combines hooking the module loading process with the readonly-making capabilities of the Readonly module:
$ cat Foo.pm
package Foo {
my $baz = bar();
sub bar { 42 }; ## Overwrite this
print $baz; ## Before this is executed
}
$ cat test.pl
#!/usr/bin/perl
use strict;
use warnings;
use lib qw(.);
use Path::Tiny;
use Readonly;
BEGIN {
my #remap = (
'$Foo::{bar} => \&mybar'
);
my $pre = join ' ', map "Readonly::Scalar $_;", #remap;
my #inc = #INC;
unshift #INC, sub {
return undef if $_[1] ne 'Foo.pm';
my ($pm) = grep { $_->is_file && -r } map { path $_, $_[1] } #inc
or return undef;
open my $fh, '<', \($pre. "#line 1 $pm\n". $pm->slurp_raw);
return $fh;
};
}
sub mybar { 5 }
use Foo;
$ ./test.pl
5
I have revised my solution here, so that it no longer relies on Readonly.pm, after learning that I had missed a very simple alternative, based on m-conrad's answer, which I have reworked into the modular approach that I had started here.
Foo.pm (Same as in the opening post)
package Foo {
my $baz = bar();
sub bar { 42 }; ## Overwrite this
print $baz; ## Before this is executed
}
# Note, even though print normally returns true, a final line of 1; is recommended.
OverrideSubs.pm Updated
package OverrideSubs;
use strict;
use warnings;
use Path::Tiny;
use List::Util qw(first);
sub import {
my (undef, %overrides) = #_;
my $default_pkg = caller; # Default namespace when unspecified.
my %remap;
for my $what (keys %overrides) {
( my $with = $overrides{$what} ) =~ s/^([^:]+)$/${default_pkg}::$1/;
my $what_pkg = $what =~ /^(.*)\:\:/ ? $1 : $default_pkg;
my $what_file = ( join '/', split /\:\:/, $what_pkg ). '.pm';
push #{ $remap{$what_file} }, "*$what = *$with";
}
my #inc = grep !ref, #INC; # Filter out any existing hooks; strings only.
unshift #INC, sub {
my $remap = $remap{ $_[1] } or return undef;
my $pre = join ';', #$remap;
my $pm = first { $_->is_file && -r } map { path $_, $_[1] } #inc
or return undef;
# Prepend code to override subroutine(s) and reset line numbering.
open my $fh, '<', \( $pre. ";\n#line 1 $pm\n". $pm->slurp_raw );
return $fh;
};
}
1;
test-run.pl
#!/usr/bin/env perl
use strict;
use warnings;
use lib qw(.); # Needed for newer Perls that typically exclude . from #INC by default.
use OverrideSubs
'Foo::bar' => 'mybar';
sub mybar { 5 } # This can appear before or after 'use OverrideSubs',
# but must appear before 'use Foo'.
use Foo;
Run and output:
$ ./test-run.pl
5
If the sub bar inside Foo.pm has a different prototype than an existing Foo::bar function, Perl won't overwrite it? That seems to be the case, and makes the solution pretty simple:
# test.pl
BEGIN { *Foo::bar = sub () { 7 } }
use Foo;
or kind of the same thing
# test.pl
package Foo { use constant bar => 7 };
use Foo;
Update: no, the reason this works is that Perl won't redefine a "constant" subroutine (with prototype ()), so this is only a viable solution if your mock function is constant.
Lets have a Golf contest!
sub _override { 7 }
BEGIN {
my ($pm)= grep -f, map "$_/Foo.pm", #INC or die "Foo.pm not found";
open my $fh, "<", $pm or die;
local $/= undef;
eval "*Foo::bar= *main::_override;\n#line 1 $pm\n".<$fh> or die $#;
$INC{'Foo.pm'}= $pm;
}
use Foo;
This just prefixes the module's code with a replacement of the method, which will be the first line of code that runs after the compilation phase and before the execution phase.
Then, fill in the %INC entry so that future loads of use Foo don't pull in the original.
I am using more modules in my perl program.
example:
use File::copy;
so likewise File module contains Basename, Path, stat and etc..
i want to list all the subroutine(function) names which is in File Package module.
In python has dir(modulename)
It list all the function that used in that module....
example:
#!/usr/bin/python
# Import built-in module math
import math
content = dir(math)
print content
Like python tell any code for in perl
If you want to look at the contents of a namespace in perl, you can use %modulename::.
For main that's either %main:: or %::.
E.g.:
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
sub fish {};
sub carrot {};
print "Stuff defined in Dumper:\n";
print Dumper \%Data::Dumper::;
print "Stuff defined:\n";
print Dumper \%::;
That covers a load of stuff though - including pragmas. But you can check for e.g. subroutines by simply testing it for being a code reference.
foreach my $thing ( keys %:: ) {
if ( defined &$thing ) {
print "sub $thing\n";
}
}
And with reference to the above sample, this prints:
sub Dumper
sub carrot
sub fish
So with reference to your original question:
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
use File::Copy;
print "File::Copy has subs of:\n";
foreach my $thing ( keys %File::Copy:: ) {
if ( defined &$thing ) {
print "sub $thing\n";
}
}
Unfortunately you can't do the same thing with the whole File:: namespace, because there's a whole bunch of different modules that could be installed/loaded, but might not be.
You'd have to use e.g. CPAN to check that -
perl -MCPAN -e shell
i /^File::/
Which will list you around 717 modules that are grouped into the File:: tree.
You could look this up on CPAN. Or if you're just after the core modules, then some variant of using Module::CoreList might do what you want.
Something like this:
#!/usr/bin/perl
use strict;
use warnings;
use Module::CoreList;
foreach my $module ( Module::CoreList->find_modules(qr/^File::/) ) {
if ( eval { require $module =~ s|::|/|gr . ".pm" } ) {
print "Module: $module contains\n";
my $key_str = "\%$module\:\:";
my %stuff = eval $key_str;
foreach my $thing ( sort keys %stuff ) {
my $full_sub_path = "$module::$thing";
if ( eval {"defined &$full_sub_path"} ) {
if ( defined &$thing ) {
print "$thing <- $full_sub_path imported by default\n";
}
else {
print "\t$full_sub_path might be loadable\n";
}
}
}
}
else {
print "Module: $module couldn't be loaded\n";
}
}
It's a bit messy because you have to eval various bits of it to test if a module is in fact present and loadable at runtime. Oddly enough, File::Spec::VMS wasn't present on my Win32 system. Can't think why.... :).
Should note - just because you could import a sub from a module (that isn't exported by default) doesn't make it a good idea. By convention, any sub prefixed with an _ is not supposed to be used externally, etc.
My Devel::Examine::Subs module can do this, plus much more. Note that whether it's a method or function is irrelevant, it'll catch both. It works purely on subroutines as found with PPI.
use warnings;
use strict;
use Devel::Examine::Subs;
my $des = Devel::Examine::Subs->new;
my $subs = $des->module(module => 'File::Copy');
for (#$subs){
print "$_\n";
}
Output:
_move
move
syscopy
carp
mv
_eq
_catname
cp
copy
croak
Or a file/full directory. For all Perl files in a directory (recursively), just pass the dir to file param without a file at the end of the path:
my $des = Devel::Examine::Subs->new(file => '/path/to/file.pm');
my $subs = $des->all;
If you just want to print it use the Data::Dumper module and the following method, CGI used as an example:
use strict;
use warnings;
use CGI;
use Data::Dumper;
my $object = CGI->new();
{
no strict 'refs';
print "Instance METHOD IS " . Dumper( \%{ref ($object)."::" }) ;
}
Also note, it's File::Copy, not File::copy.
I'm looking for way to debug print each subroutine call from the namespace Myapp::* (e.g. without dumping the CPAN modules), but without the need edit every .pm file manually for to inserting some module or print statement.
I just learning (better to say: trying to understand) the package DB, what allows me tracing the execution (using the shebang #!/usr/bin/perl -d:Mytrace)
package DB;
use 5.010;
sub DB {
my( $package, $file, $line ) = caller;
my $code = \#{"::_<$file"};
print STDERR "--> $file $line $code->[$line]";
}
#sub sub {
# print STDERR "$sub\n";
# &$sub;
#}
1;
and looking for a way how to use the sub call to print the actual arguments of the called sub from the namespace of Myapp::*.
Or is here some easier (common) method to
combine the execution line-tracer DB::DB
with the Dump of the each subroutine call arguments (and its return values, if possible)?
I don't know if it counts as "easier" in any sane meaning of the word, but you can walk the symbol table and wrap all functions in code that prints their arguments and return values. Here's an example of how it might be done:
#!/usr/bin/env perl
use 5.14.2;
use warnings;
package Foo;
sub first {
my ( $m, $n ) = #_;
return $m+$n;
}
sub second {
my ( $m, $n ) = #_;
return $m*$n;
}
package main;
no warnings 'redefine';
for my $k (keys %{$::{'Foo::'}}) {
my $orig = *{$::{'Foo::'}{$k}}{CODE};
$::{'Foo::'}{$k} = sub {
say "Args: #_";
unless (wantarray) {
my $r = $orig->(#_);
say "Scalar return: $r";
return $r;
}
else {
my #r = $orig->(#_);
say "List return: #r";
return #r
}
}
}
say Foo::first(2,3);
say Foo::second(4,6);
I want to call a main controller function that dispatches other function dynamically, something like this:
package Controller;
my %callback_funcs = ();
sub register_callback{
my ($class,$callback,$options) = _#;
#apppend to %callback_funcs hash ... ?
}
sub main{
%callback_funcs = ( add => 'add_func', rem => 'remove_func', edit => 'edit_func');
while(<STDIN>){
last if ($_ =~ /^\s*$/);
if($_ == 'add' || _$ == 'rem' || _$ == 'edit'){
$result = ${callback_funcs['add']['func']}(callback_funcs['add']['options']);
}
}
}
sub add_func{
...
}
One caveat is that the subs are defined in other Modules, so the callbacks would have to be able to reference them... plus
I'm having a hard time getting the hashes right!
So, it's possible to have a hash that contains anonymous subroutines that you can invoke from stdin.
my %callbacks = (
add => sub {
# do stuff
},
fuzzerbligh => sub {
# other stuff
},
);
And you can insert more hashvalues into the hash:
$callbacks{next} = sub {
...
};
And you would invoke one like this
$callbacks{next}->(#args);
Or
my $coderef = $callbacks{next};
$coderef->(#args);
You can get the hashkey from STDIN, or anywhere else.
You can also define them nonymously and then take a reference to them.
sub delete {
# regular sub definition
}
$callbacks{delete} = \&delete;
I wouldn't call these callbacks, however. Callbacks are subs that get called after another subroutine has returned.
Your code is also rife with syntax errors which may be obscuring the deeper issues here. It's also not clear to me what you're trying to do with the second level of arrays. When are you defining these subs, and who is using them when, and for what?
Perhaps this simplified example will help:
# Very important.
use strict;
use warnings;
# Define some functions.
sub multiply { $_[0] * $_[1] }
sub divide { $_[0] / $_[1] }
sub add { $_[0] + $_[1] }
sub subtract { $_[0] - $_[1] }
# Create a hash of references to those functions (dispatch table).
my %funcs = (
multiply => \&multiply,
divide => \÷,
add => \&add,
subtract => \&subtract,
);
# Register some more functions.
sub register {
my ($key, $func) = #_;
$funcs{$key} = $func;
}
register('+', \&add); # As above.
register('sum', sub { # Or using an anonymous subroutine.
my $s = 0;
$s += $_ for #_;
return $s;
});
# Invoke them dynamically.
while (<>){
my ($op, #args) = split;
last unless $op and exists $funcs{$op}; # No need for equality tests.
print $funcs{$op}->(#args), "\n";
}
You've already got some good answers on how to build a dispatch table and call functions through it within a single file, but you also keep talking about wanting the functions to be defined in other modules. If that's the case, then wouldn't it be better to build the dispatch table dynamically based on what dispatchable functions each module says it has rather than having to worry about keeping it up to date manually? Of course it would!
Demonstrating this requires multiple files, of course, and I'm using Module::Pluggable from CPAN to find the modules which provide the function definitions.
dispatch_core.pl:
#!/usr/bin/env perl
use strict;
use warnings;
my %dispatch;
use lib '.'; # a demo is easier if I can put modules in the same directory
use Module::Pluggable require => 1, search_path => 'DTable';
for my $plugin (plugins) {
%dispatch = (%dispatch, $plugin->dispatchable);
}
for my $func (sort keys %dispatch) {
print "$func:\n";
$dispatch{$func}->(2, 5);
}
DTable/Add.pm:
package DTable::Add;
use strict;
use warnings;
sub dispatchable {
return (add => \&add);
}
sub add {
my ($num1, $num2) = #_;
print "$num1 + $num2 = ", $num1 + $num2, "\n";
}
1;
DTable/MultDiv.pm:
package DTable::MultDiv;
use strict;
use warnings;
sub dispatchable {
return (multiply => \&multiply, divide => \÷);
}
sub multiply {
my ($num1, $num2) = #_;
print "$num1 * $num2 = ", $num1 * $num2, "\n";
}
sub divide {
my ($num1, $num2) = #_;
print "$num1 / $num2 = ", $num1 / $num2, "\n";
}
1;
Then, on the command line:
$ ./dispatch_core.pl
add:
2 + 5 = 7
divide:
2 / 5 = 0.4
multiply:
2 * 5 = 10
Adding new functions is now as simple as dropping a new file into the DTable directory with an appropriate dispatchable sub. No need to ever touch dispatch_core.pl just to add a new function again.
Edit: In response to the comment's question about whether this can be done without Module::Pluggable, here's a modified dispatch_core.pl which doesn't use any external modules other than the ones defining the dispatchable functions:
#!/usr/bin/env perl
use strict;
use warnings;
my %dispatch;
my #dtable = qw(
DTable::Add
DTable::MultDiv
);
use lib '.';
for my $plugin (#dtable) {
eval "use $plugin";
%dispatch = (%dispatch, $plugin->dispatchable);
}
for my $func (sort keys %dispatch) {
print "$func:\n";
$dispatch{$func}->(2, 5);
}