/* 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.
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. */
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)
{
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();
}
CV *cv;
SV *msv;
STRLEN msglen;
- IO *io;
- MAGIC *mg;
msv = vmess(pat, args);
message = SvPV(msv, msglen);
}
}
- /* 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)
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 {
return;
}
}
- {
- PerlIO *serr = Perl_error_log;
- PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
- (void)PerlIO_flush(serr);
- }
+ write_to_stderr(message, msglen);
}
}
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
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
}
#ifdef EBCDIC
if (rev > 0x7FFFFFFF)
- Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
+ 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);
orev = rev;
rev += (*s - '0') * mult;
mult /= 10;
- if ( abs(orev) > abs(rev) )
+ if ( PERL_ABS(orev) > PERL_ABS(rev) )
Perl_croak(aTHX_ "Integer overflow in version");
s++;
}
orev = rev;
rev += (*end - '0') * mult;
mult *= 10;
- if ( abs(orev) > abs(rev) )
+ if ( PERL_ABS(orev) > PERL_ABS(rev) )
Perl_croak(aTHX_ "Integer overflow in version");
}
}
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");
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) )
if (isDIGIT(*p)) {
opt = (U32) atoi(p);
while (isDIGIT(*p)) p++;
- if (*p)
+ if (*p && *p != '\n' && *p != '\r')
Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
}
else {
case PERL_UNICODE_ARGV:
opt |= PERL_UNICODE_ARGV_FLAG; break;
default:
- Perl_croak(aTHX_
- "Unknown Unicode option letter '%c'", *p);
+ if (*p != '\n' && *p != '\r')
+ Perl_croak(aTHX_
+ "Unknown Unicode option letter '%c'", *p);
}
}
}
opt = PERL_UNICODE_DEFAULT_FLAGS;
if (opt & ~PERL_UNICODE_ALL_FLAGS)
- Perl_croak(aTHX_ "Unknown Unicode option value 0x%"IVdf,
+ 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;
+}
+