sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
s = (U8*)SvPV_force(sv, len);
(void)SvUPGRADE(sv, SVt_PVBM);
- if (len == 0) /* TAIL might be on on a zero-length string. */
+ if (len == 0) /* TAIL might be on a zero-length string. */
return;
if (len > 2) {
U8 mlen;
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
if (thr->tid)
Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
#endif
PL_restartop = die_where(message, msglen);
JMPENV_JUMP(3);
}
+ else if (!message)
+ message = SvPVx(ERRSV, msglen);
+
{
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
#endif
PerlIO *serr = Perl_error_log;
- PerlIO_write(serr, message, msglen);
+ PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
(void)PerlIO_flush(serr);
#ifdef USE_SFIO
errno = e;
{
PerlIO *serr = Perl_error_log;
- PerlIO_write(serr, message, msglen);
+ PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
#ifdef LEAKTEST
DEBUG_L(*message == '!'
? (xstat(message[1]=='!'
message = SvPV(msv, msglen);
if (ckDEAD(err)) {
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
if (PL_diehook) {
/* sv_2cv might call Perl_croak() */
SV *olddiehook = PL_diehook;
}
{
PerlIO *serr = Perl_error_log;
- PerlIO_write(serr, message, msglen);
+ PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
(void)PerlIO_flush(serr);
}
my_failure_exit();
}
{
PerlIO *serr = Perl_error_log;
- PerlIO_write(serr, message, msglen);
+ PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
#ifdef LEAKTEST
DEBUG_L(*message == '!'
? (xstat(message[1]=='!'
}
}
+/* since we've already done strlen() for both nam and val
+ * we can use that info to make things faster than
+ * sprintf(s, "%s=%s", nam, val)
+ */
+#define my_setenv_format(s, nam, nlen, val, vlen) \
+ Copy(nam, s, nlen, char); \
+ *(s+nlen) = '='; \
+ Copy(val, s+(nlen+1), vlen, char); \
+ *(s+(nlen+1+vlen)) = '\0'
+
#ifdef USE_ENVIRON_ARRAY
/* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */
#if !defined(WIN32) && !defined(NETWARE)
#ifndef PERL_USE_SAFE_PUTENV
/* most putenv()s leak, so we manipulate environ directly */
register I32 i=setenv_getix(nam); /* where does it go? */
+ int nlen, vlen;
if (environ == PL_origenviron) { /* need we copy environment? */
I32 j;
for (max = i; environ[max]; max++) ;
tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
for (j=0; j<max; j++) { /* copy environment */
- tmpenv[j] = (char*)safesysmalloc((strlen(environ[j])+1)*sizeof(char));
- strcpy(tmpenv[j], environ[j]);
+ int len = strlen(environ[j]);
+ tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+ Copy(environ[j], tmpenv[j], len+1, char);
}
tmpenv[max] = Nullch;
environ = tmpenv; /* tell exec where it is now */
}
else
safesysfree(environ[i]);
- environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char));
+ nlen = strlen(nam);
+ vlen = strlen(val);
- (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
+ environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(environ[i], nam, nlen, val, vlen);
#else /* PERL_USE_SAFE_PUTENV */
# if defined(__CYGWIN__)
setenv(nam, val, 1);
# else
char *new_env;
-
- new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
- (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
+ int nlen = strlen(nam), vlen;
+ if (!val) {
+ val = "";
+ }
+ vlen = strlen(val);
+ new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
# endif /* __CYGWIN__ */
#endif /* PERL_USE_SAFE_PUTENV */
Perl_my_setenv(pTHX_ char *nam,char *val)
{
register char *envstr;
- STRLEN len = strlen(nam) + 3;
+ int nlen = strlen(nam), vlen;
+
if (!val) {
val = "";
}
- len += strlen(val);
- New(904, envstr, len, char);
- (void)sprintf(envstr,"%s=%s",nam,val);
+ vlen = strlen(val);
+ New(904, envstr, nlen+vlen+2, char);
+ my_setenv_format(envstr, nam, nlen, val, vlen);
(void)PerlEnv_putenv(envstr);
Safefree(envstr);
}
did_pipes = 0;
if (n) { /* Error */
int pid2, status;
+ PerlLIO_close(p[This]);
if (n != sizeof(int))
Perl_croak(aTHX_ "panic: kid popen errno read");
do {
}
#endif /* defined OS2 */
/*SUPPRESS 560*/
- if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
+ if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+ SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), PerlProc_getpid());
+ SvREADONLY_on(GvSV(tmpgv));
+ }
PL_forkprocess = 0;
hv_clear(PL_pidstatus); /* we have no children */
return Nullfp;
did_pipes = 0;
if (n) { /* Error */
int pid2, status;
+ PerlLIO_close(p[This]);
if (n != sizeof(int))
Perl_croak(aTHX_ "panic: kid popen errno read");
do {
void
Perl_atfork_lock(void)
{
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
/* locks must be held in locking order (if any) */
# ifdef MYMALLOC
MUTEX_LOCK(&PL_malloc_mutex);
void
Perl_atfork_unlock(void)
{
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
/* locks must be released in same order as in atfork_lock() */
# ifdef MYMALLOC
MUTEX_UNLOCK(&PL_malloc_mutex);
{
#if defined(HAS_FORK)
Pid_t pid;
-#if (defined(USE_THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
+#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
atfork_lock();
pid = fork();
atfork_unlock();
return PerlProc_signal(signo, handler);
}
-static int sig_trapped;
+static int sig_trapped; /* XXX signals are process-wide anyway, so we
+ ignore the implications of this for threading */
static
Signal_t
char *xfailed = Nullch;
char tmpbuf[MAXPATHLEN];
register char *s;
- I32 len;
+ I32 len = 0;
int retval;
#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
# define SEARCH_EXTS ".bat", ".cmd", NULL
void *
Perl_get_context(void)
{
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
# ifdef OLD_PTHREADS_API
pthread_addr_t t;
if (pthread_getspecific(PL_thr_key, &t))
void
Perl_set_context(void *t)
{
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
# else
#endif /* !PERL_GET_CONTEXT_DEFINED */
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
#ifdef FAKE_THREADS
/* Very simplistic scheduler for now */
PL_tainted = t->Ttainted;
PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
- PL_nrs = newSVsv(t->Tnrs);
- PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv;
+ PL_rs = newSVsv(t->Trs);
PL_last_in_gv = Nullgv;
PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
#endif /* HAVE_THREAD_INTERN */
return thr;
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars *
case want_vtbl_uvar:
result = &PL_vtbl_uvar;
break;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
case want_vtbl_mutex:
result = &PL_vtbl_mutex;
break;
{
#ifndef PERL_MICRO
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(sv);
+#endif
+
#ifdef HAS_GETCWD
{
char buf[MAXPATHLEN];
#endif
}
+/*
+=for apidoc new_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 = new_vstring(s,sv);
+
+The sv must already be large enough to store the vstring
+passed in.
+
+=cut
+*/
+
+char *
+Perl_new_vstring(pTHX_ char *s, SV *sv)
+{
+ char *pos = 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;
+ if ( *(s-1) == '_') {
+ mult = 10;
+ }
+ while (--end >= s) {
+ UV orev;
+ orev = rev;
+ rev += (*end - '0') * mult;
+ mult *= 10;
+ if (orev > rev && ckWARN_d(WARN_OVERFLOW))
+ Perl_warner(aTHX_ WARN_OVERFLOW,
+ "Integer overflow in decimal number");
+ }
+ }
+ /* 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 == '.' || *pos == '_') && isDIGIT(pos[1]))
+ s = ++pos;
+ else {
+ s = pos;
+ break;
+ }
+ while (isDIGIT(*pos) )
+ pos++;
+ }
+ SvPOK_on(sv);
+ SvREADONLY_on(sv);
+ }
+ return s;
+}
+
+
projects / p5sagit/p5-mst-13.2.git / blobdiff