1# $OpenBSD: Getopt.pm,v 1.12 2014/03/19 02:16:22 afresh1 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, $o) = @_; 25 if ($o =~ m/^(.)$/) { 26 return Option::Short->new($1); 27 } elsif ($o =~ m/^(.)\:$/) { 28 return Option::ShortArg->new($1); 29 } elsif ($o =~ m/^(\-?.)(?:\:\!|\!\:)$/) { 30 return Option::LongArg0->new($1); 31 } elsif ($o =~ m/^(\-?.)\!$/) { 32 return Option::Long->new($1); 33 } elsif ($o =~ m/^(\-?.*)\=$/) { 34 return Option::LongArg->new($1); 35 } elsif ($o =~ m/^(\-?.*)\:$/) { 36 return Option::LongArg0->new($1); 37 } elsif ($o =~ 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, $arg, $opts, $canonical, $code) = @_; 61 if ($arg =~ m/^\-\Q$$self\E$/) { 62 &$code($opts, $canonical, 1, $arg); 63 return 1; 64 } 65 if ($arg =~ 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, $arg, $opts, $canonical, $code) = @_; 79 if ($arg =~ m/^\-\Q$$self\E$/) { 80 &$code($opts, $canonical, (shift @main::ARGV), $arg); 81 return 1; 82 } 83 if ($arg =~ 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, $arg, $opts, $canonical, $code) = @_; 96 if ($arg =~ m/^\-\Q$$self\E$/) { 97 &$code($opts, $canonical, 1, $arg); 98 return 1; 99 } 100 return 0; 101} 102 103package Option::LongArg0; 104our @ISA = qw(Option::Long); 105sub match 106{ 107 my ($self, $arg, $opts, $canonical, $code) = @_; 108 if ($arg =~ m/^\-\Q$$self\E$/) { 109 if (@main::ARGV > 0) { 110 &$code($opts, $canonical, (shift @main::ARGV), $arg); 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, $arg, $opts, $canonical, $code) = @_; 125 if ($self->SUPER::match($arg, $opts, $canonical, $code)) { 126 return 1; 127 } 128 if ($arg =~ 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 $arg = shift @main::ARGV; 264 if ($arg =~ m/^\-\-$/) { 265 last; 266 } 267 if ($arg =~ m/^\-/) { 268 for my $opt (@options) { 269 if ($opt->match($arg, $self)) { 270 next MAINLOOP; 271 } 272 } 273 shortdie "Unknown option $arg\n"; 274 } else { 275 unshift(@main::ARGV, $arg); 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 $arg = shift @main::ARGV; 292 if ($arg =~ m/^\-\-$/) { 293 next; # XXX ? 294 } 295 if ($arg =~ m/^\-/) { 296 for my $opt (@options) { 297 if ($opt->match($arg, $self)) { 298 next MAINLOOP2; 299 } 300 } 301 } 302 $self->keep_for_later($arg); 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