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