This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Using Getopts::* with strict vars
[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 $Exporter::ExportLevel;
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     $Exporter::ExportLevel++;
97     import Getopt::Std;
98 }
99
100 # Usage:
101 #   getopts('a:bc');    # -a takes arg. -b & -c not. Sets opt_* as a
102 #                       #  side effect.
103
104 sub getopts ($;$) {
105     local($argumentative, $hash) = @_;
106     local(@args,$_,$first,$rest);
107     local($errs) = 0;
108     local $Exporter::ExportLevel;
109
110     @args = split( / */, $argumentative );
111     while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
112         ($first,$rest) = ($1,$2);
113         $pos = index($argumentative,$first);
114         if($pos >= 0) {
115             if(defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
116                 shift(@ARGV);
117                 if($rest eq '') {
118                     ++$errs unless @ARGV;
119                     $rest = shift(@ARGV);
120                 }
121               if (ref $hash) {
122                   $$hash{$first} = $rest;
123               }
124               else {
125                   ${"opt_$first"} = $rest;
126                   push( @EXPORT, "\$opt_$first" );
127               }
128             }
129             else {
130               if (ref $hash) {
131                   $$hash{$first} = 1;
132               }
133               else {
134                   ${"opt_$first"} = 1;
135                   push( @EXPORT, "\$opt_$first" );
136               }
137                 if($rest eq '') {
138                     shift(@ARGV);
139                 }
140                 else {
141                     $ARGV[0] = "-$rest";
142                 }
143             }
144         }
145         else {
146             print STDERR "Unknown option: $first\n";
147             ++$errs;
148             if($rest ne '') {
149                 $ARGV[0] = "-$rest";
150             }
151             else {
152                 shift(@ARGV);
153             }
154         }
155     }
156     $Exporter::ExportLevel++;
157     import Getopt::Std;
158     $errs == 0;
159 }
160
161 1;
162