Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
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 imbibing at the Monastery: (4)
As of 2015-07-06 04:33 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (70 votes), past polls