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