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*/
If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
void
-Perl_fbm_compile(pTHX_ SV *sv, U32 flags /* not used yet */)
+Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
register U8 *s;
register U8 *table;
if (len == 0) /* TAIL might be on on a zero-length string. */
return;
if (len > 2) {
- I32 mlen = len;
+ U8 mlen;
unsigned char *sb;
- if (mlen > 255)
+ if (len > 255)
mlen = 255;
- Sv_Grow(sv,len + 256 + FBM_TABLE_OFFSET);
+ else
+ mlen = (U8)len;
+ Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
- s = table - 1 - FBM_TABLE_OFFSET; /* Last char */
- for (i = 0; i < 256; i++) {
- table[i] = mlen;
- }
- table[-1] = flags; /* Not used yet */
+ s = table - 1 - FBM_TABLE_OFFSET; /* last char */
+ memset((void*)table, mlen, 256);
+ table[-1] = (U8)flags;
i = 0;
- sb = s - mlen;
+ sb = s - mlen + 1; /* first char (maybe) */
while (s >= sb) {
if (table[*s] == mlen)
- table[*s] = i;
+ table[*s] = (U8)i;
s--, i++;
}
}
BmUSEFUL(sv) = 100; /* Initial value */
if (flags & FBMcf_TAIL)
SvTAIL_on(sv);
- DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
+ BmRARE(sv),BmPREVIOUS(sv)));
}
/* If SvTAIL(littlestr), it has a fake '\n' at end. */
}
if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
s = bigend - littlelen;
- if (s >= big
- && bigend[-1] == '\n'
- && *s == *little
+ if (s >= big && bigend[-1] == '\n' && *s == *little
/* Automatically of length > 2 */
&& memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
+ {
return (char*)s; /* how sweet it is */
- if (s[1] == *little && memEQ((char*)s + 2,(char*)little + 1,
- littlelen - 2))
+ }
+ if (s[1] == *little
+ && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
+ {
return (char*)s + 1; /* how sweet it is */
+ }
return Nullch;
}
if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
/* Chop \n from littlestr: */
s = bigend - littlelen + 1;
- if (*s == *little && memEQ((char*)s + 1, (char*)little + 1,
- littlelen - 2))
+ if (*s == *little
+ && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
+ {
return (char*)s;
+ }
return Nullch;
}
return b;
top2:
/*SUPPRESS 560*/
- if (tmp = table[*s]) {
+ if ((tmp = table[*s])) {
#ifdef POINTERRIGOR
if (bigend - s > tmp) {
s += tmp;
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";
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
dTHR;
-#ifdef IV_IS_QUAD
if (PL_curcop->cop_line)
- Perl_sv_catpvf(aTHX_ sv, " at %_ line %" PERL_PRId64,
+ Perl_sv_catpvf(aTHX_ sv, " at %_ line %"IVdf,
GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line);
-#else
- if (PL_curcop->cop_line)
- Perl_sv_catpvf(aTHX_ sv, " at %_ line %ld",
- GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
-#endif
if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
bool line_mode = (RsSIMPLE(PL_rs) &&
SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
-#ifdef IV_IS_QUAD
- Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %" PERL_PRId64,
+ Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
-#else
- Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %ld",
- PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
- line_mode ? "line" : "chunk",
- (long)IoLINES(GvIOp(PL_last_in_gv)));
-#endif
}
#ifdef USE_THREADS
if (thr->tid)
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;
PUSHMARK(SP);
XPUSHs(msg);
PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
+ /* HACK - REVISIT - avoid CATCH_SET(TRUE) in call_sv()
+ or we come back here due to a JMPENV_JMP() and do
+ a POPSTACK - but die_where() will have already done
+ one as it unwound - NI-S 1999/08/14 */
+ call_sv((SV*)cv, G_DISCARD|G_NOCATCH);
POPSTACK;
LEAVE;
}
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 */
}
/* 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;
}
if (!overflowed)
rnv = (NV) ruv;
if ( ( overflowed && rnv > 4294967295.0)
-#if UV_SIZEOF > 4
+#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
if (!overflowed)
rnv = (NV) ruv;
if ( ( overflowed && rnv > 4294967295.0)
-#if UV_SIZEOF > 4
+#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
if (!overflowed)
rnv = (NV) ruv;
if ( ( overflowed && rnv > 4294967295.0)
-#if UV_SIZEOF > 4
+#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
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);
projects / p5sagit/p5-mst-13.2.git / blobdiff