1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
#! @PERL@ -w
# This script is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 2 as
# published by the Free Software Foundation.
#
# See the COPYING and AUTHORS files for more details.
use strict;
my $opts = '';
my @words;
my $found_sep = 0;
foreach my $arg (@ARGV) {
if (!$found_sep && $arg eq '--') {
$found_sep = 1;
}
else {
if (!$found_sep) {
$opts .= ' ' . $arg;
}
else {
push @words, $arg;
}
}
}
# there is no reason to parse
# the opts if there are no args.
if (!@words) {
print " --\n";
exit;
}
my $short_opts = '';
my @long_opts;
# nothing fancy to see here; this script provides minimal compatibility
# with the getopt from util-linux until a cross platform binary exists.
# We silently ignore option -q.
if ($opts =~ /^\s*(?:-q\s+)?-o ([a-zA-Z:]*)?(\s+--long .*)*/) {
$short_opts = $1;
if ($2) {
my $long_opts = $2;
$long_opts =~ s/^\s*--long //g;
$long_opts =~ s/ --long /,/g;
@long_opts = split(/,/,$long_opts);
}
}
my @barewords = ('--');
my @options;
# set the previous option name when a param is required
my $need_param;
sub quote_word
{
my $word = shift;
$word =~ s/'/'\\''/;
return "'$word'";
}
# there can be a second separator, to inhibit processing following arguments
# as options
$found_sep = 0;
foreach my $word (@words) {
if ($word eq '--') {
$found_sep = 1;
next;
}
# allow '-' to be an option value
if ($found_sep || (!$need_param && $word !~ /^-./)) {
push @barewords, quote_word($word);
next;
}
if ($need_param) {
die "expecting param for $need_param" if $word =~ /^-./;
push @options, quote_word($word);
$need_param = undef;
next;
}
# process short options
if ($word =~ s/^-([^-])/$1/) {
my @letters = reverse(split(//,$word));
while (@letters) {
my $letter = pop @letters;
my $found = grep(/$letter/, $short_opts);
push @options, '-'.$letter;
die "illegal option: $letter" if !$found;
# handle options with optional parameters
if (grep(/${letter}::/, $short_opts)) {
if (scalar(@letters) == 0) {
push @options, quote_word('');
} else {
# what looked like more short options
# are in fact the optional parameters
push @options, quote_word(join('', reverse @letters));
}
last;
}
# handle options with mandatory parameters
if (grep(/$letter:/, $short_opts)) {
if (scalar(@letters) == 0) {
$need_param = $letter;
} else {
# short options can have args
# embedded in the short option list
push @options, quote_word(join('', reverse @letters));
@letters = ();
}
}
}
}
# process long options
if ($word =~ s/^--//) {
my $param = '';
if ($word =~ /(.*)=(.*)/) {
$word = $1;
$param = $2;
}
my ($found) = grep(/^$word:{0,2}$/,@long_opts);
die "illegal option: $word" if !$found;
die "$word: unexpected paramater $param" if $found !~ /:$/ && $param ne '';
$need_param = $word if $found =~ /[^:]:$/ && $param eq '';
push @options, "--$word";
push @options, quote_word($param) if $param || $found =~ /::$/;
}
}
print " @options @barewords\n"
|
