I am trying to learn Devel::Declare so as to attempt to reimplement something like PDL::NiceSlice without source filters. I was getting somewhere when I noticed that it was removing the next line from my script. To illustrate I have made this minimal example wherein one can use the comment keyword to remove the entire line from the code, allowing a compile even though barewords abound on that line.
#Comment.pm
package Comment;
use strict;
use warnings;
use Devel::Declare ();
sub import {
my $class = shift;
my $caller = caller;
Devel::Declare->setup_for(
$caller,
{ comment => { const => \&parser } }
);
no strict 'refs';
*{$caller.'::comment'} = sub {};
}
sub parser {
#my $linestr = Devel::Declare::get_linestr;
#print $linestr;
Devel::Declare::set_linestr("");
}
1
and
#!/usr/bin/env perl
#test.pl
use strict;
use warnings;
use Comment;
comment stuff;
print "Print 1\n";
print "Print 2\n";
yields only
Print 2
what am I missing?
P.S. I will probably have a few more questions on D::D coming up if I should figure this one out, so thanks in advance!
Ok so I got it. Using perl -MO=Deparse test.pl you get:
use Comment;
use warnings;
use strict 'refs';
comment("Print 1\n");
print "Print 2\n";
test.pl syntax OK
which tells me that if forces the comment function to be called. After some experimentation I found that I could just set the output to call comment() explicitly so that it doesn't try to call comment on whatever is next.
sub parser {
Devel::Declare::set_linestr("comment();");
}
so that the deparse is:
use Comment;
use warnings;
use strict 'refs';
comment();
print "Print 1\n";
print "Print 2\n";
test.pl syntax OK
and the proper output too.
Related
A couple of times I've ran into the situation where I've forgotten to load the Try::Tiny module in my script and I've still used its try-catch block, like this:
#!/usr/bin/env perl
use strict;
use warnings;
try {
call_a( 'x' );
} catch {
die "ACTUALLY die $_";
};
sub call_a {
die "Yes, I will";
}
For some reason, the script works fine without giving any hints that there is no try. No Undefined subroutine errors. This makes me wonder why my raised exceptions are not caught.
Why does this work silently, without an error?
EDIT
I looked into symbol table as well:
say "$_: %main::{ $_ }" for keys %main::;
and found there no try. Also I tried to call it as main::try in the script above, and it caused also no errors.
This is due to the indirect-object syntax, and is a more elaborate variation on this example.
The "indirect object notation" allows code
PackageName->method(#args);
to be written as
method PackageName #args;
So the "try" and "catch" words don't matter. The interesting bit here is the more involved and extended syntax, with two parts, each in this indirect object notation.
The code in question in fact has method BLOCK LIST form, but that also goes by indirect object syntax into (do BLOCK)->method(LIST), where do BLOCK needs to produce a name of a package or a blessed (object) reference for a meaningful method call. This is seen below in Deparse output.
Using B::Deparse compiler backend (via O module) on this code
use strict;
use warnings;
use feature 'say';
try { call_a( 'x' ) }
catch {
die "ACTUALLY die";
#say "NO DONT die";
};
sub call_a {
die "Yes it dies";
#say "no die";
}
as perl -MO=Deparse script.pl should show a very close approximation of what runs:
use warnings;
use strict;
use feature 'say';
try {
call_a('x')
} do {
die 'ACTUALLY die'
}->catch;
sub call_a {
use warnings;
use strict;
use feature 'say';
die 'Yes it dies';
}
undef_sub.pl syntax OK
The nested indirect object syntax is apparently too much for Deparse which still leaves method BLOCK LIST form in the output. The equivalent code can be spelled out as
(do { call_a('x') })->try( (do { die("ACTUALLY die") })->catch() );
what in this case is more simply
call_a('x')->try( die("ACTUALLY die")->catch() );
Thus the original code is interpreted as valid syntax (!) and it is the contents of the block after try (call_a('x')) that runs first --- so the program dies and never gets to go for the "method" try.
It gets more interesting if we change the example to
use strict;
use warnings;
use feature 'say';
try { call_a( 'x' ) }
catch {
#die "ACTUALLY die";
say "NO DONT die";
};
sub call_a {
#die "Yes it dies";
say "no die";
}
with no die-ing anywhere. Run it with -MO=Deparse to see
use warnings;
use strict;
use feature 'say';
try {
call_a('x')
} (catch {
say 'NO DONT die'
} );
sub call_a {
use warnings;
use strict;
use feature 'say';
say 'no die';
}
undef_sub.pl syntax OK
which is now in a straight-up method {} args syntax (with args itself shown by Deparse in an indirect object notation as well).
The equivalent code is
call_a('x')->try( say("NO DONT die")->catch() );
where first the call_a() goes and, after it returns, then the code for the argument list in the try method call runs next. We aren't running into a die and an actual run goes as
no die
NO DONT die
Can't call method "catch" without a package or object reference at ...
So now a problem with the method "catch" does come up.
Thanks to ikegami for comments
If the block above were to return a name of a package (or object reference) which does have a method catch then the try would finally be attempted as well
use strict;
use warnings;
use feature 'say';
BEGIN {
package Catch;
sub catch { say "In ", (caller(0))[3] };
$INC{"Catch.pm"} = 1;
};
use Catch;
try { call_a( 'x' ) }
catch {
say "NO DONT die";
"Catch";
};
sub call_a { say "no die" }
Now we have the equivalent
call_a('x')->try( do { say("NO DONT die"); 'Catch' }->catch() );
with the output
no die
NO DONT die
In Catch::catch
Can't call method "try" without a package or object reference at undef_sub.pl line 14.
I'm trying to create a module with a method that receives a subroutine and redefines it. I had no problem redefining a subroutine inside the main script but the same syntax doesn't seem to work inside the method:
main.pl
use strict;
use warnings;
use ReDef;
sub orig{
print "Original!\n";
}
orig;
*orig=sub{print "not Original!\n";};
orig;
ReDef::redef(\&orig);
orig;
ReDef.pm
package ReDef;
use strict;
use warnings;
sub redef {
my $ref=shift;
*ref = sub {print "Redefined!";}
}
1;
Test output:
perl main.pl
Original!
Subroutine main::orig redefined at main.pl line 9.
not Original!
not Original!
ReDef::redef() doesn't redefine. The way I see it, the *ref is a coderef and assigning to it another subroutine should change main::orig();
What is the correct syntax?
Your redef function should be like this:
package ReDef;
use strict;
use warnings;
sub redef {
my $ref = shift;
no warnings qw(redefine);
*$ref = sub { print "Redefined!" };
}
And you should NOT call it like this:
ReDef::redef(\&orig);
Instead, you must call it like this:
ReDef::redef(\*orig);
Why? When you call orig, you're looking up the name "orig" via the symbol table, so the redef function needs to be altering the symbol table, so that it can point that name to a different bit of code. Globrefs are basically pointers to little bits of symbol table, so that's what you need to pass to ReDef::redef.
As an analogy, imagine that when you want to know the date of the Battle of Lewes, your procedure is to go to the library, look in the catalogue for the shelf address of a book on 13th century English battles, go to that shelf, and look up the date... voila 14 May 1264! Now, imagine I want to feed you altered information. Simply defining a new coderef would be like putting a new book on the shelf: it won't trick you because the catalogue is still pointing you at the old book. We need to alter the catalogue too.
UPDATE
You can make this a little prettier using prototypes. Prototypes are not usually recommended, but this seems to be a non-evil use for them...
use strict;
use warnings;
sub ReDef::redef (*) {
my $ref = shift;
no warnings qw(redefine);
*$ref = sub { print "Redefined!\n" };
}
sub orig { print "Original!\n" }
orig;
ReDef::redef *orig; # don't need the backslash any more
orig;
This works for me:
use v5.16;
use strict;
use warnings;
package Redef;
sub redef {
my $ref = shift;
${$ref} = sub { say "Redefined!"; }
}
package main;
my $orig = sub { say "Original!"; };
Redef::redef(\$orig);
$orig->(); # Redefined!
Although it’s just a result of trial and error, I’d be happy to see better answers.
What maybe got you confused is the typeglob operator, *. In Perl you dereference using a sigil (${$scalar_ref}, #{$array_ref}) and the * operator is used for symbol table tricks – which could also be used in your case, see the answer by #tobyink.
If a file is already loaded, is there anyway to hook into the use/require so I can throw an exception? In my upcoming nextgen::blacklist, I'm trying to die if certain modules are used. I'm using the object-hook method as mentioned in perldoc -f require: there are three-like hooks object, array with subref, and subref. The example in this post is the object-hook, you can find my attempt of the sub-ref hook in nextgen::blacklist.
The syntax I'm desiring is something like:
perl -Mnextgen -E"use NEXT"
package Foo;
use nextgen;
use NEXT;
Ideally it is supposed to throw a message like this:
nextgen::blacklist violation with import attempt for: [ NEXT (NEXT.pm) ] try 'use mro' instead.
I've tried this a bunch of different ways.
package Class;
use Data::Dumper;
use strict;
use warnings;
sub install {
unshift #main::INC, bless {}, __PACKAGE__
unless ref $main::INC[0] eq __PACKAGE__
;
}
sub reset_cache { undef %main::INC }
sub Class::INC {
my ( $self, $pmfile ) = #_;
warn Dumper [\%main::INC, $pmfile];
#undef %INC;
}
package main;
BEGIN { Class->install; undef %main::INC }
use strict;
use strict;
use strict;
use strict;
use warnings;
use strict;
use warnings;
It seems as if %INC is only set after these hooks. I'm interested in anything that will allow me to throw an exception. If an attempt is made to load/reload a module dispite the status of it as a dependency of other modules that don't use my pragma, I want to die.
package Foo;
use NEXT;
package main;
use Foo; (which uses Next.pm);
use NEXT.pm; ## Throw exception
You probably want to put a coderef onto the beginning #INC, as described in perldoc -f require. From there, you can raise exceptions to prevent certain modules from being loaded, or do nothing to let require carry on with its normal job of looking up the module in the other #INC entries.
$ perl -E'BEGIN { unshift #INC, sub { die q{no NEXT} if pop eq q{NEXT.pm}; () }; }; use Carp; say q{success}'
success
$ perl -E'BEGIN { unshift #INC, sub { die q{no NEXT} if pop eq q{NEXT.pm}; () }; }; use NEXT; say q{success}'
no NEXT at -e line 1.
BEGIN failed--compilation aborted at -e line 1.
If you want that behaviour to be lexical, you should make use of Perl's hints hash %^H. Dealing with that is a little fiddly, so I'd recommend using Devel::Pragma, which can take care of all the gory details for you.
As you pointed out, the #INC hooks won't be executed for a module that's already loaded. If you also need to hook into the use or require of a loaded module, overriding CORE::GLOBAL::require would work, as it is called for every attempt to load a module.
$ perl -E'BEGIN { *CORE::GLOBAL::require = sub { warn #_ } } use NEXT; use NEXT;'
NEXT.pm at -e line 1
NEXT.pm at -e line 1.
Also, as the maintainer of NEXT, I completely approve of preventing people from using it, at all, ever. :-)
I saw some code that called methods on scalars (numbers), something like:
print 42->is_odd
What do you have to overload so that you can achieve this sort of "functionality" in your code?
Are you referring to autobox? See also Should I use autobox in Perl?.
This is an example using the autobox feature.
#!/usr/bin/perl
use strict;
use warnings;
package MyInt;
sub is_odd {
my $int = shift;
return ($int%2);
}
package main;
use autobox INTEGER => 'MyInt';
print "42: ".42->is_odd."\n";
print "43: ".43->is_odd."\n";
print "44: ".44->is_odd."\n";
Requirement is to pass module name and function name from the command-line argument.
I need to get the command-line argument in the program and I need to call that function from that module
For example, calling a try.pl program with 2 arguments: MODULE1(Module name) Display(Function name)
perl try.pl MODULE1 Display
I want to some thing like this, but its not working, please guide me:
use $ARGV[0];
& $ARGV[0]::$ARGV[1]();
Assuming the function is not a class method, try this:
#!/usr/bin/perl
use strict;
use warnings;
my ( $package, $function ) = #ARGV;
eval "use $package (); ${package}::$function()";
die $# if $#;
Keep in mind that this technique is wide open to code injection. (The arguments could easily contain any Perl code instead of a module name.)
There's many ways to do this. One of them is:
#!/usr/bin/perl
use strict;
use warnings;
my ( $package, $function ) = #ARGV;
eval "use $package; 1" or die $#;
$package->$function();
Note the the first argument of the function will be $package.
Assuming the module exports the function, this should do:
perl -Mmodule -e function
If you want to make sure your perl script is secure (or at least, prevent yourself from accidentally doing something stupid), I'd avoid doing any kind of eval on data passed in to the script without at least some kind of checking. But, if you're doing some kind of checking anyway, and you end up explicitly checking the input, you might as well explicitly spell out witch methods you want to call. You could set up a hash with 'known good' methods, thus documenting everything that you want callable and protecting yourself at the same time.
my %routines = (
Module => {
Routine1 => \&Module::Method,
Routine2 => \&Module::Method2,
},
Module2 => {
# and so on
},
);
my $module = shift #ARGV;
my $routine = shift #ARGV;
if (defined $module
&& defined $routine
&& exists $routines{$module} # use `exists` to prevent
&& exists $routines{$module}{$routine}) # unnecessary autovivication
{
$routines{$module}{$routine}->(#ARGV); # with remaining command line args
}
else { } # error handling
As a neat side effect of this method, you can simply iterate through the methods available for any kind of help output:
print "Available commands:\n";
foreach my $module (keys %routines)
{
foreach my $routine (keys %$module)
{
print "$module::$routine\n";
}
}
As per Leon's, if the perl module doesn't export it, you can call it like so
perl -MMyModule -e 'MyModule::doit()'
provided that the sub is in that package.
If it exports the sub all the time (in #EXPORT), then Leon's will work:
perl -MMyModule -e doit
If it is an optional export (in #EXPORT_OK), then you can do it like this.
perl -MMyModule=doit -e doit
But the first will work in any case where the sub is defined to the package, and I'd probably use that one over the last one.
Always start your Perl like this:
use strict;
use warnings 'all';
Then do this:
no strict 'refs';
my ($class, $method) = #_;
(my $file = "$class.pm") =~ s/::/\//g;
require $file;
&{"$class\::$method"}();
Whatever you do, try not to eval "$string" ever.
Well, for your revised question, you can do this:
use strict;
use warnings;
{
no strict;
use Symbol qw<qualify>;
my $symb = qualify( $ARGV[1], $ARGV[0] );
unless ( defined &{$symb} ) {
die "&$ARGV[1] not defined to package $ARGV[0]\::";
}
&{$symb};
}
And because you're specifying it on the command line, the easiest way to include from the command line is the -M flag.
perl -MMyModule try.pl MyModule a_subroutine_which_does_something_cool
But you can always
eval "use $ARGV[0];";
But that's highly susceptible to injection:
perl try.pl "Carp; `do something disastrous`;" no_op
I'd use UNIVERSAL::require. It allows you to require or use a module from a variable. So your code would change to something like this:
use UNIVERSAL::require;
$ARGV[0]->use or die $UNIVERSAL::require::ERROR;
$ARGV[0]::$ARGV[1]();
Disclaimer: I did not test that code and I agree Robert P's comment about there probably being a better solution than passing these as command line arguments.