Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Wild - Perl extension for improved program interface. Wild-card expansion for @ARGV.

by hsmyers (Canon)
on Sep 27, 2001 at 22:37 UTC ( #115201=sourcecode: print w/ replies, xml ) Need Help??

Category: Win32 Stuff
Author/Contact Info hsmyers@sdragons.com
Description: Will handle DOS-style wild-card expansion of '*' and '?'. Additionally it introduces '@', '!', and '~' as filename prefixes with the following effects: '@' -- treat each line of the file as though it were a command line, '!' -- directory recursion operator, '~' -- exclusion operator creates an exclusionary list, a sort of negative @ARGV. As a last step in WildARGV(), the union of the two is removed from @ARGV. '!' forces lookups to be recursive.
package Wild;

require 5.005_62;
use strict;
use warnings;
use File::DosGlob 'glob';

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not expo
+rt
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration    use Wild ':all';
# If you do not need this, moving things directly into @EXPORT or @EXP
+ORT_OK
# will save memory.
our %EXPORT_TAGS = (
  'all' => [
      qw(

      )
  ]
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(&WildARGV

);
our $VERSION = '0.01';

# Preloaded methods go here.
sub WildARGV {
    my $arg;
    my @newARGV;
    my @glob_args;
    my @xARGV;
    my $recurse;
    my $command;
    my $exclude;

    while (@ARGV) {
        $arg     = pop (@ARGV);
        $recurse = ( $arg =~ /\!/ ) ? 1 : 0;
        $exclude = ( $arg =~ /\~/ ) ? 1 : 0;
        $command = ( $arg =~ /\@/ ) ? 1 : 0;
        $arg =~ s/[\~\@\!]//g;

        if ($command) {
            WildFILE( $arg, $exclude );
        }
        elsif ($exclude) {
            push ( @xARGV, WildGLOB($arg) );
        }
        elsif ($recurse) {

            if ($exclude) {
                push ( @xARGV, WildDIRFILES($arg) );
            }
            else {
                push ( @newARGV, WildDIRFILES($arg) );
            }
        }
        else {
            push ( @newARGV, WildGLOB($arg) );
        }
    }
    push ( @ARGV, @newARGV );

    foreach (@ARGV) {
        s|\/|\\|g;
    }
    if ($exclude) {
        foreach (@xARGV) {
            s|\/|\\|g;
        }
        ExcludeARGV(@xARGV);
    }
}

sub WildGLOB {
    my $arg  = shift;
    my $spec = shift;
    $arg =~ s|\\|/|g;
    if ( $arg =~ / / ) {
        $arg = '"' . $arg . '"';
        $arg =~ s/ /\\ /g;
    }
    my @glob_args = glob($arg);

    return @glob_args ? @glob_args : $arg;
}

sub WildFILE {
    my $filename = shift;
    my $exclude  = shift;
    my @filenames;

    open( FILE, $filename );
    while (<FILE>) {
        @filenames = split;
        if ($exclude) {
            @filenames = map( $_ =~ /\~/ ? $_ : '~' . $_, @filenames )
+;
        }
        push ( @ARGV, @filenames );
    }
    close(FILE);
}

sub ExcludeARGV {
    my @b = @_;
    my %seen;
    my @aonly;

    @seen{@b} = ();
    foreach my $item (@ARGV) {
        push ( @aonly, $item ) unless exists $seen{$item};
    }
    @ARGV = @aonly;
}

sub WildDIRFILES {
    my $spec = shift;
    my $path;
    my @dirlist;
    my @filelist;
    my $dir;

    $spec =~ s/\\/\//g;
    if ( $spec =~ /(.*[\\\/])(.*)/ ) {
        $path = $1;
        $spec = $2;
    }
    else {
        $path = './';
    }
    @dirlist = rdirlist($path);

    while (@dirlist) {
        $dir = pop (@dirlist);
        push ( @filelist, glob( $dir . '/' . $spec ) );
    }
    return @filelist;
}

sub rdirlist {
    my @list = shift;
    my $dir;
    my @rlist;

    while (@list) {
        push ( @rlist, $dir = pop (@list) );
        push ( @list, dirlist($dir) );
    }
    return @rlist;
}

sub dirlist {
    my $spec = shift;

    if ( !( $spec =~ /[\/\\]*\.\*$/ ) ) {
        $spec .= '/*.*';
    }
    my @list = grep( -d $_, glob($spec) );
    return @list;
}

1;
__END__

=head1 NAME

Wild - Perl extension for improved program interface. Wild-card expans
+ion for @ARGV.

=head1 SYNOPSIS

  use Wild;

=head1 DESCRIPTION

Will handle DOS-style wild-card expansion of '*' and '?'. Additionally
it introduces '@', '!', and '~' as filename prefixes with the followin
+g
effects:
   '@' -- treat each line of the file as though it were a command line
+.
   '!' -- directory recursion operator.
   '~' -- exclusion operator.

'~' creates an exclusionary list, a sort of negative @ARGV. As a last 
+step 
in WildARGV(), the union of the two is removed from @ARGV. '!' forces 
+lookups
to be recursive. The allowed combinations of operators are:

   !~@ | ~!@ -- Recursion on, Exclusion on, applied to a command line 
+list file.
   !~* | ~!* -- Recursion on, Exclusion on, applied to a file specific
+ation.
   !@        -- Recursion on, applied to a command line list file.
   ~@        -- Exclusion on, applied to a command line list file.
   ~*        -- Exclusion on, applied to a file specification.
   !*        -- Recursion on, applied to a file specification.

The recursion operation consists of:

   1. Get path to implied directory (i.e. either path to current direc
+tory or path as 
      given).
   2. Use remainder of specification as wild-card specification.
   3. Find all relevant sub-directories and form new glob string (i.e.
+ path + specification).
   4. Append list of files (if any) to the appropriate argument vector
+.
   5. Continue until all directories have been searched.

Crudely speaking, this can be done by forming a list of all relevant d
+irectories first
and then for each, find the necessary matching files. The first versio
+n will not use
recursion, it will manage the task in normal linear fashion.

=head2 EXPORT

WildARGV

=head2 EXAMPLE

 #!/perl/bin/perl -w
 #
 # testwild.pl -- WildARGV demonstration script.
 use strict;
 use diagnostics;
 use Getopt::Std;
 use Wild;
 
 my %OPT;
 
 printARGV("Initial state.");
 getopts('hx:',\%OPT);
 printARGV("After getopts().");
 WildARGV();
 printARGV("After WildARGV().");
 
 sub printARGV{
 
     my $s = shift;
 
     print "\@ARGV: $s\n";
     foreach (0..$#ARGV) {
         print "ARGV[$_]=$ARGV[$_]\n";
     }
 }

=head2 BUGS

Of course, though I try to be neat...

=head1 AUTHOR

B<I<Hugh S. Myers>>

=over

=item Always: hsmyers@sdragons.com

=item Sometimes: hughmyers@micron.com

=back

=cut

Comment on Wild - Perl extension for improved program interface. Wild-card expansion for @ARGV.
Download Code
Re: Wild - Perl extension for improved program interface. Wild-card expansion for @ARGV.
by miyagawa (Chaplain) on Sep 28, 2001 at 02:37 UTC
      Nice one liner! I would still have written this one since its a transliteration of the one of used in 'C' for the last 20 years or so and I've gotten kinda spoiled by having the extra features ;).

      hsm

Re: Wild - Perl extension for improved program interface. Wild-card expansion for @ARGV.
by Jenda (Abbot) on Nov 12, 2002 at 23:19 UTC

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://115201]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (12)
As of 2014-07-24 13:34 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (160 votes), past polls