For example:
#!/usr/bin/perl
my #arr = ('/usr/test/test.*.con');
my $result = FileExists(\#arr);
print $result;
sub FileExists {
my $param = shift;
foreach my $file (#{$param}) {
print $file;
if (-e $file) {
return 1;
}
}
return 0;
}
It returns 0. But I want to find all wild characters too... How can I solve this?
-e can't handle file globs. Change this line
my #arr = ('/usr/test/test.*.con');
to
my #arr = glob('/usr/test/test.*.con');
To expand the glob pattern first and then check the matched files for existence. However, since glob will only return existing files matching the pattern, all the files will exist anyway.
If you want to handle glob patterns, use the glob operator to expand them. Then test all the paths, store the results in a hash, and return the hash.
sub FileExists {
my #param = map glob($_) => #{ shift #_ };
my %exists;
foreach my $file (#param) {
print $file, "\n";
$exists{$file} = -e $file;
}
wantarray ? %exists : \%exists;
}
Then say you use it as in
use Data::Dumper;
my #arr = ('/tmp/test/test.*.con', '/usr/bin/a.txt');
my $result = FileExists(\#arr);
$Data::Dumper::Indent = $Data::Dumper::Terse = 1;
print Dumper $result;
Sample run:
$ ls /tmp/test
test.1.con test.2.con test.3.con
$ ./prog.pl
/tmp/test/test.1.con
/tmp/test/test.2.con
/tmp/test/test.3.con
/usr/bin/a.txt
{
'/tmp/test/test.3.con' => 1,
'/tmp/test/test.1.con' => 1,
'/usr/bin/a.txt' => undef,
'/tmp/test/test.2.con' => 1
}
You need to use glob() to get the file list.
Also, I'm not sure why you are passing the array as a reference, when subroutines take an array by default. You could much more easily write it like this:
my #arr = (...);
my $result = FileExists(#arr);
sub FileExists {
foreach my $file (#_) {
...
}
return 0;
}
Using glob() you would have the shell expansion, and files using shell wildcards can be retrieved, as the others have pointed out.
And just in case you find it useful, a bit more concise function for 'all_files_exist' could be
sub all_files_exist {
# returns 1 if all files exist and 0 if the number of missing files (!-e)
# captured with grep is > 0.
# This method expect an array_ref as first and only argument
my $files=shift;
return (grep {!-e $_} #$files)>0? 0 : 1;
}
sub non_existing_files {
# or you can capture which ones fail, and print with
# print join("\n", #(non_existing_files($files)))
my $files = shift;
return [grep {!-e $_} #$files]
}
Related
I would like to use
myscript.pl targetfolder/* > result.csv
to grep some number from multiple ASCII files.
The data table is like
| 44.2 | 3123.7 | 3123 |
+--------+--------+--------+
--> this is the end of data table is like
myscript.pl
#!/usr/bin/env perl
use warnings;
use strict;
use Data::Dumper; # for debugging
$Data::Dumper::Useqq=1;
#####start######
Title1();
Title2();
print "\n";
#####Grep#######
foreach my $currentfile (#ARGV) { # ARGV is the target files list
print Dumper($currentfile); # debug
open my $filehanlder, '<', $currentfile or die "$currentfile: $!";
while ($r <= $#fswf) { #judge end of the open file
Value1();
Value2();
Print1();
Print2();
print "\n";
$r++;
} #go next line output
Close $filehanlder;
}
#####sub#######
sub Title1 {
print "title1,title2";
}
sub Title2{
print "title5,title6,title7,title8";
}
sub Value1 {
my ($line);
while ($line = <$filehanlder>)) {
if ($line =~ /^\|\sMachine\:(\S+)\s+Release\:(\S+)\s+/) {
our ($machine) = $1;our ($sw) = $2;
}
}
}
sub Value2 {
my ($line);
while ($line = <$filehanlder>)) {
if ($line =~ /^\|\sProduction\sResult\s+\|\s(\S+)\s+\|/) {
next if 1..4;
my (#b) = "";
$r = 1
#result1 = #result2 = #result3 = #result4 = "";
while ($line !~ /\+\-/) {
chomp $line;
#b = split / *\| */, $line;
our ($result1[$r]) = $b[1];
our ($result2[$r]) = $b[2];
our ($result3[$r]) = $b[3];
our ($result4[$r]) = $b[4];
$r++;
$line = (<$filehanlder>);
#b = "";
}
}
}
}
##I need a value as file counter, but not sure where to put it.
Sub Print1 {
print "$machine,$sw,"; # this keeps same cross lines from same file
}
Sub Print2 {
print "$result1[$r],$result2[$r],$result3[$r],$result4[$r],"; # change every line
}
#####sub#######
I don't know is this correct way to pass the $filehander to the subroutine and pass it throught different subroutine.
#Dave Cross: Thanks for pointing out. Exactly as you said. If I do loop in the subroutine, then one subroutine will go to the end of file, other subroutine get nothing. So shall I do while loop in the main ? Or shall I do open in every subroutines? so I can reset the filehandler to the 1st line of the file in every subroutine. If I have multiple #result as I grep in the sub values2 , how I can print them with the max lines number of these #result. For example, I have #result5[7] ,#result6[12], so I would like to print 12 lines record, the first 7 lines with result5 grep result, the last 5 line ,result5 column keeps empty and result6 column continue printout.
Your filehandle is just stored in a scalar variable ($filehanlder) so it can be passed into a subroutine in exactly the same way as any other variable.
some_subroutine($filehanlder);
And, inside the subroutine:
sub some_subroutine {
my ($fh) = #_;
# do something with $fh
}
But I think you have more serious problems to worry about. You have two subroutines that have a while (<$filehanlder>) loop in them. The first of those to be called, will go to the end of the file, leaving the second with no data to process.
You probably want to rethink the design of this code.
I wrote the following subroutine:
sub MakeNan {
my $n = $_;
if ( $n !~ /^Positive|^Negative/ ) {
return "N/A";
}
else { return "$n"; }
}
I have been calling it in the following context:
open ( FILE, $file);
while (<FILE>) {
chomp;
my #a = split("\t", $_);
my $hr = $a[55];
$hr = &MakeNan($hr);
print "$hr\n";
}
close FILE;
Unfortunately, it returns "N/A" for every value it is given despite the fact that there are many instances of values that should return either "Positive..." or "Negative..."
I don't understand what I am doing wrong to make the subroutine return "N/A" each time.
There are several mistakes. $n doesn't contain your argument because the default variable is not your argument. Your regex is wrong. Do this instead:
sub make_nan {
my ($n) = #_; # or: my $n = shift;
return $n =~ /^(Positive|Negative)/ ? $n : 'N/A';
}
And drop the & when calling your function.
But then, you don't need a subroutine since all you need is a ternary operator.
Since items passed into a subroutine are passed thru #_, your first line in sub MakeNan should be:
my $n = $_[0];
Or, since there is more than one way to do it, you could also make a scalar reference in the first line of the subroutine to $hr like this.
my $hr_ref = \$hr;
My task is:
Read the directory, type of sorting, and order of sorting from command line.
Sort the file names and print them out with size and date.
Here is what I got so far.
#!/usr/bin/perl
use 5.010;
use strict;
use warnings;
use Getopt::Long;
my $dir = "";
my $sortby = "";
my $order = "";
my $result;
$result = GetOptions (
'dir=s' => \$dir, # specify derictory
'sortby=s' => \$sortby, # 'name' or 'date'
'order=s' => \$order); # 'asc'- or 'des'-ending order of sorting
print "derictory = $dir, sortby = $sortby, order = $order \n\n";
opendir (DH, $dir)or die "couldn open dericroty: $!\n";
my #filenames = grep ! /^\./, readdir DH;
closedir (DH);
if ($sortby eq "name") {
if ($order eq "asc") {
foreach my $name (sort {lc $a cmp lc $b} #filenames) {
my #statinfo = stat("$dir/$name");
print "$name\tsize= " . $statinfo[7] . ",\t last modified=" .
scalar(localtime($statinfo[9])) . "\n";
}
}
elsif ($order eq "des") {
foreach my $name (sort {lc $b cmp lc $a} #filenames) {
my #statinfo = stat("$dir/$name");
print "$name\tsize= " . $statinfo[7] . ",\t last modified=" .
scalar(localtime($statinfo[9])) . "\n";
}
}
}
if ($sortby eq "date") {
if ($order eq "asc") {
#filenames = sort { -M "$dir/$a" <=> -M "$dir/$b" } (#filenames);
print join ("\n", #filenames);
}
elsif ($order eq "des") {
#filenames = sort { -M "$dir/$b" <=> -M "$dir/$a" } (#filenames);
print join ("\n", #filenames);
}
}
The problem is if I need to sort it by date modified, I don't know how to print out the list of the file names with the size and date. I guess I am supposed to use the stat function, but I can't loop through names, and get each stat.
All I have above is basically what I was able to google and put together.
Here's a different way to think about the problem. The essential points:
Write small functions that do simple things, and build your program
by assembling those functions together.
If you collect all of your information in a convenient data
structure (in this example, a list of hashes), the algorithmic/logical
aspects of the program become easy and natural.
For simplicity, this example ignore option-parsing and instead just accepts the params as regular command line arguments.
use strict;
use warnings;
main();
sub main {
my ($dir, $sortby, $order) = #ARGV;
my #contents = read_dir($dir);
my $sb = $sortby eq 'date' ? 'mtime' : 'path';
my #sorted = sort { $a->{$sb} cmp $b->{$sb} } #contents;
#sorted = reverse(#sorted) if $order eq 'des';
for my $fi (#sorted){
print $fi->{path}, ' : ', $fi->{mtime}, "\n";
}
}
sub read_dir {
# Takes a dir path.
# Returns a list of file_info() hash refs.
my $d = shift;
opendir(my $dh, $d) or die $!;
return map { file_info($_) } # Collect info.
map { "$d/$_" } # Attach dir path.
grep { ! /^\.\.?$/ } # No dot dirs.
readdir($dh);
}
sub file_info {
# Takes a path to a file/dir.
# Returns hash ref containing the path plus any stat() info you need.
my $f = shift;
my #s = stat($f);
return {
path => $f,
mtime => $s[9],
};
}
If you are going to sort by certain properties of your data, you may want to take a look at the Schwartzian Transform. This is a basic example of how you might use it to sort by modified time:
use strict;
use warnings;
use constant MTIME_STAT_INDEX => 9;
use constant FILENAME_INDEX => 0;
use constant MTIME_INDEX => 1;
# Grab a list of files in the current folder
my $some_dir = '.';
opendir(my $dh, $some_dir) || die "can't opendir $some_dir: $!";
my #fileNames = readdir $dh;
closedir $dh;
# Use a Schwartzian transform to generate a sorted list of <file_name, mtime> tuples
my #sortedByMtime =
map { $_ }
sort { $a->[MTIME_INDEX] cmp $b->[MTIME_INDEX] }
map { [$_, (stat($_))[MTIME_STAT_INDEX]] } #fileNames;
# Print the file name and mtime
for my $sortedRecord (#sortedByMtime) {
print $sortedRecord->[FILENAME_INDEX] . "\t" . $sortedRecord->[MTIME_INDEX] . "\n";
}
1;
It may help to read the transform outside-in (ie starting at the end and working toward the start). Starting with a list of file names, you use map to produce an array containing entries of the form <file_name, modified_time>. You then sort this list by modified time and can use the final map (ie the first one) to strip out any unwanted properties. In this example, I did not strip anything out, but I hope you get the idea that you could in theory have other properties in this built up structure, such as file size, for instance.
This is intended to just get you started as a proof of concept – I did not take much consideration for efficiency, error handling, or making the output pretty.
You should look at File::stat. This module (which comes with Subversion allows you to easily access all sorts of information about the file.
You should also look at Time::Piece. This module allows you to easily format your date and time.
I would also not worry about having four separate sorting routines. Instead, just sort what you need in an array standard ascending order. Then, before you print out, see if the user requested descending order. If the user did request descending order, you can use the reverse to reverse your sorted array.
I am using References. The array I am storing my file names contains not a string, but a reference to a hash. This way, each entry in my array contains four separate bits of information about my file.
I am also use Pod::Usage to print out messages based upon my POD documentation. POD is a rather simple format for storing documentation about your program. Users can use the perldoc command to display the pod:
$ perldoc prog.pl
Or, they can use commands such as pod2html to convert the documentation into HTML. These various Perldoc and POD commands come with your Perl distribution. I highly recommend that you learn POD and use it extensively. It keeps your program documentation in your program and allows you to produce all sorts of formats for your documentation. (Text, HTML, manpage, markdown, wiki, etc.).
#! /usr/bin/env perl
#
use strict;
use warnings;
use feature qw(say);
use autodie;
# All of these are standard Perl module and come with all distributions
# or Perl
use Time::Piece;
use File::stat;
use Getopt::Long;
use Pod::Usage;
use File::Basename;
my ( $directory, $sort_order, $sort_descending, $help );
#
# Using pod2usage to print out my messages
#
GetOptions (
"directory=s" => \$directory,
"sort=s" => \$sort_order,
"descending" => \$sort_descending,
"help" => \$help,
) or pod2usage;
if ( $help ) {
pod2usage ( -message => qq(Use command 'perldoc print_dir.pl' for complete documetation) );
}
if ( not ( defined $directory and defined $sort_order ) ) {
pod2usage ( -message => qq(Must use parameters "directory" and "sort") );
}
if ( $sort_order ne "name" and
$sort_order ne "ctime" and
$sort_order ne "size" and
$sort_order ne "mtime" ) {
die qq(Sort order must be "name", "size", "ctime", or "mtime"\n);
}
opendir ( my $dir_fh, $directory ); #Will autodie here if directory doesn't exist
my #files;
while ( my $file = readdir $dir_fh ) {
$file = "$directory/$file";
next if not -f $file;
#
# Note I'm using File::stat to get the info on the files
#
my $stat = stat $file or die qq(Couldn't stat file "$file"\n);
my %file;
$file{NAME} = basename $file;
$file{CTIME} = $stat->ctime;
$file{MTIME} = $stat->mtime;
$file{SIZE} = $stat->size;
#
# I'm storing this information in a hash and pushing a Hash Reference
#
push #files, \%file; #Pushing a reference to the hash
}
closedir $dir_fh;
my #sorted_files = sort file_sort #files;
#
# I am using the fact that my hash keys and my sort options
# are very similar. One routine sorts all which ways
#
sub file_sort {
my $sort_by = uc $sort_order;
if ( $sort_order eq "name" ) {
return $a->{$sort_by} cmp $b->{$sort_by};
} else {
return $a->{$sort_by} <=> $b->{$sort_by};
}
}
#
# If the user wants descending order, reverse the array
#
if ( $sort_descending ) {
#sorted_files = reverse #sorted_files;
}
#
# I'm using 'printf' to print out a nice report.
# My $format is the format of the report, and I
# can use it for the title or the body.
#
my $format = "%-20.20s %-10d %-11.11s %-11.11s\n";
( my $title_format = $format ) =~ s/d/s/;
printf $title_format, "Name", "Sixe", "Mod-Time", "C-Time";
say join " ", "=" x 20, "=" x 10, "=" x 11, "=" x 11;
for my $file ( #sorted_files ) {
#
# The "->" dereferences the hash
# Note how I use Time::Piece to format my time
#
my $mtime = Time::Piece->new ( $file->{MTIME} );
my $ctime = Time::Piece->new ( $file->{CTIME} );
printf $format, $file->{NAME}, $file->{SIZE}, $mtime->ymd, $ctime->ymd;
}
#
# Here be the Plain Old Documention (POD) This is the standard
# way to document Perl programs. You can use the "perldoc" program
# to print it out, and pod2usage to print out bits and pieces.
#
=pod
=head1 NAME
print_dir.pl
=head1 SYNOPSIS
print_dir.pl -sort [name|size|mtime|ctime] -directory $directory [ -descending ]
=head1 DESCRIPTION
This program does somee amazing wonderful stuff...
=head1 OPTIONS
=over 4
=item *
-sort
(Required) Sort order of directory parameters can be C<name>, C<size>, C<mtime>, C<ctime>
=item *
-directory
(Required) Name of the directory to print
=item *
-descending
(Optional) Sort in descending order instead of ascending order
=back
=cut
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;
}
Is there a way I can access (for printout) a list of sub + module to arbitrary depth of sub-calls preceding a current position in a Perl script?
I need to make changes to some Perl modules (.pm's). The workflow is initiated from a web-page thru a cgi-script, passing input through several modules/objects ending in the module where I need to use the data. Somewhere along the line the data got changed and I need to find out where.
You can use Devel::StackTrace.
use Devel::StackTrace;
my $trace = Devel::StackTrace->new;
print $trace->as_string; # like carp
It behaves like Carp's trace, but you can get more control over the frames.
The one problem is that references are stringified and if a referenced value changes, you won't see it. However, you could whip up some stuff with PadWalker to print out the full data (it would be huge, though).
This code works without any additional modules.
Just include it where needed.
my $i = 1;
print STDERR "Stack Trace:\n";
while ( (my #call_details = (caller($i++))) ){
print STDERR $call_details[1].":".$call_details[2]." in function ".$call_details[3]."\n";
}
Carp::longmess will do what you want, and it's standard.
use Carp qw<longmess>;
use Data::Dumper;
sub A { &B; }
sub B { &C; }
sub C { &D; }
sub D { &E; }
sub E {
# Uncomment below if you want to see the place in E
# local $Carp::CarpLevel = -1;
my $mess = longmess();
print Dumper( $mess );
}
A();
__END__
$VAR1 = ' at - line 14
main::D called at - line 12
main::C called at - line 10
main::B called at - line 8
main::A() called at - line 23
';
I came up with this sub (Now with optional blessin' action!)
my $stack_frame_re = qr{
^ # Beginning of line
\s* # Any number of spaces
( [\w:]+ ) # Package + sub
(?: [(] ( .*? ) [)] )? # Anything between two parens
\s+ # At least one space
called [ ] at # "called" followed by a single space
\s+ ( \S+ ) \s+ # Spaces surrounding at least one non-space character
line [ ] (\d+) # line designation
}x;
sub get_stack {
my #lines = split /\s*\n\s*/, longmess;
shift #lines;
my #frames
= map {
my ( $sub_name, $arg_str, $file, $line ) = /$stack_frame_re/;
my $ref = { sub_name => $sub_name
, args => [ map { s/^'//; s/'$//; $_ }
split /\s*,\s*/, $arg_str
]
, file => $file
, line => $line
};
bless $ref, $_[0] if #_;
$ref
}
#lines
;
return wantarray ? #frames : \#frames;
}
caller can do that, though you may want even more information than that.
There's also Carp::confess and Carp::cluck.
In case you can't use (or would like to avoid) non-core modules, here's a simple subroutine I came up with:
#!/usr/bin/perl
use strict;
use warnings;
sub printstack {
my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash);
my $i = 1;
my #r;
while (#r = caller($i)) {
($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) = #r;
print "$filename:$line $subroutine\n";
$i++;
}
}
sub i {
printstack();
}
sub h {
i;
}
sub g {
h;
}
g;
It produces output like as follows:
/root/_/1.pl:21 main::i
/root/_/1.pl:25 main::h
/root/_/1.pl:28 main::g
Or a oneliner:
for (my $i = 0; my #r = caller($i); $i++) { print "$r[1]:$r[2] $r[3]\n"; }
You can find documentation on caller here.
One that is more pretty: Devel::PrettyTrace
use Devel::PrettyTrace;
bt;
Moving my comment to an answer:
Install Devel::Confess the right way
cpanm Devel::Confess
Run with
perl -d:Confess myscript.pl
On errors, this will show the whole call stack list.