This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
integrate mainline changes
[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 $VERSION = '1.01';
46
47 # Process single-character switches with switch clustering.  Pass one argument
48 # which is a string containing all switches that take an argument.  For each
49 # switch found, sets $opt_x (where x is the switch name) to the value of the
50 # argument, or 1 if no argument.  Switches which take an argument don't care
51 # whether there is a space between the switch and the argument.
52
53 # Usage:
54 #       getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
55
56 sub getopt ($;$) {
57     local($argumentative, $hash) = @_;
58     local($_,$first,$rest);
59     local @EXPORT;
60
61     while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
62         ($first,$rest) = ($1,$2);
63         if (index($argumentative,$first) >= 0) {
64             if ($rest ne '') {
65                 shift(@ARGV);
66             }
67             else {
68                 shift(@ARGV);
69                 $rest = shift(@ARGV);
70             }
71           if (ref $hash) {
72               $$hash{$first} = $rest;
73           }
74           else {
75               ${"opt_$first"} = $rest;
76               push( @EXPORT, "\$opt_$first" );
77           }
78         }
79         else {
80           if (ref $hash) {
81               $$hash{$first} = 1;
82           }
83           else {
84               ${"opt_$first"} = 1;
85               push( @EXPORT, "\$opt_$first" );
86           }
87             if ($rest ne '') {
88                 $ARGV[0] = "-$rest";
89             }
90             else {
91                 shift(@ARGV);
92             }
93         }
94     }
95     unless (ref $hash) { 
96         local $Exporter::ExportLevel = 1;
97         import Getopt::Std;
98     }
99 }
100
101 # Usage:
102 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
103 #                       #  side effect.
104
105 sub getopts ($;$) {
106     local($argumentative, $hash) = @_;
107     local(@args,$_,$first,$rest);
108     local($errs) = 0;
109     local @EXPORT;
110
111     @args = split( / */, $argumentative );
112     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
113         ($first,$rest) = ($1,$2);
114         $pos = index($argumentative,$first);
115         if($pos >= 0) {
116             if(defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
117                 shift(@ARGV);
118                 if($rest eq '') {
119                     ++$errs unless @ARGV;
120                     $rest = shift(@ARGV);
121                 }
122               if (ref $hash) {
123                   $$hash{$first} = $rest;
124               }
125               else {
126                   ${"opt_$first"} = $rest;
127                   push( @EXPORT, "\$opt_$first" );
128               }
129             }
130             else {
131               if (ref $hash) {
132                   $$hash{$first} = 1;
133               }
134               else {
135                   ${"opt_$first"} = 1;
136                   push( @EXPORT, "\$opt_$first" );
137               }
138                 if($rest eq '') {
139                     shift(@ARGV);
140                 }
141                 else {
142                     $ARGV[0] = "-$rest";
143                 }
144             }
145         }
146         else {
147             warn "Unknown option: $first\n";
148             ++$errs;
149             if($rest ne '') {
150                 $ARGV[0] = "-$rest";
151             }
152             else {
153                 shift(@ARGV);
154             }
155         }
156     }
157     unless (ref $hash) { 
158         local $Exporter::ExportLevel = 1;
159         import Getopt::Std;
160     }
161     $errs == 0;
162 }
163
164 1;
165