From: Gurusamy Sarathy Date: Fri, 24 Dec 1999 04:02:35 +0000 (+0000) Subject: support for v5.5.640 style version numbers X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a7cb1f9979dd83ab32266dc555f72f0939829c3f;p=p5sagit%2Fp5-mst-13.2.git support for v5.5.640 style version numbers p4raw-id: //depot/utfperl@4705 --- diff --git a/configpm b/configpm index 8c53dbb..f57ef0b 100755 --- a/configpm +++ b/configpm @@ -17,7 +17,7 @@ my $glossary = $ARGV[1] || 'Porting/Glossary'; open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n"; -$myver = $]; +$myver = 0+$]; print CONFIG <<'ENDOFBEG_NOQ', <<"ENDOFBEG"; package Config; @@ -39,7 +39,7 @@ sub import { ENDOFBEG_NOQ \$] == $myver - or die "Perl lib version ($myver) doesn't match executable version (\$])"; + or die "Perl lib version ($myver) doesn't match executable version (" . 0+\$] . ")"; # This file was created by configpm when Perl was built. Any changes # made to this file will be lost the next time perl is built. diff --git a/embedvar.h b/embedvar.h index 6611921..837c030 100644 --- a/embedvar.h +++ b/embedvar.h @@ -191,7 +191,6 @@ #define PL_StdIO (PERL_GET_INTERP->IStdIO) #define PL_amagic_generation (PERL_GET_INTERP->Iamagic_generation) #define PL_an (PERL_GET_INTERP->Ian) -#define PL_archpat_auto (PERL_GET_INTERP->Iarchpat_auto) #define PL_argvgv (PERL_GET_INTERP->Iargvgv) #define PL_argvout_stack (PERL_GET_INTERP->Iargvout_stack) #define PL_argvoutgv (PERL_GET_INTERP->Iargvoutgv) @@ -456,7 +455,6 @@ #define PL_StdIO (vTHX->IStdIO) #define PL_amagic_generation (vTHX->Iamagic_generation) #define PL_an (vTHX->Ian) -#define PL_archpat_auto (vTHX->Iarchpat_auto) #define PL_argvgv (vTHX->Iargvgv) #define PL_argvout_stack (vTHX->Iargvout_stack) #define PL_argvoutgv (vTHX->Iargvoutgv) @@ -858,7 +856,6 @@ #define PL_StdIO (aTHXo->interp.IStdIO) #define PL_amagic_generation (aTHXo->interp.Iamagic_generation) #define PL_an (aTHXo->interp.Ian) -#define PL_archpat_auto (aTHXo->interp.Iarchpat_auto) #define PL_argvgv (aTHXo->interp.Iargvgv) #define PL_argvout_stack (aTHXo->interp.Iargvout_stack) #define PL_argvoutgv (aTHXo->interp.Iargvoutgv) @@ -1124,7 +1121,6 @@ #define PL_IStdIO PL_StdIO #define PL_Iamagic_generation PL_amagic_generation #define PL_Ian PL_an -#define PL_Iarchpat_auto PL_archpat_auto #define PL_Iargvgv PL_argvgv #define PL_Iargvout_stack PL_argvout_stack #define PL_Iargvoutgv PL_argvoutgv diff --git a/gv.c b/gv.c index e1e4ae0..e2c6349 100644 --- a/gv.c +++ b/gv.c @@ -812,10 +812,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case ']': if (len == 1) { SV *sv = GvSV(gv); - (void)SvUPGRADE(sv, SVt_PVNV); - sv_setpv(sv, PL_patchlevel); - (void)sv_2nv(sv); - SvREADONLY_on(sv); + GvSV(gv) = SvREFCNT_inc(PL_patchlevel); + SvREFCNT_dec(sv); } break; } diff --git a/intrpvar.h b/intrpvar.h index 3e2c563..606a892 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -25,7 +25,7 @@ PERLVAR(Iwarnhook, SV *) /* switches */ PERLVAR(Iminus_c, bool) -PERLVARA(Ipatchlevel,10,char) +PERLVAR(Ipatchlevel, SV *) PERLVAR(Ilocalpatches, char **) PERLVARI(Isplitstr, char *, " ") PERLVAR(Ipreprocess, bool) @@ -170,7 +170,6 @@ PERLVAR(Isys_intern, struct interp_intern) /* more statics moved here */ PERLVARI(Igeneration, int, 100) /* from op.c */ PERLVAR(IDBcv, CV *) /* from perl.c */ -PERLVAR(Iarchpat_auto, char*) /* from perl.c */ PERLVARI(Iin_clean_objs,bool, FALSE) /* from sv.c */ PERLVARI(Iin_clean_all, bool, FALSE) /* from sv.c */ diff --git a/objXSUB.h b/objXSUB.h index 3e07876..36c9f7c 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -48,8 +48,6 @@ #define PL_amagic_generation (*Perl_Iamagic_generation_ptr(aTHXo)) #undef PL_an #define PL_an (*Perl_Ian_ptr(aTHXo)) -#undef PL_archpat_auto -#define PL_archpat_auto (*Perl_Iarchpat_auto_ptr(aTHXo)) #undef PL_argvgv #define PL_argvgv (*Perl_Iargvgv_ptr(aTHXo)) #undef PL_argvout_stack diff --git a/patchlevel.h b/patchlevel.h index 5122217..d0fa32d 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -5,7 +5,7 @@ #define PERL_REVISION 5 /* age */ #define PERL_VERSION 5 /* epoch */ -#define PERL_SUBVERSION 63 /* generation */ +#define PERL_SUBVERSION 640 /* generation */ /* Compatibility across versions: MakeMaker will install add-on modules in a directory with the PERL_APIVERSION version number. @@ -18,7 +18,7 @@ See INSTALL for how this works. */ -#define PERL_APIVERSION 5.00563 /* Adjust manually as needed. */ +#define PERL_APIVERSION 5.00564 /* Adjust manually as needed. */ #define __PATCHLEVEL_H_INCLUDED__ #endif diff --git a/perl.c b/perl.c index a235122..9af4a60 100644 --- a/perl.c +++ b/perl.c @@ -204,14 +204,29 @@ perl_construct(pTHXx) init_i18nl10n(1); SET_NUMERIC_STANDARD(); + { + U8 *s; + PL_patchlevel = NEWSV(0,4); + SvUPGRADE(PL_patchlevel, SVt_PVNV); + if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127) + SvGROW(PL_patchlevel,24); + s = (U8*)SvPVX(PL_patchlevel); + s = uv_to_utf8(s, (UV)PERL_REVISION); + s = uv_to_utf8(s, (UV)PERL_VERSION); + s = uv_to_utf8(s, (UV)PERL_SUBVERSION); + *s = '\0'; + SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel)); + SvPOK_on(PL_patchlevel); + SvNVX(PL_patchlevel) = (NV)PERL_REVISION + + ((NV)PERL_VERSION / (NV)1000) #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 - sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION - + ((double) PERL_VERSION / (double) 1000) - + ((double) PERL_SUBVERSION / (double) 100000)); -#else - sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION + - ((double) PERL_VERSION / (double) 1000)); + + ((NV)PERL_SUBVERSION / (NV)1000000) #endif + ; + SvNOK_on(PL_patchlevel); /* dual valued */ + SvUTF8_on(PL_patchlevel); + SvREADONLY_on(PL_patchlevel); + } #if defined(LOCAL_PATCH_COUNT) PL_localpatches = local_patches; /* For possible -v */ @@ -394,6 +409,7 @@ perl_destruct(pTHXx) Safefree(PL_inplace); PL_inplace = Nullch; + SvREFCNT_dec(PL_patchlevel); if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -599,7 +615,6 @@ perl_destruct(pTHXx) /* No SVs have survived, need to clean out */ Safefree(PL_origfilename); - Safefree(PL_archpat_auto); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) Safefree(PL_reg_curpm); @@ -1841,13 +1856,8 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': -#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0 - printf("\nThis is perl, version %d.%03d_%02d built for %s", - PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME); -#else - printf("\nThis is perl, version %s built for %s", - PL_patchlevel, ARCHNAME); -#endif + printf("\nThis is perl, v%"UVuf".%"UVuf".%"UVuf" built for %s", + (UV)PERL_REVISION, (UV)PERL_VERSION, (UV)PERL_SUBVERSION, ARCHNAME); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) printf("\n(with %d registered patch%s, see perl -V for more detail)", @@ -2243,7 +2253,9 @@ sed %s -e \"/^[^#]/b\" \ PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ - PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP, + (UV)PERL_REVISION, (UV)PERL_VERSION, + (UV)PERL_SUBVERSION), PL_origargv); Perl_croak(aTHX_ "Can't do setuid\n"); } #endif @@ -2490,7 +2502,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); (void)PerlIO_close(PL_rsfp); #ifndef IAMSUID /* try again */ - PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv); + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP, + (UV)PERL_REVISION, (UV)PERL_VERSION, + (UV)PERL_SUBVERSION), PL_origargv); #endif Perl_croak(aTHX_ "Can't do setuid\n"); } @@ -2572,7 +2586,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif - PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */ + PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP, + (UV)PERL_REVISION, (UV)PERL_VERSION, + (UV)PERL_SUBVERSION), PL_origargv);/* try again */ Perl_croak(aTHX_ "Can't do setuid\n"); #endif /* IAMSUID */ #else /* !DOSUID */ @@ -2969,17 +2985,6 @@ S_incpush(pTHX_ char *p, int addsubdirs) if (addsubdirs) { subdir = sv_newmortal(); - if (!PL_archpat_auto) { - STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel) - + sizeof("//auto")); - New(55, PL_archpat_auto, len, char); - sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel); -#ifdef VMS - for (len = sizeof(ARCHNAME) + 2; - PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++) - if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_'; -#endif - } } /* Break at all separators */ @@ -3025,16 +3030,16 @@ S_incpush(pTHX_ char *p, int addsubdirs) SvPV(libdir,len)); #endif /* .../archname/version if -d .../archname/version/auto */ - sv_setsv(subdir, libdir); - sv_catpv(subdir, PL_archpat_auto); + Perl_sv_setpvf(aTHX_ subdir, "%_/%s/"PERL_FS_VER_FMT"/auto", libdir, + ARCHNAME, (UV)PERL_REVISION, + (UV)PERL_VERSION, (UV)PERL_SUBVERSION); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); /* .../archname if -d .../archname/auto */ - sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), - strlen(PL_patchlevel) + 1, "", 0); + Perl_sv_setpvf(aTHX_ subdir, "%_/%s/auto", libdir, ARCHNAME); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(PL_incgv), diff --git a/perl.h b/perl.h index a1f97c9..626e413 100644 --- a/perl.h +++ b/perl.h @@ -1596,7 +1596,12 @@ typedef pthread_key_t perl_key; #define PERL_EXIT_EXPECTED 0x01 #ifndef MEMBER_TO_FPTR -#define MEMBER_TO_FPTR(name) name +# define MEMBER_TO_FPTR(name) name +#endif + +/* format to use for version numbers in file/directory names */ +#ifndef PERL_FS_VER_FMT +# define PERL_FS_VER_FMT "%"UVuf".%"UVuf".%"UVuf #endif /* This defines a way to flush all output buffers. This may be a diff --git a/pp_ctl.c b/pp_ctl.c index f5a016f..c028b4e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2834,10 +2834,54 @@ PP(pp_require) SV *filter_sub = 0; sv = POPs; - if (SvNIOKp(sv) && !SvPOKp(sv)) { - if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv)) - DIE(aTHX_ "Perl %s required--this is only version %s, stopped", - SvPV(sv,n_a),PL_patchlevel); + if (SvNIOKp(sv)) { + UV rev, ver, sver; + if (SvPOKp(sv) && SvUTF8(sv)) { /* require v5.6.1 */ + I32 len; + U8 *s = (U8*)SvPVX(sv); + U8 *end = (U8*)SvPVX(sv) + SvCUR(sv); + if (s < end) { + rev = utf8_to_uv(s, &len); + s += len; + if (s < end) { + ver = utf8_to_uv(s, &len); + s += len; + if (s < end) + sver = utf8_to_uv(s, &len); + else + sver = 0; + } + else + ver = 0; + } + else + rev = 0; + if (PERL_REVISION < rev + || (PERL_REVISION == rev + && (PERL_VERSION < ver + || (PERL_VERSION == ver + && PERL_SUBVERSION < sver)))) + { + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version " + "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION, + PERL_VERSION, PERL_SUBVERSION); + } + } + else if (!SvPOKp(sv)) { /* require 5.005_03 */ + NV n = SvNV(sv); + rev = (UV)n; + ver = (UV)((n-rev)*1000); + sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000); + + if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000) + + ((NV)PERL_SUBVERSION/(NV)1000000) + + 0.00000099 < SvNV(sv)) + { + DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version " + "v%"UVuf".%"UVuf".%"UVuf", stopped", rev, ver, sver, PERL_REVISION, + PERL_VERSION, PERL_SUBVERSION); + } + } RETPUSHYES; } name = SvPV(sv, len); diff --git a/sv.c b/sv.c index 7fa4514..36f88c7 100644 --- a/sv.c +++ b/sv.c @@ -2655,6 +2655,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) *SvEND(dstr) = '\0'; (void)SvPOK_only(dstr); } + if (SvUTF8(sstr)) + SvUTF8_on(dstr); /*SUPPRESS 560*/ if (sflags & SVp_NOK) { SvNOK_on(dstr); @@ -6710,7 +6712,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* switches */ PL_minus_c = proto_perl->Iminus_c; - Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char); + PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel); PL_localpatches = proto_perl->Ilocalpatches; PL_splitstr = proto_perl->Isplitstr; PL_preprocess = proto_perl->Ipreprocess; @@ -6850,7 +6852,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* more statics moved here */ PL_generation = proto_perl->Igeneration; PL_DBcv = cv_dup(proto_perl->IDBcv); - PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto); PL_in_clean_objs = proto_perl->Iin_clean_objs; PL_in_clean_all = proto_perl->Iin_clean_all; diff --git a/sv.h b/sv.h index cefe13c..a16dcdd 100644 --- a/sv.h +++ b/sv.h @@ -373,9 +373,9 @@ struct xpvio { #define SvNOK_only(sv) (SvOK_off(sv), \ SvFLAGS(sv) |= (SVf_NOK|SVp_NOK)) -#define SvUTF8(sv) (SvFLAGS(sv) & SVf_ISUTF8) -#define SvUTF8_on(sv) (SvFLAGS(sv) |= (SVf_ISUTF8)) -#define SvUTF8_off(sv) (SvFLAGS(sv) &= ~(SVf_ISUTF8)) +#define SvUTF8(sv) (SvFLAGS(sv) & SVf_UTF8) +#define SvUTF8_on(sv) (SvFLAGS(sv) |= (SVf_UTF8)) +#define SvUTF8_off(sv) (SvFLAGS(sv) &= ~(SVf_UTF8)) #define SvPOK(sv) (SvFLAGS(sv) & SVf_POK) #define SvPOK_on(sv) (SvFLAGS(sv) |= (SVf_POK|SVp_POK)) diff --git a/t/comp/require.t b/t/comp/require.t index 581dcba..d4c9d8c 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -7,7 +7,7 @@ BEGIN { # don't make this lexical $i = 1; -print "1..4\n"; +print "1..16\n"; sub do_require { %INC = (); @@ -23,6 +23,56 @@ sub write_file { close REQ; } +# new style version numbers + +eval { require v5.5.630; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval { require v10.0.2; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +eval q{ use v5.5.630; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +eval q{ use v10.0.2; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +my $ver = v5.5.630; +eval { require $ver; }; +print "# $@\nnot " if $@; +print "ok ",$i++,"\n"; + +$ver = v10.0.2; +eval { require $ver; }; +print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; +print "ok ",$i++,"\n"; + +print "not " unless v5.5.1 gt v5.5; +print "ok ",$i++,"\n"; + +print "not " unless 5.005_01 > v5.5; +print "ok ",$i++,"\n"; + +print "not " unless 5.005_64 - v5.5.640 < 0.0000001; +print "ok ",$i++,"\n"; + +{ + use utf8; + print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}"; + print "ok ",$i++,"\n"; + + print "not " unless v7.15 eq "\x{7}\x{f}"; + print "ok ",$i++,"\n"; + + print "not " + unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}"; + print "ok ",$i++,"\n"; +} + # interaction with pod (see the eof) write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); require "bleah.pm"; diff --git a/toke.c b/toke.c index ff239a6..8109c3e 100644 --- a/toke.c +++ b/toke.c @@ -803,13 +803,12 @@ S_force_version(pTHX_ char *s) s = skipspace(s); - /* default VERSION number -- GBARR */ - - if(isDIGIT(*s)) { - char *d; - int c; - for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++); - if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') { + if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { + char *d = s; + if (*d == 'v') + d++; + for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++); + if ((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') { s = scan_num(s); /* real VERSION number -- GBARR */ version = yylval.opval; @@ -3399,6 +3398,19 @@ Perl_yylex(pTHX) no_op("Backslash",s); OPERATOR(REFGEN); + case 'v': + if (isDIGIT(s[1]) && PL_expect == XTERM) { + char *start = s; + start++; + start++; + while (isDIGIT(*start)) + start++; + if (*start == '.' && isDIGIT(start[1])) { + s = scan_num(s); + TERM(THING); + } + } + goto keylookup; case 'x': if (isDIGIT(s[1]) && PL_expect == XOPERATOR) { s++; @@ -3428,7 +3440,7 @@ Perl_yylex(pTHX) case 's': case 'S': case 't': case 'T': case 'u': case 'U': - case 'v': case 'V': + case 'V': case 'w': case 'W': case 'X': case 'y': case 'Y': @@ -4362,12 +4374,18 @@ Perl_yylex(pTHX) OLDLOP(OP_RETURN); case KEY_require: - *PL_tokenbuf = '\0'; - s = force_word(s,WORD,TRUE,TRUE,FALSE); - if (isIDFIRST_lazy(PL_tokenbuf)) - gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE); - else if (*s == '<') - yyerror("<> should be quotes"); + s = skipspace(s); + if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { + s = force_version(s); + } + else { + *PL_tokenbuf = '\0'; + s = force_word(s,WORD,TRUE,TRUE,FALSE); + if (isIDFIRST_lazy(PL_tokenbuf)) + gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE); + else if (*s == '<') + yyerror("<> should be quotes"); + } UNI(OP_REQUIRE); case KEY_reset: @@ -4729,9 +4747,9 @@ Perl_yylex(pTHX) if (PL_expect != XSTATE) yyerror("\"use\" not allowed in expression"); s = skipspace(s); - if(isDIGIT(*s)) { + if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { s = force_version(s); - if(*s == ';' || (s = skipspace(s), *s == ';')) { + if (*s == ';' || (s = skipspace(s), *s == ';')) { PL_nextval[PL_nexttoke].opval = Nullop; force_next(WORD); } @@ -6506,7 +6524,7 @@ Perl_scan_num(pTHX_ char *start) register char *e; /* end of temp buffer */ IV tryiv; /* used to see if it can be an IV */ NV value; /* number read, as a double */ - SV *sv; /* place to put the converted number */ + SV *sv = Nullsv; /* place to put the converted number */ bool floatit; /* boolean: int or float? */ char *lastub = 0; /* position of last underbar */ static char number_too_long[] = "Number too long"; @@ -6518,8 +6536,7 @@ Perl_scan_num(pTHX_ char *start) Perl_croak(aTHX_ "panic: scan_num"); /* if it starts with a 0, it could be an octal number, a decimal in - 0.13 disguise, or a hexadecimal number, or a binary number. - */ + 0.13 disguise, or a hexadecimal number, or a binary number. */ case '0': { /* variables: @@ -6781,11 +6798,61 @@ Perl_scan_num(pTHX_ char *start) (floatit ? "float" : "integer"), sv, Nullsv, NULL); break; + /* if it starts with a v, it could be a version number */ + case 'v': + { + UV rev, ver, sver; + char *pos = s; + pos++; + while (isDIGIT(*pos)) + pos++; + if (*pos == '.' && isDIGIT(pos[1])) { + U8 tmpbuf[10]; + U8 *tmpend; + NV nshift = 1.0; + s++; /* get past 'v' */ + + sv = NEWSV(92,5); + SvUPGRADE(sv, SVt_PVNV); + sv_setpvn(sv, "", 0); + + do { + rev = atoi(s); + s = ++pos; + while (isDIGIT(*pos)) + pos++; + + tmpend = uv_to_utf8(tmpbuf, rev); + *tmpend = '\0'; + sv_catpvn(sv, tmpbuf, tmpend - tmpbuf); + if (rev > 0) + SvNVX(sv) += (NV)rev/nshift; + nshift *= 1000; + } while (*pos == '.' && isDIGIT(pos[1])); + + rev = atoi(s); + s = pos; + tmpend = uv_to_utf8(tmpbuf, rev); + *tmpend = '\0'; + sv_catpvn(sv, tmpbuf, tmpend - tmpbuf); + if (rev > 0) + SvNVX(sv) += (NV)rev/nshift; + + SvPOK_on(sv); + SvNOK_on(sv); + SvREADONLY_on(sv); + SvUTF8_on(sv); + } + } + break; } /* make the op for the constant and return */ - yylval.opval = newSVOP(OP_CONST, 0, sv); + if (sv) + yylval.opval = newSVOP(OP_CONST, 0, sv); + else + yylval.opval = Nullop; return s; }