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