X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=40abb483b03868345fc26f448bd3ba06ebbada56;hb=9ac5eb64d274bdbd879ebb568a13f392d2a50575;hp=c4b25af64eb923aa1a3a2dbdd38b8aa0475f8941;hpb=e568f1a0c324be00c66a63ff9480ccd16934f37e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index c4b25af..40abb48 100644
--- a/util.c
+++ b/util.c
@@ -1,6 +1,6 @@
 /*    util.c
  *
- *    Copyright (c) 1991-2002, Larry Wall
+ *    Copyright (c) 1991-2003, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -357,8 +357,12 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     I32 rarest = 0;
     U32 frequency = 256;
 
-    if (flags & FBMcf_TAIL)
+    if (flags & FBMcf_TAIL) {
+	MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 	sv_catpvn(sv, "\n", 1);		/* Taken into account in fbm_instr() */
+	if (mg && mg->mg_len >= 0)
+	    mg->mg_len++;
+    }
     s = (U8*)SvPV_force(sv, len);
     (void)SvUPGRADE(sv, SVt_PVBM);
     if (len == 0)		/* TAIL might be on a zero-length string. */
@@ -2172,6 +2176,11 @@ dup2(int oldfd, int newfd)
 #ifndef PERL_MICRO
 #ifdef HAS_SIGACTION
 
+#ifdef MACOS_TRADITIONAL
+/* We don't want restart behavior on MacOS */
+#undef SA_RESTART
+#endif
+
 Sighandler_t
 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 {
@@ -2187,9 +2196,8 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
     sigemptyset(&act.sa_mask);
     act.sa_flags = 0;
 #ifdef SA_RESTART
-#if defined(PERL_OLD_SIGNALS)
-    act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
-#endif
+    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+        act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
 #endif
 #ifdef SA_NOCLDWAIT
     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
@@ -2227,9 +2235,8 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
     sigemptyset(&act.sa_mask);
     act.sa_flags = 0;
 #ifdef SA_RESTART
-#if defined(PERL_OLD_SIGNALS)
-    act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
-#endif
+    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+        act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
 #endif
 #ifdef SA_NOCLDWAIT
     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
@@ -2973,6 +2980,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;
 }
@@ -2980,7 +2990,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
 I32
 Perl_my_fflush_all(pTHX)
 {
-#if defined(FFLUSH_NULL)
+#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
     return PerlIO_flush(NULL);
 #else
 # if defined(HAS__FWALK)
@@ -3383,6 +3393,20 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon,
   mytm.tm_yday = yday;
   mytm.tm_isdst = isdst;
   mini_mktime(&mytm);
+  /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
+#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
+  STMT_START {
+    struct tm mytm2;
+    mytm2 = mytm;
+    mktime(&mytm2);
+#ifdef HAS_TM_TM_GMTOFF
+    mytm.tm_gmtoff = mytm2.tm_gmtoff;
+#endif
+#ifdef HAS_TM_TM_ZONE
+    mytm.tm_zone = mytm2.tm_zone;
+#endif
+  } STMT_END;
+#endif
   buflen = 64;
   New(0, buf, buflen, char);
   len = strftime(buf, buflen, fmt, &mytm);
@@ -3741,26 +3765,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 ( PERL_ABS(orev) > PERL_ABS(rev) )
+ 			    Perl_croak(aTHX_ "Integer overflow in version");
+ 			s++;
+ 		    }
+  		}
+ 		else {
+ 		    while (--end >= s) {
+ 			orev = rev;
+ 			rev += (*end - '0') * mult;
+ 			mult *= 10;
+ 			if ( PERL_ABS(orev) > PERL_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;
@@ -3796,7 +3834,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 */ 
     {
@@ -3810,7 +3848,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);
     }
@@ -3873,14 +3911,15 @@ Perl_vnumify(pTHX_ SV *vs)
 	return sv;
     }
     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
-    Perl_sv_setpvf(aTHX_ sv,"%d.",abs(digit));
+    Perl_sv_setpvf(aTHX_ sv,"%d.", PERL_ABS(digit));
     for ( i = 1 ; i <= len ; i++ )
     {
 	digit = SvIVX(*av_fetch((AV *)vs, i, 0));
-	Perl_sv_catpvf(aTHX_ sv,"%03d",abs(digit));
+	Perl_sv_catpvf(aTHX_ sv,"%03d", PERL_ABS(digit));
     }
     if ( len == 0 )
 	 Perl_sv_catpv(aTHX_ sv,"000");
+    sv_setnv(sv, SvNV(sv));
     return sv;
 }
 
@@ -3912,19 +3951,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
@@ -3954,8 +3993,8 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
 	I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
 	bool lbeta = left  < 0 ? 1 : 0;
 	bool rbeta = right < 0 ? 1 : 0;
-	left  = abs(left);
-	right = abs(right);
+	left  = PERL_ABS(left);
+	right = PERL_ABS(right);
 	if ( left < right || (left == right && lbeta && !rbeta) )
 	    retval = -1;
 	if ( left > right || (left == right && rbeta && !lbeta) )
@@ -3963,8 +4002,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;
 }
 
@@ -4269,3 +4314,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 %"UVuf,
+		  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
+
+  *popt = p;
+
+  return opt;
+}
+