lib/Getopt/Std.pm

package Getopt::Std;
require 5.000;
require Exporter;

=head1 NAME

getopt, getopts - Process single-character switches with switch clustering

=head1 SYNOPSIS

    use Getopt::Std;

    getopt('oDI');    # -o, -D & -I take arg.  Sets $opt_* as a side effect.
    getopt('oDI', \%opts);    # -o, -D & -I take arg.  Values in %opts
    getopts('oif:');  # -o & -i are boolean flags, -f takes an argument
                      # Sets $opt_* as a side effect.
    getopts('oif:', \%opts);  # options as above. Values in %opts

=head1 DESCRIPTION

The getopt() function processes 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 if an argument is expected,
or 1 otherwise.  Switches which take an argument don't care whether
there is a space between the switch and the argument.

The getopts() function is similar, but you should pass to it the list of all
switches to be recognized.  If unspecified switches are found on the
command-line, the user will be warned that an unknown option was given.

Note that, if your code is running under the recommended C<use strict
'vars'> pragma, you will need to declare these package variables
with "our":

    our($opt_x, $opt_y);

For those of you who don't like additional global variables being created, getopt()
and getopts() will also accept a hash reference as an optional second argument. 
Hash keys will be x (where x is the switch name) with key values the value of
the argument or 1 if no argument is specified.

To allow programs to process arguments that look like switches, but aren't,
both functions will stop processing switches when they see the argument
C<-->.  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<main::HELP_MESSAGE()> and/or
C<main::VERSION_MESSAGE()> 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<perlpod>) 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<Usage:> 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.05';
# 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()} <<EOM;
  [Now continuing due to backward compatibility and excessive paranoia.
   See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.]
EOM
}

sub version_mess ($;$) {
    my $args = shift;
    my $h = output_h;
    if (@_ and defined &main::VERSION_MESSAGE) {
        main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
    } else {
        my $v = $main::VERSION;
        $v = '[unknown]' unless defined $v;
        my $myv = $VERSION;
        $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
        my $perlv = $];
        $perlv = sprintf "%vd", $^V if $] >= 5.006;
        print $h <<EOH;
$0 version $v calling Getopt::Std::getopts (version $myv),
running under Perl version $perlv.
EOH
    }
}

sub help_mess ($;$) {
    my $args = shift;
    my $h = output_h;
    if (@_ and defined &main::HELP_MESSAGE) {
        main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
    } else {
        my (@witharg) = ($args =~ /(\S)\s*:/g);
        my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
        my ($help, $arg) = ('', '');
        if (@witharg) {
            $help .= "\n\tWith arguments: -" . join " -", @witharg;
            $arg = "\nSpace is not required between options and their arguments.";
        }
        if (@rest) {
            $help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
        }
        my ($scr) = ($0 =~ m,([^/\\]+)$,);
        print $h <<EOH if @_;                   # Let the script override this

Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
EOH
        print $h <<EOH;

The following single-character options are accepted:$help

Options may be merged together.  -- stops processing of options.$arg
EOH
        my $has_pod;
        if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
             and open my $script, '<', $0 ) {
            while (<$script>) {
                $has_pod = 1, last if /^=(pod|head1)/;
            }
        }
        print $h <<EOH if $has_pod;

For more details run
        perldoc -F $0
EOH
    }
}

# Usage:
#   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
#                       #  side effect.

sub getopts ($;$) {
    my ($argumentative, $hash) = @_;
    my (@args,$first,$rest,$exit);
    my $errs = 0;
    local $_;
    local @EXPORT;

    @args = split( / */, $argumentative );
    while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
        ($first,$rest) = ($1,$2);
        if (/^--$/) {   # early exit if --
            shift @ARGV;
            last;
        }
        my $pos = index($argumentative,$first);
        if ($pos >= 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;
Revision:	1.1
Committed:	Thu Jun 30 14:27:12 2005 UTC (21 years, 4 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package Getopt::Std;
2			require 5.000;
3			require Exporter;
4
5			=head1 NAME
6
7			getopt, getopts - Process single-character switches with switch clustering
8
9			=head1 SYNOPSIS
10
11			use Getopt::Std;
12
13			getopt('oDI'); # -o, -D & -I take arg. Sets $opt_* as a side effect.
14			getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts
15			getopts('oif:'); # -o & -i are boolean flags, -f takes an argument
16			# Sets $opt_* as a side effect.
17			getopts('oif:', \%opts); # options as above. Values in %opts
18
19			=head1 DESCRIPTION
20
21			The getopt() function processes single-character switches with switch
22			clustering. Pass one argument which is a string containing all switches
23			that take an argument. For each switch found, sets $opt_x (where x is the
24			switch name) to the value of the argument if an argument is expected,
25			or 1 otherwise. Switches which take an argument don't care whether
26			there is a space between the switch and the argument.
27
28			The getopts() function is similar, but you should pass to it the list of all
29			switches to be recognized. If unspecified switches are found on the
30			command-line, the user will be warned that an unknown option was given.
31
32			Note that, if your code is running under the recommended C<use strict
33			'vars'> pragma, you will need to declare these package variables
34			with "our":
35
36			our($opt_x, $opt_y);
37
38			For those of you who don't like additional global variables being created, getopt()
39			and getopts() will also accept a hash reference as an optional second argument.
40			Hash keys will be x (where x is the switch name) with key values the value of
41			the argument or 1 if no argument is specified.
42
43			To allow programs to process arguments that look like switches, but aren't,
44			both functions will stop processing switches when they see the argument
45			C<-->. The C<--> will be removed from @ARGV.
46
47			=head1 C<--help> and C<--version>
48
49			If C<-> is not a recognized switch letter, getopts() supports arguments
50			C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or
51			C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
52			the output file handle, the name of option-processing package, its version,
53			and the switches string. If the subroutines are not defined, an attempt is
54			made to generate intelligent messages; for best results, define $main::VERSION.
55
56			If embedded documentation (in pod format, see L<perlpod>) is detected
57			in the script, C<--help> will also show how to access the documentation.
58
59			Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
60			isn't true (the default is false), then the messages are printed on STDERR,
61			and the processing continues after the messages are printed. This being
62			the opposite of the standard-conforming behaviour, it is strongly recommended
63			to set $Getopt::Std::STANDARD_HELP_VERSION to true.
64
65			One can change the output file handle of the messages by setting
66			$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help>
67			(without the C<Usage:> line) and C<--version> by calling functions help_mess()
68			and version_mess() with the switches string as an argument.
69
70			=cut
71
72			@ISA = qw(Exporter);
73			@EXPORT = qw(getopt getopts);
74			$VERSION = '1.05';
75			# uncomment the next line to disable 1.03-backward compatibility paranoia
76			# $STANDARD_HELP_VERSION = 1;
77
78			# Process single-character switches with switch clustering. Pass one argument
79			# which is a string containing all switches that take an argument. For each
80			# switch found, sets $opt_x (where x is the switch name) to the value of the
81			# argument, or 1 if no argument. Switches which take an argument don't care
82			# whether there is a space between the switch and the argument.
83
84			# Usage:
85			# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
86
87			sub getopt (;$$) {
88			my ($argumentative, $hash) = @_;
89			$argumentative = '' if !defined $argumentative;
90			my ($first,$rest);
91			local $_;
92			local @EXPORT;
93
94			while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
95			($first,$rest) = ($1,$2);
96			if (/^--$/) { # early exit if --
97			shift @ARGV;
98			last;
99			}
100			if (index($argumentative,$first) >= 0) {
101			if ($rest ne '') {
102			shift(@ARGV);
103			}
104			else {
105			shift(@ARGV);
106			$rest = shift(@ARGV);
107			}
108			if (ref $hash) {
109			$$hash{$first} = $rest;
110			}
111			else {
112			${"opt_$first"} = $rest;
113			push( @EXPORT, "\$opt_$first" );
114			}
115			}
116			else {
117			if (ref $hash) {
118			$$hash{$first} = 1;
119			}
120			else {
121			${"opt_$first"} = 1;
122			push( @EXPORT, "\$opt_$first" );
123			}
124			if ($rest ne '') {
125			$ARGV[0] = "-$rest";
126			}
127			else {
128			shift(@ARGV);
129			}
130			}
131			}
132			unless (ref $hash) {
133			local $Exporter::ExportLevel = 1;
134			import Getopt::Std;
135			}
136			}
137
138			sub output_h () {
139			return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
140			return \*STDOUT if $STANDARD_HELP_VERSION;
141			return \*STDERR;
142			}
143
144			sub try_exit () {
145			exit 0 if $STANDARD_HELP_VERSION;
146			my $p = __PACKAGE__;
147			print {output_h()} <<EOM;
148			[Now continuing due to backward compatibility and excessive paranoia.
149			See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.]
150			EOM
151			}
152
153			sub version_mess ($;$) {
154			my $args = shift;
155			my $h = output_h;
156			if (@_ and defined &main::VERSION_MESSAGE) {
157			main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
158			} else {
159			my $v = $main::VERSION;
160			$v = '[unknown]' unless defined $v;
161			my $myv = $VERSION;
162			$myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
163			my $perlv = $];
164			$perlv = sprintf "%vd", $^V if $] >= 5.006;
165			print $h <<EOH;
166			$0 version $v calling Getopt::Std::getopts (version $myv),
167			running under Perl version $perlv.
168			EOH
169			}
170			}
171
172			sub help_mess ($;$) {
173			my $args = shift;
174			my $h = output_h;
175			if (@_ and defined &main::HELP_MESSAGE) {
176			main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
177			} else {
178			my (@witharg) = ($args =~ /(\S)\s*:/g);
179			my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
180			my ($help, $arg) = ('', '');
181			if (@witharg) {
182			$help .= "\n\tWith arguments: -" . join " -", @witharg;
183			$arg = "\nSpace is not required between options and their arguments.";
184			}
185			if (@rest) {
186			$help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
187			}
188			my ($scr) = ($0 =~ m,([^/\\]+)$,);
189			print $h <<EOH if @_; # Let the script override this
190
191			Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
192			EOH
193			print $h <<EOH;
194
195			The following single-character options are accepted:$help
196
197			Options may be merged together. -- stops processing of options.$arg
198			EOH
199			my $has_pod;
200			if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
201			and open my $script, '<', $0 ) {
202			while (<$script>) {
203			$has_pod = 1, last if /^=(pod\|head1)/;
204			}
205			}
206			print $h <<EOH if $has_pod;
207
208			For more details run
209			perldoc -F $0
210			EOH
211			}
212			}
213
214			# Usage:
215			# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
216			# # side effect.
217
218			sub getopts ($;$) {
219			my ($argumentative, $hash) = @_;
220			my (@args,$first,$rest,$exit);
221			my $errs = 0;
222			local $_;
223			local @EXPORT;
224
225			@args = split( / */, $argumentative );
226			while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
227			($first,$rest) = ($1,$2);
228			if (/^--$/) { # early exit if --
229			shift @ARGV;
230			last;
231			}
232			my $pos = index($argumentative,$first);
233			if ($pos >= 0) {
234			if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
235			shift(@ARGV);
236			if ($rest eq '') {
237			++$errs unless @ARGV;
238			$rest = shift(@ARGV);
239			}
240			if (ref $hash) {
241			$$hash{$first} = $rest;
242			}
243			else {
244			${"opt_$first"} = $rest;
245			push( @EXPORT, "\$opt_$first" );
246			}
247			}
248			else {
249			if (ref $hash) {
250			$$hash{$first} = 1;
251			}
252			else {
253			${"opt_$first"} = 1;
254			push( @EXPORT, "\$opt_$first" );
255			}
256			if ($rest eq '') {
257			shift(@ARGV);
258			}
259			else {
260			$ARGV[0] = "-$rest";
261			}
262			}
263			}
264			else {
265			if ($first eq '-' and $rest eq 'help') {
266			version_mess($argumentative, 'main');
267			help_mess($argumentative, 'main');
268			try_exit();
269			shift(@ARGV);
270			next;
271			} elsif ($first eq '-' and $rest eq 'version') {
272			version_mess($argumentative, 'main');
273			try_exit();
274			shift(@ARGV);
275			next;
276			}
277			warn "Unknown option: $first\n";
278			++$errs;
279			if ($rest ne '') {
280			$ARGV[0] = "-$rest";
281			}
282			else {
283			shift(@ARGV);
284			}
285			}
286			}
287			unless (ref $hash) {
288			local $Exporter::ExportLevel = 1;
289			import Getopt::Std;
290			}
291			$errs == 0;
292			}
293
294			1;