Getopt.pm revision 1.14 
1# $OpenBSD: Getopt.pm,v 1.14 2023/07/06 08:29:26 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 v5.36;
19
20package Option;
21sub factory($class, $o)
22{
23	if ($o =~ m/^(.)$/) {
24		return Option::Short->new($1);
25	} elsif ($o =~ m/^(.)\:$/) {
26		return Option::ShortArg->new($1);
27	} elsif ($o =~ m/^(\-?.)(?:\:\!|\!\:)$/) {
28		return Option::LongArg0->new($1);
29	} elsif ($o =~ m/^(\-?.)\!$/) {
30		return Option::Long->new($1);
31	} elsif ($o =~ m/^(\-?.*)\=$/) {
32		return Option::LongArg->new($1);
33	} elsif ($o =~ m/^(\-?.*)\:$/) {
34		return Option::LongArg0->new($1);
35	} elsif ($o =~ m/^(\-?.*)$/) {
36		return Option::Long->new($1);
37	}
38}
39
40sub new($class, $v)
41{
42	bless \$v, $class;
43}
44
45sub setup($self, $opts, $isarray)
46{
47	$opts->add_option_accessor($$self, $isarray);
48	return $self;
49}
50
51package Option::Short;
52our @ISA = qw(Option);
53
54sub match($self, $arg, $opts, $canonical, $code)
55{
56	if ($arg =~ m/^\-\Q$$self\E$/) {
57		&$code($opts, $canonical, 1, $arg);
58		return 1;
59	}
60	if ($arg =~ m/^(\-\Q$$self\E)(.*)$/) {
61		unshift(@main::ARGV, "-$2");
62		&$code($opts, $canonical, 1, $1);
63		return 1;
64	}
65	return 0;
66}
67
68package Option::ShortArg;
69our @ISA = qw(Option::Short);
70
71sub match($self, $arg, $opts, $canonical, $code)
72{
73	if ($arg =~ m/^\-\Q$$self\E$/) {
74		&$code($opts, $canonical, (shift @main::ARGV), $arg);
75		return 1;
76	}
77	if ($arg =~ m/^(\-\Q$$self\E)(.*)$/) {
78		&$code($opts, $canonical, $2, $1);
79		return 1;
80	}
81	return 0;
82}
83
84package Option::Long;
85our @ISA = qw(Option);
86
87sub match($self, $arg, $opts, $canonical, $code)
88{
89	if ($arg =~ m/^\-\Q$$self\E$/) {
90		&$code($opts, $canonical, 1, $arg);
91		return 1;
92	}
93	return 0;
94}
95
96package Option::LongArg0;
97our @ISA = qw(Option::Long);
98sub match($self, $arg, $opts, $canonical, $code)
99{
100	if ($arg =~ m/^\-\Q$$self\E$/) {
101		if (@main::ARGV > 0) {
102			&$code($opts, $canonical, (shift @main::ARGV), $arg);
103			return 1;
104		} else {
105			die "Missing argument  for option -$$self\n";
106		}
107	}
108	return 0;
109}
110
111package Option::LongArg;
112our @ISA = qw(Option::LongArg0);
113
114sub match($self, $arg, $opts, $canonical, $code)
115{
116	if ($self->SUPER::match($arg, $opts, $canonical, $code)) {
117		return 1;
118	}
119	if ($arg =~ m/^(-\Q$$self\E)\=(.*)$/) {
120		&$code($opts, $canonical, $2, $1);
121		return 1;
122	}
123	return 0;
124}
125
126package Option::Regexp;
127sub new($class, $re, $code)
128{
129	bless {re => $re, code => $code}, $class;
130}
131
132sub setup($self, $, $)
133{
134	return $self;
135}
136
137sub match($self, $arg, $opts)
138{
139	if (my @l = ($arg =~ m/^$self->{re}$/)) {
140		&{$self->{code}}(@l);
141		return 1;
142	} else {
143		return 0;
144	}
145}
146
147package Options;
148
149sub new($class, $string, $code)
150{
151	if (ref($string) eq 'Regexp') {
152		return Option::Regexp->new($string, $code);
153	}
154	my @alternates = split(/\|/, $string);
155
156	bless {
157		alt => [map { Option->factory($_); } @alternates],
158		code => $code
159	}, $class;
160}
161
162sub setup($self, $allopts, $isarray)
163{
164	$self->{alt}[0]->setup($allopts, $isarray);
165	return $self;
166}
167
168sub match($self, $arg, $opts)
169{
170
171	my $canonical = ${$self->{alt}[0]};
172	for my $s (@{$self->{alt}}) {
173		if ($s->match($arg, $opts, $canonical, $self->{code})) {
174			return 1;
175		}
176	}
177	return 0;
178}
179
180# seems I spend my life rewriting option handlers, not surprisingly...
181package LT::Getopt;
182use LT::Util;
183
184
185# parsing an option 'all-static' will automatically add an
186# accessor $self->all_static   that maps to the option.
187
188sub add_option_accessor($self, $option, $isarray)
189{
190	my $access = $option;
191	$access =~ s/^\-//;
192	$access =~ s/-/_/g;
193	my $actual = $isarray ?
194		sub($self) {
195		    $self->{opt}{$option} //= [];
196		    if (wantarray) {
197			    return @{$self->{opt}{$option}};
198		    } else {
199			    return scalar @{$self->{opt}{$option}};
200		    }
201		} : sub($self) {
202		    return $self->{opt}{$option};
203		};
204	my $callpkg = ref($self);
205	unless ($self->can($access)) {
206		no strict 'refs';
207		*{$callpkg."::$access"} = $actual;
208	}
209}
210
211sub create_options($self, @l)
212{
213	my @options = ();
214	# first pass creates accessors
215	push(@l, '-tag=', sub { $self->add_tag($_[2]); });
216	while (my $opt = shift @l) {
217		my $isarray = ($opt =~ s/\@$//);
218		# default code or not
219		my $code;
220		if (@l > 0 && ref($l[0]) eq 'CODE') {
221			$code = shift @l;
222		} else {
223			if ($isarray) {
224				$code = sub {
225				    my ($object, $canonical, $value) = @_;
226				    push(@{$object->{opt}{$canonical}}, $value);
227				};
228			} else {
229				$code = sub {
230				    my ($object, $canonical, $value) = @_;
231				    $object->{opt}{$canonical} = $value;
232				};
233			}
234		}
235		push(@options,
236		    Options->new($opt, $code)->setup($self, $isarray));
237	}
238	return @options;
239}
240
241sub handle_options($self, @l)
242{
243	my @options = $self->create_options(@l);
244
245MAINLOOP:
246	while (@main::ARGV > 0) {
247		my $arg = shift @main::ARGV;
248		if ($arg =~ m/^\-\-$/) {
249			last;
250		}
251		if ($arg =~ m/^\-/) {
252			for my $opt (@options) {
253				if ($opt->match($arg, $self)) {
254					next MAINLOOP;
255				}
256			}
257			shortdie "Unknown option $arg\n";
258		} else {
259			unshift(@main::ARGV, $arg);
260			last;
261		}
262	}
263}
264
265sub handle_permuted_options($self, @l)
266{
267	my @options = $self->create_options(@l);
268
269	$self->{kept} = [];
270
271MAINLOOP2:
272	while (@main::ARGV > 0) {
273		my $arg = shift @main::ARGV;
274		if ($arg =~ m/^\-\-$/) {
275			next;   # XXX ?
276		}
277		if ($arg =~ m/^\-/) {
278			for my $opt (@options) {
279				if ($opt->match($arg, $self)) {
280					next MAINLOOP2;
281				}
282			}
283		}
284		$self->keep_for_later($arg);
285	}
286	@main::ARGV = @{$self->{kept}};
287}
288
289sub keep_for_later($self, @args)
290{
291	push(@{$self->{kept}}, @args);
292}
293
294sub new($class)
295{
296	bless {}, $class;
297}
298
2991;
300