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