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