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