line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#======================================================================== |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Badger::Utils |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# DESCRIPTION |
6
|
|
|
|
|
|
|
# Module implementing various useful utility functions. |
7
|
|
|
|
|
|
|
# |
8
|
|
|
|
|
|
|
# AUTHOR |
9
|
|
|
|
|
|
|
# Andy Wardley |
10
|
|
|
|
|
|
|
# |
11
|
|
|
|
|
|
|
#======================================================================== |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
package Badger::Utils; |
14
|
|
|
|
|
|
|
|
15
|
70
|
|
|
70
|
|
1065
|
use strict; |
|
70
|
|
|
|
|
170
|
|
|
70
|
|
|
|
|
1830
|
|
16
|
70
|
|
|
70
|
|
295
|
use warnings; |
|
70
|
|
|
|
|
118
|
|
|
70
|
|
|
|
|
1815
|
|
17
|
70
|
|
|
70
|
|
322
|
use base 'Badger::Exporter'; |
|
70
|
|
|
|
|
152
|
|
|
70
|
|
|
|
|
7695
|
|
18
|
70
|
|
|
70
|
|
414
|
use File::Path; |
|
70
|
|
|
|
|
136
|
|
|
70
|
|
|
|
|
4949
|
|
19
|
70
|
|
|
70
|
|
388
|
use Scalar::Util qw( blessed ); |
|
70
|
|
|
|
|
129
|
|
|
70
|
|
|
|
|
3176
|
|
20
|
70
|
|
|
70
|
|
377
|
use Badger::Constants 'HASH ARRAY PKG DELIMITER BLANK TRUE FALSE'; |
|
70
|
|
|
|
|
117
|
|
|
70
|
|
|
|
|
641
|
|
21
|
|
|
|
|
|
|
use Badger::Debug |
22
|
70
|
|
|
|
|
335
|
import => ':dump', |
23
|
70
|
|
|
70
|
|
420
|
default => 0; |
|
70
|
|
|
|
|
113
|
|
24
|
70
|
|
|
70
|
|
399
|
use overload; |
|
70
|
|
|
|
|
115
|
|
|
70
|
|
|
|
|
372
|
|
25
|
|
|
|
|
|
|
use constant { |
26
|
70
|
|
|
|
|
78176
|
UTILS => 'Badger::Utils', |
27
|
|
|
|
|
|
|
CLASS => 0, |
28
|
|
|
|
|
|
|
FILE => 1, |
29
|
|
|
|
|
|
|
LOADED => 2, |
30
|
70
|
|
|
70
|
|
4154
|
}; |
|
70
|
|
|
|
|
122
|
|
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
our $VERSION = 0.02; |
33
|
|
|
|
|
|
|
our $ERROR = ''; |
34
|
|
|
|
|
|
|
our $WARN = sub { warn @_ }; # for testing - see t/core/utils.t |
35
|
|
|
|
|
|
|
our $MESSAGES = { }; |
36
|
|
|
|
|
|
|
our $HELPERS = { # keep this compact in case we don't need to use it |
37
|
|
|
|
|
|
|
'Digest::MD5' => 'md5 md5_hex md5_base64', |
38
|
|
|
|
|
|
|
'Scalar::Util' => 'blessed dualvar isweak readonly refaddr reftype |
39
|
|
|
|
|
|
|
tainted weaken isvstring looks_like_number |
40
|
|
|
|
|
|
|
set_prototype', |
41
|
|
|
|
|
|
|
'List::Util' => 'first max maxstr min minstr reduce shuffle sum', |
42
|
|
|
|
|
|
|
'List::MoreUtils' => 'any all none notall true false firstidx |
43
|
|
|
|
|
|
|
first_index lastidx last_index insert_after |
44
|
|
|
|
|
|
|
insert_after_string apply after after_incl before |
45
|
|
|
|
|
|
|
before_incl indexes firstval first_value lastval |
46
|
|
|
|
|
|
|
last_value each_array each_arrayref pairwise |
47
|
|
|
|
|
|
|
natatime mesh zip uniq minmax', |
48
|
|
|
|
|
|
|
'Hash::Util' => 'lock_keys unlock_keys lock_value unlock_value |
49
|
|
|
|
|
|
|
lock_hash unlock_hash hash_seed', |
50
|
|
|
|
|
|
|
'Badger::Date' => 'DATE Date Today', |
51
|
|
|
|
|
|
|
'Badger::Timestamp' => 'TIMESTAMP TS Timestamp Now', |
52
|
|
|
|
|
|
|
'Badger::Logic' => 'LOGIC Logic', |
53
|
|
|
|
|
|
|
'Badger::Duration' => 'DURATION Duration', |
54
|
|
|
|
|
|
|
'Badger::URL' => 'URL', |
55
|
|
|
|
|
|
|
'Badger::Filter' => 'FILTER Filter', |
56
|
|
|
|
|
|
|
'Badger::Filesystem' => 'FS File Dir Bin Cwd', |
57
|
|
|
|
|
|
|
'Badger::Filesystem::Virtual' |
58
|
|
|
|
|
|
|
=> 'VFS', |
59
|
|
|
|
|
|
|
}; |
60
|
|
|
|
|
|
|
our $DELEGATES; # fill this from $HELPERS on demand |
61
|
|
|
|
|
|
|
our $RANDOM_NAME_LENGTH = 32; |
62
|
|
|
|
|
|
|
our $TEXT_WRAP_WIDTH = 78; |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
__PACKAGE__->export_any(qw( |
66
|
|
|
|
|
|
|
UTILS blessed is_object numlike textlike truelike falselike |
67
|
|
|
|
|
|
|
params self_params plural |
68
|
|
|
|
|
|
|
odd_params xprintf dotid random_name camel_case CamelCase wrap |
69
|
|
|
|
|
|
|
permute_fragments plurality inflect split_to_list extend merge merge_hash |
70
|
|
|
|
|
|
|
list_each hash_each join_uri resolve_uri |
71
|
|
|
|
|
|
|
)); |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
__PACKAGE__->export_fail(\&_export_fail); |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# looks_like_number() is such a mouthful. I prefer numlike() to go with textlike() |
76
|
|
|
|
|
|
|
*numlike = \&Scalar::Util::looks_like_number; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# it would be too confusing not to have this alias |
79
|
|
|
|
|
|
|
*CamelCase = \&camel_case; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
sub _export_fail { |
83
|
101
|
|
|
101
|
|
264
|
my ($class, $target, $symbol, $more_symbols) = @_; |
84
|
101
|
|
66
|
|
|
388
|
$DELEGATES ||= _expand_helpers($HELPERS); |
85
|
101
|
|
50
|
|
|
385
|
my $helper = $DELEGATES->{ $symbol } || return 0; |
86
|
101
|
50
|
|
|
|
6376
|
require $helper->[FILE] unless $helper->[LOADED]; |
87
|
101
|
|
|
|
|
4649
|
$class->export_symbol($target, $symbol, \&{ $helper->[CLASS].PKG.$symbol }); |
|
101
|
|
|
|
|
911
|
|
88
|
101
|
|
|
|
|
376
|
return 1; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub _expand_helpers { |
92
|
|
|
|
|
|
|
# invert { x => 'a b c' } into { a => 'x', b => 'x', c => 'x' } |
93
|
70
|
|
|
70
|
|
109
|
my $helpers = shift; |
94
|
|
|
|
|
|
|
return { |
95
|
|
|
|
|
|
|
map { |
96
|
70
|
|
|
|
|
266
|
my $name = $_; # e.g. Scalar::Util |
|
910
|
|
|
|
|
942
|
|
97
|
910
|
|
|
|
|
1126
|
my $file = module_file($name); # e.g. Scalar/Util.pm |
98
|
5530
|
|
|
|
|
14566
|
map { $_ => [$name, $file, 0] } # third item is loaded flag |
99
|
910
|
|
|
|
|
7263
|
split(DELIMITER, $helpers->{ $name }) |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
keys %$helpers |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
sub is_object($$) { |
106
|
737
|
100
|
|
737
|
1
|
3559
|
blessed $_[1] && $_[1]->isa($_[0]); |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub textlike($) { |
110
|
95
|
100
|
100
|
95
|
1
|
354
|
! ref $_[0] # check if $[0] is a non-reference |
111
|
|
|
|
|
|
|
|| blessed $_[0] # or an object with an overloaded |
112
|
|
|
|
|
|
|
&& overload::Method($_[0], '""'); # '""' stringification operator |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub truelike($) { |
116
|
11
|
100
|
|
11
|
0
|
13
|
falselike($_[0]) ? FALSE : TRUE; |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
sub falselike($) { |
120
|
22
|
100
|
100
|
22
|
0
|
201
|
(! $_[0] || $_[0] =~ /^(0|off|no|none|false)$/i) ? TRUE : FALSE; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub params { |
124
|
|
|
|
|
|
|
# enable $DEBUG to track down calls to params() that pass an odd number |
125
|
|
|
|
|
|
|
# of arguments, typically when the rhs argument returns an empty list, |
126
|
|
|
|
|
|
|
# e.g. $obj->foo( x => this_returns_empty_list() ) |
127
|
17
|
|
|
17
|
1
|
55
|
my @args = @_; |
128
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { |
129
|
3
|
|
|
1
|
|
36
|
odd_params(@args); |
130
|
17
|
|
|
|
|
32
|
} if DEBUG; |
131
|
|
|
|
|
|
|
|
132
|
15
|
100
|
100
|
|
|
69
|
@_ && ref $_[0] eq HASH ? shift : { @_ }; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub self_params { |
136
|
3
|
|
|
3
|
1
|
26
|
my @args = @_; |
137
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { |
138
|
2
|
|
|
0
|
|
22
|
odd_params(@args); |
139
|
3
|
|
|
|
|
10
|
} if DEBUG; |
140
|
|
|
|
|
|
|
|
141
|
1
|
100
|
66
|
|
|
9
|
(shift, @_ && ref $_[0] eq HASH ? shift : { @_ }); |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
sub odd_params { |
145
|
1
|
|
|
1
|
1
|
6
|
my $method = (caller(2))[3]; |
146
|
|
|
|
|
|
|
$WARN->( |
147
|
|
|
|
|
|
|
"$method() called with an odd number of arguments: ", |
148
|
1
|
50
|
|
|
|
5
|
join(', ', map { defined $_ ? $_ : '' } @_), |
|
3
|
|
|
|
|
29
|
|
149
|
|
|
|
|
|
|
"\n" |
150
|
|
|
|
|
|
|
); |
151
|
1
|
|
|
|
|
6
|
my $i = 3; |
152
|
1
|
|
|
|
|
2
|
while (1) { |
153
|
4
|
|
|
|
|
20
|
my @info = caller($i); |
154
|
4
|
100
|
|
|
|
18
|
last unless @info; |
155
|
3
|
|
|
|
|
7
|
my ($pkg, $file, $line, $sub) = @info; |
156
|
3
|
|
|
|
|
13
|
$WARN->( |
157
|
|
|
|
|
|
|
sprintf( |
158
|
|
|
|
|
|
|
"%4s: Called from %s in %s at line %s\n", |
159
|
|
|
|
|
|
|
'#' . ($i++ - 2), $sub, $file, $line |
160
|
|
|
|
|
|
|
) |
161
|
|
|
|
|
|
|
); |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub module_file { |
167
|
910
|
|
|
910
|
1
|
866
|
my $file = shift; |
168
|
910
|
|
|
|
|
1808
|
$file =~ s[::][/]g; |
169
|
910
|
|
|
|
|
1285
|
$file .= '.pm'; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
sub xprintf { |
173
|
1895
|
|
|
1895
|
1
|
2110
|
my $format = shift; |
174
|
1895
|
|
|
|
|
2990
|
my @args = @_; |
175
|
1895
|
|
|
|
|
2741
|
$format =~ |
176
|
|
|
|
|
|
|
s{ < (\d+) |
177
|
|
|
|
|
|
|
(?: :( [#\-\+ ]? [\w\.]+ ) )? |
178
|
|
|
|
|
|
|
(?: \| (.*?) )? |
179
|
|
|
|
|
|
|
> |
180
|
48
|
100
|
100
|
|
|
234
|
} |
181
|
|
|
|
|
|
|
{ defined $3 |
182
|
|
|
|
|
|
|
? _xprintf_ifdef(\@args, $1, $2, $3) |
183
|
|
|
|
|
|
|
: '%' . $1 . '$' . ($2 || 's') |
184
|
70
|
|
|
70
|
|
40615
|
}egx; |
|
70
|
|
|
|
|
833
|
|
|
70
|
|
|
|
|
406
|
|
185
|
1895
|
|
|
|
|
9605
|
no if $] > 5.021, warnings => "redundant"; |
186
|
|
|
|
|
|
|
sprintf($format, @_); |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
3
|
|
|
3
|
|
15
|
sub _xprintf_ifdef { |
190
|
3
|
100
|
|
|
|
10
|
my ($args, $n, $format, $text) = @_; |
191
|
2
|
50
|
|
|
|
10
|
if (defined $args->[$n-1]) { |
192
|
2
|
|
|
|
|
15
|
$format = 's' unless defined $format; |
193
|
2
|
|
|
|
|
7
|
$format = '%' . $n . '$' . $format; |
194
|
2
|
|
|
|
|
5
|
$text =~ s/\?/$format/g; |
195
|
|
|
|
|
|
|
return $text; |
196
|
|
|
|
|
|
|
} |
197
|
1
|
|
|
|
|
3
|
else { |
198
|
|
|
|
|
|
|
return ''; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
83
|
|
|
83
|
1
|
109
|
sub dotid { |
203
|
83
|
|
|
|
|
207
|
my $text = shift; # munge $text to canonical lower case and dotted form |
204
|
83
|
|
|
|
|
213
|
$text =~ s/\W+/./g; # e.g. Foo::Bar ==> Foo.Bar |
205
|
|
|
|
|
|
|
return lc $text; # e.g. Foo.Bar ==> foo.bar |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
sub camel_case { |
209
|
|
|
|
|
|
|
join( |
210
|
|
|
|
|
|
|
BLANK, |
211
|
132
|
|
|
132
|
1
|
158
|
map { |
|
132
|
|
|
|
|
207
|
|
|
141
|
|
|
|
|
492
|
|
212
|
|
|
|
|
|
|
map { ucfirst $_ } |
213
|
|
|
|
|
|
|
split '_' |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
@_ |
216
|
|
|
|
|
|
|
); |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
5
|
|
66
|
5
|
1
|
12
|
sub random_name { |
220
|
5
|
|
|
|
|
15
|
my $length = shift || $RANDOM_NAME_LENGTH; |
221
|
5
|
|
|
|
|
19
|
my $name = ''; |
222
|
|
|
|
|
|
|
require Digest::MD5; |
223
|
5
|
|
|
|
|
13
|
|
224
|
7
|
|
|
|
|
95
|
while (length $name < $length) { |
225
|
|
|
|
|
|
|
$name .= Digest::MD5::md5_hex( |
226
|
|
|
|
|
|
|
time(), rand(), $$, { }, @_ |
227
|
|
|
|
|
|
|
); |
228
|
5
|
|
|
|
|
28
|
} |
229
|
|
|
|
|
|
|
return substr($name, 0, $length); |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
19
|
|
|
19
|
1
|
52
|
sub alternates { |
233
|
|
|
|
|
|
|
my $text = shift; |
234
|
19
|
100
|
|
|
|
151
|
return [ |
235
|
|
|
|
|
|
|
$text =~ /\|/ |
236
|
|
|
|
|
|
|
? split(qr<\|>, $text, -1) # alternates: (foo|bar) as ['foo', 'bar'] |
237
|
|
|
|
|
|
|
: ('', $text) # optional (foo) as (|foo) as ['', 'foo'] |
238
|
|
|
|
|
|
|
]; |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
0
|
|
|
0
|
1
|
0
|
sub wrap { |
242
|
0
|
|
0
|
|
|
0
|
my $text = shift; |
243
|
0
|
|
0
|
|
|
0
|
my $width = shift || $TEXT_WRAP_WIDTH; |
244
|
0
|
|
|
|
|
0
|
my $indent = shift || 0; |
245
|
0
|
|
|
|
|
0
|
my @words = split(/\s+/, $text); |
246
|
0
|
|
|
|
|
0
|
my (@lines, @line, $length); |
247
|
|
|
|
|
|
|
my $total = 0; |
248
|
0
|
|
|
|
|
0
|
|
249
|
0
|
|
0
|
|
|
0
|
while (@words) { |
250
|
0
|
0
|
0
|
|
|
0
|
$length = length $words[0] || (shift(@words), next); |
251
|
0
|
0
|
|
|
|
0
|
if ($total + $length > 74 || $words[0] eq '\n') { |
252
|
0
|
|
|
|
|
0
|
shift @words if $words[0] eq '\n'; |
253
|
0
|
|
|
|
|
0
|
push(@lines, join(" ", @line)); |
254
|
0
|
|
|
|
|
0
|
@line = (); |
255
|
|
|
|
|
|
|
$total = 0; |
256
|
|
|
|
|
|
|
} |
257
|
0
|
|
|
|
|
0
|
else { |
258
|
0
|
|
|
|
|
0
|
$total += $length + 1; # account for spaces joining words |
259
|
|
|
|
|
|
|
push(@line, shift @words); |
260
|
|
|
|
|
|
|
} |
261
|
0
|
0
|
|
|
|
0
|
} |
262
|
0
|
|
|
|
|
0
|
push(@lines, join(" ", @line)) if @line; |
263
|
|
|
|
|
|
|
return join( |
264
|
|
|
|
|
|
|
"\n" . (' ' x $indent), |
265
|
|
|
|
|
|
|
@lines |
266
|
|
|
|
|
|
|
); |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
|
270
|
54
|
|
|
54
|
1
|
101
|
sub permute_fragments { |
271
|
54
|
|
|
|
|
75
|
my $input = shift; |
272
|
|
|
|
|
|
|
my (@frags, @outputs); |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
# Lookup all the (a) optional fragments and (a|b|c) alternate fragments |
275
|
|
|
|
|
|
|
# replace them with %s. This gives us an sprintf format that we can later |
276
|
|
|
|
|
|
|
# user to re-fill the fragment slots. Meanwhile create a list of @frags |
277
|
|
|
|
|
|
|
# with each item corresponding to a (...) fragment which is represented |
278
|
|
|
|
|
|
|
# by a list reference containing the alternates. e.g. the input |
279
|
|
|
|
|
|
|
# string 'Fo(o|p) Ba(r|z)' generates @frags as ( ['o','p'], ['r','z'] ), |
280
|
|
|
|
|
|
|
# leaving $input set to 'Fo%s Ba%s'. We treat (foo) as sugar for (|foo), |
281
|
|
|
|
|
|
|
# so that 'Template(X)' is permuted as ('Template', 'TemplateX'), for |
282
|
|
|
|
|
|
|
# example. |
283
|
54
|
|
|
|
|
182
|
|
284
|
|
|
|
|
|
|
$input =~ |
285
|
|
|
|
|
|
|
s/ |
286
|
|
|
|
|
|
|
\( ( .*? ) \) |
287
|
19
|
|
|
|
|
72
|
/ |
288
|
19
|
|
|
|
|
65
|
push(@frags, alternates($1)); |
289
|
|
|
|
|
|
|
'%s'; |
290
|
|
|
|
|
|
|
/gex; |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
# If any of the fragments have multiple values then $format will still contain |
293
|
|
|
|
|
|
|
# one or more '%s' tokens and @frags will have the same number of list refs |
294
|
|
|
|
|
|
|
# in it, one for each fragment. To iterate across all permutations of the |
295
|
|
|
|
|
|
|
# fragment values, we calculate the product P of the sizes of all the lists in |
296
|
|
|
|
|
|
|
# @frags and loop from 0 to P-1. Then we use a div and a mod to get the right |
297
|
|
|
|
|
|
|
# value for each fragment, for each iteration. We divide $n by the product of |
298
|
|
|
|
|
|
|
# all fragment lists to the right of the current fragment and mod it by the size |
299
|
|
|
|
|
|
|
# of the current fragment list. It's effectively counting with a different base |
300
|
|
|
|
|
|
|
# for each column. e.g. consider 3 fragments with 7, 3, and 5 values respectively |
301
|
|
|
|
|
|
|
# [7] [3] [5] P = 7 * 3 * 5 = 105 |
302
|
|
|
|
|
|
|
# [n / 15 % 7] [n / 5 % 3] [n % 5] for 0 < n < P |
303
|
54
|
100
|
|
|
|
149
|
|
304
|
18
|
|
|
|
|
33
|
if (@frags) { |
|
18
|
|
|
|
|
73
|
|
305
|
18
|
|
|
|
|
82
|
my $product = 1; $product *= @$_ for @frags; |
306
|
38
|
|
|
|
|
50
|
for (my $n = 0; $n < $product; $n++) { |
307
|
|
|
|
|
|
|
my $divisor = 1; |
308
|
38
|
|
|
|
|
63
|
my @args = reverse map { |
|
42
|
|
|
|
|
151
|
|
309
|
42
|
|
|
|
|
61
|
my $item = $_->[ $n / $divisor % @$_ ]; |
310
|
42
|
|
|
|
|
91
|
$divisor *= @$_; |
311
|
|
|
|
|
|
|
$item; |
312
|
38
|
|
|
|
|
196
|
} reverse @frags; # working backwards from right to left |
313
|
|
|
|
|
|
|
push(@outputs, sprintf($input, @args)); |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
} |
316
|
36
|
|
|
|
|
52
|
else { |
317
|
|
|
|
|
|
|
push(@outputs, $input); |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
return wantarray |
320
|
54
|
50
|
|
|
|
229
|
? @outputs |
321
|
|
|
|
|
|
|
: \@outputs; |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
325
|
|
|
|
|
|
|
# pluralisation and inflection |
326
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
327
|
|
|
|
|
|
|
|
328
|
73
|
|
|
73
|
1
|
124
|
sub plural { |
329
|
|
|
|
|
|
|
my $name = shift; |
330
|
73
|
50
|
|
|
|
704
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
331
|
0
|
|
|
|
|
0
|
if ($name =~ /(ss|sh|ch|x)$/) { |
332
|
|
|
|
|
|
|
$name .= 'es'; |
333
|
|
|
|
|
|
|
} |
334
|
3
|
|
|
|
|
13
|
elsif ($name =~ s/([^aeiou])y$//) { |
335
|
|
|
|
|
|
|
$name .= $1.'ies'; |
336
|
|
|
|
|
|
|
} |
337
|
70
|
|
|
|
|
141
|
elsif ($name =~ /([^s\d\W])$/) { |
338
|
|
|
|
|
|
|
$name .= 's'; |
339
|
73
|
|
|
|
|
169
|
} |
340
|
|
|
|
|
|
|
return $name; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
19
|
|
50
|
19
|
1
|
28
|
sub plurality { |
344
|
19
|
|
|
|
|
29
|
my $n = shift || 0; |
345
|
|
|
|
|
|
|
my @items = map { permute_fragments($_) } |
346
|
19
|
50
|
33
|
|
|
96
|
(@_ == 1 && ref $_[0] eq ARRAY) |
|
0
|
|
|
|
|
0
|
|
347
|
|
|
|
|
|
|
? @{ $_[0] } |
348
|
|
|
|
|
|
|
: @_; |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# if the user specifies a single word then we pluralise it for them, |
351
|
19
|
50
|
|
|
|
34
|
# assuming that 0 items are plural, 1 is singular, and > 1 is plural |
352
|
19
|
|
|
|
|
26
|
if (@items == 1) { |
353
|
19
|
|
|
|
|
27
|
my $plural = plural($items[0]); |
354
|
19
|
|
|
|
|
30
|
unshift(@items, $plural); # 0 whatevers |
355
|
|
|
|
|
|
|
push(@items, $plural); # n whatevers (where n > 1) |
356
|
|
|
|
|
|
|
} |
357
|
19
|
50
|
|
|
|
48
|
|
358
|
19
|
100
|
|
|
|
36
|
die "$n is not a number\n" unless numlike($n); |
359
|
19
|
50
|
|
|
|
26
|
my $i = $n > $#items ? $#items : $n; |
360
|
|
|
|
|
|
|
$i = 0 if $i < 0; |
361
|
19
|
|
|
|
|
40
|
|
362
|
|
|
|
|
|
|
return $items[$i]; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
19
|
|
50
|
19
|
1
|
28
|
sub inflect { |
366
|
19
|
|
|
|
|
20
|
my $n = shift || 0; |
367
|
19
|
|
50
|
|
|
43
|
my $i = shift; |
368
|
19
|
50
|
|
|
|
29
|
my $f = shift || '%s %s'; |
369
|
19
|
|
33
|
|
|
34
|
my $z = @_ ? shift : 'no'; |
370
|
|
|
|
|
|
|
return xprintf( |
371
|
|
|
|
|
|
|
$f, ($n or $z), plurality($n, $i) |
372
|
|
|
|
|
|
|
); |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
|
376
|
0
|
|
|
0
|
|
0
|
sub _debug { |
377
|
|
|
|
|
|
|
print STDERR @_; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
381
|
|
|
|
|
|
|
# List utilities |
382
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
383
|
|
|
|
|
|
|
|
384
|
1
|
|
|
1
|
1
|
3
|
sub list_each { |
385
|
1
|
|
|
|
|
10
|
my ($list, $fn) = @_; |
386
|
|
|
|
|
|
|
my $n = 0; |
387
|
1
|
|
|
|
|
4
|
|
388
|
3
|
|
|
|
|
14
|
for (@$list) { |
389
|
|
|
|
|
|
|
$fn->($list, $n++, $_); |
390
|
|
|
|
|
|
|
} |
391
|
1
|
|
|
|
|
5
|
|
392
|
|
|
|
|
|
|
return $list; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
3
|
|
|
3
|
1
|
5
|
sub split_to_list { |
396
|
3
|
50
|
33
|
|
|
13
|
my $list = shift; |
397
|
|
|
|
|
|
|
return [ ] unless defined $list and length $list; |
398
|
3
|
100
|
|
|
|
8
|
|
|
|
50
|
|
|
|
|
|
399
|
2
|
|
|
|
|
19
|
if (! ref $list) { |
400
|
|
|
|
|
|
|
return [ split(DELIMITER, $list) ]; |
401
|
|
|
|
|
|
|
} |
402
|
1
|
|
|
|
|
5
|
elsif (ref $list eq ARRAY) { |
403
|
|
|
|
|
|
|
return $list; |
404
|
|
|
|
|
|
|
} |
405
|
0
|
|
|
|
|
0
|
else { |
406
|
|
|
|
|
|
|
return [$list]; |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
411
|
|
|
|
|
|
|
# Hash utilities |
412
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
413
|
|
|
|
|
|
|
|
414
|
1
|
|
|
1
|
1
|
3
|
sub hash_each { |
415
|
|
|
|
|
|
|
my ($hash, $fn) = @_; |
416
|
1
|
|
|
|
|
12
|
|
417
|
2
|
|
|
|
|
13
|
while (my ($key, $value) = each %$hash) { |
418
|
|
|
|
|
|
|
$fn->($hash, $key, $value); |
419
|
|
|
|
|
|
|
} |
420
|
1
|
|
|
|
|
6
|
|
421
|
|
|
|
|
|
|
return $hash; |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
|
425
|
2
|
|
|
2
|
1
|
3
|
sub extend { |
426
|
2
|
|
|
|
|
2
|
my $hash = shift; |
427
|
|
|
|
|
|
|
my $more; |
428
|
2
|
|
|
|
|
5
|
|
429
|
4
|
50
|
|
|
|
11
|
while (@_) { |
|
|
50
|
|
|
|
|
|
430
|
|
|
|
|
|
|
if (! $_[0]) { |
431
|
0
|
|
|
|
|
0
|
# ignore undefined/false values |
432
|
0
|
|
|
|
|
0
|
shift; |
433
|
|
|
|
|
|
|
next; |
434
|
|
|
|
|
|
|
} |
435
|
4
|
|
|
|
|
5
|
elsif (ref $_[0] eq HASH) { |
436
|
|
|
|
|
|
|
$more = shift; |
437
|
|
|
|
|
|
|
} |
438
|
0
|
|
|
|
|
0
|
else { |
439
|
0
|
|
|
|
|
0
|
$more = params(@_); |
440
|
|
|
|
|
|
|
@_ = (); |
441
|
4
|
|
|
|
|
14
|
} |
442
|
|
|
|
|
|
|
@$hash{ keys %$more } = values %$more; |
443
|
|
|
|
|
|
|
} |
444
|
2
|
|
|
|
|
12
|
|
445
|
|
|
|
|
|
|
return $hash; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
2
|
|
|
2
|
1
|
47
|
sub merge { |
449
|
2
|
|
|
|
|
3
|
my $hash = shift; |
450
|
|
|
|
|
|
|
my $more; |
451
|
2
|
|
|
|
|
6
|
|
452
|
3
|
50
|
|
|
|
9
|
while (@_) { |
|
|
50
|
|
|
|
|
|
453
|
|
|
|
|
|
|
if (! $_[0]) { |
454
|
0
|
|
|
|
|
0
|
# ignore undefined/false values |
455
|
0
|
|
|
|
|
0
|
shift; |
456
|
|
|
|
|
|
|
next; |
457
|
|
|
|
|
|
|
} |
458
|
3
|
|
|
|
|
4
|
elsif (ref $_[0] eq HASH) { |
459
|
3
|
|
|
|
|
9
|
$more = shift; |
460
|
|
|
|
|
|
|
$more = { %$more }; |
461
|
|
|
|
|
|
|
} |
462
|
0
|
|
|
|
|
0
|
else { |
463
|
0
|
|
|
|
|
0
|
$more = params(@_); |
464
|
|
|
|
|
|
|
@_ = (); |
465
|
3
|
|
|
|
|
8
|
} |
466
|
|
|
|
|
|
|
merge_hash($hash, $more); |
467
|
|
|
|
|
|
|
} |
468
|
2
|
|
|
|
|
11
|
|
469
|
|
|
|
|
|
|
return $hash; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
|
472
|
6
|
|
|
6
|
0
|
7
|
sub merge_hash { |
473
|
6
|
|
|
|
|
7
|
my ($hash, $more) = @_; |
474
|
|
|
|
|
|
|
my $into; |
475
|
6
|
|
|
|
|
23
|
|
476
|
10
|
|
|
|
|
11
|
while (my ($key, $value) = each %$more) { |
477
|
|
|
|
|
|
|
$into = $hash->{ $key }; |
478
|
10
|
100
|
100
|
|
|
28
|
|
|
|
|
66
|
|
|
|
|
479
|
3
|
|
|
|
|
9
|
if ($into && ref $into eq HASH && ref $value eq HASH) { |
480
|
|
|
|
|
|
|
merge_hash($into, $value); |
481
|
|
|
|
|
|
|
} |
482
|
7
|
|
|
|
|
13
|
else { |
483
|
|
|
|
|
|
|
$hash->{ $key } = $value; |
484
|
|
|
|
|
|
|
}; |
485
|
6
|
|
|
|
|
14
|
} |
486
|
|
|
|
|
|
|
return $hash; |
487
|
|
|
|
|
|
|
} |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
491
|
|
|
|
|
|
|
# Simple URI manipulation |
492
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
493
|
|
|
|
|
|
|
|
494
|
10
|
|
|
10
|
1
|
34
|
sub join_uri { |
495
|
10
|
|
|
|
|
41
|
my $uri = join('/', @_); |
496
|
10
|
|
|
|
|
33
|
$uri =~ s{(?
|
497
|
|
|
|
|
|
|
return $uri; |
498
|
|
|
|
|
|
|
} |
499
|
|
|
|
|
|
|
|
500
|
3
|
|
|
3
|
1
|
6
|
sub resolve_uri { |
501
|
3
|
|
|
|
|
8
|
my $base = shift; |
502
|
3
|
100
|
|
|
|
13
|
my $rel = join_uri(@_); |
503
|
|
|
|
|
|
|
return ($rel =~ m{^/}) |
504
|
|
|
|
|
|
|
? $rel |
505
|
|
|
|
|
|
|
: join_uri($base, $rel); |
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
1; |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
__END__ |