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