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