Getopt.pm revision 1.11 
1# $OpenBSD: Getopt.pm,v 1.11 2012/07/12 12:20:06 espie Exp $
2
3# Copyright (c) 2012 Marc Espie <espie@openbsd.org>
4#
5# Permission to use, copy, modify, and distribute this software for any
6# purpose with or without fee is hereby granted, provided that the above
7# copyright notice and this permission notice appear in all copies.
8#
9# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16#
17
18use strict;
19use warnings;
20
21package Option;
22sub factory
23{
24	my ($class, $_) = @_;
25	if (m/^(.)$/) {
26		return Option::Short->new($1);
27	} elsif (m/^(.)\:$/) {
28		return Option::ShortArg->new($1);
29	} elsif (m/^(\-?.)(?:\:\!|\!\:)$/) {
30		return Option::LongArg0->new($1);
31	} elsif (m/^(\-?.)\!$/) {
32		return Option::Long->new($1);
33	} elsif (m/^(\-?.*)\=$/) {
34		return Option::LongArg->new($1);
35	} elsif (m/^(\-?.*)\:$/) {
36		return Option::LongArg0->new($1);
37	} elsif (m/^(\-?.*)$/) {
38		return Option::Long->new($1);
39	}
40}
41
42sub new
43{
44	my ($class, $v) = @_;
45	bless \$v, $class;
46}
47
48sub setup
49{
50	my ($self, $opts, $isarray) = @_;
51	$opts->add_option_accessor($$self, $isarray);
52	return $self;
53}
54
55package Option::Short;
56our @ISA = qw(Option);
57
58sub match
59{
60	my ($self, $_, $opts, $canonical, $code) = @_;
61	if (m/^\-\Q$$self\E$/) {
62		&$code($opts, $canonical, 1, $_);
63		return 1;
64	}
65	if (m/^(\-\Q$$self\E)(.*)$/) {
66		unshift(@main::ARGV, "-$2");
67		&$code($opts, $canonical, 1, $1);
68		return 1;
69	}
70	return 0;
71}
72
73package Option::ShortArg;
74our @ISA = qw(Option::Short);
75
76sub match
77{
78	my ($self, $_, $opts, $canonical, $code) = @_;
79	if (m/^\-\Q$$self\E$/) {
80		&$code($opts, $canonical, (shift @main::ARGV), $_);
81		return 1;
82	}
83	if (m/^(\-\Q$$self\E)(.*)$/) {
84		&$code($opts, $canonical, $2, $1);
85		return 1;
86	}
87	return 0;
88}
89
90package Option::Long;
91our @ISA = qw(Option);
92
93sub match
94{
95	my ($self, $_, $opts, $canonical, $code) = @_;
96	if (m/^\-\Q$$self\E$/) {
97		&$code($opts, $canonical, 1, $_);
98		return 1;
99	}
100	return 0;
101}
102
103package Option::LongArg0;
104our @ISA = qw(Option::Long);
105sub match
106{
107	my ($self, $_, $opts, $canonical, $code) = @_;
108	if (m/^\-\Q$$self\E$/) {
109		if (@main::ARGV > 0) {
110			&$code($opts, $canonical, (shift @main::ARGV), $_);
111			return 1;
112		} else {
113			die "Missing argument  for option -$$self\n";
114		}
115	}
116	return 0;
117}
118
119package Option::LongArg;
120our @ISA = qw(Option::LongArg0);
121
122sub match
123{
124	my ($self, $_, $opts, $canonical, $code) = @_;
125	if ($self->SUPER::match($_, $opts, $canonical, $code)) {
126		return 1;
127	}
128	if (m/^(-\Q$$self\E)\=(.*)$/) {
129		&$code($opts, $canonical, $2, $1);
130		return 1;
131	}
132	return 0;
133}
134
135package Option::Regexp;
136sub new
137{
138	my ($class, $re, $code) = @_;
139	bless {re => $re, code => $code}, $class;
140}
141
142sub setup
143{
144	return shift;
145}
146
147sub match
148{
149	my ($self, $arg, $opts) = @_;
150	if (my @l = ($arg =~ m/^$self->{re}$/)) {
151		&{$self->{code}}(@l);
152		return 1;
153	} else {
154		return 0;
155	}
156}
157
158package Options;
159
160sub new
161{
162	my ($class, $string, $code) = @_;
163
164	if (ref($string) eq 'Regexp') {
165		return Option::Regexp->new($string, $code);
166	}
167	my @alternates = split(/\|/, $string);
168
169	bless {alt => [map { Option->factory($_); } @alternates], code => $code}, $class;
170}
171
172sub setup
173{
174	my ($self, $allopts, $isarray) = @_;
175	$self->{alt}[0]->setup($allopts, $isarray);
176	return $self;
177}
178
179sub match
180{
181	my ($self, $arg, $opts) = @_;
182
183	my $canonical = ${$self->{alt}[0]};
184	for my $s (@{$self->{alt}}) {
185		if ($s->match($arg, $opts, $canonical, $self->{code})) {
186			return 1;
187		}
188	}
189	return 0;
190}
191
192# seems I spend my life rewriting option handlers, not surprisingly...
193package LT::Getopt;
194use LT::Util;
195
196
197# parsing an option 'all-static' will automatically add an
198# accessor $self->all_static   that maps to the option.
199
200sub add_option_accessor
201{
202	my ($self, $option, $isarray) = @_;
203	my $access = $option;
204	$access =~ s/^\-//;
205	$access =~ s/-/_/g;
206	my $actual = $isarray ?
207		sub {
208		    my $self = shift;
209		    $self->{opt}{$option} //= [];
210		    if (wantarray) {
211			    return @{$self->{opt}{$option}};
212		    } else {
213			    return scalar @{$self->{opt}{$option}};
214		    }
215		} : sub {
216		    my $self = shift;
217		    return $self->{opt}{$option};
218		};
219	my $callpkg = ref($self);
220	unless ($self->can($access)) {
221		no strict 'refs';
222		*{$callpkg."::$access"} = $actual;
223	}
224}
225
226sub create_options
227{
228	my ($self, @l) = @_;
229	my @options = ();
230	# first pass creates accessors
231	while (my $opt = shift @l) {
232		my $isarray = ($opt =~ s/\@$//);
233		# default code or not
234		my $code;
235		if (@l > 0 && ref($l[0]) eq 'CODE') {
236			$code = shift @l;
237		} else {
238			if ($isarray) {
239				$code = sub {
240				    my ($object, $canonical, $value) = @_;
241				    push(@{$object->{opt}{$canonical}}, $value);
242				};
243			} else {
244				$code = sub {
245				    my ($object, $canonical, $value) = @_;
246				    $object->{opt}{$canonical} = $value;
247				};
248			}
249		}
250		push(@options, Options->new($opt, $code)->setup($self, $isarray));
251	}
252	return @options;
253}
254
255sub handle_options
256{
257	my ($self, @l) = @_;
258
259	my @options = $self->create_options(@l);
260
261MAINLOOP:
262	while (@main::ARGV > 0) {
263		my $_ = shift @main::ARGV;
264		if (m/^\-\-$/) {
265			last;
266		}
267		if (m/^\-/) {
268			for my $opt (@options) {
269				if ($opt->match($_, $self)) {
270					next MAINLOOP;
271				}
272			}
273			shortdie "Unknown option $_\n";
274		} else {
275			unshift(@main::ARGV, $_);
276			last;
277		}
278	}
279}
280
281sub handle_permuted_options
282{
283	my ($self, @l) = @_;
284
285	my @options = $self->create_options(@l);
286
287	$self->{kept} = [];
288
289MAINLOOP2:
290	while (@main::ARGV > 0) {
291		my $_ = shift @main::ARGV;
292		if (m/^\-\-$/) {
293			next;   # XXX ?
294		}
295		if (m/^\-/) {
296			for my $opt (@options) {
297				if ($opt->match($_, $self)) {
298					next MAINLOOP2;
299				}
300			}
301		}
302		$self->keep_for_later($_);
303	}
304	@main::ARGV = @{$self->{kept}};
305}
306
307sub keep_for_later
308{
309	my ($self, @args) = @_;
310	push(@{$self->{kept}}, @args);
311}
312
313sub new
314{
315	my $class = shift;
316	bless {}, $class;
317}
318
3191;
320