SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
- sv->sv_debug_line = (U16) (PL_parser
- ? PL_parser->copline == NOLINE
- ? PL_curcop
+ sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
+ ? PL_parser->copline
+ : PL_curcop
? CopLINE(PL_curcop)
: 0
- : PL_parser->copline
- : 0);
+ );
sv->sv_debug_inpad = 0;
sv->sv_debug_cloned = 0;
sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
do_clean_all(pTHX_ SV *const sv)
{
dVAR;
+ if (sv == (SV*) PL_fdpid || sv == (SV *)PL_strtab) {
+ /* don't clean pid table and strtab */
+ return;
+ }
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
SvREFCNT_dec(sv);
s = SvPVX_mutable(sv);
if (newlen > SvLEN(sv)) { /* need more room? */
-#ifndef MYMALLOC
+#ifndef Perl_safesysmalloc_size
newlen = PERL_STRLEN_ROUNDUP(newlen);
#endif
if (SvLEN(sv) && s) {
{
/* need to nuke the magic */
mg_free(dstr);
- SvRMAGICAL_off(dstr);
}
/* There's a lot of redundancy below but we're going for speed here */
GvMULTI_on(dstr);
return;
}
- glob_assign_glob(dstr, sstr, dtype);
- return;
+ if (isGV_with_GP(sstr)) {
+ glob_assign_glob(dstr, sstr, dtype);
+ return;
+ }
}
if (dtype >= SVt_PV) {
=for apidoc sv_insert
Inserts a string at the specified offset/length within the SV. Similar to
-the Perl substr() function.
+the Perl substr() function. Handles get magic.
+
+=for apidoc sv_insert_flags
+
+Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
=cut
*/
void
-Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len,
- const char *const little, const STRLEN littlelen)
+Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
{
dVAR;
register char *big;
register I32 i;
STRLEN curlen;
- PERL_ARGS_ASSERT_SV_INSERT;
+ PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
if (!bigstr)
Perl_croak(aTHX_ "Can't modify non-existent substring");
- SvPV_force(bigstr, curlen);
+ SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
if (offset + len > curlen) {
SvGROW(bigstr, offset+len+1);
boffset = real_boffset;
}
- S_utf8_mg_pos_cache_update(aTHX_ sv, mgp, boffset, uoffset, send - start);
+ if (PL_utf8cache)
+ utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
return boffset;
}
}
*offsetp = len;
- S_utf8_mg_pos_cache_update(aTHX_ sv, &mg, byte, len, blen);
+ if (PL_utf8cache)
+ utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
}
/*
I32 bytesread;
char *buffer;
U32 recsize;
+#ifdef VMS
+ int fd;
+#endif
/* Grab the size of the record we're getting */
recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
/* doing, but we've got no other real choice - except avoid stdio
as implementation - perhaps write a :vms layer ?
*/
- bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
+ fd = PerlIO_fileno(fp);
+ if (fd == -1) { /* in-memory file from PerlIO::Scalar */
+ bytesread = PerlIO_read(fp, buffer, recsize);
+ }
+ else {
+ bytesread = PerlLIO_read(fd, buffer, recsize);
+ }
#else
bytesread = PerlIO_read(fp, buffer, recsize);
#endif
goto fix_gv;
default:
- SvGETMAGIC(sv);
if (SvROK(sv)) {
SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
+ SvGETMAGIC(sv);
tryAMAGICunDEREF(to_cv);
sv = SvRV(sv);
else
Perl_croak(aTHX_ "Not a subroutine reference");
}
- else if (isGV(sv))
+ else if (isGV(sv)) {
+ SvGETMAGIC(sv);
gv = (GV*)sv;
+ }
else
- gv = gv_fetchsv(sv, lref, SVt_PVCV);
+ gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
*gvp = gv;
if (!gv) {
*st = NULL;
LEAVE;
if (!GvCVu(gv))
Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
- SVfARG(sv));
+ SVfARG(SvOK(sv) ? sv : &PL_sv_no));
}
return GvCVu(gv);
}
/* duplicate a file handle */
PerlIO *
-Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
+Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
{
PerlIO *ret;
/* duplicate a chain of magic */
MAGIC *
-Perl_mg_dup(pTHX_ MAGIC *const mg, CLONE_PARAMS *const param)
+Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
{
MAGIC *mgprev = (MAGIC*)NULL;
MAGIC *mgret;
/* map an existing pointer using a table */
STATIC PTR_TBL_ENT_t *
-S_ptr_table_find(PTR_TBL_t *tbl, const void *sv)
+S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
{
PTR_TBL_ENT_t *tblent;
const UV hash = PTR_TABLE_HASH(sv);
}
void *
-Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
+Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
{
PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
/* add a new entry to a pointer-mapping table */
void
-Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
+Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
{
PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
/* double the hash bucket size of an existing ptr table */
void
-Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
+Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
{
PTR_TBL_ENT_t **ary = tbl->tbl_ary;
const UV oldsize = tbl->tbl_max + 1;
/* remove all the entries from a ptr table */
void
-Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
+Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
{
if (tbl && tbl->tbl_items) {
register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
/* clear and free a ptr table */
void
-Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
+Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
{
if (!tbl) {
return;
#if defined(USE_ITHREADS)
void
-Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
+Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
{
PERL_ARGS_ASSERT_RVPV_DUP;
/* duplicate an SV of any type (including AV, HV etc) */
SV *
-Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
+Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
{
dVAR;
SV *dstr;
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
}
- else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
- Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within "));
+ else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
+ /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
+ Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
+ }
return name;
}