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