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