This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
mg.c: Extract code into a function.
[perl5.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW
9 */
10
11/*
4ac71550
TC
12 * Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent.
14 *
15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
79072805
LW
16 */
17
ccfc67b7
JH
18/*
19=head1 Magical Functions
166f8a29
DM
20
21"Magic" is special data attached to SV structures in order to give them
22"magical" properties. When any Perl code tries to read from, or assign to,
23an SV marked as magical, it calls the 'get' or 'set' function associated
24with that SV's magic. A get is called prior to reading an SV, in order to
ddfa107c 25give it a chance to update its internal value (get on $. writes the line
166f8a29
DM
26number of the last read filehandle into to the SV's IV slot), while
27set is called after an SV has been written to, in order to allow it to make
ddfa107c 28use of its changed value (set on $/ copies the SV's new value to the
166f8a29
DM
29PL_rs global variable).
30
31Magic is implemented as a linked list of MAGIC structures attached to the
32SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33of functions that implement the get(), set(), length() etc functions,
34plus space for some flags and pointers. For example, a tied variable has
35a MAGIC structure that contains a pointer to the object associated with the
36tie.
37
ccfc67b7
JH
38*/
39
79072805 40#include "EXTERN.h"
864dbfa3 41#define PERL_IN_MG_C
79072805
LW
42#include "perl.h"
43
5cd24f17 44#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
b7953727
JH
45# ifdef I_GRP
46# include <grp.h>
47# endif
188ea221
CS
48#endif
49
757f63d8
SP
50#if defined(HAS_SETGROUPS)
51# ifndef NGROUPS
52# define NGROUPS 32
53# endif
54#endif
55
17aa7f3d
JH
56#ifdef __hpux
57# include <sys/pstat.h>
58#endif
59
7636ea95
AB
60#ifdef HAS_PRCTL_SET_NAME
61# include <sys/prctl.h>
62#endif
63
8aad04aa 64#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b6455c53 65Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
8aad04aa 66#else
e69880a5 67Signal_t Perl_csighandler(int sig);
8aad04aa 68#endif
e69880a5 69
9cffb111
OS
70#ifdef __Lynx__
71/* Missing protos on LynxOS */
72void setruid(uid_t id);
73void seteuid(uid_t id);
74void setrgid(uid_t id);
75void setegid(uid_t id);
76#endif
77
c07a80fd 78/*
4bac9ae4 79 * Pre-magic setup and post-magic takedown.
c07a80fd
PP
80 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 */
82
83struct magic_state {
84 SV* mgs_sv;
455ece5e 85 I32 mgs_ss_ix;
f9c6fee5
CS
86 U32 mgs_magical;
87 bool mgs_readonly;
150b625d 88 bool mgs_bumped;
c07a80fd 89};
455ece5e 90/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e
GS
91
92STATIC void
ff44333e 93S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
c07a80fd 94{
97aff369 95 dVAR;
455ece5e 96 MGS* mgs;
150b625d 97 bool bumped = FALSE;
7918f24d 98
ff44333e 99 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
7918f24d 100
4bac9ae4
CS
101 assert(SvMAGICAL(sv));
102
150b625d
DM
103 /* we shouldn't really be called here with RC==0, but it can sometimes
104 * happen via mg_clear() (which also shouldn't be called when RC==0,
105 * but it can happen). Handle this case gracefully(ish) by not RC++
106 * and thus avoiding the resultant double free */
107 if (SvREFCNT(sv) > 0) {
108 /* guard against sv getting freed midway through the mg clearing,
109 * by holding a private reference for the duration. */
110 SvREFCNT_inc_simple_void_NN(sv);
111 bumped = TRUE;
112 }
8985fe98 113
8772537c 114 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
455ece5e
AD
115
116 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd 117 mgs->mgs_sv = sv;
f9c6fee5 118 mgs->mgs_magical = SvMAGICAL(sv);
46959f1c 119 mgs->mgs_readonly = SvREADONLY(sv) != 0;
455ece5e 120 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
150b625d 121 mgs->mgs_bumped = bumped;
c07a80fd 122
ff44333e 123 SvFLAGS(sv) &= ~flags;
3805b5fb 124 SvREADONLY_off(sv);
c07a80fd
PP
125}
126
ff44333e
FC
127#define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
128
954c1994
GS
129/*
130=for apidoc mg_magical
131
132Turns on the magical status of an SV. See C<sv_magic>.
133
134=cut
135*/
136
8990e307 137void
864dbfa3 138Perl_mg_magical(pTHX_ SV *sv)
8990e307 139{
e1ec3a88 140 const MAGIC* mg;
7918f24d 141 PERL_ARGS_ASSERT_MG_MAGICAL;
96a5add6 142 PERL_UNUSED_CONTEXT;
f9c6fee5
CS
143
144 SvMAGICAL_off(sv);
218787bd 145 if ((mg = SvMAGIC(sv))) {
218787bd
VP
146 do {
147 const MGVTBL* const vtbl = mg->mg_virtual;
148 if (vtbl) {
149 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
150 SvGMAGICAL_on(sv);
151 if (vtbl->svt_set)
152 SvSMAGICAL_on(sv);
153 if (vtbl->svt_clear)
154 SvRMAGICAL_on(sv);
155 }
156 } while ((mg = mg->mg_moremagic));
157 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
158 SvRMAGICAL_on(sv);
8990e307
LW
159 }
160}
161
954c1994
GS
162/*
163=for apidoc mg_get
164
4b1e7f06
DD
165Do magic before a value is retrieved from the SV. The type of SV must
166be >= SVt_PVMG. See C<sv_magic>.
954c1994
GS
167
168=cut
169*/
170
79072805 171int
864dbfa3 172Perl_mg_get(pTHX_ SV *sv)
79072805 173{
97aff369 174 dVAR;
35a4481c 175 const I32 mgs_ix = SSNEW(sizeof(MGS));
a9844598 176 bool saved = FALSE;
f9c6fee5 177 bool have_new = 0;
ff76feab 178 MAGIC *newmg, *head, *cur, *mg;
6683b158 179
7918f24d
NC
180 PERL_ARGS_ASSERT_MG_GET;
181
407287f9
FC
182 if (PL_localizing == 1 && sv == DEFSV) return 0;
183
ff76feab
AMS
184 /* We must call svt_get(sv, mg) for each valid entry in the linked
185 list of magic. svt_get() may delete the current entry, add new
186 magic to the head of the list, or upgrade the SV. AMS 20010810 */
187
188 newmg = cur = head = mg = SvMAGIC(sv);
189 while (mg) {
35a4481c 190 const MGVTBL * const vtbl = mg->mg_virtual;
f9c6fee5 191 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
ff76feab 192
2b260de0 193 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
a9844598
CS
194
195 /* taint's mg get is so dumb it doesn't need flag saving */
196 if (!saved && mg->mg_type != PERL_MAGIC_taint) {
197 save_magic(mgs_ix, sv);
198 saved = TRUE;
199 }
200
16c91539 201 vtbl->svt_get(aTHX_ sv, mg);
b77f7d40 202
58f82c5c
DM
203 /* guard against magic having been deleted - eg FETCH calling
204 * untie */
f9c6fee5
CS
205 if (!SvMAGIC(sv)) {
206 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
58f82c5c 207 break;
f9c6fee5 208 }
b77f7d40 209
f9c6fee5 210 /* recalculate flags if this entry was deleted. */
ff76feab 211 if (mg->mg_flags & MGf_GSKIP)
f9c6fee5 212 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
a0d0e21e 213 }
7d1328bb
FC
214 else if (vtbl == &PL_vtbl_utf8) {
215 /* get-magic can reallocate the PV */
216 magic_setutf8(sv, mg);
217 }
ff76feab 218
f9c6fee5 219 mg = nextmg;
ff76feab 220
0723351e 221 if (have_new) {
ff76feab
AMS
222 /* Have we finished with the new entries we saw? Start again
223 where we left off (unless there are more new entries). */
224 if (mg == head) {
0723351e 225 have_new = 0;
ff76feab
AMS
226 mg = cur;
227 head = newmg;
228 }
229 }
230
231 /* Were any new entries added? */
0723351e
NC
232 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
233 have_new = 1;
ff76feab
AMS
234 cur = mg;
235 mg = newmg;
f9c6fee5 236 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
760ac839 237 }
79072805 238 }
463ee0b2 239
a9844598
CS
240 if (saved)
241 restore_magic(INT2PTR(void *, (IV)mgs_ix));
242
79072805
LW
243 return 0;
244}
245
954c1994
GS
246/*
247=for apidoc mg_set
248
249Do magic after a value is assigned to the SV. See C<sv_magic>.
250
251=cut
252*/
253
79072805 254int
864dbfa3 255Perl_mg_set(pTHX_ SV *sv)
79072805 256{
97aff369 257 dVAR;
35a4481c 258 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 259 MAGIC* mg;
463ee0b2
LW
260 MAGIC* nextmg;
261
7918f24d
NC
262 PERL_ARGS_ASSERT_MG_SET;
263
b5ed8c44
FC
264 if (PL_localizing == 2 && sv == DEFSV) return 0;
265
ff44333e 266 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
463ee0b2
LW
267
268 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
e1ec3a88 269 const MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 270 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e
LW
271 if (mg->mg_flags & MGf_GSKIP) {
272 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
f9c6fee5 273 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
a0d0e21e 274 }
e0a73de4 275 if (PL_localizing == 2
b5ed8c44 276 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
e7cbf6c6 277 continue;
2b260de0 278 if (vtbl && vtbl->svt_set)
16c91539 279 vtbl->svt_set(aTHX_ sv, mg);
79072805 280 }
463ee0b2 281
8772537c 282 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW
283 return 0;
284}
285
954c1994
GS
286/*
287=for apidoc mg_length
288
d4e99c76 289Reports on the SV's length in bytes, calling length magic if available,
bd8446cf
FC
290but does not set the UTF8 flag on the sv. It will fall back to 'get'
291magic if there is no 'length' magic, but with no indication as to
292whether it called 'get' magic. It assumes the sv is a PVMG or
293higher. Use sv_len() instead.
954c1994
GS
294
295=cut
296*/
297
79072805 298U32
864dbfa3 299Perl_mg_length(pTHX_ SV *sv)
79072805 300{
97aff369 301 dVAR;
79072805 302 MAGIC* mg;
463ee0b2 303 STRLEN len;
463ee0b2 304
7918f24d
NC
305 PERL_ARGS_ASSERT_MG_LENGTH;
306
79072805 307 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 308 const MGVTBL * const vtbl = mg->mg_virtual;
2b260de0 309 if (vtbl && vtbl->svt_len) {
35a4481c 310 const I32 mgs_ix = SSNEW(sizeof(MGS));
455ece5e 311 save_magic(mgs_ix, sv);
a0d0e21e 312 /* omit MGf_GSKIP -- not changed here */
16c91539 313 len = vtbl->svt_len(aTHX_ sv, mg);
8772537c 314 restore_magic(INT2PTR(void*, (IV)mgs_ix));
85e6fe83
LW
315 return len;
316 }
317 }
318
bd8446cf 319 (void)SvPV_const(sv, len);
463ee0b2 320 return len;
79072805
LW
321}
322
8fb26106 323I32
864dbfa3 324Perl_mg_size(pTHX_ SV *sv)
93965878
NIS
325{
326 MAGIC* mg;
ac27b0f5 327
7918f24d
NC
328 PERL_ARGS_ASSERT_MG_SIZE;
329
93965878 330 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 331 const MGVTBL* const vtbl = mg->mg_virtual;
2b260de0 332 if (vtbl && vtbl->svt_len) {
35a4481c
AL
333 const I32 mgs_ix = SSNEW(sizeof(MGS));
334 I32 len;
455ece5e 335 save_magic(mgs_ix, sv);
93965878 336 /* omit MGf_GSKIP -- not changed here */
16c91539 337 len = vtbl->svt_len(aTHX_ sv, mg);
8772537c 338 restore_magic(INT2PTR(void*, (IV)mgs_ix));
93965878
NIS
339 return len;
340 }
341 }
342
343 switch(SvTYPE(sv)) {
344 case SVt_PVAV:
502c6561 345 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
93965878
NIS
346 case SVt_PVHV:
347 /* FIXME */
348 default:
cea2e8a9 349 Perl_croak(aTHX_ "Size magic not implemented");
93965878
NIS
350 break;
351 }
352 return 0;
353}
354
954c1994
GS
355/*
356=for apidoc mg_clear
357
358Clear something magical that the SV represents. See C<sv_magic>.
359
360=cut
361*/
362
79072805 363int
864dbfa3 364Perl_mg_clear(pTHX_ SV *sv)
79072805 365{
35a4481c 366 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 367 MAGIC* mg;
8ac77ac9 368 MAGIC *nextmg;
463ee0b2 369
7918f24d
NC
370 PERL_ARGS_ASSERT_MG_CLEAR;
371
455ece5e 372 save_magic(mgs_ix, sv);
463ee0b2 373
8ac77ac9 374 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
35a4481c 375 const MGVTBL* const vtbl = mg->mg_virtual;
a0d0e21e 376 /* omit GSKIP -- never set here */
727405f8 377
8ac77ac9
NC
378 nextmg = mg->mg_moremagic; /* it may delete itself */
379
2b260de0 380 if (vtbl && vtbl->svt_clear)
16c91539 381 vtbl->svt_clear(aTHX_ sv, mg);
79072805 382 }
463ee0b2 383
8772537c 384 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW
385 return 0;
386}
387
ed624ca8 388static MAGIC*
39de7f53
FR
389S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
390{
391 PERL_UNUSED_CONTEXT;
392
393 assert(flags <= 1);
394
395 if (sv) {
396 MAGIC *mg;
397
7db6405c
FC
398 assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
399
39de7f53
FR
400 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
401 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
402 return mg;
403 }
404 }
405 }
406
407 return NULL;
408}
409
954c1994
GS
410/*
411=for apidoc mg_find
412
413Finds the magic pointer for type matching the SV. See C<sv_magic>.
414
415=cut
416*/
417
93a17b20 418MAGIC*
35a4481c 419Perl_mg_find(pTHX_ const SV *sv, int type)
93a17b20 420{
39de7f53
FR
421 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
422}
423
424/*
425=for apidoc mg_findext
426
427Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
428C<sv_magicext>.
429
430=cut
431*/
432
433MAGIC*
434Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
435{
436 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
93a17b20
LW
437}
438
96c2a8ff
FC
439MAGIC *
440Perl_mg_find_mglob(pTHX_ SV *sv)
441{
442 PERL_ARGS_ASSERT_MG_FIND_MGLOB;
443 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
444 /* This sv is only a delegate. //g magic must be attached to
445 its target. */
446 vivify_defelem(sv);
447 sv = LvTARG(sv);
448 }
449 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
450 return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0);
451 return NULL;
452}
453
954c1994
GS
454/*
455=for apidoc mg_copy
456
457Copies the magic from one SV to another. See C<sv_magic>.
458
459=cut
460*/
461
79072805 462int
864dbfa3 463Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 464{
463ee0b2 465 int count = 0;
79072805 466 MAGIC* mg;
7918f24d
NC
467
468 PERL_ARGS_ASSERT_MG_COPY;
469
463ee0b2 470 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 471 const MGVTBL* const vtbl = mg->mg_virtual;
68795e93 472 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
16c91539 473 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
68795e93 474 }
823a54a3
AL
475 else {
476 const char type = mg->mg_type;
1e73acc8 477 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
823a54a3
AL
478 sv_magic(nsv,
479 (type == PERL_MAGIC_tied)
480 ? SvTIED_obj(sv, mg)
481 : (type == PERL_MAGIC_regdata && mg->mg_obj)
482 ? sv
483 : mg->mg_obj,
484 toLOWER(type), key, klen);
485 count++;
486 }
79072805 487 }
79072805 488 }
463ee0b2 489 return count;
79072805
LW
490}
491
954c1994 492/*
0cbee0a4
DM
493=for apidoc mg_localize
494
9711599e
CS
495Copy some of the magic from an existing SV to new localized version of that
496SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
497taint, pos).
498
af7df257 499If setmagic is false then no set magic will be called on the new (empty) SV.
9711599e
CS
500This typically means that assignment will soon follow (e.g. 'local $x = $y'),
501and that will handle the magic.
0cbee0a4
DM
502
503=cut
504*/
505
506void
af7df257 507Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
0cbee0a4 508{
97aff369 509 dVAR;
0cbee0a4 510 MAGIC *mg;
7918f24d
NC
511
512 PERL_ARGS_ASSERT_MG_LOCALIZE;
513
658a9f31
JD
514 if (nsv == DEFSV)
515 return;
516
0cbee0a4 517 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
2b1b43ea 518 const MGVTBL* const vtbl = mg->mg_virtual;
e0a73de4 519 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
0cbee0a4 520 continue;
0cbee0a4 521
a5063e7c 522 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
16c91539 523 (void)vtbl->svt_local(aTHX_ nsv, mg);
a5063e7c 524 else
0cbee0a4
DM
525 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
526 mg->mg_ptr, mg->mg_len);
a5063e7c 527
0cbee0a4 528 /* container types should remain read-only across localization */
9ff3e6d8 529 SvFLAGS(nsv) |= SvREADONLY(sv);
0cbee0a4
DM
530 }
531
532 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
533 SvFLAGS(nsv) |= SvMAGICAL(sv);
af7df257 534 if (setmagic) {
9711599e
CS
535 PL_localizing = 1;
536 SvSETMAGIC(nsv);
537 PL_localizing = 0;
538 }
0cbee0a4
DM
539 }
540}
541
d9088386
Z
542#define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
543static void
544S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
545{
546 const MGVTBL* const vtbl = mg->mg_virtual;
547 if (vtbl && vtbl->svt_free)
548 vtbl->svt_free(aTHX_ sv, mg);
549 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
550 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
551 Safefree(mg->mg_ptr);
552 else if (mg->mg_len == HEf_SVKEY)
553 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
554 }
555 if (mg->mg_flags & MGf_REFCOUNTED)
556 SvREFCNT_dec(mg->mg_obj);
557 Safefree(mg);
558}
559
0cbee0a4 560/*
954c1994
GS
561=for apidoc mg_free
562
563Free any magic storage used by the SV. See C<sv_magic>.
564
565=cut
566*/
567
79072805 568int
864dbfa3 569Perl_mg_free(pTHX_ SV *sv)
79072805
LW
570{
571 MAGIC* mg;
572 MAGIC* moremagic;
7918f24d
NC
573
574 PERL_ARGS_ASSERT_MG_FREE;
575
79072805 576 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
79072805 577 moremagic = mg->mg_moremagic;
d9088386 578 mg_free_struct(sv, mg);
c826f41b 579 SvMAGIC_set(sv, moremagic);
79072805 580 }
b162af07 581 SvMAGIC_set(sv, NULL);
68f8932e 582 SvMAGICAL_off(sv);
79072805
LW
583 return 0;
584}
585
d9088386
Z
586/*
587=for apidoc Am|void|mg_free_type|SV *sv|int how
588
589Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
590
591=cut
592*/
593
594void
595Perl_mg_free_type(pTHX_ SV *sv, int how)
596{
597 MAGIC *mg, *prevmg, *moremg;
598 PERL_ARGS_ASSERT_MG_FREE_TYPE;
599 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
600 MAGIC *newhead;
601 moremg = mg->mg_moremagic;
602 if (mg->mg_type == how) {
603 /* temporarily move to the head of the magic chain, in case
604 custom free code relies on this historical aspect of mg_free */
605 if (prevmg) {
606 prevmg->mg_moremagic = moremg;
607 mg->mg_moremagic = SvMAGIC(sv);
608 SvMAGIC_set(sv, mg);
609 }
610 newhead = mg->mg_moremagic;
611 mg_free_struct(sv, mg);
612 SvMAGIC_set(sv, newhead);
613 mg = prevmg;
614 }
615 }
616 mg_magical(sv);
617}
618
79072805 619#include <signal.h>
79072805 620
942e002e 621U32
864dbfa3 622Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 623{
97aff369 624 dVAR;
8772537c 625 PERL_UNUSED_ARG(sv);
6cef1e77 626
7918f24d
NC
627 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
628
0bd48802 629 if (PL_curpm) {
eb578fdb 630 const REGEXP * const rx = PM_GETRE(PL_curpm);
0bd48802 631 if (rx) {
a678b0e4
YO
632 if (mg->mg_obj) { /* @+ */
633 /* return the number possible */
07bc277f 634 return RX_NPARENS(rx);
a678b0e4 635 } else { /* @- */
07bc277f 636 I32 paren = RX_LASTPAREN(rx);
a678b0e4
YO
637
638 /* return the last filled */
f46c4081 639 while ( paren >= 0
07bc277f
NC
640 && (RX_OFFS(rx)[paren].start == -1
641 || RX_OFFS(rx)[paren].end == -1) )
f46c4081 642 paren--;
a678b0e4
YO
643 return (U32)paren;
644 }
0bd48802 645 }
8f580fb8 646 }
ac27b0f5 647
942e002e 648 return (U32)-1;
6cef1e77
IZ
649}
650
6502e081
DM
651/* @-, @+ */
652
6cef1e77 653int
864dbfa3 654Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 655{
97aff369 656 dVAR;
7918f24d
NC
657
658 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
659
0bd48802 660 if (PL_curpm) {
eb578fdb 661 const REGEXP * const rx = PM_GETRE(PL_curpm);
0bd48802 662 if (rx) {
eb578fdb 663 const I32 paren = mg->mg_len;
a10eae29
FC
664 SSize_t s;
665 SSize_t t;
0bd48802
AL
666 if (paren < 0)
667 return 0;
07bc277f
NC
668 if (paren <= (I32)RX_NPARENS(rx) &&
669 (s = RX_OFFS(rx)[paren].start) != -1 &&
670 (t = RX_OFFS(rx)[paren].end) != -1)
0bd48802 671 {
a10eae29 672 SSize_t i;
0bd48802
AL
673 if (mg->mg_obj) /* @+ */
674 i = t;
675 else /* @- */
676 i = s;
677
a10eae29 678 if (RX_MATCH_UTF8(rx)) {
07bc277f 679 const char * const b = RX_SUBBEG(rx);
0bd48802 680 if (b)
6502e081
DM
681 i = RX_SUBCOFFSET(rx) +
682 utf8_length((U8*)b,
683 (U8*)(b-RX_SUBOFFSET(rx)+i));
0bd48802 684 }
727405f8 685
a10eae29 686 sv_setuv(sv, i);
232af1f8 687 return 0;
1aa99e6b 688 }
0bd48802 689 }
6cef1e77 690 }
232af1f8 691 sv_setsv(sv, NULL);
6cef1e77
IZ
692 return 0;
693}
694
6502e081
DM
695/* @-, @+ */
696
e4b89193 697int
a29d06ed
MG
698Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
699{
7918f24d 700 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
d4c19fe8
AL
701 PERL_UNUSED_ARG(sv);
702 PERL_UNUSED_ARG(mg);
cb077ed2 703 Perl_croak_no_modify();
0dbb1585 704 NORETURN_FUNCTION_END;
a29d06ed
MG
705}
706
ad3296c6 707#define SvRTRIM(sv) STMT_START { \
eae92ea0
GA
708 if (SvPOK(sv)) { \
709 STRLEN len = SvCUR(sv); \
710 char * const p = SvPVX(sv); \
8e6b4db6
PC
711 while (len > 0 && isSPACE(p[len-1])) \
712 --len; \
713 SvCUR_set(sv, len); \
714 p[len] = '\0'; \
715 } \
ad3296c6
SH
716} STMT_END
717
8b850bd5
NC
718void
719Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
720{
7918f24d
NC
721 PERL_ARGS_ASSERT_EMULATE_COP_IO;
722
8b850bd5
NC
723 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
724 sv_setsv(sv, &PL_sv_undef);
725 else {
726 sv_setpvs(sv, "");
727 SvUTF8_off(sv);
728 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
20439bc7 729 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
8b850bd5
NC
730 assert(value);
731 sv_catsv(sv, value);
732 }
733 sv_catpvs(sv, "\0");
734 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
20439bc7 735 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
8b850bd5
NC
736 assert(value);
737 sv_catsv(sv, value);
738 }
739 }
740}
741
d9fe7d23
KW
742STATIC void
743S_fixup_errno_string(pTHX_ SV* sv)
744{
745 /* Do what is necessary to fixup the non-empty string in 'sv' for return to
746 * Perl space. */
747
748 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
749
750 assert(SvOK(sv));
751 assert(strNE(SvPVX(sv), ""));
752
753 /* In some locales the error string may come back as UTF-8, in
754 * which case we should turn on that flag. This didn't use to
755 * happen, and to avoid any possible backward compatibility issues,
756 * we don't turn on the flag unless we have to. So the flag stays
757 * off for an entirely ASCII string. We assume that if the string
758 * looks like UTF-8, it really is UTF-8: "text in any other
759 * encoding that uses bytes with the high bit set is extremely
760 * unlikely to pass a UTF-8 validity test"
761 * (http://en.wikipedia.org/wiki/Charset_detection). There is a
762 * potential that we will get it wrong however, especially on short
763 * error message text. (If it turns out to be necessary, we could
764 * also keep track if the current LC_MESSAGES locale is UTF-8) */
765 if (! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
766 && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
767 {
768 SvUTF8_on(sv);
769 }
770}
771
25bbd826
CB
772#ifdef VMS
773#include <descrip.h>
774#include <starlet.h>
775#endif
776
79072805 777int
864dbfa3 778Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805 779{
27da23d5 780 dVAR;
eb578fdb
KW
781 I32 paren;
782 const char *s = NULL;
783 REGEXP *rx;
823a54a3 784 const char * const remaining = mg->mg_ptr + 1;
e91d8259 785 char nextchar;
79072805 786
7918f24d
NC
787 PERL_ARGS_ASSERT_MAGIC_GET;
788
e91d8259 789 if (!mg->mg_ptr) {
e91d8259 790 paren = mg->mg_len;
e91d8259 791 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
a6d0b1b5 792 do_numbuf_fetch:
e91d8259
NC
793 CALLREG_NUMBUF_FETCH(rx,paren,sv);
794 } else {
795 sv_setsv(sv,&PL_sv_undef);
796 }
797 return 0;
798 }
799
800 nextchar = *remaining;
79072805 801 switch (*mg->mg_ptr) {
748a9306 802 case '\001': /* ^A */
f2da823f
FC
803 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
804 else sv_setsv(sv, &PL_sv_undef);
125b9982
NT
805 if (SvTAINTED(PL_bodytarget))
806 SvTAINTED_on(sv);
748a9306 807 break;
e5218da5 808 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
823a54a3 809 if (nextchar == '\0') {
e5218da5
GA
810 sv_setiv(sv, (IV)PL_minus_c);
811 }
823a54a3 812 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
e5218da5
GA
813 sv_setiv(sv, (IV)STATUS_NATIVE);
814 }
49460fe6
NIS
815 break;
816
79072805 817 case '\004': /* ^D */
aea4f609 818 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
79072805 819 break;
28f23441 820 case '\005': /* ^E */
6c6eab55
KW
821 if (nextchar != '\0') {
822 if (strEQ(remaining, "NCODING"))
823 sv_setsv(sv, PL_encoding);
4f4ff3a7 824 break;
6c6eab55 825 }
4f4ff3a7
KW
826
827#if defined(VMS) || defined(OS2) || defined(WIN32)
828# if defined(VMS)
2a99ff86
KW
829 {
830 char msg[255];
831 $DESCRIPTOR(msgdsc,msg);
832 sv_setnv(sv,(NV) vaxc$errno);
833 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
834 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
835 else
836 sv_setpvs(sv,"");
837 }
4b645107 838#elif defined(OS2)
2a99ff86
KW
839 if (!(_emx_env & 0x200)) { /* Under DOS */
840 sv_setnv(sv, (NV)errno);
841 sv_setpv(sv, errno ? Strerror(errno) : "");
842 } else {
843 if (errno != errno_isOS2) {
844 const int tmp = _syserrno();
845 if (tmp) /* 2nd call to _syserrno() makes it 0 */
846 Perl_rc = tmp;
847 }
848 sv_setnv(sv, (NV)Perl_rc);
849 sv_setpv(sv, os2error(Perl_rc));
850 }
4f4ff3a7 851# elif defined(WIN32)
2a99ff86
KW
852 {
853 const DWORD dwErr = GetLastError();
854 sv_setnv(sv, (NV)dwErr);
855 if (dwErr) {
856 PerlProc_GetOSError(sv, dwErr);
857 }
858 else
859 sv_setpvs(sv, "");
860 SetLastError(dwErr);
861 }
4f4ff3a7
KW
862# else
863# error Missing code for platform
864# endif
2a99ff86
KW
865 SvRTRIM(sv);
866 SvNOK_on(sv); /* what a wonderful hack! */
867 break;
4f4ff3a7
KW
868#endif /* End of platforms with special handling for $^E; others just fall
869 through to $! */
46f3e16c
KW
870
871 case '!':
872 {
873 dSAVE_ERRNO;
874#ifdef VMS
875 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
876#else
877 sv_setnv(sv, (NV)errno);
878#endif
879#ifdef OS2
880 if (errno == errno_isOS2 || errno == errno_isOS2_set)
881 sv_setpv(sv, os2error(Perl_rc));
882 else
883#endif
884 if (! errno) {
885 sv_setpvs(sv, "");
886 }
887 else {
888
889 /* Strerror can return NULL on some platforms, which will result in
890 * 'sv' not being considered SvOK. The SvNOK_on() below will cause
891 * just the number part to be valid */
892 sv_setpv(sv, Strerror(errno));
d9fe7d23
KW
893 if (SvOK(sv)) {
894 fixup_errno_string(sv);
46f3e16c
KW
895 }
896 }
897 RESTORE_ERRNO;
898 }
899
900 SvRTRIM(sv);
901 SvNOK_on(sv); /* what a wonderful hack! */
902 break;
903
79072805 904 case '\006': /* ^F */
3280af22 905 sv_setiv(sv, (IV)PL_maxsysfd);
79072805 906 break;
9ebf26ad
FR
907 case '\007': /* ^GLOBAL_PHASE */
908 if (strEQ(remaining, "LOBAL_PHASE")) {
909 sv_setpvn(sv, PL_phase_names[PL_phase],
910 strlen(PL_phase_names[PL_phase]));
911 }
912 break;
a0d0e21e 913 case '\010': /* ^H */
3280af22 914 sv_setiv(sv, (IV)PL_hints);
a0d0e21e 915 break;
9d116dd7 916 case '\011': /* ^I */ /* NOT \t in EBCDIC */
120f7abe 917 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
79072805 918 break;
8561ea1d
FC
919 case '\014': /* ^LAST_FH */
920 if (strEQ(remaining, "AST_FH")) {
921 if (PL_last_in_gv) {
922 assert(isGV_with_GP(PL_last_in_gv));
923 SV_CHECK_THINKFIRST_COW_DROP(sv);
924 prepare_SV_for_RV(sv);
925 SvOK_off(sv);
926 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
927 SvROK_on(sv);
928 sv_rvweaken(sv);
929 }
930 else sv_setsv_nomg(sv, NULL);
931 }
932 break;
ac27b0f5 933 case '\017': /* ^O & ^OPEN */
823a54a3 934 if (nextchar == '\0') {
ac27b0f5 935 sv_setpv(sv, PL_osname);
3511154c
DM
936 SvTAINTED_off(sv);
937 }
823a54a3 938 else if (strEQ(remaining, "PEN")) {
8b850bd5 939 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
ac27b0f5 940 }
28f23441 941 break;
9ebf26ad 942 case '\020':
a6d0b1b5 943 sv_setiv(sv, (IV)PL_perldb);
79072805 944 break;
fb73857a 945 case '\023': /* ^S */
a6d0b1b5 946 {
bc177e6b 947 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
0c34ef67 948 SvOK_off(sv);
3280af22 949 else if (PL_in_eval)
6dc8a9e4 950 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
a4268c0a
AMS
951 else
952 sv_setiv(sv, 0);
d58bf5aa 953 }
fb73857a 954 break;
79072805 955 case '\024': /* ^T */
823a54a3 956 if (nextchar == '\0') {
88e89b8a 957#ifdef BIG_TIME
7c36658b 958 sv_setnv(sv, PL_basetime);
88e89b8a 959#else
7c36658b 960 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 961#endif
7c36658b 962 }
823a54a3 963 else if (strEQ(remaining, "AINT"))
284167a5
SM
964 sv_setiv(sv, TAINTING_get
965 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
9aa05f58 966 : 0);
7c36658b 967 break;
e07ea26a 968 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
823a54a3 969 if (strEQ(remaining, "NICODE"))
a05d7ebb 970 sv_setuv(sv, (UV) PL_unicode);
823a54a3 971 else if (strEQ(remaining, "TF8LOCALE"))
7cebcbc0 972 sv_setuv(sv, (UV) PL_utf8locale);
e07ea26a
NC
973 else if (strEQ(remaining, "TF8CACHE"))
974 sv_setiv(sv, (IV) PL_utf8cache);
fde18df1
JH
975 break;
976 case '\027': /* ^W & $^WARNING_BITS */
823a54a3 977 if (nextchar == '\0')
4438c4b7 978 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
823a54a3 979 else if (strEQ(remaining, "ARNING_BITS")) {
013b78e8 980 if (PL_compiling.cop_warnings == pWARN_NONE) {
4438c4b7 981 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
013b78e8
RGS
982 }
983 else if (PL_compiling.cop_warnings == pWARN_STD) {
7e4f0450
FC
984 sv_setsv(sv, &PL_sv_undef);
985 break;
013b78e8 986 }
d3a7d8c7 987 else if (PL_compiling.cop_warnings == pWARN_ALL) {
75b6c4ca
RGS
988 /* Get the bit mask for $warnings::Bits{all}, because
989 * it could have been extended by warnings::register */
4bac9ae4
CS
990 HV * const bits = get_hv("warnings::Bits", 0);
991 SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
992 if (bits_all)
993 sv_copypv(sv, *bits_all);
994 else
995 sv_setpvn(sv, WARN_ALLstring, WARNsize);
ac27b0f5 996 }
4438c4b7 997 else {
72dc9ed5
NC
998 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
999 *PL_compiling.cop_warnings);
ac27b0f5 1000 }
4438c4b7 1001 }
79072805 1002 break;
79072805 1003 case '+':
aaa362c4 1004 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2c7b5d76
DM
1005 paren = RX_LASTPAREN(rx);
1006 if (paren)
1007 goto do_numbuf_fetch;
79072805 1008 }
3280af22 1009 sv_setsv(sv,&PL_sv_undef);
79072805 1010 break;
a01268b5
JH
1011 case '\016': /* ^N */
1012 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2c7b5d76
DM
1013 paren = RX_LASTCLOSEPAREN(rx);
1014 if (paren)
1015 goto do_numbuf_fetch;
a01268b5
JH
1016 }
1017 sv_setsv(sv,&PL_sv_undef);
1018 break;
79072805 1019 case '.':
3280af22 1020 if (GvIO(PL_last_in_gv)) {
357c8808 1021 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805 1022 }
79072805
LW
1023 break;
1024 case '?':
809a5acc 1025 {
809a5acc 1026 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 1027#ifdef COMPLEX_STATUS
41cb7b2b 1028 SvUPGRADE(sv, SVt_PVLV);
6b88bc9c
GS
1029 LvTARGOFF(sv) = PL_statusvalue;
1030 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 1031#endif
809a5acc 1032 }
79072805
LW
1033 break;
1034 case '^':
acbe1b9d 1035 if (GvIOp(PL_defoutgv))
099be4f1 1036 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
1037 if (s)
1038 sv_setpv(sv,s);
1039 else {
3280af22 1040 sv_setpv(sv,GvENAME(PL_defoutgv));
cb421d5e 1041 sv_catpvs(sv,"_TOP");
79072805
LW
1042 }
1043 break;
1044 case '~':
acbe1b9d 1045 if (GvIOp(PL_defoutgv))
0daa599b 1046 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 1047 if (!s)
3280af22 1048 s = GvENAME(PL_defoutgv);
79072805
LW
1049 sv_setpv(sv,s);
1050 break;
79072805 1051 case '=':
099be4f1 1052 if (GvIO(PL_defoutgv))
0daa599b 1053 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
1054 break;
1055 case '-':
099be4f1 1056 if (GvIO(PL_defoutgv))
0daa599b 1057 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
1058 break;
1059 case '%':
099be4f1 1060 if (GvIO(PL_defoutgv))
0daa599b 1061 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805 1062 break;
79072805
LW
1063 case ':':
1064 break;
1065 case '/':
1066 break;
1067 case '[':
e1dccc0d 1068 sv_setiv(sv, 0);
79072805
LW
1069 break;
1070 case '|':
099be4f1 1071 if (GvIO(PL_defoutgv))
0daa599b 1072 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805 1073 break;
79072805 1074 case '\\':
b2ce0fda 1075 if (PL_ors_sv)
f28098ff 1076 sv_copypv(sv, PL_ors_sv);
4bac9ae4
CS
1077 else
1078 sv_setsv(sv, &PL_sv_undef);
79072805 1079 break;
0e219455 1080 case '$': /* $$ */
9cdac2a2
FC
1081 {
1082 IV const pid = (IV)PerlProc_getpid();
19db9fb7 1083 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
9cdac2a2
FC
1084 /* never set manually, or at least not since last fork */
1085 sv_setiv(sv, pid);
19db9fb7
Z
1086 /* never unsafe, even if reading in a tainted expression */
1087 SvTAINTED_off(sv);
1088 }
9cdac2a2
FC
1089 /* else a value has been assigned manually, so do nothing */
1090 }
0e219455 1091 break;
79072805 1092 case '<':
dfff4baf 1093 sv_setuid(sv, PerlProc_getuid());
79072805
LW
1094 break;
1095 case '>':
dfff4baf 1096 sv_setuid(sv, PerlProc_geteuid());
79072805
LW
1097 break;
1098 case '(':
dfff4baf 1099 sv_setgid(sv, PerlProc_getgid());
79072805
LW
1100 goto add_groups;
1101 case ')':
dfff4baf 1102 sv_setgid(sv, PerlProc_getegid());
79072805 1103 add_groups:
79072805 1104#ifdef HAS_GETGROUPS
79072805 1105 {
57d7c65e 1106 Groups_t *gary = NULL;
fb45abb2 1107 I32 i, num_groups = getgroups(0, gary);
57d7c65e
JC
1108 Newx(gary, num_groups, Groups_t);
1109 num_groups = getgroups(num_groups, gary);
fb45abb2
GA
1110 for (i = 0; i < num_groups; i++)
1111 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
57d7c65e 1112 Safefree(gary);
79072805 1113 }
155aba94 1114 (void)SvIOK_on(sv); /* what a wonderful hack! */
cd70abae 1115#endif
79072805 1116 break;
79072805
LW
1117 case '0':
1118 break;
1119 }
a0d0e21e 1120 return 0;
79072805
LW
1121}
1122
1123int
864dbfa3 1124Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 1125{
8772537c 1126 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 1127
7918f24d
NC
1128 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1129
79072805 1130 if (uf && uf->uf_val)
24f81a43 1131 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
1132 return 0;
1133}
1134
1135int
864dbfa3 1136Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 1137{
27da23d5 1138 dVAR;
9ae3433d 1139 STRLEN len = 0, klen;
12033064 1140 const char * const key = MgPV_const(mg,klen);
888a67f6 1141 const char *s = "";
1e422769 1142
7918f24d
NC
1143 PERL_ARGS_ASSERT_MAGIC_SETENV;
1144
613c63b4 1145 SvGETMAGIC(sv);
12033064 1146 if (SvOK(sv)) {
613c63b4
CS
1147 /* defined environment variables are byte strings; unfortunately
1148 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1149 (void)SvPV_force_nomg_nolen(sv);
1150 sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1151 if (SvUTF8(sv)) {
1152 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1153 SvUTF8_off(sv);
1154 }
1155 s = SvPVX(sv);
1156 len = SvCUR(sv);
12033064
CS
1157 }
1158 my_setenv(key, s); /* does the deed */
1159
a0d0e21e
LW
1160#ifdef DYNAMIC_ENV_FETCH
1161 /* We just undefd an environment var. Is a replacement */
1162 /* waiting in the wings? */
1163 if (!len) {
6bd66ee9 1164 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
fabdb6c0 1165 if (valp)
4ab59fcc 1166 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
a0d0e21e
LW
1167 }
1168#endif
1e422769 1169
39e571d4 1170#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
1171 /* And you'll never guess what the dog had */
1172 /* in its mouth... */
284167a5 1173 if (TAINTING_get) {
1e422769
PP
1174 MgTAINTEDDIR_off(mg);
1175#ifdef VMS
6bd66ee9 1176 if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
b8ffc8df 1177 char pathbuf[256], eltbuf[256], *cp, *elt;
1e422769
PP
1178 int i = 0, j = 0;
1179
6fca0082 1180 my_strlcpy(eltbuf, s, sizeof(eltbuf));
b8ffc8df 1181 elt = eltbuf;
1e422769
PP
1182 do { /* DCL$PATH may be a search list */
1183 while (1) { /* as may dev portion of any element */
1184 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1185 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1186 cando_by_name(S_IWUSR,0,elt) ) {
1187 MgTAINTEDDIR_on(mg);
1188 return 0;
1189 }
1190 }
bd61b366 1191 if ((cp = strchr(elt, ':')) != NULL)
1e422769
PP
1192 *cp = '\0';
1193 if (my_trnlnm(elt, eltbuf, j++))
1194 elt = eltbuf;
1195 else
1196 break;
1197 }
1198 j = 0;
1199 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1200 }
1201#endif /* VMS */
12033064 1202 if (s && klen == 4 && strEQ(key,"PATH")) {
8772537c 1203 const char * const strend = s + len;
463ee0b2
LW
1204
1205 while (s < strend) {
96827780 1206 char tmpbuf[256];
c623ac67 1207 Stat_t st;
5f74f29c 1208 I32 i;
f5a63d97
AL
1209#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1210 const char path_sep = '|';
1211#else
1212 const char path_sep = ':';
1213#endif
96827780 1214 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
427eaa01 1215 s, strend, path_sep, &i);
463ee0b2 1216 s++;
bb7a0f54 1217 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
326b5008
CB
1218#ifdef VMS
1219 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1220#else
1221 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1222#endif
c6ed36e1 1223 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1224 MgTAINTEDDIR_on(mg);
1e422769
PP
1225 return 0;
1226 }
463ee0b2 1227 }
79072805
LW
1228 }
1229 }
39e571d4 1230#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1231
79072805
LW
1232 return 0;
1233}
1234
1235int
864dbfa3 1236Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1237{
7918f24d 1238 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
8772537c 1239 PERL_UNUSED_ARG(sv);
bd61b366 1240 my_setenv(MgPV_nolen_const(mg),NULL);
85e6fe83
LW
1241 return 0;
1242}
1243
88e89b8a 1244int
864dbfa3 1245Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1246{
97aff369 1247 dVAR;
7918f24d 1248 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
65e66c80 1249 PERL_UNUSED_ARG(mg);
b0269e46 1250#if defined(VMS)
cea2e8a9 1251 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1252#else
3280af22 1253 if (PL_localizing) {
fb73857a 1254 HE* entry;
b0269e46 1255 my_clearenv();
85fbaab2
NC
1256 hv_iterinit(MUTABLE_HV(sv));
1257 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
fb73857a
PP
1258 I32 keylen;
1259 my_setenv(hv_iterkey(entry, &keylen),
85fbaab2 1260 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
fb73857a
PP
1261 }
1262 }
1263#endif
1264 return 0;
1265}
1266
1267int
864dbfa3 1268Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1269{
27da23d5 1270 dVAR;
7918f24d 1271 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
8772537c
AL
1272 PERL_UNUSED_ARG(sv);
1273 PERL_UNUSED_ARG(mg);
b0269e46
AB
1274#if defined(VMS)
1275 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1276#else
1277 my_clearenv();
1278#endif
3e3baf6d 1279 return 0;
66b1d557
HM
1280}
1281
64ca3a65 1282#ifndef PERL_MICRO
2d4fcd5e
AJ
1283#ifdef HAS_SIGPROCMASK
1284static void
1285restore_sigmask(pTHX_ SV *save_sv)
1286{
0bd48802 1287 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
f5a63d97 1288 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
2d4fcd5e
AJ
1289}
1290#endif
66b1d557 1291int
864dbfa3 1292Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1293{
97aff369 1294 dVAR;
88e89b8a 1295 /* Are we fetching a signal entry? */
708854f2 1296 int i = (I16)mg->mg_private;
7918f24d
NC
1297
1298 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1299
708854f2 1300 if (!i) {
84c7b88c
BF
1301 STRLEN siglen;
1302 const char * sig = MgPV_const(mg, siglen);
1303 mg->mg_private = i = whichsig_pvn(sig, siglen);
708854f2
NC
1304 }
1305
e02bfb16 1306 if (i > 0) {
22c35a8c
GS
1307 if(PL_psig_ptr[i])
1308 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1309 else {
46da273f 1310 Sighandler_t sigstate = rsignal_state(i);
23ada85b 1311#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
46da273f
AL
1312 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1313 sigstate = SIG_IGN;
2e34cc90
CL
1314#endif
1315#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
46da273f
AL
1316 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1317 sigstate = SIG_DFL;
85b332e2 1318#endif
88e89b8a 1319 /* cache state so we don't fetch it again */
8aad04aa 1320 if(sigstate == (Sighandler_t) SIG_IGN)
6502358f 1321 sv_setpvs(sv,"IGNORE");
88e89b8a 1322 else
3280af22 1323 sv_setsv(sv,&PL_sv_undef);
46da273f 1324 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a
PP
1325 SvTEMP_off(sv);
1326 }
1327 }
1328 return 0;
1329}
1330int
864dbfa3 1331Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1332{
7918f24d 1333 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
179c85a2 1334
38a124f0 1335 magic_setsig(NULL, mg);
179c85a2 1336 return sv_unmagic(sv, mg->mg_type);
88e89b8a 1337}
3d37d572 1338
0a8e0eff 1339Signal_t
8aad04aa 1340#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b6455c53 1341Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
8aad04aa 1342#else
0a8e0eff 1343Perl_csighandler(int sig)
8aad04aa 1344#endif
0a8e0eff 1345{
1018e26f
NIS
1346#ifdef PERL_GET_SIG_CONTEXT
1347 dTHXa(PERL_GET_SIG_CONTEXT);
1348#else
85b332e2
CL
1349 dTHX;
1350#endif
23ada85b 1351#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1352 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1353 if (PL_sig_ignoring[sig]) return;
85b332e2 1354#endif
2e34cc90 1355#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1356 if (PL_sig_defaulting[sig])
2e34cc90
CL
1357#ifdef KILL_BY_SIGPRC
1358 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1359#else
1360 exit(1);
1361#endif
1362#endif
406878dd 1363 if (
853d2c32
RGS
1364#ifdef SIGILL
1365 sig == SIGILL ||
1366#endif
1367#ifdef SIGBUS
1368 sig == SIGBUS ||
1369#endif
1370#ifdef SIGSEGV
1371 sig == SIGSEGV ||
1372#endif
1373 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
4ffa73a3 1374 /* Call the perl level handler now--
31c91b43 1375 * with risk we may be in malloc() or being destructed etc. */
6e324d09 1376#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
80626cf1 1377 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09
CB
1378#else
1379 (*PL_sighandlerp)(sig);
92807b6d 1380#endif
406878dd 1381 else {
31c91b43 1382 if (!PL_psig_pend) return;
406878dd
GA
1383 /* Set a flag to say this signal is pending, that is awaiting delivery after
1384 * the current Perl opcode completes */
1385 PL_psig_pend[sig]++;
1386
1387#ifndef SIG_PENDING_DIE_COUNT
1388# define SIG_PENDING_DIE_COUNT 120
1389#endif
fe13d51d 1390 /* Add one to say _a_ signal is pending */
406878dd
GA
1391 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1392 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1393 (unsigned long)SIG_PENDING_DIE_COUNT);
1394 }
0a8e0eff
NIS
1395}
1396
2e34cc90
CL
1397#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1398void
1399Perl_csighandler_init(void)
1400{
1401 int sig;
27da23d5 1402 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1403
1404 for (sig = 1; sig < SIG_SIZE; sig++) {
1405#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1406 dTHX;
27da23d5 1407 PL_sig_defaulting[sig] = 1;
5c1546dc 1408 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1409#endif
1410#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1411 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1412#endif
1413 }
27da23d5 1414 PL_sig_handlers_initted = 1;
2e34cc90
CL
1415}
1416#endif
1417
7fe50b8b
LT
1418#if defined HAS_SIGPROCMASK
1419static void
1420unblock_sigmask(pTHX_ void* newset)
1421{
1422 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1423}
1424#endif
1425
0a8e0eff
NIS
1426void
1427Perl_despatch_signals(pTHX)
1428{
97aff369 1429 dVAR;
0a8e0eff
NIS
1430 int sig;
1431 PL_sig_pending = 0;
1432 for (sig = 1; sig < SIG_SIZE; sig++) {
1433 if (PL_psig_pend[sig]) {
d0166017 1434 dSAVE_ERRNO;
7fe50b8b 1435#ifdef HAS_SIGPROCMASK
55534442
LT
1436 /* From sigaction(2) (FreeBSD man page):
1437 * | Signal routines normally execute with the signal that
1438 * | caused their invocation blocked, but other signals may
1439 * | yet occur.
1440 * Emulation of this behavior (from within Perl) is enabled
1441 * using sigprocmask
1442 */
1443 int was_blocked;
1444 sigset_t newset, oldset;
1445
1446 sigemptyset(&newset);
1447 sigaddset(&newset, sig);
1448 sigprocmask(SIG_BLOCK, &newset, &oldset);
1449 was_blocked = sigismember(&oldset, sig);
7fe50b8b
LT
1450 if (!was_blocked) {
1451 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1452 ENTER;
1453 SAVEFREESV(save_sv);
1454 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1455 }
55534442 1456#endif
25da4428 1457 PL_psig_pend[sig] = 0;
6e324d09 1458#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
80626cf1 1459 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09
CB
1460#else
1461 (*PL_sighandlerp)(sig);
92807b6d 1462#endif
7fe50b8b 1463#ifdef HAS_SIGPROCMASK
55534442 1464 if (!was_blocked)
7fe50b8b 1465 LEAVE;
55534442 1466#endif
d0166017 1467 RESTORE_ERRNO;
0a8e0eff
NIS
1468 }
1469 }
1470}
1471
38a124f0 1472/* sv of NULL signifies that we're acting as magic_clearsig. */
85e6fe83 1473int
864dbfa3 1474Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1475{
27da23d5 1476 dVAR;
79072805 1477 I32 i;
cbbf8932 1478 SV** svp = NULL;
2d4fcd5e
AJ
1479 /* Need to be careful with SvREFCNT_dec(), because that can have side
1480 * effects (due to closures). We must make sure that the new disposition
1481 * is in place before it is called.
1482 */
cbbf8932 1483 SV* to_dec = NULL;
e72dc28c 1484 STRLEN len;
2d4fcd5e
AJ
1485#ifdef HAS_SIGPROCMASK
1486 sigset_t set, save;
1487 SV* save_sv;
1488#endif
eb578fdb 1489 const char *s = MgPV_const(mg,len);
7918f24d
NC
1490
1491 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1492
748a9306 1493 if (*s == '_') {
84c7b88c 1494 if (memEQs(s, len, "__DIE__"))
3280af22 1495 svp = &PL_diehook;
84c7b88c 1496 else if (memEQs(s, len, "__WARN__")
38a124f0
NC
1497 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1498 /* Merge the existing behaviours, which are as follows:
1499 magic_setsig, we always set svp to &PL_warnhook
1500 (hence we always change the warnings handler)
1501 For magic_clearsig, we don't change the warnings handler if it's
1502 set to the &PL_warnhook. */
3280af22 1503 svp = &PL_warnhook;
84c7b88c
BF
1504 } else if (sv) {
1505 SV *tmp = sv_newmortal();
1506 Perl_croak(aTHX_ "No such hook: %s",
1507 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1508 }
748a9306 1509 i = 0;
38a124f0 1510 if (svp && *svp) {
9289f461
RGS
1511 if (*svp != PERL_WARNHOOK_FATAL)
1512 to_dec = *svp;
cbbf8932 1513 *svp = NULL;
4633a7c4 1514 }
748a9306
LW
1515 }
1516 else {
708854f2
NC
1517 i = (I16)mg->mg_private;
1518 if (!i) {
84c7b88c 1519 i = whichsig_pvn(s, len); /* ...no, a brick */
58a26b12 1520 mg->mg_private = (U16)i;
708854f2 1521 }
86d86cad 1522 if (i <= 0) {
84c7b88c
BF
1523 if (sv) {
1524 SV *tmp = sv_newmortal();
1525 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1526 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1527 }
748a9306
LW
1528 return 0;
1529 }
2d4fcd5e
AJ
1530#ifdef HAS_SIGPROCMASK
1531 /* Avoid having the signal arrive at a bad time, if possible. */
1532 sigemptyset(&set);
1533 sigaddset(&set,i);
1534 sigprocmask(SIG_BLOCK, &set, &save);
1535 ENTER;
9ff8e806 1536 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
2d4fcd5e
AJ
1537 SAVEFREESV(save_sv);
1538 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1539#endif
1540 PERL_ASYNC_CHECK();
2e34cc90 1541#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1542 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1543#endif
23ada85b 1544#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1545 PL_sig_ignoring[i] = 0;
85b332e2 1546#endif
2e34cc90 1547#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1548 PL_sig_defaulting[i] = 0;
2e34cc90 1549#endif
2d4fcd5e 1550 to_dec = PL_psig_ptr[i];
38a124f0
NC
1551 if (sv) {
1552 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1553 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
79fd3822
NC
1554
1555 /* Signals don't change name during the program's execution, so once
1556 they're cached in the appropriate slot of PL_psig_name, they can
1557 stay there.
1558
1559 Ideally we'd find some way of making SVs at (C) compile time, or
1560 at least, doing most of the work. */
1561 if (!PL_psig_name[i]) {
1562 PL_psig_name[i] = newSVpvn(s, len);
1563 SvREADONLY_on(PL_psig_name[i]);
1564 }
38a124f0 1565 } else {
79fd3822 1566 SvREFCNT_dec(PL_psig_name[i]);
38a124f0
NC
1567 PL_psig_name[i] = NULL;
1568 PL_psig_ptr[i] = NULL;
1569 }
748a9306 1570 }
38a124f0 1571 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
2d4fcd5e 1572 if (i) {
5c1546dc 1573 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1574 }
748a9306 1575 else
b37c2d43 1576 *svp = SvREFCNT_inc_simple_NN(sv);
38a124f0 1577 } else {
9dfa190b
NC
1578 if (sv && SvOK(sv)) {
1579 s = SvPV_force(sv, len);
1580 } else {
1581 sv = NULL;
1582 }
84c7b88c 1583 if (sv && memEQs(s, len,"IGNORE")) {
9dfa190b 1584 if (i) {
23ada85b 1585#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
9dfa190b
NC
1586 PL_sig_ignoring[i] = 1;
1587 (void)rsignal(i, PL_csighandlerp);
85b332e2 1588#else
9dfa190b 1589 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1590#endif
9dfa190b 1591 }
2d4fcd5e 1592 }
84c7b88c 1593 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
9dfa190b 1594 if (i) {
2e34cc90 1595#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
9dfa190b
NC
1596 PL_sig_defaulting[i] = 1;
1597 (void)rsignal(i, PL_csighandlerp);
2e34cc90 1598#else
9dfa190b 1599 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1600#endif
9dfa190b
NC
1601 }
1602 }
1603 else {
1604 /*
1605 * We should warn if HINT_STRICT_REFS, but without
1606 * access to a known hint bit in a known OP, we can't
1607 * tell whether HINT_STRICT_REFS is in force or not.
1608 */
1609 if (!strchr(s,':') && !strchr(s,'\''))
1610 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1611 SV_GMAGIC);
1612 if (i)
1613 (void)rsignal(i, PL_csighandlerp);
1614 else
1615 *svp = SvREFCNT_inc_simple_NN(sv);
136e0459 1616 }
748a9306 1617 }
9dfa190b 1618
2d4fcd5e
AJ
1619#ifdef HAS_SIGPROCMASK
1620 if(i)
1621 LEAVE;
1622#endif
ef8d46e8 1623 SvREFCNT_dec(to_dec);
79072805
LW
1624 return 0;
1625}
64ca3a65 1626#endif /* !PERL_MICRO */
79072805
LW
1627
1628int
864dbfa3 1629Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1630{
97aff369 1631 dVAR;
7918f24d 1632 PERL_ARGS_ASSERT_MAGIC_SETISA;
8772537c 1633 PERL_UNUSED_ARG(sv);
e1a479c5 1634
89c14e2e 1635 /* Skip _isaelem because _isa will handle it shortly */
354b0578 1636 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
89c14e2e
BB
1637 return 0;
1638
0e446081 1639 return magic_clearisa(NULL, mg);
463ee0b2
LW
1640}
1641
0e446081 1642/* sv of NULL signifies that we're acting as magic_setisa. */
463ee0b2 1643int
52b45067
RD
1644Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1645{
1646 dVAR;
1647 HV* stash;
1648
7918f24d
NC
1649 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1650
52b45067 1651 /* Bail out if destruction is going on */
627364f1 1652 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
52b45067 1653
0e446081
NC
1654 if (sv)
1655 av_clear(MUTABLE_AV(sv));
52b45067 1656
6624142a
FC
1657 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1658 /* This occurs with setisa_elem magic, which calls this
1659 same function. */
1660 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1661
1662 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1663 SV **svp = AvARRAY((AV *)mg->mg_obj);
1664 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1665 while (items--) {
1666 stash = GvSTASH((GV *)*svp++);
1667 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1668 }
1669
1670 return 0;
1671 }
1672
52b45067 1673 stash = GvSTASH(
6624142a 1674 (const GV *)mg->mg_obj
52b45067
RD
1675 );
1676
00169e2c
FC
1677 /* The stash may have been detached from the symbol table, so check its
1678 name before doing anything. */
1679 if (stash && HvENAME_get(stash))
5562fa71 1680 mro_isa_changed_in(stash);
52b45067
RD
1681
1682 return 0;
1683}
1684
1685int
864dbfa3 1686Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1687{
85fbaab2 1688 HV * const hv = MUTABLE_HV(LvTARG(sv));
6ff81951 1689 I32 i = 0;
7918f24d
NC
1690
1691 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
8772537c 1692 PERL_UNUSED_ARG(mg);
7719e241 1693
6ff81951 1694 if (hv) {
497b47a8 1695 (void) hv_iterinit(hv);
ad64d0ec 1696 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1b95d04f 1697 i = HvUSEDKEYS(hv);
497b47a8
JH
1698 else {
1699 while (hv_iternext(hv))
1700 i++;
1701 }
6ff81951
GS
1702 }
1703
1704 sv_setiv(sv, (IV)i);
1705 return 0;
1706}
1707
1708int
864dbfa3 1709Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1710{
7918f24d 1711 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
8772537c 1712 PERL_UNUSED_ARG(mg);
946ec16e 1713 if (LvTARG(sv)) {
85fbaab2 1714 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
946ec16e
PP
1715 }
1716 return 0;
ac27b0f5 1717}
946ec16e 1718
efaf3674
DM
1719/*
1720=for apidoc magic_methcall
1721
1722Invoke a magic method (like FETCH).
1723
2baee27b
FC
1724C<sv> and C<mg> are the tied thingy and the tie magic.
1725
1726C<meth> is the name of the method to call.
1727
1728C<argc> is the number of args (in addition to $self) to pass to the method.
1729
1730The C<flags> can be:
1731
1732 G_DISCARD invoke method with G_DISCARD flag and don't
1733 return a value
1734 G_UNDEF_FILL fill the stack with argc pointers to
1735 PL_sv_undef
1736
1737The arguments themselves are any values following the C<flags> argument.
efaf3674
DM
1738
1739Returns the SV (if any) returned by the method, or NULL on failure.
1740
1741
1742=cut
1743*/
1744
1745SV*
36925d9e 1746Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
046b0c7d 1747 U32 argc, ...)
a0d0e21e 1748{
97aff369 1749 dVAR;
a0d0e21e 1750 dSP;
efaf3674 1751 SV* ret = NULL;
463ee0b2 1752
7918f24d
NC
1753 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1754
efaf3674 1755 ENTER;
d1d7a15d
NC
1756
1757 if (flags & G_WRITING_TO_STDERR) {
1758 SAVETMPS;
1759
1760 save_re_context();
1761 SAVESPTR(PL_stderrgv);
1762 PL_stderrgv = NULL;
1763 }
1764
efaf3674 1765 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1766 PUSHMARK(SP);
efaf3674 1767
67549bd2
NC
1768 EXTEND(SP, argc+1);
1769 PUSHs(SvTIED_obj(sv, mg));
1770 if (flags & G_UNDEF_FILL) {
1771 while (argc--) {
efaf3674 1772 PUSHs(&PL_sv_undef);
93965878 1773 }
67549bd2 1774 } else if (argc > 0) {
046b0c7d
NC
1775 va_list args;
1776 va_start(args, argc);
1777
1778 do {
1779 SV *const sv = va_arg(args, SV *);
1780 PUSHs(sv);
1781 } while (--argc);
1782
1783 va_end(args);
88e89b8a 1784 }
463ee0b2 1785 PUTBACK;
efaf3674 1786 if (flags & G_DISCARD) {
36925d9e 1787 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
efaf3674
DM
1788 }
1789 else {
36925d9e 1790 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
efaf3674
DM
1791 ret = *PL_stack_sp--;
1792 }
1793 POPSTACK;
d1d7a15d
NC
1794 if (flags & G_WRITING_TO_STDERR)
1795 FREETMPS;
efaf3674
DM
1796 LEAVE;
1797 return ret;
1798}
1799
efaf3674 1800/* wrapper for magic_methcall that creates the first arg */
463ee0b2 1801
efaf3674 1802STATIC SV*
36925d9e 1803S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
efaf3674
DM
1804 int n, SV *val)
1805{
1806 dVAR;
1807 SV* arg1 = NULL;
1808
1809 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1810
1811 if (mg->mg_ptr) {
1812 if (mg->mg_len >= 0) {
db4b3a1d 1813 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
efaf3674
DM
1814 }
1815 else if (mg->mg_len == HEf_SVKEY)
1816 arg1 = MUTABLE_SV(mg->mg_ptr);
1817 }
1818 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
db4b3a1d 1819 arg1 = newSViv((IV)(mg->mg_len));
efaf3674
DM
1820 sv_2mortal(arg1);
1821 }
1822 if (!arg1) {
046b0c7d 1823 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
efaf3674 1824 }
046b0c7d 1825 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
946ec16e
PP
1826}
1827
76e3520e 1828STATIC int
36925d9e 1829S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
a0d0e21e 1830{
efaf3674
DM
1831 dVAR;
1832 SV* ret;
463ee0b2 1833
7918f24d
NC
1834 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1835
efaf3674
DM
1836 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1837 if (ret)
1838 sv_setsv(sv, ret);
a0d0e21e
LW
1839 return 0;
1840}
463ee0b2 1841
a0d0e21e 1842int
864dbfa3 1843Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1844{
7918f24d
NC
1845 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1846
fd69380d 1847 if (mg->mg_type == PERL_MAGIC_tiedelem)
a0d0e21e 1848 mg->mg_flags |= MGf_GSKIP;
36925d9e 1849 magic_methpack(sv,mg,SV_CONST(FETCH));
463ee0b2
LW
1850 return 0;
1851}
1852
1853int
864dbfa3 1854Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1855{
efaf3674 1856 dVAR;
b112cff9
DM
1857 MAGIC *tmg;
1858 SV *val;
7918f24d
NC
1859
1860 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1861
b112cff9
DM
1862 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1863 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1864 * public flags indicate its value based on copying from $val. Doing
1865 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1866 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1867 * wrong if $val happened to be tainted, as sv hasn't got magic
1868 * enabled, even though taint magic is in the chain. In which case,
1869 * fake up a temporary tainted value (this is easier than temporarily
1870 * re-enabling magic on sv). */
1871
284167a5 1872 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
b112cff9
DM
1873 && (tmg->mg_len & 1))
1874 {
1875 val = sv_mortalcopy(sv);
1876 SvTAINTED_on(val);
1877 }
1878 else
1879 val = sv;
1880
36925d9e 1881 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
463ee0b2
LW
1882 return 0;
1883}
1884
1885int
864dbfa3 1886Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1887{
7918f24d
NC
1888 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1889
4c13be3f 1890 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
36925d9e 1891 return magic_methpack(sv,mg,SV_CONST(DELETE));
a0d0e21e 1892}
463ee0b2 1893
93965878
NIS
1894
1895U32
864dbfa3 1896Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1897{
efaf3674 1898 dVAR;
22846ab4 1899 I32 retval = 0;
efaf3674 1900 SV* retsv;
93965878 1901
7918f24d
NC
1902 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1903
36925d9e 1904 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
efaf3674
DM
1905 if (retsv) {
1906 retval = SvIV(retsv)-1;
22846ab4
AB
1907 if (retval < -1)
1908 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
93965878 1909 }
22846ab4 1910 return (U32) retval;
93965878
NIS
1911}
1912
cea2e8a9
GS
1913int
1914Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1915{
efaf3674 1916 dVAR;
463ee0b2 1917
7918f24d
NC
1918 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1919
36925d9e 1920 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
463ee0b2
LW
1921 return 0;
1922}
1923
1924int
864dbfa3 1925Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1926{
efaf3674
DM
1927 dVAR;
1928 SV* ret;
463ee0b2 1929
7918f24d
NC
1930 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1931
36925d9e
RZ
1932 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
1933 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
efaf3674
DM
1934 if (ret)
1935 sv_setsv(key,ret);
79072805
LW
1936 return 0;
1937}
1938
1939int
1146e912 1940Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
a0d0e21e 1941{
7918f24d
NC
1942 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1943
36925d9e 1944 return magic_methpack(sv,mg,SV_CONST(EXISTS));
ac27b0f5 1945}
a0d0e21e 1946
a3bcc51e
TP
1947SV *
1948Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1949{
efaf3674 1950 dVAR;
5fcbf73d 1951 SV *retval;
ad64d0ec
NC
1952 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1953 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
a3bcc51e 1954
7918f24d
NC
1955 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1956
a3bcc51e
TP
1957 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1958 SV *key;
bfcb3514 1959 if (HvEITER_get(hv))
a3bcc51e
TP
1960 /* we are in an iteration so the hash cannot be empty */
1961 return &PL_sv_yes;
1962 /* no xhv_eiter so now use FIRSTKEY */
1963 key = sv_newmortal();
ad64d0ec 1964 magic_nextpack(MUTABLE_SV(hv), mg, key);
bfcb3514 1965 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1966 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1967 }
1968
1969 /* there is a SCALAR method that we can call */
36925d9e 1970 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
efaf3674 1971 if (!retval)
5fcbf73d 1972 retval = &PL_sv_undef;
a3bcc51e
TP
1973 return retval;
1974}
1975
a0d0e21e 1976int
864dbfa3 1977Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1978{
97aff369 1979 dVAR;
089b5c60 1980 SV **svp;
7918f24d
NC
1981
1982 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1983
089b5c60
NC
1984 /* The magic ptr/len for the debugger's hash should always be an SV. */
1985 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
1986 Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'",
7b0eb0b8 1987 (IV)mg->mg_len, mg->mg_ptr);
089b5c60
NC
1988 }
1989
1990 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
1991 setting/clearing debugger breakpoints is not a hot path. */
43e4250a
FC
1992 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
1993 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
089b5c60 1994
8772537c
AL
1995 if (svp && SvIOKp(*svp)) {
1996 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1997 if (o) {
7bbbc3c0
NC
1998#ifdef PERL_DEBUG_READONLY_OPS
1999 Slab_to_rw(OpSLAB(o));
2000#endif
8772537c 2001 /* set or clear breakpoint in the relevant control op */
089b5c60 2002 if (SvTRUE(sv))
8772537c
AL
2003 o->op_flags |= OPf_SPECIAL;
2004 else
2005 o->op_flags &= ~OPf_SPECIAL;
7bbbc3c0
NC
2006#ifdef PERL_DEBUG_READONLY_OPS
2007 Slab_to_ro(OpSLAB(o));
2008#endif
8772537c 2009 }
5df8de69 2010 }
79072805
LW
2011 return 0;
2012}
2013
2014int
8772537c 2015Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 2016{
97aff369 2017 dVAR;
502c6561 2018 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC
2019
2020 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2021
83bf042f 2022 if (obj) {
e1dccc0d 2023 sv_setiv(sv, AvFILL(obj));
83bf042f 2024 } else {
d4a823b3 2025 sv_setsv(sv, NULL);
83bf042f 2026 }
79072805
LW
2027 return 0;
2028}
2029
2030int
864dbfa3 2031Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 2032{
97aff369 2033 dVAR;
502c6561 2034 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC
2035
2036 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2037
83bf042f 2038 if (obj) {
e1dccc0d 2039 av_fill(obj, SvIV(sv));
83bf042f 2040 } else {
a2a5de95
NC
2041 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2042 "Attempt to set length of freed array");
83bf042f
NC
2043 }
2044 return 0;
2045}
2046
2047int
83f29afa
VP
2048Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2049{
2050 dVAR;
2051
2052 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2053 PERL_UNUSED_ARG(sv);
2054
2055 /* Reset the iterator when the array is cleared */
3565fbf3
VP
2056#if IVSIZE == I32SIZE
2057 *((IV *) &(mg->mg_len)) = 0;
2058#else
83f29afa
VP
2059 if (mg->mg_ptr)
2060 *((IV *) mg->mg_ptr) = 0;
3565fbf3 2061#endif
83f29afa
VP
2062
2063 return 0;
2064}
2065
2066int
83bf042f
NC
2067Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2068{
97aff369 2069 dVAR;
7918f24d
NC
2070
2071 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
53c1dcc0 2072 PERL_UNUSED_ARG(sv);
7918f24d 2073
94f3782b
DM
2074 /* during global destruction, mg_obj may already have been freed */
2075 if (PL_in_clean_all)
1ea47f64 2076 return 0;
94f3782b 2077
83bf042f
NC
2078 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2079
2080 if (mg) {
2081 /* arylen scalar holds a pointer back to the array, but doesn't own a
2082 reference. Hence the we (the array) are about to go away with it
2083 still pointing at us. Clear its pointer, else it would be pointing
2084 at free memory. See the comment in sv_magic about reference loops,
2085 and why it can't own a reference to us. */
2086 mg->mg_obj = 0;
2087 }
a0d0e21e
LW
2088 return 0;
2089}
2090
2091int
864dbfa3 2092Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2093{
97aff369 2094 dVAR;
16eb5365 2095 SV* const lsv = LvTARG(sv);
96c2a8ff 2096 MAGIC * const found = mg_find_mglob(lsv);
7918f24d
NC
2097
2098 PERL_ARGS_ASSERT_MAGIC_GETPOS;
16eb5365 2099 PERL_UNUSED_ARG(mg);
ac27b0f5 2100
6174b39a
FC
2101 if (found && found->mg_len != -1) {
2102 STRLEN i = found->mg_len;
25fdce4a 2103 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
6174b39a
FC
2104 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2105 sv_setuv(sv, i);
a0d0e21e 2106 return 0;
a0d0e21e 2107 }
35995e5c 2108 sv_setsv(sv,NULL);
a0d0e21e
LW
2109 return 0;
2110}
2111
2112int
864dbfa3 2113Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2114{
97aff369 2115 dVAR;
16eb5365 2116 SV* const lsv = LvTARG(sv);
a0d0e21e
LW
2117 SSize_t pos;
2118 STRLEN len;
c00206c8 2119 STRLEN ulen = 0;
53d44271 2120 MAGIC* found;
aec43834 2121 const char *s;
a0d0e21e 2122
7918f24d 2123 PERL_ARGS_ASSERT_MAGIC_SETPOS;
16eb5365 2124 PERL_UNUSED_ARG(mg);
ac27b0f5 2125
96c2a8ff 2126 found = mg_find_mglob(lsv);
3881461a 2127 if (!found) {
a0d0e21e
LW
2128 if (!SvOK(sv))
2129 return 0;
96c2a8ff 2130 found = sv_magicext_mglob(lsv);
a0d0e21e
LW
2131 }
2132 else if (!SvOK(sv)) {
3881461a 2133 found->mg_len = -1;
a0d0e21e
LW
2134 return 0;
2135 }
aec43834 2136 s = SvPV_const(lsv, len);
a0d0e21e 2137
e1dccc0d 2138 pos = SvIV(sv);
a0ed51b3 2139
7e2040f0 2140 if (DO_UTF8(lsv)) {
aec43834 2141 ulen = sv_or_pv_len_utf8(lsv, s, len);
a0ed51b3
LW
2142 if (ulen)
2143 len = ulen;
a0ed51b3
LW
2144 }
2145
a0d0e21e
LW
2146 if (pos < 0) {
2147 pos += len;
2148 if (pos < 0)
2149 pos = 0;
2150 }
eb160463 2151 else if (pos > (SSize_t)len)
a0d0e21e 2152 pos = len;
a0ed51b3 2153
3881461a 2154 found->mg_len = pos;
25fdce4a 2155 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
a0d0e21e 2156
79072805
LW
2157 return 0;
2158}
2159
2160int
864dbfa3 2161Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
2162{
2163 STRLEN len;
35a4481c 2164 SV * const lsv = LvTARG(sv);
b83604b4 2165 const char * const tmps = SvPV_const(lsv,len);
777f7c56
EB
2166 STRLEN offs = LvTARGOFF(sv);
2167 STRLEN rem = LvTARGLEN(sv);
83f78d1a
FC
2168 const bool negoff = LvFLAGS(sv) & 1;
2169 const bool negrem = LvFLAGS(sv) & 2;
7918f24d
NC
2170
2171 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
8772537c 2172 PERL_UNUSED_ARG(mg);
6ff81951 2173
83f78d1a 2174 if (!translate_substr_offsets(
4ddea69a 2175 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
83f78d1a
FC
2176 negoff ? -(IV)offs : (IV)offs, !negoff,
2177 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2178 )) {
2179 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2180 sv_setsv_nomg(sv, &PL_sv_undef);
2181 return 0;
2182 }
2183
9aa983d2 2184 if (SvUTF8(lsv))
4ddea69a 2185 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
1c900557 2186 sv_setpvn(sv, tmps + offs, rem);
9aa983d2 2187 if (SvUTF8(lsv))
2ef4b674 2188 SvUTF8_on(sv);
6ff81951
GS
2189 return 0;
2190}
2191
2192int
864dbfa3 2193Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 2194{
97aff369 2195 dVAR;
83f78d1a 2196 STRLEN len, lsv_len, oldtarglen, newtarglen;
5fcbf73d 2197 const char * const tmps = SvPV_const(sv, len);
dd374669 2198 SV * const lsv = LvTARG(sv);
777f7c56
EB
2199 STRLEN lvoff = LvTARGOFF(sv);
2200 STRLEN lvlen = LvTARGLEN(sv);
83f78d1a
FC
2201 const bool negoff = LvFLAGS(sv) & 1;
2202 const bool neglen = LvFLAGS(sv) & 2;
7918f24d
NC
2203
2204 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
8772537c 2205 PERL_UNUSED_ARG(mg);
075a4a2b 2206
a74fb2cd
FC
2207 SvGETMAGIC(lsv);
2208 if (SvROK(lsv))
2209 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2210 "Attempt to use reference as lvalue in substr"
2211 );
fc061ed8
FC
2212 SvPV_force_nomg(lsv,lsv_len);
2213 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
83f78d1a
FC
2214 if (!translate_substr_offsets(
2215 lsv_len,
2216 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2217 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2218 ))
2219 Perl_croak(aTHX_ "substr outside of string");
2220 oldtarglen = lvlen;
1aa99e6b 2221 if (DO_UTF8(sv)) {
73a087f0 2222 sv_utf8_upgrade_nomg(lsv);
d931b1be 2223 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
a74fb2cd 2224 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
7a385470 2225 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
9aa983d2
JH
2226 SvUTF8_on(lsv);
2227 }
0d336106 2228 else if (SvUTF8(lsv)) {
5fcbf73d 2229 const char *utf8;
d931b1be 2230 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
83f78d1a 2231 newtarglen = len;
5fcbf73d 2232 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
a74fb2cd 2233 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
5fcbf73d 2234 Safefree(utf8);
1aa99e6b 2235 }
b76f3ce2 2236 else {
a74fb2cd 2237 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
83f78d1a 2238 newtarglen = len;
b76f3ce2 2239 }
83f78d1a
FC
2240 if (!neglen) LvTARGLEN(sv) = newtarglen;
2241 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
b76f3ce2 2242
79072805
LW
2243 return 0;
2244}
2245
2246int
864dbfa3 2247Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2248{
97aff369 2249 dVAR;
7918f24d
NC
2250
2251 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
8772537c 2252 PERL_UNUSED_ARG(sv);
9a9b5ec9
DM
2253#ifdef NO_TAINT_SUPPORT
2254 PERL_UNUSED_ARG(mg);
2255#endif
7918f24d 2256
27cc343c 2257 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW
2258 return 0;
2259}
2260
2261int
864dbfa3 2262Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2263{
97aff369 2264 dVAR;
7918f24d
NC
2265
2266 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
8772537c 2267 PERL_UNUSED_ARG(sv);
7918f24d 2268
b01e650a 2269 /* update taint status */
284167a5 2270 if (TAINT_get)
b01e650a
DM
2271 mg->mg_len |= 1;
2272 else
2273 mg->mg_len &= ~1;
463ee0b2
LW
2274 return 0;
2275}
2276
2277int
864dbfa3 2278Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 2279{
35a4481c 2280 SV * const lsv = LvTARG(sv);
7918f24d
NC
2281
2282 PERL_ARGS_ASSERT_MAGIC_GETVEC;
8772537c 2283 PERL_UNUSED_ARG(mg);
6ff81951 2284
2e9e14dd 2285 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951 2286
6ff81951
GS
2287 return 0;
2288}
2289
2290int
864dbfa3 2291Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 2292{
7918f24d 2293 PERL_ARGS_ASSERT_MAGIC_SETVEC;
8772537c 2294 PERL_UNUSED_ARG(mg);
79072805
LW
2295 do_vecset(sv); /* XXX slurp this routine */
2296 return 0;
2297}
2298
13733cde
FC
2299SV *
2300Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 2301{
97aff369 2302 dVAR;
a0714e2c 2303 SV *targ = NULL;
13733cde
FC
2304 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2305 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2306 assert(mg);
5f05dabc 2307 if (LvTARGLEN(sv)) {
68dc0745 2308 if (mg->mg_obj) {
8772537c 2309 SV * const ahv = LvTARG(sv);
85fbaab2 2310 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
6d822dc4
MS
2311 if (he)
2312 targ = HeVAL(he);
68dc0745 2313 }
bbfdc870 2314 else if (LvSTARGOFF(sv) >= 0) {
502c6561 2315 AV *const av = MUTABLE_AV(LvTARG(sv));
bbfdc870 2316 if (LvSTARGOFF(sv) <= AvFILL(av))
ca58dfd9
FC
2317 {
2318 if (SvRMAGICAL(av)) {
2319 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2320 targ = svp ? *svp : NULL;
2321 }
2322 else
bbfdc870 2323 targ = AvARRAY(av)[LvSTARGOFF(sv)];
ca58dfd9 2324 }
68dc0745 2325 }
46da273f 2326 if (targ && (targ != &PL_sv_undef)) {
68dc0745
PP
2327 /* somebody else defined it for us */
2328 SvREFCNT_dec(LvTARG(sv));
b37c2d43 2329 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
68dc0745
PP
2330 LvTARGLEN(sv) = 0;
2331 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2332 mg->mg_obj = NULL;
68dc0745
PP
2333 mg->mg_flags &= ~MGf_REFCOUNTED;
2334 }
13733cde 2335 return targ;
5f05dabc 2336 }
71be2cbc 2337 else
13733cde
FC
2338 return LvTARG(sv);
2339}
2340
2341int
2342Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2343{
2344 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2345
2346 sv_setsv(sv, defelem_target(sv, mg));
71be2cbc
PP
2347 return 0;
2348}
2349
2350int
864dbfa3 2351Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2352{
7918f24d 2353 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
8772537c 2354 PERL_UNUSED_ARG(mg);
71be2cbc 2355 if (LvTARGLEN(sv))
68dc0745
PP
2356 vivify_defelem(sv);
2357 if (LvTARG(sv)) {
5f05dabc 2358 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
2359 SvSETMAGIC(LvTARG(sv));
2360 }
5f05dabc
PP
2361 return 0;
2362}
2363
71be2cbc 2364void
864dbfa3 2365Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2366{
97aff369 2367 dVAR;
74e13ce4 2368 MAGIC *mg;
a0714e2c 2369 SV *value = NULL;
71be2cbc 2370
7918f24d
NC
2371 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2372
14befaf4 2373 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2374 return;
68dc0745 2375 if (mg->mg_obj) {
8772537c 2376 SV * const ahv = LvTARG(sv);
85fbaab2 2377 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
6d822dc4
MS
2378 if (he)
2379 value = HeVAL(he);
3280af22 2380 if (!value || value == &PL_sv_undef)
be2597df 2381 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
71be2cbc 2382 }
bbfdc870
FC
2383 else if (LvSTARGOFF(sv) < 0)
2384 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
68dc0745 2385 else {
502c6561 2386 AV *const av = MUTABLE_AV(LvTARG(sv));
bbfdc870 2387 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
a0714e2c 2388 LvTARG(sv) = NULL; /* array can't be extended */
68dc0745 2389 else {
bbfdc870 2390 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
031c6d82 2391 if (!svp || !(value = *svp))
bbfdc870 2392 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
68dc0745
PP
2393 }
2394 }
b37c2d43 2395 SvREFCNT_inc_simple_void(value);
68dc0745
PP
2396 SvREFCNT_dec(LvTARG(sv));
2397 LvTARG(sv) = value;
71be2cbc 2398 LvTARGLEN(sv) = 0;
68dc0745 2399 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2400 mg->mg_obj = NULL;
68dc0745 2401 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2402}
2403
2404int
864dbfa3 2405Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2406{
7918f24d 2407 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
5648c0ae
DM
2408 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2409 return 0;
810b8aa5
GS
2410}
2411
2412int
864dbfa3 2413Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2414{
7918f24d 2415 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
96a5add6 2416 PERL_UNUSED_CONTEXT;
0177730e 2417 PERL_UNUSED_ARG(sv);
565764a8 2418 mg->mg_len = -1;
93a17b20
LW
2419 return 0;
2420}
2421
2422int
864dbfa3 2423Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2424{
35a4481c 2425 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 2426
7918f24d
NC
2427 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2428
79072805 2429 if (uf && uf->uf_set)
24f81a43 2430 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2431 return 0;
2432}
2433
c277df42 2434int
faf82a0b
AE
2435Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2436{
488344d2 2437 const char type = mg->mg_type;
7918f24d
NC
2438
2439 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2440
488344d2
NC
2441 if (type == PERL_MAGIC_qr) {
2442 } else if (type == PERL_MAGIC_bm) {
2443 SvTAIL_off(sv);
2444 SvVALID_off(sv);
2445 } else {
2446 assert(type == PERL_MAGIC_fm);
488344d2
NC
2447 }
2448 return sv_unmagic(sv, type);
faf82a0b
AE
2449}
2450
7a4c00b4 2451#ifdef USE_LOCALE_COLLATE
79072805 2452int
864dbfa3 2453Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69 2454{
7918f24d
NC
2455 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2456
bbce6d69 2457 /*
838b5b74 2458 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2459 * and vanished with a faint plop.
2460 */
96a5add6 2461 PERL_UNUSED_CONTEXT;
8772537c 2462 PERL_UNUSED_ARG(sv);
7a4c00b4
PP
2463 if (mg->mg_ptr) {
2464 Safefree(mg->mg_ptr);
2465 mg->mg_ptr = NULL;
565764a8 2466 mg->mg_len = -1;
7a4c00b4 2467 }
bbce6d69
PP
2468 return 0;
2469}
7a4c00b4 2470#endif /* USE_LOCALE_COLLATE */
bbce6d69 2471
7e8c5dac
HS
2472/* Just clear the UTF-8 cache data. */
2473int
2474Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2475{
7918f24d 2476 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
96a5add6 2477 PERL_UNUSED_CONTEXT;
8772537c 2478 PERL_UNUSED_ARG(sv);
7e8c5dac 2479 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
3881461a 2480 mg->mg_ptr = NULL;
7e8c5dac
HS
2481 mg->mg_len = -1; /* The mg_len holds the len cache. */
2482 return 0;
2483}
2484
bbce6d69 2485int
864dbfa3 2486Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2487{
97aff369 2488 dVAR;
eb578fdb
KW
2489 const char *s;
2490 I32 paren;
2491 const REGEXP * rx;
79072805 2492 I32 i;
8990e307 2493 STRLEN len;
125b9982 2494 MAGIC *tmg;
2fdbfb4d 2495
7918f24d
NC
2496 PERL_ARGS_ASSERT_MAGIC_SET;
2497
e91d8259 2498 if (!mg->mg_ptr) {
960b831f 2499 paren = mg->mg_len;
1e05feb3 2500 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
e91d8259 2501 setparen_got_rx:
2fdbfb4d 2502 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
1e05feb3 2503 } else {
2fdbfb4d
AB
2504 /* Croak with a READONLY error when a numbered match var is
2505 * set without a previous pattern match. Unless it's C<local $1>
2506 */
e91d8259 2507 croakparen:
2fdbfb4d 2508 if (!PL_localizing) {
cb077ed2 2509 Perl_croak_no_modify();
2fdbfb4d
AB
2510 }
2511 }
e91d8259
NC
2512 return 0;
2513 }
2514
2515 switch (*mg->mg_ptr) {
748a9306 2516 case '\001': /* ^A */
f2da823f
FC
2517 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2518 else SvOK_off(PL_bodytarget);
64eff8b7
DM
2519 FmLINES(PL_bodytarget) = 0;
2520 if (SvPOK(PL_bodytarget)) {
2521 char *s = SvPVX(PL_bodytarget);
2522 while ( ((s = strchr(s, '\n'))) ) {
2523 FmLINES(PL_bodytarget)++;
2524 s++;
2525 }
2526 }
125b9982 2527 /* mg_set() has temporarily made sv non-magical */
284167a5 2528 if (TAINTING_get) {
125b9982
NT
2529 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2530 SvTAINTED_on(PL_bodytarget);
2531 else
2532 SvTAINTED_off(PL_bodytarget);
2533 }
748a9306 2534 break;
49460fe6 2535 case '\003': /* ^C */
f2338a2e 2536 PL_minus_c = cBOOL(SvIV(sv));
49460fe6
NIS
2537 break;
2538
79072805 2539 case '\004': /* ^D */
b4ab917c 2540#ifdef DEBUGGING
b83604b4 2541 s = SvPV_nolen_const(sv);
ddcf8bc1 2542 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
a58fb6f9
CS
2543 if (DEBUG_x_TEST || DEBUG_B_TEST)
2544 dump_all_perl(!DEBUG_B_TEST);
b4ab917c 2545#else
38ab35f8 2546 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
b4ab917c 2547#endif
79072805 2548 break;
28f23441 2549 case '\005': /* ^E */
d0063567 2550 if (*(mg->mg_ptr+1) == '\0') {
e37778c2 2551#ifdef VMS
38ab35f8 2552 set_vaxc_errno(SvIV(sv));
e37778c2
NC
2553#else
2554# ifdef WIN32
d0063567 2555 SetLastError( SvIV(sv) );
e37778c2
NC
2556# else
2557# ifdef OS2
38ab35f8 2558 os2_setsyserrno(SvIV(sv));
e37778c2 2559# else
d0063567 2560 /* will anyone ever use this? */
38ab35f8 2561 SETERRNO(SvIV(sv), 4);
048c1ddf
IZ
2562# endif
2563# endif
22fae026 2564#endif
d0063567
DK
2565 }
2566 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
ef8d46e8 2567 SvREFCNT_dec(PL_encoding);
d0063567
DK
2568 if (SvOK(sv) || SvGMAGICAL(sv)) {
2569 PL_encoding = newSVsv(sv);
2570 }
2571 else {
a0714e2c 2572 PL_encoding = NULL;
d0063567
DK
2573 }
2574 }
2575 break;
79072805 2576 case '\006': /* ^F */
38ab35f8 2577 PL_maxsysfd = SvIV(sv);
79072805 2578 break;
a0d0e21e 2579 case '\010': /* ^H */
38ab35f8 2580 PL_hints = SvIV(sv);
a0d0e21e 2581 break;
9d116dd7 2582 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d 2583 Safefree(PL_inplace);
bd61b366 2584 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
da78da6e 2585 break;
d9bad346
FC
2586 case '\016': /* ^N */
2587 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2588 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2589 goto croakparen;
28f23441 2590 case '\017': /* ^O */
ac27b0f5 2591 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d 2592 Safefree(PL_osname);
bd61b366 2593 PL_osname = NULL;
3511154c
DM
2594 if (SvOK(sv)) {
2595 TAINT_PROPER("assigning to $^O");
2e0de35c 2596 PL_osname = savesvpv(sv);
3511154c 2597 }
ac27b0f5
NIS
2598 }
2599 else if (strEQ(mg->mg_ptr, "\017PEN")) {
8b850bd5
NC
2600 STRLEN len;
2601 const char *const start = SvPV(sv, len);
b54fc2b6 2602 const char *out = (const char*)memchr(start, '\0', len);
8b850bd5 2603 SV *tmp;
8b850bd5
NC
2604
2605
2606 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
f747ebd6 2607 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
8b850bd5
NC
2608
2609 /* Opening for input is more common than opening for output, so
2610 ensure that hints for input are sooner on linked list. */
59cd0e26 2611 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
f747ebd6
Z
2612 SvUTF8(sv))
2613 : newSVpvs_flags("", SvUTF8(sv));
2614 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2615 mg_set(tmp);
8b850bd5 2616
f747ebd6
Z
2617 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2618 SvUTF8(sv));
2619 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2620 mg_set(tmp);
ac27b0f5 2621 }
28f23441 2622 break;
79072805 2623 case '\020': /* ^P */
2fdbfb4d
AB
2624 PL_perldb = SvIV(sv);
2625 if (PL_perldb && !PL_DBsingle)
2626 init_debugger();
9b9e0be4 2627 break;
79072805 2628 case '\024': /* ^T */
88e89b8a 2629#ifdef BIG_TIME
6b88bc9c 2630 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2631#else
38ab35f8 2632 PL_basetime = (Time_t)SvIV(sv);
88e89b8a 2633#endif
79072805 2634 break;
e07ea26a
NC
2635 case '\025': /* ^UTF8CACHE */
2636 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2637 PL_utf8cache = (signed char) sv_2iv(sv);
2638 }
2639 break;
fde18df1 2640 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2641 if (*(mg->mg_ptr+1) == '\0') {
2642 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
38ab35f8 2643 i = SvIV(sv);
ac27b0f5 2644 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2645 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2646 }
599cee73 2647 }
0a378802 2648 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2649 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
7e4f0450
FC
2650 if (!SvPOK(sv)) {
2651 PL_compiling.cop_warnings = pWARN_STD;
d775746e
GS
2652 break;
2653 }
f4fc7782 2654 {
b5477537 2655 STRLEN len, i;
d3a7d8c7 2656 int accumulate = 0 ;
f4fc7782 2657 int any_fatals = 0 ;
b83604b4 2658 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2659 for (i = 0 ; i < len ; ++i) {
2660 accumulate |= ptr[i] ;
2661 any_fatals |= (ptr[i] & 0xAA) ;
2662 }
4243c432
NC
2663 if (!accumulate) {
2664 if (!specialWARN(PL_compiling.cop_warnings))
2665 PerlMemShared_free(PL_compiling.cop_warnings);
2666 PL_compiling.cop_warnings = pWARN_NONE;
2667 }
72dc9ed5 2668 /* Yuck. I can't see how to abstract this: */
2f3f0b56
KW
2669 else if (isWARN_on(
2670 ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2671 WARN_ALL)
2672 && !any_fatals)
2673 {
4243c432
NC
2674 if (!specialWARN(PL_compiling.cop_warnings))
2675 PerlMemShared_free(PL_compiling.cop_warnings);
f4fc7782
JH
2676 PL_compiling.cop_warnings = pWARN_ALL;
2677 PL_dowarn |= G_WARN_ONCE ;
727405f8 2678 }
d3a7d8c7 2679 else {
72dc9ed5
NC
2680 STRLEN len;
2681 const char *const p = SvPV_const(sv, len);
2682
2683 PL_compiling.cop_warnings
8ee4cf24 2684 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
72dc9ed5
NC
2685 p, len);
2686
d3a7d8c7
GS
2687 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2688 PL_dowarn |= G_WARN_ONCE ;
2689 }
f4fc7782 2690
d3a7d8c7 2691 }
4438c4b7 2692 }
971a9dd3 2693 }
79072805
LW
2694 break;
2695 case '.':
3280af22
NIS
2696 if (PL_localizing) {
2697 if (PL_localizing == 1)
7766f137 2698 SAVESPTR(PL_last_in_gv);
748a9306 2699 }
3280af22 2700 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2701 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2702 break;
2703 case '^':
acbe1b9d
FC
2704 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2705 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2706 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2707 break;
2708 case '~':
acbe1b9d
FC
2709 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2710 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2711 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2712 break;
2713 case '=':
acbe1b9d 2714 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2715 break;
2716 case '-':
acbe1b9d
FC
2717 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2718 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
099be4f1 2719 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2720 break;
2721 case '%':
acbe1b9d 2722 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2723 break;
2724 case '|':
4b65379b 2725 {
099be4f1 2726 IO * const io = GvIO(PL_defoutgv);
720f287d
AB
2727 if(!io)
2728 break;
38ab35f8 2729 if ((SvIV(sv)) == 0)
4b65379b
CS
2730 IoFLAGS(io) &= ~IOf_FLUSH;
2731 else {
2732 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2733 PerlIO *ofp = IoOFP(io);
2734 if (ofp)
2735 (void)PerlIO_flush(ofp);
2736 IoFLAGS(io) |= IOf_FLUSH;
2737 }
2738 }
79072805
LW
2739 }
2740 break;
79072805 2741 case '/':
3280af22 2742 SvREFCNT_dec(PL_rs);
8bfdd7d9 2743 PL_rs = newSVsv(sv);
79072805
LW
2744 break;
2745 case '\\':
ef8d46e8 2746 SvREFCNT_dec(PL_ors_sv);
6bc2995b 2747 if (SvOK(sv)) {
7889fe52 2748 PL_ors_sv = newSVsv(sv);
009c130f 2749 }
e3c19b7b 2750 else {
a0714e2c 2751 PL_ors_sv = NULL;
e3c19b7b 2752 }
79072805 2753 break;
7d69d4a6
FC
2754 case '[':
2755 if (SvIV(sv) != 0)
2756 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2757 break;
79072805 2758 case '?':
ff0cee69 2759#ifdef COMPLEX_STATUS
6b88bc9c 2760 if (PL_localizing == 2) {
41cb7b2b 2761 SvUPGRADE(sv, SVt_PVLV);
6b88bc9c
GS
2762 PL_statusvalue = LvTARGOFF(sv);
2763 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2764 }
2765 else
2766#endif
2767#ifdef VMSISH_STATUS
2768 if (VMSISH_STATUS)
fb38d079 2769 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
ff0cee69
PP
2770 else
2771#endif
38ab35f8 2772 STATUS_UNIX_EXIT_SET(SvIV(sv));
79072805
LW
2773 break;
2774 case '!':
93189314
JH
2775 {
2776#ifdef VMS
2777# define PERL_VMS_BANG vaxc$errno
2778#else
2779# define PERL_VMS_BANG 0
2780#endif
27329181 2781#if defined(WIN32) && ! defined(UNDER_CE)
c9beaf97
SH
2782 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
2783 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2784#else
91487cfc 2785 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314 2786 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
c9beaf97 2787#endif
93189314 2788 }
79072805
LW
2789 break;
2790 case '<':
985213f2 2791 {
04783dc7 2792 int rc = 0;
dfff4baf 2793 const Uid_t new_uid = SvUID(sv);
985213f2 2794 PL_delaymagic_uid = new_uid;
3280af22
NIS
2795 if (PL_delaymagic) {
2796 PL_delaymagic |= DM_RUID;
79072805
LW
2797 break; /* don't do magic till later */
2798 }
2799#ifdef HAS_SETRUID
04783dc7 2800 rc = setruid(new_uid);
79072805
LW
2801#else
2802#ifdef HAS_SETREUID
04783dc7 2803 rc = setreuid(new_uid, (Uid_t)-1);
748a9306 2804#else
85e6fe83 2805#ifdef HAS_SETRESUID
04783dc7 2806 rc = setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2807#else
985213f2 2808 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
75870ed3 2809#ifdef PERL_DARWIN
2810 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
985213f2 2811 if (new_uid != 0 && PerlProc_getuid() == 0)
04783dc7 2812 rc = PerlProc_setuid(0);
75870ed3 2813#endif
04783dc7 2814 rc = PerlProc_setuid(new_uid);
75870ed3 2815 } else {
cea2e8a9 2816 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2817 }
79072805
LW
2818#endif
2819#endif
85e6fe83 2820#endif
04783dc7
DM
2821 /* XXX $< currently silently ignores failures */
2822 PERL_UNUSED_VAR(rc);
79072805 2823 break;
985213f2 2824 }
79072805 2825 case '>':
985213f2 2826 {
04783dc7 2827 int rc = 0;
dfff4baf 2828 const Uid_t new_euid = SvUID(sv);
985213f2 2829 PL_delaymagic_euid = new_euid;
3280af22
NIS
2830 if (PL_delaymagic) {
2831 PL_delaymagic |= DM_EUID;
79072805
LW
2832 break; /* don't do magic till later */
2833 }
2834#ifdef HAS_SETEUID
04783dc7 2835 rc = seteuid(new_euid);
79072805
LW
2836#else
2837#ifdef HAS_SETREUID
04783dc7 2838 rc = setreuid((Uid_t)-1, new_euid);
85e6fe83
LW
2839#else
2840#ifdef HAS_SETRESUID
04783dc7 2841 rc = setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
79072805 2842#else
985213f2 2843 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
04783dc7 2844 rc = PerlProc_setuid(new_euid);
a0d0e21e 2845 else {
cea2e8a9 2846 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2847 }
79072805
LW
2848#endif
2849#endif
85e6fe83 2850#endif
04783dc7
DM
2851 /* XXX $> currently silently ignores failures */
2852 PERL_UNUSED_VAR(rc);
79072805 2853 break;
985213f2 2854 }
79072805 2855 case '(':
985213f2 2856 {
04783dc7 2857 int rc = 0;
dfff4baf 2858 const Gid_t new_gid = SvGID(sv);
985213f2 2859 PL_delaymagic_gid = new_gid;
3280af22
NIS
2860 if (PL_delaymagic) {
2861 PL_delaymagic |= DM_RGID;
79072805
LW
2862 break; /* don't do magic till later */
2863 }
2864#ifdef HAS_SETRGID
04783dc7 2865 rc = setrgid(new_gid);
79072805
LW
2866#else
2867#ifdef HAS_SETREGID
04783dc7 2868 rc = setregid(new_gid, (Gid_t)-1);
85e6fe83
LW
2869#else
2870#ifdef HAS_SETRESGID
04783dc7 2871 rc = setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
79072805 2872#else
985213f2 2873 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
04783dc7 2874 rc = PerlProc_setgid(new_gid);
748a9306 2875 else {
cea2e8a9 2876 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2877 }
79072805
LW
2878#endif
2879#endif
85e6fe83 2880#endif
04783dc7
DM
2881 /* XXX $( currently silently ignores failures */
2882 PERL_UNUSED_VAR(rc);
79072805 2883 break;
985213f2 2884 }
79072805 2885 case ')':
985213f2 2886 {
04783dc7 2887 int rc = 0;
dfff4baf 2888 Gid_t new_egid;
5cd24f17
PP
2889#ifdef HAS_SETGROUPS
2890 {
b83604b4 2891 const char *p = SvPV_const(sv, len);
757f63d8 2892 Groups_t *gary = NULL;
fb4089e0 2893#ifdef _SC_NGROUPS_MAX
2894 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2895
2896 if (maxgrp < 0)
2897 maxgrp = NGROUPS;
2898#else
2899 int maxgrp = NGROUPS;
2900#endif
757f63d8
SP
2901
2902 while (isSPACE(*p))
2903 ++p;
dfff4baf 2904 new_egid = (Gid_t)Atol(p);
fb4089e0 2905 for (i = 0; i < maxgrp; ++i) {
757f63d8
SP
2906 while (*p && !isSPACE(*p))
2907 ++p;
2908 while (isSPACE(*p))
2909 ++p;
2910 if (!*p)
2911 break;
2912 if(!gary)
2913 Newx(gary, i + 1, Groups_t);
2914 else
2915 Renew(gary, i + 1, Groups_t);
dfff4baf 2916 gary[i] = (Groups_t)Atol(p);
757f63d8
SP
2917 }
2918 if (i)
04783dc7 2919 rc = setgroups(i, gary);
f5a63d97 2920 Safefree(gary);
5cd24f17
PP
2921 }
2922#else /* HAS_SETGROUPS */
dfff4baf 2923 new_egid = SvGID(sv);
5cd24f17 2924#endif /* HAS_SETGROUPS */
985213f2 2925 PL_delaymagic_egid = new_egid;
3280af22
NIS
2926 if (PL_delaymagic) {
2927 PL_delaymagic |= DM_EGID;
79072805
LW
2928 break; /* don't do magic till later */
2929 }
2930#ifdef HAS_SETEGID
04783dc7 2931 rc = setegid(new_egid);
79072805
LW
2932#else
2933#ifdef HAS_SETREGID
04783dc7 2934 rc = setregid((Gid_t)-1, new_egid);
85e6fe83
LW
2935#else
2936#ifdef HAS_SETRESGID
04783dc7 2937 rc = setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
79072805 2938#else
985213f2 2939 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
04783dc7 2940 rc = PerlProc_setgid(new_egid);
748a9306 2941 else {
cea2e8a9 2942 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2943 }
79072805
LW
2944#endif
2945#endif
85e6fe83 2946#endif
04783dc7
DM
2947 /* XXX $) currently silently ignores failures */
2948 PERL_UNUSED_VAR(rc);
79072805 2949 break;
985213f2 2950 }
79072805 2951 case ':':
2d8e6c8d 2952 PL_chopset = SvPV_force(sv,len);
79072805 2953 break;
9cdac2a2
FC
2954 case '$': /* $$ */
2955 /* Store the pid in mg->mg_obj so we can tell when a fork has
2956 occurred. mg->mg_obj points to *$ by default, so clear it. */
2957 if (isGV(mg->mg_obj)) {
2958 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2959 SvREFCNT_dec(mg->mg_obj);
2960 mg->mg_flags |= MGf_REFCOUNTED;
2961 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2962 }
2963 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2964 break;
79072805 2965 case '0':
e2975953 2966 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2967#ifdef HAS_SETPROCTITLE
2968 /* The BSDs don't show the argv[] in ps(1) output, they
2969 * show a string from the process struct and provide
2970 * the setproctitle() routine to manipulate that. */
a2722ac9 2971 if (PL_origalen != 1) {
b83604b4 2972 s = SvPV_const(sv, len);
98b76f99 2973# if __FreeBSD_version > 410001
9aad2c0e 2974 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2975 * but not the "(perl) suffix from the ps(1)
2976 * output, because that's what ps(1) shows if the
2977 * argv[] is modified. */
6f2ad931 2978 setproctitle("-%s", s);
9aad2c0e 2979# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2980 /* This doesn't really work if you assume that
2981 * $0 = 'foobar'; will wipe out 'perl' from the $0
2982 * because in ps(1) output the result will be like
2983 * sprintf("perl: %s (perl)", s)
2984 * I guess this is a security feature:
2985 * one (a user process) cannot get rid of the original name.
2986 * --jhi */
2987 setproctitle("%s", s);
2988# endif
2989 }
9d3968b2 2990#elif defined(__hpux) && defined(PSTAT_SETCMD)
a2722ac9 2991 if (PL_origalen != 1) {
17aa7f3d 2992 union pstun un;
b83604b4 2993 s = SvPV_const(sv, len);
6867be6d 2994 un.pst_command = (char *)s;
17aa7f3d
JH
2995 pstat(PSTAT_SETCMD, un, len, 0, 0);
2996 }
9d3968b2 2997#else
2d2af554
GA
2998 if (PL_origalen > 1) {
2999 /* PL_origalen is set in perl_parse(). */
3000 s = SvPV_force(sv,len);
3001 if (len >= (STRLEN)PL_origalen-1) {
3002 /* Longer than original, will be truncated. We assume that
3003 * PL_origalen bytes are available. */
3004 Copy(s, PL_origargv[0], PL_origalen-1, char);
3005 }
3006 else {
3007 /* Shorter than original, will be padded. */
235ac35d 3008#ifdef PERL_DARWIN
60777a0d
JH
3009 /* Special case for Mac OS X: see [perl #38868] */
3010 const int pad = 0;
235ac35d 3011#else
8a89a4f1
MB
3012 /* Is the space counterintuitive? Yes.
3013 * (You were expecting \0?)
3014 * Does it work? Seems to. (In Linux 2.4.20 at least.)
3015 * --jhi */
60777a0d 3016 const int pad = ' ';
235ac35d 3017#endif
60777a0d
JH
3018 Copy(s, PL_origargv[0], len, char);
3019 PL_origargv[0][len] = 0;
3020 memset(PL_origargv[0] + len + 1,
3021 pad, PL_origalen - len - 1);
2d2af554
GA
3022 }
3023 PL_origargv[0][PL_origalen-1] = 0;
3024 for (i = 1; i < PL_origargc; i++)
3025 PL_origargv[i] = 0;
7636ea95
AB
3026#ifdef HAS_PRCTL_SET_NAME
3027 /* Set the legacy process name in addition to the POSIX name on Linux */
3028 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3029 /* diag_listed_as: SKIPME */
3030 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3031 }
3032#endif
79072805 3033 }
9d3968b2 3034#endif
e2975953 3035 UNLOCK_DOLLARZERO_MUTEX;
79072805
LW
3036 break;
3037 }
3038 return 0;
3039}
3040
3041I32
84c7b88c
BF
3042Perl_whichsig_sv(pTHX_ SV *sigsv)
3043{
3044 const char *sigpv;
3045 STRLEN siglen;
3046 PERL_ARGS_ASSERT_WHICHSIG_SV;
3047 PERL_UNUSED_CONTEXT;
3048 sigpv = SvPV_const(sigsv, siglen);
3049 return whichsig_pvn(sigpv, siglen);
3050}
3051
3052I32
3053Perl_whichsig_pv(pTHX_ const char *sig)
3054{
3055 PERL_ARGS_ASSERT_WHICHSIG_PV;
3056 PERL_UNUSED_CONTEXT;
3057 return whichsig_pvn(sig, strlen(sig));
3058}
3059
3060I32
3061Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
79072805 3062{
eb578fdb 3063 char* const* sigv;
7918f24d 3064
84c7b88c 3065 PERL_ARGS_ASSERT_WHICHSIG_PVN;
96a5add6 3066 PERL_UNUSED_CONTEXT;
79072805 3067
aadb217d 3068 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
84c7b88c 3069 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
aadb217d 3070 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805 3071#ifdef SIGCLD
84c7b88c 3072 if (memEQs(sig, len, "CHLD"))
79072805
LW
3073 return SIGCLD;
3074#endif
3075#ifdef SIGCHLD
84c7b88c 3076 if (memEQs(sig, len, "CLD"))
79072805
LW
3077 return SIGCHLD;
3078#endif
7f1236c0 3079 return -1;
79072805
LW
3080}
3081
ecfc5424 3082Signal_t
1e82f5a6 3083#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b3dbdd48 3084Perl_sighandler(int sig, siginfo_t *sip, void *uap)
1e82f5a6
SH
3085#else
3086Perl_sighandler(int sig)
3087#endif
79072805 3088{
1018e26f
NIS
3089#ifdef PERL_GET_SIG_CONTEXT
3090 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 3091#else
cea2e8a9 3092 dTHX;
71d280e3 3093#endif
79072805 3094 dSP;
a0714e2c
SS
3095 GV *gv = NULL;
3096 SV *sv = NULL;
8772537c 3097 SV * const tSv = PL_Sv;
601f1833 3098 CV *cv = NULL;
533c011a 3099 OP *myop = PL_op;
84902520 3100 U32 flags = 0;
8772537c 3101 XPV * const tXpv = PL_Xpv;
0c4d3b5e 3102 I32 old_ss_ix = PL_savestack_ix;
100c03aa 3103 SV *errsv_save = NULL;
71d280e3 3104
84902520 3105
727405f8 3106 if (!PL_psig_ptr[sig]) {
99ef548b 3107 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
3108 PL_sig_name[sig]);
3109 exit(sig);
3110 }
ff0cee69 3111
a0d63a7b
DM
3112 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3113 /* Max number of items pushed there is 3*n or 4. We cannot fix
3114 infinity, so we fix 4 (in fact 5): */
3115 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3116 flags |= 1;
3117 PL_savestack_ix += 5; /* Protect save in progress. */
3118 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3119 }
84902520 3120 }
84902520 3121 /* sv_2cv is too complicated, try a simpler variant first: */
ea726b52 3122 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
8772537c
AL
3123 || SvTYPE(cv) != SVt_PVCV) {
3124 HV *st;
f2c0649b 3125 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 3126 }
84902520 3127
a0d0e21e 3128 if (!cv || !CvROOT(cv)) {
a2a5de95
NC
3129 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3130 PL_sig_name[sig], (gv ? GvENAME(gv)
3131 : ((cv && CvGV(cv))
3132 ? GvENAME(CvGV(cv))
3133 : "__ANON__")));
00d579c5 3134 goto cleanup;
79072805
LW
3135 }
3136
0c4d3b5e
DM
3137 sv = PL_psig_name[sig]
3138 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3139 : newSVpv(PL_sig_name[sig],0);
72048cfe 3140 flags |= 8;
0c4d3b5e
DM
3141 SAVEFREESV(sv);
3142
a0d63a7b
DM
3143 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3144 /* make sure our assumption about the size of the SAVEs are correct:
3145 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3146 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3147 }
e336de0d 3148
e788e7d3 3149 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 3150 PUSHMARK(SP);
79072805 3151 PUSHs(sv);
8aad04aa
JH
3152#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3153 {
3154 struct sigaction oact;
3155
3156 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
8aad04aa
JH
3157 if (sip) {
3158 HV *sih = newHV();
ad64d0ec 3159 SV *rv = newRV_noinc(MUTABLE_SV(sih));
8aad04aa
JH
3160 /* The siginfo fields signo, code, errno, pid, uid,
3161 * addr, status, and band are defined by POSIX/SUSv3. */
85771703
NC
3162 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3163 (void)hv_stores(sih, "code", newSViv(sip->si_code));
79dec0f4 3164#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. */
85771703
NC
3165 hv_stores(sih, "errno", newSViv(sip->si_errno));
3166 hv_stores(sih, "status", newSViv(sip->si_status));
3167 hv_stores(sih, "uid", newSViv(sip->si_uid));
3168 hv_stores(sih, "pid", newSViv(sip->si_pid));
3169 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3170 hv_stores(sih, "band", newSViv(sip->si_band));
79dec0f4 3171#endif
8aad04aa 3172 EXTEND(SP, 2);
ad64d0ec 3173 PUSHs(rv);
22f1178f 3174 mPUSHp((char *)sip, sizeof(*sip));
8aad04aa 3175 }
b4552a27 3176
8aad04aa
JH
3177 }
3178 }
3179#endif
79072805 3180 PUTBACK;
a0d0e21e 3181
100c03aa
JL
3182 errsv_save = newSVsv(ERRSV);
3183
ad64d0ec 3184 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
79072805 3185
d3acc0f7 3186 POPSTACK;
eed484f9
DD
3187 {
3188 SV * const errsv = ERRSV;
3189 if (SvTRUE_NN(errsv)) {
3190 SvREFCNT_dec(errsv_save);
c22d665b 3191#ifndef PERL_MICRO
1b266415
NIS
3192 /* Handler "died", for example to get out of a restart-able read().
3193 * Before we re-do that on its behalf re-enable the signal which was
3194 * blocked by the system when we entered.
3195 */
c22d665b 3196#ifdef HAS_SIGPROCMASK
d488af49 3197#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
eed484f9 3198 if (sip || uap)
c22d665b 3199#endif
eed484f9
DD
3200 {
3201 sigset_t set;
3202 sigemptyset(&set);
3203 sigaddset(&set,sig);
3204 sigprocmask(SIG_UNBLOCK, &set, NULL);
3205 }
c22d665b 3206#else
eed484f9
DD
3207 /* Not clear if this will work */
3208 (void)rsignal(sig, SIG_IGN);
3209 (void)rsignal(sig, PL_csighandlerp);
c22d665b
LT
3210#endif
3211#endif /* !PERL_MICRO */
eed484f9
DD
3212 die_sv(errsv);
3213 }
3214 else {
3215 sv_setsv(errsv, errsv_save);
3216 SvREFCNT_dec(errsv_save);
3217 }
100c03aa
JL
3218 }
3219
00d579c5 3220cleanup:
0c4d3b5e
DM
3221 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3222 PL_savestack_ix = old_ss_ix;
72048cfe 3223 if (flags & 8)
2357bae7 3224 SvREFCNT_dec_NN(sv);
533c011a 3225 PL_op = myop; /* Apparently not needed... */
ac27b0f5 3226
3280af22
NIS
3227 PL_Sv = tSv; /* Restore global temporaries. */
3228 PL_Xpv = tXpv;
53bb94e2 3229 return;
79072805 3230}
4e35701f
NIS
3231
3232
51371543 3233static void
8772537c 3234S_restore_magic(pTHX_ const void *p)
51371543 3235{
97aff369 3236 dVAR;
8772537c
AL
3237 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3238 SV* const sv = mgs->mgs_sv;
150b625d 3239 bool bumped;
51371543
GS
3240
3241 if (!sv)
3242 return;
3243
4bac9ae4
CS
3244 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3245 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
f8c7b90f 3246#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
3247 /* While magic was saved (and off) sv_setsv may well have seen
3248 this SV as a prime candidate for COW. */
3249 if (SvIsCOW(sv))
e424a81e 3250 sv_force_normal_flags(sv, 0);
f9701176 3251#endif
f9c6fee5
CS
3252 if (mgs->mgs_readonly)
3253 SvREADONLY_on(sv);
3254 if (mgs->mgs_magical)
3255 SvFLAGS(sv) |= mgs->mgs_magical;
51371543
GS
3256 else
3257 mg_magical(sv);
51371543
GS
3258 }
3259
150b625d 3260 bumped = mgs->mgs_bumped;
51371543
GS
3261 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3262
3263 /* If we're still on top of the stack, pop us off. (That condition
3264 * will be satisfied if restore_magic was called explicitly, but *not*
3265 * if it's being called via leave_scope.)
3266 * The reason for doing this is that otherwise, things like sv_2cv()
3267 * may leave alloc gunk on the savestack, and some code
3268 * (e.g. sighandler) doesn't expect that...
3269 */
3270 if (PL_savestack_ix == mgs->mgs_ss_ix)
3271 {
1be36ce0
NC
3272 UV popval = SSPOPUV;
3273 assert(popval == SAVEt_DESTRUCTOR_X);
51371543 3274 PL_savestack_ix -= 2;
1be36ce0
NC
3275 popval = SSPOPUV;
3276 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3277 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
51371543 3278 }
150b625d
DM
3279 if (bumped) {
3280 if (SvREFCNT(sv) == 1) {
3281 /* We hold the last reference to this SV, which implies that the
3282 SV was deleted as a side effect of the routines we called.
3283 So artificially keep it alive a bit longer.
3284 We avoid turning on the TEMP flag, which can cause the SV's
3285 buffer to get stolen (and maybe other stuff). */
150b625d 3286 sv_2mortal(sv);
4bac9ae4 3287 SvTEMP_off(sv);
8985fe98 3288 }
150b625d 3289 else
2357bae7 3290 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
8985fe98 3291 }
51371543
GS
3292}
3293
0c4d3b5e
DM
3294/* clean up the mess created by Perl_sighandler().
3295 * Note that this is only called during an exit in a signal handler;
3296 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
9a7f166c 3297 * skipped over. */
0c4d3b5e 3298
51371543 3299static void
8772537c 3300S_unwind_handler_stack(pTHX_ const void *p)
51371543 3301{
27da23d5 3302 dVAR;
0c4d3b5e 3303 PERL_UNUSED_ARG(p);
7918f24d 3304
0c4d3b5e 3305 PL_savestack_ix -= 5; /* Unprotect save in progress. */
51371543 3306}
1018e26f 3307
66610fdd 3308/*
b3ca2e83
NC
3309=for apidoc magic_sethint
3310
3311Triggered by a store to %^H, records the key/value pair to
c28fe1ec
NC
3312C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3313anything that would need a deep copy. Maybe we should warn if we find a
3314reference.
b3ca2e83
NC
3315
3316=cut
3317*/
3318int
3319Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3320{
3321 dVAR;
ad64d0ec 3322 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
59cd0e26 3323 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
b3ca2e83 3324
7918f24d
NC
3325 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3326
e6e3e454
NC
3327 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3328 an alternative leaf in there, with PL_compiling.cop_hints being used if
3329 it's NULL. If needed for threads, the alternative could lock a mutex,
3330 or take other more complex action. */
3331
5b9c0671
NC
3332 /* Something changed in %^H, so it will need to be restored on scope exit.
3333 Doing this here saves a lot of doing it manually in perl code (and
3334 forgetting to do it, and consequent subtle errors. */
3335 PL_hints |= HINT_LOCALIZE_HH;
20439bc7
Z
3336 CopHINTHASH_set(&PL_compiling,
3337 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
b3ca2e83
NC
3338 return 0;
3339}
3340
3341/*
f175cff5 3342=for apidoc magic_clearhint
b3ca2e83 3343
c28fe1ec
NC
3344Triggered by a delete from %^H, records the key to
3345C<PL_compiling.cop_hints_hash>.
b3ca2e83
NC
3346
3347=cut
3348*/
3349int
3350Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3351{
3352 dVAR;
7918f24d
NC
3353
3354 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
f5a63d97
AL
3355 PERL_UNUSED_ARG(sv);
3356
5b9c0671 3357 PL_hints |= HINT_LOCALIZE_HH;
20439bc7 3358 CopHINTHASH_set(&PL_compiling,
e3352591
FC
3359 mg->mg_len == HEf_SVKEY
3360 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3361 MUTABLE_SV(mg->mg_ptr), 0, 0)
3362 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3363 mg->mg_ptr, mg->mg_len, 0, 0));
b3ca2e83
NC
3364 return 0;
3365}
3366
3367/*
f747ebd6
Z
3368=for apidoc magic_clearhints
3369
3370Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3371
3372=cut
3373*/
3374int
3375Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3376{
3377 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3378 PERL_UNUSED_ARG(sv);
3379 PERL_UNUSED_ARG(mg);
20439bc7
Z
3380 cophh_free(CopHINTHASH_get(&PL_compiling));
3381 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
f747ebd6
Z
3382 return 0;
3383}
3384
09fb282d
FC
3385int
3386Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3387 const char *name, I32 namlen)
3388{
3389 MAGIC *nmg;
3390
3391 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
4f8dbb2d 3392 PERL_UNUSED_ARG(sv);
09fb282d
FC
3393 PERL_UNUSED_ARG(name);
3394 PERL_UNUSED_ARG(namlen);
3395
3396 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3397 nmg = mg_find(nsv, mg->mg_type);
3398 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3399 nmg->mg_ptr = mg->mg_ptr;
3400 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3401 nmg->mg_flags |= MGf_REFCOUNTED;
3402 return 1;
3403}
3404
f747ebd6 3405/*
66610fdd
RGS
3406 * Local variables:
3407 * c-indentation-style: bsd
3408 * c-basic-offset: 4
14d04a33 3409 * indent-tabs-mode: nil
66610fdd
RGS
3410 * End:
3411 *
14d04a33 3412 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3413 */