/* util.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 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.
Perl_savepv(pTHX_ const char *pv)
{
register char *newaddr;
+#ifdef PERL_MALLOC_WRAP
+ STRLEN pvlen;
+#endif
if (!pv)
return Nullch;
+#ifdef PERL_MALLOC_WRAP
+ pvlen = strlen(pv)+1;
+ New(902,newaddr,pvlen,char);
+#else
New(902,newaddr,strlen(pv)+1,char);
+#endif
return strcpy(newaddr,pv);
}
return strcpy(newaddr,pv);
}
+/*
+=for apidoc savesvpv
+
+A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
+the passed in SV using C<SvPV()>
+
+=cut
+*/
+
+char *
+Perl_savesvpv(pTHX_ SV *sv)
+{
+ STRLEN len;
+ const char *pv = SvPV(sv, len);
+ register char *newaddr;
+
+ ++len;
+ New(903,newaddr,len,char);
+ return CopyD(pv,newaddr,len,char);
+}
/* the SV for Perl_form() and mess() is not kept in an arena */
}
}
+/* Common code used by vcroak, vdie and vwarner */
+
+void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8);
+
+char *
+S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
+ I32* utf8)
+{
+ char *message;
+
+ if (pat) {
+ SV *msv = vmess(pat, args);
+ if (PL_errors && SvCUR(PL_errors)) {
+ sv_catsv(PL_errors, msv);
+ message = SvPV(PL_errors, *msglen);
+ SvCUR_set(PL_errors, 0);
+ }
+ else
+ message = SvPV(msv,*msglen);
+ *utf8 = SvUTF8(msv);
+ }
+ else {
+ message = Nullch;
+ }
+
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
+ "%p: die/croak: message = %s\ndiehook = %p\n",
+ thr, message, PL_diehook));
+ if (PL_diehook) {
+ S_vdie_common(aTHX_ message, *msglen, *utf8);
+ }
+ return message;
+}
+
void
S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
{
{
char *message;
int was_in_eval = PL_in_eval;
- SV *msv;
STRLEN msglen;
I32 utf8 = 0;
"%p: die: curstack = %p, mainstack = %p\n",
thr, PL_curstack, PL_mainstack));
- if (pat) {
- msv = vmess(pat, args);
- if (PL_errors && SvCUR(PL_errors)) {
- sv_catsv(PL_errors, msv);
- message = SvPV(PL_errors, msglen);
- SvCUR_set(PL_errors, 0);
- }
- else
- message = SvPV(msv,msglen);
- utf8 = SvUTF8(msv);
- }
- else {
- message = Nullch;
- msglen = 0;
- }
-
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p: die: message = %s\ndiehook = %p\n",
- thr, message, PL_diehook));
- if (PL_diehook) {
- S_vdie_common(aTHX_ message, msglen, utf8);
- }
+ message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
PL_restartop = die_where(message, msglen);
SvFLAGS(ERRSV) |= utf8;
Perl_vcroak(pTHX_ const char* pat, va_list *args)
{
char *message;
- HV *stash;
- GV *gv;
- CV *cv;
- SV *msv;
STRLEN msglen;
I32 utf8 = 0;
- if (pat) {
- msv = vmess(pat, args);
- if (PL_errors && SvCUR(PL_errors)) {
- sv_catsv(PL_errors, msv);
- message = SvPV(PL_errors, msglen);
- SvCUR_set(PL_errors, 0);
- }
- else
- message = SvPV(msv,msglen);
- utf8 = SvUTF8(msv);
- }
- else {
- message = Nullch;
- msglen = 0;
- }
-
- DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
- PTR2UV(thr), message));
-
- if (PL_diehook) {
- /* sv_2cv might call Perl_croak() */
- SV *olddiehook = PL_diehook;
- ENTER;
- SAVESPTR(PL_diehook);
- PL_diehook = Nullsv;
- cv = sv_2cv(olddiehook, &stash, &gv, 0);
- LEAVE;
- if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
- dSP;
- SV *msg;
-
- ENTER;
- save_re_context();
- if (message) {
- msg = newSVpvn(message, msglen);
- SvFLAGS(msg) |= utf8;
- SvREADONLY_on(msg);
- SAVEFREESV(msg);
- }
- else {
- msg = ERRSV;
- }
+ message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
- PUSHSTACKi(PERLSI_DIEHOOK);
- PUSHMARK(SP);
- XPUSHs(msg);
- PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
- POPSTACK;
- LEAVE;
- }
- }
if (PL_in_eval) {
PL_restartop = die_where(message, msglen);
SvFLAGS(ERRSV) |= utf8;
#endif
{
#ifndef PERL_USE_SAFE_PUTENV
+ if (!PL_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;
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 */
+ } else {
+# endif
# if defined(__CYGWIN__) || defined( EPOC)
setenv(nam, val, 1);
# else
my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
# endif /* __CYGWIN__ */
-#endif /* PERL_USE_SAFE_PUTENV */
+#ifndef PERL_USE_SAFE_PUTENV
+ }
+#endif
}
}
register I32 This, that;
register Pid_t pid;
SV *sv;
- I32 doexec = strNE(cmd,"-");
+ I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
I32 did_pipes = 0;
int pp[2];
{
SV *sv;
SV** svp;
- char spid[TYPE_CHARS(int)];
+ char spid[TYPE_CHARS(IV)];
if (pid > 0) {
sprintf(spid, "%"IVdf, (IV)pid);
hv_iterinit(PL_pidstatus);
if ((entry = hv_iternext(PL_pidstatus))) {
- SV *sv;
- char spid[TYPE_CHARS(int)];
-
pid = atoi(hv_iterkey(entry,(I32*)statusp));
sv = hv_iterval(PL_pidstatus,entry);
*statusp = SvIVX(sv);
Perl_pidgone(pTHX_ Pid_t pid, int status)
{
register SV *sv;
- char spid[TYPE_CHARS(int)];
+ char spid[TYPE_CHARS(IV)];
sprintf(spid, "%"IVdf, (IV)pid);
sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
#endif
else /* must be a string or something like a string */
{
- STRLEN n_a;
- version = savepv(SvPV(ver,n_a));
+ version = savesvpv(ver);
}
(void)scan_version(version, ver, qv);
Safefree(version);