Commit | Line | Data |
---|---|---|
abc6d738 FC |
1 | /* This file is part of the "version" CPAN distribution. Please avoid |
2 | editing it in the perl core. */ | |
3 | ||
14f3031b JP |
4 | #ifdef PERL_CORE |
5 | # include "vutil.h" | |
d4e59e62 | 6 | #endif |
d4e59e62 | 7 | |
abc6d738 FC |
8 | #define VERSION_MAX 0x7FFFFFFF |
9 | ||
10 | /* | |
9eabb0a9 SH |
11 | =for apidoc_section Versioning |
12 | ||
abc6d738 FC |
13 | =for apidoc prescan_version |
14 | ||
15 | Validate that a given string can be parsed as a version object, but doesn't | |
16 | actually perform the parsing. Can use either strict or lax validation rules. | |
17 | Can optionally set a number of hint variables to save the parsing code | |
18 | some time when tokenizing. | |
19 | ||
20 | =cut | |
21 | */ | |
22 | const char * | |
24120986 | 23 | #ifdef VUTIL_REPLACE_CORE |
d4e59e62 FC |
24 | Perl_prescan_version2(pTHX_ const char *s, bool strict, |
25 | #else | |
abc6d738 | 26 | Perl_prescan_version(pTHX_ const char *s, bool strict, |
d4e59e62 | 27 | #endif |
abc6d738 FC |
28 | const char **errstr, |
29 | bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) { | |
30 | bool qv = (sqv ? *sqv : FALSE); | |
31 | int width = 3; | |
32 | int saw_decimal = 0; | |
33 | bool alpha = FALSE; | |
34 | const char *d = s; | |
35 | ||
130cad93 LT |
36 | PERL_ARGS_ASSERT_PRESCAN_VERSION; |
37 | PERL_UNUSED_CONTEXT; | |
abc6d738 FC |
38 | |
39 | if (qv && isDIGIT(*d)) | |
40 | goto dotted_decimal_version; | |
41 | ||
42 | if (*d == 'v') { /* explicit v-string */ | |
43 | d++; | |
44 | if (isDIGIT(*d)) { | |
45 | qv = TRUE; | |
46 | } | |
47 | else { /* degenerate v-string */ | |
48 | /* requires v1.2.3 */ | |
49 | BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); | |
50 | } | |
51 | ||
52 | dotted_decimal_version: | |
53 | if (strict && d[0] == '0' && isDIGIT(d[1])) { | |
54 | /* no leading zeros allowed */ | |
55 | BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); | |
56 | } | |
57 | ||
58 | while (isDIGIT(*d)) /* integer part */ | |
59 | d++; | |
60 | ||
61 | if (*d == '.') | |
62 | { | |
63 | saw_decimal++; | |
64 | d++; /* decimal point */ | |
65 | } | |
66 | else | |
67 | { | |
68 | if (strict) { | |
69 | /* require v1.2.3 */ | |
70 | BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); | |
71 | } | |
72 | else { | |
73 | goto version_prescan_finish; | |
74 | } | |
75 | } | |
76 | ||
77 | { | |
78 | int i = 0; | |
79 | int j = 0; | |
80 | while (isDIGIT(*d)) { /* just keep reading */ | |
81 | i++; | |
82 | while (isDIGIT(*d)) { | |
83 | d++; j++; | |
84 | /* maximum 3 digits between decimal */ | |
85 | if (strict && j > 3) { | |
86 | BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)"); | |
87 | } | |
88 | } | |
89 | if (*d == '_') { | |
90 | if (strict) { | |
91 | BADVERSION(s,errstr,"Invalid version format (no underscores)"); | |
92 | } | |
93 | if ( alpha ) { | |
94 | BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); | |
95 | } | |
96 | d++; | |
97 | alpha = TRUE; | |
98 | } | |
99 | else if (*d == '.') { | |
100 | if (alpha) { | |
101 | BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); | |
102 | } | |
103 | saw_decimal++; | |
104 | d++; | |
105 | } | |
106 | else if (!isDIGIT(*d)) { | |
107 | break; | |
108 | } | |
109 | j = 0; | |
110 | } | |
111 | ||
112 | if (strict && i < 2) { | |
113 | /* requires v1.2.3 */ | |
114 | BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); | |
115 | } | |
116 | } | |
117 | } /* end if dotted-decimal */ | |
118 | else | |
119 | { /* decimal versions */ | |
120 | int j = 0; /* may need this later */ | |
121 | /* special strict case for leading '.' or '0' */ | |
122 | if (strict) { | |
123 | if (*d == '.') { | |
124 | BADVERSION(s,errstr,"Invalid version format (0 before decimal required)"); | |
125 | } | |
126 | if (*d == '0' && isDIGIT(d[1])) { | |
127 | BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); | |
128 | } | |
129 | } | |
130 | ||
131 | /* and we never support negative versions */ | |
132 | if ( *d == '-') { | |
133 | BADVERSION(s,errstr,"Invalid version format (negative version number)"); | |
134 | } | |
135 | ||
136 | /* consume all of the integer part */ | |
137 | while (isDIGIT(*d)) | |
138 | d++; | |
139 | ||
140 | /* look for a fractional part */ | |
141 | if (*d == '.') { | |
142 | /* we found it, so consume it */ | |
143 | saw_decimal++; | |
144 | d++; | |
145 | } | |
146 | else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') { | |
147 | if ( d == s ) { | |
148 | /* found nothing */ | |
149 | BADVERSION(s,errstr,"Invalid version format (version required)"); | |
150 | } | |
151 | /* found just an integer */ | |
152 | goto version_prescan_finish; | |
153 | } | |
154 | else if ( d == s ) { | |
155 | /* didn't find either integer or period */ | |
156 | BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); | |
157 | } | |
158 | else if (*d == '_') { | |
159 | /* underscore can't come after integer part */ | |
160 | if (strict) { | |
161 | BADVERSION(s,errstr,"Invalid version format (no underscores)"); | |
162 | } | |
163 | else if (isDIGIT(d[1])) { | |
164 | BADVERSION(s,errstr,"Invalid version format (alpha without decimal)"); | |
165 | } | |
166 | else { | |
167 | BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); | |
168 | } | |
169 | } | |
170 | else { | |
171 | /* anything else after integer part is just invalid data */ | |
172 | BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); | |
173 | } | |
174 | ||
175 | /* scan the fractional part after the decimal point*/ | |
176 | ||
177 | if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) { | |
178 | /* strict or lax-but-not-the-end */ | |
179 | BADVERSION(s,errstr,"Invalid version format (fractional part required)"); | |
180 | } | |
181 | ||
182 | while (isDIGIT(*d)) { | |
183 | d++; j++; | |
184 | if (*d == '.' && isDIGIT(d[-1])) { | |
185 | if (alpha) { | |
186 | BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); | |
187 | } | |
188 | if (strict) { | |
189 | BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); | |
190 | } | |
191 | d = (char *)s; /* start all over again */ | |
192 | qv = TRUE; | |
193 | goto dotted_decimal_version; | |
194 | } | |
195 | if (*d == '_') { | |
196 | if (strict) { | |
197 | BADVERSION(s,errstr,"Invalid version format (no underscores)"); | |
198 | } | |
199 | if ( alpha ) { | |
200 | BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); | |
201 | } | |
202 | if ( ! isDIGIT(d[1]) ) { | |
203 | BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); | |
204 | } | |
205 | width = j; | |
206 | d++; | |
207 | alpha = TRUE; | |
208 | } | |
209 | } | |
210 | } | |
211 | ||
212 | version_prescan_finish: | |
213 | while (isSPACE(*d)) | |
214 | d++; | |
215 | ||
216 | if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) { | |
217 | /* trailing non-numeric data */ | |
218 | BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); | |
219 | } | |
14f3031b JP |
220 | if (saw_decimal > 1 && d[-1] == '.') { |
221 | /* no trailing period allowed */ | |
222 | BADVERSION(s,errstr,"Invalid version format (trailing decimal)"); | |
223 | } | |
224 | ||
abc6d738 FC |
225 | |
226 | if (sqv) | |
227 | *sqv = qv; | |
228 | if (swidth) | |
229 | *swidth = width; | |
230 | if (ssaw_decimal) | |
231 | *ssaw_decimal = saw_decimal; | |
232 | if (salpha) | |
233 | *salpha = alpha; | |
234 | return d; | |
235 | } | |
236 | ||
237 | /* | |
238 | =for apidoc scan_version | |
239 | ||
240 | Returns a pointer to the next character after the parsed | |
241 | version string, as well as upgrading the passed in SV to | |
242 | an RV. | |
243 | ||
244 | Function must be called with an already existing SV like | |
245 | ||
246 | sv = newSV(0); | |
247 | s = scan_version(s, SV *sv, bool qv); | |
248 | ||
249 | Performs some preprocessing to the string to ensure that | |
250 | it has the correct characteristics of a version. Flags the | |
251 | object if it contains an underscore (which denotes this | |
252 | is an alpha version). The boolean qv denotes that the version | |
253 | should be interpreted as if it had multiple decimals, even if | |
254 | it doesn't. | |
255 | ||
256 | =cut | |
257 | */ | |
258 | ||
259 | const char * | |
24120986 | 260 | #ifdef VUTIL_REPLACE_CORE |
d4e59e62 FC |
261 | Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv) |
262 | #else | |
abc6d738 | 263 | Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) |
d4e59e62 | 264 | #endif |
abc6d738 FC |
265 | { |
266 | const char *start = s; | |
267 | const char *pos; | |
268 | const char *last; | |
269 | const char *errstr = NULL; | |
270 | int saw_decimal = 0; | |
271 | int width = 3; | |
272 | bool alpha = FALSE; | |
273 | bool vinf = FALSE; | |
274 | AV * av; | |
275 | SV * hv; | |
276 | ||
277 | PERL_ARGS_ASSERT_SCAN_VERSION; | |
278 | ||
279 | while (isSPACE(*s)) /* leading whitespace is OK */ | |
280 | s++; | |
281 | ||
d4e59e62 | 282 | last = PRESCAN_VERSION(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha); |
abc6d738 FC |
283 | if (errstr) { |
284 | /* "undef" is a special case and not an error */ | |
05402f6b | 285 | if ( ! ( *s == 'u' && strEQ(s+1,"ndef")) ) { |
abc6d738 FC |
286 | Perl_croak(aTHX_ "%s", errstr); |
287 | } | |
288 | } | |
289 | ||
290 | start = s; | |
291 | if (*s == 'v') | |
292 | s++; | |
293 | pos = s; | |
294 | ||
295 | /* Now that we are through the prescan, start creating the object */ | |
296 | av = newAV(); | |
297 | hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ | |
298 | (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ | |
299 | ||
300 | #ifndef NODEFAULT_SHAREKEYS | |
301 | HvSHAREKEYS_on(hv); /* key-sharing on by default */ | |
302 | #endif | |
303 | ||
304 | if ( qv ) | |
305 | (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv)); | |
306 | if ( alpha ) | |
307 | (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha)); | |
308 | if ( !qv && width < 3 ) | |
309 | (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); | |
310 | ||
14f3031b | 311 | while (isDIGIT(*pos) || *pos == '_') |
abc6d738 FC |
312 | pos++; |
313 | if (!isALPHA(*pos)) { | |
314 | I32 rev; | |
315 | ||
316 | for (;;) { | |
317 | rev = 0; | |
318 | { | |
319 | /* this is atoi() that delimits on underscores */ | |
320 | const char *end = pos; | |
321 | I32 mult = 1; | |
322 | I32 orev; | |
323 | ||
324 | /* the following if() will only be true after the decimal | |
325 | * point of a version originally created with a bare | |
326 | * floating point number, i.e. not quoted in any way | |
327 | */ | |
328 | if ( !qv && s > start && saw_decimal == 1 ) { | |
329 | mult *= 100; | |
330 | while ( s < end ) { | |
14f3031b JP |
331 | if (*s == '_') |
332 | continue; | |
abc6d738 FC |
333 | orev = rev; |
334 | rev += (*s - '0') * mult; | |
335 | mult /= 10; | |
336 | if ( (PERL_ABS(orev) > PERL_ABS(rev)) | |
337 | || (PERL_ABS(rev) > VERSION_MAX )) { | |
338 | Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), | |
339 | "Integer overflow in version %d",VERSION_MAX); | |
340 | s = end - 1; | |
341 | rev = VERSION_MAX; | |
342 | vinf = 1; | |
343 | } | |
344 | s++; | |
345 | if ( *s == '_' ) | |
346 | s++; | |
347 | } | |
348 | } | |
349 | else { | |
350 | while (--end >= s) { | |
14f3031b JP |
351 | int i; |
352 | if (*end == '_') | |
353 | continue; | |
354 | i = (*end - '0'); | |
355 | if ( (mult == VERSION_MAX) | |
356 | || (i > VERSION_MAX / mult) | |
357 | || (i * mult > VERSION_MAX - rev)) | |
358 | { | |
abc6d738 FC |
359 | Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), |
360 | "Integer overflow in version"); | |
361 | end = s - 1; | |
362 | rev = VERSION_MAX; | |
363 | vinf = 1; | |
364 | } | |
14f3031b JP |
365 | else |
366 | rev += i * mult; | |
367 | ||
368 | if (mult > VERSION_MAX / 10) | |
369 | mult = VERSION_MAX; | |
370 | else | |
371 | mult *= 10; | |
abc6d738 FC |
372 | } |
373 | } | |
374 | } | |
375 | ||
376 | /* Append revision */ | |
377 | av_push(av, newSViv(rev)); | |
378 | if ( vinf ) { | |
379 | s = last; | |
380 | break; | |
381 | } | |
14f3031b JP |
382 | else if ( *pos == '.' ) { |
383 | pos++; | |
384 | if (qv) { | |
385 | while (*pos == '0') | |
386 | ++pos; | |
387 | } | |
388 | s = pos; | |
389 | } | |
abc6d738 FC |
390 | else if ( *pos == '_' && isDIGIT(pos[1]) ) |
391 | s = ++pos; | |
392 | else if ( *pos == ',' && isDIGIT(pos[1]) ) | |
393 | s = ++pos; | |
394 | else if ( isDIGIT(*pos) ) | |
395 | s = pos; | |
396 | else { | |
397 | s = pos; | |
398 | break; | |
399 | } | |
400 | if ( qv ) { | |
14f3031b | 401 | while ( isDIGIT(*pos) || *pos == '_') |
abc6d738 FC |
402 | pos++; |
403 | } | |
404 | else { | |
405 | int digits = 0; | |
406 | while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) { | |
407 | if ( *pos != '_' ) | |
408 | digits++; | |
409 | pos++; | |
410 | } | |
411 | } | |
412 | } | |
413 | } | |
414 | if ( qv ) { /* quoted versions always get at least three terms*/ | |
05402f6b | 415 | SSize_t len = AvFILLp(av); |
abc6d738 FC |
416 | /* This for loop appears to trigger a compiler bug on OS X, as it |
417 | loops infinitely. Yes, len is negative. No, it makes no sense. | |
418 | Compiler in question is: | |
419 | gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) | |
420 | for ( len = 2 - len; len > 0; len-- ) | |
421 | av_push(MUTABLE_AV(sv), newSViv(0)); | |
422 | */ | |
423 | len = 2 - len; | |
424 | while (len-- > 0) | |
425 | av_push(av, newSViv(0)); | |
426 | } | |
427 | ||
428 | /* need to save off the current version string for later */ | |
429 | if ( vinf ) { | |
430 | SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1); | |
431 | (void)hv_stores(MUTABLE_HV(hv), "original", orig); | |
432 | (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1)); | |
433 | } | |
434 | else if ( s > start ) { | |
435 | SV * orig = newSVpvn(start,s-start); | |
436 | if ( qv && saw_decimal == 1 && *start != 'v' ) { | |
437 | /* need to insert a v to be consistent */ | |
438 | sv_insert(orig, 0, 0, "v", 1); | |
439 | } | |
440 | (void)hv_stores(MUTABLE_HV(hv), "original", orig); | |
441 | } | |
442 | else { | |
443 | (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0")); | |
444 | av_push(av, newSViv(0)); | |
445 | } | |
446 | ||
447 | /* And finally, store the AV in the hash */ | |
448 | (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); | |
449 | ||
450 | /* fix RT#19517 - special case 'undef' as string */ | |
05402f6b | 451 | if ( *s == 'u' && strEQ(s+1,"ndef") ) { |
abc6d738 FC |
452 | s += 5; |
453 | } | |
454 | ||
455 | return s; | |
456 | } | |
457 | ||
458 | /* | |
459 | =for apidoc new_version | |
460 | ||
461 | Returns a new version object based on the passed in SV: | |
462 | ||
463 | SV *sv = new_version(SV *ver); | |
464 | ||
465 | Does not alter the passed in ver SV. See "upg_version" if you | |
466 | want to upgrade the SV. | |
467 | ||
468 | =cut | |
469 | */ | |
470 | ||
471 | SV * | |
24120986 | 472 | #ifdef VUTIL_REPLACE_CORE |
d4e59e62 FC |
473 | Perl_new_version2(pTHX_ SV *ver) |
474 | #else | |
abc6d738 | 475 | Perl_new_version(pTHX_ SV *ver) |
d4e59e62 | 476 | #endif |
abc6d738 | 477 | { |
abc6d738 FC |
478 | SV * const rv = newSV(0); |
479 | PERL_ARGS_ASSERT_NEW_VERSION; | |
05402f6b | 480 | if ( ISA_VERSION_OBJ(ver) ) /* can just copy directly */ |
abc6d738 FC |
481 | { |
482 | SSize_t key; | |
483 | AV * const av = newAV(); | |
484 | AV *sav; | |
485 | /* This will get reblessed later if a derived class*/ | |
486 | SV * const hv = newSVrv(rv, "version"); | |
487 | (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ | |
488 | #ifndef NODEFAULT_SHAREKEYS | |
489 | HvSHAREKEYS_on(hv); /* key-sharing on by default */ | |
490 | #endif | |
491 | ||
492 | if ( SvROK(ver) ) | |
493 | ver = SvRV(ver); | |
494 | ||
495 | /* Begin copying all of the elements */ | |
817794ed | 496 | if ( hv_exists(MUTABLE_HV(ver), "qv", 2) ) |
abc6d738 FC |
497 | (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1)); |
498 | ||
817794ed | 499 | if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) ) |
abc6d738 | 500 | (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1)); |
abc6d738 | 501 | { |
05402f6b JP |
502 | SV ** svp = hv_fetchs(MUTABLE_HV(ver), "width", FALSE); |
503 | if(svp) { | |
504 | const I32 width = SvIV(*svp); | |
505 | (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); | |
506 | } | |
abc6d738 | 507 | } |
abc6d738 | 508 | { |
05402f6b JP |
509 | SV ** svp = hv_fetchs(MUTABLE_HV(ver), "original", FALSE); |
510 | if(svp) | |
511 | (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(*svp)); | |
abc6d738 | 512 | } |
abc6d738 FC |
513 | sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE))); |
514 | /* This will get reblessed later if a derived class*/ | |
515 | for ( key = 0; key <= av_len(sav); key++ ) | |
516 | { | |
05402f6b JP |
517 | SV * const sv = *av_fetch(sav, key, FALSE); |
518 | const I32 rev = SvIV(sv); | |
abc6d738 FC |
519 | av_push(av, newSViv(rev)); |
520 | } | |
521 | ||
522 | (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); | |
523 | return rv; | |
524 | } | |
525 | #ifdef SvVOK | |
526 | { | |
527 | const MAGIC* const mg = SvVSTRING_mg(ver); | |
528 | if ( mg ) { /* already a v-string */ | |
529 | const STRLEN len = mg->mg_len; | |
05402f6b | 530 | const char * const version = (const char*)mg->mg_ptr; |
14f3031b JP |
531 | char *raw, *under; |
532 | static const char underscore[] = "_"; | |
abc6d738 | 533 | sv_setpvn(rv,version,len); |
14f3031b JP |
534 | raw = SvPV_nolen(rv); |
535 | under = ninstr(raw, raw+len, underscore, underscore + 1); | |
536 | if (under) { | |
537 | Move(under + 1, under, raw + len - under - 1, char); | |
2324bdb9 | 538 | SvCUR_set(rv, SvCUR(rv) - 1); |
14f3031b JP |
539 | *SvEND(rv) = '\0'; |
540 | } | |
abc6d738 FC |
541 | /* this is for consistency with the pure Perl class */ |
542 | if ( isDIGIT(*version) ) | |
543 | sv_insert(rv, 0, 0, "v", 1); | |
abc6d738 FC |
544 | } |
545 | else { | |
546 | #endif | |
95a23f5d | 547 | SvSetSV_nosteal(rv, ver); /* make a duplicate */ |
abc6d738 FC |
548 | #ifdef SvVOK |
549 | } | |
550 | } | |
551 | #endif | |
9190f8ab JP |
552 | sv_2mortal(rv); /* in case upg_version croaks before it returns */ |
553 | return SvREFCNT_inc_NN(UPG_VERSION(rv, FALSE)); | |
abc6d738 FC |
554 | } |
555 | ||
556 | /* | |
557 | =for apidoc upg_version | |
558 | ||
559 | In-place upgrade of the supplied SV to a version object. | |
560 | ||
561 | SV *sv = upg_version(SV *sv, bool qv); | |
562 | ||
563 | Returns a pointer to the upgraded SV. Set the boolean qv if you want | |
564 | to force this SV to be interpreted as an "extended" version. | |
565 | ||
566 | =cut | |
567 | */ | |
568 | ||
569 | SV * | |
24120986 | 570 | #ifdef VUTIL_REPLACE_CORE |
d4e59e62 FC |
571 | Perl_upg_version2(pTHX_ SV *ver, bool qv) |
572 | #else | |
abc6d738 | 573 | Perl_upg_version(pTHX_ SV *ver, bool qv) |
d4e59e62 | 574 | #endif |
abc6d738 FC |
575 | { |
576 | const char *version, *s; | |
577 | #ifdef SvVOK | |
578 | const MAGIC *mg; | |
579 | #endif | |
580 | ||
d2b110e6 | 581 | #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS) |
e2ca569e | 582 | ENTER; |
d2b110e6 | 583 | #endif |
abc6d738 FC |
584 | PERL_ARGS_ASSERT_UPG_VERSION; |
585 | ||
9190f8ab JP |
586 | if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX) |
587 | || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) { | |
588 | /* out of bounds [unsigned] integer */ | |
589 | STRLEN len; | |
590 | char tbuf[64]; | |
591 | len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX); | |
592 | version = savepvn(tbuf, len); | |
593 | SAVEFREEPV(version); | |
594 | Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), | |
595 | "Integer overflow in version %d",VERSION_MAX); | |
596 | } | |
597 | else if ( SvUOK(ver) || SvIOK(ver)) | |
24120986 | 598 | #if PERL_VERSION_LT(5,17,2) |
9190f8ab | 599 | VER_IV: |
24120986 | 600 | #endif |
9190f8ab JP |
601 | { |
602 | version = savesvpv(ver); | |
603 | SAVEFREEPV(version); | |
604 | } | |
605 | else if (SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) ) | |
24120986 | 606 | #if PERL_VERSION_LT(5,17,2) |
9190f8ab | 607 | VER_NV: |
24120986 | 608 | #endif |
abc6d738 FC |
609 | { |
610 | STRLEN len; | |
611 | ||
612 | /* may get too much accuracy */ | |
613 | char tbuf[64]; | |
614 | SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0; | |
615 | char *buf; | |
14f3031b JP |
616 | |
617 | #if PERL_VERSION_GE(5,19,0) | |
618 | if (SvPOK(ver)) { | |
619 | /* dualvar? */ | |
620 | goto VER_PV; | |
621 | } | |
622 | #endif | |
f57000bc | 623 | #ifdef USE_LOCALE_NUMERIC |
190ce35b | 624 | |
d3a5b29c | 625 | { |
190ce35b KW |
626 | /* This may or may not be called from code that has switched |
627 | * locales without letting perl know, therefore we have to find it | |
628 | * from first principals. See [perl #121930]. */ | |
629 | ||
e9bc6d6b KW |
630 | /* In windows, or not threaded, or not thread-safe, if it isn't C, |
631 | * set it to C. */ | |
632 | ||
633 | # ifndef USE_POSIX_2008_LOCALE | |
634 | ||
190ce35b KW |
635 | const char * locale_name_on_entry; |
636 | ||
49d7d366 KW |
637 | LC_NUMERIC_LOCK(0); /* Start critical section */ |
638 | ||
190ce35b KW |
639 | locale_name_on_entry = setlocale(LC_NUMERIC, NULL); |
640 | if ( strNE(locale_name_on_entry, "C") | |
641 | && strNE(locale_name_on_entry, "POSIX")) | |
642 | { | |
bcb1da5c TC |
643 | /* the setlocale() call might free or overwrite the name */ |
644 | locale_name_on_entry = savepv(locale_name_on_entry); | |
190ce35b KW |
645 | setlocale(LC_NUMERIC, "C"); |
646 | } | |
647 | else { /* This value indicates to the restore code that we didn't | |
648 | change the locale */ | |
649 | locale_name_on_entry = NULL; | |
650 | } | |
49d7d366 | 651 | |
e9bc6d6b KW |
652 | # else |
653 | ||
654 | const locale_t locale_obj_on_entry = uselocale((locale_t) 0); | |
655 | const char * locale_name_on_entry = NULL; | |
656 | DECLARATION_FOR_LC_NUMERIC_MANIPULATION; | |
657 | ||
658 | if (locale_obj_on_entry == LC_GLOBAL_LOCALE) { | |
659 | ||
660 | /* in the global locale, we can call system setlocale and if it | |
661 | * isn't C, set it to C. */ | |
662 | LC_NUMERIC_LOCK(0); | |
663 | ||
664 | locale_name_on_entry = setlocale(LC_NUMERIC, NULL); | |
665 | if ( strNE(locale_name_on_entry, "C") | |
666 | && strNE(locale_name_on_entry, "POSIX")) | |
667 | { | |
bcb1da5c TC |
668 | /* the setlocale() call might free or overwrite the name */ |
669 | locale_name_on_entry = savepv(locale_name_on_entry); | |
e9bc6d6b KW |
670 | setlocale(LC_NUMERIC, "C"); |
671 | } | |
672 | else { /* This value indicates to the restore code that we | |
673 | didn't change the locale */ | |
674 | locale_name_on_entry = NULL; | |
d3a5b29c JP |
675 | } |
676 | } | |
e9bc6d6b KW |
677 | else if (locale_obj_on_entry == PL_underlying_numeric_obj) { |
678 | /* Here, the locale appears to have been changed to use the | |
679 | * program's underlying locale. Just use our mechanisms to | |
680 | * switch back to C. It might be possible for this pointer to | |
681 | * actually refer to something else if it got released and | |
682 | * reused somehow. But it doesn't matter, our mechanisms will | |
683 | * work even so */ | |
684 | STORE_LC_NUMERIC_SET_STANDARD(); | |
685 | } | |
686 | else if (locale_obj_on_entry != PL_C_locale_obj) { | |
687 | /* The C object should be unchanged during a program's | |
688 | * execution, so it should be safe to assume it means what it | |
689 | * says, so if we are in it, no locale change is required. | |
690 | * Otherwise, simply use the thread-safe operation. */ | |
691 | uselocale(PL_C_locale_obj); | |
692 | } | |
693 | ||
694 | # endif | |
695 | ||
190ce35b KW |
696 | /* Prevent recursed calls from trying to change back */ |
697 | LOCK_LC_NUMERIC_STANDARD(); | |
698 | ||
f57000bc | 699 | #endif |
190ce35b | 700 | |
d3a5b29c | 701 | if (sv) { |
966a3447 | 702 | Perl_sv_setpvf(aTHX_ sv, "%.9" NVff, SvNVX(ver)); |
d3a5b29c JP |
703 | len = SvCUR(sv); |
704 | buf = SvPVX(sv); | |
705 | } | |
706 | else { | |
a6842133 | 707 | len = my_snprintf(tbuf, sizeof(tbuf), "%.9" NVff, SvNVX(ver)); |
d3a5b29c JP |
708 | buf = tbuf; |
709 | } | |
190ce35b KW |
710 | |
711 | #ifdef USE_LOCALE_NUMERIC | |
712 | ||
713 | UNLOCK_LC_NUMERIC_STANDARD(); | |
714 | ||
e9bc6d6b KW |
715 | # ifndef USE_POSIX_2008_LOCALE |
716 | ||
190ce35b KW |
717 | if (locale_name_on_entry) { |
718 | setlocale(LC_NUMERIC, locale_name_on_entry); | |
bcb1da5c | 719 | Safefree(locale_name_on_entry); |
190ce35b | 720 | } |
49d7d366 KW |
721 | |
722 | LC_NUMERIC_UNLOCK; /* End critical section */ | |
723 | ||
e9bc6d6b KW |
724 | # else |
725 | ||
726 | if (locale_name_on_entry) { | |
727 | setlocale(LC_NUMERIC, locale_name_on_entry); | |
bcb1da5c | 728 | Safefree(locale_name_on_entry); |
e9bc6d6b KW |
729 | LC_NUMERIC_UNLOCK; |
730 | } | |
731 | else if (locale_obj_on_entry == PL_underlying_numeric_obj) { | |
732 | RESTORE_LC_NUMERIC(); | |
733 | } | |
734 | else if (locale_obj_on_entry != PL_C_locale_obj) { | |
735 | uselocale(locale_obj_on_entry); | |
d3a5b29c | 736 | } |
e9bc6d6b KW |
737 | |
738 | # endif | |
739 | ||
f57000bc | 740 | } |
190ce35b KW |
741 | |
742 | #endif /* USE_LOCALE_NUMERIC */ | |
743 | ||
abc6d738 FC |
744 | while (buf[len-1] == '0' && len > 0) len--; |
745 | if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */ | |
746 | version = savepvn(buf, len); | |
05402f6b | 747 | SAVEFREEPV(version); |
abc6d738 FC |
748 | SvREFCNT_dec(sv); |
749 | } | |
750 | #ifdef SvVOK | |
751 | else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ | |
752 | version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); | |
05402f6b | 753 | SAVEFREEPV(version); |
abc6d738 FC |
754 | qv = TRUE; |
755 | } | |
756 | #endif | |
9190f8ab JP |
757 | else if ( SvPOK(ver))/* must be a string or something like a string */ |
758 | VER_PV: | |
abc6d738 FC |
759 | { |
760 | STRLEN len; | |
4141ef59 | 761 | version = savepvn(SvPV(ver,len), SvCUR(ver)); |
05402f6b | 762 | SAVEFREEPV(version); |
abc6d738 | 763 | #ifndef SvVOK |
abc6d738 FC |
764 | /* This will only be executed for 5.6.0 - 5.8.0 inclusive */ |
765 | if ( len >= 3 && !instr(version,".") && !instr(version,"_")) { | |
766 | /* may be a v-string */ | |
767 | char *testv = (char *)version; | |
768 | STRLEN tlen = len; | |
769 | for (tlen=0; tlen < len; tlen++, testv++) { | |
770 | /* if one of the characters is non-text assume v-string */ | |
771 | if (testv[0] < ' ') { | |
772 | SV * const nsv = sv_newmortal(); | |
773 | const char *nver; | |
774 | const char *pos; | |
775 | int saw_decimal = 0; | |
776 | sv_setpvf(nsv,"v%vd",ver); | |
777 | pos = nver = savepv(SvPV_nolen(nsv)); | |
05402f6b | 778 | SAVEFREEPV(pos); |
abc6d738 FC |
779 | |
780 | /* scan the resulting formatted string */ | |
781 | pos++; /* skip the leading 'v' */ | |
782 | while ( *pos == '.' || isDIGIT(*pos) ) { | |
783 | if ( *pos == '.' ) | |
784 | saw_decimal++ ; | |
785 | pos++; | |
786 | } | |
787 | ||
788 | /* is definitely a v-string */ | |
789 | if ( saw_decimal >= 2 ) { | |
abc6d738 FC |
790 | version = nver; |
791 | } | |
792 | break; | |
793 | } | |
794 | } | |
795 | } | |
abc6d738 FC |
796 | #endif |
797 | } | |
9190f8ab JP |
798 | #if PERL_VERSION_LT(5,17,2) |
799 | else if (SvIOKp(ver)) { | |
800 | goto VER_IV; | |
801 | } | |
802 | else if (SvNOKp(ver)) { | |
803 | goto VER_NV; | |
804 | } | |
805 | else if (SvPOKp(ver)) { | |
806 | goto VER_PV; | |
807 | } | |
808 | #endif | |
ab4e0d4b JP |
809 | else |
810 | { | |
811 | /* no idea what this is */ | |
812 | Perl_croak(aTHX_ "Invalid version format (non-numeric data)"); | |
813 | } | |
abc6d738 | 814 | |
d4e59e62 | 815 | s = SCAN_VERSION(version, ver, qv); |
abc6d738 FC |
816 | if ( *s != '\0' ) |
817 | Perl_ck_warner(aTHX_ packWARN(WARN_MISC), | |
818 | "Version string '%s' contains invalid data; " | |
819 | "ignoring: '%s'", version, s); | |
d2b110e6 JP |
820 | |
821 | #if PERL_VERSION_LT(5,19,8) && defined(USE_ITHREADS) | |
e2ca569e | 822 | LEAVE; |
d2b110e6 | 823 | #endif |
9190f8ab | 824 | |
abc6d738 FC |
825 | return ver; |
826 | } | |
827 | ||
828 | /* | |
829 | =for apidoc vverify | |
830 | ||
831 | Validates that the SV contains valid internal structure for a version object. | |
832 | It may be passed either the version object (RV) or the hash itself (HV). If | |
833 | the structure is valid, it returns the HV. If the structure is invalid, | |
834 | it returns NULL. | |
835 | ||
836 | SV *hv = vverify(sv); | |
837 | ||
838 | Note that it only confirms the bare minimum structure (so as not to get | |
839 | confused by derived classes which may contain additional hash entries): | |
840 | ||
841 | =over 4 | |
842 | ||
843 | =item * The SV is an HV or a reference to an HV | |
844 | ||
845 | =item * The hash contains a "version" key | |
846 | ||
847 | =item * The "version" key has a reference to an AV as its value | |
848 | ||
849 | =back | |
850 | ||
851 | =cut | |
852 | */ | |
853 | ||
854 | SV * | |
24120986 | 855 | #ifdef VUTIL_REPLACE_CORE |
d4e59e62 FC |
856 | Perl_vverify2(pTHX_ SV *vs) |
857 | #else | |
abc6d738 | 858 | Perl_vverify(pTHX_ SV *vs) |
d4e59e62 | 859 | #endif |
abc6d738 FC |
860 | { |
861 | SV *sv; | |
05402f6b | 862 | SV **svp; |
abc6d738 FC |
863 | |
864 | PERL_ARGS_ASSERT_VVERIFY; | |
865 | ||
866 | if ( SvROK(vs) ) | |
867 | vs = SvRV(vs); | |
868 | ||
869 | /* see if the appropriate elements exist */ | |
870 | if ( SvTYPE(vs) == SVt_PVHV | |
05402f6b JP |
871 | && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE)) |
872 | && (sv = SvRV(*svp)) | |
abc6d738 FC |
873 | && SvTYPE(sv) == SVt_PVAV ) |
874 | return vs; | |
875 | else | |
876 | return NULL; | |
877 | } | |
878 | ||
879 | /* | |
880 | =for apidoc vnumify | |
881 | ||
882 | Accepts a version object and returns the normalized floating | |
883 | point representation. Call like: | |
884 | ||
885 | sv = vnumify(rv); | |
886 | ||
887 | NOTE: you can pass either the object directly or the SV | |
888 | contained within the RV. | |
889 | ||
890 | The SV returned has a refcount of 1. | |
891 | ||
892 | =cut | |
893 | */ | |
894 | ||
895 | SV * | |
24120986 | 896 | #ifdef VUTIL_REPLACE_CORE |
d4e59e62 FC |
897 | Perl_vnumify2(pTHX_ SV *vs) |
898 | #else | |
abc6d738 | 899 | Perl_vnumify(pTHX_ SV *vs) |
d4e59e62 | 900 | #endif |
abc6d738 FC |
901 | { |
902 | SSize_t i, len; | |
903 | I32 digit; | |
abc6d738 FC |
904 | bool alpha = FALSE; |
905 | SV *sv; | |
906 | AV *av; | |
907 | ||
908 | PERL_ARGS_ASSERT_VNUMIFY; | |
909 | ||
910 | /* extract the HV from the object */ | |
d4e59e62 | 911 | vs = VVERIFY(vs); |
abc6d738 FC |
912 | if ( ! vs ) |
913 | Perl_croak(aTHX_ "Invalid version object"); | |
914 | ||
915 | /* see if various flags exist */ | |
817794ed | 916 | if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) |
abc6d738 | 917 | alpha = TRUE; |
abc6d738 | 918 | |
14f3031b JP |
919 | if (alpha) { |
920 | Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC), | |
921 | "alpha->numify() is lossy"); | |
922 | } | |
abc6d738 FC |
923 | |
924 | /* attempt to retrieve the version array */ | |
925 | if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { | |
926 | return newSVpvs("0"); | |
927 | } | |
928 | ||
929 | len = av_len(av); | |
930 | if ( len == -1 ) | |
931 | { | |
932 | return newSVpvs("0"); | |
933 | } | |
934 | ||
05402f6b JP |
935 | { |
936 | SV * tsv = *av_fetch(av, 0, 0); | |
937 | digit = SvIV(tsv); | |
938 | } | |
abc6d738 | 939 | sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit)); |
14f3031b | 940 | for ( i = 1 ; i <= len ; i++ ) |
abc6d738 | 941 | { |
05402f6b JP |
942 | SV * tsv = *av_fetch(av, i, 0); |
943 | digit = SvIV(tsv); | |
14f3031b | 944 | Perl_sv_catpvf(aTHX_ sv, "%03d", (int)digit); |
abc6d738 FC |
945 | } |
946 | ||
14f3031b | 947 | if ( len == 0 ) { |
abc6d738 FC |
948 | sv_catpvs(sv, "000"); |
949 | } | |
950 | return sv; | |
951 | } | |
952 | ||
953 | /* | |
954 | =for apidoc vnormal | |
955 | ||
956 | Accepts a version object and returns the normalized string | |
957 | representation. Call like: | |
958 | ||
959 | sv = vnormal(rv); | |
960 | ||
961 | NOTE: you can pass either the object directly or the SV | |
962 | contained within the RV. | |
963 | ||
964 | The SV returned has a refcount of 1. | |
965 | ||
966 | =cut | |
967 | */ | |
968 | ||
969 | SV * | |
24120986 | 970 | #ifdef VUTIL_REPLACE_CORE |
d4e59e62 FC |
971 | Perl_vnormal2(pTHX_ SV *vs) |
972 | #else | |
abc6d738 | 973 | Perl_vnormal(pTHX_ SV *vs) |
d4e59e62 | 974 | #endif |
abc6d738 FC |
975 | { |
976 | I32 i, len, digit; | |
abc6d738 FC |
977 | SV *sv; |
978 | AV *av; | |
979 | ||
980 | PERL_ARGS_ASSERT_VNORMAL; | |
981 | ||
982 | /* extract the HV from the object */ | |
d4e59e62 | 983 | vs = VVERIFY(vs); |
abc6d738 FC |
984 | if ( ! vs ) |
985 | Perl_croak(aTHX_ "Invalid version object"); | |
986 | ||
abc6d738 FC |
987 | av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))); |
988 | ||
989 | len = av_len(av); | |
990 | if ( len == -1 ) | |
991 | { | |
992 | return newSVpvs(""); | |
993 | } | |
05402f6b JP |
994 | { |
995 | SV * tsv = *av_fetch(av, 0, 0); | |
996 | digit = SvIV(tsv); | |
997 | } | |
a6842133 | 998 | sv = Perl_newSVpvf(aTHX_ "v%" IVdf, (IV)digit); |
14f3031b | 999 | for ( i = 1 ; i <= len ; i++ ) { |
05402f6b JP |
1000 | SV * tsv = *av_fetch(av, i, 0); |
1001 | digit = SvIV(tsv); | |
a6842133 | 1002 | Perl_sv_catpvf(aTHX_ sv, ".%" IVdf, (IV)digit); |
abc6d738 FC |
1003 | } |
1004 | ||
abc6d738 FC |
1005 | if ( len <= 2 ) { /* short version, must be at least three */ |
1006 | for ( len = 2 - len; len != 0; len-- ) | |
1007 | sv_catpvs(sv,".0"); | |
1008 | } | |
1009 | return sv; | |
1010 | } | |
1011 | ||
1012 | /* | |
1013 | =for apidoc vstringify | |
1014 | ||
1015 | In order to maintain maximum compatibility with earlier versions | |
1016 | of Perl, this function will return either the floating point | |
1017 | notation or the multiple dotted notation, depending on whether | |
1018 | the original version contained 1 or more dots, respectively. | |
1019 | ||
1020 | The SV returned has a refcount of 1. | |
1021 | ||
1022 | =cut | |
1023 | */ | |
1024 | ||
1025 | SV * | |
24120986 | 1026 | #ifdef VUTIL_REPLACE_CORE |
d4e59e62 FC |
1027 | Perl_vstringify2(pTHX_ SV *vs) |
1028 | #else | |
abc6d738 | 1029 | Perl_vstringify(pTHX_ SV *vs) |
d4e59e62 | 1030 | #endif |
abc6d738 | 1031 | { |
05402f6b | 1032 | SV ** svp; |
abc6d738 FC |
1033 | PERL_ARGS_ASSERT_VSTRINGIFY; |
1034 | ||
1035 | /* extract the HV from the object */ | |
d4e59e62 | 1036 | vs = VVERIFY(vs); |
abc6d738 FC |
1037 | if ( ! vs ) |
1038 | Perl_croak(aTHX_ "Invalid version object"); | |
1039 | ||
05402f6b JP |
1040 | svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE); |
1041 | if (svp) { | |
abc6d738 | 1042 | SV *pv; |
05402f6b | 1043 | pv = *svp; |
dddb2275 JP |
1044 | if ( SvPOK(pv) |
1045 | #if PERL_VERSION_LT(5,17,2) | |
1046 | || SvPOKp(pv) | |
1047 | #endif | |
1048 | ) | |
abc6d738 FC |
1049 | return newSVsv(pv); |
1050 | else | |
1051 | return &PL_sv_undef; | |
1052 | } | |
1053 | else { | |
817794ed | 1054 | if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) |
d4e59e62 | 1055 | return VNORMAL(vs); |
abc6d738 | 1056 | else |
d4e59e62 | 1057 | return VNUMIFY(vs); |
abc6d738 FC |
1058 | } |
1059 | } | |
1060 | ||
1061 | /* | |
1062 | =for apidoc vcmp | |
1063 | ||
1064 | Version object aware cmp. Both operands must already have been | |
1065 | converted into version objects. | |
1066 | ||
1067 | =cut | |
1068 | */ | |
1069 | ||
1070 | int | |
24120986 | 1071 | #ifdef VUTIL_REPLACE_CORE |
d4e59e62 FC |
1072 | Perl_vcmp2(pTHX_ SV *lhv, SV *rhv) |
1073 | #else | |
abc6d738 | 1074 | Perl_vcmp(pTHX_ SV *lhv, SV *rhv) |
d4e59e62 | 1075 | #endif |
abc6d738 FC |
1076 | { |
1077 | SSize_t i,l,m,r; | |
1078 | I32 retval; | |
abc6d738 FC |
1079 | I32 left = 0; |
1080 | I32 right = 0; | |
1081 | AV *lav, *rav; | |
1082 | ||
1083 | PERL_ARGS_ASSERT_VCMP; | |
1084 | ||
1085 | /* extract the HVs from the objects */ | |
d4e59e62 FC |
1086 | lhv = VVERIFY(lhv); |
1087 | rhv = VVERIFY(rhv); | |
abc6d738 FC |
1088 | if ( ! ( lhv && rhv ) ) |
1089 | Perl_croak(aTHX_ "Invalid version object"); | |
1090 | ||
1091 | /* get the left hand term */ | |
1092 | lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE))); | |
abc6d738 FC |
1093 | |
1094 | /* and the right hand term */ | |
1095 | rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE))); | |
abc6d738 FC |
1096 | |
1097 | l = av_len(lav); | |
1098 | r = av_len(rav); | |
1099 | m = l < r ? l : r; | |
1100 | retval = 0; | |
1101 | i = 0; | |
1102 | while ( i <= m && retval == 0 ) | |
1103 | { | |
05402f6b JP |
1104 | SV * const lsv = *av_fetch(lav,i,0); |
1105 | SV * rsv; | |
1106 | left = SvIV(lsv); | |
1107 | rsv = *av_fetch(rav,i,0); | |
1108 | right = SvIV(rsv); | |
abc6d738 FC |
1109 | if ( left < right ) |
1110 | retval = -1; | |
1111 | if ( left > right ) | |
1112 | retval = +1; | |
1113 | i++; | |
1114 | } | |
1115 | ||
abc6d738 FC |
1116 | if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ |
1117 | { | |
1118 | if ( l < r ) | |
1119 | { | |
1120 | while ( i <= r && retval == 0 ) | |
1121 | { | |
05402f6b JP |
1122 | SV * const rsv = *av_fetch(rav,i,0); |
1123 | if ( SvIV(rsv) != 0 ) | |
abc6d738 FC |
1124 | retval = -1; /* not a match after all */ |
1125 | i++; | |
1126 | } | |
1127 | } | |
1128 | else | |
1129 | { | |
1130 | while ( i <= l && retval == 0 ) | |
1131 | { | |
05402f6b JP |
1132 | SV * const lsv = *av_fetch(lav,i,0); |
1133 | if ( SvIV(lsv) != 0 ) | |
abc6d738 FC |
1134 | retval = +1; /* not a match after all */ |
1135 | i++; | |
1136 | } | |
1137 | } | |
1138 | } | |
1139 | return retval; | |
1140 | } | |
14f3031b JP |
1141 | |
1142 | /* ex: set ro: */ |