*/
/*
-=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
if (vtbl && vtbl->svt_free)
vtbl->svt_free(aTHX_ sv, mg);
- if (mg->mg_type == PERL_MAGIC_collxfrm && mg->mg_len >= 0)
- /* collate magic uses string len not buffer len, so
- * free even with mg_len == 0 */
+ if (mg->mg_len > 0)
Safefree(mg->mg_ptr);
- else 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));
- }
+ 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);
}
/*
+=for apidoc_section $errno
=for apidoc sv_string_from_errnum
Generates the message string describing an OS error and returns it as
if (nextchar == '\0') {
sv_setiv(sv, (IV)PL_maxsysfd);
}
- else if (strEQ(remaining, "EATURE_BITS")) {
- sv_setuv(sv, PL_compiling.cop_features);
- }
break;
case '\007': /* ^GLOBAL_PHASE */
if (strEQ(remaining, "LOBAL_PHASE")) {
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 {
}
/*
+=for apidoc_section $magic
=for apidoc magic_methcall
Invoke a magic method (like FETCH).
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)
{
}
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;
PERL_TSA_REQUIRES(PL_dollarzero_mutex)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
const char *s;
STRLEN len;
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
I32 paren;
const REGEXP * rx;
if (mg->mg_ptr[1] == '\0') {
PL_maxsysfd = SvIV(sv);
}
- else if (strEQ(mg->mg_ptr + 1, "EATURE_BITS")) {
- PL_compiling.cop_features = SvUV(sv);
- }
break;
case '\010': /* ^H */
{
else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
if (!SvPOK(sv)) {
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_STD;
+ free_and_set_cop_warnings(&PL_compiling, pWARN_STD);
break;
}
{
not_all |= ptr[i] ^ 0x55;
}
if (!not_none) {
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_NONE;
+ free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
} else if (len >= WARNsize && !not_all) {
- 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,
+ 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 = (bool)sv_true(sv);
+ w32_sloppystat = SvTRUE(sv);
}
#endif
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)
{
}
/*
+=for apidoc_section $magic
=for apidoc magic_sethint
Triggered by a store to C<%^H>, records the key/value pair to
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;
}
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;
}
PERL_UNUSED_ARG(mg);
cophh_free(CopHINTHASH_get(&PL_compiling));
CopHINTHASH_set(&PL_compiling, cophh_new_empty());
+ CLEARFEATUREBITS();
return 0;
}
https://perl5.git.perl.org / perl5.git / blobdiff