This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Explicit ENTER/LEAVE block for upg_version
[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
d4e59e62 528 return UPG_VERSION(rv, FALSE);
abc6d738
FC
529}
530
531/*
532=for apidoc upg_version
533
534In-place upgrade of the supplied SV to a version object.
535
536 SV *sv = upg_version(SV *sv, bool qv);
537
538Returns a pointer to the upgraded SV. Set the boolean qv if you want
539to force this SV to be interpreted as an "extended" version.
540
541=cut
542*/
543
544SV *
d4e59e62
FC
545#if VUTIL_REPLACE_CORE
546Perl_upg_version2(pTHX_ SV *ver, bool qv)
547#else
abc6d738 548Perl_upg_version(pTHX_ SV *ver, bool qv)
d4e59e62 549#endif
abc6d738
FC
550{
551 const char *version, *s;
552#ifdef SvVOK
553 const MAGIC *mg;
554#endif
555
e2ca569e 556 ENTER;
abc6d738
FC
557 PERL_ARGS_ASSERT_UPG_VERSION;
558
05402f6b 559 if ( SvNOK(ver) && !( SvPOK(ver) && SvCUR(ver) == 3 ) )
abc6d738
FC
560 {
561 STRLEN len;
562
563 /* may get too much accuracy */
564 char tbuf[64];
565 SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
566 char *buf;
90d6b40e 567 STORE_NUMERIC_LOCAL_SET_STANDARD();
abc6d738 568 if (sv) {
ab4e0d4b
JP
569 Perl_sv_catpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
570 len = SvCUR(sv);
571 buf = SvPVX(sv);
abc6d738
FC
572 }
573 else {
574 len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
575 buf = tbuf;
576 }
90d6b40e 577 RESTORE_NUMERIC_LOCAL();
abc6d738
FC
578 while (buf[len-1] == '0' && len > 0) len--;
579 if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
580 version = savepvn(buf, len);
05402f6b 581 SAVEFREEPV(version);
abc6d738
FC
582 SvREFCNT_dec(sv);
583 }
584#ifdef SvVOK
585 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
586 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
05402f6b 587 SAVEFREEPV(version);
abc6d738
FC
588 qv = TRUE;
589 }
590#endif
4141ef59
JP
591 else if ( (SvUOK(ver) && SvUVX(ver) > VERSION_MAX)
592 || (SvIOK(ver) && SvIVX(ver) > VERSION_MAX) ) {
95a23f5d 593 /* out of bounds [unsigned] integer */
4141ef59
JP
594 STRLEN len;
595 char tbuf[64];
596 len = my_snprintf(tbuf, sizeof(tbuf), "%d", VERSION_MAX);
597 version = savepvn(tbuf, len);
05402f6b 598 SAVEFREEPV(version);
4141ef59
JP
599 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
600 "Integer overflow in version %d",VERSION_MAX);
601 }
95a23f5d
JP
602 else if ( SvUOK(ver) || SvIOK(ver) ) {
603 version = savesvpv(ver);
05402f6b 604 SAVEFREEPV(version);
95a23f5d 605 }
ab4e0d4b 606 else if ( SvPOK(ver) )/* must be a string or something like a string */
abc6d738
FC
607 {
608 STRLEN len;
4141ef59 609 version = savepvn(SvPV(ver,len), SvCUR(ver));
05402f6b 610 SAVEFREEPV(version);
abc6d738
FC
611#ifndef SvVOK
612# if PERL_VERSION > 5
613 /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
614 if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
615 /* may be a v-string */
616 char *testv = (char *)version;
617 STRLEN tlen = len;
618 for (tlen=0; tlen < len; tlen++, testv++) {
619 /* if one of the characters is non-text assume v-string */
620 if (testv[0] < ' ') {
621 SV * const nsv = sv_newmortal();
622 const char *nver;
623 const char *pos;
624 int saw_decimal = 0;
625 sv_setpvf(nsv,"v%vd",ver);
626 pos = nver = savepv(SvPV_nolen(nsv));
05402f6b 627 SAVEFREEPV(pos);
abc6d738
FC
628
629 /* scan the resulting formatted string */
630 pos++; /* skip the leading 'v' */
631 while ( *pos == '.' || isDIGIT(*pos) ) {
632 if ( *pos == '.' )
633 saw_decimal++ ;
634 pos++;
635 }
636
637 /* is definitely a v-string */
638 if ( saw_decimal >= 2 ) {
abc6d738
FC
639 version = nver;
640 }
641 break;
642 }
643 }
644 }
645# endif
646#endif
647 }
ab4e0d4b
JP
648 else
649 {
650 /* no idea what this is */
651 Perl_croak(aTHX_ "Invalid version format (non-numeric data)");
652 }
abc6d738 653
d4e59e62 654 s = SCAN_VERSION(version, ver, qv);
abc6d738
FC
655 if ( *s != '\0' )
656 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
657 "Version string '%s' contains invalid data; "
658 "ignoring: '%s'", version, s);
e2ca569e 659 LEAVE;
abc6d738
FC
660 return ver;
661}
662
663/*
664=for apidoc vverify
665
666Validates that the SV contains valid internal structure for a version object.
667It may be passed either the version object (RV) or the hash itself (HV). If
668the structure is valid, it returns the HV. If the structure is invalid,
669it returns NULL.
670
671 SV *hv = vverify(sv);
672
673Note that it only confirms the bare minimum structure (so as not to get
674confused by derived classes which may contain additional hash entries):
675
676=over 4
677
678=item * The SV is an HV or a reference to an HV
679
680=item * The hash contains a "version" key
681
682=item * The "version" key has a reference to an AV as its value
683
684=back
685
686=cut
687*/
688
689SV *
d4e59e62
FC
690#if VUTIL_REPLACE_CORE
691Perl_vverify2(pTHX_ SV *vs)
692#else
abc6d738 693Perl_vverify(pTHX_ SV *vs)
d4e59e62 694#endif
abc6d738
FC
695{
696 SV *sv;
05402f6b 697 SV **svp;
abc6d738
FC
698
699 PERL_ARGS_ASSERT_VVERIFY;
700
701 if ( SvROK(vs) )
702 vs = SvRV(vs);
703
704 /* see if the appropriate elements exist */
705 if ( SvTYPE(vs) == SVt_PVHV
05402f6b
JP
706 && (svp = hv_fetchs(MUTABLE_HV(vs), "version", FALSE))
707 && (sv = SvRV(*svp))
abc6d738
FC
708 && SvTYPE(sv) == SVt_PVAV )
709 return vs;
710 else
711 return NULL;
712}
713
714/*
715=for apidoc vnumify
716
717Accepts a version object and returns the normalized floating
718point representation. Call like:
719
720 sv = vnumify(rv);
721
722NOTE: you can pass either the object directly or the SV
723contained within the RV.
724
725The SV returned has a refcount of 1.
726
727=cut
728*/
729
730SV *
d4e59e62
FC
731#if VUTIL_REPLACE_CORE
732Perl_vnumify2(pTHX_ SV *vs)
733#else
abc6d738 734Perl_vnumify(pTHX_ SV *vs)
d4e59e62 735#endif
abc6d738
FC
736{
737 SSize_t i, len;
738 I32 digit;
739 int width;
740 bool alpha = FALSE;
741 SV *sv;
742 AV *av;
743
744 PERL_ARGS_ASSERT_VNUMIFY;
745
746 /* extract the HV from the object */
d4e59e62 747 vs = VVERIFY(vs);
abc6d738
FC
748 if ( ! vs )
749 Perl_croak(aTHX_ "Invalid version object");
750
751 /* see if various flags exist */
752 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
753 alpha = TRUE;
05402f6b
JP
754 {
755 SV ** svp = hv_fetchs(MUTABLE_HV(vs), "width", FALSE);
756 if ( svp )
757 width = SvIV(*svp);
758 else
759 width = 3;
760 }
abc6d738
FC
761
762
763 /* attempt to retrieve the version array */
764 if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
765 return newSVpvs("0");
766 }
767
768 len = av_len(av);
769 if ( len == -1 )
770 {
771 return newSVpvs("0");
772 }
773
05402f6b
JP
774 {
775 SV * tsv = *av_fetch(av, 0, 0);
776 digit = SvIV(tsv);
777 }
abc6d738
FC
778 sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
779 for ( i = 1 ; i < len ; i++ )
780 {
05402f6b
JP
781 SV * tsv = *av_fetch(av, i, 0);
782 digit = SvIV(tsv);
abc6d738
FC
783 if ( width < 3 ) {
784 const int denom = (width == 2 ? 10 : 100);
785 const div_t term = div((int)PERL_ABS(digit),denom);
786 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
787 }
788 else {
789 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
790 }
791 }
792
793 if ( len > 0 )
794 {
05402f6b
JP
795 SV * tsv = *av_fetch(av, len, 0);
796 digit = SvIV(tsv);
abc6d738
FC
797 if ( alpha && width == 3 ) /* alpha version */
798 sv_catpvs(sv,"_");
799 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
800 }
801 else /* len == 0 */
802 {
803 sv_catpvs(sv, "000");
804 }
805 return sv;
806}
807
808/*
809=for apidoc vnormal
810
811Accepts a version object and returns the normalized string
812representation. Call like:
813
814 sv = vnormal(rv);
815
816NOTE: you can pass either the object directly or the SV
817contained within the RV.
818
819The SV returned has a refcount of 1.
820
821=cut
822*/
823
824SV *
d4e59e62
FC
825#if VUTIL_REPLACE_CORE
826Perl_vnormal2(pTHX_ SV *vs)
827#else
abc6d738 828Perl_vnormal(pTHX_ SV *vs)
d4e59e62 829#endif
abc6d738
FC
830{
831 I32 i, len, digit;
832 bool alpha = FALSE;
833 SV *sv;
834 AV *av;
835
836 PERL_ARGS_ASSERT_VNORMAL;
837
838 /* extract the HV from the object */
d4e59e62 839 vs = VVERIFY(vs);
abc6d738
FC
840 if ( ! vs )
841 Perl_croak(aTHX_ "Invalid version object");
842
843 if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
844 alpha = TRUE;
845 av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
846
847 len = av_len(av);
848 if ( len == -1 )
849 {
850 return newSVpvs("");
851 }
05402f6b
JP
852 {
853 SV * tsv = *av_fetch(av, 0, 0);
854 digit = SvIV(tsv);
855 }
abc6d738
FC
856 sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
857 for ( i = 1 ; i < len ; i++ ) {
05402f6b
JP
858 SV * tsv = *av_fetch(av, i, 0);
859 digit = SvIV(tsv);
abc6d738
FC
860 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
861 }
862
863 if ( len > 0 )
864 {
865 /* handle last digit specially */
05402f6b
JP
866 SV * tsv = *av_fetch(av, len, 0);
867 digit = SvIV(tsv);
abc6d738
FC
868 if ( alpha )
869 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
870 else
871 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
872 }
873
874 if ( len <= 2 ) { /* short version, must be at least three */
875 for ( len = 2 - len; len != 0; len-- )
876 sv_catpvs(sv,".0");
877 }
878 return sv;
879}
880
881/*
882=for apidoc vstringify
883
884In order to maintain maximum compatibility with earlier versions
885of Perl, this function will return either the floating point
886notation or the multiple dotted notation, depending on whether
887the original version contained 1 or more dots, respectively.
888
889The SV returned has a refcount of 1.
890
891=cut
892*/
893
894SV *
d4e59e62
FC
895#if VUTIL_REPLACE_CORE
896Perl_vstringify2(pTHX_ SV *vs)
897#else
abc6d738 898Perl_vstringify(pTHX_ SV *vs)
d4e59e62 899#endif
abc6d738 900{
05402f6b 901 SV ** svp;
abc6d738
FC
902 PERL_ARGS_ASSERT_VSTRINGIFY;
903
904 /* extract the HV from the object */
d4e59e62 905 vs = VVERIFY(vs);
abc6d738
FC
906 if ( ! vs )
907 Perl_croak(aTHX_ "Invalid version object");
908
05402f6b
JP
909 svp = hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
910 if (svp) {
abc6d738 911 SV *pv;
05402f6b 912 pv = *svp;
abc6d738
FC
913 if ( SvPOK(pv) )
914 return newSVsv(pv);
915 else
916 return &PL_sv_undef;
917 }
918 else {
919 if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
d4e59e62 920 return VNORMAL(vs);
abc6d738 921 else
d4e59e62 922 return VNUMIFY(vs);
abc6d738
FC
923 }
924}
925
926/*
927=for apidoc vcmp
928
929Version object aware cmp. Both operands must already have been
930converted into version objects.
931
932=cut
933*/
934
935int
d4e59e62
FC
936#if VUTIL_REPLACE_CORE
937Perl_vcmp2(pTHX_ SV *lhv, SV *rhv)
938#else
abc6d738 939Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
d4e59e62 940#endif
abc6d738
FC
941{
942 SSize_t i,l,m,r;
943 I32 retval;
944 bool lalpha = FALSE;
945 bool ralpha = FALSE;
946 I32 left = 0;
947 I32 right = 0;
948 AV *lav, *rav;
949
950 PERL_ARGS_ASSERT_VCMP;
951
952 /* extract the HVs from the objects */
d4e59e62
FC
953 lhv = VVERIFY(lhv);
954 rhv = VVERIFY(rhv);
abc6d738
FC
955 if ( ! ( lhv && rhv ) )
956 Perl_croak(aTHX_ "Invalid version object");
957
958 /* get the left hand term */
959 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
960 if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
961 lalpha = TRUE;
962
963 /* and the right hand term */
964 rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
965 if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
966 ralpha = TRUE;
967
968 l = av_len(lav);
969 r = av_len(rav);
970 m = l < r ? l : r;
971 retval = 0;
972 i = 0;
973 while ( i <= m && retval == 0 )
974 {
05402f6b
JP
975 SV * const lsv = *av_fetch(lav,i,0);
976 SV * rsv;
977 left = SvIV(lsv);
978 rsv = *av_fetch(rav,i,0);
979 right = SvIV(rsv);
abc6d738
FC
980 if ( left < right )
981 retval = -1;
982 if ( left > right )
983 retval = +1;
984 i++;
985 }
986
987 /* tiebreaker for alpha with identical terms */
988 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
989 {
990 if ( lalpha && !ralpha )
991 {
992 retval = -1;
993 }
994 else if ( ralpha && !lalpha)
995 {
996 retval = +1;
997 }
998 }
999
1000 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
1001 {
1002 if ( l < r )
1003 {
1004 while ( i <= r && retval == 0 )
1005 {
05402f6b
JP
1006 SV * const rsv = *av_fetch(rav,i,0);
1007 if ( SvIV(rsv) != 0 )
abc6d738
FC
1008 retval = -1; /* not a match after all */
1009 i++;
1010 }
1011 }
1012 else
1013 {
1014 while ( i <= l && retval == 0 )
1015 {
05402f6b
JP
1016 SV * const lsv = *av_fetch(lav,i,0);
1017 if ( SvIV(lsv) != 0 )
abc6d738
FC
1018 retval = +1; /* not a match after all */
1019 i++;
1020 }
1021 }
1022 }
1023 return retval;
1024}