I am trying to print caller function in Perl. Its displaying as per the expectation.
Below is the code:
#!/usr/bin/perl
use strict; use warnings;
my $a = 5;
my $b = fun1($a);
print "a:$a ** b:$b\n";
sub fun1 {
my $r = shift;
my $s = fun2($r);
return $s;
}
sub fun2 {
my $p = shift;
print "the calling function is:", (caller 1)[3], "\n";
print "and you're in:", (caller 0)[3], "\n";
my $q = $p * 5;
return $q;
}
Output:
the calling function is:main::fun1
and you're in:main::fun2
a:5 ** b:25
How can I print only fun1 and fun2 instead of main::fun1 and main::fun2 respectively.
If there is a way to print them according to I stated above its good. Or I would have to trim the result :(
You can use the following:
my $name = $full_name =~ s/^.*:://sr;
Related
I am trying to write a subroutine to demonstrate getting a subroutine of a number as a function in Perl. I have no idea how to use the #_ operator in perl
#!/usr/bin/perl
use strict ;
use warnings ;
my $number = $ARGV[0] ;
if (not defined $number) {
die " I need a number to multiply" }
sub square {
my $number = shift ;
print "$number\n"
return $number * $number ;
}
my $result = square() ;
print "$result";
Your subroutine expects a number as first argument. You access the argument when you do :
my $number = shift;
Which is actually roughly equivalent to :
my ($number) = #_;
So as you can see, #_ is a special variable that represents the list of arguments that were passed to the subroutine.
The problem in your code is that you do not pass any argument to your sub. This :
my $result = square();
Should be written as :
my $result = square($number);
You are not passing $number to your sub. Try this:
#!/usr/bin/perl
use strict ;
use warnings ;
my $number = $ARGV[0] ;
die "I need a number to multiply" unless(defined $number);
sub square {
my $number = shift ;
print "$number\n";
return $number * $number;
}
my $result = square($number);
print "$result\n";
use strict;
sub main {
print shift;
nested(#_);
}
sub nested {
print shift;
deep(#_);
}
sub deep {
print shift;
}
my #list = qw(main nested deep);
main(#list);
How to get this "stair-step" output:
>main
>>nested
>>>deep
Note functions main, nested and deep - required and may be call over and over in different variations
I'd generally pass around an indentation string, along these lines:
use strict;
sub main {
my ($strings, $indent) = #_;
$indent = "" unless defined $indent;
print $indent, shift(#$strings), "\n";
nested($strings, $indent."\t");
}
sub nested {
my ($strings, $indent) = #_;
$indent = "" unless defined $indent;
print $indent, shift(#$strings), "\n";
deep($strings, $indent."\t");
}
sub deep {
my ($strings, $indent) = #_;
$indent = "" unless defined $indent;
print $indent, shift(#$strings), "\n";
}
my #list = qw(main nested deep);
main(\#list);
A similar technique is to pass around an indent level as an integer, incrementing it as needed:
use strict;
sub main {
my ($strings, $indent) = #_;
$indent = 0 unless defined $indent;
print "\t" x $indent, shift(#$strings), "\n";
nested($strings, $indent+1);
}
sub nested {
my ($strings, $indent) = #_;
$indent = 0 unless defined $indent;
print "\t" x $indent, shift(#$strings), "\n";
deep($strings, $indent+1);
}
sub deep {
my ($strings, $indent) = #_;
$indent = 0 unless defined $indent;
print "\t" x $indent, shift(#$strings), "\n";
}
my #list = qw(main nested deep);
main(\#list);
It looks like your array is a list of subroutine names that you want to be called in order. To do that you need to disable strict 'refs' temporarily. This example demonstrates.
Note that the code for all three subroutines is identical. Presumably you will want to put something between the print trace output and the call to the next subroutine in the list the differentiates the three blocks of code.
I have written it so that the number of preceding angle brackets is passed as the second parameter to the subroutines, and defaults to 1 if no value was passed (for the initial call of the sequence).
use strict;
use warnings;
my #list = qw(main nested main deep nested);
main(\#list);
sub main {
my ($list, $indent) = (#_, 1);
my $name = shift #$list;
print '>' x $indent, $name, "\n";
no strict 'refs';
&{$list->[0]}($list, $indent + 1) if #$list;
}
sub nested {
my ($list, $indent) = (#_, 1);
my $name = shift #$list;
print '>' x $indent, $name, "\n";
no strict 'refs';
&{$list->[0]}($list, $indent + 1) if #$list;
}
sub deep {
my ($list, $indent) = (#_, 1);
my $name = shift #$list;
print '>' x $indent, $name, "\n";
no strict 'refs';
&{$list->[0]}($list, $indent + 1) if #$list;
}
output
>main
>>nested
>>>main
>>>>deep
>>>>>nested
Here's a way to maintain the indent level in it's own state:
sub decorator {
my $string = +shift;
my $level = 0;
return sub { $string x ++$level }
}
my $steps = decorator( '>' ); # Each time $steps->() is called
# the indent level increases
print $steps->(), $_, "\n" for qw( main deep nested );
I have a higher order function that maps even position values in an array:
sub map_even(&#) {
my $block = shift;
my #res;
for $i (0..$#_) {
push #res, $i%2 ? $_[$i] : &$block($_[$i]);
}
#res;
}
print map_even {$_*$_} 1,2,3,4;
I am expecting the output to be 14316, but the actual output is
0204
Why does this happen and how can I fix this? And is there any improvement can be done to the code?
In your anonymous function you have to access first input argument via $_[0] (hint: #_ array).
use strict;
use warnings;
sub map_even(&#) {
my $block = shift;
my #res;
for my $i (0..$#_) {
push #res, $i%2 ? $block->($_[$i]) : $_[$i];
}
#res;
}
print join ",", map_even {$_[0]*$_[0]} 1,2,3,4;
output
1,4,3,16
Using $_,
sub map_even(&#) {
my $block = shift;
my #res;
for my $i (0..$#_) {
push #res, $i%2 ? $block->() : $_ for $_[$i];
# or
# local $_ = $_[$i];
# push #res, $i%2 ? $block->() : $_;
}
#res;
}
print join ",", map_even {$_*$_} 1,2,3,4;
In your map_even block, you use the special $_ variable. However, you have to set it inside your loop:
local $_ = $_[$i];
... $block->();
The $_ is a global variable and can be temporarily overridden with the local operator. The $_ has nothing to do with subroutine arguments.
About aliasing: Perls for, map and grep mostly alias $_ to the current element as a performance hack, not because this behavior would be particularly desirable. In order to perform an alias, you should localize the whole *_ typeglob which contains the $_ variable and then assign a scalar reference of the alias target to the glob:
local *_ = \$_[$i];
I would solve this one of two ways.
First, by using List::Utils's pairmap:
use strict;
use warnings;
use List::Util qw(pairmap);
my #x = (1 .. 4);
my #result = pairmap {$a, $b**2} #x;
print "#result\n";
Or more simply, by just using the indexes:
use strict;
use warnings;
my #x = (1 .. 4);
my #result = map {$_ % 2 ? $x[$_] ** 2 : $x[$_]} (0..$#x);
print "#result\n";
However, if you really wanted a new sub, I'd just setup a flip-flop:
use strict;
use warnings;
sub map_even(&#) {
my $block = shift;
my $even = 1;
map {($even ^= 1) ? $block->() : $_} #_;
}
print join " ", map_even {$_*$_} 1,2,3,4;
All output:
1 4 3 16
I have written the following code for passing arguments to eval function in sample.pl and calling the function in another Perl file sample1.pl.
sample1.pl:
use strict;
use warnings;
require 'sample.pl';
use subs "hello";
my $main2 = hello();
sub hello
{
print "Hello World!\n";
our $a=10;
our $b=20;
my $str="sample.pl";
my $xc=eval "sub{$str($a,$b)}";
}
Sample.pl
use strict;
use warnings;
our $a;
our $b;
use subs "hello_world";
my $sdf=hello_world();
sub hello_world($a,$b)
{
print "Hello World!\n";
our $c=$a+$b;
print "This is the called function from sample !\n";
print "C: " .$c;
} 1;
I am getting output as:
Illegal character in prototype for main::hello_world : $a,$b at D:/workspace/SamplePerl_project/sample.pl line 6.
Use of uninitialized value $b in addition (+) at D:/workspace/SamplePerl_project/sample.pl line 9.
Use of uninitialized value $a in addition (+) at D:/workspace/SamplePerl_project/sample.pl line 9.
Hello World!
This is the called function from sample !
C: 0Hello World!
can u guys show me a solution for this how to call a function through eval by passing arguments
how to call a function through eval by passing arguments?
sub func {
print join(", ", #_), "\n";
return 99;
}
my ($str, $a, $b) = ('func', 10, 'tester');
my $f = eval "\\&$str" or die $#;
my $c = $f->($a, $b);
print "c = $c\n";
But there's need to use eval. The above can be written as
my $f = \&$str;
my $c = $f->($a, $b);
or even
my $c = (\&$str)->($a, $b);
Try this This will help u..
my $action="your function name";
if ($action) {
eval "&$action($a,$b)";
}
in Receiving function
sub your function name {
my ($a,$b) =#_;#these are the arguments
}
Given a typeglob, how can I find which types are actually defined?
In my application, we user PERL as a simple configuration format.
I'd like to require() the user config file, then be able to see which variables are defined, as well as what types they are.
Code: (questionable quality advisory)
#!/usr/bin/env perl
use strict;
use warnings;
my %before = %main::;
require "/path/to/my.config";
my %after = %main::;
foreach my $key (sort keys %after) {
next if exists $before{$symbol};
local *myglob = $after{$symbol};
#the SCALAR glob is always defined, so we check the value instead
if ( defined ${ *myglob{SCALAR} } ) {
my $val = ${ *myglob{SCALAR} };
print "\$$symbol = '".$val."'\n" ;
}
if ( defined *myglob{ARRAY} ) {
my #val = #{ *myglob{ARRAY} };
print "\#$symbol = ( '". join("', '", #val) . "' )\n" ;
}
if ( defined *myglob{HASH} ) {
my %val = %{ *myglob{HASH} };
print "\%$symbol = ( ";
while( my ($key, $val) = each %val ) {
print "$key=>'$val', ";
}
print ")\n" ;
}
}
my.config:
#A = ( a, b, c );
%B = ( b=>'bee' );
$C = 'see';
output:
#A = ( 'a', 'b', 'c' )
%B = ( b=>'bee', )
$C = 'see'
$_<my.config = 'my.config'
In the fully general case, you can't do what you want thanks to the following excerpt from perlref:
*foo{THING} returns undef if that particular THING hasn't been used yet, except in the case of scalars. *foo{SCALAR} returns a reference to an anonymous scalar if $foo hasn't been used yet. This might change in a future release.
But if you're willing to accept the restriction that any scalar must have a defined value to be detected, then you might use code such as
#! /usr/bin/perl
use strict;
use warnings;
open my $fh, "<", \$_; # get DynaLoader out of the way
my %before = %main::;
require "my.config";
my %after = %main::;
foreach my $name (sort keys %after) {
unless (exists $before{$name}) {
no strict 'refs';
my $glob = $after{$name};
print "\$$name\n" if defined ${ *{$glob}{SCALAR} };
print "\#$name\n" if defined *{$glob}{ARRAY};
print "%$name\n" if defined *{$glob}{HASH};
print "&$name\n" if defined *{$glob}{CODE};
print "$name (format)\n" if defined *{$glob}{FORMAT};
print "$name (filehandle)\n" if defined *{$glob}{IO};
}
}
will get you there.
With my.config of
$JACKPOT = 3_756_788;
$YOU_CANT_SEE_ME = undef;
#OPTIONS = qw/ apple cherries bar orange lemon /;
%CREDITS = (1 => 1, 5 => 6, 10 => 15);
sub is_jackpot {
local $" = ""; # " fix Stack Overflow highlighting
"#_[0,1,2]" eq "barbarbar";
}
open FH, "<", \$JACKPOT;
format WinMessage =
You win!
.
the output is
%CREDITS
FH (filehandle)
$JACKPOT
#OPTIONS
WinMessage (format)
&is_jackpot
Printing the names takes a little work, but we can use the Data::Dumper module to take part of the burden. The front matter is similar:
#! /usr/bin/perl
use warnings;
use strict;
use Data::Dumper;
sub _dump {
my($ref) = #_;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Terse = 1;
scalar Dumper $ref;
}
open my $fh, "<", \$_; # get DynaLoader out of the way
my %before = %main::;
require "my.config";
my %after = %main::;
We need to dump the various slots slightly differently and in each case remove the trappings of references:
my %dump = (
SCALAR => sub {
my($ref,$name) = #_;
return unless defined $$ref;
"\$$name = " . substr _dump($ref), 1;
},
ARRAY => sub {
my($ref,$name) = #_;
return unless defined $ref;
for ("\#$name = " . _dump $ref) {
s/= \[/= (/;
s/\]$/)/;
return $_;
}
},
HASH => sub {
my($ref,$name) = #_;
return unless defined $ref;
for ("%$name = " . _dump $ref) {
s/= \{/= (/;
s/\}$/)/;
return $_;
}
},
);
Finally, we loop over the set-difference between %before and %after:
foreach my $name (sort keys %after) {
unless (exists $before{$name}) {
no strict 'refs';
my $glob = $after{$name};
foreach my $slot (keys %dump) {
my $var = $dump{$slot}(*{$glob}{$slot},$name);
print $var, "\n" if defined $var;
}
}
}
Using the my.config from your question, the output is
$ ./prog.pl
#A = ('a','b','c')
%B = ('b' => 'bee')
$C = 'see'
Working code using a CPAN module that gets some of the hair out of the way, Package::Stash. As noted in my comment to gbacon's answer, this is blind to the config file doing $someval = undef but that seems to be unavoidable, and at least the other cases are caught. It also limits itself to the SCALAR, ARRAY, HASH, CODE, and IO types -- getting GLOB and FORMAT is possible but it makes the code less pretty and also creates noise in the output :)
#!perl
use strict;
use warnings;
use Package::Stash;
sub all_vars_in {
my ($package) = #_;
my #ret;
my $stash = Package::Stash->new($package);
for my $sym ($stash->list_all_package_symbols) {
for my $sigil (qw($ # % &), '') {
my $fullsym = "$sigil$sym";
push #ret, $fullsym if $stash->has_package_symbol($fullsym);
}
}
#ret;
}
my %before;
$before{$_} ++ for all_vars_in('main');
require "my.config";
for my $var (all_vars_in('main')) {
print "$var\n" unless exists $before{$var};
}
Beginning in 5.010, you can distinguish whether a SCALAR exists using the B introspection module; see Detecting declared package variables in perl
Update: example copied from that answer:
# package main;
our $f;
sub f {}
sub g {}
use B;
use 5.010;
if ( ${ B::svref_2object(\*f)->SV } ) {
say "f: Thar be a scalar tharrr!";
}
if ( ${ B::svref_2object(\*g)->SV } ) {
say "g: Thar be a scalar tharrr!";
}
1;
UPDATE:
gbacon is right. *glob{SCALAR} is defined.
Here is the output I get using your code:
Name "main::glob" used only once:
possible typo at
test_glob_foo_thing.pl line 13.
'FOO1' (SCALAR)
'FOO1' (GLOB)
'FOO2' (SCALAR)
'FOO2' (GLOB)
'_<my.config' (SCALAR)
'_<my.config' (GLOB)
This is despite FOO2 being defined as a hash, but not as a scalar.
ORIGINAL ANSWER:
If I understand you correctly, you simply need to use the defined built-in.
#!/usr/bin/env perl
use strict;
use warnings;
my %before = %main::;
require "/path/to/my.config";
my %after = %main::;
foreach my $key (sort keys %after) {
if (not exists $before{$key}) {
if(defined($after{$key}){
my $val = $after{$key};
my $what = ref($val);
print "'$key' ($what)\n";
}
}
}
I hate to ask, but instead of messing around with typeglobs, why not switch to a real configuration format? e.g. check out Config::Simple and YAML.
I wouldn't recommend messing around with typeglobs and symbol tables in normal cases (some CPAN modules do that, but only at the bottom levels of large systems - e.g. Moose in the lowest levels of Class::MOP). Perl gives you a lot of rope to work with, but that rope is also quite happy to self-noosify and self-tie-around-your-neck if you're not careful :)
See also: How do you manage configuration files in Perl?
no strict 'refs';
my $func_name = 'myfunc';
*{$func_name}{CODE}()
use strict 'refs';
If you don't mind parsing Data::Dump output, you could use it to tease out the differences.
use strict;
use warnings;
use Data::Dump qw{ dump };
my %before = %main::;
require "my.config";
my %after = %main::;
foreach my $key ( sort keys %after ) {
if ( not exists $before{$key} ) {
my $glob = $after{$key};
print "'$key' " . dump( $glob) . "\n";
}
}
Using this code with the following config file:
$FOO1 = 3;
$FOO2 = 'my_scalar';
%FOO2 = ( a=>'b', c=>'d' );
#FOO3 = ( 1 .. 5);
$FOO4 = [ 1 .. 5 ];
I believe that this output provides enough information to be able to figure out which parts of each type glob are defined:
'FOO1' do {
my $a = *main::FOO1;
$a = \3;
$a;
}
'FOO2' do {
my $a = *main::FOO2;
$a = \"my_scalar";
$a = { a => "b", c => "d" };
$a;
}
'FOO3' do {
my $a = *main::FOO3;
$a = [1 .. 5];
$a;
}
'FOO4' do {
my $a = *main::FOO4;
$a = \[1 .. 5];
$a;
}
'_<my.config' do {
my $a = *main::_<my.config;
$a = \"my.config";
$a;
}