The new(er) way of controlling Unicode I/O (and other) features;

[p5sagit/p5-mst-13.2.git] / util.c

diff --git a/util.c b/util.c
index 64cb738..d5cc256 100644 (file)
--- a/util.c
+++ b/util.c
@@ -2978,6 +2978,9 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
     case want_vtbl_backref:
        result = &PL_vtbl_backref;
        break;
+    case want_vtbl_utf8:
+       result = &PL_vtbl_utf8;
+       break;
     }
     return result;
 }
@@ -3760,26 +3763,40 @@ Perl_scan_version(pTHX_ char *s, SV *rv)
        for (;;) {
            rev = 0;
            {
-               /* this is atoi() that delimits on underscores */
-               char *end = pos;
-               I32 mult = 1;
-               if ( s < pos && s > start && *(s-1) == '_' ) {
-                   if ( *s == '0' && *(s+1) != '0')
-                       mult = 10;      /* perl-style */
-                   else
-                       mult = -1;      /* beta version */
-               }
-               while (--end >= s) {
-                   I32 orev;
-                   orev = rev;
-                   rev += (*end - '0') * mult;
-                   mult *= 10;
-                   if ( abs(orev) > abs(rev) )
-                       Perl_croak(aTHX_ "Integer overflow in version");
-               }
-           }
-
-           /* Append revision */
+               /* this is atoi() that delimits on underscores */
+               char *end = pos;
+               I32 mult = 1;
+               I32 orev;
+               if ( s < pos && s > start && *(s-1) == '_' ) {
+                       mult *= -1;     /* beta version */
+               }
+               /* the following if() will only be true after the decimal
+                * point of a version originally created with a bare
+                * floating point number, i.e. not quoted in any way
+                */
+               if ( s > start+1 && saw_period == 1 && !saw_under ) {
+                   mult = 100;
+                   while ( s < end ) {
+                       orev = rev;
+                       rev += (*s - '0') * mult;
+                       mult /= 10;
+                       if ( abs(orev) > abs(rev) )
+                           Perl_croak(aTHX_ "Integer overflow in version");
+                       s++;
+                   }
+               }
+               else {
+                   while (--end >= s) {
+                       orev = rev;
+                       rev += (*end - '0') * mult;
+                       mult *= 10;
+                       if ( abs(orev) > abs(rev) )
+                           Perl_croak(aTHX_ "Integer overflow in version");
+                   }
+               } 
+           }
+  
+           /* Append revision */
            av_push((AV *)sv, newSViv(rev));
            if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
                s = ++pos;
@@ -3815,7 +3832,7 @@ want to upgrade the SV.
 SV *
 Perl_new_version(pTHX_ SV *ver)
 {
-    SV *rv = NEWSV(92,5);
+    SV *rv = newSV(0);
     char *version;
     if ( SvNOK(ver) ) /* may get too much accuracy */ 
     {
@@ -3829,7 +3846,7 @@ Perl_new_version(pTHX_ SV *ver)
        version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
     }
 #endif
-    else
+    else /* must be a string or something like a string */
     {
        version = (char *)SvPV(ver,PL_na);
     }
@@ -3900,6 +3917,7 @@ Perl_vnumify(pTHX_ SV *vs)
     }
     if ( len == 0 )
         Perl_sv_catpv(aTHX_ sv,"000");
+    sv_setnv(sv, SvNV(sv));
     return sv;
 }
 
@@ -3931,19 +3949,19 @@ Perl_vstringify(pTHX_ SV *vs)
        return sv;
     }
     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
-    Perl_sv_setpvf(aTHX_ sv,"%d",digit);
+    Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
     for ( i = 1 ; i <= len ; i++ )
     {
        digit = SvIVX(*av_fetch((AV *)vs, i, 0));
        if ( digit < 0 )
-           Perl_sv_catpvf(aTHX_ sv,"_%d",-digit);
+           Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
        else
-           Perl_sv_catpvf(aTHX_ sv,".%d",digit);
+           Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
     }
     if ( len == 0 )
         Perl_sv_catpv(aTHX_ sv,".0");
     return sv;
-}
+} 
 
 /*
 =for apidoc vcmp
@@ -3982,8 +4000,14 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
        i++;
     }
 
-    if ( l != r && retval == 0 )
-       retval = l < r ? -1 : +1;
+    if ( l != r && retval == 0 ) /* possible match except for trailing 0 */
+    {
+       if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) &&
+            !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) )
+       {
+           retval = l < r ? -1 : +1; /* not a match after all */
+       }
+    }
     return retval;
 }
 
@@ -4288,3 +4312,56 @@ Perl_sv_nounlocking(pTHX_ SV *sv)
 {
 }
 
+U32
+Perl_parse_unicode_opts(pTHX_ char **popt)
+{
+  char *p = *popt;
+  U32 opt = 0;
+
+  if (*p) {
+       if (isDIGIT(*p)) {
+           opt = (U32) atoi(p);
+           while (isDIGIT(*p)) p++;
+           if (*p)
+                Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+       }
+       else {
+           for (; *p; p++) {
+                switch (*p) {
+                case PERL_UNICODE_STDIN:
+                     opt |= PERL_UNICODE_STDIN_FLAG;   break;
+                case PERL_UNICODE_STDOUT:
+                     opt |= PERL_UNICODE_STDOUT_FLAG;  break;
+                case PERL_UNICODE_STDERR:
+                     opt |= PERL_UNICODE_STDERR_FLAG;  break;
+                case PERL_UNICODE_STD:
+                     opt |= PERL_UNICODE_STD_FLAG;     break;
+                case PERL_UNICODE_IN:
+                     opt |= PERL_UNICODE_IN_FLAG;      break;
+                case PERL_UNICODE_OUT:
+                     opt |= PERL_UNICODE_OUT_FLAG;     break;
+                case PERL_UNICODE_INOUT:
+                     opt |= PERL_UNICODE_INOUT_FLAG;   break;
+                case PERL_UNICODE_LOCALE:
+                     opt |= PERL_UNICODE_LOCALE_FLAG;  break;
+                case PERL_UNICODE_ARGV:
+                     opt |= PERL_UNICODE_ARGV_FLAG;    break;
+                default:
+                     Perl_croak(aTHX_
+                                "Unknown Unicode option letter '%c'", *p);
+                }
+           }
+       }
+  }
+  else
+       opt = PERL_UNICODE_DEFAULT_FLAGS;
+
+  if (opt & ~PERL_UNICODE_ALL_FLAGS)
+       Perl_croak(aTHX_ "Unknown Unicode option value 0x%"UVXf,
+                 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
+
+  *popt = p;
+
+  return opt;
+}
+