develooper Front page | perl.perl5.porters | Postings from May 2008

Re: Getopt::Long, + options, installperl, +v

Thread Previous | Thread Next
From:
Tom Christiansen
Date:
May 18, 2008 21:41
Subject:
Re: Getopt::Long, + options, installperl, +v
Message ID:
20409.1211172063@chthon
On "Sun, 18 May 2008 19:40:12 BST."   
    Nicholas Clark <nick@ccl4.org> wrote 
    in <20080518184012.GJ6780@plum.flirble.org>:

> So I was taking a look at the TODO

> =head2 merge common code in installperl and installman

> There are some common subroutines and a common C<BEGIN> block
> in F<installperl> and F<installman>. These should probably be
> merged. It would also be good to check for duplication in all
> the utility scripts supplied in the source tarball. It might be
> good to move them all to a subdirectory, but this would require
> careful checking to find all places that call them, and change
> those correctly.

> =cut

> and I noticed that one of the differences between the two is
> that installperl has variables $nonono and $verbose, whereas
> installman has $opts{notify} and $opts{verbose}. This is
> because installman uses Getopt::Long, whereas installperl has
> hand-rolled argument parsing.

When I read that, I was suddenly stricken with some vague but completely
unjustifiable suspicion of distant personal responsibility.  Happily, I
confirmed that it was phantom déjà vu.  I figure it's because I just now
looked inside two programs I use daily, once I was just looking over today,
too.  The one uses the old-style, home-rolled parser, including with the
very variables you mention, $nonono and $verbose.  That's what scared me.

The hand-rolled parser with the same variable names occurs in that old
rename/relink program of Larry's that I rewrote to process options and be
in general more robust and faster.

The other culprit, tcgrep, being the more "modern" program, uses a %opts
hash and Getopt::Std.  But it really should have used Getopt::Long instead,
because it became quite complicated, and so I ended up once again redoing a
bunch of stuff which Johan had long ago done so much better.  If you have
tcgrep, look at its gross parse_args() function.  It's no simple matter of

    # core of tcgrep's opt parser
    $optstring = "incCwsxvhe:f:l1HurtpP:aqTF";
    getopts($optstring, \%opt)                  || usage();

but rather, has more auxiliary logic in it.  A *lot* more.  Should
have used Getopt::Long, no question about it.  Oh well.

> So, I wondered whether installperl should be dragged into the
> century of the fruitbat and converted to Getopt::Long.

How about thinking of it as being dragged into the new millennium some 7
years late, or now into the 3rd decade of Perl's existence?  I think you'll
be happy you did.  I *really* like Getopt::Long, and the work that Johan's
done with it in so brilliant I cannot say enough good things about it to do
it the justice it deserves.

The only problem is that I just don't use it enough.  I bet I'm not alone.
What seems to happen is that at first we just want to add--oh say for
example JUST ONE, SINGLE LITTLE -v flag.  Well, that's so easy enough to
hand-hack, that of course we do so; maybe like this:

    if (@ARGV && $ARGV[0] eq '-v') {
        $verbose = 1;
        shift @ARGV;
    } 

or maybe we do something a tad fancier.

But even so, it's still a slip, slip, slippery slope.  I remember how
Larry'd always roll his own quick, simple ones.  I'd ask him why not use
the library, and he said it didn't seem worth the bother to load it in for
just an opt or two.  IIRC, he's written a lot of hand-rolled opt parsers
like I'm about to demo below, and in that peculiar style, too.

But just like any other piece of software, these things all seem to have a
way of overgrowing their original expectations.  It's like writing "just a
simple" shell script: you don't foresee that it's going to grow beyond the
tools ability to get the job done, or beyond your own patience for working
around the beast you've begotten, kicking yourself you didn't do it the
"right way" all the way from the get-go.  At least, that's what happens to
me all the time with option handling.

A quick inspection of two different semi-substantial corpora of perl code
shows that (1) I'm not alone in this kick-myself underestimation of what it
would need, (2) more often resorting to hand-rolling than to Getopt:Std,
and (3) more apt to use Getopt:Std than to use Getopt::Long.  

But Getopt::Long is just *wonderful*, up--I believe--to any job you can
come up with for it.  Too often its absence means that I've in the long run
made more work for myself--or others--by not having used it originally.
Even in the rare case that what you want *isn't* there, I'd bet you a
finely Belgian Trappist Ale of arbitrary size that Johan'd put your
functionality in there for you right away in a jiffy.

Observe two metrics, first on my own scripts:

    % ls -l ~/scripts | wc -l 
         769 

    % tcgrep -lq '(while.*ARGV.*=~|ARGV.*eq)' ~/scripts | wc -l
          59 
    % tcgrep -lq 'Getopt::Std' ~/scripts | wc -l
          17 
    % tcgrep -lq 'Getopt::Long' ~/scripts | wc -l
          12 

and then on the Perl Power Tools programs, some by me but most
by other people:

    % ls ppt-0.14/bin | wc -l
         116 

    % tcgrep -lq '(while.*ARGV.*=~|ARGV.*eq)' ppt-0.14/bin | wc -l
          39 
    % tcgrep -lq 'Getopt::Std' ppt-0.14/bin | wc -l
          38 
    % tcgrep -lq 'Getopt::Long' ppt-0.14/bin | wc -l
           5 

See the trend?  Alas, it's more of the same, and perhaps even more
egregious than in my own stuff, which is really atrocious (we won't
ask Larry to check his though :-).

But Nick, just because you have yourself a hand-rolled parser, and may even
want to keep it, by no means demands that it must be ugly, that it can't
look elegant and (gasp) legible!  :-)

Contrast installperl's version:  (BTW, fails on destdirs w/newlines in them,
but those are so evil, they deserve to suffer--I think.)

    while (@ARGV) {
        $nonono = 1 if $ARGV[0] eq '-n';
        $dostrip = 1 if $ARGV[0] eq '-s';
        $versiononly = 1 if $ARGV[0] eq '-v';
        $versiononly = 0 if $ARGV[0] eq '+v';
        $silent = 1 if $ARGV[0] eq '-S';
        $otherperls = 0 if $ARGV[0] eq '-o';
        $force = 1 if $ARGV[0] eq '-f';
        $verbose = 1 if $ARGV[0] eq '-V' || $ARGV [0] eq '-n';
        $archname = 1 if $ARGV[0] eq '-A';
        $nwinstall = 1 if $ARGV[0] eq '-netware';
        $nopods = 1 if $ARGV[0] eq '-p';
        $destdir = $1 if $ARGV[0] =~ /^-?-destdir=(.*)$/;
        if ($ARGV[0] eq '-?' or $ARGV[0] =~ /^-?-h/) {
            print <<"EOT";
    Usage $0: [switches]
      -n        Don't actually run any commands; just print them.
      -s        Run strip on installed binaries.
      -v        Only install perl as a binary with the version number in the name.
                (Override whatever config.sh says)
        [ETC]

with my own hand-rolled but highly stylized (=funny-looking) critter 
out of the the dark ages for the rename/relink program (where you 
can see the similar things line up in the same column from one line to 
the next so you can quickly see what's different):

    sub opter {

    ARG: while (@ARGV && $ARGV[0] =~ s/^-(?=.)//) {
    OPT:    for (shift @ARGV) {

                m/^$/        && do {                    next ARG; };
                m/^-$/       && do {                    last ARG; };

                s/^0//       && do { $nullpaths++;      redo OPT; };
                s/^f//       && do { $force++;          redo OPT; };
                s/^l//       && do { $reslinking++;     redo OPT; };
                s/^I//       && do { $inspect++;        redo OPT; };
                s/^i//       && do { $careful++;        redo OPT; };
                s/^v//       && do { $verbose++;        redo OPT; };
                s/^V//       && do { $verbose += 2;     redo OPT; };  # like two -v's
                s/^m//       && do { $renaming++;       redo OPT; };
                s/^n//       && do { $nonono++;         redo OPT; };
                s/^N//       && do { $nonono += 2;      redo OPT; };  # like two -n's
                s/^q//       && do { $quiet++;          redo OPT; };

                s/^F(.*)//s  && do { push @flist, $1 || shift @ARGV; redo OPT; };

                usage("Unknown option: $_");
            }
        }
        unless ($renaming || $reslinking) {
            $renaming   = $0 =~ /name/; 
            $reslinking = $0 =~ /link/; 
        } 
        if ($renaming && $reslinking) {
            usage "Can't both rename (-r) and relink (-h)";
        } 
        unless ($renaming || $reslinking) {
            warn "$0: assuming renaming behavior requested\n";
            $renaming++;
        } 
        $verbose += $nonono if $nonono;

        if ($inspect) { 
            accesstty() || usage "can't inspect without /dev/tty: $!";
        }

    # pretend this was stubbed earlier as sub usage;
    sub usage {
        warn "@_\n" if @_;
        die <<EOF;
    usage: $0 [-ifqI0vnml] [-F file] perlexpr [files]
        -i        ask about clobbering existent files
        -f        force clobbers without inquiring
        -q        quietly skip clobbers without inquiring
        -I        ask about all changes
        -0        read null-terminated filenames
        -v        verbosely says what it's doing 
        -V        verbosely says what it's doing but with newlines between old and new filenames
        -n        don't really do it
        -m        to always rename
        -l        to always symlink
        -F path   read filelist to change from magic path(s)
    EOF
    } 

Come on, you at least gotta admit it's a wee bit cute there at the
beginning with the hanging-regexp looking switch() emulation, even if I
am bit of a vertical-alignment freak^Waficionado. :-)  I even compressed
this for your screen compared with the real program.

But then I in turn gotta admit *I* should've used Getopt::Long all along.  :-(

I wouldn't do what I did, Nick, if I'd the whole thing thing to do over.
I'd just thank Johan and use his code.  I don't think you'll be sorry
if you do.

--tom

PS: Full program enclosed, as I think far fewer people have this really
    rather cool (if I do say so myself) version of rename than who have
    my tcgrep.  You'll see what I mean by cool stuff quite readily 
    if you look it over.  And anyway, it's only 4 lines of code :-)

        opter();
        compiler();
        fixer();
        exit($errcnt != 0);

    Have the appropriate amount of fun!

    BTW, I think you fixed the XXX problem it mentions.  Thanks!!!

#!/usr/bin/perl
# pathedit/rename/relink -- rename or relink files 
# original rename and relink were by Larry Wall
# this version by Tom Christiansen

use strict;
use warnings;

our(
    $errcnt,    # how many didn't work
    $verbose,   # trace actions
    $nonono,    # but don't do them (implies verbose)
    $careful,   # ask if target *appears* to exist 
    $inspect,   # ask about everything
    $quiet,     # don't carp if target skipped 
    $force,     # overwrite existing target without prompting
    $nullpaths, # stdin paths are null terminated, not \n
    @flist,     # list of magic filenames containing paths to edit
    $renaming,  # rename paths (disimplies reslinker)
    $reslinking,# reslink paths (disimplies renamer)
);

$errcnt = 0;

opter();
compiler();
fixer();
exit($errcnt != 0);

sub usage {
    warn "@_\n" if @_;
    die <<EOF;
usage: $0 [-ifqI0vnml] [-F file] perlexpr [files]
    -i          ask about clobbering existent files
    -f          force clobbers without inquiring
    -q          quietly skip clobbers without inquiring
    -I          ask about all changes
    -0          read null-terminated filenames
    -v          verbosely say what it's doing 
    -V          verbosely say what it's doing but with newlines between old and new filenames
    -n          don't really do it
    -m          to always rename
    -l          to always symlink
    -F path     read filelist to change from magic path(s)
EOF
} 

sub accesstty {
    return 1 if defined fileno(TTYIN)  &&
                defined fileno(TTYOUT);

    unless (open(TTYIN, "</dev/tty") && open(TTYOUT,">/dev/tty")) {
        return 0;
    } 

    select((select(TTYOUT),$|=1)[0]);
    return 1;
}

sub compiler {
    my $op    = shift @ARGV || usage();
    *pathedit = eval qq{
        sub () { 
            use warnings qw/FATAL all/;  # XXX: does not work
            local \$SIG{__WARN__} = sub { 
                local \$_ = "\@_";
                s/at \\(eval.*//;
                die "FATAL WARNING: \$_";
            };
            $op;
        }   
    } || do {
        local $_ = $@;
        s/at \(eval.*//s;
        die "$0: can't compile perlexpr $op: $_\n";
    } 
} 

sub get_targets {
    if (@ARGV) { 
        usage "-F list exclusive of command line paths" if @flist;
        return @ARGV;
    } 
    @ARGV = @flist ? @flist : "-";
    local $/ = "\0" if $nullpaths;
    my @paths = <>;
    chomp @paths;
    return @paths;
} 

sub fixer {
    my $oldslink;

PATHNAME:
    for my $oldname (get_targets()) {

        if ($oldname =~ /\0/) {
            warn "$0: null found in $oldname; did you forget -0?\n";
            $errcnt++;
            next PATHNAME;
        } 
        if ($renaming && !-e $oldname) {
            warn "$0: $oldname doesn't exist\n";
            $errcnt++;
            next PATHNAME;
        } 

        if ($reslinking) {
            unless (-l $oldname) {
                warn "$0: $oldname ", (-e _) 
                            ? "not a symbolic link\n"
                            : "doesn't exist\n"
                    unless $quiet;
                $errcnt++;
                next PATHNAME;
            } 
            $oldname = readlink($oldslink = $oldname);
        } 
        my $newname = do {
            local $_ = $oldname;
            pathedit();
            $_;
        };
        next if $newname eq $oldname;

        local *confirm = sub () { 
            next PATHNAME unless accesstty();
            print TTYOUT $renaming 
                    ? "rename $oldname to $newname? "
                    : "symlink $oldslink to point to $newname? ";
            my $answer = <TTYIN>;
            no warnings "exiting";  
            last PATHNAME  unless defined $answer;  # exit?
            chomp $answer;
            last PATHNAME  if     "QUIT" =~ /^\Q$answer/i;
            next PATHNAME  unless "YES"  =~ /^\Q$answer/i;
        };

        confirm() if $inspect;

        #  "I'd like to teach 
        #       The world to race 
        #           In perfect hackery!"
        my $was_there = do { 
            no warnings "newline";
            -e $newname;
        };

        if ($renaming) {

            if ($was_there && !$inspect && $careful) {
                confirm() unless $force || $quiet;
                next PATHNAME if $quiet;  
            } 

            unless (vrename($oldname, $newname)) {
                warn "$0: can't rename $oldname to $newname: $!\n";
                $errcnt++;
                next PATHNAME;
            } 

        } 
        elsif ($reslinking) {
            unless ($was_there) {
                warn "$0: symlinking $oldslink to nonexistent $newname\n" 
                    unless $quiet;
            }
            unless (vunlink($oldslink)) {
                warn "$0: can't unlink $oldslink: $!\n";
                $errcnt++;
                next PATHNAME;
            }
            if (!vsymlink($newname, $oldslink)) { 
                warn "$0: can't symlink $newname to $oldslink: $!\n";
                $errcnt++;
                next PATHNAME;
            }
        } 
        else {
            die "Not reached";
        } 

    } 

} 

sub vunlink {
    my $goner = shift;
    if ($verbose) {
        print "unlink $goner\n";
        return 1 if $nonono;
    } 
    unlink $goner;
} 

sub vrename {
    my ($old,$new) = @_;
    if ($verbose) {
        if ($verbose > 1) {
            print "renaming $old\n      to $new\n";
        } else {
            print "rename $old $new\n";
        } 
        return 1 if $nonono;
    } 
    rename($old,$new);
} 

sub vsymlink {
    my ($new,$old) = @_;
    if ($verbose) {
        if ($verbose > 1) {
            print "symlinking $old\n        to $new\n";
        } else { 
            print "symlink $old $new\n";
        } 
        return 1 if $nonono;
    }
    symlink($new,$old);
} 

sub opter {

ARG: while (@ARGV && $ARGV[0] =~ s/^-(?=.)//) {
OPT:    for (shift @ARGV) {

            m/^$/        && do {                                 next ARG; };
            m/^-$/       && do {                                 last ARG; };

            s/^0//       && do { $nullpaths++;                   redo OPT; };
            s/^f//       && do { $force++;                       redo OPT; };
            s/^l//       && do { $reslinking++;                  redo OPT; };
            s/^I//       && do { $inspect++;                     redo OPT; };
            s/^i//       && do { $careful++;                     redo OPT; };
            s/^v//       && do { $verbose++;                     redo OPT; };
            s/^V//       && do { $verbose += 2;                  redo OPT; };  # like two -v's
            s/^m//       && do { $renaming++;                    redo OPT; };
            s/^n//       && do { $nonono++;                      redo OPT; };
            s/^N//       && do { $nonono += 2;                   redo OPT; };  # like two -n's
            s/^q//       && do { $quiet++;                       redo OPT; };

            s/^F(.*)//s  && do { push @flist, $1 || shift @ARGV; redo OPT; };

            usage("Unknown option: $_");
        }
    }
    unless ($renaming || $reslinking) {
        $renaming   = $0 =~ /name/; 
        $reslinking = $0 =~ /link/; 
    } 
    if ($renaming && $reslinking) {
        usage "Can't both rename (-r) and relink (-h)";
    } 
    unless ($renaming || $reslinking) {
        warn "$0: assuming renaming behavior requested\n";
        $renaming++;
    } 
    $verbose += $nonono if $nonono;

    if ($inspect) { 
        accesstty() || usage "can't inspect without /dev/tty: $!";
    }

} 

Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About