X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=9a43d67fa082dc226fe24c728bcc568b2f59671c;hb=3332bd48887b0ba301a11465bf667141ae01ada3;hp=7f32acbc3ece12c980c37e6bd5d03d8b42af1cef;hpb=7e8c5daceba7cb185532328a3b67d4ca7ba4811b;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index 7f32acb..9a43d67 100644
--- a/util.c
+++ b/util.c
@@ -1,6 +1,7 @@
 /*    util.c
  *
- *    Copyright (c) 1991-2002, Larry Wall
+ *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, by Larry Wall and others
  *
  *    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 +358,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. */
@@ -972,6 +977,52 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
     return sv;
 }
 
+void
+Perl_write_to_stderr(pTHX_ const char* message, int msglen)
+{
+    IO *io;
+    MAGIC *mg;
+
+    if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
+	&& (io = GvIO(PL_stderrgv))
+	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 
+    {
+	dSP;
+	ENTER;
+	SAVETMPS;
+
+	save_re_context();
+	SAVESPTR(PL_stderrgv);
+	PL_stderrgv = Nullgv;
+
+	PUSHSTACKi(PERLSI_MAGIC);
+
+	PUSHMARK(SP);
+	EXTEND(SP,2);
+	PUSHs(SvTIED_obj((SV*)io, mg));
+	PUSHs(sv_2mortal(newSVpvn(message, msglen)));
+	PUTBACK;
+	call_method("PRINT", G_SCALAR);
+
+	POPSTACK;
+	FREETMPS;
+	LEAVE;
+    }
+    else {
+#ifdef USE_SFIO
+	/* SFIO can really mess with your errno */
+	int e = errno;
+#endif
+	PerlIO *serr = Perl_error_log;
+
+	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
+	(void)PerlIO_flush(serr);
+#ifdef USE_SFIO
+	errno = e;
+#endif
+    }
+}
+
 OP *
 Perl_vdie(pTHX_ const char* pat, va_list *args)
 {
@@ -1139,19 +1190,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args)
     else if (!message)
 	message = SvPVx(ERRSV, msglen);
 
-    {
-#ifdef USE_SFIO
-	/* SFIO can really mess with your errno */
-	int e = errno;
-#endif
-	PerlIO *serr = Perl_error_log;
-
-	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-	(void)PerlIO_flush(serr);
-#ifdef USE_SFIO
-	errno = e;
-#endif
-    }
+    write_to_stderr(message, msglen);
     my_failure_exit();
 }
 
@@ -1206,8 +1245,6 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     CV *cv;
     SV *msv;
     STRLEN msglen;
-    IO *io;
-    MAGIC *mg;
 
     msv = vmess(pat, args);
     message = SvPV(msv, msglen);
@@ -1241,25 +1278,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
 	}
     }
 
-    /* if STDERR is tied, use it instead */
-    if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
-	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
-	dSP; ENTER;
-	PUSHMARK(SP);
-	XPUSHs(SvTIED_obj((SV*)io, mg));
-	XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
-	PUTBACK;
-	call_method("PRINT", G_SCALAR);
-	LEAVE;
-	return;
-    }
-
-    {
-	PerlIO *serr = Perl_error_log;
-
-	PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-	(void)PerlIO_flush(serr);
-    }
+    write_to_stderr(message, msglen);
 }
 
 #if defined(PERL_IMPLICIT_CONTEXT)
@@ -1359,11 +1378,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 	    PL_restartop = die_where(message, msglen);
 	    JMPENV_JUMP(3);
 	}
-	{
-	    PerlIO *serr = Perl_error_log;
-	    PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-	    (void)PerlIO_flush(serr);
-	}
+	write_to_stderr(message, msglen);
 	my_failure_exit();
     }
     else {
@@ -1395,11 +1410,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 		return;
 	    }
 	}
-	{
-	    PerlIO *serr = Perl_error_log;
-	    PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
-	    (void)PerlIO_flush(serr);
-	}
+	write_to_stderr(message, msglen);
     }
 }
 
@@ -2192,11 +2203,10 @@ 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 defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
 	act.sa_flags |= SA_NOCLDWAIT;
 #endif
@@ -2232,11 +2242,10 @@ 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 */
+    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+        act.sa_flags |= SA_RESTART;	/* SVR4, 4.3+BSD */
 #endif
-#endif
-#ifdef SA_NOCLDWAIT
+#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
 	act.sa_flags |= SA_NOCLDWAIT;
 #endif
@@ -3625,85 +3634,6 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 }
 
 /*
-=head1 SV Manipulation Functions
-
-=for apidoc scan_vstring
-
-Returns a pointer to the next character after the parsed
-vstring, as well as updating the passed in sv.
-
-Function must be called like
-
-	sv = NEWSV(92,5);
-	s = scan_vstring(s,sv);
-
-The sv should already be large enough to store the vstring
-passed in, for performance reasons.
-
-=cut
-*/
-
-char *
-Perl_scan_vstring(pTHX_ char *s, SV *sv)
-{
-    char *pos = s;
-    char *start = s;
-    if (*pos == 'v') pos++;  /* get past 'v' */
-    while (isDIGIT(*pos) || *pos == '_')
-    pos++;
-    if (!isALPHA(*pos)) {
-	UV rev;
-	U8 tmpbuf[UTF8_MAXLEN+1];
-	U8 *tmpend;
-
-	if (*s == 'v') s++;  /* get past 'v' */
-
-	sv_setpvn(sv, "", 0);
-
-	for (;;) {
-	    rev = 0;
-	    {
-		/* this is atoi() that tolerates underscores */
-		char *end = pos;
-		UV mult = 1;
-		while (--end >= s) {
-		    UV orev;
-		    if (*end == '_')
-			continue;
-		    orev = rev;
-		    rev += (*end - '0') * mult;
-		    mult *= 10;
-		    if (orev > rev && ckWARN_d(WARN_OVERFLOW))
-			Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
-				    "Integer overflow in decimal number");
-		}
-	    }
-#ifdef EBCDIC
-	    if (rev > 0x7FFFFFFF)
-		 Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
-#endif
-	    /* Append native character for the rev point */
-	    tmpend = uvchr_to_utf8(tmpbuf, rev);
-	    sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
-	    if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
-		 SvUTF8_on(sv);
-	    if (*pos == '.' && isDIGIT(pos[1]))
-		 s = ++pos;
-	    else {
-		 s = pos;
-		 break;
-	    }
-	    while (isDIGIT(*pos) || *pos == '_')
-		 pos++;
-	}
-	SvPOK_on(sv);
-	sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
-	SvRMAGICAL_on(sv);
-    }
-    return s;
-}
-
-/*
 =for apidoc scan_version
 
 Returns a pointer to the next character after the parsed
@@ -3763,26 +3693,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;
@@ -3818,7 +3762,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 */ 
     {
@@ -3832,7 +3776,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);
     }
@@ -3895,14 +3839,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;
 }
 
@@ -3934,19 +3879,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
@@ -3976,8 +3921,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) )
@@ -3985,8 +3930,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;
 }
 
@@ -4291,3 +4242,170 @@ 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 && *p != '\n' && *p != '\r')
+		 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:
+		      if (*p != '\n' && *p != '\r')
+			  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;
+}
+
+U32
+Perl_seed(pTHX)
+{
+    /*
+     * This is really just a quick hack which grabs various garbage
+     * values.  It really should be a real hash algorithm which
+     * spreads the effect of every input bit onto every output bit,
+     * if someone who knows about such things would bother to write it.
+     * Might be a good idea to add that function to CORE as well.
+     * No numbers below come from careful analysis or anything here,
+     * except they are primes and SEED_C1 > 1E6 to get a full-width
+     * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
+     * probably be bigger too.
+     */
+#if RANDBITS > 16
+#  define SEED_C1	1000003
+#define   SEED_C4	73819
+#else
+#  define SEED_C1	25747
+#define   SEED_C4	20639
+#endif
+#define   SEED_C2	3
+#define   SEED_C3	269
+#define   SEED_C5	26107
+
+#ifndef PERL_NO_DEV_RANDOM
+    int fd;
+#endif
+    U32 u;
+#ifdef VMS
+#  include <starlet.h>
+    /* when[] = (low 32 bits, high 32 bits) of time since epoch
+     * in 100-ns units, typically incremented ever 10 ms.        */
+    unsigned int when[2];
+#else
+#  ifdef HAS_GETTIMEOFDAY
+    struct timeval when;
+#  else
+    Time_t when;
+#  endif
+#endif
+
+/* This test is an escape hatch, this symbol isn't set by Configure. */
+#ifndef PERL_NO_DEV_RANDOM
+#ifndef PERL_RANDOM_DEVICE
+   /* /dev/random isn't used by default because reads from it will block
+    * if there isn't enough entropy available.  You can compile with
+    * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
+    * is enough real entropy to fill the seed. */
+#  define PERL_RANDOM_DEVICE "/dev/urandom"
+#endif
+    fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
+    if (fd != -1) {
+    	if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
+	    u = 0;
+	PerlLIO_close(fd);
+	if (u)
+	    return u;
+    }
+#endif
+
+#ifdef VMS
+    _ckvmssts(sys$gettim(when));
+    u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
+#else
+#  ifdef HAS_GETTIMEOFDAY
+    PerlProc_gettimeofday(&when,NULL);
+    u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
+#  else
+    (void)time(&when);
+    u = (U32)SEED_C1 * when;
+#  endif
+#endif
+    u += SEED_C3 * (U32)PerlProc_getpid();
+    u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
+#ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
+    u += SEED_C5 * (U32)PTR2UV(&when);
+#endif
+    return u;
+}
+
+UV
+Perl_get_hash_seed(pTHX)
+{
+     char *s = PerlEnv_getenv("PERL_HASH_SEED");
+     UV myseed = 0;
+
+     if (s)
+	  while (isSPACE(*s)) s++;
+     if (s && isDIGIT(*s))
+	  myseed = (UV)Atoul(s);
+     else
+#ifdef USE_HASH_SEED_EXPLICIT
+     if (s)
+#endif
+     {
+	  /* Compute a random seed */
+	  (void)seedDrand01((Rand_seed_t)seed());
+	  PL_srand_called = TRUE;
+	  myseed = (UV)(Drand01() * (NV)UV_MAX);
+#if RANDBITS < (UVSIZE * 8)
+	  /* Since there are not enough randbits to to reach all
+	   * the bits of a UV, the low bits might need extra
+	   * help.  Sum in another random number that will
+	   * fill in the low bits. */
+	  myseed +=
+	       (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
+#endif /* RANDBITS < (UVSIZE * 8) */
+     }
+     PL_hash_seed_set = TRUE;
+
+     return myseed;
+}