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