util.c 139 KB
Newer Older
1 2
/*    util.c
 *
3 4
 *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
 *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5 6 7 8 9 10 11
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
12 13 14
 * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
 *  not content.'                                    --Gandalf to Pippin
 *
15
 *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
16 17
 */

18 19 20 21 22 23
/* This file contains assorted utility routines.
 * Which is a polite way of saying any stuff that people couldn't think of
 * a better place for. Amongst other things, it includes the warning and
 * dieing stuff, plus wrappers for malloc code.
 */

24 25 26
#include "EXTERN.h"
#define PERL_IN_UTIL_C
#include "perl.h"
27
#include "reentr.h"
28

29
#if defined(USE_PERLIO)
30 31 32
#include "perliol.h" /* For PerlIOUnix_refcnt */
#endif

33
#ifndef PERL_MICRO
34 35 36 37 38 39
#include <signal.h>
#ifndef SIG_ERR
# define SIG_ERR ((Sighandler_t) -1)
#endif
#endif

40 41 42
#include <math.h>
#include <stdlib.h>

43 44 45 46 47
#ifdef __Lynx__
/* Missing protos on LynxOS */
int putenv(char *);
#endif

48 49 50 51
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
#  include <sys/select.h>
# endif
52 53
#endif

54 55 56 57
#ifdef PERL_DEBUG_READONLY_COW
# include <sys/mman.h>
#endif

58 59 60 61 62 63 64 65 66 67 68 69
#define FLUSH

#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
#  define FD_CLOEXEC 1			/* NeXT needs this */
#endif

/* NOTE:  Do not call the next three routines directly.  Use the macros
 * in handy.h, so that we can easily redefine everything to do tracking of
 * allocated hunks back to the original New to track down any memory leaks.
 * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
 */

70 71 72 73
#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
#  define ALWAYS_NEED_THX
#endif

74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
static void
S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
{
    if (header->readonly
     && mprotect(header, header->size, PROT_READ|PROT_WRITE))
	Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
			 header, header->size, errno);
}

static void
S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
{
    if (header->readonly
     && mprotect(header, header->size, PROT_READ))
	Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
			 header, header->size, errno);
}
# define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
# define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
#else
# define maybe_protect_rw(foo) NOOP
# define maybe_protect_ro(foo) NOOP
#endif

#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
 /* Use memory_debug_header */
# define USE_MDH
# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
   || defined(PERL_DEBUG_READONLY_COW)
#  define MDH_HAS_SIZE
# endif
#endif

108 109
/* paranoid version of system's malloc() */

110 111 112
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
113
#ifdef ALWAYS_NEED_THX
114
    dTHX;
115
#endif
116
    Malloc_t ptr;
117
    size += PERL_MEMORY_DEBUG_HEADER_SIZE;
118
#ifdef DEBUGGING
119 120
    if ((SSize_t)size < 0)
	Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
121
#endif
122 123 124 125 126 127 128 129 130 131
    if (!size) size = 1;	/* malloc(0) is NASTY on our system */
#ifdef PERL_DEBUG_READONLY_COW
    if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
		    MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
	perror("mmap failed");
	abort();
    }
#else
    ptr = (Malloc_t)PerlMem_malloc(size?size:1);
#endif
132
    PERL_ALLOC_CHECK(ptr);
133
    if (ptr != NULL) {
134
#ifdef USE_MDH
135 136 137 138 139 140 141 142 143 144 145 146 147 148
	struct perl_memory_debug_header *const header
	    = (struct perl_memory_debug_header *)ptr;
#endif

#ifdef PERL_POISON
	PoisonNew(((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;
149
	maybe_protect_rw(header->next);
150
	header->next->prev = header;
151 152 153
	maybe_protect_ro(header->next);
#  ifdef PERL_DEBUG_READONLY_COW
	header->readonly = 0;
154 155
#  endif
#endif
156 157 158 159
#ifdef MDH_HAS_SIZE
	header->size = size;
#endif
        ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
160
	DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
161
	return ptr;
162
}
163
    else {
164 165 166 167 168 169
#ifndef ALWAYS_NEED_THX
	dTHX;
#endif
	if (PL_nomemok)
	    return NULL;
	else {
170
	    croak_no_mem();
171
	}
172 173 174 175 176 177 178 179 180
    }
    /*NOTREACHED*/
}

/* paranoid version of system's realloc() */

Malloc_t
Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
{
181
#ifdef ALWAYS_NEED_THX
182
    dTHX;
183
#endif
184
    Malloc_t ptr;
185 186 187 188 189
#ifdef PERL_DEBUG_READONLY_COW
    const MEM_SIZE oldsize = where
	? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
	: 0;
#endif
190 191 192 193 194 195 196 197 198 199 200
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
    Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */

    if (!size) {
	safesysfree(where);
	return NULL;
    }

    if (!where)
	return safesysmalloc(size);
201 202 203
#ifdef USE_MDH
    where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
    size += PERL_MEMORY_DEBUG_HEADER_SIZE;
204 205 206 207
    {
	struct perl_memory_debug_header *const header
	    = (struct perl_memory_debug_header *)where;

208
# ifdef PERL_TRACK_MEMPOOL
209
	if (header->interpreter != aTHX) {
210 211
	    Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
				 header->interpreter, aTHX);
212 213 214 215 216 217 218 219 220 221
	}
	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;
	    PoisonFree(start_of_freed, freed_up, char);
	}
#  endif
222 223 224 225
# endif
# ifdef MDH_HAS_SIZE
	header->size = size;
# endif
226 227
    }
#endif
228
#ifdef DEBUGGING
229 230
    if ((SSize_t)size < 0)
	Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
231
#endif
232 233 234 235 236 237 238 239 240 241 242 243
#ifdef PERL_DEBUG_READONLY_COW
    if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
		    MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
	perror("mmap failed");
	abort();
    }
    Copy(where,ptr,oldsize < size ? oldsize : size,char);
    if (munmap(where, oldsize)) {
	perror("munmap failed");
	abort();
    }
#else
244
    ptr = (Malloc_t)PerlMem_realloc(where,size);
245
#endif
246
    PERL_ALLOC_CHECK(ptr);
247

248 249 250 251
    /* MUST do this fixup first, before doing ANYTHING else, as anything else
       might allocate memory/free/move memory, and until we do the fixup, it
       may well be chasing (and writing to) free memory.  */
    if (ptr != NULL) {
252
#ifdef PERL_TRACK_MEMPOOL
253 254 255 256 257 258 259 260 261 262 263
	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;
	    PoisonNew(start_of_fresh, fresh, char);
	}
#  endif

264
	maybe_protect_rw(header->next);
265
	header->next->prev = header;
266 267
	maybe_protect_ro(header->next);
	maybe_protect_rw(header->prev);
268
	header->prev->next = header;
269
	maybe_protect_ro(header->prev);
270
#endif
271 272
        ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
    }
273 274 275 276 277 278 279 280 281

    /* In particular, must do that fixup above before logging anything via
     *printf(), as it can reallocate memory, which can cause SEGVs.  */

    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));


    if (ptr != NULL) {
282
	return ptr;
283
    }
284
    else {
285 286 287 288 289 290
#ifndef ALWAYS_NEED_THX
	dTHX;
#endif
	if (PL_nomemok)
	    return NULL;
	else {
291
	    croak_no_mem();
292
	}
293 294 295 296 297 298 299 300 301
    }
    /*NOTREACHED*/
}

/* safe version of system's free() */

Free_t
Perl_safesysfree(Malloc_t where)
{
302
#ifdef ALWAYS_NEED_THX
303
    dTHX;
304 305
#else
    dVAR;
306 307 308
#endif
    DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
    if (where) {
309 310
#ifdef USE_MDH
        where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
311 312 313 314
	{
	    struct perl_memory_debug_header *const header
		= (struct perl_memory_debug_header *)where;

315 316 317 318
# ifdef MDH_HAS_SIZE
	    const MEM_SIZE size = header->size;
# endif
# ifdef PERL_TRACK_MEMPOOL
319
	    if (header->interpreter != aTHX) {
320 321
		Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
				     header->interpreter, aTHX);
322 323 324 325
	    }
	    if (!header->prev) {
		Perl_croak_nocontext("panic: duplicate free");
	    }
326 327 328 329 330 331 332
	    if (!(header->next))
		Perl_croak_nocontext("panic: bad free, header->next==NULL");
	    if (header->next->prev != header || header->prev->next != header) {
		Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
				     "header=%p, ->prev->next=%p",
				     header->next->prev, header,
				     header->prev->next);
333 334
	    }
	    /* Unlink us from the chain.  */
335
	    maybe_protect_rw(header->next);
336
	    header->next->prev = header->prev;
337 338
	    maybe_protect_ro(header->next);
	    maybe_protect_rw(header->prev);
339
	    header->prev->next = header->next;
340 341
	    maybe_protect_ro(header->prev);
	    maybe_protect_rw(header);
342
#  ifdef PERL_POISON
343
	    PoisonNew(where, size, char);
344 345 346
#  endif
	    /* Trigger the duplicate free warning.  */
	    header->next = NULL;
347 348 349 350 351 352 353
# endif
# ifdef PERL_DEBUG_READONLY_COW
	    if (munmap(where, size)) {
		perror("munmap failed");
		abort();
	    }	
# endif
354 355
	}
#endif
356
#ifndef PERL_DEBUG_READONLY_COW
357
	PerlMem_free(where);
358
#endif
359 360 361 362 363 364 365 366
    }
}

/* safe version of system's calloc() */

Malloc_t
Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
{
367
#ifdef ALWAYS_NEED_THX
368
    dTHX;
369
#endif
370
    Malloc_t ptr;
371
#if defined(USE_MDH) || defined(DEBUGGING)
372
    MEM_SIZE total_size = 0;
373
#endif
374

375
    /* Even though calloc() for zero bytes is strange, be robust. */
376
    if (size && (count <= MEM_SIZE_MAX / size)) {
377
#if defined(USE_MDH) || defined(DEBUGGING)
378
	total_size = size * count;
379 380
#endif
    }
381
    else
382 383 384 385
	croak_memory_wrap();
#ifdef USE_MDH
    if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
	total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
386
    else
387
	croak_memory_wrap();
388
#endif
389
#ifdef DEBUGGING
390 391 392
    if ((SSize_t)size < 0 || (SSize_t)count < 0)
	Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
			     (UV)size, (UV)count);
393
#endif
394 395 396 397 398 399 400
#ifdef PERL_DEBUG_READONLY_COW
    if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
		    MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
	perror("mmap failed");
	abort();
    }
#elif defined(PERL_TRACK_MEMPOOL)
401 402 403 404 405 406 407 408 409 410 411 412
    /* Have to use malloc() because we've added some space for our tracking
       header.  */
    /* malloc(0) is non-portable. */
    ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
#else
    /* Use calloc() because it might save a memset() if the memory is fresh
       and clean from the OS.  */
    if (count && size)
	ptr = (Malloc_t)PerlMem_calloc(count, size);
    else /* calloc(0) is non-portable. */
	ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
#endif
413
    PERL_ALLOC_CHECK(ptr);
414 415
    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
    if (ptr != NULL) {
416
#ifdef USE_MDH
417 418 419 420
	{
	    struct perl_memory_debug_header *const header
		= (struct perl_memory_debug_header *)ptr;

421
#  ifndef PERL_DEBUG_READONLY_COW
422
	    memset((void*)ptr, 0, total_size);
423 424
#  endif
#  ifdef PERL_TRACK_MEMPOOL
425 426 427 428 429
	    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;
430
	    maybe_protect_rw(header->next);
431
	    header->next->prev = header;
432 433 434 435 436 437
	    maybe_protect_ro(header->next);
#    ifdef PERL_DEBUG_READONLY_COW
	    header->readonly = 0;
#    endif
#  endif
#  ifdef MDH_HAS_SIZE
438 439
	    header->size = total_size;
#  endif
440
	    ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
441 442
	}
#endif
443 444
	return ptr;
    }
445 446 447 448 449 450
    else {
#ifndef ALWAYS_NEED_THX
	dTHX;
#endif
	if (PL_nomemok)
	    return NULL;
451
	croak_no_mem();
452
    }
453 454
}

455 456
/* These must be defined when not using Perl's malloc for binary
 * compatibility */
457

458
#ifndef MYMALLOC
459

460
Malloc_t Perl_malloc (MEM_SIZE nbytes)
461
{
462 463
    dTHXs;
    return (Malloc_t)PerlMem_malloc(nbytes);
464 465
}

466
Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
467
{
468 469
    dTHXs;
    return (Malloc_t)PerlMem_calloc(elements, size);
470 471
}

472
Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
473
{
474 475
    dTHXs;
    return (Malloc_t)PerlMem_realloc(where, nbytes);
476 477
}

478 479 480 481
Free_t   Perl_mfree (Malloc_t where)
{
    dTHXs;
    PerlMem_free(where);
482 483
}

484
#endif
485 486 487 488

/* copy a string up to some (non-backslashed) delimiter, if any */

char *
489
Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
490
{
491
    I32 tolen;
492

493 494
    PERL_ARGS_ASSERT_DELIMCPY;

495 496
    for (tolen = 0; from < fromend; from++, tolen++) {
	if (*from == '\\') {
497
	    if (from[1] != delim) {
498 499 500 501
		if (to < toend)
		    *to++ = *from;
		tolen++;
	    }
502
	    from++;
503 504 505 506 507 508 509 510 511
	}
	else if (*from == delim)
	    break;
	if (to < toend)
	    *to++ = *from;
    }
    if (to < toend)
	*to = '\0';
    *retlen = tolen;
512
    return (char *)from;
513 514 515 516 517 518
}

/* return ptr to little string in big string, NULL if not found */
/* This routine was donated by Corey Satten. */

char *
519
Perl_instr(const char *big, const char *little)
520 521
{

522 523
    PERL_ARGS_ASSERT_INSTR;

524 525
    /* libc prior to 4.6.27 (late 1994) did not work properly on a NULL
     * 'little' */
526 527
    if (!little)
	return (char*)big;
528
    return strstr((char*)big, (char*)little);
529 530
}

531 532
/* same as instr but allow embedded nulls.  The end pointers point to 1 beyond
 * the final character desired to be checked */
533 534

char *
535
Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
536
{
537
    PERL_ARGS_ASSERT_NINSTR;
538 539 540
    if (little >= lend)
        return (char*)big;
    {
541
        const char first = *little;
542
        const char *s, *x;
543
        bigend -= lend - little++;
544 545 546 547 548 549 550 551 552 553
    OUTER:
        while (big <= bigend) {
            if (*big++ == first) {
                for (x=big,s=little; s < lend; x++,s++) {
                    if (*s != *x)
                        goto OUTER;
                }
                return (char*)(big-1);
            }
        }
554
    }
555
    return NULL;
556 557 558 559 560
}

/* reverse of the above--find last substring */

char *
561
Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
562
{
563 564 565
    const char *bigbeg;
    const I32 first = *little;
    const char * const littleend = lend;
566

567 568
    PERL_ARGS_ASSERT_RNINSTR;

569
    if (little >= littleend)
570 571 572 573
	return (char*)bigend;
    bigbeg = big;
    big = bigend - (littleend - little++);
    while (big >= bigbeg) {
574
	const char *s, *x;
575 576 577
	if (*big-- != first)
	    continue;
	for (x=big+2,s=little; s < littleend; /**/ ) {
578
	    if (*s != *x)
579
		break;
580 581 582
	    else {
		x++;
		s++;
583 584 585 586 587
	    }
	}
	if (s >= littleend)
	    return (char*)(big+1);
    }
588
    return NULL;
589 590 591 592 593 594 595 596 597
}

/* As a space optimization, we do not compile tables for strings of length
   0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
   special-cased in fbm_instr().

   If FBMcf_TAIL, the table is created as if the string has a trailing \n. */

/*
598 599
=head1 Miscellaneous Functions

600 601 602 603 604 605 606 607 608 609 610
=for apidoc fbm_compile

Analyses the string in order to make fast searches on it using fbm_instr()
-- the Boyer-Moore algorithm.

=cut
*/

void
Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
{
611
    dVAR;
612
    const U8 *s;
613
    STRLEN i;
614 615
    STRLEN len;
    U32 frequency = 256;
616
    MAGIC *mg;
617
    PERL_DEB( STRLEN rarest = 0 );
618

619 620
    PERL_ARGS_ASSERT_FBM_COMPILE;

621
    if (isGV_with_GP(sv) || SvROK(sv))
622 623 624 625 626
	return;

    if (SvVALID(sv))
	return;

627
    if (flags & FBMcf_TAIL) {
628
	MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
629
	sv_catpvs(sv, "\n");		/* Taken into account in fbm_instr() */
630 631 632
	if (mg && mg->mg_len >= 0)
	    mg->mg_len++;
    }
633 634 635
    if (!SvPOK(sv) || SvNIOKp(sv))
	s = (U8*)SvPV_force_mutable(sv, len);
    else s = (U8 *)SvPV_mutable(sv, len);
636
    if (len == 0)		/* TAIL might be on a zero-length string. */
637
	return;
638
    SvUPGRADE(sv, SVt_PVMG);
639 640 641
    SvIOK_off(sv);
    SvNOK_off(sv);
    SvVALID_on(sv);
642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660

    /* "deep magic", the comment used to add. The use of MAGIC itself isn't
       really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
       to call SvVALID_off() if the scalar was assigned to.

       The comment itself (and "deeper magic" below) date back to
       378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
       str->str_pok |= 2;
       where the magic (presumably) was that the scalar had a BM table hidden
       inside itself.

       As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
       the table instead of the previous (somewhat hacky) approach of co-opting
       the string buffer and storing it after the string.  */

    assert(!mg_find(sv, PERL_MAGIC_bm));
    mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
    assert(mg);

661
    if (len > 2) {
662 663
	/* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
	   the BM table.  */
664
	const U8 mlen = (len>255) ? 255 : (U8)len;
665
	const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
666
	U8 *table;
667

668
	Newx(table, 256, U8);
669
	memset((void*)table, mlen, 256);
670 671 672 673
	mg->mg_ptr = (char *)table;
	mg->mg_len = 256;

	s += len - 1; /* last char */
674 675 676 677 678 679 680 681
	i = 0;
	while (s >= sb) {
	    if (table[*s] == mlen)
		table[*s] = (U8)i;
	    s--, i++;
	}
    }

682
    s = (const unsigned char*)(SvPVX_const(sv));	/* deeper magic */
683 684
    for (i = 0; i < len; i++) {
	if (PL_freq[s[i]] < frequency) {
685
	    PERL_DEB( rarest = i );
686 687 688 689 690 691
	    frequency = PL_freq[s[i]];
	}
    }
    BmUSEFUL(sv) = 100;			/* Initial value */
    if (flags & FBMcf_TAIL)
	SvTAIL_on(sv);
692
    DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
693
			  s[rarest], (UV)rarest));
694 695 696 697 698 699 700 701 702
}

/* If SvTAIL(littlestr), it has a fake '\n' at end. */
/* If SvTAIL is actually due to \Z or \z, this gives false positives
   if multiline */

/*
=for apidoc fbm_instr

703 704
Returns the location of the SV in the string delimited by C<big> and
C<bigend>.  It returns C<NULL> if the string can't be found.  The C<sv>
705 706 707 708 709 710 711
does not have to be fbm_compiled, but the search will not be as fast
then.

=cut
*/

char *
712
Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
713
{
714
    unsigned char *s;
715
    STRLEN l;
716 717 718
    const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
    STRLEN littlelen = l;
    const I32 multiline = flags & FBMrf_MULTILINE;
719

720 721
    PERL_ARGS_ASSERT_FBM_INSTR;

722 723 724 725 726 727
    if ((STRLEN)(bigend - big) < littlelen) {
	if ( SvTAIL(littlestr)
	     && ((STRLEN)(bigend - big) == littlelen - 1)
	     && (littlelen == 1
		 || (*big == *little &&
		     memEQ((char *)big, (char *)little, littlelen - 1))))
728
	    return (char*)big;
729
	return NULL;
730 731
    }

732 733 734 735
    switch (littlelen) { /* Special cases for 0, 1 and 2  */
    case 0:
	return (char*)big;		/* Cannot be SvTAIL! */
    case 1:
736 737 738 739 740 741 742 743 744 745 746 747 748 749
	    if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
		/* Know that bigend != big.  */
		if (bigend[-1] == '\n')
		    return (char *)(bigend - 1);
		return (char *) bigend;
	    }
	    s = big;
	    while (s < bigend) {
		if (*s == *little)
		    return (char *)s;
		s++;
	    }
	    if (SvTAIL(littlestr))
		return (char *) bigend;
750
	    return NULL;
751
    case 2:
752 753 754 755 756
	if (SvTAIL(littlestr) && !multiline) {
	    if (bigend[-1] == '\n' && bigend[-2] == *little)
		return (char*)bigend - 2;
	    if (bigend[-1] == *little)
		return (char*)bigend - 1;
757
	    return NULL;
758 759 760 761 762
	}
	{
	    /* This should be better than FBM if c1 == c2, and almost
	       as good otherwise: maybe better since we do less indirection.
	       And we save a lot of memory by caching no table. */
763 764
	    const unsigned char c1 = little[0];
	    const unsigned char c2 = little[1];
765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809

	    s = big + 1;
	    bigend--;
	    if (c1 != c2) {
		while (s <= bigend) {
		    if (s[0] == c2) {
			if (s[-1] == c1)
			    return (char*)s - 1;
			s += 2;
			continue;
		    }
		  next_chars:
		    if (s[0] == c1) {
			if (s == bigend)
			    goto check_1char_anchor;
			if (s[1] == c2)
			    return (char*)s;
			else {
			    s++;
			    goto next_chars;
			}
		    }
		    else
			s += 2;
		}
		goto check_1char_anchor;
	    }
	    /* Now c1 == c2 */
	    while (s <= bigend) {
		if (s[0] == c1) {
		    if (s[-1] == c1)
			return (char*)s - 1;
		    if (s == bigend)
			goto check_1char_anchor;
		    if (s[1] == c1)
			return (char*)s;
		    s += 3;
		}
		else
		    s += 2;
	    }
	}
      check_1char_anchor:		/* One char and anchor! */
	if (SvTAIL(littlestr) && (*bigend == *little))
	    return (char *)bigend;	/* bigend is already decremented. */
810
	return NULL;
811 812
    default:
	break; /* Only lengths 0 1 and 2 have special-case code.  */
813
    }
814

815 816
    if (SvTAIL(littlestr) && !multiline) {	/* tail anchored? */
	s = bigend - littlelen;
817
	if (s >= big && bigend[-1] == '\n' && *s == *little
818 819 820 821 822 823 824 825 826 827
	    /* 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))
	{
	    return (char*)s + 1;	/* how sweet it is */
	}
828
	return NULL;
829
    }
830 831
    if (!SvVALID(littlestr)) {
	char * const b = ninstr((char*)big,(char*)bigend,
832 833 834 835 836 837 838 839 840 841
			 (char*)little, (char*)little + littlelen);

	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))
	    {
		return (char*)s;
	    }
842
	    return NULL;
843 844 845
	}
	return b;
    }
846

847 848 849 850 851
    /* Do actual FBM.  */
    if (littlelen > (STRLEN)(bigend - big))
	return NULL;

    {
852 853
	const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
	const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
854
	const unsigned char *oldlittle;
855 856 857 858 859 860 861

	--littlelen;			/* Last char found by table lookup */

	s = big + littlelen;
	little += littlelen;		/* last char */
	oldlittle = little;
	if (s < bigend) {
862
	    I32 tmp;
863 864 865 866 867 868 869 870

	  top2:
	    if ((tmp = table[*s])) {
		if ((s += tmp) < bigend)
		    goto top2;
		goto check_end;
	    }
	    else {		/* less expensive than calling strncmp() */
871
		unsigned char * const olds = s;
872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887

		tmp = littlelen;

		while (tmp--) {
		    if (*--s == *--little)
			continue;
		    s = olds + 1;	/* here we pay the price for failure */
		    little = oldlittle;
		    if (s < bigend)	/* fake up continue to outer loop */
			goto top2;
		    goto check_end;
		}
		return (char *)s;
	    }
	}
      check_end:
888
	if ( s == bigend
889
	     && SvTAIL(littlestr)
890 891
	     && memEQ((char *)(bigend - littlelen),
		      (char *)(oldlittle - littlelen), littlelen) )
892
	    return (char*)bigend - littlelen;
893
	return NULL;
894 895 896 897 898 899
    }
}

char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
900
    dVAR;
901
    PERL_ARGS_ASSERT_SCREAMINSTR;
902 903 904 905 906 907 908 909 910 911
    PERL_UNUSED_ARG(bigstr);
    PERL_UNUSED_ARG(littlestr);
    PERL_UNUSED_ARG(start_shift);
    PERL_UNUSED_ARG(end_shift);
    PERL_UNUSED_ARG(old_posp);
    PERL_UNUSED_ARG(last);

    /* This function must only ever be called on a scalar with study magic,
       but those do not happen any more. */
    Perl_croak(aTHX_ "panic: screaminstr");
912
    return NULL;
913 914
}

915 916 917 918 919 920 921 922 923 924 925 926
/*
=for apidoc foldEQ

Returns true if the leading len bytes of the strings s1 and s2 are the same
case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
match themselves and their opposite case counterparts.  Non-cased and non-ASCII
range bytes match only themselves.

=cut
*/


927
I32
928
Perl_foldEQ(const char *s1, const char *s2, I32 len)
929
{
930 931
    const U8 *a = (const U8 *)s1;
    const U8 *b = (const U8 *)s2;
932

933
    PERL_ARGS_ASSERT_FOLDEQ;
934

935 936
    assert(len >= 0);

937 938
    while (len--) {
	if (*a != *b && *a != PL_fold[*b])
939
	    return 0;
940 941
	a++,b++;
    }
942
    return 1;
943
}
944
I32
945
Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
946 947 948 949 950 951
{
    /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
     * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
     * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
     * does it check that the strings each have at least 'len' characters */

952 953
    const U8 *a = (const U8 *)s1;
    const U8 *b = (const U8 *)s2;
954 955 956

    PERL_ARGS_ASSERT_FOLDEQ_LATIN1;

957 958
    assert(len >= 0);

959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975
    while (len--) {
	if (*a != *b && *a != PL_fold_latin1[*b]) {
	    return 0;
	}
	a++, b++;
    }
    return 1;
}

/*
=for apidoc foldEQ_locale

Returns true if the leading len bytes of the strings s1 and s2 are the same
case-insensitively in the current locale; false otherwise.

=cut
*/
976 977

I32
978
Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
979
{
980
    dVAR;
981 982
    const U8 *a = (const U8 *)s1;
    const U8 *b = (const U8 *)s2;
983

984
    PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
985

986 987
    assert(len >= 0);

988 989
    while (len--) {
	if (*a != *b && *a != PL_fold_locale[*b])
990
	    return 0;
991 992
	a++,b++;
    }
993
    return 1;
994 995 996 997 998
}

/* copy a string to a safe spot */

/*
999 1000
=head1 Memory Management

1001 1002
=for apidoc savepv

1003 1004
Perl's version of C<strdup()>.  Returns a pointer to a newly allocated
string which is a duplicate of C<pv>.  The size of the string is
1005 1006 1007
determined by C<strlen()>, which means it may not contain embedded C<NUL>
characters and must have a trailing C<NUL>.  The memory allocated for the new
string can be freed with the C<Safefree()> function.
1008

1009 1010 1011 1012
On some platforms, Windows for example, all allocated memory owned by a thread
is deallocated when that thread ends.  So if you need that not to happen, you
need to use the shared memory functions, such as C<L</savesharedpv>>.

1013 1014 1015 1016
=cut
*/

char *
1017
Perl_savepv(pTHX_ const char *pv)
1018
{
1019
    PERL_UNUSED_CONTEXT;
1020
    if (!pv)
1021
	return NULL;
1022 1023 1024
    else {
	char *newaddr;
	const STRLEN pvlen = strlen(pv)+1;
1025 1026
	Newx(newaddr, pvlen, char);
	return (char*)memcpy(newaddr, pv, pvlen);
1027
    }
1028 1029 1030 1031 1032 1033 1034
}

/* same thing but with a known length */

/*
=for apidoc savepvn

1035
Perl's version of what C<strndup()> would be if it existed.  Returns a
1036
pointer to a newly allocated string which is a duplicate of the first
1037
C<len> bytes from C<pv>, plus a trailing
1038
C<NUL> byte.  The memory allocated for
1039
the new string can be freed with the C<Safefree()> function.
1040

1041 1042 1043 1044
On some platforms, Windows for example, all allocated memory owned by a thread
is deallocated when that thread ends.  So if you need that not to happen, you
need to use the shared memory functions, such as C<L</savesharedpvn>>.

1045 1046 1047 1048
=cut
*/

char *
1049
Perl_savepvn(pTHX_ const char *pv, I32 len)
1050
{
1051
    char *newaddr;
1052
    PERL_UNUSED_CONTEXT;
1053

1054 1055
    assert(len >= 0);

1056
    Newx(newaddr,len+1,char);
1057 1058
    /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
    if (pv) {
1059 1060
	/* might not be null terminated */
    	newaddr[len] = '\0';
1061
    	return (char *) CopyD(pv,newaddr,len,char);
1062 1063
    }
    else {
1064
	return (char *) ZeroD(newaddr,len+1,char);
1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078
    }
}

/*
=for apidoc savesharedpv

A version of C<savepv()> which allocates the duplicate string in memory
which is shared between threads.

=cut
*/
char *
Perl_savesharedpv(pTHX_ const char *pv)
{
1079
    char *newaddr;
1080
    STRLEN pvlen;
1081
    if (!pv)
1082
	return NULL;
1083

1084 1085
    pvlen = strlen(pv)+1;
    newaddr = (char*)PerlMemShared_malloc(pvlen);
1086
    if (!newaddr) {
1087
	croak_no_mem();
1088 1089 1090 1091 1092 1093 1094 1095
    }
    return (char*)memcpy(newaddr, pv, pvlen);
}

/*
=for apidoc savesharedpvn

A version of C<savepvn()> which allocates the duplicate string in memory
1096
which is shared between threads.  (With the specific difference that a NULL
1097 1098 1099 1100 1101 1102 1103 1104
pointer is not acceptable)

=cut
*/
char *
Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
{
    char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1105

1106
    /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1107

1108
    if (!newaddr) {
1109
	croak_no_mem();
1110
    }
1111 1112
    newaddr[len] = '\0';
    return (char*)memcpy(newaddr, pv, len);
1113 1114
}

1115 1116 1117 1118 1119 1120
/*
=for apidoc savesvpv

A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
the passed in SV using C<SvPV()>

1121 1122 1123 1124
On some platforms, Windows for example, all allocated memory owned by a thread
is deallocated when that thread ends.  So if you need that not to happen, you
need to use the shared memory functions, such as C<L</savesharedsvpv>>.

1125 1126 1127 1128 1129 1130 1131
=cut
*/

char *
Perl_savesvpv(pTHX_ SV *sv)
{
    STRLEN len;
1132
    const char * const pv = SvPV_const(sv, len);
1133
    char *newaddr;
1134

1135 1136
    PERL_ARGS_ASSERT_SAVESVPV;

1137
    ++len;
1138 1139
    Newx(newaddr,len,char);
    return (char *) CopyD(pv,newaddr,len,char);
1140
}
1141

1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160
/*
=for apidoc savesharedsvpv

A version of C<savesharedpv()> which allocates the duplicate string in
memory which is shared between threads.

=cut
*/

char *
Perl_savesharedsvpv(pTHX_ SV *sv)
{
    STRLEN len;
    const char * const pv = SvPV_const(sv, len);

    PERL_ARGS_ASSERT_SAVESHAREDSVPV;

    return savesharedpvn(pv, len);
}
1161

1162 1163 1164 1165 1166
/* the SV for Perl_form() and mess() is not kept in an arena */

STATIC SV *
S_mess_alloc(pTHX)
{
1167
    dVAR;
1168 1169 1170
    SV *sv;
    XPVMG *any;

1171
    if (PL_phase != PERL_PHASE_DESTRUCT)
1172
	return newSVpvs_flags("", SVs_TEMP);
1173 1174 1175 1176 1177

    if (PL_mess_sv)
	return PL_mess_sv;

    /* Create as PVMG now, to avoid any upgrading later */
1178 1179
    Newx(sv, 1, SV);
    Newxz(any, 1, XPVMG);
1180 1181
    SvFLAGS(sv) = SVt_PVMG;
    SvANY(sv) = (void*)any;
1182
    SvPV_set(sv, NULL);
1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194
    SvREFCNT(sv) = 1 << 30; /* practically infinite */
    PL_mess_sv = sv;
    return sv;
}

#if defined(PERL_IMPLICIT_CONTEXT)
char *
Perl_form_nocontext(const char* pat, ...)
{
    dTHX;
    char *retval;
    va_list args;
1195
    PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1196 1197 1198 1199 1200 1201 1202
    va_start(args, pat);
    retval = vform(pat, &args);
    va_end(args);
    return retval;
}
#endif /* PERL_IMPLICIT_CONTEXT */

1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222
/*
=head1 Miscellaneous Functions
=for apidoc form

Takes a sprintf-style format pattern and conventional
(non-SV) arguments and returns the formatted string.

    (char *) Perl_form(pTHX_ const char* pat, ...)

can be used any place a string (char *) is required:

    char * s = Perl_form("%d.%d",major,minor);

Uses a single private buffer so if you want to format several strings you
must explicitly copy the earlier strings away (and free the copies when you
are done).

=cut
*/

1223 1224 1225 1226 1227
char *
Perl_form(pTHX_ const char* pat, ...)
{
    char *retval;
    va_list args;
1228
    PERL_ARGS_ASSERT_FORM;
1229 1230 1231 1232 1233 1234 1235 1236 1237
    va_start(args, pat);
    retval = vform(pat, &args);
    va_end(args);
    return retval;
}

char *
Perl_vform(pTHX_ const char *pat, va_list *args)
{
1238
    SV * const sv = mess_alloc();
1239
    PERL_ARGS_ASSERT_VFORM;
1240
    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1241 1242 1243
    return SvPVX(sv);
}

1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258
/*
=for apidoc Am|SV *|mess|const char *pat|...

Take a sprintf-style format pattern and argument list.  These are used to
generate a string message.  If the message does not end with a newline,
then it will be extended with some indication of the current location
in the code, as described for L</mess_sv>.

Normally, the resulting message is returned in a new mortal SV.
During global destruction a single SV may be shared between uses of
this function.

=cut
*/

1259 1260 1261 1262 1263 1264 1265
#if defined(PERL_IMPLICIT_CONTEXT)
SV *
Perl_mess_nocontext(const char *pat, ...)
{
    dTHX;
    SV *retval;
    va_list args;
1266
    PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278
    va_start(args, pat);
    retval = vmess(pat, &args);
    va_end(args);
    return retval;
}
#endif /* PERL_IMPLICIT_CONTEXT */

SV *
Perl_mess(pTHX_ const char *pat, ...)
{
    SV *retval;
    va_list args;
1279
    PERL_ARGS_ASSERT_MESS;
1280 1281 1282 1283 1284 1285
    va_start(args, pat);
    retval = vmess(pat, &args);
    va_end(args);
    return retval;
}

1286 1287 1288
const COP*
Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
		       bool opnext)
1289
{
1290
    dVAR;
1291 1292 1293
    /* Look for curop starting from o.  cop is the last COP we've seen. */
    /* opnext means that curop is actually the ->op_next of the op we are
       seeking. */
1294

1295 1296
    PERL_ARGS_ASSERT_CLOSEST_COP;

1297 1298 1299
    if (!o || !curop || (
	opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
    ))
1300
	return cop;
1301 1302

    if (o->op_flags & OPf_KIDS) {
1303 1304 1305
	const OP *kid;
	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
	    const COP *new_cop;
1306 1307 1308 1309 1310

	    /* 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)
1311
		cop = (const COP *)kid;
1312 1313 1314

	    /* Keep searching, and return when we've found something. */

1315
	    new_cop = closest_cop(cop, kid, curop, opnext);
1316 1317
	    if (new_cop)
		return new_cop;
1318 1319 1320 1321 1322
	}
    }

    /* Nothing found. */

1323
    return NULL;
1324 1325
}

1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349
/*
=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume

Expands a message, intended for the user, to include an indication of
the current location in the code, if the message does not already appear
to be complete.

C<basemsg> is the initial message or object.  If it is a reference, it
will be used as-is and will be the result of this function.  Otherwise it
is used as a string, and if it already ends with a newline, it is taken
to be complete, and the result of this function will be the same string.
If the message does not end with a newline, then a segment such as C<at
foo.pl line 37> will be appended, and possibly other clauses indicating
the current state of execution.  The resulting message will end with a
dot and a newline.

Normally, the resulting message is returned in a new mortal SV.
During global destruction a single SV may be shared between uses of this
function.  If C<consume> is true, then the function is permitted (but not
required) to modify and return C<basemsg> instead of allocating a new SV.

=cut
*/

1350
SV *
1351
Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1352
{
1353
    dVAR;
1354
    SV *sv;
1355

1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375
    PERL_ARGS_ASSERT_MESS_SV;

    if (SvROK(basemsg)) {
	if (consume) {
	    sv = basemsg;
	}
	else {
	    sv = mess_alloc();
	    sv_setsv(sv, basemsg);
	}
	return sv;
    }

    if (SvPOK(basemsg) && consume) {
	sv = basemsg;
    }
    else {
	sv = mess_alloc();
	sv_copypv(sv, basemsg);
    }
1376

1377
    if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1378 1379 1380 1381 1382 1383 1384
	/*
	 * 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
	 * can try to find such a cop by searching through the optree starting
	 * from the sibling of PL_curcop.
	 */

1385 1386
	const COP *cop =
	    closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE);
1387 1388
	if (!cop)
	    cop = PL_curcop;
1389 1390

	if (CopLINE(cop))
1391
	    Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1392
	    OutCopFILE(cop), (IV)CopLINE(cop));
1393 1394 1395 1396
	/* Seems that GvIO() can be untrustworthy during global destruction. */
	if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
		&& IoLINES(GvIOp(PL_last_in_gv)))
	{
1397
	    STRLEN l;
1398
	    const bool line_mode = (RsSIMPLE(PL_rs) &&
1399
				   *SvPV_const(PL_rs,l) == '\n' && l == 1);
1400 1401 1402 1403
	    Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
			   SVfARG(PL_last_in_gv == PL_argvgv
                                 ? &PL_sv_no
                                 : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1404 1405
			   line_mode ? "line" : "chunk",
			   (IV)IoLINES(GvIOp(PL_last_in_gv)));
1406
	}
1407
	if (PL_phase == PERL_PHASE_DESTRUCT)
1408 1409
	    sv_catpvs(sv, " during global destruction");
	sv_catpvs(sv, ".\n");
1410 1411 1412 1413
    }
    return sv;
}

1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441
/*
=for apidoc Am|SV *|vmess|const char *pat|va_list *args

C<pat> and C<args> are a sprintf-style format pattern and encapsulated
argument list.  These are used to generate a string message.  If the
message does not end with a newline, then it will be extended with
some indication of the current location in the code, as described for
L</mess_sv>.

Normally, the resulting message is returned in a new mortal SV.
During global destruction a single SV may be shared between uses of
this function.

=cut
*/

SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
    dVAR;
    SV * const sv = mess_alloc();

    PERL_ARGS_ASSERT_VMESS;

    sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
    return mess_sv(sv, 1);
}

1442
void
1443
Perl_write_to_stderr(pTHX_ SV* msv)
1444
{
1445
    dVAR;
1446 1447 1448
    IO *io;
    MAGIC *mg;

1449 1450
    PERL_ARGS_ASSERT_WRITE_TO_STDERR;

1451 1452
    if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
	&& (io = GvIO(PL_stderrgv))
1453
	&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
1454
	Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1455
			    G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1456
    else {
1457
	PerlIO * const serr = Perl_error_log;
1458

Niko Tyni's avatar