Getopt::Plus - Options wrapper with standard options, help system and more

# (X)Emacs mode: -*- cperl -*-

# Check working/testing without Term::ProgressBar
# Document SUPER:: calling of check, etc.
# Add validity checks to check (e.g., modes set ok)
# Add check to mode to check mode is valid
# Document mode_info (esp. in init) (and add to SYNOPSIS)
# Document

package Getopt::Plus;

# ----------------------------------------------------------------------------

# Pragmas -----------------------------

require 5.005_62;
use strict;
use warnings;

# Inheritance -------------------------

use base qw( Exporter );
our @EXPORT_OK   = qw( OPT_FLOAT OPT_INT OPT_STRING OPT_BOOLEAN OPT_FDLEVEL
                       ERR_OK ERR_ABNORMAL ERR_UTILITY ERR_USAGE
                       ERR_IO_READ ERR_IO_WRITE
                       ERR_DB_READ ERR_DB_WRITE
                       ERR_RDBMS_READ ERR_RDBMS_WRITE
                       ERR_EXTERNAL ERR_INTERNAL ERR_INPUT
                       ERR_UNKNOWN
                       find_exec ftime commify human_file_size
                       $PACKAGE $VERSION );
our %EXPORT_TAGS = ( opt_types  => [qw/ OPT_FLOAT OPT_INT OPT_STRING
                                        OPT_BOOLEAN OPT_FDLEVEL /],
                     exit_codes => [qw/ ERR_OK
                                        ERR_ABNORMAL ERR_UTILITY
                                        ERR_USAGE
                                        ERR_IO_READ ERR_IO_WRITE
                                        ERR_DB_READ ERR_DB_WRITE
                                        ERR_RDBMS_READ ERR_RDBMS_WRITE
                                        ERR_EXTERNAL ERR_INTERNAL
                                        ERR_INPUT
                                        ERR_UNKNOWN /],
                    );

# Utility -----------------------------

use Carp                             qw( carp croak );
use Class::MethodMaker          1.04 qw( );
use Data::Dumper                     qw( );
use Env                              qw( @PATH );
use Fatal                       1.02 qw( :void close open seek sysopen );
use Fcntl                       1.03 qw( :seek );
use File::Basename               2.6 qw( fileparse );
use File::Spec::Functions        1.1 qw( catfile );
use File::Temp                  0.12 qw( tempfile );
use Getopt::Long                2.25 qw( );
use IPC::Run                    0.44 qw( harness );
use List::Util                  1.06 qw( first min max sum );
use Log::Info                   1.13 qw( :DEFAULT :log_levels
                                         :default_channels :trap );
use Pod::Select                 1.13 qw( podselect );
use Pod::Text                   2.08 qw( );
use Pod::Usage                  1.12 qw( pod2usage );
use Text::Tabs             98.112801 qw( expand );
use Text::Wrap             2001.0131 qw( wrap );

my ($ReadKeyPresent);
BEGIN {
  eval 'use Term::ReadKey 2.14 qw( );';
  $ReadKeyPresent = $@ ? 0 : 1;
}

BEGIN {
  select((select(STDOUT), $| = 1)[0]);
}

# ----------------------------------------------------------------------------

# CLASS METHODS --------------------------------------------------------------

# -------------------------------------
# CLASS CONSTANTS
# -------------------------------------

# Maximum width of option name column in opt output
use constant MAX_OPT_WIDTH => 13;

use constant FILE_SIZE_HUMAN =>
  +{ 1024**0 => +{ name => 'byte',     abbrev => 'b' },
     1024**1 => +{ name => 'kilobyte', abbrev => 'Kb' },
     1024**2 => +{ name => 'megabyte', abbrev => 'Mb' },
     1024**3 => +{ name => 'gigabyte', abbrev => 'Gb' },
     1024**4 => +{ name => 'terabyte', abbrev => 'Tb' },
   };

# OPTION TYPES ------------------------

use constant OPT_FLOAT          => 'f';
use constant OPT_INT            => 'i';
use constant OPT_STRING         => 's';
use constant OPT_FDLEVEL        => 'F';
use constant OPT_BOOLEAN        => '!';

use constant OPTION_NAMES => {
                              OPT_FLOAT   , 'float'    ,
                              OPT_INT     , 'int'      ,
                              OPT_STRING  , 'string'   ,
                              OPT_FDLEVEL , 'fd/level' ,
                             };

use constant GETOPT_TYPE_MAP => {
                                 OPT_FLOAT   , { char => 'f' } ,
                                 OPT_INT     , { char => 'i' } ,
                                 OPT_STRING  , { char => 's' } ,
                                 OPT_FDLEVEL , { char => 's' } ,
                                 OPT_BOOLEAN , { char => '!' } ,
                                };

# DEFAULT OPTIONS ---------------------

use constant STANDARD_OPTIONS =>
  [
   {
    names     => [qw/ v verbose /],
    type      => OPT_FDLEVEL,
    arg_reqd  => 0,
    mandatory => 0,
    summary   => 'output informational messages',
    desc      => <<'END',
Enable informational messages about choices made, etc. to stderr.
This option may be invoked multiple times to increase the level of
verbosity.
END
    default   => 0,
    linkage   => sub {
      my ($rse, $opt, $value) = @_;
      if ( length($opt) eq 1 ) {
        $value = 1+$rse->verbose;
      }
      my $verboseness =
        Log::Info::enable_file_channel(CHAN_INFO, $value, 'verbose',SINK_STDERR);
      $rse->verbose($verboseness);
    }
   },

   {
    names     => [qw/ progress /],
    type      => OPT_FDLEVEL,
    arg_reqd  => 0,
    mandatory => 0,
    summary   => 'output progress messages',
    desc      => <<'END',
Enable regular messages to inform the user of progress made. These may be in
simple text form, or where appropriate, progress bars or the like may be used
(when connected to a suitable terminal).
END
    default   => 0,
    linkage   => sub {
      my ($rse, $opt, $value) = @_;
      Log::Info::enable_file_channel(CHAN_PROGRESS, $value, 'progress',
                                     'p-out', 1);
    }
   },

   {
    names     => [qw/ stats /],
    type      => OPT_FDLEVEL,
    arg_reqd  => 0,
    mandatory => 0,
    summary   => 'output statistical information',
    desc      => 'Enable statistical information to be output to the user.',
    default   => 0,
    linkage   => sub {
      my ($rse, $opt, $value) = @_;
      Log::Info::enable_file_channel(CHAN_STATS, $value, 'stats', 's-out');
    }
   },

    undef,

    {
     names     => [qw/ help /],
     type      => OPT_STRING,
     arg_reqd  => 0,
     mandatory => 0,
     summary   => 'produce summary help on stdout',
     desc      => <<'END',
Print a brief help message and exit.  If an argument is given, then it is
treated as an option name, and the description for that option is given (a la
longhelp).
END
     default   => 0,
     linkage   => sub { $_[0]->dump_help(undef, $_[2]) },
    },

    {
     names     => [qw/ longhelp /],
     arg_reqd  => 0,
     mandatory => 0,
     summary   => 'produce long help on stdout',
     desc      => 'Print a longer help message and exit.',
     default   => 0,
     linkage   => sub { $_[0]->dump_longhelp },
    },

    {
     names     => [qw/ man /],
     arg_reqd  => 0,
     mandatory => 0,
     summary   => 'produce full man page on stdout',
     desc      => 'Print the manual page and exit.',
     default   => 0,
     linkage   => sub { $_[0]->dump_man },
    },

    {
     names     => [qw/ version /],
     arg_reqd  => 0,
     mandatory => 0,
     summary   => 'produce full version on stdout',
     desc      => <<'END',
Print the version info (as for C<briefversion>) and the copyright notice,
and exit.
END
     default   => 0,
     linkage   => sub { $_[0]->dump_version },
    },

    {
     names     => [qw/ V briefversion /],
     arg_reqd  => 0,
     mandatory => 0,
     summary   => 'produce brief version on stdout',
     desc      => <<'END',
Print the version number (of the source package), in the form

  scriptname (packagename): version

and exit. scriptname is the canonical installed name of the script.
END
     default   => undef,
     linkage   => sub { $_[0]->dump_briefversion },
    },

    {
     names     => [qw/ copyright /],
     arg_reqd  => 0,
     mandatory => 0,
     summary   => 'produce full copyright on stdout',
     desc      => 'Print the copyright notice, and exit.',
     default   => 0,
     linkage   => sub { $_[0]->dump_copyright },
     arg_trigger => 1,
    },

    undef,

    {
     names     => [qw/ dry-run /],
     arg_reqd  => 0,
     mandatory => 0,
     summary   => "don't really do anything",
     desc      => <<'END',
Do not write any files (other than temporary files), nor make any changes to
any RDBMS (other than disposable ones).
END
     default   => 0,
     arg_trigger => 1,
    },

   {
    names     => [qw/ debug /],
    type      => OPT_FDLEVEL,
    arg_reqd  => 0,
    mandatory => 0,
    summary   => '',
    desc      => 'Enable debugging output.',
    default   => 0,
    linkage   => sub {
      my ($rse, $opt, $value) = @_;
      Log::Info::enable_file_channel(CHAN_DEBUG, $value, 'debug', 'd-out');
    }
   },

   {
    names     => [qw/ dump-pod /],
    type      => OPT_FDLEVEL,
    arg_reqd  => 0,
    mandatory => 0,
    summary   => 'dump generated pod',
    default   => 0,
    linkage   => sub { $_[0]->dump_as_pod(1); $_[0]->dump_man },
    hidden    => 1,
   },
  ];

# STANDARD TEXT --------------------------------------------------------------

use constant OPTION_TEXT => <<'END';
Options come in short (single-character) and/or long forms. Short options are
preceded by a single dash (-x), whilst long options are preceded by a
double-dash (--option). Long options may be abbreviated to the minimal
distinct prefix. Single char options may not be bundled (-v -a -x !=
-vax). Options taking string values will assume that anything immediately
following is a string value, even if the string is optional and/or the "value"
could be interpreted as another option (if -v takes a string, -vax will give
the value "ax" to the option -v).

Options which are boolean must use the long form (if available) to negate,
prefixed by "no" (--foo may be negated by --nofoo).

Options which are repeating may be invoked multiple times for greater effect.

Option & argument order does not matter: all options will be processed prior
to any arguments.

A lone "--" may be used to terminate options processing; any text(s) following
this will be treated as arguments, rather than options.

Some options are marked as type 'fd/level'.  These take options of the form
C<+([0-9]+)> to set a specific level, and/or either a simple file name
([A-Za-z0-9_-.\/]+) or a file-descriptor number (preceded by a colon).  They
come in the order file,level,fd (but it is illegal to specify a filename and a
file descriptor together).  E.g., C<+1> sets to level one (to the default
filehandle), C</tmp/foo> sets it to output to F</tmp/foo> (at the default
level); C<+2:3> outputs at level 2 to file descriptor 3.

If a filename is given, an error will ensue if that file already exists (and
is a plain file). This is to avoid accidents due to the optional string
syntax.

Beware optional arguments; if you use an option that takes an optional
argument, then any likely-looking (in the case of string arguments, anything)
following it will be treated as an argument to the option. If you mean for an
argument-looking thing to be an argument to the option, use C<--foo=bob>
(for clarity). If you want to follow it with a value that looks like an
argument to the option (but you intend to be a value for the program), follow
it with C<-->, e.g., C<myprog --foo -- bob>
END

use constant DEFAULT_ENV_TEXT =>
  'This program has no special environment handling';

# ERROR CODES -------------------------

use constant DEFAULT_ERR =>
  [ 'Successful termination',
    'Successful, but abnormal termination',
    'A utility function was requested (--help, --version etc.)',
    'Incorrect usage',
    'Filesystem error on open/read',
    'Filesystem error on close/write',
    'RDBMS access error on read/connect',
    'RDBMS access error on on write',
    'Unexpected exit status from external program',
  ];
BEGIN {
  DEFAULT_ERR->[255] = 'Unknown Error';
}

use constant ERR_OK             => 0;

use constant ERR_ABNORMAL       => 1;

use constant ERR_UTILITY        => 2;

use constant ERR_USAGE          => 3;

use constant ERR_IO_READ        => 4;

use constant ERR_IO_WRITE       => 5;

use constant ERR_RDBMS_READ     => 6;
use constant ERR_DB_READ        => 6;

use constant ERR_RDBMS_WRITE    => 7;
use constant ERR_DB_WRITE       => 7;

use constant ERR_EXTERNAL       => 8;

use constant ERR_INTERNAL       => 9;

use constant ERR_INPUT          => 10;

use constant ERR_UNKNOWN        => 255;

# -------------------------------------

our $PACKAGE = 'Getopt-Plus';
our $VERSION = '0.98';

# -------------------------------------
# CLASS CONSTRUCTION
# -------------------------------------

# -------------------------------------
# CLASS COMPONENTS
# -------------------------------------

my $DEFAULT_VERSION = undef;

# -------------------------------------
# CLASS HIGHER-LEVEL FUNCTIONS
# -------------------------------------

# -------------------------------------
# CLASS HIGHER-LEVEL PROCEDURES
# -------------------------------------

sub VERSION { $DEFAULT_VERSION = $_[1]; $_[0]->SUPER::VERSION(@_>2?$_[1]:()) }

# -------------------------------------
# CLASS UTILITY FUNCTIONS
# -------------------------------------

sub find_exec {
  my ($exec) = @_;

  return $_
    for grep -x $_, map catfile($_, $exec), @PATH;

  return;
}

# -------------------------------------

sub columns {
  my ($outfh) = @_;

  return $ENV{COLUMNS}
    if exists $ENV{COLUMNS} and $ENV{COLUMNS} =~ /^\d+$/;

  my $columns = 72;

  if ( defined $outfh ) {
    if ( -t $outfh ) {
      if ( $ReadKeyPresent ) {
        eval {
          $columns = (Term::ReadKey::GetTerminalSize($outfh))[0];
        }; if ( $@ ) {
          warn $@;
        }
      } else {
        if ( my $stty = find_exec('stty') ) {
          my ($readfh, $writefh);
          pipe $readfh, $writefh
            or croak "Failed to forge pipe: $!\n";

          my $pid = fork;
          croak "Fork failed: $!\n"
            if ! defined $pid;

          my $sttyout;

          if ( $pid ) { # Parent
            close $writefh;
            local $/ = undef;
            $sttyout = <$readfh>;
            close $readfh;
            my $rv = waitpid($pid, 0);
            croak "waitpid returned $rv (expected $pid)\n"
              unless $rv == $pid;
          } else {      # Child
            open STDOUT, ">&" . fileno $writefh;
            exec $stty, '-a';
          }

          if ( $sttyout =~ /(?:^|;)\s*columns\s+(\d+)\;/m ) {
            $columns = $1;
          } elsif ( $sttyout =~ /(?:^|;)\s*(\d+)\s+columns\s*\;/m ) {
            $columns = $1;
          }
        }
      }
    }
  }

  return $columns;
}

# -------------------------------------

# Merge a set of values so that they use up the min. possible lines, subject
# to a max. line length & join field (and preserving order).

sub _merge_words {
  my ($words, $max_length, $join) = @_;

  my @lines;
  my $current = $words->[0];
  for (@{$words}[1..$#$words]) {
    if ( length($current) + length($_) + length($join) > $max_length ) {
      push @lines, $current;
      $current = $_;
    } else {
      $current = length($current) ? join($join,$current,$_) : $_;
    }
  }
  push @lines, $current;

  return @lines;
}

# -------------------------------------

# Format time

sub ftime {
  my ($time) = @_;

  if ( $time < 60 ) {
    return sprintf '%ds', $time;
  } elsif ( $time < 60 * 60 ) {
    return sprintf '%dm%ds', int($time/60), $time % 60;
  } elsif ( $time < 60 * 60 * 24 ) {
    return sprintf('%dh%dm%ds',
                   int($time/(60*60)),
                   int(($time%60)/60),
                   $time % 60);
  } else {
    return sprintf('%dd%dh%dm%ds',
                   int($time/(24*60*60)),
                   int($time%(60*60)/(60*60)),
                   int(($time%60)/60),
                   $time % 60);
  }
}

# -------------------------------------

sub commify ($) {
  (my $text = reverse $_[0]) =~ s/(\d{3})(?=\d)(?!\d*\.)/$1,/g;
  $text = reverse $text;
  1
    while $text =~ s/([.,])(\d{3})(?=\d)/$1$2,/g;
  return  $text;
}

# -------------------------------------

sub human_file_size {
  my ($bytes) = @_;

  carp ("human_file_size: bytes not defined\n"), return ''
    unless defined $bytes;

  return $bytes
    if $bytes < 1;

  my $exponent =
    first { $bytes >= $_ } sort {$b<=>$a} keys %{FILE_SIZE_HUMAN()};

  return join('',
              sprintf('%1.0f', ($bytes / $exponent)),
              FILE_SIZE_HUMAN->{$exponent}->{abbrev});
}

# INSTANCE METHODS -----------------------------------------------------------

# -------------------------------------
# INSTANCE CONSTRUCTION
# -------------------------------------

Class::MethodMaker->import (new_with_init => 'new',
                            new_hash_init => 'hash_init',);

sub init {
  my $self = shift;
  my (%args) = @_;

  # Initialize config with defaults
  my %config = ( arg_ary         => 0,
                 check           => sub {},
                 initialize      => sub {},
                 finalize        => sub {},
                 end             => sub {},
                 interface       => $DEFAULT_VERSION,
                 verbose         => 0,
               );

  # Check for mandatory args
  my @missing = grep ! exists $args{$_}, qw( main scriptname );
  croak sprintf("Manadatory arguments missing: %s\n", join(', ', @missing))
    if @missing;

  # Check validity of options, c_years arguments
  $config{options} = delete $args{options} || [];

  croak sprintf("'$_' must be an arrayref (if defined)")
    for grep(exists $config{$_}                    &&
             defined $config{$_}                   &&
             ! UNIVERSAL::isa($config{$_}, 'ARRAY'),
             qw( options c_years ));

  for my $opt (undef, @{STANDARD_OPTIONS()}) {
    my $name;
    ($name = $opt->{names}->[0]) =~ tr/-/_/
      if defined $opt;
    push @{$config{options}}, $opt
      if  ! defined $opt || ! exists $opt->{arg_trigger} || $args{$name};
  }
  
  # Copy in config from arguments
  $config{$_} = delete $args{$_}
    for grep(exists $args{$_},
             qw( scriptname scriptsumm copyright c_years
                 argtype arg_ary envtext
                 output_suffix main initialize mode_info
                 package version finalize end check req_check ));

  # Check for consistency in arg_type & arg_ary
  croak
    sprintf("Cannot specify a possibly positive arg_ary (%s) without an " .
            "argtype\n", $config{arg_ary})
    if ! defined $config{argtype} and
       ( $config{arg_ary} !~ /^\d+$/ or $config{arg_ary} != 0 );

  if ( exists $args{dry_run} ) {
    if ( $args{dry_run} eq 'hidden' ) {
      $_->{hidden} = 1
        for grep(defined $_ && grep($_ eq 'dry-run', @{$_->{names}}),
                 @{$config{options}});
    }
    $config{_dry_run_known} = 1;
    delete $args{dry_run};
  }

  # Check copyright & c_years
  croak "c_years must be provided with __CYEARS__ in copyright text"
    if ( exists $config{copyright}           and 
         $config{copyright} =~ /__CYEARS__/  and 
         ! defined $config{c_years} );

  croak sprintf("'c_years' must have some (sensible) values")
    unless grep(($_ >= 1990 && $_ <= 1900+(localtime)[5]),
                @{$config{c_years}});

  croak sprintf "'arg_ary' must be 0, 1, '*'  or '+'"
    unless ( $config{arg_ary} eq '+' or
             $config{arg_ary} eq '*' or
             $config{arg_ary} eq '0' or
             $config{arg_ary} eq '1'
           );
  croak sprintf("'arg_ary' must be 0 if argtype not defined, " .
                "and 1 or '+' otherwise")
    unless ( $config{arg_ary} xor
             ( ! exists $config{argtype} or ! defined $config{argtype} ) );


  my %optkeys = map({; $_ => 1 }
                    map keys %$_, grep defined $_, @{$config{options}});
  delete $optkeys{$_}
    for qw( names type arg_reqd mandatory summary desc default linkage hidden arg_trigger );
  croak sprintf("Options arg(s) not recognized: %s\n",join(', ',keys %optkeys))
    if keys %optkeys;

  # Error with bad arguments
  croak sprintf("Arguments %s unrecognized", join ', ', keys %args)
    if keys %args;

  $config{tempfh} = tempfile;

  # Set up defaults
  $self->hash_init(%config,
                   diag => DEFAULT_ERR,
                   outfh => \*STDIN,
                  );
}

# -------------------------------------
# INSTANCE FINALIZATION
# -------------------------------------

# -------------------------------------
# INSTANCE COMPONENTS
# -------------------------------------

Class::MethodMaker->import
  (
   get_set => [qw/ scriptname scriptsumm tempfh outfh argtype arg_ary
                   envtext exit_code package version copyright interface
                   main initialize finalize dump_as_pod verbose
                   mode /
              ],
   list    => [qw/ options diag c_years output_suffix /],
   hash    => [qw/ mode_info /],
   boolean => [qw/ args_done
                   _dry_run_known
                   __opt_dry_run /],
   method  => [qw/ end check
                   req_check /],
  );


# -------------------------------------
# INSTANCE HIGHER-LEVEL FUNCTIONS
# -------------------------------------

sub dry_run {
  my $self = shift;
  croak sprintf("This program (%s) does not respect the dry-run option\n",
                $self->scriptname)
    unless $self->_dry_run_known;

  return $self->__opt_dry_run;
}

# -------------------------------------

sub dump_man      { $_[0]->_dump_pod(ERR_UTILITY, 2, $_[1]) }

# -------------------------------------

sub dump_help     {
  my $self = shift;
  my ($outfh, $optname) = @_;

  if ( defined $optname and length $optname ) {
    my $opt_found = 0;
    $outfh ||= \*STDOUT;

    for my $opt ($self->options) {
      if ( grep $_ eq $optname, @{$opt->{names}} ) {
        my $desc = $opt->{desc};

        if ( ! defined $desc or $desc =~ /^\s*$/ ) {
          print $outfh "No description available for option $optname\n";
          $self->exit_code(ERR_UTILITY);
        } else {

          my $columns = columns($outfh);
          local $Text::Wrap::columns = $columns;
          my @para = split /\n\n+/, $desc;
          for (@para) {
            tr/\n/ /;
            $_ = wrap('', '', $_);
            s/\s*\Z//s;
          }

          my $tempfh = tempfile;

          print $tempfh "=pod\n\n";
          print $tempfh join "\n\n", @para;
          print $tempfh "\n";
          print $tempfh "\n=cut";

          seek $tempfh, 0, SEEK_SET;
          my $parser = Pod::Text->new(indent => 0,
                                      sentence => 1,
                                      width => $columns);
          my $tempfh2 = tempfile;
          $parser->parse_from_filehandle($tempfh, $tempfh2);

          seek $tempfh2, 0, SEEK_SET;
          my $accum;
          while (<$tempfh2>) {
            if ( /^\s*$/ ) {
              if ( defined $accum ) {
                if ( $accum =~ /^\s*$/ ) {
                  $accum .= $_;
                } else {
                  print $outfh $accum;
                  $accum = $_;
                }
              } else {
                # We're at the start; do nothing, so as to strip leading
                # blank lines
              }
            } else {
              $accum .= $_;
            }
          }
          print $outfh $accum
            if defined $accum and $accum !~ /^\s*$/;
          $self->exit_code(ERR_UTILITY);
        }
        $opt_found = 1;
      }
    }

    unless ( $opt_found ) {
      print STDERR "No such option: $optname\n";
      $self->exit_code(ERR_USAGE);
    }
  } else {
    $self->_dump_pod(ERR_UTILITY, 0, $outfh);
  }
}

sub dump_longhelp { $_[0]->_dump_pod(ERR_UTILITY, 1, $_[1]) }

sub _dump_pod {
  my $self = shift;
  my ($exitval, $verbose, $outfh) = @_;
  $outfh ||= \*STDOUT;

  my $fh = $self->tempfh;
  seek $fh, 0, SEEK_SET;
  $self->_make_pod($fh);
  seek $fh, 0, SEEK_SET;
  if ( $self->dump_as_pod ) {
    print $_
      while <$fh>;
  } else {
    pod2usage( -exitval => 'NOEXIT',
               -verbose => $verbose,
               -output  => $outfh,
               -input => $fh,
             );
  }
  $self->exit_code($exitval);
}

sub dump_copyright    { $_[0]->_dump_version_info($_[1], 0, 1) }
sub dump_version      { $_[0]->_dump_version_info($_[1], 1, 1) }
sub dump_briefversion { $_[0]->_dump_version_info($_[1], 1, 0) }

sub _dump_version_info {
  my $self = shift;
  my ($outfh, $version, $copyright) = @_;
  $outfh ||= \*STDOUT;

  if ( $version ) {
    my ($scriptname, $package, $version) =
      map $self->$_, qw( scriptname package version );
    print $outfh $scriptname;
    print $outfh " ($package)"
      if defined $package and length $package;
    print $outfh ": $version"
      if defined $version and length $version;
    print $outfh "\n";
    print $outfh "\n"
      if $copyright and defined $self->_copyright;
  }

  print $outfh $self->_copyright
    if $copyright and defined $self->_copyright;

  $self->exit_code(ERR_UTILITY);
}

sub _copyright {
  my $self = shift;

  local $" = ', ';
  my @cyears = $self->c_years;
  return unless defined(my $copyright = $self->copyright);
  $copyright =~ s/__CYEARS__/@cyears/;
  $copyright .= "\n"
    unless substr($copyright, -1, 1) eq "\n";
  return $copyright;
}

# Generate a Getopt::Long spec list (and associated details) for the option
# set.
#
# Args:
#  -) linkages
#     A hashref from an option name (can be any name given to an option; it
#     is an error for two or more aliases to the same option to be provided)
#     to a linkage type.
#
# Returns:
#  -) spec
#     an arrayref to pass (expanded) to Getopt::Long::GetOptions as an
#     option specification
#  -) config
#     A config hash containing a scalar linkage for each option for which
#     no other linkage is provided, named by the first name of the option.
#  -) mandatory
#     A hash from (first) option name to linkage, for each mandatory option.
sub _opt_spec {
  my $self = shift;
  my ($linkages) = @_;
  my $opt_values = $_;

  my (@spec, %config, %mandatory);
  my %linkage_keys = map {;$_ => 1} (defined $linkages ? keys %$linkages : ());

  my @options;
  for my $opt ($self->options) {
    $opt->{fullname} = join '|', sort { length($b) <=> length($a) } @{$opt->{names}}
      if keys %$opt;
    # Split out single-char options with optional arguments;
    # the single-char version takes *no* argument
    if ( exists $opt->{type}
         and
         ! ( exists $opt->{arg_reqd} and $opt->{arg_reqd} )
         and
         grep length($_) == 1, @{$opt->{names}}
       ) {
      my %opt1 = %$opt;
      my %opt2 = %$opt;
      $opt1{fullname} = $opt2{fullname} = join '|', sort { length($b) <=> length($a) } @{$opt->{names}};
      $opt2{names} = [grep length($_) == 1, @{$opt->{names}} ];
      $opt1{names} = [grep length($_) >  1, @{$opt->{names}} ];
      die("No multi-char options named for opt arg option ", 
          join(',', @{$opt2{names}}), "\n")
        unless @{$opt->{names}};
      delete $opt2{type};
      push @options, \%opt2;
      push @options, \%opt1;
    } else {
      push @options, $opt
        if defined $opt and keys %$opt;
    }
  }

  for my $opt ( @options) {
    my @names = sort { length($b) <=> length($a) } @{$opt->{names}};
    my $spec = join '|', @names;
    my $name = $spec;

    my $linkage;
    # Prefer linkage provided by function argument to those set in the object
    if ( defined $linkages ) {
      for my $name (@names) {
        if ( exists $linkages->{$name} ) {
          croak "Multiple linkages defined for option $name\n"
            if defined $linkage;
          $linkage = $linkages->{$name};
          delete $linkage_keys{$name};
        }
      }
    }
    # Fall back to linkage set in this instance, or failing that, a generated
    # scalar one in the default hash.
    $linkage =
      exists $opt->{linkage} ? $opt->{linkage} : \$config{$opt->{names}->[0]}
      unless defined $linkage;

    croak "Cannot handle mandatory args other than scalars ($name)\n"
      if $opt->{mandatory} && ! UNIVERSAL::isa($linkage, 'SCALAR');

    my $target = UNIVERSAL::isa($linkage, 'CODE') ?
                 sub { $linkage->($self, @_); }   :
                 $linkage;

    if ( exists $opt->{type} ) {
      my $join;
      if ( $opt->{type} eq OPT_BOOLEAN ) {
        $join = '';
        croak "Cannot have a boolean arg with a required value! ($name)\n"
          if $opt->{arg_reqd};
      } else {
        $join = exists $opt->{arg_reqd} && $opt->{arg_reqd} ? '=' : ':';
      }
      my $type = GETOPT_TYPE_MAP->{$opt->{type}}->{char};
      $spec   .= "$join$type";
    }

    push @spec, $spec, $target;

    croak "Cannot have a default value with a mandatory option: $name\n"
      if $opt->{mandatory} and defined $opt->{default};

    $mandatory{$opt->{fullname}} = $target
      if $opt->{mandatory};
  }

  carp(sprintf("Linkage names do not correspond to known options: %s\n",
               join(',', keys %linkage_keys)))
    if keys %linkage_keys;
  return \@spec, \%config, \%mandatory;
}

# -------------------------------------

# Don't set linkages for standard options (unless you want trouble!)
# Perhaps we should have a standard place for those so they can always be
# called by overriding methods (and so they should all be methods)
sub get_options {
  my $self = shift;
  my ($linkages) = @_;

  $linkages = {}
    unless defined $linkages;
  for (grep ! exists $linkages->{$_}, qw( dry-run )) {
    (my $opt_name = "__opt_$_") =~ tr/-/_/;
    $linkages->{$_} = sub { $self->$opt_name($_[2]) }
      unless $_ eq 'dry-run' && ! $self->_dry_run_known;
  }

  my ($spec, $config, $mandatory) = $self->_opt_spec($linkages);

  my $parser =
    Getopt::Long::Parser->new(config => [(qw( no_auto_abbrev no_bundling
                                              no_getopt_compat gnu_compat
                                              no_ignore_case permute
                                              prefix_pattern=(--|-)
                                            ))]);
  $parser->getoptions(@$spec)
    or warn("Options parsing failed\n"), $self->exit_code(ERR_USAGE);

  unless ( $self->exit_code ) {
    my @missing = grep ! defined ${$mandatory->{$_}}, keys %$mandatory;
    $self->die(ERR_USAGE, sprintf("Mandatory options missing: %s\n", join ', ', @missing))
      if @missing;
  }
}

# -------------------------------------

sub run {
  my $self = shift;

  eval { # Protect from early death so, e.g., end can run
    $self->get_options;
  }; if ( $@ ) {
    # Log it because die itself is caught.
    Log(CHAN_INFO, LOG_ERR, $@);
    eval {
      $self->die(ERR_USAGE, 'options parsing failed');
    };
  }

  # For arg. consistency checks, etc.
  # This differs from initialize in that this runs in both requisite & normal
  # mode, and a true return value is required.
  unless ( defined $self->exit_code and $self->exit_code > 1 ) {
    eval { # Protect from early death so, e.g., end can run
      $self->check;
    }; if ( $@ ) {
      # Log it because die itself is caught.
      Log(CHAN_INFO, LOG_ERR, $@);
      Log(CHAN_INFO, LOG_ERR, 'check failed');
      eval {
        $self->die(ERR_UNKNOWN, 'check failed');
      };
    }
  }

  my $mode = $self->mode;
  my ($initialize, $main, $finalize);
  if ( defined $mode ) {
    croak "Unknown mode -->$mode<-- selected\n"
      unless $self->mode_info_exists($mode);
    ($initialize, $main, $finalize) =
      @{$self->mode_info($mode)}{qw(initialize main finalize)};
  } else {
    ($initialize, $main, $finalize) =
      ($self->initialize, $self->main, $self->finalize);
  }

  unless ( $self->exit_code ) {
    my $arg_seen = 0;

    my $args_done = 0;

    # General set up prior to handling arguments.  This might include
    # frigging @ARGV itself
    eval {
      # Protect from early death so, e.g., C<end> can run
      if ( defined $self->interface && $self->interface >= 0.96 ) {
        my ($argv) = $initialize->($self, \@ARGV);
        @ARGV = @$argv;
      } else {
        $initialize->($self);
      }
    }; if ( $@ ) {
      # Log it because die itself is caught.
      Log(CHAN_INFO, LOG_ERR, $@);
      Log(CHAN_INFO, LOG_ERR, 'initialize failed');
      eval {
        $self->die(ERR_UNKNOWN, 'initialize failed');
      };
    }

    eval {
      # Protect from early death so, e.g., C<end> can run
      if ( @ARGV and $self->arg_ary eq '0' ) {
        my $message = sprintf "%s: brooks no argument\n", $self->scriptname;
        # Log it because die itself is caught.
        Log(CHAN_INFO, LOG_ERR, $message);
        $self->die(ERR_USAGE, $message);
      }
    };

    eval { # Protect from early death so, e.g., C<end> can run
      my $args = join('', map "-->$_<--", @ARGV);
      my $got = @ARGV ? sprintf('%d: %s', scalar @ARGV, $args) : '0';
      if ( $self->arg_ary eq '1' and @ARGV != 1 ) {
        my $message = sprintf("%s: takes exactly one argument (got %s)\n",
                           $self->scriptname,
                           $got);
        # Log it because die itself is caught.
        Log(CHAN_INFO, LOG_ERR, $message);
        $self->die(ERR_USAGE, $message);
      }
    };

    for my $arg (@ARGV) {
      last if defined $self->exit_code and $self->exit_code > 1;
      last if $self->args_done;
      eval {
        $main->($self, $arg, [$self->output_fn($arg)]);
        $args_done++;
        Logf(CHAN_PROGRESS, LOG_INFO,
             '[%d/%d Arguments Done] Done Argument %s',
             $args_done, scalar(@ARGV), $arg);
        $arg_seen = 1;
      }; if ( $@ ) {
        my $message = "failed processing argument: $arg";
        $message   .= ":\n  $@"
          if $@ !~ /^\s*$/;
        eval {
          # Protect from early death so, e.g., C<end> can run
          # Log it because die itself is caught.
          Log(CHAN_INFO, LOG_ERR, $message);
          $self->die(undef, $message);
        }
      }
    }

    unless ( $arg_seen or $self->exit_code ) {
      if ( $self->arg_ary eq '0' or $self->arg_ary eq '*' ) {
        eval {
          $main->($self);
          Log(CHAN_PROGRESS, LOG_INFO,
              '[1/1 Arguments Done] Done Empty Argument');
          $arg_seen = 1;
        }; if ( $@ ) {
          my $message = 'failed processing empty argument';
          $message   .= ":\n  $@"
            if $@ !~ /^\s*$/;
          eval {
            # Protect from early death so, e.g., C<end> can run
            # Log it because die itself is caught.
            Log(CHAN_INFO, LOG_ERR, $message);
            $self->die(undef, $message);
          }
        }
      } else {
        $self->die(ERR_USAGE, 'At least one arg must be given');
      }
    }

    eval {
      # Protect from early death so, e.g., C<end> can run
      # Deliberately at the same level as initialize
      $finalize->($self)
        unless $self->exit_code and $self->exit_code > 1;
    }; if ( $@ ) {
      # Log it because die itself is caught.
      Log(CHAN_INFO, LOG_ERR, $@);
      Log(CHAN_INFO, LOG_ERR, 'finalize failed');
      eval {
        $self->die(ERR_UNKNOWN, "finalize failed");
      };
    }
  }

  eval {
    # This deliberately runs even if a termination condition has been found.
    # Including help modes.
    # This even runs in help mode
    $self->end;
  }; if ( $@ ) {
    # Log it because die itself is caught.
    Log(CHAN_INFO, LOG_ERR, $@);
    Log(CHAN_INFO, LOG_ERR, "Error executing clean-up");
    eval { # Protect from early death so, e.g., C<end> can run
      $self->die(ERR_UNKNOWN, "Error executing clean-up");
    }
  }

  my $exit = $self->exit_code;
  $exit = 0
    unless defined $exit;
  exit (defined $exit ? $exit : 0);
}

# -------------------------------------

sub output_fn {
  my $self = shift;
  my ($in_fn) = @_;

  confess "No in_fn specified!\n"
    unless defined $in_fn;
  my @Result;

  my $stub = (fileparse($in_fn, qr!\.[^.]*$!))[0];

  for my $suffix (grep defined $_, $self->output_suffix) {
    if ( length $suffix ) {
      push @Result, join '.', $stub, $suffix;
    } else {
      push @Result, $stub;
    }
  }

  return @Result;
}

# -------------------------------------

# Run a system command, throw an exception with command name & exit status on
# non-zero exit

sub check_run {
  my $self = shift;
  my %args = @_;

  my $cmd  = delete $args{cmd}
    or croak "cmd value must be specified\n";
  my $name = ( exists $args{name}   ?
               delete $args{name}   :
               do{my $x=$cmd;$x=$x->[0] while UNIVERSAL::isa($x,"ARRAY");$x}
             );
  my $expect = delete $args{expect} || 0;

  my ($y, $z) = ('') x 2;
  my $stdin  = delete $args{stdin};
  my $stdout = delete $args{stdout} || \$y;
  my $stderr = delete $args{stderr} || \$z;

  my $obs_dr = delete $args{dry_run} || 0; # Observe Dry Run
  my $dry_run = 0;
  if ( $obs_dr ) {
    # Protect with eval for dry_run subr croaks if dry_run flag not set.
    eval { $dry_run = $self->dry_run };
  }

  my $err_code = delete $args{err_code} || ERR_EXTERNAL;

  my @redirects = @{delete $args{redirects}}
    if exists $args{redirects};

  croak sprintf 'Args not recognized: %s', join ',', keys %args
    if keys %args;

  my $expand;
  $expand =
    sub { map +(UNIVERSAL::isa($_, 'ARRAY') ? $expand->(@$_) : $_), @_ };
  my $cmdstring = join ' ', $expand->($cmd);

  Logf(CHAN_INFO, LOG_INFO+1,
       "%s cmd ($name): $cmdstring", ($dry_run ? 'Would run' : 'Running'));
  Logf(CHAN_DEBUG, LOG_INFO,
       'Cmd %s (expecting %d) : %s',
       $name, $expect,
       Data::Dumper->new([$a])->Terse(1)->Indent(0)->Useqq(1)->Dump);

  # Don't pass in even \undef to stdin unnecessarily, as IPC::Run consumes
  # memory if you do.
  my @args = ((defined $stdin ? ('<', $stdin) : ()),
              '>', $stdout, '2>', $stderr, @redirects);
  my $harness = harness @$cmd, @args;
  my $start = time;
  my $rv = $expect << 8;
  unless ( $dry_run ) {
    $harness->run;
    $rv = $harness->full_result;
  }
  my $end = time;

  Logf(CHAN_STATS, LOG_INFO,
       "Running %s took %s\n", $name, ftime($end-$start));

  if ( $rv & 255 or $rv >> 8 != $expect ) {
    Logf(CHAN_INFO, LOG_WARNING,
         'Command %s failed with err output: %s', $name, $$stderr)
      if defined $stderr and $$stderr !~ /^\s*$/;
    $self->exit_code($err_code)
      if $err_code;
    croak sprintf("Error running %s\n  Return Code %d, Signal %d, Core %d\n",
                  $cmdstring, $rv >> 8, $rv & 127, ($rv & 128) >> 7);
  }
}

# -------------------------------------
# INSTANCE HIGHER-LEVEL PROCEDURES
# -------------------------------------

sub new_exit_value {
  my $self = shift;
  my ($message) = @_;

  for (0..255) {
    my $errnum = 255 - $_;
    if ( ! defined $self->diag_index($errnum) ) {
      $self->diag_set($errnum, $message);
      return $errnum;
    }
  }

  croak "Sorry, all exit values allocated!\n";
}

# -------------------------------------

sub _make_pod {
  my $self = shift;
  my ($tempfh) = @_;

  my $columns = columns($self->outfh);
  # Offset columns to account for Pod::Usage reformatting
  $columns -= 4;
  local $Text::Wrap::columns = $columns;

  $self->_make_pod_head($tempfh, $columns);
  $self->_make_pod_opts($tempfh, $columns);

  podselect({-output => $tempfh,
             -sections => ["DESCRIPTION"]}, $0);

  $self->_make_pod_optl($tempfh, $columns);
  $self->_make_pod_env ($tempfh, $columns);
  $self->_make_pod_diag($tempfh, $columns);

  podselect
    ({-output => $tempfh,
      -sections => ["!NAME|DESCRIPTION|SYNOPSIS|OPTIONS|ENVIRONMENT|DIAGNOSTICS|COPYRIGHT|SEE ALSO"]}, $0);

  $self->_make_pod_cprt($tempfh, $columns);

  podselect
    ({-output => $tempfh,
      -sections => ["SEE ALSO"]}, $0);
}

# -------------------------------------

sub _make_pod_head {
  my $self = shift;
  my ($fh) = @_;

  my $scriptname = $self->scriptname;
  my $scriptsumm = $self->scriptsumm;
  {
    my $prefix = "$scriptname - ";
    print $fh "=head1 NAME\n\n";
    print $fh expand(wrap($prefix, ' ' x length $prefix, $scriptsumm)), "\n\n";
  }

  print $fh "=head1 SYNOPSIS\n\n$scriptname [options]";
  print $fh ' ', $self->argtype, ($self->arg_ary eq '+' ? '+' : '')
    if $self->arg_ary;
  print $fh "\n\n";
}

# -------------------------------------

sub _make_pod_opts {
  my $self = shift;
  my ($fh, $columns) = @_;

  my @summary;
 OPTION:
  for (@{$self->options}) {
    push(@summary, undef), next OPTION
      if ! defined $_;

    next OPTION
      if $_->{hidden};

    # Sort option names in ascending order of name length, including '--?'
    my @names = sort { length($a) <=> length($b) }
      map ((length($_) > 1 ? "--$_" : "-$_"),
           @{$_->{names}})
        ;

    my $type;
    $type = OPTION_NAMES->{$_->{type}}
      if exists $_->{type};

    $type = "[$type]"
      if defined $type and ! $_->{arg_reqd};
    $type ||= '';

    my $default = $_->{default};
    if ( $_->{mandatory} ) {
      $default = '------';
    } else {
      if ( defined $default ) {
        if ( $default =~ /^\d+(?:.\d+)?$/ ) {
          ; # Nothing to do
        } else {
          # Clarify that there's a string here
          $default =~ s/\'/\\\'/g;
          $default = "''"
            unless length $default;
        }
      } else {
#        $default = '*undef*';
        $default = '';
      }
    }

    my $unit    = $_->{unit}    || '';
    my $summary = $_->{summary} || '';

    my @nametext;
    my $current = '';
    for (@names) {
      if ( length($current) + length($_) + 1 > MAX_OPT_WIDTH ) {
        push @nametext, $current;
        $current = $_;
      } else {
        $current = length($current) ? join('|',$current,$_) : $_;
      }
    }
    push @nametext, $current;

    @nametext = _merge_words(\@names, MAX_OPT_WIDTH, '|')
      if @names > 1;
    push @summary, [ \@nametext, $type, $default, $unit, $summary ];
  }

  unshift @summary, ([[qw( Option )], qw( Value Default Unit Meaning )]);

  my @col_widths;
  for my $row (grep defined, @summary) {
    for (my $i = 0; $i < @$row; $i++) {
      my $length = $i ? length($row->[$i]) : length($row->[$i]->[0]);
      $col_widths[$i] = $length
        unless defined $col_widths[$i]     and
               $col_widths[$i] >= $length;
    }
  }

  # Limit option width; we have a wrapping trick below
  $col_widths[0] = min(MAX_OPT_WIDTH, $col_widths[0]);

  # Inter-column spacing
  # Offset by two for a initial 2 spaces to visually distinguish options
  my $space = max(2, int(($columns - 2 - sum @col_widths) / (@col_widths-1)));

  my $format = join ('', '  ',
                     join((' ' x $space),
                          map ("%-${_}s", @col_widths[0..$#col_widths-1])),
                     (' ' x $space)
                    );

  # Indent Meaning Field for wrapping
  (my $indent = $format) =~ s/%-?(\d+)s/' ' x $1/eg;
  for (@summary) {
    if ( ! defined $_ ) {
      print $fh ("\n");
    } else {
      my $last = pop @$_;

      my $thisformat = $format;

      # Potentially reformat names to fit onto fewer lines if space in
      # value/default/unit columns
      if ( $#{$_->[0]} and $_->[1] eq '' ) {
        my $name_space = $col_widths[0];
        my $i = 1;
        my $columns_usable = 1;
        while ( $i <= 3 and  $_->[$i] eq '' ) {
          $name_space += $space + $col_widths[$i];
          $columns_usable++;
        } continue {
          $i++;
        }

        my $replace = $columns_usable;
        $thisformat =~ s/^( *)(?:(?: *?)%-?\d+s){$replace}/$1%-${name_space}s/;

        $_->[0] = [ _merge_words($_->[0], $name_space, '|') ];
      }

      my $init = sprintf($thisformat,
                         map $_ || '', $_->[0]->[0], @{$_}[1..$#$_]);
      my @lines;
      if ( $last eq '' ) {
        @lines = $init;
      } else {
        eval {
          @lines = split/\n/, expand(wrap($init, $indent, $last));
        }; if ( $@ ) {
          die "Wrap failed: $@\n";
        }
      }
      for my $lineno ( 1..$#{$_->[0]} ) {
        my $opttext = (' ' x ($space + 2)) . $_->[0]->[$lineno];
        if ( $lineno > $#lines ) {
          $lines[$lineno] = $opttext;
        } else {
          substr($lines[$lineno], 0, length($opttext)) = $opttext;
        }
      }
      print $fh join("\n",@lines), "\n";
    }
  }

  print $fh "\n";
}

# -------------------------------------

sub _make_pod_optl {
  my $self = shift;
  my ($fh) = @_;

  print $fh "=head1 OPTIONS\n\n", OPTION_TEXT, "\n";

  my $over = 0;
 OPTION:
  for (grep defined, @{$self->options}) {
    next OPTION
      if $_->{hidden};
    # Place long options first in longhelp
    my $names = join '|', sort { length($b) <=> length($a) } @{$_->{names}};
    my $desc  = $_->{desc};
    $desc =~ s/\n+\Z//
      if defined $desc;
    if ( defined $desc and length $desc ) {
      print $fh "=over 4\n\n"
        unless $over;
      $over++;
      print $fh "=item $names\n\n";
      print $fh $desc, "\n\n";
    }
  }
  print $fh "=back\n\n"
    if $over;
}

# -------------------------------------

sub _make_pod_env {
  my $self = shift;
  my ($fh, $columns) = @_;

  print $fh "=head1 ENVIRONMENT\n\n";
  print $fh $self->envtext || DEFAULT_ENV_TEXT;
  print $fh "\n\n";
}

# -------------------------------------

sub _make_pod_diag {
  my $self = shift;
  my ($fh, $columns) = @_;

  print $fh "=head1 DIAGNOSTICS\n\n";
  print $fh "The following exit codes may be observed in abnormal cases:\n\n";

  for (1..255) {
    my $text = $self->diag_index($_);
    printf $fh " %3d   %s\n", $_, $text
      if defined $text;
  }

  print $fh "\n\n";
}

# -------------------------------------

sub _make_pod_cprt{
  my $self = shift;
  my ($fh, $columns) = @_;

  print $fh "=head1 COPYRIGHT\n\n";
  print $fh $self->_copyright, "\n";
}

# -------------------------------------

sub die {
  my $self = shift;
  my ($err, @msgs) = @_;
  croak "Not a numeric exit code: $err\n"
    if defined $err and $err !~ /^\d+$/;
  croak "Not a valid exit code: $err\n"
    if defined $err and ($err < 0 or $err > 255);

  my $exit = $self->exit_code;

  $exit = $err || ERR_UNKNOWN
    unless $exit;

  my @message = grep defined, @msgs;

  my $message = @message ? join('', @message, "\n") : "\n";

  $self->exit_code($exit);
  $! = $exit;
  die $message;
}

# ----------------------------------------------------------------------------

1; # keep require happy.

__END__