Commit | Line | Data |
---|---|---|
adfe19db MHM |
1 | ################################################################################ |
2 | ## | |
3 | ## $Revision: 6 $ | |
4 | ## $Author: mhx $ | |
5 | ## $Date: 2004/08/13 12:45:54 +0200 $ | |
6 | ## | |
7 | ################################################################################ | |
8 | ## | |
9 | ## Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz. | |
10 | ## Version 2.x, Copyright (C) 2001, Paul Marquess. | |
11 | ## Version 1.x, Copyright (C) 1999, Kenneth Albanowski. | |
12 | ## | |
13 | ## This program is free software; you can redistribute it and/or | |
14 | ## modify it under the same terms as Perl itself. | |
15 | ## | |
16 | ################################################################################ | |
17 | ||
18 | =provides | |
19 | ||
20 | grok_hex | |
21 | grok_oct | |
22 | grok_bin | |
23 | grok_numeric_radix | |
24 | grok_number | |
25 | __UNDEFINED__ | |
26 | ||
27 | =implementation | |
28 | ||
29 | __UNDEFINED__ IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) | |
30 | __UNDEFINED__ IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) | |
31 | __UNDEFINED__ IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) | |
32 | __UNDEFINED__ IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) | |
33 | ||
34 | __UNDEFINED__ IS_NUMBER_IN_UV 0x01 | |
35 | __UNDEFINED__ IS_NUMBER_GREATER_THAN_UV_MAX 0x02 | |
36 | __UNDEFINED__ IS_NUMBER_NOT_INT 0x04 | |
37 | __UNDEFINED__ IS_NUMBER_NEG 0x08 | |
38 | __UNDEFINED__ IS_NUMBER_INFINITY 0x10 | |
39 | __UNDEFINED__ IS_NUMBER_NAN 0x20 | |
40 | ||
41 | /* GROK_NUMERIC_RADIX depends on grok_numeric_radix */ | |
42 | __UNDEFINED__ GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) | |
43 | ||
44 | __UNDEFINED__ PERL_SCAN_GREATER_THAN_UV_MAX 0x02 | |
45 | __UNDEFINED__ PERL_SCAN_SILENT_ILLDIGIT 0x04 | |
46 | __UNDEFINED__ PERL_SCAN_ALLOW_UNDERSCORES 0x01 | |
47 | __UNDEFINED__ PERL_SCAN_DISALLOW_PREFIX 0x02 | |
48 | ||
49 | #ifndef grok_numeric_radix | |
50 | #if { NEED grok_numeric_radix } | |
51 | bool | |
52 | grok_numeric_radix(pTHX_ const char **sp, const char *send) | |
53 | { | |
54 | #ifdef USE_LOCALE_NUMERIC | |
55 | #ifdef PL_numeric_radix_sv | |
56 | if (PL_numeric_radix_sv && IN_LOCALE) { | |
57 | STRLEN len; | |
58 | char* radix = SvPV(PL_numeric_radix_sv, len); | |
59 | if (*sp + len <= send && memEQ(*sp, radix, len)) { | |
60 | *sp += len; | |
61 | return TRUE; | |
62 | } | |
63 | } | |
64 | #else | |
65 | /* older perls don't have PL_numeric_radix_sv so the radix | |
66 | * must manually be requested from locale.h | |
67 | */ | |
68 | #include <locale.h> | |
69 | dTHR; /* needed for older threaded perls */ | |
70 | struct lconv *lc = localeconv(); | |
71 | char *radix = lc->decimal_point; | |
72 | if (radix && IN_LOCALE) { | |
73 | STRLEN len = strlen(radix); | |
74 | if (*sp + len <= send && memEQ(*sp, radix, len)) { | |
75 | *sp += len; | |
76 | return TRUE; | |
77 | } | |
78 | } | |
79 | #endif /* PERL_VERSION */ | |
80 | #endif /* USE_LOCALE_NUMERIC */ | |
81 | /* always try "." if numeric radix didn't match because | |
82 | * we may have data from different locales mixed */ | |
83 | if (*sp < send && **sp == '.') { | |
84 | ++*sp; | |
85 | return TRUE; | |
86 | } | |
87 | return FALSE; | |
88 | } | |
89 | #endif | |
90 | #endif | |
91 | ||
92 | /* grok_number depends on grok_numeric_radix */ | |
93 | ||
94 | #ifndef grok_number | |
95 | #if { NEED grok_number } | |
96 | int | |
97 | grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) | |
98 | { | |
99 | const char *s = pv; | |
100 | const char *send = pv + len; | |
101 | const UV max_div_10 = UV_MAX / 10; | |
102 | const char max_mod_10 = UV_MAX % 10; | |
103 | int numtype = 0; | |
104 | int sawinf = 0; | |
105 | int sawnan = 0; | |
106 | ||
107 | while (s < send && isSPACE(*s)) | |
108 | s++; | |
109 | if (s == send) { | |
110 | return 0; | |
111 | } else if (*s == '-') { | |
112 | s++; | |
113 | numtype = IS_NUMBER_NEG; | |
114 | } | |
115 | else if (*s == '+') | |
116 | s++; | |
117 | ||
118 | if (s == send) | |
119 | return 0; | |
120 | ||
121 | /* next must be digit or the radix separator or beginning of infinity */ | |
122 | if (isDIGIT(*s)) { | |
123 | /* UVs are at least 32 bits, so the first 9 decimal digits cannot | |
124 | overflow. */ | |
125 | UV value = *s - '0'; | |
126 | /* This construction seems to be more optimiser friendly. | |
127 | (without it gcc does the isDIGIT test and the *s - '0' separately) | |
128 | With it gcc on arm is managing 6 instructions (6 cycles) per digit. | |
129 | In theory the optimiser could deduce how far to unroll the loop | |
130 | before checking for overflow. */ | |
131 | if (++s < send) { | |
132 | int digit = *s - '0'; | |
133 | if (digit >= 0 && digit <= 9) { | |
134 | value = value * 10 + digit; | |
135 | if (++s < send) { | |
136 | digit = *s - '0'; | |
137 | if (digit >= 0 && digit <= 9) { | |
138 | value = value * 10 + digit; | |
139 | if (++s < send) { | |
140 | digit = *s - '0'; | |
141 | if (digit >= 0 && digit <= 9) { | |
142 | value = value * 10 + digit; | |
143 | if (++s < send) { | |
144 | digit = *s - '0'; | |
145 | if (digit >= 0 && digit <= 9) { | |
146 | value = value * 10 + digit; | |
147 | if (++s < send) { | |
148 | digit = *s - '0'; | |
149 | if (digit >= 0 && digit <= 9) { | |
150 | value = value * 10 + digit; | |
151 | if (++s < send) { | |
152 | digit = *s - '0'; | |
153 | if (digit >= 0 && digit <= 9) { | |
154 | value = value * 10 + digit; | |
155 | if (++s < send) { | |
156 | digit = *s - '0'; | |
157 | if (digit >= 0 && digit <= 9) { | |
158 | value = value * 10 + digit; | |
159 | if (++s < send) { | |
160 | digit = *s - '0'; | |
161 | if (digit >= 0 && digit <= 9) { | |
162 | value = value * 10 + digit; | |
163 | if (++s < send) { | |
164 | /* Now got 9 digits, so need to check | |
165 | each time for overflow. */ | |
166 | digit = *s - '0'; | |
167 | while (digit >= 0 && digit <= 9 | |
168 | && (value < max_div_10 | |
169 | || (value == max_div_10 | |
170 | && digit <= max_mod_10))) { | |
171 | value = value * 10 + digit; | |
172 | if (++s < send) | |
173 | digit = *s - '0'; | |
174 | else | |
175 | break; | |
176 | } | |
177 | if (digit >= 0 && digit <= 9 | |
178 | && (s < send)) { | |
179 | /* value overflowed. | |
180 | skip the remaining digits, don't | |
181 | worry about setting *valuep. */ | |
182 | do { | |
183 | s++; | |
184 | } while (s < send && isDIGIT(*s)); | |
185 | numtype |= | |
186 | IS_NUMBER_GREATER_THAN_UV_MAX; | |
187 | goto skip_value; | |
188 | } | |
189 | } | |
190 | } | |
191 | } | |
192 | } | |
193 | } | |
194 | } | |
195 | } | |
196 | } | |
197 | } | |
198 | } | |
199 | } | |
200 | } | |
201 | } | |
202 | } | |
203 | } | |
204 | } | |
205 | } | |
206 | numtype |= IS_NUMBER_IN_UV; | |
207 | if (valuep) | |
208 | *valuep = value; | |
209 | ||
210 | skip_value: | |
211 | if (GROK_NUMERIC_RADIX(&s, send)) { | |
212 | numtype |= IS_NUMBER_NOT_INT; | |
213 | while (s < send && isDIGIT(*s)) /* optional digits after the radix */ | |
214 | s++; | |
215 | } | |
216 | } | |
217 | else if (GROK_NUMERIC_RADIX(&s, send)) { | |
218 | numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ | |
219 | /* no digits before the radix means we need digits after it */ | |
220 | if (s < send && isDIGIT(*s)) { | |
221 | do { | |
222 | s++; | |
223 | } while (s < send && isDIGIT(*s)); | |
224 | if (valuep) { | |
225 | /* integer approximation is valid - it's 0. */ | |
226 | *valuep = 0; | |
227 | } | |
228 | } | |
229 | else | |
230 | return 0; | |
231 | } else if (*s == 'I' || *s == 'i') { | |
232 | s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; | |
233 | s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; | |
234 | s++; if (s < send && (*s == 'I' || *s == 'i')) { | |
235 | s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; | |
236 | s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; | |
237 | s++; if (s == send || (*s != 'T' && *s != 't')) return 0; | |
238 | s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; | |
239 | s++; | |
240 | } | |
241 | sawinf = 1; | |
242 | } else if (*s == 'N' || *s == 'n') { | |
243 | /* XXX TODO: There are signaling NaNs and quiet NaNs. */ | |
244 | s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; | |
245 | s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; | |
246 | s++; | |
247 | sawnan = 1; | |
248 | } else | |
249 | return 0; | |
250 | ||
251 | if (sawinf) { | |
252 | numtype &= IS_NUMBER_NEG; /* Keep track of sign */ | |
253 | numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; | |
254 | } else if (sawnan) { | |
255 | numtype &= IS_NUMBER_NEG; /* Keep track of sign */ | |
256 | numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; | |
257 | } else if (s < send) { | |
258 | /* we can have an optional exponent part */ | |
259 | if (*s == 'e' || *s == 'E') { | |
260 | /* The only flag we keep is sign. Blow away any "it's UV" */ | |
261 | numtype &= IS_NUMBER_NEG; | |
262 | numtype |= IS_NUMBER_NOT_INT; | |
263 | s++; | |
264 | if (s < send && (*s == '-' || *s == '+')) | |
265 | s++; | |
266 | if (s < send && isDIGIT(*s)) { | |
267 | do { | |
268 | s++; | |
269 | } while (s < send && isDIGIT(*s)); | |
270 | } | |
271 | else | |
272 | return 0; | |
273 | } | |
274 | } | |
275 | while (s < send && isSPACE(*s)) | |
276 | s++; | |
277 | if (s >= send) | |
278 | return numtype; | |
279 | if (len == 10 && memEQ(pv, "0 but true", 10)) { | |
280 | if (valuep) | |
281 | *valuep = 0; | |
282 | return IS_NUMBER_IN_UV; | |
283 | } | |
284 | return 0; | |
285 | } | |
286 | #endif | |
287 | #endif | |
288 | ||
289 | /* | |
290 | * The grok_* routines have been modified to use warn() instead of | |
291 | * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, | |
292 | * which is why the stack variable has been renamed to 'xdigit'. | |
293 | */ | |
294 | ||
295 | #ifndef grok_bin | |
296 | #if { NEED grok_bin } | |
297 | UV | |
298 | grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) | |
299 | { | |
300 | const char *s = start; | |
301 | STRLEN len = *len_p; | |
302 | UV value = 0; | |
303 | NV value_nv = 0; | |
304 | ||
305 | const UV max_div_2 = UV_MAX / 2; | |
306 | bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; | |
307 | bool overflowed = FALSE; | |
308 | ||
309 | if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { | |
310 | /* strip off leading b or 0b. | |
311 | for compatibility silently suffer "b" and "0b" as valid binary | |
312 | numbers. */ | |
313 | if (len >= 1) { | |
314 | if (s[0] == 'b') { | |
315 | s++; | |
316 | len--; | |
317 | } | |
318 | else if (len >= 2 && s[0] == '0' && s[1] == 'b') { | |
319 | s+=2; | |
320 | len-=2; | |
321 | } | |
322 | } | |
323 | } | |
324 | ||
325 | for (; len-- && *s; s++) { | |
326 | char bit = *s; | |
327 | if (bit == '0' || bit == '1') { | |
328 | /* Write it in this wonky order with a goto to attempt to get the | |
329 | compiler to make the common case integer-only loop pretty tight. | |
330 | With gcc seems to be much straighter code than old scan_bin. */ | |
331 | redo: | |
332 | if (!overflowed) { | |
333 | if (value <= max_div_2) { | |
334 | value = (value << 1) | (bit - '0'); | |
335 | continue; | |
336 | } | |
337 | /* Bah. We're just overflowed. */ | |
338 | warn("Integer overflow in binary number"); | |
339 | overflowed = TRUE; | |
340 | value_nv = (NV) value; | |
341 | } | |
342 | value_nv *= 2.0; | |
343 | /* If an NV has not enough bits in its mantissa to | |
344 | * represent a UV this summing of small low-order numbers | |
345 | * is a waste of time (because the NV cannot preserve | |
346 | * the low-order bits anyway): we could just remember when | |
347 | * did we overflow and in the end just multiply value_nv by the | |
348 | * right amount. */ | |
349 | value_nv += (NV)(bit - '0'); | |
350 | continue; | |
351 | } | |
352 | if (bit == '_' && len && allow_underscores && (bit = s[1]) | |
353 | && (bit == '0' || bit == '1')) | |
354 | { | |
355 | --len; | |
356 | ++s; | |
357 | goto redo; | |
358 | } | |
359 | if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) | |
360 | warn("Illegal binary digit '%c' ignored", *s); | |
361 | break; | |
362 | } | |
363 | ||
364 | if ( ( overflowed && value_nv > 4294967295.0) | |
365 | #if UVSIZE > 4 | |
366 | || (!overflowed && value > 0xffffffff ) | |
367 | #endif | |
368 | ) { | |
369 | warn("Binary number > 0b11111111111111111111111111111111 non-portable"); | |
370 | } | |
371 | *len_p = s - start; | |
372 | if (!overflowed) { | |
373 | *flags = 0; | |
374 | return value; | |
375 | } | |
376 | *flags = PERL_SCAN_GREATER_THAN_UV_MAX; | |
377 | if (result) | |
378 | *result = value_nv; | |
379 | return UV_MAX; | |
380 | } | |
381 | #endif | |
382 | #endif | |
383 | ||
384 | #ifndef grok_hex | |
385 | #if { NEED grok_hex } | |
386 | UV | |
387 | grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) | |
388 | { | |
389 | const char *s = start; | |
390 | STRLEN len = *len_p; | |
391 | UV value = 0; | |
392 | NV value_nv = 0; | |
393 | ||
394 | const UV max_div_16 = UV_MAX / 16; | |
395 | bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; | |
396 | bool overflowed = FALSE; | |
397 | const char *xdigit; | |
398 | ||
399 | if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { | |
400 | /* strip off leading x or 0x. | |
401 | for compatibility silently suffer "x" and "0x" as valid hex numbers. | |
402 | */ | |
403 | if (len >= 1) { | |
404 | if (s[0] == 'x') { | |
405 | s++; | |
406 | len--; | |
407 | } | |
408 | else if (len >= 2 && s[0] == '0' && s[1] == 'x') { | |
409 | s+=2; | |
410 | len-=2; | |
411 | } | |
412 | } | |
413 | } | |
414 | ||
415 | for (; len-- && *s; s++) { | |
416 | xdigit = strchr((char *) PL_hexdigit, *s); | |
417 | if (xdigit) { | |
418 | /* Write it in this wonky order with a goto to attempt to get the | |
419 | compiler to make the common case integer-only loop pretty tight. | |
420 | With gcc seems to be much straighter code than old scan_hex. */ | |
421 | redo: | |
422 | if (!overflowed) { | |
423 | if (value <= max_div_16) { | |
424 | value = (value << 4) | ((xdigit - PL_hexdigit) & 15); | |
425 | continue; | |
426 | } | |
427 | warn("Integer overflow in hexadecimal number"); | |
428 | overflowed = TRUE; | |
429 | value_nv = (NV) value; | |
430 | } | |
431 | value_nv *= 16.0; | |
432 | /* If an NV has not enough bits in its mantissa to | |
433 | * represent a UV this summing of small low-order numbers | |
434 | * is a waste of time (because the NV cannot preserve | |
435 | * the low-order bits anyway): we could just remember when | |
436 | * did we overflow and in the end just multiply value_nv by the | |
437 | * right amount of 16-tuples. */ | |
438 | value_nv += (NV)((xdigit - PL_hexdigit) & 15); | |
439 | continue; | |
440 | } | |
441 | if (*s == '_' && len && allow_underscores && s[1] | |
442 | && (xdigit = strchr((char *) PL_hexdigit, s[1]))) | |
443 | { | |
444 | --len; | |
445 | ++s; | |
446 | goto redo; | |
447 | } | |
448 | if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) | |
449 | warn("Illegal hexadecimal digit '%c' ignored", *s); | |
450 | break; | |
451 | } | |
452 | ||
453 | if ( ( overflowed && value_nv > 4294967295.0) | |
454 | #if UVSIZE > 4 | |
455 | || (!overflowed && value > 0xffffffff ) | |
456 | #endif | |
457 | ) { | |
458 | warn("Hexadecimal number > 0xffffffff non-portable"); | |
459 | } | |
460 | *len_p = s - start; | |
461 | if (!overflowed) { | |
462 | *flags = 0; | |
463 | return value; | |
464 | } | |
465 | *flags = PERL_SCAN_GREATER_THAN_UV_MAX; | |
466 | if (result) | |
467 | *result = value_nv; | |
468 | return UV_MAX; | |
469 | } | |
470 | #endif | |
471 | #endif | |
472 | ||
473 | #ifndef grok_oct | |
474 | #if { NEED grok_oct } | |
475 | UV | |
476 | grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) | |
477 | { | |
478 | const char *s = start; | |
479 | STRLEN len = *len_p; | |
480 | UV value = 0; | |
481 | NV value_nv = 0; | |
482 | ||
483 | const UV max_div_8 = UV_MAX / 8; | |
484 | bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; | |
485 | bool overflowed = FALSE; | |
486 | ||
487 | for (; len-- && *s; s++) { | |
488 | /* gcc 2.95 optimiser not smart enough to figure that this subtraction | |
489 | out front allows slicker code. */ | |
490 | int digit = *s - '0'; | |
491 | if (digit >= 0 && digit <= 7) { | |
492 | /* Write it in this wonky order with a goto to attempt to get the | |
493 | compiler to make the common case integer-only loop pretty tight. | |
494 | */ | |
495 | redo: | |
496 | if (!overflowed) { | |
497 | if (value <= max_div_8) { | |
498 | value = (value << 3) | digit; | |
499 | continue; | |
500 | } | |
501 | /* Bah. We're just overflowed. */ | |
502 | warn("Integer overflow in octal number"); | |
503 | overflowed = TRUE; | |
504 | value_nv = (NV) value; | |
505 | } | |
506 | value_nv *= 8.0; | |
507 | /* If an NV has not enough bits in its mantissa to | |
508 | * represent a UV this summing of small low-order numbers | |
509 | * is a waste of time (because the NV cannot preserve | |
510 | * the low-order bits anyway): we could just remember when | |
511 | * did we overflow and in the end just multiply value_nv by the | |
512 | * right amount of 8-tuples. */ | |
513 | value_nv += (NV)digit; | |
514 | continue; | |
515 | } | |
516 | if (digit == ('_' - '0') && len && allow_underscores | |
517 | && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) | |
518 | { | |
519 | --len; | |
520 | ++s; | |
521 | goto redo; | |
522 | } | |
523 | /* Allow \octal to work the DWIM way (that is, stop scanning | |
524 | * as soon as non-octal characters are seen, complain only iff | |
525 | * someone seems to want to use the digits eight and nine). */ | |
526 | if (digit == 8 || digit == 9) { | |
527 | if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) | |
528 | warn("Illegal octal digit '%c' ignored", *s); | |
529 | } | |
530 | break; | |
531 | } | |
532 | ||
533 | if ( ( overflowed && value_nv > 4294967295.0) | |
534 | #if UVSIZE > 4 | |
535 | || (!overflowed && value > 0xffffffff ) | |
536 | #endif | |
537 | ) { | |
538 | warn("Octal number > 037777777777 non-portable"); | |
539 | } | |
540 | *len_p = s - start; | |
541 | if (!overflowed) { | |
542 | *flags = 0; | |
543 | return value; | |
544 | } | |
545 | *flags = PERL_SCAN_GREATER_THAN_UV_MAX; | |
546 | if (result) | |
547 | *result = value_nv; | |
548 | return UV_MAX; | |
549 | } | |
550 | #endif | |
551 | #endif | |
552 | ||
553 | =xsinit | |
554 | ||
555 | #define NEED_grok_number | |
556 | #define NEED_grok_numeric_radix | |
557 | #define NEED_grok_bin | |
558 | #define NEED_grok_hex | |
559 | #define NEED_grok_oct | |
560 | ||
561 | =xsubs | |
562 | ||
563 | UV | |
564 | grok_number(string) | |
565 | SV *string | |
566 | PREINIT: | |
567 | const char *pv; | |
568 | STRLEN len; | |
569 | CODE: | |
570 | pv = SvPV(string, len); | |
571 | if (!grok_number(pv, len, &RETVAL)) | |
572 | XSRETURN_UNDEF; | |
573 | OUTPUT: | |
574 | RETVAL | |
575 | ||
576 | UV | |
577 | grok_bin(string) | |
578 | SV *string | |
579 | PREINIT: | |
580 | char *pv; | |
581 | I32 flags; | |
582 | STRLEN len; | |
583 | CODE: | |
584 | pv = SvPV(string, len); | |
585 | RETVAL = grok_bin(pv, &len, &flags, NULL); | |
586 | OUTPUT: | |
587 | RETVAL | |
588 | ||
589 | UV | |
590 | grok_hex(string) | |
591 | SV *string | |
592 | PREINIT: | |
593 | char *pv; | |
594 | I32 flags; | |
595 | STRLEN len; | |
596 | CODE: | |
597 | pv = SvPV(string, len); | |
598 | RETVAL = grok_hex(pv, &len, &flags, NULL); | |
599 | OUTPUT: | |
600 | RETVAL | |
601 | ||
602 | UV | |
603 | grok_oct(string) | |
604 | SV *string | |
605 | PREINIT: | |
606 | char *pv; | |
607 | I32 flags; | |
608 | STRLEN len; | |
609 | CODE: | |
610 | pv = SvPV(string, len); | |
611 | RETVAL = grok_oct(pv, &len, &flags, NULL); | |
612 | OUTPUT: | |
613 | RETVAL | |
614 | ||
615 | UV | |
616 | Perl_grok_number(string) | |
617 | SV *string | |
618 | PREINIT: | |
619 | const char *pv; | |
620 | STRLEN len; | |
621 | CODE: | |
622 | pv = SvPV(string, len); | |
623 | if (!Perl_grok_number(aTHX_ pv, len, &RETVAL)) | |
624 | XSRETURN_UNDEF; | |
625 | OUTPUT: | |
626 | RETVAL | |
627 | ||
628 | UV | |
629 | Perl_grok_bin(string) | |
630 | SV *string | |
631 | PREINIT: | |
632 | char *pv; | |
633 | I32 flags; | |
634 | STRLEN len; | |
635 | CODE: | |
636 | pv = SvPV(string, len); | |
637 | RETVAL = Perl_grok_bin(aTHX_ pv, &len, &flags, NULL); | |
638 | OUTPUT: | |
639 | RETVAL | |
640 | ||
641 | UV | |
642 | Perl_grok_hex(string) | |
643 | SV *string | |
644 | PREINIT: | |
645 | char *pv; | |
646 | I32 flags; | |
647 | STRLEN len; | |
648 | CODE: | |
649 | pv = SvPV(string, len); | |
650 | RETVAL = Perl_grok_hex(aTHX_ pv, &len, &flags, NULL); | |
651 | OUTPUT: | |
652 | RETVAL | |
653 | ||
654 | UV | |
655 | Perl_grok_oct(string) | |
656 | SV *string | |
657 | PREINIT: | |
658 | char *pv; | |
659 | I32 flags; | |
660 | STRLEN len; | |
661 | CODE: | |
662 | pv = SvPV(string, len); | |
663 | RETVAL = Perl_grok_oct(aTHX_ pv, &len, &flags, NULL); | |
664 | OUTPUT: | |
665 | RETVAL | |
666 | ||
667 | =tests plan => 10 | |
668 | ||
669 | ok(&Devel::PPPort::grok_number("42"), 42); | |
670 | ok(!defined(&Devel::PPPort::grok_number("A"))); | |
671 | ok(&Devel::PPPort::grok_bin("10000001"), 129); | |
672 | ok(&Devel::PPPort::grok_hex("deadbeef"), 0xdeadbeef); | |
673 | ok(&Devel::PPPort::grok_oct("377"), 255); | |
674 | ||
675 | ok(&Devel::PPPort::Perl_grok_number("42"), 42); | |
676 | ok(!defined(&Devel::PPPort::Perl_grok_number("A"))); | |
677 | ok(&Devel::PPPort::Perl_grok_bin("10000001"), 129); | |
678 | ok(&Devel::PPPort::Perl_grok_hex("deadbeef"), 0xdeadbeef); | |
679 | ok(&Devel::PPPort::Perl_grok_oct("377"), 255); | |
680 |