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