Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
+ dTHX;
Malloc_t ptr;
#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
PerlIO_printf(PerlIO_stderr(),
"Allocation too large: %lx\n", size) FLUSH;
- WITH_THX(my_exit(1));
+ my_exit(1);
}
#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
Perl_croak_nocontext("panic: malloc");
#endif
ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
-#if !(defined(I286) || defined(atarist))
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
-#else
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
-#endif
if (ptr != Nullch)
return ptr;
else if (PL_nomemok)
return Nullch;
else {
PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
- WITH_THX(my_exit(1));
+ my_exit(1);
return Nullch;
}
/*NOTREACHED*/
Malloc_t
Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
{
+ dTHX;
Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
Malloc_t PerlMem_realloc();
if (size > 0xffff) {
PerlIO_printf(PerlIO_stderr(),
"Reallocation too large: %lx\n", size) FLUSH;
- WITH_THX(my_exit(1));
+ my_exit(1);
}
#endif /* HAS_64K_LIMIT */
if (!size) {
#endif
ptr = PerlMem_realloc(where,size);
-#if !(defined(I286) || defined(atarist))
- DEBUG_m( {
- PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,PL_an++);
- PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
- } )
-#else
- DEBUG_m( {
- PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++);
- PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
- } )
-#endif
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size));
if (ptr != Nullch)
return ptr;
return Nullch;
else {
PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
- WITH_THX(my_exit(1));
+ my_exit(1);
return Nullch;
}
/*NOTREACHED*/
Free_t
Perl_safesysfree(Malloc_t where)
{
-#if !(defined(I286) || defined(atarist))
- DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,PL_an++));
-#else
+ dTHX;
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,PL_an++));
-#endif
if (where) {
/*SUPPRESS 701*/
PerlMem_free(where);
Malloc_t
Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
{
+ dTHX;
Malloc_t ptr;
#ifdef HAS_64K_LIMIT
if (size * count > 0xffff) {
PerlIO_printf(PerlIO_stderr(),
"Allocation too large: %lx\n", size * count) FLUSH;
- WITH_THX(my_exit(1));
+ my_exit(1);
}
#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
#endif
size *= count;
ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
-#if !(defined(I286) || defined(atarist))
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
-#else
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
-#endif
if (ptr != Nullch) {
memset((void*)ptr, 0, size);
return ptr;
return Nullch;
else {
PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
- WITH_THX(my_exit(1));
+ my_exit(1);
return Nullch;
}
/*NOTREACHED*/
return SvPVX(sv);
}
+#if defined(PERL_IMPLICIT_CONTEXT)
+SV *
+Perl_mess_nocontext(const char *pat, ...)
+{
+ dTHX;
+ SV *retval;
+ va_list args;
+ va_start(args, pat);
+ retval = vmess(pat, &args);
+ va_end(args);
+ return retval;
+}
+#endif /* PERL_IMPLICIT_CONTEXT */
+
SV *
-Perl_mess(pTHX_ const char *pat, va_list *args)
+Perl_mess(pTHX_ const char *pat, ...)
+{
+ SV *retval;
+ va_list args;
+ va_start(args, pat);
+ retval = vmess(pat, &args);
+ va_end(args);
+ return retval;
+}
+
+SV *
+Perl_vmess(pTHX_ const char *pat, va_list *args)
{
SV *sv = mess_alloc();
static char dgd[] = " during global destruction.\n";
thr, PL_curstack, PL_mainstack));
if (pat) {
- msv = mess(pat, args);
- message = SvPV(msv,msglen);
+ 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);
}
else {
message = Nullch;
SV *msv;
STRLEN msglen;
- msv = mess(pat, args);
- message = SvPV(msv,msglen);
- DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+ 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);
+
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s",
+ (unsigned long) thr, message));
+
if (PL_diehook) {
/* sv_2cv might call Perl_croak() */
SV *olddiehook = PL_diehook;
SV *msv;
STRLEN msglen;
- msv = mess(pat, args);
+ msv = vmess(pat, args);
message = SvPV(msv, msglen);
if (PL_warnhook) {
SV *msv;
STRLEN msglen;
- msv = mess(pat, args);
+ msv = vmess(pat, args);
message = SvPV(msv, msglen);
if (ckDEAD(err)) {
safesysfree(environ[i]);
environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char));
-#ifndef MSDOS
(void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
-#else
- /* MS-DOS requires environment variable names to be in uppercase */
- /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
- * some utilities and applications may break because they only look
- * for upper case strings. (Fixed strupr() bug here.)]
- */
- strcpy(environ[i],nam); strupr(environ[i]);
- (void)sprintf(environ[i] + strlen(nam),"=%s",val);
-#endif /* MSDOS */
#else /* PERL_USE_SAFE_PUTENV */
char *new_env;
new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
-#ifndef MSDOS
(void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
-#else
- strcpy(new_env,nam); strupr(new_env);
- (void)sprintf(new_env + strlen(nam),"=%s",val);
-#endif
(void)putenv(new_env);
#endif /* PERL_USE_SAFE_PUTENV */
}
{
int p[2];
register I32 This, that;
- register I32 pid;
+ register Pid_t pid;
SV *sv;
I32 doexec = strNE(cmd,"-");
I32 did_pipes = 0;
#endif /* defined OS2 */
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv), (IV)getpid());
+ sv_setiv(GvSV(tmpgv), getpid());
PL_forkprocess = 0;
hv_clear(PL_pidstatus); /* we have no children */
return Nullfp;
Sigsave_t hstat, istat, qstat;
int status;
SV **svp;
- int pid;
- int pid2;
+ Pid_t pid;
+ Pid_t pid2;
bool close_failed;
int saved_errno;
#ifdef VMS
#endif
svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
- pid = (int)SvIVX(*svp);
+ pid = SvIVX(*svp);
SvREFCNT_dec(*svp);
*svp = &PL_sv_undef;
#ifdef OS2
#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
I32
-Perl_wait4pid(pTHX_ int pid, int *statusp, int flags)
+Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
SV *sv;
SV** svp;
void
/*SUPPRESS 590*/
-Perl_pidgone(pTHX_ int pid, int status)
+Perl_pidgone(pTHX_ Pid_t pid, int status)
{
register SV *sv;
char spid[TYPE_CHARS(int)];
/* Needs work for PerlIO ! */
FILE *f = PerlIO_findFILE(ptr);
I32 result = pclose(f);
+#if defined(DJGPP)
+ result = (result << 8) & 0xff00;
+#endif
PerlIO_releaseFILE(ptr,f);
return result;
}
}
else {
dTHR;
- if (ckWARN(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE,
+ if (ckWARN(WARN_DIGIT))
+ Perl_warner(aTHX_ WARN_DIGIT,
"Illegal binary digit '%c' ignored", *s);
break;
}
dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
- if (ckWARN_d(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE,
+ if (ckWARN_d(WARN_OVERFLOW))
+ Perl_warner(aTHX_ WARN_OVERFLOW,
"Integer overflow in binary number");
} else
ruv = xuv | (*s - '0');
if (!overflowed)
rnv = (NV) ruv;
if ( ( overflowed && rnv > 4294967295.0)
-#if UV_SIZEOF > 4
+#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
dTHR;
- if (ckWARN(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE,
+ if (ckWARN(WARN_PORTABLE))
+ Perl_warner(aTHX_ WARN_PORTABLE,
"Binary number > 0b11111111111111111111111111111111 non-portable");
}
*retlen = s - start;
* someone seems to want to use the digits eight and nine). */
if (*s == '8' || *s == '9') {
dTHR;
- if (ckWARN(WARN_OCTAL))
- Perl_warner(aTHX_ WARN_OCTAL,
+ if (ckWARN(WARN_DIGIT))
+ Perl_warner(aTHX_ WARN_DIGIT,
"Illegal octal digit '%c' ignored", *s);
}
break;
dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
- if (ckWARN_d(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE,
+ if (ckWARN_d(WARN_OVERFLOW))
+ Perl_warner(aTHX_ WARN_OVERFLOW,
"Integer overflow in octal number");
} else
ruv = xuv | (*s - '0');
if (!overflowed)
rnv = (NV) ruv;
if ( ( overflowed && rnv > 4294967295.0)
-#if UV_SIZEOF > 4
+#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
dTHR;
- if (ckWARN(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE,
+ if (ckWARN(WARN_PORTABLE))
+ Perl_warner(aTHX_ WARN_PORTABLE,
"Octal number > 037777777777 non-portable");
}
*retlen = s - start;
}
else {
dTHR;
- if (ckWARN(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE,
+ if (ckWARN(WARN_DIGIT))
+ Perl_warner(aTHX_ WARN_DIGIT,
"Illegal hexadecimal digit '%c' ignored", *s);
break;
}
dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
- if (ckWARN_d(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE,
+ if (ckWARN_d(WARN_OVERFLOW))
+ Perl_warner(aTHX_ WARN_OVERFLOW,
"Integer overflow in hexadecimal number");
} else
ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
if (!overflowed)
rnv = (NV) ruv;
if ( ( overflowed && rnv > 4294967295.0)
-#if UV_SIZEOF > 4
+#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
dTHR;
- if (ckWARN(WARN_UNSAFE))
- Perl_warner(aTHX_ WARN_UNSAFE,
+ if (ckWARN(WARN_PORTABLE))
+ Perl_warner(aTHX_ WARN_PORTABLE,
"Hexadecimal number > 0xffffffff non-portable");
}
*retlen = s - start;
PL_restartop = 0;
PL_statname = NEWSV(66,0);
+ PL_errors = newSVpvn("", 0);
PL_maxscream = -1;
PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);