DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
- *(tTHX*)ptr = aTHX;
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+#endif
+
+#ifdef PERL_POISON
+ Poison(((char *)ptr), size, char);
+#endif
+
+#ifdef PERL_TRACK_MEMPOOL
+ header->interpreter = aTHX;
+ /* Link us into the list. */
+ header->prev = &PL_memory_debug_header;
+ header->next = PL_memory_debug_header.next;
+ PL_memory_debug_header.next = header;
+ header->next->prev = header;
+# ifdef PERL_POISON
+ header->size = size;
+# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
return ptr;
#ifdef PERL_TRACK_MEMPOOL
where = (Malloc_t)((char*)where-sTHX);
size += sTHX;
- if (*(tTHX*)where != aTHX) {
- Perl_croak_nocontext("panic: realloc from wrong pool");
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
+
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: realloc from wrong pool");
+ }
+ assert(header->next->prev == header);
+ assert(header->prev->next == header);
+# ifdef PERL_POISON
+ if (header->size > size) {
+ const MEM_SIZE freed_up = header->size - size;
+ char *start_of_freed = ((char *)where) + size;
+ Poison(start_of_freed, freed_up, char);
+ }
+ header->size = size;
+# endif
}
#endif
#ifdef DEBUGGING
if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+
+# ifdef PERL_POISON
+ if (header->size < size) {
+ const MEM_SIZE fresh = size - header->size;
+ char *start_of_fresh = ((char *)ptr) + size;
+ Poison(start_of_fresh, fresh, char);
+ }
+# endif
+
+ header->next->prev = header;
+ header->prev->next = header;
+
ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
return ptr;
if (where) {
#ifdef PERL_TRACK_MEMPOOL
where = (Malloc_t)((char*)where-sTHX);
- if (*(tTHX*)where != aTHX) {
- Perl_croak_nocontext("panic: free from wrong pool");
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
+
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: free from wrong pool");
+ }
+ if (!header->prev) {
+ Perl_croak_nocontext("panic: duplicate free");
+ }
+ if (!(header->next) || header->next->prev != header
+ || header->prev->next != header) {
+ Perl_croak_nocontext("panic: bad free");
+ }
+ /* Unlink us from the chain. */
+ header->next->prev = header->prev;
+ header->prev->next = header->next;
+# ifdef PERL_POISON
+ Poison(where, header->size, char);
+# endif
+ /* Trigger the duplicate free warning. */
+ header->next = NULL;
}
#endif
PerlMem_free(where);
if (ptr != NULL) {
memset((void*)ptr, 0, size);
#ifdef PERL_TRACK_MEMPOOL
- *(tTHX*)ptr = aTHX;
- ptr = (Malloc_t)((char*)ptr+sTHX);
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
+
+ header->interpreter = aTHX;
+ /* Link us into the list. */
+ header->prev = &PL_memory_debug_header;
+ header->next = PL_memory_debug_header.next;
+ PL_memory_debug_header.next = header;
+ header->next->prev = header;
+# ifdef PERL_POISON
+ header->size = size;
+# endif
+ ptr = (Malloc_t)((char*)ptr+sTHX);
+ }
#endif
return ptr;
}
return retval;
}
-STATIC COP*
-S_closest_cop(pTHX_ COP *cop, const OP *o)
+STATIC const COP*
+S_closest_cop(pTHX_ const COP *cop, const OP *o)
{
/* Look for PL_op starting from o. cop is the last COP we've seen. */
return cop;
if (o->op_flags & OPf_KIDS) {
- OP *kid;
+ const OP *kid;
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
- COP *new_cop;
+ const COP *new_cop;
/* If the OP_NEXTSTATE has been optimised away we can still use it
* the get the file and line number. */
if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
- cop = (COP *)kid;
+ cop = (const COP *)kid;
/* Keep searching, and return when we've found something. */
/* Nothing found. */
- return Null(COP *);
+ return NULL;
}
SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
SV * const sv = mess_alloc();
- static const char dgd[] = " during global destruction.\n";
- sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
-
/*
* Try and find the file and line for PL_op. This will usually be
* PL_curcop, but it might be a cop that has been optimised away. We
*/
const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
- if (!cop) cop = PL_curcop;
+ if (!cop)
+ cop = PL_curcop;
if (CopLINE(cop))
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
const bool line_mode = (RsSIMPLE(PL_rs) &&
SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
- PL_last_in_gv == PL_argvgv ?
- "" : GvNAME(PL_last_in_gv),
+ PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
if (thr->tid)
Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
#endif
- sv_catpv(sv, PL_dirty ? dgd : ".\n");
+ if (PL_dirty)
+ sv_catpvs(sv, " during global destruction");
+ sv_catpvs(sv, ".\n");
}
return sv;
}
PerlProc__exit(1);
}
#endif /* defined OS2 */
- if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+ if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
PL_restartop = 0;
- PL_statname = NEWSV(66,0);
+ PL_statname = newSV(0);
PL_errors = newSVpvn("", 0);
PL_maxscream = -1;
PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
fd_set rset;
FD_ZERO(&rset);
- FD_SET(sockets[0], &rset);
- FD_SET(sockets[1], &rset);
+ FD_SET((unsigned int)sockets[0], &rset);
+ FD_SET((unsigned int)sockets[1], &rset);
got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
if (got != 2 || !FD_ISSET(sockets[0], &rset)
https://perl5.git.perl.org / perl5.git / blobdiff