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