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