/* mg.c
*
- * Copyright (c) 1991-2003, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
if (SvTYPE(sv) == SVTYPEMASK) {
Perl_croak(aTHX_ "Tied variable freed while still in use");
}
+ /* guard against magic having been deleted - eg FETCH calling
+ * untie */
+ if (!SvMAGIC(sv))
+ break;
/* Don't restore the flags for this entry if it was deleted. */
if (mg->mg_flags & MGf_GSKIP)
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
register I32 paren;
- register char *s;
+ register char *s = NULL;
register I32 i;
register REGEXP *rx;
}
break;
case '^':
- s = IoTOP_NAME(GvIOp(PL_defoutgv));
+ if (GvIOp(PL_defoutgv))
+ s = IoTOP_NAME(GvIOp(PL_defoutgv));
if (s)
sv_setpv(sv,s);
else {
}
break;
case '~':
- s = IoFMT_NAME(GvIOp(PL_defoutgv));
+ if (GvIOp(PL_defoutgv))
+ s = IoFMT_NAME(GvIOp(PL_defoutgv));
if (!s)
s = GvENAME(PL_defoutgv);
sv_setpv(sv,s);
break;
#ifndef lint
case '=':
- sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
+ if (GvIOp(PL_defoutgv))
+ sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
break;
case '-':
- sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
+ if (GvIOp(PL_defoutgv))
+ sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
break;
case '%':
- sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
+ if (GvIOp(PL_defoutgv))
+ sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
break;
#endif
case ':':
WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
break;
case '|':
- sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
+ if (GvIOp(PL_defoutgv))
+ sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
break;
case ',':
break;
#endif
(void)SvIOK_on(sv); /* what a wonderful hack! */
break;
- case '*':
- break;
#ifndef MACOS_TRADITIONAL
case '0':
break;
int
Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
{
+#ifndef PERL_MICRO
#if defined(VMS) || defined(EPOC)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
#else
}
# endif /* USE_ENVIRON_ARRAY */
# endif /* PERL_IMPLICIT_SYS || WIN32 */
-#endif /* VMS || EPC */
+#endif /* VMS || EPOC */
+#endif /* !PERL_MICRO */
return 0;
}
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
sig_defaulting[i] = 1;
- (void)rsignal(i, &Perl_csighandler);
+ (void)rsignal(i, PL_csighandlerp);
#else
(void)rsignal(i, SIG_DFL);
#endif
dTHX;
#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
- (void) rsignal(sig, &Perl_csighandler);
+ (void) rsignal(sig, PL_csighandlerp);
if (sig_ignoring[sig]) return;
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
dTHX;
sig_defaulting[sig] = 1;
- (void) rsignal(sig, &Perl_csighandler);
+ (void) rsignal(sig, PL_csighandlerp);
#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
sig_ignoring[sig] = 0;
}
if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
if (i) {
- (void)rsignal(i, &Perl_csighandler);
+ (void)rsignal(i, PL_csighandlerp);
#ifdef HAS_SIGPROCMASK
LEAVE;
#endif
if (i) {
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
sig_ignoring[i] = 1;
- (void)rsignal(i, &Perl_csighandler);
+ (void)rsignal(i, PL_csighandlerp);
#else
(void)rsignal(i, SIG_IGN);
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
{
sig_defaulting[i] = 1;
- (void)rsignal(i, &Perl_csighandler);
+ (void)rsignal(i, PL_csighandlerp);
}
#else
(void)rsignal(i, SIG_DFL);
if (!strchr(s,':') && !strchr(s,'\''))
sv_insert(sv, 0, 0, "main::", 6);
if (i)
- (void)rsignal(i, &Perl_csighandler);
+ (void)rsignal(i, PL_csighandlerp);
else
*svp = SvREFCNT_inc(sv);
}
int
Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
{
- magic_methpack(sv,mg,"FETCH");
if (mg->mg_ptr)
mg->mg_flags |= MGf_GSKIP;
+ magic_methpack(sv,mg,"FETCH");
return 0;
}
}
i--;
}
+ SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
return 0;
}
break;
case '\004': /* ^D */
- PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
+#ifdef DEBUGGING
+ s = SvPV_nolen(sv);
+ PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
DEBUG_x(dump_all());
+#else
+ PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
+#endif
break;
case '\005': /* ^E */
if (*(mg->mg_ptr+1) == '\0') {
}
}
break;
- case '*':
- i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
- PL_multiline = (i != 0);
- break;
case '/':
SvREFCNT_dec(PL_rs);
PL_rs = newSVsv(sv);
pstat(PSTAT_SETCMD, un, len, 0, 0);
}
#endif
- if (!PL_origalen) {
- s = PL_origargv[0];
- s += strlen(s);
- /* See if all the arguments are contiguous in memory */
- for (i = 1; i < PL_origargc; i++) {
- if (PL_origargv[i] == s + 1
-#ifdef OS2
- || PL_origargv[i] == s + 2
-#endif
- )
- {
- ++s;
- s += strlen(s); /* this one is ok too */
- }
- else
- break;
- }
- /* can grab env area too? */
- if (PL_origenviron
-#ifdef USE_ITHREADS
- && PL_curinterp == aTHX
-#endif
- && (PL_origenviron[0] == s + 1))
- {
- my_setenv("NoNe SuCh", Nullch);
- /* force copy of environment */
- for (i = 0; PL_origenviron[i]; i++)
- if (PL_origenviron[i] == s + 1) {
- ++s;
- s += strlen(s);
- }
- else
- break;
- }
- PL_origalen = s - PL_origargv[0];
- }
+ /* PL_origalen is set in perl_parse(). */
s = SvPV_force(sv,len);
- i = len;
- if (i >= (I32)PL_origalen) {
- i = PL_origalen;
- /* don't allow system to limit $0 seen by script */
- /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
- Copy(s, PL_origargv[0], i, char);
- s = PL_origargv[0]+i;
- *s = '\0';
+ if (len >= (STRLEN)PL_origalen) {
+ /* Longer than original, will be truncated. */
+ Copy(s, PL_origargv[0], PL_origalen, char);
+ PL_origargv[0][PL_origalen - 1] = 0;
}
else {
- Copy(s, PL_origargv[0], i, char);
- s = PL_origargv[0]+i;
- *s++ = '\0';
- while (++i < (I32)PL_origalen)
- *s++ = '\0';
+ /* Shorter than original, will be padded. */
+ Copy(s, PL_origargv[0], len, char);
+ PL_origargv[0][len] = 0;
+ memset(PL_origargv[0] + len + 1,
+ /* Is the space counterintuitive? Yes.
+ * (You were expecting \0?)
+ * Does it work? Seems to. (In Linux 2.4.20 at least.)
+ * --jhi */
+ (int)' ',
+ PL_origalen - len - 1);
for (i = 1; i < PL_origargc; i++)
- PL_origargv[i] = Nullch;
+ PL_origargv[i] = 0;
}
UNLOCK_DOLLARZERO_MUTEX;
break;
#else
/* Not clear if this will work */
(void)rsignal(sig, SIG_IGN);
- (void)rsignal(sig, &Perl_csighandler);
+ (void)rsignal(sig, PL_csighandlerp);
#endif
#endif /* !PERL_MICRO */
Perl_die(aTHX_ Nullformat);
https://perl5.git.perl.org / perl5.git / blobdiff