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