Mass Deface
. The C<--> will be removed from @ARGV.
=head1 C<--help> and C<--version>
If C<-> is not a recognized switch letter, getopts() supports arguments
C<--help> and C<--version>. If C and/or
C are defined, they are called; the arguments are
the output file handle, the name of option-processing package, its version,
and the switches string. If the subroutines are not defined, an attempt is
made to generate intelligent messages; for best results, define $main::VERSION.
If embedded documentation (in pod format, see L) is detected
in the script, C<--help> will also show how to access the documentation.
Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
isn't true (the default is false), then the messages are printed on STDERR,
and the processing continues after the messages are printed. This being
the opposite of the standard-conforming behaviour, it is strongly recommended
to set $Getopt::Std::STANDARD_HELP_VERSION to true.
One can change the output file handle of the messages by setting
$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help>
(without the C line) and C<--version> by calling functions help_mess()
and version_mess() with the switches string as an argument.
=cut
@ISA = qw(Exporter);
@EXPORT = qw(getopt getopts);
$VERSION = '1.07';
# uncomment the next line to disable 1.03-backward compatibility paranoia
# $STANDARD_HELP_VERSION = 1;
# Process single-character switches with switch clustering. Pass one argument
# which is a string containing all switches that take an argument. For each
# switch found, sets $opt_x (where x is the switch name) to the value of the
# argument, or 1 if no argument. Switches which take an argument don't care
# whether there is a space between the switch and the argument.
# Usage:
# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
sub getopt (;$$) {
my ($argumentative, $hash) = @_;
$argumentative = '' if !defined $argumentative;
my ($first,$rest);
local $_;
local @EXPORT;
while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
($first,$rest) = ($1,$2);
if (/^--$/) { # early exit if --
shift @ARGV;
last;
}
if (index($argumentative,$first) >= 0) {
if ($rest ne '') {
shift(@ARGV);
}
else {
shift(@ARGV);
$rest = shift(@ARGV);
}
if (ref $hash) {
$$hash{$first} = $rest;
}
else {
${"opt_$first"} = $rest;
push( @EXPORT, "\$opt_$first" );
}
}
else {
if (ref $hash) {
$$hash{$first} = 1;
}
else {
${"opt_$first"} = 1;
push( @EXPORT, "\$opt_$first" );
}
if ($rest ne '') {
$ARGV[0] = "-$rest";
}
else {
shift(@ARGV);
}
}
}
unless (ref $hash) {
local $Exporter::ExportLevel = 1;
import Getopt::Std;
}
}
sub output_h () {
return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
return \*STDOUT if $STANDARD_HELP_VERSION;
return \*STDERR;
}
sub try_exit () {
exit 0 if $STANDARD_HELP_VERSION;
my $p = __PACKAGE__;
print {output_h()} <= 5.006;
print $h <) {
$has_pod = 1, last if /^=(pod|head1)/;
}
}
print $h <= 0) {
if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
shift(@ARGV);
if ($rest eq '') {
++$errs unless @ARGV;
$rest = shift(@ARGV);
}
if (ref $hash) {
$$hash{$first} = $rest;
}
else {
${"opt_$first"} = $rest;
push( @EXPORT, "\$opt_$first" );
}
}
else {
if (ref $hash) {
$$hash{$first} = 1;
}
else {
${"opt_$first"} = 1;
push( @EXPORT, "\$opt_$first" );
}
if ($rest eq '') {
shift(@ARGV);
}
else {
$ARGV[0] = "-$rest";
}
}
}
else {
if ($first eq '-' and $rest eq 'help') {
version_mess($argumentative, 'main');
help_mess($argumentative, 'main');
try_exit();
shift(@ARGV);
next;
} elsif ($first eq '-' and $rest eq 'version') {
version_mess($argumentative, 'main');
try_exit();
shift(@ARGV);
next;
}
warn "Unknown option: $first\n";
++$errs;
if ($rest ne '') {
$ARGV[0] = "-$rest";
}
else {
shift(@ARGV);
}
}
}
unless (ref $hash) {
local $Exporter::ExportLevel = 1;
import Getopt::Std;
}
$errs == 0;
}
1;