# include <sys/resource.h>
#endif
-#ifdef NETWARE
-NETDB_DEFINE_CONTEXT
-#endif
-
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
methname = "TIEHASH";
if (HvLAZYDEL(varsv) && (entry = HvEITER_get((HV *)varsv))) {
HvLAZYDEL_off(varsv);
- hv_free_ent((HV *)varsv, entry);
+ hv_free_ent(NULL, entry);
}
HvEITER_set(MUTABLE_HV(varsv), 0);
HvRITER_set(MUTABLE_HV(varsv), -1);
stash = gv_stashsv(*MARK, 0);
if (!stash) {
if (SvROK(*MARK))
- DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
+ DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX
+ " via package %" SVf_QUOTEDPREFIX,
methname, SVfARG(*MARK));
else if (isGV(*MARK)) {
/* If the glob doesn't name an existing package, using
* SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
* generate the name for the error message explicitly. */
- SV *stashname = sv_2mortal(newSV(0));
+ SV *stashname = sv_newmortal();
gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
- DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
+ DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX
+ " via package %" SVf_QUOTEDPREFIX,
methname, SVfARG(stashname));
}
else {
SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
: SvCUR(*MARK) ? *MARK
- : sv_2mortal(newSVpvs("main"));
- DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
- " (perhaps you forgot to load \"%" SVf "\"?)",
+ : newSVpvs_flags("main", SVs_TEMP);
+ DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX
+ " via package %" SVf_QUOTEDPREFIX
+ " (perhaps you forgot to load %" SVf_QUOTEDPREFIX "?)",
methname, SVfARG(stashname), SVfARG(stashname));
}
}
* been deleted from the symbol table, which this one can't
* be, since we just looked it up by name.
*/
- DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"",
+ DIE(aTHX_ "Can't locate object method %" PVf_QUOTEDPREFIX
+ " via package %" HEKf_QUOTEDPREFIX ,
methname, HvENAME_HEK_NN(stash));
}
ENTER_with_name("call_TIE");
}
}
sv_unmagic(sv, how) ;
+
+ if (SvTYPE(sv) == SVt_PVHV) {
+ /* If the tied hash was partway through iteration, free the iterator and
+ * any key that it is pointing to. */
+ HE *entry;
+ if (HvLAZYDEL(sv) && (entry = HvEITER_get((HV *)sv))) {
+ HvLAZYDEL_off(sv);
+ hv_free_ent(NULL, entry);
+ HvEITER_set(MUTABLE_HV(sv), 0);
+ }
+ }
+
RETPUSHYES;
}
Perl_croak_no_modify();
}
else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
- if (!SvPOK(sv)) {
+ if (SvPOK(sv)) {
+ if (SvUTF8(sv)) sv_utf8_downgrade(sv, FALSE);
+ }
+ else {
if (!SvPOKp(sv))
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Non-string passed as bitmask");
count of the passed in typeglob is increased by one, and the reference count
of the typeglob that C<PL_defoutgv> points to is decreased by one.
+=for apidoc AmnU||PL_defoutgv
+
+See C<L</setdefout>>.
+
=cut
*/
if (PL_op->op_flags & OPf_SPECIAL
? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
- : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
+ : cBOOL(tmpgv = MAYBE_DEREF_GV(sv)) )
+ {
io = GvIO(tmpgv);
if (!io)
result = 0;
goto nuts;
switch (optype) {
case OP_GSOCKOPT:
- SvGROW(sv, 257);
+ /* Note: there used to be an explicit SvGROW(sv,257) here, but
+ * this is redundant given the sv initialization ternary above */
(void)SvPOK_only(sv);
SvCUR_set(sv,256);
*SvEND(sv) ='\0';
const char *buf;
int aint;
SvGETMAGIC(sv);
- if (SvPOKp(sv)) {
+ if (SvPOK(sv) && !SvIsBOOL(sv)) { /* sv is originally a string */
STRLEN l;
buf = SvPVbyte_nomg(sv, l);
len = l;
SV* sv;
if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
- : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
+ : cBOOL((sv=POPs, gv = MAYBE_DEREF_GV(sv))))
+ {
if (PL_op->op_type == OP_LSTAT) {
if (gv != PL_defgv) {
do_fstat_warning_check:
"lstat() on filehandle%s%" SVf,
gv ? " " : "",
SVfARG(gv
- ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
+ ? newSVhek_mortal(GvENAME_HEK(gv))
: &PL_sv_no));
} else if (PL_laststype != OP_LSTAT)
/* diag_listed_as: The stat preceding %s wasn't an lstat */
if (max) {
EXTEND(SP, max);
EXTEND_MORTAL(max);
+#if ST_DEV_SIZE < IVSIZE || (ST_DEV_SIZE == IVSIZE && ST_DEV_SIGN < 0)
mPUSHi(PL_statcache.st_dev);
+#elif ST_DEV_SIZE == IVSIZE
+ mPUSHu(PL_statcache.st_dev);
+#else
+# if ST_DEV_SIGN < 0
+ if (LIKELY((IV)PL_statcache.st_dev == PL_statcache.st_dev)) {
+ mPUSHi((IV)PL_statcache.st_dev);
+ }
+# else
+ if (LIKELY((UV)PL_statcache.st_dev == PL_statcache.st_dev)) {
+ mPUSHu((UV)PL_statcache.st_dev);
+ }
+# endif
+ else {
+ char buf[sizeof(PL_statcache.st_dev)*3+1];
+ /* sv_catpvf() casts 'j' size values down to IV, so it
+ isn't suitable for use here.
+ */
+# if defined(I_INTTYPES) && defined(HAS_SNPRINTF)
+# if ST_DEV_SIGN < 0
+ int size = snprintf(buf, sizeof(buf), "%" PRIdMAX, (intmax_t)PL_statcache.st_dev);
+# else
+ int size = snprintf(buf, sizeof(buf), "%" PRIuMAX, (uintmax_t)PL_statcache.st_dev);
+# endif
+ STATIC_ASSERT_STMT(sizeof(intmax_t) >= sizeof(PL_statcache.st_dev));
+ mPUSHp(buf, size);
+# else
+# error extraordinarily large st_dev but no inttypes.h or no snprintf
+# endif
+ }
+#endif
{
/*
* We try to represent st_ino as a native IV or UV where
sigset_t oldmask, newmask;
#endif
+
EXTEND(SP, 1);
PERL_FLUSHALL_FOR_CHILD;
#ifdef HAS_SIGPROCMASK
#ifdef PERL_USES_PL_PIDSTATUS
hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
#endif
+ PERL_SRAND_OVERRIDE_NEXT_CHILD();
+ } else {
+ PERL_SRAND_OVERRIDE_NEXT_PARENT();
}
PUSHi(childpid);
RETURN;
childpid = PerlProc_fork();
if (childpid == -1)
RETPUSHUNDEF;
+ else if (childpid) {
+ /* we are in the parent */
+ PERL_SRAND_OVERRIDE_NEXT_PARENT();
+ }
+ else {
+ /* This is part of the logic supporting the env var
+ * PERL_RAND_SEED which causes use of rand() without an
+ * explicit srand() to use a deterministic seed. This logic is
+ * intended to give most forked children of a process a
+ * deterministic but different srand seed.
+ */
+ PERL_SRAND_OVERRIDE_NEXT_CHILD();
+ }
PUSHi(childpid);
RETURN;
#else
sv_2mortal(copysv);
if (SvPOK(origsv) || SvPOKp(origsv)) {
pv = SvPV_nomg(origsv, len);
- sv_setpvn(copysv, pv, len);
+ sv_setpvn_fresh(copysv, pv, len);
SvPOK_off(copysv);
}
if (SvIOK(origsv) || SvIOKp(origsv))
PUSHs(sv = sv_newmortal());
if (hent) {
if (which == OP_GHBYNAME) {
- if (hent->h_addr)
- sv_setpvn(sv, hent->h_addr, hent->h_length);
+ if (hent->h_addr) {
+ sv_upgrade(sv, SVt_PV);
+ sv_setpvn_fresh(sv, hent->h_addr, hent->h_length);
+ }
}
else
sv_setpv(sv, (char*)hent->h_name);
# endif
# ifdef PWGECOS
- PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
+ PUSHs(sv = newSVpvn_flags(pwent->pw_gecos,
+ pwent->pw_gecos == NULL ? 0 : strlen(pwent->pw_gecos),
+ SVs_TEMP));
# else
PUSHs(sv = sv_mortalcopy(&PL_sv_no));
# endif
mPUSHs(newSVpv(pwent->pw_dir, 0));
- PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
+ PUSHs(sv = newSVpvn_flags(pwent->pw_shell,
+ pwent->pw_shell == NULL ? 0 : strlen(pwent->pw_shell),
+ SVs_TEMP));
/* pw_shell is tainted because user himself can diddle with it. */
SvTAINTED_on(sv);
https://perl5.git.perl.org / perl5.git / blobdiff