e063712b |
1 | # |
2 | # MdwOpt.pm |
3 | # |
4 | # Options parsing |
5 | # |
6 | # (c) 1996 Mark Wooding |
7 | # |
8 | |
9 | #----- Notices -------------------------------------------------------------- |
10 | # |
11 | # This program comes with no warranty, not even of any kind, unless |
12 | # someone other than the author offers to provide one. It may be used |
13 | # and distributed under the terms of the GNU General Public Licence, in |
14 | # the interests of promoting freely available software for Linux. |
15 | |
16 | package MdwOpt; |
17 | require 5.00; |
18 | require Exporter; |
19 | |
20 | @ISA=qw(Exporter); |
21 | @EXPORT=qw( ); |
22 | |
23 | #----- The code ------------------------------------------------------------- |
24 | |
25 | # --- MdwOpt::new --- |
26 | # |
27 | # Arguments: (scalar) shortopts == short options description |
28 | # (see below) longopts == long options description |
29 | # (array ref) arguments == pointer to argument list |
30 | # (array ref) flags == a number of flags you can set |
31 | # |
32 | # Returns: A `MdwOpt' object, which can be used to extract options from |
33 | # an array of argument strings. |
34 | # |
35 | # Use: Creates a `MdwOpt' object which contains all the information |
36 | # needed to parse a command line. The arguments are a bit |
37 | # complicated, so I'll explain them below. This implementation |
38 | # provides a similar level of flexibility to the C `mdwopt' |
39 | # routine, although the interface is rather different, since it |
40 | # takes advantage of some of Perl's object-oriented features. |
41 | # |
42 | # |
43 | # How options parsing appears to users |
44 | # |
45 | # A command line consists of a number of `words' (which may |
46 | # contain spaces, according to various shell quoting |
47 | # conventions). A word may be an option, an argument to an |
48 | # option, or a non-option. An option begins with a special |
49 | # character, usually `-', although `+' is also used sometimes. |
50 | # As special exceptions, the word containing only a `-' is |
51 | # considered to be a non-option, since it usually represents |
52 | # standard input or output as a filename, and the word |
53 | # containing a double-dash `--' is used to mark all following |
54 | # words as being non-options regardless of their initial |
55 | # character. |
56 | # |
57 | # Traditionally, all words after the first non-option have been |
58 | # considered to be non-options automatically, so that options |
59 | # must be specified before filenames. However, this |
60 | # implementation can extract all the options from the command |
61 | # line regardless of their position. This can usually be |
62 | # disabled by setting one of the environment variables |
63 | # `POSIXLY_CORRECT' or `_POSIX_OPTION_ORDER'. |
64 | # |
65 | # There are two different styles of options: `short' and |
66 | # `long'. |
67 | # |
68 | # Short options are the sort which Unix has known for ages: an |
69 | # option is a single letter, preceded by a `-'. Short options |
70 | # can be joined together to save space (and possibly to make |
71 | # silly words): e.g., instead of giving options `-x -y', a user |
72 | # could write `-xy'. Some short options can have arguments, |
73 | # which appear after the option letter, either immediately |
74 | # following, or in the next `word' (so an option with an |
75 | # argument could be written as `-o foo' or as `-ofoo'). Note |
76 | # that options with optional arguments must be written in the |
77 | # second style. |
78 | # |
79 | # When a short option controls a flag setting, it is sometimes |
80 | # possible to explicitly turn the flag off, as well as turning |
81 | # it on, (usually to override default options). This is |
82 | # usually done by using a `+' instead of a `-' to introduce the |
83 | # option. |
84 | # |
85 | # Long options, as popularised by the GNU utilities, are given |
86 | # long-ish memorable names, preceded by a double-dash `--'. |
87 | # Since their names are more than a single character, long |
88 | # options can't be combined in the same way as short options. |
89 | # Arguments to long options may be given either in the same |
90 | # `word', separated from the option name by an equals sign, |
91 | # or in the following `word'. |
92 | # |
93 | # Long option names can be abbreviated if necessary, as long |
94 | # as the abbreviation is unique. This means that options can |
95 | # have sensible and memorable names but still not require much |
96 | # typing from an experienced user. |
97 | # |
98 | # Like short options, long options can control flag settings. |
99 | # The options to manipulate these settings come in pairs: an |
100 | # option of the form `--set-flag' might set the flag, while an |
101 | # option of the form `--no-set-flag' might clear it. |
102 | # |
103 | # It is usual for applications to provide both short and long |
104 | # options with identical behaviour. Some applications with |
105 | # lots of options may only provide long options (although they |
106 | # will often be only two or three characters long). In this |
107 | # case, long options can be preceded with a single `-' |
108 | # character, and negated by a `+' character. |
109 | # |
110 | # Finally, some (older) programs accept arguments of the form |
111 | # `-<number>', to set some numerical parameter, typically a |
112 | # line count of some kind. |
113 | # |
114 | # |
115 | # How programs parse options |
116 | # |
117 | # The difficult bit is all in the setting up at the beginning. |
118 | # I've used some funny data structures to try and pack all the |
119 | # important information away. |
120 | # |
121 | # The first `shortopts' argument specifies the allowable short |
122 | # options, followed by various switch characters which control |
123 | # option-specific features. Allowable characters are as |
124 | # follows: |
125 | # |
126 | # : option takes a required argument |
127 | # :: option takes an optional argument |
128 | # + option may be negated |
129 | # |
130 | # Note that the `+' must appear /before/ the `:' characters. |
131 | # |
132 | # The `longopts' argument is a reference to a hash, containing |
133 | # various pieces of information. (Using a reference here means |
134 | # that we can pass other aggregate values around. It also |
135 | # might save a little memory.) The hash contains an item for |
136 | # each long option string you want to support: the option's |
137 | # name is the key; the value is another hash reference |
138 | # containing information about the option. This sub-hash |
139 | # should contain a number of the following items: |
140 | # |
141 | # Key Use |
142 | # ~~~ ~~~ |
143 | # |
144 | # return Value to return when this option is found. |
145 | # May be any sort of non-false scalar value. |
146 | # |
147 | # arg Information about the argument for this |
148 | # option. May be one of the strings `none', |
149 | # `opt' and `req'. (Actually `none' is the |
150 | # same as a false value, and `req' is the same |
151 | # as any other true value.) |
152 | # |
153 | # negate If true, allow the option to be negated. |
154 | # |
155 | # The `flags' argument is a reference to a array containing |
156 | # items from the following table. |
157 | # |
158 | # Flag Use |
159 | # ~~~~ ~~~ |
160 | # |
161 | # nolong Don't support any long options |
162 | # noshort Don't support any short options |
163 | # numeric Support numeric options |
164 | # negate Support negated options |
165 | # env Read options from environment variable |
166 | # permute Force permuting of the argument list |
167 | # inorder Read options in order |
168 | # posix Force use of POSIX option semantics |
169 | # quiet Don't report errors when they happen |
170 | |
171 | sub new |
172 | { |
173 | my $class=shift; |
174 | my $self=bless {}; # Make an empty reference for me |
175 | my ($short,$long,$argv,$flags)=@_; # Read the caller's arguments |
176 | my ($x); # Temporaries for copying |
177 | my ($prog); # Program name read from argv[0] |
178 | |
179 | # --- Set up the simple parts of the structure --- |
180 | |
181 | @{$self->{argv}}=@$argv; # Copy the arguments list |
182 | |
183 | $self->{flags}={}; # Clear the flags hash out |
184 | foreach $x (@$flags) { $self->{flags}{$x}=1; } |
185 | |
186 | $self->{short}=$short; # Copy the short options string |
187 | $self->{long}=$long; # Take a reference to the long opts |
188 | |
189 | # --- Get the arguments list sorted out --- |
190 | |
191 | $prog=$0; # Read the program name |
192 | $prog =~ s|^.*/||; # Strip leading gubbins from it |
193 | $self->{prog}=$prog; # This as the program name |
194 | |
195 | # --- Play with the ordering settings --- |
196 | |
197 | unless ($self->{flags}{permute} || |
198 | $self->{flags}{inorder} || |
199 | $self->{flags}{posix}) |
200 | { |
201 | if (defined($ENV{'POSIXLY_CORRECT'}) || |
202 | defined($ENV{'_POSIX_OPTION_ORDER'})) |
203 | { $self->{flags}{posix}=1; } |
204 | else |
205 | { $self->{flags}{permute}=1; } |
206 | } |
207 | |
208 | # --- Set up the environment variable, if we're reading that --- |
209 | # |
210 | # List concatenation is so easy ;-) This is actually better than the C |
211 | # version, although much less efficient, since it works `properly' with |
212 | # non-options in the options string. |
213 | |
214 | @{$self->{argv}}=(split(' ',$ENV{uc($self->{prog})}),@{$self->{argv}}) |
215 | if ($self->{flags}{env}); |
216 | |
217 | # --- Initialise persistent state bits --- |
218 | |
219 | $self->{rest}=[]; # No non-options found yet |
220 | $self->{this}=''; # We're not in a shortopt group |
221 | |
222 | # --- That's it, so we're done now --- |
223 | |
224 | return ($self); |
225 | } |
226 | |
227 | # --- mo->err --- |
228 | # |
229 | # Arguments: (scalar) error == a string to return |
230 | # |
231 | # Returns: A suitable error message from mo->read. |
232 | # |
233 | # Use: Contructs an error return and maybe displays the message to |
234 | # the user. |
235 | |
236 | sub err |
237 | { |
238 | my ($self,$msg)=@_; |
239 | |
240 | print STDERR "$self->{prog}: $msg\n" |
241 | unless $self->{flags}{quiet}; |
242 | return ($msg); |
243 | } |
244 | |
245 | # --- mo->read --- |
246 | # |
247 | # Arguments: -- |
248 | # |
249 | # Returns: A list containing interesting things about the option |
250 | # |
251 | # Use: Returns information about the next option read. The list |
252 | # contains, in order: |
253 | # |
254 | # * The `value' of the option, with a suffix `+' if negated |
255 | # * The argument passed to the option |
256 | # |
257 | # Non-options are reported by passing a `value' of an empty |
258 | # string. The end of the options is reported by returning |
259 | # `undef' as the value. An error is returned my setting |
260 | # `value' to `?' and putting the error message in the argument |
261 | # field. |
262 | |
263 | sub read |
264 | { |
265 | my ($self)=@_; # Read the arguments list |
266 | my ($opt,$arg,$prefix); |
267 | |
268 | if ($self->{this} eq '') # Have we any shortopts left? |
269 | { |
270 | $self->{flags}{_neg}=0; # This option isn't negated yet |
271 | |
272 | # --- Find the next option to handle --- |
273 | |
274 | arg: for (;;) |
275 | { |
276 | $opt=shift(@{$self->{argv}}); # Shift out the next option |
277 | return (undef,undef) |
278 | unless (defined($opt)); |
279 | |
280 | if ($opt =~ /^-/ || ($opt =~ /^\+/ && $self->{flags}{negate})) |
281 | { |
282 | if ($opt eq '--') # If no more options at all |
283 | { |
284 | push(@{$self->{rest}},@{$self->{argv}}); |
285 | return (undef,undef); # Return two undefined values |
286 | } |
287 | elsif (length($opt)!=1) |
288 | { last arg; } # Otherwise we've found an option |
289 | } |
290 | |
291 | switch: { |
292 | push(@{$self->{rest}},$opt,@{$self->{argv}}), |
293 | return (undef,undef) # And return two undefined values |
294 | if $self->{flags}{posix}; |
295 | |
296 | return ('',$opt) # Return this non-option |
297 | if $self->{flags}{inorder}; |
298 | |
299 | push(@{$self->{rest}},$opt) # Add to the `rest' list |
300 | ; |
301 | } |
302 | } |
303 | |
304 | # --- Check for a numeric option --- |
305 | |
306 | return ('#',substr($opt,1)) |
307 | if $self->{flags}{numeric} && $opt =~ /^-[+-]?[0-9]/; |
308 | |
309 | # --- Handle long options --- |
310 | # |
311 | # This is where things start getting hairy. |
312 | |
313 | if (($opt =~ /^--/ || $self->{flags}{noshort}) && |
314 | !$self->{flags}{nolong}) |
315 | { |
316 | my ($match,$key,$real); |
317 | |
318 | # --- Extract the prefix, option name and argument --- |
319 | # |
320 | # This is rather easier than the C version. |
321 | |
322 | ($self->{flags}{negate}) ? |
323 | (($prefix,$opt) = $opt =~ /^(\+|--no-|--|-)(.*)/) : |
324 | (($prefix,$opt) = $opt =~ /^(\+|--)(.*)/); |
325 | $self->{flags}{_neg}=1 if ($prefix eq '+' || $prefix eq '--no-'); |
326 | |
327 | ($opt,$arg)=($`,$') if $opt =~ /=/; |
328 | |
329 | # --- Now try and find an entry in the hash table --- |
330 | |
331 | longopt: foreach $key (keys(%{$self->{long}})) |
332 | { |
333 | next longopt |
334 | if $self->{flags}{_neg} && !$self->{long}{$key}{negate}; |
335 | |
336 | ($match,$real)=($self->{long}{$key},$key), |
337 | last longopt |
338 | if $key eq $opt; |
339 | |
340 | next longopt |
341 | if length($key)<length($opt) || |
342 | $opt ne substr($key,0,length($opt)); |
343 | |
344 | $match=undef, |
345 | last longopt |
346 | if defined($match); |
347 | |
348 | ($match,$real)=($self->{long}{$key},$key) |
349 | ; |
350 | } |
351 | |
352 | return ('?',$self->err("unrecognised option `$prefix$opt'")) |
353 | unless defined($match); |
354 | |
355 | if ($match->{arg} eq 'none' || !$match->{arg}) |
356 | { |
357 | return ('?', |
358 | $self->err("option `$prefix$real' does not accept " . |
359 | "arguments")) |
360 | if $arg; |
361 | } |
362 | elsif ($match->{arg} ne 'opt') |
363 | { |
364 | $arg=shift(@{$self->{argv}}) |
365 | unless $arg; |
366 | return ('?',$self->err("option `$prefix$real' requires an argument")) |
367 | unless defined($arg); |
368 | } |
369 | |
370 | $opt=($match->{"return"} || $real); |
371 | $opt .= '+' if ($self->{flags}{_neg}); |
372 | return ($opt,$arg); |
373 | } |
374 | |
375 | # --- Right, it must be a short option --- |
376 | |
377 | $self->{flags}{_neg}=1 if ($opt =~ /^\+/); |
378 | $self->{this}=substr($opt,1); |
379 | } |
380 | |
381 | # --- Handle the next short option --- |
382 | |
383 | ($opt,$self->{this})=(substr($self->{this},0,1),substr($self->{this},1)); |
384 | $prefix=($self->{flags}{_neg} ? '+' : '-'); |
385 | |
386 | if ($self->{short} =~ /\Q$opt/ && |
387 | (!$self->{flags}{_neg} || substr($',0,1) eq '+')) |
388 | { |
389 | my ($rest,$arg)=($',undef); |
390 | |
391 | # --- Found an option, so handle the argument --- |
392 | |
393 | $rest =~ /^\+?(:{0,2})/; |
394 | if ($1) |
395 | { |
396 | $arg=$self->{this}; |
397 | $self->{this}=''; |
398 | if ($1 eq ':' && !$arg) |
399 | { |
400 | $arg=shift(@{$self->{argv}}); |
401 | return ('?',$self->err("option `$prefix$opt' requires an argument")) |
402 | unless defined($arg); |
403 | } |
404 | } |
405 | |
406 | $opt.='+' if $self->{flags}{_neg}; |
407 | return ($opt,$arg); |
408 | } |
409 | return ('?',$self->err("unrecognised option `$prefix$opt'")); |
410 | } |
411 | |
412 | # --- mo->rest --- |
413 | # |
414 | # Arguments: -- |
415 | # |
416 | # Returns: A list containing the remaining command line items in order. |
417 | # |
418 | # Use: Returns all the unprocessed command line arguments. |
419 | |
420 | sub rest |
421 | { |
422 | my ($self)=@_; |
423 | return (@{$self->{rest}}); |
424 | } |
425 | |
426 | # --- prog --- |
427 | # |
428 | # Arguments: -- |
429 | # |
430 | # Returns: The program name, read from $0. |
431 | # |
432 | # Use: Returns the name of the program, with leading path elements |
433 | # snipped off. You can call this either as a class method or |
434 | # by passing a MdwOpt object. |
435 | |
436 | sub prog { $0 =~ m|^.*/| ? $' : $0 } |
437 | |
438 | 1; |