line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Statistics::R::IO::Parser; |
2
|
|
|
|
|
|
|
# ABSTRACT: Functions for parsing R data files |
3
|
|
|
|
|
|
|
$Statistics::R::IO::Parser::VERSION = '1.0001'; |
4
|
14
|
|
|
14
|
|
131202
|
use 5.010; |
|
14
|
|
|
|
|
35
|
|
5
|
14
|
|
|
14
|
|
45
|
use strict; |
|
14
|
|
|
|
|
19
|
|
|
14
|
|
|
|
|
265
|
|
6
|
14
|
|
|
14
|
|
36
|
use warnings FATAL => 'all'; |
|
14
|
|
|
|
|
63
|
|
|
14
|
|
|
|
|
379
|
|
7
|
|
|
|
|
|
|
|
8
|
14
|
|
|
14
|
|
43
|
use Exporter 'import'; |
|
14
|
|
|
|
|
14
|
|
|
14
|
|
|
|
|
1249
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
our @EXPORT = qw( ); |
11
|
|
|
|
|
|
|
our @EXPORT_OK = qw( endianness any_char char string |
12
|
|
|
|
|
|
|
any_uint8 any_uint16 any_uint24 any_uint32 any_real32 any_real64 any_real64_na |
13
|
|
|
|
|
|
|
uint8 uint16 uint24 uint32 |
14
|
|
|
|
|
|
|
any_int8 any_int16 any_int24 any_int32 any_int32_na |
15
|
|
|
|
|
|
|
int8 int16 int24 int32 |
16
|
|
|
|
|
|
|
count with_count many_till seq choose mreturn error add_singleton get_singleton reserve_singleton bind ); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( all => [ @EXPORT_OK ], |
19
|
|
|
|
|
|
|
num => [ qw( any_uint8 any_uint16 any_uint24 any_uint32 any_int32_na any_real32 any_real64 any_real64_na uint8 uint16 uint24 uint32 ) ], |
20
|
|
|
|
|
|
|
char => [ qw( any_char char string ) ], |
21
|
|
|
|
|
|
|
combinator => [ qw( count with_count many_till seq choose mreturn bind ) ] ); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
|
24
|
14
|
|
|
14
|
|
52
|
use Scalar::Util qw(looks_like_number); |
|
14
|
|
|
|
|
16
|
|
|
14
|
|
|
|
|
906
|
|
25
|
14
|
|
|
14
|
|
52
|
use Carp; |
|
14
|
|
|
|
|
13
|
|
|
14
|
|
|
|
|
27079
|
|
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub endianness { |
28
|
55836
|
|
|
55836
|
1
|
42310
|
state $endianness = '>'; |
29
|
55836
|
50
|
100
|
|
|
120100
|
my $new_value = shift if @_ or return $endianness; |
30
|
952
|
|
66
|
|
|
5286
|
$endianness = $new_value =~ /^[<>]$/ && $new_value || $endianness; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
sub any_char { |
35
|
277948
|
|
|
277948
|
1
|
194376
|
my $state = shift; |
36
|
|
|
|
|
|
|
|
37
|
277948
|
100
|
66
|
|
|
681340
|
return undef if !$state || $state->eof; |
38
|
|
|
|
|
|
|
|
39
|
277933
|
|
|
|
|
1559483
|
[$state->at, $state->next] |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
sub char { |
44
|
7
|
|
|
7
|
1
|
1291
|
my $arg = shift; |
45
|
7
|
100
|
|
|
|
26
|
die 'Must be a single-char argument: ' . $arg unless length($arg) == 1; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
sub { |
48
|
16
|
50
|
|
16
|
|
49
|
my $state = shift or return; |
49
|
16
|
100
|
100
|
|
|
30
|
return if $state->eof || $arg ne $state->at; |
50
|
|
|
|
|
|
|
|
51
|
6
|
|
|
|
|
123
|
[ $arg, $state->next ] |
52
|
|
|
|
|
|
|
} |
53
|
6
|
|
|
|
|
26
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub string { |
57
|
1580
|
|
|
1580
|
1
|
1950
|
my $arg = shift; |
58
|
1580
|
100
|
66
|
|
|
4987
|
die 'Must be a scalar argument: ' . $arg unless $arg && !ref($arg); |
59
|
1579
|
|
|
|
|
2981
|
my $chars = count(length($arg), \&any_char); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
sub { |
62
|
960
|
100
|
|
960
|
|
855
|
my ($char_values, $state) = @{$chars->(@_) or return}; |
|
960
|
|
|
|
|
1251
|
|
63
|
959
|
100
|
|
|
|
1162
|
return unless join('', @{$char_values}) eq $arg; |
|
959
|
|
|
|
|
2587
|
|
64
|
791
|
|
|
|
|
1477
|
[ $arg, $state ] |
65
|
|
|
|
|
|
|
} |
66
|
1579
|
|
|
|
|
5513
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
sub any_uint8 { |
70
|
237063
|
100
|
|
237063
|
1
|
155989
|
my ($value, $state) = @{any_char @_ or return}; |
|
237063
|
|
|
|
|
232657
|
|
71
|
|
|
|
|
|
|
|
72
|
237051
|
|
|
|
|
2327922
|
[ unpack('C', $value), $state ] |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub any_uint16 { |
77
|
18
|
50
|
|
18
|
1
|
55
|
my ($value, $state) = @{count(2, \&any_uint8)->(@_) or return}; |
|
18
|
|
|
|
|
35
|
|
78
|
|
|
|
|
|
|
|
79
|
18
|
|
|
|
|
66
|
[ unpack("S" . endianness, pack 'C2' => @{$value}), |
|
18
|
|
|
|
|
92
|
|
80
|
|
|
|
|
|
|
$state ] |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub any_uint24 { |
85
|
179
|
100
|
|
179
|
1
|
199
|
my ($value, $state) = @{count(3, \&any_uint8)->(@_) or return}; |
|
179
|
|
|
|
|
399
|
|
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
[ unpack("L" . endianness, |
88
|
175
|
100
|
|
|
|
792
|
pack(endianness eq '>' ? 'xC3' : 'C3x', @{$value})), |
|
175
|
|
|
|
|
801
|
|
89
|
|
|
|
|
|
|
$state ] |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
sub any_uint32 { |
94
|
47385
|
100
|
|
47385
|
1
|
33428
|
my ($value, $state) = @{count(4, \&any_uint8)->(@_) or return}; |
|
47385
|
|
|
|
|
68672
|
|
95
|
|
|
|
|
|
|
|
96
|
47379
|
|
|
|
|
145381
|
[ unpack("L" . endianness, pack 'C4' => @{$value}), |
|
47379
|
|
|
|
|
151442
|
|
97
|
|
|
|
|
|
|
$state ] |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
sub uint8 { |
102
|
169
|
|
|
169
|
1
|
248
|
my $arg = shift; |
103
|
169
|
50
|
33
|
|
|
1071
|
die 'Argument must be a number 0-255: ' . $arg |
|
|
|
33
|
|
|
|
|
104
|
|
|
|
|
|
|
unless looks_like_number($arg) && $arg <= 0x000000FF && $arg >= 0; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub { |
107
|
169
|
50
|
|
169
|
|
138
|
my ($value, $state) = @{any_uint8 @_ or return}; |
|
169
|
|
|
|
|
257
|
|
108
|
169
|
100
|
|
|
|
390
|
return unless $arg == $value; |
109
|
|
|
|
|
|
|
|
110
|
167
|
|
|
|
|
380
|
[ $arg, $state ] |
111
|
|
|
|
|
|
|
} |
112
|
169
|
|
|
|
|
912
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub uint16 { |
116
|
8
|
|
|
8
|
1
|
468
|
my $arg = shift; |
117
|
8
|
50
|
33
|
|
|
58
|
die 'Argument must be a number 0-65535: ' . $arg |
|
|
|
33
|
|
|
|
|
118
|
|
|
|
|
|
|
unless looks_like_number($arg) && $arg <= 0x0000FFFF && $arg >= 0; |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub { |
121
|
8
|
50
|
|
8
|
|
8
|
my ($value, $state) = @{any_uint16 @_ or return}; |
|
8
|
|
|
|
|
12
|
|
122
|
8
|
100
|
|
|
|
18
|
return unless $arg == $value; |
123
|
|
|
|
|
|
|
|
124
|
6
|
|
|
|
|
20
|
[ $arg, $state ] |
125
|
|
|
|
|
|
|
} |
126
|
8
|
|
|
|
|
48
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub uint24 { |
130
|
8
|
|
|
8
|
1
|
451
|
my $arg = shift; |
131
|
8
|
50
|
33
|
|
|
54
|
die 'Argument must be a number 0-16777215: ' . $arg |
|
|
|
33
|
|
|
|
|
132
|
|
|
|
|
|
|
unless looks_like_number($arg) && $arg <= 0x00FFFFFF && $arg >= 0; |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
sub { |
135
|
8
|
100
|
|
8
|
|
7
|
my ($value, $state) = @{any_uint24 @_ or return}; |
|
8
|
|
|
|
|
12
|
|
136
|
6
|
100
|
|
|
|
14
|
return unless $arg == $value; |
137
|
|
|
|
|
|
|
|
138
|
4
|
|
|
|
|
13
|
[ $arg, $state ] |
139
|
|
|
|
|
|
|
} |
140
|
8
|
|
|
|
|
35
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
sub uint32 { |
144
|
1640
|
|
|
1640
|
1
|
2038
|
my $arg = shift; |
145
|
1640
|
50
|
33
|
|
|
8817
|
die 'Argument must be a number 0-4294967295: ' . $arg |
|
|
|
33
|
|
|
|
|
146
|
|
|
|
|
|
|
unless looks_like_number($arg) && $arg <= 0xFFFFFFFF && $arg >= 0; |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
sub { |
149
|
7526
|
100
|
|
7526
|
|
5545
|
my ($value, $state) = @{any_uint32 @_ or return}; |
|
7526
|
|
|
|
|
9254
|
|
150
|
7524
|
100
|
|
|
|
18907
|
return unless $arg == $value; |
151
|
|
|
|
|
|
|
|
152
|
1710
|
|
|
|
|
3039
|
[ $arg, $state ] |
153
|
|
|
|
|
|
|
} |
154
|
1640
|
|
|
|
|
4238
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
sub any_int8 { |
158
|
4
|
50
|
|
4
|
1
|
21
|
my ($value, $state) = @{any_char @_ or return}; |
|
4
|
|
|
|
|
7
|
|
159
|
|
|
|
|
|
|
|
160
|
4
|
|
|
|
|
55
|
[ unpack('c', $value), $state ] |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
sub any_int16 { |
165
|
4
|
50
|
|
4
|
1
|
27
|
my ($value, $state) = @{any_uint16 @_ or return}; |
|
4
|
|
|
|
|
8
|
|
166
|
|
|
|
|
|
|
|
167
|
4
|
100
|
|
|
|
10
|
$value |= 0x8000 if ($value >= 1<<15); |
168
|
4
|
|
|
|
|
17
|
[ unpack('s', pack 's' => $value), |
169
|
|
|
|
|
|
|
$state ] |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub any_int24 { |
174
|
4
|
50
|
|
4
|
1
|
29
|
my ($value, $state) = @{any_uint24 @_ or return}; |
|
4
|
|
|
|
|
8
|
|
175
|
|
|
|
|
|
|
|
176
|
4
|
100
|
|
|
|
12
|
$value |= 0xff800000 if ($value >= 1<<23); |
177
|
4
|
|
|
|
|
20
|
[ unpack('l', pack 'l' => $value), |
178
|
|
|
|
|
|
|
$state ] |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
sub any_int32 { |
183
|
16630
|
100
|
|
16630
|
1
|
11791
|
my ($value, $state) = @{any_uint32 @_ or return}; |
|
16630
|
|
|
|
|
19636
|
|
184
|
|
|
|
|
|
|
|
185
|
16628
|
100
|
|
|
|
30583
|
$value |= 0x80000000 if ($value >= 1<<31); |
186
|
16628
|
|
|
|
|
33487
|
[ unpack('l', pack 'l' => $value), |
187
|
|
|
|
|
|
|
$state ] |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
sub int8 { |
192
|
2
|
|
|
2
|
1
|
20
|
my $arg = shift; |
193
|
2
|
50
|
33
|
|
|
17
|
die 'Argument must be a number -128-127: ' . $arg |
|
|
|
33
|
|
|
|
|
194
|
|
|
|
|
|
|
unless looks_like_number($arg) && $arg < 1<<7 && $arg >= -(1<<7); |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub { |
197
|
2
|
50
|
|
2
|
|
3
|
my ($value, $state) = @{any_int8 @_ or return}; |
|
2
|
|
|
|
|
5
|
|
198
|
2
|
50
|
|
|
|
6
|
return unless $arg == $value; |
199
|
|
|
|
|
|
|
|
200
|
2
|
|
|
|
|
7
|
[ $arg, $state ] |
201
|
|
|
|
|
|
|
} |
202
|
2
|
|
|
|
|
14
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
sub int16 { |
206
|
2
|
|
|
2
|
1
|
31
|
my $arg = shift; |
207
|
2
|
50
|
33
|
|
|
19
|
die 'Argument must be a number -32768-32767: ' . $arg |
|
|
|
33
|
|
|
|
|
208
|
|
|
|
|
|
|
unless looks_like_number($arg) && $arg < 1<<15 && $arg >= -(1<<15); |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
sub { |
211
|
2
|
50
|
|
2
|
|
2
|
my ($value, $state) = @{any_int16 @_ or return}; |
|
2
|
|
|
|
|
5
|
|
212
|
2
|
50
|
|
|
|
4
|
return unless $arg == $value; |
213
|
|
|
|
|
|
|
|
214
|
2
|
|
|
|
|
9
|
[ $arg, $state ] |
215
|
|
|
|
|
|
|
} |
216
|
2
|
|
|
|
|
10
|
} |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
sub int24 { |
220
|
2
|
|
|
2
|
1
|
29
|
my $arg = shift; |
221
|
2
|
50
|
33
|
|
|
20
|
die 'Argument must be a number 0-16777215: ' . $arg |
|
|
|
33
|
|
|
|
|
222
|
|
|
|
|
|
|
unless looks_like_number($arg) && $arg < 1<<23 && $arg >= -(1<<23); |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub { |
225
|
2
|
50
|
|
2
|
|
2
|
my ($value, $state) = @{any_int24 @_ or return}; |
|
2
|
|
|
|
|
5
|
|
226
|
2
|
50
|
|
|
|
5
|
return unless $arg == $value; |
227
|
|
|
|
|
|
|
|
228
|
2
|
|
|
|
|
7
|
[ $arg, $state ] |
229
|
|
|
|
|
|
|
} |
230
|
2
|
|
|
|
|
13
|
} |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
sub int32 { |
234
|
1189
|
|
|
1189
|
1
|
1140
|
my $arg = shift; |
235
|
1189
|
50
|
33
|
|
|
7951
|
die 'Argument must be a number -2147483648-2147483647: ' . $arg |
|
|
|
33
|
|
|
|
|
236
|
|
|
|
|
|
|
unless looks_like_number($arg) && $arg < 1<<31 && $arg >= -(1<<31); |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub { |
239
|
2738
|
100
|
|
2738
|
|
2230
|
my ($value, $state) = @{any_int32 @_ or return}; |
|
2738
|
|
|
|
|
3322
|
|
240
|
2737
|
100
|
|
|
|
7127
|
return unless $arg == $value; |
241
|
|
|
|
|
|
|
|
242
|
121
|
|
|
|
|
216
|
[ $arg, $state ] |
243
|
|
|
|
|
|
|
} |
244
|
1189
|
|
|
|
|
4518
|
} |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub any_int32_na { |
248
|
|
|
|
|
|
|
choose(&bind(int32(-2147483648), |
249
|
|
|
|
|
|
|
sub { |
250
|
119
|
|
|
119
|
|
228
|
mreturn(undef); |
251
|
1186
|
|
|
1186
|
1
|
2253
|
}), |
252
|
|
|
|
|
|
|
\&any_int32) |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
my %na_real = ( '>' => [ uint32(0x7ff00000), |
256
|
|
|
|
|
|
|
uint32(0x7a2) ], |
257
|
|
|
|
|
|
|
'<' => [ uint32(0x7a2), |
258
|
|
|
|
|
|
|
uint32(0x7ff00000) ]); |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
sub any_real64_na { |
261
|
1319
|
|
|
|
|
1944
|
choose(&bind(seq(@{$na_real{endianness()}}), |
262
|
|
|
|
|
|
|
sub { |
263
|
65
|
|
|
65
|
|
121
|
mreturn(undef); |
264
|
1319
|
|
|
1319
|
1
|
1640
|
}), |
265
|
|
|
|
|
|
|
\&any_real64) |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
sub any_real32 { |
270
|
2
|
50
|
|
2
|
1
|
21
|
my ($value, $state) = @{count(4, \&any_uint8)->(@_) or return}; |
|
2
|
|
|
|
|
5
|
|
271
|
|
|
|
|
|
|
|
272
|
2
|
|
|
|
|
9
|
[ unpack("f" . endianness, pack 'C4' => @{$value}), |
|
2
|
|
|
|
|
13
|
|
273
|
|
|
|
|
|
|
$state ] |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
sub any_real64 { |
278
|
5815
|
50
|
|
5815
|
1
|
4249
|
my ($value, $state) = @{count(8, \&any_uint8)->(@_) or return}; |
|
5815
|
|
|
|
|
9955
|
|
279
|
|
|
|
|
|
|
|
280
|
5815
|
|
|
|
|
18390
|
[ unpack("d" . endianness, pack 'C8' => @{$value}), |
|
5815
|
|
|
|
|
16675
|
|
281
|
|
|
|
|
|
|
$state ] |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
sub count { |
286
|
70582
|
|
|
70582
|
1
|
64923
|
my ($n, $parser) = (shift, shift); |
287
|
|
|
|
|
|
|
sub { |
288
|
70015
|
|
|
70015
|
|
50875
|
my $state = shift; |
289
|
70015
|
|
|
|
|
45121
|
my @value; |
290
|
|
|
|
|
|
|
|
291
|
70015
|
|
|
|
|
101546
|
for (1..$n) { |
292
|
300716
|
100
|
|
|
|
1216097
|
my $result = $parser->($state) or return; |
293
|
|
|
|
|
|
|
|
294
|
300701
|
|
|
|
|
881327
|
push @value, shift @$result; |
295
|
300701
|
|
|
|
|
496213
|
$state = shift @$result; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
70000
|
|
|
|
|
554355
|
return [ [ @value ], $state ]; |
299
|
|
|
|
|
|
|
} |
300
|
70582
|
|
|
|
|
195424
|
} |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
sub seq { |
304
|
10675
|
|
|
10675
|
1
|
12528
|
my @parsers = @_; |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
sub { |
307
|
15234
|
|
|
15234
|
|
11643
|
my $state = shift; |
308
|
15234
|
|
|
|
|
10577
|
my @value; |
309
|
|
|
|
|
|
|
|
310
|
15234
|
|
|
|
|
15279
|
foreach my $parser (@parsers) { |
311
|
22407
|
100
|
|
|
|
35627
|
my $result = $parser->($state) or return; |
312
|
|
|
|
|
|
|
|
313
|
16585
|
|
|
|
|
126153
|
push @value, shift @$result; |
314
|
16585
|
|
|
|
|
24127
|
$state = shift @$result; |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
|
317
|
9412
|
|
|
|
|
45010
|
return [ [ @value ], $state ]; |
318
|
|
|
|
|
|
|
} |
319
|
10675
|
|
|
|
|
34649
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
sub many_till { |
323
|
1
|
|
|
1
|
1
|
3
|
my ($p, $end) = (shift, shift); |
324
|
1
|
50
|
33
|
|
|
5
|
die "'bind' expects two arguments" unless $p && $end; |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
sub { |
327
|
2
|
50
|
|
2
|
|
925
|
my $state = shift or return; |
328
|
2
|
|
|
|
|
3
|
my @value; |
329
|
|
|
|
|
|
|
|
330
|
2
|
|
|
|
|
3
|
until ($end->($state)) { |
331
|
3
|
100
|
|
|
|
63
|
my $result = $p->($state) or return; |
332
|
|
|
|
|
|
|
|
333
|
2
|
|
|
|
|
21
|
push @value, shift @$result; |
334
|
2
|
|
|
|
|
4
|
$state = shift @$result; |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
|
337
|
1
|
|
|
|
|
16
|
return [ [ @value ], $state ] |
338
|
|
|
|
|
|
|
} |
339
|
1
|
|
|
|
|
4
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
sub choose { |
343
|
3294
|
|
|
3294
|
1
|
4162
|
my @parsers = @_; |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
sub { |
346
|
9403
|
50
|
|
9403
|
|
14522
|
my $state = shift or return; |
347
|
|
|
|
|
|
|
|
348
|
9403
|
|
|
|
|
9434
|
foreach my $parser (@parsers) { |
349
|
18000
|
|
|
|
|
21693
|
my $result = $parser->($state); |
350
|
18000
|
100
|
|
|
|
40504
|
return $result if $result; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
|
353
|
1
|
|
|
|
|
3
|
return; |
354
|
|
|
|
|
|
|
} |
355
|
3294
|
|
|
|
|
10247
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub mreturn { |
359
|
50561
|
|
|
50561
|
1
|
115936
|
my $arg = shift; |
360
|
|
|
|
|
|
|
sub { |
361
|
50561
|
|
|
50561
|
|
103550
|
[ $arg, shift ] |
362
|
|
|
|
|
|
|
} |
363
|
50561
|
|
|
|
|
148580
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
sub error { |
367
|
12
|
|
|
12
|
1
|
21
|
my $message = shift; |
368
|
|
|
|
|
|
|
sub { |
369
|
12
|
|
|
12
|
|
15
|
my $state = shift; |
370
|
12
|
|
|
|
|
239
|
croak $message . " (at " . $state->position . ")"; |
371
|
|
|
|
|
|
|
} |
372
|
12
|
|
|
|
|
46
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
sub add_singleton { |
376
|
1883
|
|
|
1883
|
1
|
18886
|
my $singleton = shift; |
377
|
|
|
|
|
|
|
sub { |
378
|
1883
|
|
|
1883
|
|
4615
|
[ $singleton, shift->add_singleton($singleton) ] |
379
|
|
|
|
|
|
|
} |
380
|
1883
|
|
|
|
|
5989
|
} |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
sub get_singleton { |
384
|
1632
|
|
|
1632
|
1
|
1391
|
my $ref_id = shift; |
385
|
|
|
|
|
|
|
sub { |
386
|
1632
|
|
|
1632
|
|
1346
|
my $state = shift; |
387
|
1632
|
|
|
|
|
3332
|
[ $state->get_singleton($ref_id), $state ] |
388
|
|
|
|
|
|
|
} |
389
|
1632
|
|
|
|
|
4115
|
} |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
## Preallocates a space for a singleton before running a given parser, |
393
|
|
|
|
|
|
|
## and then assigns the parser's value to the singleton. |
394
|
|
|
|
|
|
|
sub reserve_singleton { |
395
|
|
|
|
|
|
|
|
396
|
53
|
|
|
53
|
1
|
68
|
my $p = shift; |
397
|
|
|
|
|
|
|
&bind( |
398
|
|
|
|
|
|
|
seq( |
399
|
|
|
|
|
|
|
sub { |
400
|
53
|
|
|
53
|
|
67
|
my $state = shift; |
401
|
53
|
|
|
|
|
50
|
my $ref_id = scalar(@{$state->singletons}); |
|
53
|
|
|
|
|
970
|
|
402
|
53
|
|
|
|
|
274
|
my $new_state = $state->add_singleton(undef); |
403
|
53
|
|
|
|
|
450
|
[ $ref_id, $new_state ] |
404
|
|
|
|
|
|
|
}, |
405
|
|
|
|
|
|
|
$p), |
406
|
|
|
|
|
|
|
sub { |
407
|
53
|
|
|
53
|
|
66
|
my ($ref_id, $value) = @{shift()}; |
|
53
|
|
|
|
|
77
|
|
408
|
|
|
|
|
|
|
sub { |
409
|
53
|
|
|
|
|
61
|
my $state = shift; |
410
|
53
|
|
|
|
|
948
|
$state->singletons->[$ref_id] = $value; |
411
|
53
|
|
|
|
|
317
|
[ $value, $state ] |
412
|
|
|
|
|
|
|
} |
413
|
53
|
|
|
|
|
182
|
}) |
414
|
53
|
|
|
|
|
166
|
} |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
sub bind { |
418
|
72336
|
|
|
72336
|
1
|
62031
|
my ($p1, $fp2) = (shift, shift); |
419
|
72336
|
50
|
33
|
|
|
196020
|
die "'bind' expects two arguments" unless $p1 && $fp2; |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
sub { |
422
|
93806
|
|
50
|
93806
|
|
156083
|
my $v1 = $p1->(shift or return); |
423
|
93785
|
100
|
|
|
|
171234
|
my ($value, $state) = @{$v1 or return}; |
|
93785
|
|
|
|
|
147222
|
|
424
|
85191
|
|
|
|
|
151438
|
$fp2->($value)->($state) |
425
|
|
|
|
|
|
|
} |
426
|
72336
|
|
|
|
|
178633
|
} |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
sub with_count { |
430
|
4837
|
50
|
33
|
4837
|
1
|
16221
|
die "'bind' expects one or two arguments" |
431
|
|
|
|
|
|
|
unless @_ and scalar(@_) <= 2; |
432
|
|
|
|
|
|
|
|
433
|
4837
|
100
|
|
|
|
7434
|
unshift(@_, \&any_uint32) if (scalar(@_) == 1); |
434
|
4837
|
|
|
|
|
4608
|
my ($counter, $content) = (shift, shift); |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
&bind($counter, |
437
|
|
|
|
|
|
|
sub { |
438
|
4827
|
|
|
4827
|
|
3985
|
my $n = shift; |
439
|
4827
|
|
|
|
|
6012
|
count($n, $content) |
440
|
|
|
|
|
|
|
}) |
441
|
4837
|
|
|
|
|
9229
|
} |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
1; |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
__END__ |