Re: Copious warnings from Sys::Syslog
[p5sagit/p5-mst-13.2.git] / lib / Getopt / Std.pm
1 package Getopt::Std;
2 require 5.000;
3 require Exporter;
4
5 =head1 NAME
6
7 getopt - Process single-character switches with switch clustering
8
9 getopts - Process single-character switches with switch clustering
10
11 =head1 SYNOPSIS
12
13     use Getopt::Std;
14
15     getopt('oDI');    # -o, -D & -I take arg.  Sets $opt_* as a side effect.
16     getopt('oDI', \%opts);    # -o, -D & -I take arg.  Values in %opts
17     getopts('oif:');  # -o & -i are boolean flags, -f takes an argument
18                       # Sets $opt_* as a side effect.
19     getopts('oif:', \%opts);  # options as above. Values in %opts
20
21 =head1 DESCRIPTION
22
23 The getopt() function processes single-character switches with switch
24 clustering.  Pass one argument which is a string containing all switches
25 that take an argument.  For each switch found, sets $opt_x (where x is the
26 switch name) to the value of the argument, or 1 if no argument.  Switches
27 which take an argument don't care whether there is a space between the
28 switch and the argument.
29
30 The getopts() function is similar, but you should pass to it the list of all
31 switches to be recognized.  If unspecified switches are found on the
32 command-line, the user will be warned that an unknown option was given.
33
34 Note that, if your code is running under the recommended C<use strict
35 'vars'> pragma, you will need to declare these package variables
36 with "our":
37
38     our($opt_x, $opt_y);
39
40 For those of you who don't like additional global variables being created, getopt()
41 and getopts() will also accept a hash reference as an optional second argument. 
42 Hash keys will be x (where x is the switch name) with key values the value of
43 the argument or 1 if no argument is specified.
44
45 To allow programs to process arguments that look like switches, but aren't,
46 both functions will stop processing switches when they see the argument
47 C<-->.  The C<--> will be removed from @ARGV.
48
49 =cut
50
51 @ISA = qw(Exporter);
52 @EXPORT = qw(getopt getopts);
53 $VERSION = '1.03';
54
55 # Process single-character switches with switch clustering.  Pass one argument
56 # which is a string containing all switches that take an argument.  For each
57 # switch found, sets $opt_x (where x is the switch name) to the value of the
58 # argument, or 1 if no argument.  Switches which take an argument don't care
59 # whether there is a space between the switch and the argument.
60
61 # Usage:
62 #       getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
63
64 sub getopt (;$$) {
65     my ($argumentative, $hash) = @_;
66     $argumentative = '' if !defined $argumentative;
67     my ($first,$rest);
68     local $_;
69     local @EXPORT;
70
71     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
72         ($first,$rest) = ($1,$2);
73         if (/^--$/) {   # early exit if --
74             shift @ARGV;
75             last;
76         }
77         if (index($argumentative,$first) >= 0) {
78             if ($rest ne '') {
79                 shift(@ARGV);
80             }
81             else {
82                 shift(@ARGV);
83                 $rest = shift(@ARGV);
84             }
85             if (ref $hash) {
86                 $$hash{$first} = $rest;
87             }
88             else {
89                 ${"opt_$first"} = $rest;
90                 push( @EXPORT, "\$opt_$first" );
91             }
92         }
93         else {
94             if (ref $hash) {
95                 $$hash{$first} = 1;
96             }
97             else {
98                 ${"opt_$first"} = 1;
99                 push( @EXPORT, "\$opt_$first" );
100             }
101             if ($rest ne '') {
102                 $ARGV[0] = "-$rest";
103             }
104             else {
105                 shift(@ARGV);
106             }
107         }
108     }
109     unless (ref $hash) { 
110         local $Exporter::ExportLevel = 1;
111         import Getopt::Std;
112     }
113 }
114
115 # Usage:
116 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
117 #                       #  side effect.
118
119 sub getopts ($;$) {
120     my ($argumentative, $hash) = @_;
121     my (@args,$first,$rest);
122     my $errs = 0;
123     local $_;
124     local @EXPORT;
125
126     @args = split( / */, $argumentative );
127     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
128         ($first,$rest) = ($1,$2);
129         if (/^--$/) {   # early exit if --
130             shift @ARGV;
131             last;
132         }
133         $pos = index($argumentative,$first);
134         if ($pos >= 0) {
135             if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
136                 shift(@ARGV);
137                 if ($rest eq '') {
138                     ++$errs unless @ARGV;
139                     $rest = shift(@ARGV);
140                 }
141                 if (ref $hash) {
142                     $$hash{$first} = $rest;
143                 }
144                 else {
145                     ${"opt_$first"} = $rest;
146                     push( @EXPORT, "\$opt_$first" );
147                 }
148             }
149             else {
150                 if (ref $hash) {
151                     $$hash{$first} = 1;
152                 }
153                 else {
154                     ${"opt_$first"} = 1;
155                     push( @EXPORT, "\$opt_$first" );
156                 }
157                 if ($rest eq '') {
158                     shift(@ARGV);
159                 }
160                 else {
161                     $ARGV[0] = "-$rest";
162                 }
163             }
164         }
165         else {
166             warn "Unknown option: $first\n";
167             ++$errs;
168             if ($rest ne '') {
169                 $ARGV[0] = "-$rest";
170             }
171             else {
172                 shift(@ARGV);
173             }
174         }
175     }
176     unless (ref $hash) { 
177         local $Exporter::ExportLevel = 1;
178         import Getopt::Std;
179     }
180     $errs == 0;
181 }
182
183 1;