1# $OpenBSD: Getopt.pm,v 1.13 2017/05/27 10:35:41 zhuk 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 push(@l, '-tag=', sub { $self->add_tag($_[2]); }); 232 while (my $opt = shift @l) { 233 my $isarray = ($opt =~ s/\@$//); 234 # default code or not 235 my $code; 236 if (@l > 0 && ref($l[0]) eq 'CODE') { 237 $code = shift @l; 238 } else { 239 if ($isarray) { 240 $code = sub { 241 my ($object, $canonical, $value) = @_; 242 push(@{$object->{opt}{$canonical}}, $value); 243 }; 244 } else { 245 $code = sub { 246 my ($object, $canonical, $value) = @_; 247 $object->{opt}{$canonical} = $value; 248 }; 249 } 250 } 251 push(@options, Options->new($opt, $code)->setup($self, $isarray)); 252 } 253 return @options; 254} 255 256sub handle_options 257{ 258 my ($self, @l) = @_; 259 260 my @options = $self->create_options(@l); 261 262MAINLOOP: 263 while (@main::ARGV > 0) { 264 my $arg = shift @main::ARGV; 265 if ($arg =~ m/^\-\-$/) { 266 last; 267 } 268 if ($arg =~ m/^\-/) { 269 for my $opt (@options) { 270 if ($opt->match($arg, $self)) { 271 next MAINLOOP; 272 } 273 } 274 shortdie "Unknown option $arg\n"; 275 } else { 276 unshift(@main::ARGV, $arg); 277 last; 278 } 279 } 280} 281 282sub handle_permuted_options 283{ 284 my ($self, @l) = @_; 285 286 my @options = $self->create_options(@l); 287 288 $self->{kept} = []; 289 290MAINLOOP2: 291 while (@main::ARGV > 0) { 292 my $arg = shift @main::ARGV; 293 if ($arg =~ m/^\-\-$/) { 294 next; # XXX ? 295 } 296 if ($arg =~ m/^\-/) { 297 for my $opt (@options) { 298 if ($opt->match($arg, $self)) { 299 next MAINLOOP2; 300 } 301 } 302 } 303 $self->keep_for_later($arg); 304 } 305 @main::ARGV = @{$self->{kept}}; 306} 307 308sub keep_for_later 309{ 310 my ($self, @args) = @_; 311 push(@{$self->{kept}}, @args); 312} 313 314sub new 315{ 316 my $class = shift; 317 bless {}, $class; 318} 319 3201; 321