Need to capture an optional sub-directory name

technojosh has asked for the wisdom of the Perl Monks concerning the following question:

I have a sub I use to build a name of a "test case" during an automation run. This name is a string that includes the directory of the Perl .pl file, as well as the file name with the suffix (.pl) stripped off.

So a file with the path 'C:\Tools\scripts\Test\Foo.pl' would produce the string 'Test - Foo'

here is my current sub, which works for me as long as there is no directory between 'Test' and 'Foo':

sub ScriptName {
    my ($self) = @_;
    my $name = Win32::GetFullPathName($0);
    
    my $dirChop = substr(
        $name,
        index($name,'\\scripts\\')+9
    );
    
    my $dir = substr(
        $dirChop,
        0,
        index($dirChop,'\\')
    );
    
    my $clean = substr(
        $name,
        rindex($name,'\\')+1,
        rindex($name,'.')-(rindex($name,'\\')+1)
    );
    return "$dir - $clean"
}
[download]

This will totally ignore the sub-directory in the path 'C:\Tools\scripts\Test\Unstable\Foo.pl', where I would like it to return the string 'Test - Unstable - Foo'... but I am no regex pro.

I am looking for a couple pointers:

Can this be cleaned up with regex?
How can I capture a subdirectory (if it exists) too (without losing current functionality)?

-TJ

Comment on Need to capture an optional sub-directory name Download Code

Replies are listed 'Best First'.
Re: Need to capture an optional sub-directory name by BrowserUk (Patriarch) on Mar 29, 2012 at 15:28 UTC
but I am no regex pro You don't need to become a "regex pro" -- whatever one of those is -- but you would sure save yourself some time in the long run, by making the effort to learn the basics: `$p = 'C:\Tools\scripts\Test\Unstable\Foo.pl';; $p =~ s[C:\\Tools\\scripts\\([^.]+).pl][$1]; $p =~ s[\\][ - ]g; print $p;; Test - Unstable - Foo $p2 = 'C:\Tools\scripts\Test\Foo.pl';; $p2 =~ s[C:\\Tools\\scripts\\([^.]+).pl][$1]; $p2 =~ s[\\][ - ]g; print $p2;; Test - Foo` [download] With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday' Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error. "Science is about questioning the status quo. Questioning authority". In the absence of evidence, opinion is indistinguishable from prejudice. The start of some sanity?	[reply] [d/l]
Re: Need to capture an optional sub-directory name by spazm (Monk) on Mar 29, 2012 at 16:26 UTC
You way want to look into a module like File::Spec or Path::Class that allows manipulation of file paths to use the fact that you know this is a path situation. `use File::Spec sub SriptName { my ($self) = @_; my $name = Win32::GetFullPathName($0); my ($volume, $dirs, $file ) = File::Spec->splitpath( $name ); my (@dirs) = File::Spec->splitdir( $dirs ); $_ = shift @dirs until $_ eq 'scripts'; #drop all suffix (not sure if this is what you want here) # this could/should also be $file = basename($file) $file =~ s/\..*//; return join( ' - ', @dirs, $file) }` [download]	[reply] [d/l]
Re: Need to capture an optional sub-directory name by AnomalousMonk (Archbishop) on Mar 29, 2012 at 18:35 UTC
A nice module like File::Spec or Path::Class will probably save you some head-hurt, but here's a possible regex approach (needs 5.10+ for `\K`): >perl -wMstrict -le "my @paths = qw( C:\Tools\scripts\Test\Foo.pl C:\Tools\Test\Unstable\Foo.pl C:\Tools\scripts\Test\Bar.dir\Baz\Foo.pl C:\Tools\Test\Baz\Test\Foo.pl ); ;; my $all_before_Test = qr{ \A (?: (?! \\ Test) .)* }xms; ;; for my $path (@paths) { print qq{'$path'}; my @chunks = $path =~ m{ (?: $all_before_Test \| \G) \\ \K [^\\]+ }xmsg; $chunks[-1] =~ s{ [.] [^.]* \z }{}xms; my $msg = join q{ - }, @chunks; print qq{'$msg' \n}; } " 'C:\Tools\scripts\Test\Foo.pl' 'Test - Foo' 'C:\Tools\Test\Unstable\Foo.pl' 'Test - Unstable - Foo' 'C:\Tools\scripts\Test\Bar.dir\Baz\Foo.pl' 'Test - Bar.dir - Baz - Foo' 'C:\Tools\Test\Baz\Test\Foo.pl' 'Test - Baz - Test - Foo' [download] If you want 'C:\Tools\Test\Baz\Test\Foo.pl' to render as 'Test - Foo' use `my $all_before_Test = qr{ \A .* (?= \\ Test) }xms;` instead.	[reply] [d/l] [select]