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