*/
/*
-=head1 Magical Functions
+=head1 Magic
"Magic" is special data attached to SV structures in order to give them
"magical" properties. When any Perl code tries to read from, or assign to,
an SV marked as magical, it calls the 'get' or 'set' function associated
a MAGIC structure that contains a pointer to the object associated with the
tie.
+=for apidoc Ayh||MAGIC
+
=cut
*/
#include "EXTERN.h"
#define PERL_IN_MG_C
#include "perl.h"
+#include "feature.h"
#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
# ifdef I_GRP
# include <sys/prctl.h>
#endif
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
-#else
-Signal_t Perl_csighandler(int sig);
-#endif
-
#ifdef __Lynx__
/* Missing protos on LynxOS */
void setruid(uid_t id);
/*
=for apidoc mg_magical
-Turns on the magical status of an SV. See C<sv_magic>.
+Turns on the magical status of an SV. See C<L</sv_magic>>.
=cut
*/
=for apidoc mg_get
Do magic before a value is retrieved from the SV. The type of SV must
-be >= SVt_PVMG. See C<sv_magic>.
+be >= C<SVt_PVMG>. See C<L</sv_magic>>.
=cut
*/
const I32 mgs_ix = SSNEW(sizeof(MGS));
bool saved = FALSE;
bool have_new = 0;
+ bool taint_only = TRUE; /* the only get method seen is taint */
MAGIC *newmg, *head, *cur, *mg;
PERL_ARGS_ASSERT_MG_GET;
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
/* taint's mg get is so dumb it doesn't need flag saving */
- if (!saved && mg->mg_type != PERL_MAGIC_taint) {
- save_magic(mgs_ix, sv);
- saved = TRUE;
- }
+ if (mg->mg_type != PERL_MAGIC_taint) {
+ taint_only = FALSE;
+ if (!saved) {
+ save_magic(mgs_ix, sv);
+ saved = TRUE;
+ }
+ }
vtbl->svt_get(aTHX_ sv, mg);
~(SVs_GMG|SVs_SMG|SVs_RMG);
}
else if (vtbl == &PL_vtbl_utf8) {
- /* get-magic can reallocate the PV */
- magic_setutf8(sv, mg);
+ /* get-magic can reallocate the PV, unless there's only taint
+ * magic */
+ if (taint_only) {
+ MAGIC *mg2;
+ for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
+ if ( mg2->mg_type != PERL_MAGIC_taint
+ && !(mg2->mg_flags & MGf_GSKIP)
+ && mg2->mg_virtual
+ && mg2->mg_virtual->svt_get
+ ) {
+ taint_only = FALSE;
+ break;
+ }
+ }
+ }
+ if (!taint_only)
+ magic_setutf8(sv, mg);
}
mg = nextmg;
/*
=for apidoc mg_set
-Do magic after a value is assigned to the SV. See C<sv_magic>.
+Do magic after a value is assigned to the SV. See C<L</sv_magic>>.
=cut
*/
=for apidoc mg_length
Reports on the SV's length in bytes, calling length magic if available,
-but does not set the UTF8 flag on the sv. It will fall back to 'get'
+but does not set the UTF8 flag on C<sv>. It will fall back to 'get'
magic if there is no 'length' magic, but with no indication as to
-whether it called 'get' magic. It assumes the sv is a PVMG or
-higher. Use sv_len() instead.
+whether it called 'get' magic. It assumes C<sv> is a C<PVMG> or
+higher. Use C<sv_len()> instead.
=cut
*/
/*
=for apidoc mg_clear
-Clear something magical that the SV represents. See C<sv_magic>.
+Clear something magical that the SV represents. See C<L</sv_magic>>.
=cut
*/
/*
=for apidoc mg_find
-Finds the magic pointer for type matching the SV. See C<sv_magic>.
+Finds the magic pointer for C<type> matching the SV. See C<L</sv_magic>>.
=cut
*/
=for apidoc mg_findext
Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
-C<sv_magicext>.
+C<L</sv_magicext>>.
=cut
*/
/*
=for apidoc mg_copy
-Copies the magic from one SV to another. See C<sv_magic>.
+Copies the magic from one SV to another. See C<L</sv_magic>>.
=cut
*/
sv_magic(nsv,
(type == PERL_MAGIC_tied)
? SvTIED_obj(sv, mg)
- : (type == PERL_MAGIC_regdata && mg->mg_obj)
- ? sv
- : mg->mg_obj,
+ : mg->mg_obj,
toLOWER(type), key, klen);
count++;
}
=for apidoc mg_localize
Copy some of the magic from an existing SV to new localized version of that
-SV. Container magic (eg %ENV, $1, tie)
-gets copied, value magic doesn't (eg
-taint, pos).
+SV. Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>)
+gets copied, value magic doesn't (I<e.g.>,
+C<taint>, C<pos>).
-If setmagic is false then no set magic will be called on the new (empty) SV.
-This typically means that assignment will soon follow (e.g. 'local $x = $y'),
+If C<setmagic> is false then no set magic will be called on the new (empty) SV.
+This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>),
and that will handle the magic.
=cut
const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_free)
vtbl->svt_free(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
- if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
- Safefree(mg->mg_ptr);
- else if (mg->mg_len == HEf_SVKEY)
- SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
- }
+
+ if (mg->mg_len > 0)
+ Safefree(mg->mg_ptr);
+ else if (mg->mg_len == HEf_SVKEY)
+ SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
+
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
/*
=for apidoc mg_free
-Free any magic storage used by the SV. See C<sv_magic>.
+Free any magic storage used by the SV. See C<L</sv_magic>>.
=cut
*/
}
/*
-=for apidoc Am|void|mg_free_type|SV *sv|int how
+=for apidoc mg_free_type
-Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
+Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
=cut
*/
MAGIC *mg, *prevmg, *moremg;
PERL_ARGS_ASSERT_MG_FREE_TYPE;
for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
- MAGIC *newhead;
moremg = mg->mg_moremagic;
if (mg->mg_type == how) {
+ MAGIC *newhead;
+ /* temporarily move to the head of the magic chain, in case
+ custom free code relies on this historical aspect of mg_free */
+ if (prevmg) {
+ prevmg->mg_moremagic = moremg;
+ mg->mg_moremagic = SvMAGIC(sv);
+ SvMAGIC_set(sv, mg);
+ }
+ newhead = mg->mg_moremagic;
+ mg_free_struct(sv, mg);
+ SvMAGIC_set(sv, newhead);
+ mg = prevmg;
+ }
+ }
+ mg_magical(sv);
+}
+
+/*
+=for apidoc mg_freeext
+
+Remove any magic of type C<how> using virtual table C<vtbl> from the
+SV C<sv>. See L</sv_magic>.
+
+C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>.
+
+=cut
+*/
+
+void
+Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl)
+{
+ MAGIC *mg, *prevmg, *moremg;
+ PERL_ARGS_ASSERT_MG_FREEEXT;
+ for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
+ MAGIC *newhead;
+ moremg = mg->mg_moremagic;
+ if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) {
/* temporarily move to the head of the magic chain, in case
custom free code relies on this historical aspect of mg_free */
if (prevmg) {
PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
if (PL_curpm) {
- const REGEXP * const rx = PM_GETRE(PL_curpm);
+ REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
- if (mg->mg_obj) { /* @+ */
+ const SSize_t n = (SSize_t)mg->mg_obj;
+ if (n == '+') { /* @+ */
/* return the number possible */
return RX_NPARENS(rx);
- } else { /* @- */
+ } else { /* @- @^CAPTURE @{^CAPTURE} */
I32 paren = RX_LASTPAREN(rx);
/* return the last filled */
&& (RX_OFFS(rx)[paren].start == -1
|| RX_OFFS(rx)[paren].end == -1) )
paren--;
- return (U32)paren;
- }
+ if (n == '-') {
+ /* @- */
+ return (U32)paren;
+ } else {
+ /* @^CAPTURE @{^CAPTURE} */
+ return paren >= 0 ? (U32)(paren-1) : (U32)-1;
+ }
+ }
}
}
PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
if (PL_curpm) {
- const REGEXP * const rx = PM_GETRE(PL_curpm);
+ REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
- const I32 paren = mg->mg_len;
+ const SSize_t n = (SSize_t)mg->mg_obj;
+ /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
+ const I32 paren = mg->mg_len
+ + (n == '\003' ? 1 : 0);
SSize_t s;
SSize_t t;
if (paren < 0)
(t = RX_OFFS(rx)[paren].end) != -1)
{
SSize_t i;
- if (mg->mg_obj) /* @+ */
+
+ if (n == '+') /* @+ */
i = t;
- else /* @- */
+ else if (n == '-') /* @- */
i = s;
+ else { /* @^CAPTURE @{^CAPTURE} */
+ CALLREG_NUMBUF_FETCH(rx,paren,sv);
+ return 0;
+ }
if (RX_MATCH_UTF8(rx)) {
const char * const b = RX_SUBBEG(rx);
}
}
}
- sv_setsv(sv, NULL);
+ sv_set_undef(sv);
return 0;
}
PERL_ARGS_ASSERT_EMULATE_COP_IO;
if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
- sv_setsv(sv, &PL_sv_undef);
+ sv_set_undef(sv);
else {
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
SvUTF8_off(sv);
if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
* avoid as many possible backward compatibility issues as possible, we
* don't turn on the flag unless we have to. So the flag stays off for
* an entirely invariant string. We assume that if the string looks
- * like UTF-8, it really is UTF-8: "text in any other encoding that
- * uses bytes with the high bit set is extremely unlikely to pass a
- * UTF-8 validity test"
+ * like UTF-8 in a single script, it really is UTF-8: "text in any
+ * other encoding that uses bytes with the high bit set is extremely
+ * unlikely to pass a UTF-8 validity test"
* (http://en.wikipedia.org/wiki/Charset_detection). There is a
* potential that we will get it wrong however, especially on short
- * error message text. (If it turns out to be necessary, we could also
- * keep track if the current LC_MESSAGES locale is UTF-8) */
- if (! IN_BYTES /* respect 'use bytes' */
- && ! is_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
- && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
- {
+ * error message text, so do an additional check. */
+ if ( ! IN_BYTES /* respect 'use bytes' */
+ && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
+
+#ifdef USE_LOCALE_MESSAGES
+
+ && _is_cur_LC_category_utf8(LC_MESSAGES)
+
+#else /* If can't check directly, at least can see if script is consistent,
+ under UTF-8, which gives us an extra measure of confidence. */
+
+ && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv),
+ TRUE) /* Means assume UTF-8 */
+#endif
+
+ ) {
SvUTF8_on(sv);
}
}
}
-SV*
-Perl__get_encoding(pTHX)
-{
- /* For core Perl use only: Returns the $^ENCODING or 'use encoding' in
- * effect; NULL if none.
- *
- * $^ENCODING maps to PL_encoding, and is the old way to do things, and is
- * retained for backwards compatibility. Now, there is a shadow variable
- * ${^E_NCODING} set only by the encoding pragma, used to give this pragma
- * lexical scope, unlike the global scope it (shudder) used to have. This
- * variable maps to PL_lex_encoding. Again for backwards compatibility,
- * PL_encoding has precedence over PL_lex_encoding. The hints hash is used
- * to determine if PL_lex_encoding is in scope, and hence valid. The hints
- * hash only accepts simple values, so we can't put an Encode object into
- * it, so we put the object into the global, and put a simple boolean into
- * the hints hash giving whether the global is valid or not */
-
- dVAR;
- SV *is_encoding;
-
- if (PL_encoding) {
- return PL_encoding;
- }
-
- if (! PL_lex_encoding) {
- return NULL;
- }
-
- is_encoding = cop_hints_fetch_pvs(PL_curcop, "encoding", 0);
- if ( is_encoding
- && is_encoding != &PL_sv_placeholder
- && SvIOK(is_encoding)
- && SvIV(is_encoding)) /* non-zero mean valid */
- {
- return PL_lex_encoding;
- }
+/*
+=for apidoc_section $errno
+=for apidoc sv_string_from_errnum
+
+Generates the message string describing an OS error and returns it as
+an SV. C<errnum> must be a value that C<errno> could take, identifying
+the type of error.
+
+If C<tgtsv> is non-null then the string will be written into that SV
+(overwriting existing content) and it will be returned. If C<tgtsv>
+is a null pointer then the string will be written into a new mortal SV
+which will be returned.
+
+The message will be taken from whatever locale would be used by C<$!>,
+and will be encoded in the SV in whatever manner would be used by C<$!>.
+The details of this process are subject to future change. Currently,
+the message is taken from the C locale by default (usually producing an
+English message), and from the currently selected locale when in the scope
+of the C<use locale> pragma. A heuristic attempt is made to decode the
+message from the locale's character encoding, but it will only be decoded
+as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
+locale, usually in an ISO-8859-1 locale, and never in any other locale.
+
+The SV is always returned containing an actual string, and with no other
+OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
+(meaning success), and if no useful message is available then a useless
+string (currently empty) is returned.
- return NULL;
+=cut
+*/
+
+SV *
+Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
+{
+ char const *errstr;
+ if(!tgtsv)
+ tgtsv = sv_newmortal();
+ errstr = my_strerror(errnum);
+ if(errstr) {
+ sv_setpv(tgtsv, errstr);
+ fixup_errno_string(tgtsv);
+ } else {
+ SvPVCLEAR(tgtsv);
+ }
+ return tgtsv;
}
#ifdef VMS
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
do_numbuf_fetch:
CALLREG_NUMBUF_FETCH(rx,paren,sv);
- } else {
- sv_setsv(sv,&PL_sv_undef);
}
+ else
+ goto set_undef;
return 0;
}
switch (*mg->mg_ptr) {
case '\001': /* ^A */
if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
- else sv_setsv(sv, &PL_sv_undef);
+ else
+ sv_set_undef(sv);
if (SvTAINTED(PL_bodytarget))
SvTAINTED_on(sv);
break;
case '\005': /* ^E */
if (nextchar != '\0') {
if (strEQ(remaining, "NCODING"))
- sv_setsv(sv, _get_encoding());
- else if (strEQ(remaining, "_NCODING"))
- sv_setsv(sv, NULL);
+ sv_set_undef(sv);
break;
}
if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
else
- sv_setpvs(sv,"");
+ SvPVCLEAR(sv);
}
#elif defined(OS2)
if (!(_emx_env & 0x200)) { /* Under DOS */
fixup_errno_string(sv);
}
else
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
SetLastError(dwErr);
}
# else
break;
#endif /* End of platforms with special handling for $^E; others just fall
through to $! */
+ /* FALLTHROUGH */
case '!':
{
else
#endif
if (! errno) {
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
}
else {
-
- /* Strerror can return NULL on some platforms, which will
- * result in 'sv' not being considered SvOK. The SvNOK_on()
+ sv_string_from_errnum(errno, sv);
+ /* If no useful string is available, don't
+ * claim to have a string part. The SvNOK_on()
* below will cause just the number part to be valid */
- sv_setpv(sv, my_strerror(errno));
- if (SvOK(sv)) {
- fixup_errno_string(sv);
- }
+ if (!SvCUR(sv))
+ SvPOK_off(sv);
}
RESTORE_ERRNO;
}
break;
case '\006': /* ^F */
- sv_setiv(sv, (IV)PL_maxsysfd);
+ if (nextchar == '\0') {
+ sv_setiv(sv, (IV)PL_maxsysfd);
+ }
break;
case '\007': /* ^GLOBAL_PHASE */
if (strEQ(remaining, "LOBAL_PHASE")) {
}
break;
case '\010': /* ^H */
- sv_setiv(sv, (IV)PL_hints);
+ sv_setuv(sv, PL_hints);
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
break;
case '\014': /* ^LAST_FH */
if (strEQ(remaining, "AST_FH")) {
- if (PL_last_in_gv) {
+ if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) {
assert(isGV_with_GP(PL_last_in_gv));
SV_CHECK_THINKFIRST_COW_DROP(sv);
prepare_SV_for_RV(sv);
SvROK_on(sv);
sv_rvweaken(sv);
}
- else sv_setsv_nomg(sv, NULL);
+ else
+ sv_set_undef(sv);
}
break;
case '\017': /* ^O & ^OPEN */
sv_setiv(sv, (IV)PL_perldb);
break;
case '\023': /* ^S */
- {
+ if (nextchar == '\0') {
if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
SvOK_off(sv);
else if (PL_in_eval)
else
sv_setiv(sv, 0);
}
+ else if (strEQ(remaining, "AFE_LOCALES")) {
+
+#if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
+
+ sv_setuv(sv, (UV) 1);
+
+#else
+ sv_setuv(sv, (UV) 0);
+
+#endif
+
+ }
break;
case '\024': /* ^T */
if (nextchar == '\0') {
break;
case '\027': /* ^W & $^WARNING_BITS */
if (nextchar == '\0')
- sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
+ sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
else if (strEQ(remaining, "ARNING_BITS")) {
if (PL_compiling.cop_warnings == pWARN_NONE) {
sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
}
else if (PL_compiling.cop_warnings == pWARN_STD) {
- sv_setsv(sv, &PL_sv_undef);
- break;
+ goto set_undef;
}
else if (PL_compiling.cop_warnings == pWARN_ALL) {
- /* Get the bit mask for $warnings::Bits{all}, because
- * it could have been extended by warnings::register */
- HV * const bits = get_hv("warnings::Bits", 0);
- SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
- if (bits_all)
- sv_copypv(sv, *bits_all);
- else
- sv_setpvn(sv, WARN_ALLstring, WARNsize);
+ sv_setpvn(sv, WARN_ALLstring, WARNsize);
}
else {
sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
*PL_compiling.cop_warnings);
}
}
+#ifdef WIN32
+ else if (strEQ(remaining, "IN32_SLOPPY_STAT")) {
+ sv_setiv(sv, w32_sloppystat);
+ }
+#endif
break;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (paren)
goto do_numbuf_fetch;
}
- sv_setsv(sv,&PL_sv_undef);
- break;
+ goto set_undef;
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = RX_LASTCLOSEPAREN(rx);
if (paren)
goto do_numbuf_fetch;
}
- sv_setsv(sv,&PL_sv_undef);
- break;
+ goto set_undef;
case '.':
if (GvIO(PL_last_in_gv)) {
sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
break;
case ':':
- break;
case '/':
break;
case '[':
if (PL_ors_sv)
sv_copypv(sv, PL_ors_sv);
else
- sv_setsv(sv, &PL_sv_undef);
+ goto set_undef;
break;
case '$': /* $$ */
{
#ifdef HAS_GETGROUPS
{
Groups_t *gary = NULL;
- I32 i;
I32 num_groups = getgroups(0, gary);
if (num_groups > 0) {
+ I32 i;
Newx(gary, num_groups, Groups_t);
num_groups = getgroups(num_groups, gary);
for (i = 0; i < num_groups; i++)
- Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+ Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
Safefree(gary);
}
}
break;
}
return 0;
+
+ set_undef:
+ sv_set_undef(sv);
+ return 0;
}
int
}
#endif
-#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
+#if !defined(OS2) && !defined(WIN32) && !defined(MSDOS)
/* And you'll never guess what the dog had */
/* in its mouth... */
if (TAINTING_get) {
MgTAINTEDDIR_off(mg);
#ifdef VMS
- if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
+ if (s && memEQs(key, klen, "DCL$PATH")) {
char pathbuf[256], eltbuf[256], *cp, *elt;
int i = 0, j = 0;
} while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
}
#endif /* VMS */
- if (s && klen == 4 && strEQ(key,"PATH")) {
+ if (s && memEQs(key, klen, "PATH")) {
const char * const strend = s + len;
+ /* set MGf_TAINTEDDIR if any component of the new path is
+ * relative or world-writeable */
while (s < strend) {
char tmpbuf[256];
Stat_t st;
I32 i;
-#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
- const char path_sep = '|';
+#ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */
+ const char path_sep = PL_perllib_sep;
#else
const char path_sep = ':';
#endif
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
+ s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
s, strend, path_sep, &i);
s++;
if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
-#ifdef VMS
- || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
+#ifdef __VMS
+ /* no colon thus no device name -- assume relative path */
+ || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
+ /* Using Unix separator, e.g. under bash, so act line Unix */
+ || (PL_perllib_sep == ':' && *tmpbuf != '/')
#else
|| *tmpbuf != '/' /* no starting slash -- assume relative path */
#endif
}
}
}
-#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
+#endif /* neither OS2 nor WIN32 nor MSDOS */
return 0;
}
if(sigstate == (Sighandler_t) SIG_IGN)
sv_setpvs(sv,"IGNORE");
else
- sv_setsv(sv,&PL_sv_undef);
+ sv_set_undef(sv);
PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
SvTEMP_off(sv);
}
return sv_unmagic(sv, mg->mg_type);
}
+
+#ifdef PERL_USE_3ARG_SIGHANDLER
Signal_t
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
+Perl_csighandler(int sig, Siginfo_t *sip, void *uap)
+{
+ Perl_csighandler3(sig, sip, uap);
+}
#else
+Signal_t
Perl_csighandler(int sig)
+{
+ Perl_csighandler3(sig, NULL, NULL);
+}
#endif
+
+Signal_t
+Perl_csighandler1(int sig)
+{
+ Perl_csighandler3(sig, NULL, NULL);
+}
+
+/* Handler intended to directly handle signal calls from the kernel.
+ * (Depending on configuration, the kernel may actually call one of the
+ * wrappers csighandler() or csighandler1() instead.)
+ * It either queues up the signal or dispatches it immediately depending
+ * on whether safe signals are enabled and whether the signal is capable
+ * of being deferred (e.g. SEGV isn't).
+ */
+
+Signal_t
+Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
{
#ifdef PERL_GET_SIG_CONTEXT
dTHXa(PERL_GET_SIG_CONTEXT);
#else
dTHX;
#endif
+
+#ifdef PERL_USE_3ARG_SIGHANDLER
#if defined(__cplusplus) && defined(__GNUC__)
/* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
* parameters would be warned about. */
PERL_UNUSED_ARG(sip);
PERL_UNUSED_ARG(uap);
#endif
+#endif
+
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
(void) rsignal(sig, PL_csighandlerp);
if (PL_sig_ignoring[sig]) return;
(PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
/* Call the perl level handler now--
* with risk we may be in malloc() or being destructed etc. */
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
- (*PL_sighandlerp)(sig, NULL, NULL);
+ {
+ if (PL_sighandlerp == Perl_sighandler)
+ /* default handler, so can call perly_sighandler() directly
+ * rather than via Perl_sighandler, passing the extra
+ * 'safe = false' arg
+ */
+ Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */);
+ else
+#ifdef PERL_USE_3ARG_SIGHANDLER
+ (*PL_sighandlerp)(sig, NULL, NULL);
#else
- (*PL_sighandlerp)(sig);
+ (*PL_sighandlerp)(sig);
#endif
+ }
else {
if (!PL_psig_pend) return;
/* Set a flag to say this signal is pending, that is awaiting delivery after
}
#endif
PL_psig_pend[sig] = 0;
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
- (*PL_sighandlerp)(sig, NULL, NULL);
+ if (PL_sighandlerp == Perl_sighandler)
+ /* default handler, so can call perly_sighandler() directly
+ * rather than via Perl_sighandler, passing the extra
+ * 'safe = true' arg
+ */
+ Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */);
+ else
+#ifdef PERL_USE_3ARG_SIGHANDLER
+ (*PL_sighandlerp)(sig, NULL, NULL);
#else
- (*PL_sighandlerp)(sig);
+ (*PL_sighandlerp)(sig);
#endif
+
#ifdef HAS_SIGPROCMASK
if (!was_blocked)
LEAVE;
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
I32 i;
SV** svp = NULL;
/* Need to be careful with SvREFCNT_dec(), because that can have side
Ideally we'd find some way of making SVs at (C) compile time, or
at least, doing most of the work. */
if (!PL_psig_name[i]) {
- PL_psig_name[i] = newSVpvn(s, len);
+ const char* name = PL_sig_name[i];
+ PL_psig_name[i] = newSVpvn(name, strlen(name));
SvREADONLY_on(PL_psig_name[i]);
}
} else {
* access to a known hint bit in a known OP, we can't
* tell whether HINT_STRICT_REFS is in force or not.
*/
- if (!strchr(s,':') && !strchr(s,'\''))
+ if (!memchr(s, ':', len) && !memchr(s, '\'', len))
Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
SV_GMAGIC);
if (i)
}
/*
+=for apidoc_section $magic
=for apidoc magic_methcall
Invoke a magic method (like FETCH).
The arguments themselves are any values following the C<flags> argument.
-Returns the SV (if any) returned by the method, or NULL on failure.
+Returns the SV (if any) returned by the method, or C<NULL> on failure.
=cut
if (flags & G_WRITING_TO_STDERR) {
SAVETMPS;
+ save_re_context();
SAVESPTR(PL_stderrgv);
PL_stderrgv = NULL;
}
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
- EXTEND(SP, argc+1);
+ /* EXTEND() expects a signed argc; don't wrap when casting */
+ assert(argc <= I32_MAX);
+ EXTEND(SP, (I32)argc+1);
PUSHs(SvTIED_obj(sv, mg));
if (flags & G_UNDEF_FILL) {
while (argc--) {
va_start(args, argc);
do {
- SV *const sv = va_arg(args, SV *);
- PUSHs(sv);
+ SV *const this_sv = va_arg(args, SV *);
+ PUSHs(this_sv);
} while (--argc);
va_end(args);
/* The magic ptr/len for the debugger's hash should always be an SV. */
if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
- Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'",
+ Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
(IV)mg->mg_len, mg->mg_ptr);
}
if (obj) {
sv_setiv(sv, AvFILL(obj));
} else {
- sv_setsv(sv, NULL);
+ sv_set_undef(sv);
}
return 0;
}
PERL_UNUSED_CONTEXT;
/* Reset the iterator when the array is cleared */
-#if IVSIZE == I32SIZE
- *((IV *) &(mg->mg_len)) = 0;
-#else
- if (mg->mg_ptr)
- *((IV *) mg->mg_ptr) = 0;
-#endif
+ if (sizeof(IV) == sizeof(SSize_t)) {
+ *((IV *) &(mg->mg_len)) = 0;
+ } else {
+ if (mg->mg_ptr)
+ *((IV *) mg->mg_ptr) = 0;
+ }
return 0;
}
sv_setuv(sv, i);
return 0;
}
- sv_setsv(sv,NULL);
+ sv_set_undef(sv);
return 0;
}
SV* const lsv = LvTARG(sv);
SSize_t pos;
STRLEN len;
- STRLEN ulen = 0;
MAGIC* found;
const char *s;
pos = SvIV(sv);
if (DO_UTF8(lsv)) {
- ulen = sv_or_pv_len_utf8(lsv, s, len);
+ const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
if (ulen)
len = ulen;
}
const char * const tmps = SvPV_const(lsv,len);
STRLEN offs = LvTARGOFF(sv);
STRLEN rem = LvTARGLEN(sv);
- const bool negoff = LvFLAGS(sv) & 1;
- const bool negrem = LvFLAGS(sv) & 2;
+ const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
+ const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
PERL_UNUSED_ARG(mg);
negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
)) {
Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
- sv_setsv_nomg(sv, &PL_sv_undef);
+ sv_set_undef(sv);
return 0;
}
SV * const lsv = LvTARG(sv);
STRLEN lvoff = LvTARGOFF(sv);
STRLEN lvlen = LvTARGLEN(sv);
- const bool negoff = LvFLAGS(sv) & 1;
- const bool neglen = LvFLAGS(sv) & 2;
+ const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
+ const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
PERL_UNUSED_ARG(mg);
Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
{
SV * const lsv = LvTARG(sv);
+ char errflags = LvFLAGS(sv);
PERL_ARGS_ASSERT_MAGIC_GETVEC;
PERL_UNUSED_ARG(mg);
- sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
+ /* non-zero errflags implies deferred out-of-range condition */
+ assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
+ sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
return 0;
}
}
int
+Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
+ PERL_UNUSED_ARG(mg);
+ sv_unmagic(sv, PERL_MAGIC_nonelem);
+ return 0;
+}
+
+int
Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
return 0;
}
+
+int
+Perl_magic_freemglob(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_FREEMGLOB;
+ PERL_UNUSED_ARG(sv);
+
+ /* glob magic uses mg_len as a string length rather than a buffer
+ * length, so we need to free even with mg_len == 0: hence we can't
+ * rely on standard magic free handling */
+ assert(mg->mg_type == PERL_MAGIC_regex_global && mg->mg_len >= -1);
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ return 0;
+}
+
+
int
Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
- if (type == PERL_MAGIC_qr) {
- } else if (type == PERL_MAGIC_bm) {
- SvTAIL_off(sv);
- SvVALID_off(sv);
- } else {
- assert(type == PERL_MAGIC_fm);
- }
+ assert( type == PERL_MAGIC_fm
+ || type == PERL_MAGIC_qr
+ || type == PERL_MAGIC_bm);
return sv_unmagic(sv, type);
}
}
return 0;
}
+
+int
+Perl_magic_freecollxfrm(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_FREECOLLXFRM;
+ PERL_UNUSED_ARG(sv);
+
+ /* Collate magic uses mg_len as a string length rather than a buffer
+ * length, so we need to free even with mg_len == 0: hence we can't
+ * rely on standard magic free handling */
+ if (mg->mg_len >= 0) {
+ assert(mg->mg_type == PERL_MAGIC_collxfrm);
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ }
+
+ return 0;
+}
#endif /* USE_LOCALE_COLLATE */
/* Just clear the UTF-8 cache data. */
}
int
+Perl_magic_freeutf8(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_FREEUTF8;
+ PERL_UNUSED_ARG(sv);
+
+ /* utf8 magic uses mg_len as a string length rather than a buffer
+ * length, so we need to free even with mg_len == 0: hence we can't
+ * rely on standard magic free handling */
+ assert(mg->mg_type == PERL_MAGIC_utf8 && mg->mg_len >= -1);
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ return 0;
+}
+
+
+int
Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
{
const char *bad = NULL;
return 0;
}
+static void
+S_set_dollarzero(pTHX_ SV *sv)
+ PERL_TSA_REQUIRES(PL_dollarzero_mutex)
+{
+#ifdef USE_ITHREADS
+#endif
+ const char *s;
+ STRLEN len;
+#ifdef HAS_SETPROCTITLE
+ /* The BSDs don't show the argv[] in ps(1) output, they
+ * show a string from the process struct and provide
+ * the setproctitle() routine to manipulate that. */
+ if (PL_origalen != 1) {
+ s = SvPV_const(sv, len);
+# if __FreeBSD_version > 410001 || defined(__DragonFly__)
+ /* The leading "-" removes the "perl: " prefix,
+ * but not the "(perl) suffix from the ps(1)
+ * output, because that's what ps(1) shows if the
+ * argv[] is modified. */
+ setproctitle("-%s", s);
+# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
+ /* This doesn't really work if you assume that
+ * $0 = 'foobar'; will wipe out 'perl' from the $0
+ * because in ps(1) output the result will be like
+ * sprintf("perl: %s (perl)", s)
+ * I guess this is a security feature:
+ * one (a user process) cannot get rid of the original name.
+ * --jhi */
+ setproctitle("%s", s);
+# endif
+ }
+#elif defined(__hpux) && defined(PSTAT_SETCMD)
+ if (PL_origalen != 1) {
+ union pstun un;
+ s = SvPV_const(sv, len);
+ un.pst_command = (char *)s;
+ pstat(PSTAT_SETCMD, un, len, 0, 0);
+ }
+#else
+ if (PL_origalen > 1) {
+ I32 i;
+ /* PL_origalen is set in perl_parse(). */
+ s = SvPV_force(sv,len);
+ if (len >= (STRLEN)PL_origalen-1) {
+ /* Longer than original, will be truncated. We assume that
+ * PL_origalen bytes are available. */
+ Copy(s, PL_origargv[0], PL_origalen-1, char);
+ }
+ else {
+ /* Shorter than original, will be padded. */
+#ifdef PERL_DARWIN
+ /* Special case for Mac OS X: see [perl #38868] */
+ const int pad = 0;
+#else
+ /* Is the space counterintuitive? Yes.
+ * (You were expecting \0?)
+ * Does it work? Seems to. (In Linux 2.4.20 at least.)
+ * --jhi */
+ const int pad = ' ';
+#endif
+ Copy(s, PL_origargv[0], len, char);
+ PL_origargv[0][len] = 0;
+ memset(PL_origargv[0] + len + 1,
+ pad, PL_origalen - len - 1);
+ }
+ PL_origargv[0][PL_origalen-1] = 0;
+ for (i = 1; i < PL_origargc; i++)
+ PL_origargv[i] = 0;
+#ifdef HAS_PRCTL_SET_NAME
+ /* Set the legacy process name in addition to the POSIX name on Linux */
+ if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
+ /* diag_listed_as: SKIPME */
+ Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
+ }
+#endif
+ }
+#endif
+}
+
int
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
- const char *s;
I32 paren;
const REGEXP * rx;
I32 i;
FmLINES(PL_bodytarget) = 0;
if (SvPOK(PL_bodytarget)) {
char *s = SvPVX(PL_bodytarget);
- while ( ((s = strchr(s, '\n'))) ) {
+ char *e = SvEND(PL_bodytarget);
+ while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
FmLINES(PL_bodytarget)++;
s++;
}
case '\004': /* ^D */
#ifdef DEBUGGING
- s = SvPV_nolen_const(sv);
- PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
- if (DEBUG_x_TEST || DEBUG_B_TEST)
- dump_all_perl(!DEBUG_B_TEST);
+ {
+ const char *s = SvPV_nolen_const(sv);
+ PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
+ if (DEBUG_x_TEST || DEBUG_B_TEST)
+ dump_all_perl(!DEBUG_B_TEST);
+ }
#else
PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
#endif
if (*(mg->mg_ptr+1) == '\0') {
#ifdef VMS
set_vaxc_errno(SvIV(sv));
-#else
-# ifdef WIN32
+#elif defined(WIN32)
SetLastError( SvIV(sv) );
-# else
-# ifdef OS2
+#elif defined(OS2)
os2_setsyserrno(SvIV(sv));
-# else
+#else
/* will anyone ever use this? */
SETERRNO(SvIV(sv), 4);
-# endif
-# endif
#endif
}
- else {
- unsigned int offset = 1;
- bool lex = FALSE;
-
- /* It may be the shadow variable ${E_NCODING} which has lexical
- * scope. See comments at Perl__get_encoding in this file */
- if (*(mg->mg_ptr + 1) == '_') {
- if (CopSTASH(PL_curcop) != get_hv("encoding::",0))
- Perl_croak_no_modify();
- lex = TRUE;
- offset++;
- }
- if (strEQ(mg->mg_ptr + offset, "NCODING")) {
- if (lex) { /* Use the shadow global */
- SvREFCNT_dec(PL_lex_encoding);
- if (SvOK(sv) || SvGMAGICAL(sv)) {
- PL_lex_encoding = newSVsv(sv);
- }
- else {
- PL_lex_encoding = NULL;
- }
- }
- else { /* Use the regular global */
- SvREFCNT_dec(PL_encoding);
- if (SvOK(sv) || SvGMAGICAL(sv)) {
- if (PL_localizing != 2) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Setting ${^ENCODING} is deprecated");
- }
- PL_encoding = newSVsv(sv);
- }
- else {
- PL_encoding = NULL;
- }
- }
- }
- }
+ else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
+ Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
break;
case '\006': /* ^F */
- PL_maxsysfd = SvIV(sv);
+ if (mg->mg_ptr[1] == '\0') {
+ PL_maxsysfd = SvIV(sv);
+ }
break;
case '\010': /* ^H */
- PL_hints = SvIV(sv);
+ {
+ U32 save_hints = PL_hints;
+ PL_hints = SvUV(sv);
+
+ /* If wasn't UTF-8, and now is, notify the parser */
+ if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
+ notify_parser_that_changed_to_utf8();
+ }
+ }
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
Safefree(PL_inplace);
else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
if (!SvPOK(sv)) {
- PL_compiling.cop_warnings = pWARN_STD;
+ free_and_set_cop_warnings(&PL_compiling, pWARN_STD);
break;
}
{
STRLEN len, i;
- int accumulate = 0 ;
- int any_fatals = 0 ;
- const char * const ptr = SvPV_const(sv, len) ;
+ int not_none = 0, not_all = 0;
+ const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
for (i = 0 ; i < len ; ++i) {
- accumulate |= ptr[i] ;
- any_fatals |= (ptr[i] & 0xAA) ;
+ not_none |= ptr[i];
+ not_all |= ptr[i] ^ 0x55;
}
- if (!accumulate) {
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_NONE;
- }
- /* Yuck. I can't see how to abstract this: */
- else if (isWARN_on(
- ((STRLEN *)SvPV_nolen_const(sv)) - 1,
- WARN_ALL)
- && !any_fatals)
- {
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_ALL;
- PL_dowarn |= G_WARN_ONCE ;
- }
- else {
- STRLEN len;
- const char *const p = SvPV_const(sv, len);
-
- PL_compiling.cop_warnings
- = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
+ if (!not_none) {
+ free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
+ } else if (len >= WARNsize && !not_all) {
+ free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
+ PL_dowarn |= G_WARN_ONCE ;
+ }
+ else {
+ STRLEN len;
+ const char *const p = SvPV_const(sv, len);
+
+ PL_compiling.cop_warnings
+ = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
p, len);
- if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
+ if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
PL_dowarn |= G_WARN_ONCE ;
- }
+ }
}
}
}
+#ifdef WIN32
+ else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
+ w32_sloppystat = SvTRUE(sv);
+ }
+#endif
break;
case '.':
if (PL_localizing) {
break;
case '^':
Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
- s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
+ IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
break;
case '~':
Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
- s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
+ IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
break;
case '=':
break;
case '/':
{
- SV *tmpsv= sv;
if (SvROK(sv)) {
- SV *referent= SvRV(sv);
- const char *reftype= sv_reftype(referent, 0);
- /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative
- * is to copy pretty much the entire sv_reftype() into this routine, or to do
- * a full string comparison on the return of sv_reftype() both of which
- * make me feel worse! NOTE, do not modify this comment without reviewing the
- * corresponding comment in sv_reftype(). - Yves */
+ SV *referent = SvRV(sv);
+ const char *reftype = sv_reftype(referent, 0);
+ /* XXX: dodgy type check: This leaves me feeling dirty, but
+ * the alternative is to copy pretty much the entire
+ * sv_reftype() into this routine, or to do a full string
+ * comparison on the return of sv_reftype() both of which
+ * make me feel worse! NOTE, do not modify this comment
+ * without reviewing the corresponding comment in
+ * sv_reftype(). - Yves */
if (reftype[0] == 'S' || reftype[0] == 'L') {
- IV val= SvIV(referent);
+ IV val = SvIV(referent);
if (val <= 0) {
- tmpsv= &PL_sv_undef;
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
- SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
- );
+ sv_setsv(sv, PL_rs);
+ Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
+ val < 0 ? "a negative integer" : "zero");
}
} else {
- /* diag_listed_as: Setting $/ to %s reference is forbidden */
+ sv_setsv(sv, PL_rs);
+ /* diag_listed_as: Setting $/ to %s reference is forbidden */
Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
*reftype == 'A' ? "n" : "", reftype);
}
}
SvREFCNT_dec(PL_rs);
- PL_rs = newSVsv(tmpsv);
+ PL_rs = newSVsv(sv);
}
break;
case '\\':
#else
# define PERL_VMS_BANG 0
#endif
-#if defined(WIN32) && ! defined(UNDER_CE)
+#if defined(WIN32)
SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
(SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
#else
}
#ifdef HAS_SETRUID
PERL_UNUSED_RESULT(setruid(new_uid));
-#else
-#ifdef HAS_SETREUID
+#elif defined(HAS_SETREUID)
PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
-#else
-#ifdef HAS_SETRESUID
+#elif defined(HAS_SETRESUID)
PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
#else
if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
-#ifdef PERL_DARWIN
+# ifdef PERL_DARWIN
/* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
if (new_uid != 0 && PerlProc_getuid() == 0)
PERL_UNUSED_RESULT(PerlProc_setuid(0));
-#endif
+# endif
PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
} else {
Perl_croak(aTHX_ "setruid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case '>':
}
#ifdef HAS_SETEUID
PERL_UNUSED_RESULT(seteuid(new_euid));
-#else
-#ifdef HAS_SETREUID
+#elif defined(HAS_SETREUID)
PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
-#else
-#ifdef HAS_SETRESUID
+#elif defined(HAS_SETRESUID)
PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
#else
if (new_euid == PerlProc_getuid()) /* special case $> = $< */
Perl_croak(aTHX_ "seteuid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case '(':
}
#ifdef HAS_SETRGID
PERL_UNUSED_RESULT(setrgid(new_gid));
-#else
-#ifdef HAS_SETREGID
+#elif defined(HAS_SETREGID)
PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
-#else
-#ifdef HAS_SETRESGID
+#elif defined(HAS_SETRESGID)
PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
#else
if (new_gid == PerlProc_getegid()) /* special case $( = $) */
Perl_croak(aTHX_ "setrgid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case ')':
{
+/* (hv) best guess: maybe we'll need configure probes to do a better job,
+ * but you can override it if you need to.
+ */
+#ifndef INVALID_GID
+#define INVALID_GID ((Gid_t)-1)
+#endif
/* XXX $) currently silently ignores failures */
Gid_t new_egid;
#ifdef HAS_SETGROUPS
{
const char *p = SvPV_const(sv, len);
Groups_t *gary = NULL;
- const char* endptr;
+ const char* p_end = p + len;
+ const char* endptr = p_end;
+ UV uv;
#ifdef _SC_NGROUPS_MAX
int maxgrp = sysconf(_SC_NGROUPS_MAX);
while (isSPACE(*p))
++p;
- new_egid = (Gid_t)grok_atou(p, &endptr);
+ if (grok_atoUV(p, &uv, &endptr))
+ new_egid = (Gid_t)uv;
+ else {
+ new_egid = INVALID_GID;
+ endptr = NULL;
+ }
for (i = 0; i < maxgrp; ++i) {
if (endptr == NULL)
break;
p = endptr;
+ endptr = p_end;
while (isSPACE(*p))
++p;
if (!*p)
Newx(gary, i + 1, Groups_t);
else
Renew(gary, i + 1, Groups_t);
- gary[i] = (Groups_t)grok_atou(p, &endptr);
+ if (grok_atoUV(p, &uv, &endptr))
+ gary[i] = (Groups_t)uv;
+ else {
+ gary[i] = INVALID_GID;
+ endptr = NULL;
+ }
}
if (i)
PERL_UNUSED_RESULT(setgroups(i, gary));
}
#ifdef HAS_SETEGID
PERL_UNUSED_RESULT(setegid(new_egid));
-#else
-#ifdef HAS_SETREGID
+#elif defined(HAS_SETREGID)
PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
-#else
-#ifdef HAS_SETRESGID
+#elif defined(HAS_SETRESGID)
PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
#else
if (new_egid == PerlProc_getgid()) /* special case $) = $( */
Perl_croak(aTHX_ "setegid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case ':':
break;
case '0':
LOCK_DOLLARZERO_MUTEX;
-#ifdef HAS_SETPROCTITLE
- /* The BSDs don't show the argv[] in ps(1) output, they
- * show a string from the process struct and provide
- * the setproctitle() routine to manipulate that. */
- if (PL_origalen != 1) {
- s = SvPV_const(sv, len);
-# if __FreeBSD_version > 410001
- /* The leading "-" removes the "perl: " prefix,
- * but not the "(perl) suffix from the ps(1)
- * output, because that's what ps(1) shows if the
- * argv[] is modified. */
- setproctitle("-%s", s);
-# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
- /* This doesn't really work if you assume that
- * $0 = 'foobar'; will wipe out 'perl' from the $0
- * because in ps(1) output the result will be like
- * sprintf("perl: %s (perl)", s)
- * I guess this is a security feature:
- * one (a user process) cannot get rid of the original name.
- * --jhi */
- setproctitle("%s", s);
-# endif
- }
-#elif defined(__hpux) && defined(PSTAT_SETCMD)
- if (PL_origalen != 1) {
- union pstun un;
- s = SvPV_const(sv, len);
- un.pst_command = (char *)s;
- pstat(PSTAT_SETCMD, un, len, 0, 0);
- }
-#else
- if (PL_origalen > 1) {
- /* PL_origalen is set in perl_parse(). */
- s = SvPV_force(sv,len);
- if (len >= (STRLEN)PL_origalen-1) {
- /* Longer than original, will be truncated. We assume that
- * PL_origalen bytes are available. */
- Copy(s, PL_origargv[0], PL_origalen-1, char);
- }
- else {
- /* Shorter than original, will be padded. */
-#ifdef PERL_DARWIN
- /* Special case for Mac OS X: see [perl #38868] */
- const int pad = 0;
-#else
- /* Is the space counterintuitive? Yes.
- * (You were expecting \0?)
- * Does it work? Seems to. (In Linux 2.4.20 at least.)
- * --jhi */
- const int pad = ' ';
-#endif
- Copy(s, PL_origargv[0], len, char);
- PL_origargv[0][len] = 0;
- memset(PL_origargv[0] + len + 1,
- pad, PL_origalen - len - 1);
- }
- PL_origargv[0][PL_origalen-1] = 0;
- for (i = 1; i < PL_origargc; i++)
- PL_origargv[i] = 0;
-#ifdef HAS_PRCTL_SET_NAME
- /* Set the legacy process name in addition to the POSIX name on Linux */
- if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
- /* diag_listed_as: SKIPME */
- Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
- }
-#endif
- }
-#endif
+ S_set_dollarzero(aTHX_ sv);
UNLOCK_DOLLARZERO_MUTEX;
break;
}
return 0;
}
+/*
+=for apidoc_section $signals
+=for apidoc whichsig
+=for apidoc_item whichsig_pv
+=for apidoc_item whichsig_pvn
+=for apidoc_item whichsig_sv
+
+These all convert a signal name into its corresponding signal number;
+returning -1 if no corresponding number was found.
+
+They differ only in the source of the signal name:
+
+C<whichsig_pv> takes the name from the C<NUL>-terminated string starting at
+C<sig>.
+
+C<whichsig> is merely a different spelling, a synonym, of C<whichsig_pv>.
+
+C<whichsig_pvn> takes the name from the string starting at C<sig>, with length
+C<len> bytes.
+
+C<whichsig_sv> takes the name from the PV stored in the SV C<sigsv>.
+
+=cut
+*/
+
I32
Perl_whichsig_sv(pTHX_ SV *sigsv)
{
return -1;
}
+
+/* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3():
+ * these three function are intended to be called by the OS as 'C' level
+ * signal handler functions in the case where unsafe signals are being
+ * used - i.e. they immediately invoke Perl_perly_sighandler() to call the
+ * perl-level sighandler, rather than deferring.
+ * In fact, the core itself will normally use Perl_csighandler as the
+ * OS-level handler; that function will then decide whether to queue the
+ * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these
+ * functions are more useful for e.g. POSIX.xs when it wants explicit
+ * control of what's happening.
+ */
+
+
+#ifdef PERL_USE_3ARG_SIGHANDLER
+
Signal_t
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_sighandler(int sig, siginfo_t *sip, void *uap)
+Perl_sighandler(int sig, Siginfo_t *sip, void *uap)
+{
+ Perl_perly_sighandler(sig, sip, uap, 0);
+}
+
#else
+
+Signal_t
Perl_sighandler(int sig)
+{
+ Perl_perly_sighandler(sig, NULL, NULL, 0);
+}
+
#endif
+
+Signal_t
+Perl_sighandler1(int sig)
+{
+ Perl_perly_sighandler(sig, NULL, NULL, 0);
+}
+
+Signal_t
+Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
+{
+ Perl_perly_sighandler(sig, sip, uap, 0);
+}
+
+
+/* Invoke the perl-level signal handler. This function is called either
+ * directly from one of the C-level signals handlers (Perl_sighandler or
+ * Perl_csighandler), or for safe signals, later from
+ * Perl_despatch_signals() at a suitable safe point during execution.
+ *
+ * 'safe' is a boolean indicating the latter call path.
+ */
+
+Signal_t
+Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL,
+ void *uap PERL_UNUSED_DECL, bool safe)
{
#ifdef PERL_GET_SIG_CONTEXT
dTHXa(PERL_GET_SIG_CONTEXT);
: cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
if (hek)
Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
- "SIG%s handler \"%"HEKf"\" not defined.\n",
- PL_sig_name[sig], hek);
+ "SIG%s handler \"%" HEKf "\" not defined.\n",
+ PL_sig_name[sig], HEKfARG(hek));
/* diag_listed_as: SIG%s handler "%s" not defined */
else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
"SIG%s handler \"__ANON__\" not defined.\n",
PUSHSTACKi(PERLSI_SIGNAL);
PUSHMARK(SP);
PUSHs(sv);
+
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
{
struct sigaction oact;
- if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
- if (sip) {
- HV *sih = newHV();
- SV *rv = newRV_noinc(MUTABLE_SV(sih));
- /* The siginfo fields signo, code, errno, pid, uid,
- * addr, status, and band are defined by POSIX/SUSv3. */
- (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
- (void)hv_stores(sih, "code", newSViv(sip->si_code));
-#if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
- hv_stores(sih, "errno", newSViv(sip->si_errno));
- hv_stores(sih, "status", newSViv(sip->si_status));
- hv_stores(sih, "uid", newSViv(sip->si_uid));
- hv_stores(sih, "pid", newSViv(sip->si_pid));
- hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
- hv_stores(sih, "band", newSViv(sip->si_band));
-#endif
- EXTEND(SP, 2);
- PUSHs(rv);
- mPUSHp((char *)sip, sizeof(*sip));
- }
+ if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
+ HV *sih = newHV();
+ SV *rv = newRV_noinc(MUTABLE_SV(sih));
+ /* The siginfo fields signo, code, errno, pid, uid,
+ * addr, status, and band are defined by POSIX/SUSv3. */
+ (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
+ (void)hv_stores(sih, "code", newSViv(sip->si_code));
+# ifdef HAS_SIGINFO_SI_ERRNO
+ (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
+# endif
+# ifdef HAS_SIGINFO_SI_STATUS
+ (void)hv_stores(sih, "status", newSViv(sip->si_status));
+# endif
+# ifdef HAS_SIGINFO_SI_UID
+ {
+ SV *uid = newSV(0);
+ sv_setuid(uid, sip->si_uid);
+ (void)hv_stores(sih, "uid", uid);
+ }
+# endif
+# ifdef HAS_SIGINFO_SI_PID
+ (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
+# endif
+# ifdef HAS_SIGINFO_SI_ADDR
+ (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
+# endif
+# ifdef HAS_SIGINFO_SI_BAND
+ (void)hv_stores(sih, "band", newSViv(sip->si_band));
+# endif
+ EXTEND(SP, 2);
+ PUSHs(rv);
+ mPUSHp((char *)sip, sizeof(*sip));
}
}
#endif
+
PUTBACK;
errsv_save = newSVsv(ERRSV);
SV * const errsv = ERRSV;
if (SvTRUE_NN(errsv)) {
SvREFCNT_dec(errsv_save);
+
#ifndef PERL_MICRO
- /* Handler "died", for example to get out of a restart-able read().
- * Before we re-do that on its behalf re-enable the signal which was
- * blocked by the system when we entered.
- */
-#ifdef HAS_SIGPROCMASK
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
- if (sip || uap)
-#endif
- {
+ /* Handler "died", for example to get out of a restart-able read().
+ * Before we re-do that on its behalf re-enable the signal which was
+ * blocked by the system when we entered.
+ */
+# ifdef HAS_SIGPROCMASK
+ if (!safe) {
+ /* safe signals called via dispatch_signals() set up a
+ * savestack destructor, unblock_sigmask(), to
+ * automatically unblock the handler at the end. If
+ * instead we get here directly, we have to do it
+ * ourselves
+ */
sigset_t set;
sigemptyset(&set);
sigaddset(&set,sig);
sigprocmask(SIG_UNBLOCK, &set, NULL);
}
-#else
+# else
/* Not clear if this will work */
+ /* XXX not clear if this should be protected by 'if (safe)'
+ * too */
+
(void)rsignal(sig, SIG_IGN);
(void)rsignal(sig, PL_csighandlerp);
-#endif
+# endif
#endif /* !PERL_MICRO */
+
die_sv(errsv);
}
else {
}
}
-cleanup:
+ cleanup:
/* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
PL_savestack_ix = old_ss_ix;
if (flags & 8)
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
-#ifdef PERL_OLD_COPY_ON_WRITE
- /* While magic was saved (and off) sv_setsv may well have seen
- this SV as a prime candidate for COW. */
- if (SvIsCOW(sv))
- sv_force_normal_flags(sv, 0);
-#endif
if (mgs->mgs_flags)
SvFLAGS(sv) |= mgs->mgs_flags;
else
}
/*
+=for apidoc_section $magic
=for apidoc magic_sethint
-Triggered by a store to %^H, records the key/value pair to
+Triggered by a store to C<%^H>, records the key/value pair to
C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
anything that would need a deep copy. Maybe we should warn if we find a
reference.
PL_hints |= HINT_LOCALIZE_HH;
CopHINTHASH_set(&PL_compiling,
cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
+ magic_sethint_feature(key, NULL, 0, sv, 0);
return 0;
}
/*
=for apidoc magic_clearhint
-Triggered by a delete from %^H, records the key to
+Triggered by a delete from C<%^H>, records the key to
C<PL_compiling.cop_hints_hash>.
=cut
MUTABLE_SV(mg->mg_ptr), 0, 0)
: cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
mg->mg_ptr, mg->mg_len, 0, 0));
+ if (mg->mg_len == HEf_SVKEY)
+ magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE);
+ else
+ magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE);
return 0;
}
/*
=for apidoc magic_clearhints
-Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
+Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
=cut
*/
PERL_UNUSED_ARG(mg);
cophh_free(CopHINTHASH_get(&PL_compiling));
CopHINTHASH_set(&PL_compiling, cophh_new_empty());
+ CLEARFEATUREBITS();
return 0;
}
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/