Perl Challenge - Directory Iterator - perl

You sometimes hear it said about Perl that there might be 6 different ways to approach the same problem. Good Perl developers usually have well-reasoned insights for making choices between the various possible methods of implementation.
So an example Perl problem:
A simple script which recursively iterates through a directory structure, looking for files which were modified recently (after a certain date, which would be variable). Save the results to a file.
The question, for Perl developers: What is your best way to accomplish this?

This sounds like a job for File::Find::Rule:
#!/usr/bin/perl
use strict;
use warnings;
use autodie; # Causes built-ins like open to succeed or die.
# You can 'use Fatal qw(open)' if autodie is not installed.
use File::Find::Rule;
use Getopt::Std;
use constant SECONDS_IN_DAY => 24 * 60 * 60;
our %option = (
m => 1, # -m switch: days ago modified, defaults to 1
o => undef, # -o switch: output file, defaults to STDOUT
);
getopts('m:o:', \%option);
# If we haven't been given directories to search, default to the
# current working directory.
if (not #ARGV) {
#ARGV = ( '.' );
}
print STDERR "Finding files changed in the last $option{m} day(s)\n";
# Convert our time in days into a timestamp in seconds from the epoch.
my $last_modified_timestamp = time() - SECONDS_IN_DAY * $option{m};
# Now find all the regular files, which have been modified in the last
# $option{m} days, looking in all the locations specified in
# #ARGV (our remaining command line arguments).
my #files = File::Find::Rule->file()
->mtime(">= $last_modified_timestamp")
->in(#ARGV);
# $out_fh will store the filehandle where we send the file list.
# It defaults to STDOUT.
my $out_fh = \*STDOUT;
if ($option{o}) {
open($out_fh, '>', $option{o});
}
# Print our results.
print {$out_fh} join("\n", #files), "\n";

Where the problem is solved mainly by standard libraries use them.
File::Find in this case works nicely.
There may be many ways to do things in perl, but where a very standard library exists to do something, it should be utilised unless it has problems of it's own.
#!/usr/bin/perl
use strict;
use File::Find();
File::Find::find( {wanted => \&wanted}, ".");
sub wanted {
my (#stat);
my ($time) = time();
my ($days) = 5 * 60 * 60 * 24;
#stat = stat($_);
if (($time - $stat[9]) >= $days) {
print "$_ \n";
}
}

There aren't six ways to do this, there's the old way, and the new way. The old way is with File::Find, and you already have a couple of examples of that. File::Find has a pretty awful callback interface, it was cool 20 years ago, but we've moved on since then.
Here's a real life (lightly amended) program I use to clear out the cruft on one of my production servers. It uses File::Find::Rule, rather than File::Find. File::Find::Rule has a nice declarative interface that reads easily.
Randal Schwartz also wrote File::Finder, as a wrapper over File::Find. It's quite nice but it hasn't really taken off.
#! /usr/bin/perl -w
# delete temp files on agr1
use strict;
use File::Find::Rule;
use File::Path 'rmtree';
for my $file (
File::Find::Rule->new
->mtime( '<' . days_ago(2) )
->name( qr/^CGItemp\d+$/ )
->file()
->in('/tmp'),
File::Find::Rule->new
->mtime( '<' . days_ago(20) )
->name( qr/^listener-\d{4}-\d{2}-\d{2}-\d{4}.log$/ )
->file()
->maxdepth(1)
->in('/usr/oracle/ora81/network/log'),
File::Find::Rule->new
->mtime( '<' . days_ago(10) )
->name( qr/^batch[_-]\d{8}-\d{4}\.run\.txt$/ )
->file()
->maxdepth(1)
->in('/var/log/req'),
File::Find::Rule->new
->mtime( '<' . days_ago(20) )
->or(
File::Find::Rule->name( qr/^remove-\d{8}-\d{6}\.txt$/ ),
File::Find::Rule->name( qr/^insert-tp-\d{8}-\d{4}\.log$/ ),
)
->file()
->maxdepth(1)
->in('/home/agdata/import/logs'),
File::Find::Rule->new
->mtime( '<' . days_ago(90) )
->or(
File::Find::Rule->name( qr/^\d{8}-\d{6}\.txt$/ ),
File::Find::Rule->name( qr/^\d{8}-\d{4}\.report\.txt$/ ),
)
->file()
->maxdepth(1)
->in('/home/agdata/redo/log'),
) {
if (unlink $file) {
print "ok $file\n";
}
else {
print "fail $file: $!\n";
}
}
{
my $now;
sub days_ago {
# days as number of seconds
$now ||= time;
return $now - (86400 * shift);
}
}

File::Find is the right way to solve this problem. There is no use in reimplementing stuff that already exists in other modules, but reimplementing something that is in a standard module should really be discouraged.

Others have mentioned File::Find, which is the way I'd go, but you asked for an iterator, which File::Find isn't (nor is File::Find::Rule). You might want to look at File::Next or File::Find::Object, which do have an iterative interfaces. Mark Jason Dominus goes over building your own in chapter 4.2.2 of Higher Order Perl.

My preferred method is to use the File::Find module as so:
use File::Find;
find (\&checkFile, $directory_to_check_recursively);
sub checkFile()
{
#examine each file in here. Filename is in $_ and you are chdired into it's directory
#directory is also available in $File::Find::dir
}

There's my File::Finder, as already mentioned, but there's also my iterator-as-a-tied-hash solution from Finding Files Incrementally (Linux Magazine).

I wrote File::Find::Closures as a set of closures that you can use with File::Find so you don't have to write your own. There's a couple of mtime functions that should handle
use File::Find;
use File::Find::Closures qw(:all);
my( $wanted, $list_reporter ) = find_by_modified_after( time - 86400 );
#my( $wanted, $list_reporter ) = find_by_modified_before( time - 86400 );
File::Find::find( $wanted, #directories );
my #modified = $list_reporter->();
You don't really need to use the module because I mostly designed it as a way that you could look at the code and steal the parts that you wanted. In this case it's a little trickier because all the subroutines that deal with stat depend on a second subroutine. You'll quickly get the idea from the code though.
Good luck,

Using standard modules is indeed a good idea but out of interest here is my back to basic approach using no external modules. I know code syntax here might not be everyone's cup of tea.
It could be improved to use less memory via providing an iterator access (input list could temporarily be on hold once it reaches a certain size) and conditional check can be expanded via callback ref.
sub mfind {
my %done;
sub find {
my $last_mod = shift;
my $path = shift;
#determine physical link if symlink
$path = readlink($path) || $path;
#return if already processed
return if $done{$path} > 1;
#mark path as processed
$done{$path}++;
#DFS recursion
return grep{$_} #_
? ( find($last_mod, $path), find($last_mod, #_) )
: -d $path
? find($last_mod, glob("$path/*") )
: -f $path && (stat($path))[9] >= $last_mod
? $path : undef;
}
return find(#_);
}
print join "\n", mfind(time - 1 * 86400, "some path");

I write a subroutine that reads a directory with readdir, throws out the "." and ".." directories, recurses if it finds a new directory, and examines the files for what I'm looking for (in your case, you'll want to use utime or stat). By time the recursion is done, every file should have been examined.
I think all the functions you'd need for this script are described briefly here:
http://www.cs.cf.ac.uk/Dave/PERL/node70.html
The semantics of input and output are a fairly trivial exercise which I'll leave to you.

I'm riskying to get downvoted, but IMHO 'ls' (with appropriate params) command does it in a best known performant way. In this case it might be quite good solution to pipe 'ls' from perl code through shell, returning results to an array or hash.
Edit: It could also be 'find' used, as proposed in comments.

Related

How are these quoted strings replaced with the values in perl .pm file?

Below is the Perl code in .pm file which is supposed to replace the specified strings (that are in "quotes") with some values. But its not happening. Can anyone explain what is happening in this code?
package SomePackage;
require Exporter;
#ISA = qw(Exporter);
#EXPORT = qw(send_request, create_mmd_and_transfer, update_mmd_file);
sub send_request {
my ( $service, $action, $torole ) = #_;
my ( $seller_request_mmd );
my $replace_contents = ();
$replace_contents{"REPLACE_Service"} = $service;
$replace_contents{"REPLACE_RequestAction"} = $action;
$replace_contents{"REPLACE_TradingPartner"} = $torole;
$replace_contents{"REPLACE_Requestxml"} = "Request.xml";
create_mmd_and_transfer( \%replace_contents, $seller_request_mmd, "/MMD.xml" );
}
sub create_mmd_and_transfer {
my $local_replace_contents = shift;
my $input_mmd = shift;
my $local_output_mmd = shift;
my $output_mmd = shift;
update_mmd_file( "$input_mmd", "temp_mmd_file.xml", $local_replace_contents );
}
sub update_mmd_file {
my $input_file = shift;
my $output_file = shift;
my $contents = shift;
open( MMD_FILE, "<$input_file" )
or main::error_exit(" Cannot open MMD file template $input_file \n $input_file not found int the Templates folder \n Please place the same and then run the script ");
open( TEMP_MMD_FILE, ">$output_file" );
while ( <MMD_FILE> ) {
s/^M//g; # Getrid of the ^Ms
foreach my $content ( keys( %$contents ) ) {
my $exact_value = ${%$contents}{$content};
if ( $main::test_scenario =~ /^Invalid Request Action \a\n\d Service/
and ( $content =~ /REPLACE_Service|REPLACE_RequestAction/i ) ) {
}
else {
if ( $exact_value ne "" ) {
s/$content/$exact_value/g;
}
}
}
print TEMP_MMD_FILE;
}
close MMD_FILE;
close TEMP_MMD_FILE;
}
The following will not make your script work, just create the better base for some future questions.
Before you even thinking about posting a perl question here:
1.) add to the top of your script:
use strict;
use warnings;
Posting a code here without these two lines, nobody will bother even trying to read the code.
2.) use perl -c SomePackage.pm for the check. If it will tell you: SomePackage.pm syntax OK - you can start thinking about posting a question here. ;)
Some basic problems with your script:
package SomePackage;
use strict; # see the above
use warnings;
require Exporter;
# these variables are defined outside of this package, so, tell perl this fact. use the `our`
our #ISA = qw(Exporter);
#the use warnings will warn you about the following line
# #EXPORT = qw(send_request, create_mmd_and_transfer, update_mmd_file);
#the correct one is without commas
our #EXPORT = qw(send_request create_mmd_and_transfer update_mmd_file); #not saying anything about the #EXPORT rudeness. :)
#my $replace_contents = ();
#the $replace_contents is a scalar. Bellow you using a hash. So,
my %replace_contents;
#or use the scalar but the lines bellow should use the hashref notation, e.g.
# $replace_contents->{"REPLACE_Service"} = $service;
# you decide. :)
# the seller_request_mmd contains undef here.
create_mmd_and_transfer( \%replace_contents, $seller_request_mmd, "/MMD.xml");
# also bellow, in the subroutine definition it wants 4 arguments.
# indicates a problem...
# using 2-arg open is not the best practice.
# Also, you should to use lexical filehandles
# open (MMD_FILE, "<$input_file")
# better
open (my $mmd_file, '<', $input_file)
# of course, you need change every MMD_FILE to $mmd_file
# check the result of the open and die if not successful
# or you can use the
use autodie;
# instead of $exact_value = ${%$contents}{$content};
# you probably want
my $exact_value = $contents->{$content};
Indent your code!
All the above are just about the syntactic problems and not solving anything about the "logic" of your code.
Ps: And me is still an beginner, so, others sure will find much more problems with the above code.
Ok. Here's what I've done to test this.
Firstly, you didn't give us an input file or the code that you use to call the module. So I invented them. I made the simplest possible input file:
REPLACE_Service
REPLACE_RequestAction
REPLACE_TradingPartner
REPLACE_Requestxml
And this driver program:
#!/usr/bin/perl
use strict;
use warnings;
use SomePackage;
send_request('foo', 'bar', 'baz');
sub error_exit {
die #_;
}
The first time, I ran it, I got this error:
Undefined subroutine &main::send_request called at test line 8.
That was because your #EXPORT line was wrong. You had:
#EXPORT = qw(send_request, create_mmd_and_transfer, update_mmd_file);
But the point of qw(...) is that you don't need the commas. So I corrected it to:
#EXPORT = qw(send_request create_mmd_and_transfer update_mmd_file);
Then I re-ran the program and got this error:
Cannot open MMD file template
not found int the Templates folder
Please place the same and then run the script at test line 11.
That looked like there was something missing. I changed the error message, adding indicators of where the variable interpolation was supposed to happen:
open( MMD_FILE, "<$input_file" )
or main::error_exit(" Cannot open MMD file template <$input_file> \n <$input_file> not found int the Templates folder \n Please place the same and then run the script ");
Then the error message looked like this:
Cannot open MMD file template <>
<> not found int the Templates folder
Please place the same and then run the script at test line 11.
So it seems clear that the $input_file variable isn't set in the update_mmd_file() subroutine. Tracing that variable back, we see that this value is originally the $seller_request_mmd variable in send_request(). But in send_request() you declare $seller_request_mmd but you never give it a value. So let's do that:
my ( $seller_request_mmd ) = 'test_input.txt';
Now, when I run your program, it runs to completion without any errors. And I find a new temp_mmd_file.xml is generated. But it is exactly the same as the input file. So more investigation is needed.
Digging into the update_mmd_file() subroutine, we find this interesting line:
my $exact_value = ${%$contents}{$content};
I think you're trying to extract a value from $contents, which is a hash reference. But your syntax is wrong. You were probably aiming at:
my $exact_value = ${$contents}{$content};
But most Perl programmers prefer the arrow notation for working with reference look-ups.
my $exact_value = $contents->{$content};
Making that change and re-running the program, I get an output file that contains:
foo
bar
baz
Request.xml
Which is exactly what I expected. So the program now works.
But there is still a lot of work to do. As you have been told repeatedly, you should always add:
use strict;
use warnings;
to your code. That will find a lot of potential problems in your code - which you should fix.
To be honest, this feels to me like you were trying to run before you could walk. I'd recommend spending some time to work through a good Perl introductory book before taking on my more Perl work.
And there was a lot of useful information missing from your question. It wouldn't have taken as long to get to the solution if you had shown us your driver program and your input data.

Fetching file path from a Perl '.rc' file

So I have a Perl '.rc' file (let's call it 'path.rc' with Perl syntax) which has this line:
$RC{model_root} = '/nfs/fm/disks/fm_fabric_00011/abc_rel//xy/xy-abc1-15aa05e'
I need to fetch the files from directory 'xy-abc1-15aa05e'. I am not supposed to hard code this path in my Perl file (let's call this 'Fetch.pl') as the path may change frequently, so there's a separate .rc file maintained. I'm using:
my $model_root = $RC{model_root};
to link to the path in my Perl code (like a parameter to link to the path in rc file). How do I now open the files in directory 'xy-abc1-15aa05e'? My Perl file is not able to get the path :(
This is breaking the rest of my code... How can I to do this?
If you make your 'rc' file a Perl module like this:
Defs.pm:
package Defs;
our $path = '/nfs/fm/disks/fm_fabric_00011/abc_rel//xy/xy-abc1-15aa05e';
1;
Then you can - in your script:
#Ensure we can 'find' the defs file, by having a library path that's relative to
#the script location.
use FindBin;
use lib $FindBin::Bin;
use Defs;
print $Defs::path, "\n";
If you specifically need to use the format you've listed, then you need to process the contents of the file. One way of doing this is with eval. But I'm not overly keen on doing that unless absolutely necessary.
You could do something like this though:
use Data::Dumper;
open ( my $rcfile, "<", 'rcfile' ) or die $!;
my %RC;
eval <$rcfile>;
print Dumper \%RC;
I dislike using eval in this sort of way though - you need to be quite careful about your inputs, because otherwise odd things might break. (Note - this only works for a one line file - if you have multiple lines, you might need to local $/; to slurp the whole file to eval it).
I would instead be tempted to use a regular expression to parse:
my $model_root;
while ( <$rcfile> ) {
my ( $varname, $value ) = ( m/\A(\S+) = \'(\S+)\'/ );
if ( $varname eq '$RC{model_root}' ) { $model_root = $value; }
}
print $model_root;
foreach my $file ( glob "$model_root/*" ) {
print "Doing something with $file\n";
}

How to make recursive calls using Perl, awk or sed?

If a .cpp or .h file has #includes (e.g. #include "ready.h"), I need to make a text file that has these filenames on it. Since ready.h may have its own #includes, the calls have to be made recursively. Not sure how to do this.
The solution of #OneSolitaryNoob will likely work allright, but has an issue: for each recursion, it starts another process, which is quite wasteful. We can use subroutines to do that more efficiently. Assuming that all header files are in the working directory:
sub collect_recursive_includes {
# Unpack parameter from subroutine
my ($filename, $seen) = #_;
# Open the file to lexically scoped filehandle
# In your script, you'll probably have to transform $filename to correct path
open my $fh, "<", $filename or do {
# On failure: Print a warning, and return. I.e. go on with next include
warn "Can't open $filename: $!";
return;
};
# Loop through each line, recursing as needed
LINE: while(<$fh>) {
if (/^\s*#include\s+"([^"]+)"/) {
my $include = $1;
# you should probably normalize $include before testing if you've seen it
next LINE if $seen->{$include}; # skip seen includes
$seen->{$include} = 1;
collect_recursive_includes($include, $seen);
}
}
}
This subroutine remembers what files it has already seen, and avoids recursing there again—each file is visited one time only.
At the top level, you need to provide a hashref as second argument, that will hold all filenames as keys after the sub has run:
my %seen = ( $start_filename => 1 );
collect_recursive_includes($start_filename, \%seen);
my #files = sort keys %seen;
# output #files, e.g. print "$_\n" for #files;
I hinted in the code comments that you'll probabably have to normalize the filenames. E.g consider a starting filename ./foo/bar/baz.h, which points to qux.h. Then the actual filename we wan't to recurse to is ./foo/bar/qux.h, not ./qux.h. The Cwd module can help you find your current location, and to transform relative to absolute paths. The File::Spec module is a lot more complex, but has good support for platform-independent filename and -path manipulation.
In Perl, recursion is straightforward:
sub factorial
{
my $n = shift;
if($n <= 1)
{ return 1; }
else
{ return $n * factorial($n - 1); }
}
print factorial 7; # prints 7 * 6 * 5 * 4 * 3 * 2 * 1
Offhand, I can think of only two things that require care:
In Perl, variables are global by default, and therefore static by default. Since you don't want one function-call's variables to trample another's, you need to be sure to localize your variables, e.g. by using my.
There are some limitations with prototypes and recursion. If you want to use prototypes (e.g. sub factorial($) instead of just sub factorial), then you need to provide the prototype before the function definition, so that it can be used within the function body. (Alternatively, you can use & when you call the function recursively; that will prevent the prototype from being applied.)
Not totally clear what you want the display to look like, but the basic would be a script called follow_includes.pl:
#!/usr/bin/perl -w
while(<>) {
if(/\#include "(\S+)\"/) {
print STDOUT $1 . "\n";
system("./follow_includes.pl $1");
}
}
Run it like:
% follow_includes.pl somefile.cpp
And if you want to hide any duplicate includes, run it like:
% follow_includes.pl somefile.cpp | sort -u
Usually you'd want this in some sort of tree-print.

Simple Perl Script: Two questions

I have a small program:
#!/user/bin/perl
use strict;
system ("clear");
my($option, $path);
do
{
print "\tEnter the number of your chosen option:\n";
print "\n";
print "\tOption\t\tCommand\n";
print "\t======\t\t=======\n";
print "\t1\t\tDate\n";
print "\t2\t\tDirectory Listing\n";
print "\t3\t\tCalendar\n";
print "\t4\t\tVi Editor\n";
print "\t5\t\tCalculator\n";
print "\t6\t\tExit\n\n";
chomp($option=<STDIN>);
SWITCH:
{
($option =="1") and do
{
system(date);
last;
};
($option =="2") and do
{
print "Enter the path:"; ############################
chomp($path=<STDIN>); #This is giving me an error#
system(ls $path); ############################
last;
};
($option =="3") and do
{
system(cal);
last;
};
($option =="4") and do
{
system(vi);
last;
};
($option =="5") and do
{
system(bc);
last;
};
}
}while ($option!=6);
print "Goodbye!\n";
sleep 2;
First question: Can anyone help me how to write the proper command to create a directory listing in case 2.
Second Question: Why do I get a loop if I use
$date = `date`;
print "$date";
instead of
system(date);
You should be able to solve a lot of your problems by remembering to put quotes around literal arguments to system():
system("date");
system("ls $path");
and the same for most other places you call system() (your first call to system("clear") is correct).
It is a quirk of Perl that calling something like system(cal) works at all, because the unquoted cal is treated as a "bareword" by Perl, which happens to be roughly equivalent to a string when passed to a function such as system(). Relying on this behaviour would be terribly bad practice, and so you should always quote literal strings.
You could read the path like:
chomp($path=<STDIN>);
system("ls $path");
Not sure why you'd get the loop for $date =date;print "$date";. But I don't think there's a date function unless you're using a package for it. You can show a time like:
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
$year += 1900;
$mon += 1;
printf "%04d-%02d-%02d %02d:%02d:%02d",
$year, $mday, $mon,
$hour, $min, $sec;
On most unix systems perl resides in /usr/bin, without the e in user, so you might consider double-checking the first line of your script.
Your immediate problems were caused by quoting issues and the lack of use warnings in your script.
It's also worth noting that menu-driven scripts like yours are ideal candidates for dispatch tables. A dispatch table is a technique for defining actions as data. The actions are Perl subroutines. The data is usually a set of key-value pairs that end up getting stored in a hash.
The keys to the hash are the choices made by the user (menu items 1-6 in your case).
The values in the hash are called code references. There are two ways to set up these code references: (1) Directly in the dispatch table, using anonymous subroutines; or (2) using the &\foo syntax, which would create a reference to a subroutine named foo.
The handy thing about this approach is that your menu() method can be reused -- simply with a different dispatch table and a different usage message.
This example is so small that the benefit of reuse might not seem compelling, but the general technique of having data -- in the form of a dispatch table -- control program behavior is powerful in many contexts.
# Always use both of these.
use strict;
use warnings;
sub dispatch_table {
return
1 => sub { system 'date' },
2 => \&ls_path,
3 => sub { system 'cal' },
4 => sub { system 'vi' },
5 => sub { system 'bc' },
6 => sub { print "Goodbye!\n"; sleep 2 },
;
}
sub ls_path {
print "\nEnter the path: ";
chomp(my $path=<STDIN>);
# Note quoting. To be super robust, you would
# need to escape apostrophes in the path.
system "ls '$path'";
}
sub usage_message {
return "Choose wisely:
Option Command
====== =======
1 Date
2 Directory Listing
3 Calendar
4 Vi Editor
5 Calculator
6 Exit
";
}
sub menu {
system 'clear';
my %dt = dispatch_table();
my $option;
print usage_message();
while (1){
print "> ";
chomp($option = <STDIN>);
last if exists $dt{$option};
}
$dt{$option}->();
}
menu();
I can not reproduce your loop with:
$date =date;print "$date";
I doubt that is exactly how you coded it since I get a compile error
with use strict;. If you can show a reduced code example which still illustrates the problem, we could help debug it further.
If you are trying to capture the output of an external command into a variable, you could use backticks or qx:
my $date = qx(date);
print "$date";
On a side note, whenever I see a series of print statements, I think here-doc:
print <<"EOF";
Enter the number of your chosen option:
Option Command
====== =======
1 Date
2 Directory Listing
etc...
EOF
A little easier to read and maintain, no?
Finally, it is also a good idea to use warnings;.
The first couple of suggests I have are, first like others have already suggested, use warnings is strongly encouraged. Older Perl interpreters may require you use the older form #!/usr/bin/perl -w as the first line of your Perl script. Second, there is a Switch module available, to make the switch statement look less ugly. I've also shown usage of subroutines to clean up the appearance of the program.
I've attached a alternative version of your script with some potential suggestions. Note it uses a slightly different alternative for switch. If available, I'd recommend using the Switch module. It includes a different way of printing the time, and of course fixes your problem with the system calls.
I hope that helps.
#!/usr/bin/perl
use strict;
use warnings; # otherwise /usr/bin/perl -w in first line
sub menu() {
print <<EOM;
Enter the number of your chosen option:
Option Command
====== =======
1 Date
2 Directory Listing
3 Calendar
4 Vi Editor
5 Calculator
6 Exit
EOM
}
sub showtime() {
my $time = localtime;
print $time,"\n";
}
sub listdir() {
my $path;
print "Enter the path: ";
chomp($path = <STDIN>);
system("ls $path");
print "\n";
}
system("clear");
my $option;
do {
menu();
chomp($option = <STDIN>);
# SWITCH:
for ($option) {
/1/ and do {
showtime();
};
/2/ and do {
listdir();
};
/3/ and do {
system("cal");
};
/4/ and do {
system("vi");
};
/5/ and do {
system("bc");
};
last;
}
} while ($option != 6);
print "Goodbye!\n";
sleep 2;

How do I get the full path to a Perl script that is executing?

I have Perl script and need to determine the full path and filename of the script during execution. I discovered that depending on how you call the script $0 varies and sometimes contains the fullpath+filename and sometimes just filename. Because the working directory can vary as well I can't think of a way to reliably get the fullpath+filename of the script.
Anyone got a solution?
There are a few ways:
$0 is the currently executing script as provided by POSIX, relative to the current working directory if the script is at or below the CWD
Additionally, cwd(), getcwd() and abs_path() are provided by the Cwd module and tell you where the script is being run from
The module FindBin provides the $Bin & $RealBin variables that usually are the path to the executing script; this module also provides $Script & $RealScript that are the name of the script
__FILE__ is the actual file that the Perl interpreter deals with during compilation, including its full path.
I've seen the first three ($0, the Cwd module and the FindBin module) fail under mod_perl spectacularly, producing worthless output such as '.' or an empty string. In such environments, I use __FILE__ and get the path from that using the File::Basename module:
use File::Basename;
my $dirname = dirname(__FILE__);
$0 is typically the name of your program, so how about this?
use Cwd 'abs_path';
print abs_path($0);
Seems to me that this should work as abs_path knows if you are using a relative or absolute path.
Update For anyone reading this years later, you should read Drew's answer. It's much better than mine.
use File::Spec;
File::Spec->rel2abs( __FILE__ );
http://perldoc.perl.org/File/Spec/Unix.html
I think the module you're looking for is FindBin:
#!/usr/bin/perl
use FindBin;
$0 = "stealth";
print "The actual path to this is: $FindBin::Bin/$FindBin::Script\n";
You could use FindBin, Cwd, File::Basename, or a combination of them. They're all in the base distribution of Perl IIRC.
I used Cwd in the past:
Cwd:
use Cwd qw(abs_path);
my $path = abs_path($0);
print "$path\n";
Getting the absolute path to $0 or __FILE__ is what you want. The only trouble is if someone did a chdir() and the $0 was relative -- then you need to get the absolute path in a BEGIN{} to prevent any surprises.
FindBin tries to go one better and grovel around in the $PATH for something matching the basename($0), but there are times when that does far-too-surprising things (specifically: when the file is "right in front of you" in the cwd.)
File::Fu has File::Fu->program_name and File::Fu->program_dir for this.
Some short background:
Unfortunately the Unix API doesn't provide a running program with the full path to the executable. In fact, the program executing yours can provide whatever it wants in the field that normally tells your program what it is. There are, as all the answers point out, various heuristics for finding likely candidates. But nothing short of searching the entire filesystem will always work, and even that will fail if the executable is moved or removed.
But you don't want the Perl executable, which is what's actually running, but the script it is executing. And Perl needs to know where the script is to find it. It stores this in __FILE__, while $0 is from the Unix API. This can still be a relative path, so take Mark's suggestion and canonize it with File::Spec->rel2abs( __FILE__ );
Have you tried:
$ENV{'SCRIPT_NAME'}
or
use FindBin '$Bin';
print "The script is located in $Bin.\n";
It really depends on how it's being called and if it's CGI or being run from a normal shell, etc.
In order to get the path to the directory containing my script I used a combination of answers given already.
#!/usr/bin/perl
use strict;
use warnings;
use File::Spec;
use File::Basename;
my $dir = dirname(File::Spec->rel2abs(__FILE__));
perlfaq8 answers a very similar question with using the rel2abs() function on $0. That function can be found in File::Spec.
There's no need to use external modules, with just one line you can have the file name and relative path. If you are using modules and need to apply a path relative to the script directory, the relative path is enough.
$0 =~ m/(.+)[\/\\](.+)$/;
print "full path: $1, file name: $2\n";
#!/usr/bin/perl -w
use strict;
my $path = $0;
$path =~ s/\.\///g;
if ($path =~ /\//){
if ($path =~ /^\//){
$path =~ /^((\/[^\/]+){1,}\/)[^\/]+$/;
$path = $1;
}
else {
$path =~ /^(([^\/]+\/){1,})[^\/]+$/;
my $path_b = $1;
my $path_a = `pwd`;
chop($path_a);
$path = $path_a."/".$path_b;
}
}
else{
$path = `pwd`;
chop($path);
$path.="/";
}
$path =~ s/\/\//\//g;
print "\n$path\n";
:DD
Are you looking for this?:
my $thisfile = $1 if $0 =~
/\\([^\\]*)$|\/([^\/]*)$/;
print "You are running $thisfile
now.\n";
The output will look like this:
You are running MyFileName.pl now.
It works on both Windows and Unix.
The problem with just using dirname(__FILE__) is that it doesn't follow symlinks. I had to use this for my script to follow the symlink to the actual file location.
use File::Basename;
my $script_dir = undef;
if(-l __FILE__) {
$script_dir = dirname(readlink(__FILE__));
}
else {
$script_dir = dirname(__FILE__);
}
use strict ; use warnings ; use Cwd 'abs_path';
sub ResolveMyProductBaseDir {
# Start - Resolve the ProductBaseDir
#resolve the run dir where this scripts is placed
my $ScriptAbsolutPath = abs_path($0) ;
#debug print "\$ScriptAbsolutPath is $ScriptAbsolutPath \n" ;
$ScriptAbsolutPath =~ m/^(.*)(\\|\/)(.*)\.([a-z]*)/;
$RunDir = $1 ;
#debug print "\$1 is $1 \n" ;
#change the \'s to /'s if we are on Windows
$RunDir =~s/\\/\//gi ;
my #DirParts = split ('/' , $RunDir) ;
for (my $count=0; $count < 4; $count++) { pop #DirParts ; }
my $ProductBaseDir = join ( '/' , #DirParts ) ;
# Stop - Resolve the ProductBaseDir
#debug print "ResolveMyProductBaseDir $ProductBaseDir is $ProductBaseDir \n" ;
return $ProductBaseDir ;
} #eof sub
The problem with __FILE__ is that it will print the core module ".pm" path not necessarily the ".cgi" or ".pl" script path that is running. I guess it depends on what your goal is.
It seems to me that Cwd just needs to be updated for mod_perl. Here is my suggestion:
my $path;
use File::Basename;
my $file = basename($ENV{SCRIPT_NAME});
if (exists $ENV{MOD_PERL} && ($ENV{MOD_PERL_API_VERSION} < 2)) {
if ($^O =~/Win/) {
$path = `echo %cd%`;
chop $path;
$path =~ s!\\!/!g;
$path .= $ENV{SCRIPT_NAME};
}
else {
$path = `pwd`;
$path .= "/$file";
}
# add support for other operating systems
}
else {
require Cwd;
$path = Cwd::getcwd()."/$file";
}
print $path;
Please add any suggestions.
Without any external modules, valid for shell, works well even with '../':
my $self = `pwd`;
chomp $self;
$self .='/'.$1 if $0 =~/([^\/]*)$/; #keep the filename only
print "self=$self\n";
test:
$ /my/temp/Host$ perl ./host-mod.pl
self=/my/temp/Host/host-mod.pl
$ /my/temp/Host$ ./host-mod.pl
self=/my/temp/Host/host-mod.pl
$ /my/temp/Host$ ../Host/./host-mod.pl
self=/my/temp/Host/host-mod.pl
All the library-free solutions don't actually work for more than a few ways to write a path (think ../ or /bla/x/../bin/./x/../ etc. My solution looks like below. I have one quirk: I don't have the faintest idea why I have to run the replacements twice. If I don't, I get a spurious "./" or "../". Apart from that, it seems quite robust to me.
my $callpath = $0;
my $pwd = `pwd`; chomp($pwd);
# if called relative -> add pwd in front
if ($callpath !~ /^\//) { $callpath = $pwd."/".$callpath; }
# do the cleanup
$callpath =~ s!^\./!!; # starts with ./ -> drop
$callpath =~ s!/\./!/!g; # /./ -> /
$callpath =~ s!/\./!/!g; # /./ -> / (twice)
$callpath =~ s!/[^/]+/\.\./!/!g; # /xxx/../ -> /
$callpath =~ s!/[^/]+/\.\./!/!g; # /xxx/../ -> / (twice)
my $calldir = $callpath;
$calldir =~ s/(.*)\/([^\/]+)/$1/;
None of the "top" answers were right for me. The problem with using FindBin '$Bin' or Cwd is that they return absolute path with all symbolic links resolved. In my case I needed the exact path with symbolic links present - the same as returns Unix command "pwd" and not "pwd -P". The following function provides the solution:
sub get_script_full_path {
use File::Basename;
use File::Spec;
use Cwd qw(chdir cwd);
my $curr_dir = cwd();
chdir(dirname($0));
my $dir = $ENV{PWD};
chdir( $curr_dir);
return File::Spec->catfile($dir, basename($0));
}
On Windows using dirname and abs_path together worked best for me.
use File::Basename;
use Cwd qw(abs_path);
# absolute path of the directory containing the executing script
my $abs_dirname = dirname(abs_path($0));
print "\ndirname(abs_path(\$0)) -> $abs_dirname\n";
here's why:
# this gives the answer I want in relative path form, not absolute
my $rel_dirname = dirname(__FILE__);
print "dirname(__FILE__) -> $rel_dirname\n";
# this gives the slightly wrong answer, but in the form I want
my $full_filepath = abs_path($0);
print "abs_path(\$0) -> $full_filepath\n";
use File::Basename;
use Cwd 'abs_path';
print dirname(abs_path(__FILE__)) ;
Drew's answer gave me:
'.'
$ cat >testdirname
use File::Basename;
print dirname(__FILE__);
$ perl testdirname
.$ perl -v
This is perl 5, version 28, subversion 1 (v5.28.1) built for x86_64-linux-gnu-thread-multi][1]
What's wrong with $^X ?
#!/usr/bin/env perl<br>
print "This is executed by $^X\n";
Would give you the full path to the Perl binary being used.
Evert
On *nix, you likely have the "whereis" command, which searches your $PATH looking for a binary with a given name. If $0 doesn't contain the full path name, running whereis $scriptname and saving the result into a variable should tell you where the script is located.