Commit | Line | Data |
a0d0e21e |
1 | package Getopt::Std; |
2 | require 5.000; |
3 | require Exporter; |
4 | |
f06db76b |
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 | getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. |
15 | getopts('oif:'); # -o & -i are boolean flags, -f takes an argument |
16 | # Sets opt_* as a side effect. |
17 | |
18 | =head1 DESCRIPTION |
19 | |
20 | The getopt() functions processes single-character switches with switch |
21 | clustering. Pass one argument which is a string containing all switches |
22 | that take an argument. For each switch found, sets $opt_x (where x is the |
23 | switch name) to the value of the argument, or 1 if no argument. Switches |
24 | which take an argument don't care whether there is a space between the |
25 | switch and the argument. |
26 | |
27 | =cut |
28 | |
a0d0e21e |
29 | @ISA = qw(Exporter); |
30 | @EXPORT = qw(getopt getopts); |
31 | |
32 | # $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $ |
33 | |
34 | # Process single-character switches with switch clustering. Pass one argument |
35 | # which is a string containing all switches that take an argument. For each |
36 | # switch found, sets $opt_x (where x is the switch name) to the value of the |
37 | # argument, or 1 if no argument. Switches which take an argument don't care |
38 | # whether there is a space between the switch and the argument. |
39 | |
40 | # Usage: |
41 | # getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. |
42 | |
43 | sub getopt { |
44 | local($argumentative) = @_; |
45 | local($_,$first,$rest); |
46 | local $Exporter::ExportLevel; |
47 | |
48 | while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { |
49 | ($first,$rest) = ($1,$2); |
50 | if (index($argumentative,$first) >= 0) { |
51 | if ($rest ne '') { |
52 | shift(@ARGV); |
53 | } |
54 | else { |
55 | shift(@ARGV); |
56 | $rest = shift(@ARGV); |
57 | } |
58 | eval "\$opt_$first = \$rest;"; |
59 | push( @EXPORT, "\$opt_$first" ); |
60 | } |
61 | else { |
62 | eval "\$opt_$first = 1;"; |
63 | push( @EXPORT, "\$opt_$first" ); |
64 | if ($rest ne '') { |
65 | $ARGV[0] = "-$rest"; |
66 | } |
67 | else { |
68 | shift(@ARGV); |
69 | } |
70 | } |
71 | } |
72 | $Exporter::ExportLevel++; |
73 | import Getopt::Std; |
74 | } |
75 | |
76 | # Usage: |
77 | # getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a |
78 | # # side effect. |
79 | |
80 | sub getopts { |
81 | local($argumentative) = @_; |
82 | local(@args,$_,$first,$rest); |
83 | local($errs) = 0; |
84 | local $Exporter::ExportLevel; |
85 | |
86 | @args = split( / */, $argumentative ); |
87 | while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { |
88 | ($first,$rest) = ($1,$2); |
89 | $pos = index($argumentative,$first); |
90 | if($pos >= 0) { |
f06db76b |
91 | if(defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { |
a0d0e21e |
92 | shift(@ARGV); |
93 | if($rest eq '') { |
94 | ++$errs unless @ARGV; |
95 | $rest = shift(@ARGV); |
96 | } |
97 | eval "\$opt_$first = \$rest;"; |
98 | push( @EXPORT, "\$opt_$first" ); |
99 | } |
100 | else { |
101 | eval "\$opt_$first = 1"; |
102 | push( @EXPORT, "\$opt_$first" ); |
103 | if($rest eq '') { |
104 | shift(@ARGV); |
105 | } |
106 | else { |
107 | $ARGV[0] = "-$rest"; |
108 | } |
109 | } |
110 | } |
111 | else { |
112 | print STDERR "Unknown option: $first\n"; |
113 | ++$errs; |
114 | if($rest ne '') { |
115 | $ARGV[0] = "-$rest"; |
116 | } |
117 | else { |
118 | shift(@ARGV); |
119 | } |
120 | } |
121 | } |
122 | $Exporter::ExportLevel++; |
123 | import Getopt::Std; |
124 | $errs == 0; |
125 | } |
126 | |
127 | 1; |
128 | |