Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 92 lines (87 sloc) 2.844 kB
a06dd3c @sorear Mergeback and factor out OpHelpers/GetOptLong
authored
1 # GNU getopt_long compatible options parser
2
3 module GetOptLong;
4
5 sub GetOptions(*@pairs, :$permute = True, :onerror($onerror_), :onarg($onarg_)) is export {
6 my @nonopt;
7 my $onerror = $onerror_ // sub ($message) {
8 note $message;
9 exit 1;
10 };
11 my $onarg = $onarg_ // sub ($arg) {
12 push @nonopt, $arg;
13 if !$permute {
14 push @nonopt, @*ARGS;
15 @*ARGS = ();
16 }
17 };
18 my @unpk;
19 sub pick_long_option($st) {
20 my @cand = grep { chars($_[0]) > 1 &&
21 substr($_[0],0,chars($st)) eq $st }, @unpk;
22 $onerror.("Ambiguous long option --$st; could be any of {map *[0], @cand}") if @cand > 1;
23 $onerror.("No match for long option --$st") if !@cand;
24 @cand[0];
25 }
26 sub pick_short_option($st) {
27 my @cand = grep { $_[0] eq $st }, @unpk;
28 $onerror.("No match for short option -$st") if !@cand;
29 @cand[0];
30 }
31 for @pairs -> $p {
32 my $key = $p.key;
33 my $type = '';
34 if $key ~~ /<[:=]>s$/ {
35 $type = ~$/;
36 $key = substr($key, 0, $/.from);
37 }
38 for $key.split('|') {
39 push @unpk, [ $_, $type, $p.value ];
40 }
41 }
42
43 while @*ARGS {
44 my $opt = shift @*ARGS;
45 if $opt eq '--' {
46 $onarg.(shift @*ARGS) while @*ARGS;
47 last;
48 }
49 elsif substr($opt, 0, 2) eq '--' {
50 if $opt ~~ /'='/ {
51 my $obl = pick_long_option(substr($opt, 2, $/.from - 2));
52 $onerror.("Long option --$obl[0] does not accept an argument")
53 if $obl[1] eq '';
54 $obl[2].(substr($opt, $/.to));
55 } else {
56 my $obl = pick_long_option(substr($opt, 2));
57 if $obl[1] eq '=s' {
58 $onerror.("Argument required for long option --$obl[0]")
59 unless @*ARGS;
60 $obl[2].(shift @*ARGS);
61 } else {
62 $obl[2].(Str);
63 }
64 }
65 }
66 elsif chars($opt) > 1 && substr($opt, 0, 1) eq '-' {
67 $opt = substr($opt, 1);
68 while $opt ne '' {
69 my $obl = pick_short_option(substr($opt, 0, 1));
70 $opt = substr($opt, 1);
71 if $obl[1] eq '' || $obl[1] eq ':s' && $opt eq '' {
72 $obl[2].(Str);
73 }
74 elsif $opt ne '' {
75 $obl[2].($opt);
76 $opt = '';
77 }
78 else {
79 $onerror.("Argument required for short option -$obl[0]")
80 unless @*ARGS;
81 $obl[2].(shift @*ARGS);
82 }
83 }
84 }
85 else {
86 $onarg.($opt);
87 }
88 }
89
90 @*ARGS = @nonopt;
91 }
Something went wrong with that request. Please try again.