This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
tweaks to Getopt::Std
[perl5.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() functions 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 Note that, if your code is running under the recommended C<use strict
31 'vars'> pragma, it may be helpful to declare these package variables
32 via C<use vars> perhaps something like this:
33
34     use vars qw/ $opt_foo $opt_bar /;
35
36 For those of you who don't like additional variables being created, getopt()
37 and getopts() will also accept a hash reference as an optional second argument. 
38 Hash keys will be x (where x is the switch name) with key values the value of
39 the argument or 1 if no argument is specified.
40
41 =cut
42
43 @ISA = qw(Exporter);
44 @EXPORT = qw(getopt getopts);
45
46 # $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
47
48 # Process single-character switches with switch clustering.  Pass one argument
49 # which is a string containing all switches that take an argument.  For each
50 # switch found, sets $opt_x (where x is the switch name) to the value of the
51 # argument, or 1 if no argument.  Switches which take an argument don't care
52 # whether there is a space between the switch and the argument.
53
54 # Usage:
55 #       getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
56
57 sub getopt ($;$) {
58     local($argumentative, $hash) = @_;
59     local($_,$first,$rest);
60     local @EXPORT;
61
62     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
63         ($first,$rest) = ($1,$2);
64         if (index($argumentative,$first) >= 0) {
65             if ($rest ne '') {
66                 shift(@ARGV);
67             }
68             else {
69                 shift(@ARGV);
70                 $rest = shift(@ARGV);
71             }
72           if (ref $hash) {
73               $$hash{$first} = $rest;
74           }
75           else {
76               ${"opt_$first"} = $rest;
77               push( @EXPORT, "\$opt_$first" );
78           }
79         }
80         else {
81           if (ref $hash) {
82               $$hash{$first} = 1;
83           }
84           else {
85               ${"opt_$first"} = 1;
86               push( @EXPORT, "\$opt_$first" );
87           }
88             if ($rest ne '') {
89                 $ARGV[0] = "-$rest";
90             }
91             else {
92                 shift(@ARGV);
93             }
94         }
95     }
96     unless (ref $hash) { 
97         local $Exporter::ExportLevel = 1;
98         import Getopt::Std;
99     }
100 }
101
102 # Usage:
103 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
104 #                       #  side effect.
105
106 sub getopts ($;$) {
107     local($argumentative, $hash) = @_;
108     local(@args,$_,$first,$rest);
109     local($errs) = 0;
110     local @EXPORT;
111
112     @args = split( / */, $argumentative );
113     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
114         ($first,$rest) = ($1,$2);
115         $pos = index($argumentative,$first);
116         if($pos >= 0) {
117             if(defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
118                 shift(@ARGV);
119                 if($rest eq '') {
120                     ++$errs unless @ARGV;
121                     $rest = shift(@ARGV);
122                 }
123               if (ref $hash) {
124                   $$hash{$first} = $rest;
125               }
126               else {
127                   ${"opt_$first"} = $rest;
128                   push( @EXPORT, "\$opt_$first" );
129               }
130             }
131             else {
132               if (ref $hash) {
133                   $$hash{$first} = 1;
134               }
135               else {
136                   ${"opt_$first"} = 1;
137                   push( @EXPORT, "\$opt_$first" );
138               }
139                 if($rest eq '') {
140                     shift(@ARGV);
141                 }
142                 else {
143                     $ARGV[0] = "-$rest";
144                 }
145             }
146         }
147         else {
148             print STDERR "Unknown option: $first\n";
149             ++$errs;
150             if($rest ne '') {
151                 $ARGV[0] = "-$rest";
152             }
153             else {
154                 shift(@ARGV);
155             }
156         }
157     }
158     unless (ref $hash) { 
159         local $Exporter::ExportLevel = 1;
160         import Getopt::Std;
161     }
162     $errs == 0;
163 }
164
165 1;
166