1 /* mg.c
2 *
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
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 *
9 */
10
11 /*
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"]
16 */
17
18 /*
19 =head1 Magic
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,
22 an SV marked as magical, it calls the 'get' or 'set' function associated
23 with that SV's magic. A get is called prior to reading an SV, in order to
24 give it a chance to update its internal value (get on $. writes the line
25 number of the last read filehandle into the SV's IV slot), while
26 set is called after an SV has been written to, in order to allow it to make
27 use of its changed value (set on $/ copies the SV's new value to the
28 PL_rs global variable).
29
30 Magic is implemented as a linked list of MAGIC structures attached to the
31 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
32 of functions that implement the get(), set(), length() etc functions,
33 plus space for some flags and pointers. For example, a tied variable has
34 a MAGIC structure that contains a pointer to the object associated with the
35 tie.
36
37 =for apidoc Ayh||MAGIC
38
39 =cut
40
41 */
42
43 #include "EXTERN.h"
44 #define PERL_IN_MG_C
45 #include "perl.h"
46 #include "feature.h"
47
48 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
49 # ifdef I_GRP
50 # include <grp.h>
51 # endif
52 #endif
53
54 #if defined(HAS_SETGROUPS)
55 # ifndef NGROUPS
56 # define NGROUPS 32
57 # endif
58 #endif
59
60 #ifdef __hpux
61 # include <sys/pstat.h>
62 #endif
63
64 #ifdef HAS_PRCTL_SET_NAME
65 # include <sys/prctl.h>
66 #endif
67
68 #ifdef __Lynx__
69 /* Missing protos on LynxOS */
70 void setruid(uid_t id);
71 void seteuid(uid_t id);
72 void setrgid(uid_t id);
73 void setegid(uid_t id);
74 #endif
75
76 /*
77 * Pre-magic setup and post-magic takedown.
78 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
79 */
80
81 struct magic_state {
82 SV* mgs_sv;
83 I32 mgs_ss_ix;
84 U32 mgs_flags;
85 bool mgs_bumped;
86 };
87 /* MGS is typedef'ed to struct magic_state in perl.h */
88
89 STATIC void
S_save_magic_flags(pTHX_ SSize_t mgs_ix,SV * sv,U32 flags)90 S_save_magic_flags(pTHX_ SSize_t mgs_ix, SV *sv, U32 flags)
91 {
92 MGS* mgs;
93 bool bumped = FALSE;
94
95 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
96
97 assert(SvMAGICAL(sv));
98
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 }
109
110 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
111
112 mgs = SSPTR(mgs_ix, MGS*);
113 mgs->mgs_sv = sv;
114 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
115 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
116 mgs->mgs_bumped = bumped;
117
118 SvFLAGS(sv) &= ~flags;
119 SvREADONLY_off(sv);
120 }
121
122 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
123
124 /*
125 =for apidoc mg_magical
126
127 Turns on the magical status of an SV. See C<L</sv_magic>>.
128
129 =cut
130 */
131
132 void
Perl_mg_magical(SV * sv)133 Perl_mg_magical(SV *sv)
134 {
135 const MAGIC* mg;
136 PERL_ARGS_ASSERT_MG_MAGICAL;
137
138 SvMAGICAL_off(sv);
139 if ((mg = SvMAGIC(sv))) {
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);
153 }
154 }
155
156 /*
157 =for apidoc mg_get
158
159 Do magic before a value is retrieved from the SV. The type of SV must
160 be >= C<SVt_PVMG>. See C<L</sv_magic>>.
161
162 =cut
163 */
164
165 int
Perl_mg_get(pTHX_ SV * sv)166 Perl_mg_get(pTHX_ SV *sv)
167 {
168 const SSize_t mgs_ix = SSNEW(sizeof(MGS));
169 bool saved = FALSE;
170 bool have_new = 0;
171 bool taint_only = TRUE; /* the only get method seen is taint */
172 MAGIC *newmg, *head, *cur, *mg;
173
174 PERL_ARGS_ASSERT_MG_GET;
175
176 if (PL_localizing == 1 && sv == DEFSV) return 0;
177
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) {
184 const MGVTBL * const vtbl = mg->mg_virtual;
185 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
186
187 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
188
189 /* taint's mg get is so dumb it doesn't need flag saving */
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 }
197
198 vtbl->svt_get(aTHX_ sv, mg);
199
200 /* guard against magic having been deleted - eg FETCH calling
201 * untie */
202 if (!SvMAGIC(sv)) {
203 /* recalculate flags */
204 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
205 break;
206 }
207
208 /* recalculate flags if this entry was deleted. */
209 if (mg->mg_flags & MGf_GSKIP)
210 (SSPTR(mgs_ix, MGS *))->mgs_flags &=
211 ~(SVs_GMG|SVs_SMG|SVs_RMG);
212 }
213 else if (vtbl == &PL_vtbl_utf8) {
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);
231 }
232
233 mg = nextmg;
234
235 if (have_new) {
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) {
239 have_new = 0;
240 mg = cur;
241 head = newmg;
242 }
243 }
244
245 /* Were any new entries added? */
246 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
247 have_new = 1;
248 cur = mg;
249 mg = newmg;
250 /* recalculate flags */
251 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
252 }
253 }
254
255 if (saved)
256 restore_magic(INT2PTR(void *, (IV)mgs_ix));
257
258 return 0;
259 }
260
261 /*
262 =for apidoc mg_set
263
264 Do magic after a value is assigned to the SV. See C<L</sv_magic>>.
265
266 =cut
267 */
268
269 int
Perl_mg_set(pTHX_ SV * sv)270 Perl_mg_set(pTHX_ SV *sv)
271 {
272 const SSize_t mgs_ix = SSNEW(sizeof(MGS));
273 MAGIC* mg;
274 MAGIC* nextmg;
275
276 PERL_ARGS_ASSERT_MG_SET;
277
278 if (PL_localizing == 2 && sv == DEFSV) return 0;
279
280 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
281
282 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
283 const MGVTBL* vtbl = mg->mg_virtual;
284 nextmg = mg->mg_moremagic; /* it may delete itself */
285 if (mg->mg_flags & MGf_GSKIP) {
286 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
287 (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
288 }
289 if (PL_localizing == 2
290 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
291 continue;
292 if (vtbl && vtbl->svt_set)
293 vtbl->svt_set(aTHX_ sv, mg);
294 }
295
296 restore_magic(INT2PTR(void*, (IV)mgs_ix));
297 return 0;
298 }
299
300 I32
Perl_mg_size(pTHX_ SV * sv)301 Perl_mg_size(pTHX_ SV *sv)
302 {
303 MAGIC* mg;
304
305 PERL_ARGS_ASSERT_MG_SIZE;
306
307 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
308 const MGVTBL* const vtbl = mg->mg_virtual;
309 if (vtbl && vtbl->svt_len) {
310 const SSize_t mgs_ix = SSNEW(sizeof(MGS));
311 I32 len;
312 save_magic(mgs_ix, sv);
313 /* omit MGf_GSKIP -- not changed here */
314 len = vtbl->svt_len(aTHX_ sv, mg);
315 restore_magic(INT2PTR(void*, (IV)mgs_ix));
316 return len;
317 }
318 }
319
320 switch(SvTYPE(sv)) {
321 case SVt_PVAV:
322 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
323 case SVt_PVHV:
324 /* FIXME */
325 default:
326 Perl_croak(aTHX_ "Size magic not implemented");
327
328 }
329 NOT_REACHED; /* NOTREACHED */
330 }
331
332 /*
333 =for apidoc mg_clear
334
335 Clear something magical that the SV represents. See C<L</sv_magic>>.
336
337 =cut
338 */
339
340 int
Perl_mg_clear(pTHX_ SV * sv)341 Perl_mg_clear(pTHX_ SV *sv)
342 {
343 const SSize_t mgs_ix = SSNEW(sizeof(MGS));
344 MAGIC* mg;
345 MAGIC *nextmg;
346
347 PERL_ARGS_ASSERT_MG_CLEAR;
348
349 save_magic(mgs_ix, sv);
350
351 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
352 const MGVTBL* const vtbl = mg->mg_virtual;
353 /* omit GSKIP -- never set here */
354
355 nextmg = mg->mg_moremagic; /* it may delete itself */
356
357 if (vtbl && vtbl->svt_clear)
358 vtbl->svt_clear(aTHX_ sv, mg);
359 }
360
361 restore_magic(INT2PTR(void*, (IV)mgs_ix));
362 return 0;
363 }
364
365 static MAGIC*
S_mg_findext_flags(const SV * sv,int type,const MGVTBL * vtbl,U32 flags)366 S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
367 {
368 assert(flags <= 1);
369
370 if (sv) {
371 MAGIC *mg;
372
373 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
374 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
375 return mg;
376 }
377 }
378 }
379
380 return NULL;
381 }
382
383 /*
384 =for apidoc mg_find
385
386 Finds the magic pointer for C<type> matching the SV. See C<L</sv_magic>>.
387
388 =cut
389 */
390
391 MAGIC*
Perl_mg_find(const SV * sv,int type)392 Perl_mg_find(const SV *sv, int type)
393 {
394 return S_mg_findext_flags(sv, type, NULL, 0);
395 }
396
397 /*
398 =for apidoc mg_findext
399
400 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
401 C<L</sv_magicext>>.
402
403 =cut
404 */
405
406 MAGIC*
Perl_mg_findext(const SV * sv,int type,const MGVTBL * vtbl)407 Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl)
408 {
409 return S_mg_findext_flags(sv, type, vtbl, 1);
410 }
411
412 MAGIC *
Perl_mg_find_mglob(pTHX_ SV * sv)413 Perl_mg_find_mglob(pTHX_ SV *sv)
414 {
415 PERL_ARGS_ASSERT_MG_FIND_MGLOB;
416 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
417 /* This sv is only a delegate. //g magic must be attached to
418 its target. */
419 vivify_defelem(sv);
420 sv = LvTARG(sv);
421 }
422 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
423 return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0);
424 return NULL;
425 }
426
427 /*
428 =for apidoc mg_copy
429
430 Copies the magic from one SV to another. See C<L</sv_magic>>.
431
432 =cut
433 */
434
435 int
Perl_mg_copy(pTHX_ SV * sv,SV * nsv,const char * key,I32 klen)436 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
437 {
438 int count = 0;
439 MAGIC* mg;
440
441 PERL_ARGS_ASSERT_MG_COPY;
442
443 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
444 const MGVTBL* const vtbl = mg->mg_virtual;
445 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
446 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
447 }
448 else {
449 const char type = mg->mg_type;
450 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
451 sv_magic(nsv,
452 (type == PERL_MAGIC_tied)
453 ? SvTIED_obj(sv, mg)
454 : mg->mg_obj,
455 toLOWER(type), key, klen);
456 count++;
457 }
458 }
459 }
460 return count;
461 }
462
463 /*
464 =for apidoc mg_localize
465
466 Copy some of the magic from an existing SV to new localized version of that
467 SV. Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>)
468 gets copied, value magic doesn't (I<e.g.>,
469 C<taint>, C<pos>).
470
471 If C<setmagic> is false then no set magic will be called on the new (empty) SV.
472 This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>),
473 and that will handle the magic.
474
475 =cut
476 */
477
478 void
Perl_mg_localize(pTHX_ SV * sv,SV * nsv,bool setmagic)479 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
480 {
481 MAGIC *mg;
482
483 PERL_ARGS_ASSERT_MG_LOCALIZE;
484
485 if (nsv == DEFSV)
486 return;
487
488 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
489 const MGVTBL* const vtbl = mg->mg_virtual;
490 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
491 continue;
492
493 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
494 (void)vtbl->svt_local(aTHX_ nsv, mg);
495 else
496 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
497 mg->mg_ptr, mg->mg_len);
498
499 /* container types should remain read-only across localization */
500 SvFLAGS(nsv) |= SvREADONLY(sv);
501 }
502
503 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
504 SvFLAGS(nsv) |= SvMAGICAL(sv);
505 if (setmagic) {
506 PL_localizing = 1;
507 SvSETMAGIC(nsv);
508 PL_localizing = 0;
509 }
510 }
511 }
512
513 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
514 static void
S_mg_free_struct(pTHX_ SV * sv,MAGIC * mg)515 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
516 {
517 const MGVTBL* const vtbl = mg->mg_virtual;
518 if (vtbl && vtbl->svt_free)
519 vtbl->svt_free(aTHX_ sv, mg);
520
521 if (mg->mg_len > 0)
522 Safefree(mg->mg_ptr);
523 else if (mg->mg_len == HEf_SVKEY)
524 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
525
526 if (mg->mg_flags & MGf_REFCOUNTED)
527 SvREFCNT_dec(mg->mg_obj);
528 Safefree(mg);
529 }
530
531 /*
532 =for apidoc mg_free
533
534 Free any magic storage used by the SV. See C<L</sv_magic>>.
535
536 =cut
537 */
538
539 int
Perl_mg_free(pTHX_ SV * sv)540 Perl_mg_free(pTHX_ SV *sv)
541 {
542 MAGIC* mg;
543 MAGIC* moremagic;
544
545 PERL_ARGS_ASSERT_MG_FREE;
546
547 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
548 moremagic = mg->mg_moremagic;
549 mg_free_struct(sv, mg);
550 SvMAGIC_set(sv, moremagic);
551 }
552 SvMAGIC_set(sv, NULL);
553 SvMAGICAL_off(sv);
554 return 0;
555 }
556
557 /*
558 =for apidoc mg_free_type
559
560 Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
561
562 =cut
563 */
564
565 void
Perl_mg_free_type(pTHX_ SV * sv,int how)566 Perl_mg_free_type(pTHX_ SV *sv, int how)
567 {
568 MAGIC *mg, *prevmg, *moremg;
569 PERL_ARGS_ASSERT_MG_FREE_TYPE;
570 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
571 moremg = mg->mg_moremagic;
572 if (mg->mg_type == how) {
573 MAGIC *newhead;
574 /* temporarily move to the head of the magic chain, in case
575 custom free code relies on this historical aspect of mg_free */
576 if (prevmg) {
577 prevmg->mg_moremagic = moremg;
578 mg->mg_moremagic = SvMAGIC(sv);
579 SvMAGIC_set(sv, mg);
580 }
581 newhead = mg->mg_moremagic;
582 mg_free_struct(sv, mg);
583 SvMAGIC_set(sv, newhead);
584 mg = prevmg;
585 }
586 }
587 mg_magical(sv);
588 }
589
590 /*
591 =for apidoc mg_freeext
592
593 Remove any magic of type C<how> using virtual table C<vtbl> from the
594 SV C<sv>. See L</sv_magic>.
595
596 C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>.
597
598 =cut
599 */
600
601 void
Perl_mg_freeext(pTHX_ SV * sv,int how,const MGVTBL * vtbl)602 Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl)
603 {
604 MAGIC *mg, *prevmg, *moremg;
605 PERL_ARGS_ASSERT_MG_FREEEXT;
606 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
607 MAGIC *newhead;
608 moremg = mg->mg_moremagic;
609 if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) {
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
626 #include <signal.h>
627
628 U32
Perl_magic_regdata_cnt(pTHX_ SV * sv,MAGIC * mg)629 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
630 {
631 PERL_UNUSED_ARG(sv);
632
633 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
634
635 if (PL_curpm) {
636 REGEXP * const rx = PM_GETRE(PL_curpm);
637 if (rx) {
638 const SSize_t n = (SSize_t)mg->mg_obj;
639 if (n == '+') { /* @+ */
640 /* return the number possible */
641 return RX_LOGICAL_NPARENS(rx) ? RX_LOGICAL_NPARENS(rx) : RX_NPARENS(rx);
642 } else { /* @- @^CAPTURE @{^CAPTURE} */
643 I32 paren = RX_LASTPAREN(rx);
644
645 /* return the last filled */
646 while ( paren >= 0 && !RX_OFFS_VALID(rx,paren) )
647 paren--;
648 if (paren && RX_PARNO_TO_LOGICAL(rx))
649 paren = RX_PARNO_TO_LOGICAL(rx)[paren];
650 if (n == '-') {
651 /* @- */
652 return (U32)paren;
653 } else {
654 /* @^CAPTURE @{^CAPTURE} */
655 return paren >= 0 ? (U32)(paren-1) : (U32)-1;
656 }
657 }
658 }
659 }
660
661 return (U32)-1;
662 }
663
664 /* @-, @+ */
665
666 int
Perl_magic_regdatum_get(pTHX_ SV * sv,MAGIC * mg)667 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
668 {
669 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
670 REGEXP * const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
671
672 if (rx) {
673 const SSize_t n = (SSize_t)mg->mg_obj;
674 /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
675 const I32 paren = mg->mg_len
676 + (n == '\003' ? 1 : 0);
677
678 if (paren < 0)
679 return 0;
680
681 SSize_t s;
682 SSize_t t;
683 I32 logical_nparens = (I32)RX_LOGICAL_NPARENS(rx);
684
685 if (!logical_nparens)
686 logical_nparens = (I32)RX_NPARENS(rx);
687
688 if (n != '+' && n != '-') {
689 CALLREG_NUMBUF_FETCH(rx,paren,sv);
690 return 0;
691 }
692 if (paren <= (I32)logical_nparens) {
693 I32 true_paren = RX_LOGICAL_TO_PARNO(rx)
694 ? RX_LOGICAL_TO_PARNO(rx)[paren]
695 : paren;
696 do {
697 if (((s = RX_OFFS_START(rx,true_paren)) != -1) &&
698 ((t = RX_OFFS_END(rx,true_paren)) != -1))
699 {
700 SSize_t i;
701
702 if (n == '+') /* @+ */
703 i = t;
704 else /* @- */
705 i = s;
706
707 if (RX_MATCH_UTF8(rx)) {
708 const char * const b = RX_SUBBEG(rx);
709 if (b)
710 i = RX_SUBCOFFSET(rx) +
711 utf8_length((U8*)b,
712 (U8*)(b-RX_SUBOFFSET(rx)+i));
713 }
714
715 sv_setuv(sv, i);
716 return 0;
717 }
718 if (RX_PARNO_TO_LOGICAL_NEXT(rx))
719 true_paren = RX_PARNO_TO_LOGICAL_NEXT(rx)[true_paren];
720 else
721 break;
722 } while (true_paren);
723 }
724 }
725 sv_set_undef(sv);
726 return 0;
727 }
728
729 /* @-, @+ */
730
731 int
Perl_magic_regdatum_set(pTHX_ SV * sv,MAGIC * mg)732 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
733 {
734 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
735 PERL_UNUSED_CONTEXT;
736 PERL_UNUSED_ARG(sv);
737 PERL_UNUSED_ARG(mg);
738 Perl_croak_no_modify();
739 NORETURN_FUNCTION_END;
740 }
741
742 #define SvRTRIM(sv) STMT_START { \
743 SV * sv_ = sv; \
744 if (SvPOK(sv_)) { \
745 STRLEN len = SvCUR(sv_); \
746 char * const p = SvPVX(sv_); \
747 while (len > 0 && isSPACE(p[len-1])) \
748 --len; \
749 SvCUR_set(sv_, len); \
750 p[len] = '\0'; \
751 } \
752 } STMT_END
753
754 void
Perl_emulate_cop_io(pTHX_ const COP * const c,SV * const sv)755 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
756 {
757 PERL_ARGS_ASSERT_EMULATE_COP_IO;
758
759 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
760 sv_set_undef(sv);
761 else {
762 SvPVCLEAR(sv);
763 SvUTF8_off(sv);
764 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
765 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
766 assert(value);
767 sv_catsv(sv, value);
768 }
769 sv_catpvs(sv, "\0");
770 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
771 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
772 assert(value);
773 sv_catsv(sv, value);
774 }
775 }
776 }
777
778 int
Perl_get_extended_os_errno(void)779 Perl_get_extended_os_errno(void)
780 {
781
782 #if defined(VMS)
783
784 return (int) vaxc$errno;
785
786 #elif defined(OS2)
787
788 if (! (_emx_env & 0x200)) { /* Under DOS */
789 return (int) errno;
790 }
791
792 if (errno != errno_isOS2) {
793 const int tmp = _syserrno();
794 if (tmp) /* 2nd call to _syserrno() makes it 0 */
795 Perl_rc = tmp;
796 }
797 return (int) Perl_rc;
798
799 #elif defined(WIN32)
800
801 return (int) GetLastError();
802
803 #else
804
805 return (int) errno;
806
807 #endif
808
809 }
810
811 STATIC void
S_fixup_errno_string(pTHX_ SV * sv)812 S_fixup_errno_string(pTHX_ SV* sv)
813 {
814 /* Do what is necessary to fixup the non-empty string in 'sv' for return to
815 * Perl space. */
816
817 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
818
819 assert(SvOK(sv));
820
821 if(strEQ(SvPVX(sv), "")) {
822 sv_catpv(sv, UNKNOWN_ERRNO_MSG);
823 }
824 }
825
826 /*
827 =for apidoc_section $errno
828 =for apidoc sv_string_from_errnum
829
830 Generates the message string describing an OS error and returns it as
831 an SV. C<errnum> must be a value that C<errno> could take, identifying
832 the type of error.
833
834 If C<tgtsv> is non-null then the string will be written into that SV
835 (overwriting existing content) and it will be returned. If C<tgtsv>
836 is a null pointer then the string will be written into a new mortal SV
837 which will be returned.
838
839 The message will be taken from whatever locale would be used by C<$!>,
840 and will be encoded in the SV in whatever manner would be used by C<$!>.
841 The details of this process are subject to future change. Currently,
842 the message is taken from the C locale by default (usually producing an
843 English message), and from the currently selected locale when in the scope
844 of the C<use locale> pragma. A heuristic attempt is made to decode the
845 message from the locale's character encoding, but it will only be decoded
846 as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
847 locale, usually in an ISO-8859-1 locale, and never in any other locale.
848
849 The SV is always returned containing an actual string, and with no other
850 OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
851 (meaning success), and if no useful message is available then a useless
852 string (currently empty) is returned.
853
854 =cut
855 */
856
857 SV *
Perl_sv_string_from_errnum(pTHX_ int errnum,SV * tgtsv)858 Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
859 {
860 char const *errstr;
861 utf8ness_t utf8ness;
862
863 if(!tgtsv)
864 tgtsv = newSV_type_mortal(SVt_PV);
865 errstr = my_strerror(errnum, &utf8ness);
866 if(errstr) {
867 sv_setpv(tgtsv, errstr);
868 if (utf8ness == UTF8NESS_YES) {
869 SvUTF8_on(tgtsv);
870 }
871 fixup_errno_string(tgtsv);
872 } else {
873 SvPVCLEAR(tgtsv);
874 }
875 return tgtsv;
876 }
877
878 #ifdef VMS
879 #include <descrip.h>
880 #include <starlet.h>
881 #endif
882
883 int
Perl_magic_get(pTHX_ SV * sv,MAGIC * mg)884 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
885 {
886 I32 paren;
887 const char *s = NULL;
888 REGEXP *rx;
889 char nextchar;
890
891 PERL_ARGS_ASSERT_MAGIC_GET;
892
893 const char * const remaining = (mg->mg_ptr)
894 ? mg->mg_ptr + 1
895 : NULL;
896
897 if (!mg->mg_ptr) {
898 paren = mg->mg_len;
899 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
900 do_numbuf_fetch:
901 CALLREG_NUMBUF_FETCH(rx,paren,sv);
902 }
903 else
904 goto set_undef;
905 return 0;
906 }
907
908 nextchar = *remaining;
909 switch (*mg->mg_ptr) {
910 case '\001': /* ^A */
911 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
912 else
913 sv_set_undef(sv);
914 if (SvTAINTED(PL_bodytarget))
915 SvTAINTED_on(sv);
916 break;
917 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
918 if (nextchar == '\0') {
919 sv_setiv(sv, (IV)PL_minus_c);
920 }
921 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
922 sv_setiv(sv, (IV)STATUS_NATIVE);
923 }
924 break;
925
926 case '\004': /* ^D */
927 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
928 break;
929 case '\005': /* ^E */
930 {
931 if (nextchar != '\0') {
932 if (strEQ(remaining, "NCODING"))
933 sv_set_undef(sv);
934 break;
935 }
936
937 #if defined(VMS) || defined(OS2) || defined(WIN32)
938
939 int extended_errno = get_extended_os_errno();
940
941 # if defined(VMS)
942 char msg[255];
943 $DESCRIPTOR(msgdsc,msg);
944
945 sv_setnv(sv, (NV) extended_errno);
946 if (sys$getmsg(extended_errno,
947 &msgdsc.dsc$w_length,
948 &msgdsc,
949 0, 0)
950 & 1)
951 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
952 else
953 SvPVCLEAR(sv);
954
955 #elif defined(OS2)
956 if (!(_emx_env & 0x200)) { /* Under DOS */
957 sv_setnv(sv, (NV) extended_errno);
958 if (extended_errno) {
959 utf8ness_t utf8ness;
960 const char * errstr = my_strerror(extended_errno, &utf8ness);
961
962 sv_setpv(sv, errstr);
963
964 if (utf8ness == UTF8NESS_YES) {
965 SvUTF8_on(sv);
966 }
967 }
968 else {
969 SvPVCLEAR(sv);
970 }
971 } else {
972 sv_setnv(sv, (NV) extended_errno);
973 sv_setpv(sv, os2error(extended_errno));
974 }
975 if (SvOK(sv) && strNE(SvPVX(sv), "")) {
976 fixup_errno_string(sv);
977 }
978
979 # elif defined(WIN32)
980 const DWORD dwErr = (DWORD) extended_errno;
981 sv_setnv(sv, (NV) dwErr);
982 if (dwErr) {
983 PerlProc_GetOSError(sv, dwErr);
984 fixup_errno_string(sv);
985
986 # ifdef USE_LOCALE
987 if ( IN_LOCALE
988 && get_win32_message_utf8ness(SvPV_nomg_const_nolen(sv)))
989 {
990 SvUTF8_on(sv);
991 }
992 # endif
993 }
994 else
995 SvPVCLEAR(sv);
996 SetLastError(dwErr);
997 # else
998 # error Missing code for platform
999 # endif
1000 SvRTRIM(sv);
1001 SvNOK_on(sv); /* what a wonderful hack! */
1002 break;
1003 #endif /* End of platforms with special handling for $^E; others just fall
1004 through to $! */
1005 }
1006 /* FALLTHROUGH */
1007
1008 case '!':
1009 {
1010 dSAVE_ERRNO;
1011 #ifdef VMS
1012 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1013 #else
1014 sv_setnv(sv, (NV)errno);
1015 #endif
1016 #ifdef OS2
1017 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1018 sv_setpv(sv, os2error(Perl_rc));
1019 else
1020 #endif
1021 if (! errno) {
1022 SvPVCLEAR(sv);
1023 }
1024 else {
1025 sv_string_from_errnum(errno, sv);
1026 /* If no useful string is available, don't
1027 * claim to have a string part. The SvNOK_on()
1028 * below will cause just the number part to be valid */
1029 if (!SvCUR(sv))
1030 SvPOK_off(sv);
1031 }
1032 RESTORE_ERRNO;
1033 }
1034
1035 SvRTRIM(sv);
1036 SvNOK_on(sv); /* what a wonderful hack! */
1037 break;
1038
1039 case '\006': /* ^F */
1040 if (nextchar == '\0') {
1041 sv_setiv(sv, (IV)PL_maxsysfd);
1042 }
1043 break;
1044 case '\007': /* ^GLOBAL_PHASE */
1045 if (strEQ(remaining, "LOBAL_PHASE")) {
1046 sv_setpvn(sv, PL_phase_names[PL_phase],
1047 strlen(PL_phase_names[PL_phase]));
1048 }
1049 break;
1050 case '\010': /* ^H */
1051 sv_setuv(sv, PL_hints);
1052 break;
1053 case '\011': /* ^I */ /* NOT \t in EBCDIC */
1054 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
1055 break;
1056 case '\014': /* ^LAST_FH */
1057 if (strEQ(remaining, "AST_FH")) {
1058 if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) {
1059 assert(isGV_with_GP(PL_last_in_gv));
1060 sv_setrv_inc(sv, MUTABLE_SV(PL_last_in_gv));
1061 sv_rvweaken(sv);
1062 }
1063 else
1064 sv_set_undef(sv);
1065 }
1066 else if (strEQ(remaining, "AST_SUCCESSFUL_PATTERN")) {
1067 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1068 sv_setrv_inc(sv, MUTABLE_SV(rx));
1069 sv_rvweaken(sv);
1070 }
1071 else
1072 sv_set_undef(sv);
1073 }
1074 break;
1075 case '\017': /* ^O & ^OPEN */
1076 if (nextchar == '\0') {
1077 sv_setpv(sv, PL_osname);
1078 SvTAINTED_off(sv);
1079 }
1080 else if (strEQ(remaining, "PEN")) {
1081 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
1082 }
1083 break;
1084 case '\020':
1085 sv_setiv(sv, (IV)PL_perldb);
1086 break;
1087 case '\023': /* ^S */
1088 if (nextchar == '\0') {
1089 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
1090 SvOK_off(sv);
1091 else if (PL_in_eval)
1092 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
1093 else
1094 sv_setiv(sv, 0);
1095 }
1096 else if (strEQ(remaining, "AFE_LOCALES")) {
1097
1098 #if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
1099
1100 sv_setuv(sv, (UV) 1);
1101
1102 #else
1103 sv_setuv(sv, (UV) 0);
1104
1105 #endif
1106
1107 }
1108 break;
1109 case '\024': /* ^T */
1110 if (nextchar == '\0') {
1111 #ifdef BIG_TIME
1112 sv_setnv(sv, PL_basetime);
1113 #else
1114 sv_setiv(sv, (IV)PL_basetime);
1115 #endif
1116 }
1117 else if (strEQ(remaining, "AINT"))
1118 sv_setiv(sv, TAINTING_get
1119 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
1120 : 0);
1121 break;
1122 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
1123 if (strEQ(remaining, "NICODE"))
1124 sv_setuv(sv, (UV) PL_unicode);
1125 else if (strEQ(remaining, "TF8LOCALE"))
1126 sv_setuv(sv, (UV) PL_utf8locale);
1127 else if (strEQ(remaining, "TF8CACHE"))
1128 sv_setiv(sv, (IV) PL_utf8cache);
1129 break;
1130 case '\027': /* ^W & $^WARNING_BITS */
1131 if (nextchar == '\0')
1132 sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
1133 else if (strEQ(remaining, "ARNING_BITS")) {
1134 if (PL_compiling.cop_warnings == pWARN_NONE) {
1135 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
1136 }
1137 else if (PL_compiling.cop_warnings == pWARN_STD) {
1138 goto set_undef;
1139 }
1140 else if (PL_compiling.cop_warnings == pWARN_ALL) {
1141 sv_setpvn(sv, WARN_ALLstring, WARNsize);
1142 }
1143 else {
1144 sv_setpvn(sv, PL_compiling.cop_warnings,
1145 RCPV_LEN(PL_compiling.cop_warnings));
1146 }
1147 }
1148 break;
1149 case '+': /* $+ */
1150 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1151 paren = RX_LASTPAREN(rx);
1152 if (paren) {
1153 I32 *parno_to_logical = RX_PARNO_TO_LOGICAL(rx);
1154 if (parno_to_logical)
1155 paren = parno_to_logical[paren];
1156 goto do_numbuf_fetch;
1157 }
1158 }
1159 goto set_undef;
1160 case '\016': /* $^N */
1161 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1162 paren = RX_LASTCLOSEPAREN(rx);
1163 if (paren) {
1164 I32 *parno_to_logical = RX_PARNO_TO_LOGICAL(rx);
1165 if (parno_to_logical)
1166 paren = parno_to_logical[paren];
1167 goto do_numbuf_fetch;
1168 }
1169 }
1170 goto set_undef;
1171 case '.':
1172 if (GvIO(PL_last_in_gv)) {
1173 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1174 }
1175 break;
1176 case '?':
1177 {
1178 sv_setiv(sv, (IV)STATUS_CURRENT);
1179 #ifdef COMPLEX_STATUS
1180 SvUPGRADE(sv, SVt_PVLV);
1181 LvTARGOFF(sv) = PL_statusvalue;
1182 LvTARGLEN(sv) = PL_statusvalue_vms;
1183 #endif
1184 }
1185 break;
1186 case '^':
1187 if (GvIOp(PL_defoutgv))
1188 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1189 if (s)
1190 sv_setpv(sv,s);
1191 else {
1192 sv_setpv(sv,GvENAME(PL_defoutgv));
1193 sv_catpvs(sv,"_TOP");
1194 }
1195 break;
1196 case '~':
1197 if (GvIOp(PL_defoutgv))
1198 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1199 if (!s)
1200 s = GvENAME(PL_defoutgv);
1201 sv_setpv(sv,s);
1202 break;
1203 case '=':
1204 if (GvIO(PL_defoutgv))
1205 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1206 break;
1207 case '-':
1208 if (GvIO(PL_defoutgv))
1209 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1210 break;
1211 case '%':
1212 if (GvIO(PL_defoutgv))
1213 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1214 break;
1215 case ':':
1216 case '/':
1217 break;
1218 case '[':
1219 sv_setiv(sv, 0);
1220 break;
1221 case '|':
1222 if (GvIO(PL_defoutgv))
1223 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1224 break;
1225 case '\\':
1226 if (PL_ors_sv)
1227 sv_copypv(sv, PL_ors_sv);
1228 else
1229 goto set_undef;
1230 break;
1231 case '$': /* $$ */
1232 {
1233 IV const pid = (IV)PerlProc_getpid();
1234 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1235 /* never set manually, or at least not since last fork */
1236 sv_setiv(sv, pid);
1237 /* never unsafe, even if reading in a tainted expression */
1238 SvTAINTED_off(sv);
1239 }
1240 /* else a value has been assigned manually, so do nothing */
1241 }
1242 break;
1243 case '<':
1244 sv_setuid(sv, PerlProc_getuid());
1245 break;
1246 case '>':
1247 sv_setuid(sv, PerlProc_geteuid());
1248 break;
1249 case '(':
1250 sv_setgid(sv, PerlProc_getgid());
1251 goto add_groups;
1252 case ')':
1253 sv_setgid(sv, PerlProc_getegid());
1254 add_groups:
1255 #ifdef HAS_GETGROUPS
1256 {
1257 Groups_t *gary = NULL;
1258 I32 num_groups = getgroups(0, gary);
1259 if (num_groups > 0) {
1260 I32 i;
1261 Newx(gary, num_groups, Groups_t);
1262 num_groups = getgroups(num_groups, gary);
1263 for (i = 0; i < num_groups; i++)
1264 Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
1265 Safefree(gary);
1266 }
1267 }
1268
1269 /*
1270 Set this to avoid warnings when the SV is used as a number.
1271 Avoid setting the public IOK flag so that serializers will
1272 use the PV.
1273 */
1274 (void)SvIOKp_on(sv); /* what a wonderful hack! */
1275 #endif
1276 break;
1277 case '0':
1278 break;
1279 }
1280 return 0;
1281
1282 set_undef:
1283 sv_set_undef(sv);
1284 return 0;
1285 }
1286
1287 int
Perl_magic_getuvar(pTHX_ SV * sv,MAGIC * mg)1288 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1289 {
1290 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1291
1292 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1293
1294 if (uf && uf->uf_val)
1295 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1296 return 0;
1297 }
1298
1299 int
Perl_magic_setenv(pTHX_ SV * sv,MAGIC * mg)1300 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1301 {
1302 STRLEN len = 0, klen;
1303
1304 const char *key;
1305 const char *s = "";
1306
1307 SV *keysv = MgSV(mg);
1308
1309 if (keysv == NULL) {
1310 key = mg->mg_ptr;
1311 klen = mg->mg_len;
1312 }
1313 else {
1314 if (!sv_utf8_downgrade(keysv, /* fail_ok */ TRUE)) {
1315 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv key (encoding to utf8)");
1316 }
1317
1318 key = SvPV_const(keysv,klen);
1319 }
1320
1321 PERL_ARGS_ASSERT_MAGIC_SETENV;
1322
1323 SvGETMAGIC(sv);
1324 if (SvOK(sv)) {
1325 /* defined environment variables are byte strings; unfortunately
1326 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1327 (void)SvPV_force_nomg_nolen(sv);
1328 (void)sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1329 if (SvUTF8(sv)) {
1330 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1331 SvUTF8_off(sv);
1332 }
1333 s = SvPVX(sv);
1334 len = SvCUR(sv);
1335 }
1336 my_setenv(key, s); /* does the deed */
1337
1338 #ifdef DYNAMIC_ENV_FETCH
1339 /* We just undefd an environment var. Is a replacement */
1340 /* waiting in the wings? */
1341 if (!len) {
1342 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1343 if (valp)
1344 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1345 }
1346 #endif
1347
1348 #if !defined(OS2) && !defined(WIN32)
1349 /* And you'll never guess what the dog had */
1350 /* in its mouth... */
1351 if (TAINTING_get) {
1352 MgTAINTEDDIR_off(mg);
1353 #ifdef VMS
1354 if (s && memEQs(key, klen, "DCL$PATH")) {
1355 char pathbuf[256], eltbuf[256], *cp, *elt;
1356 int i = 0, j = 0;
1357
1358 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1359 elt = eltbuf;
1360 do { /* DCL$PATH may be a search list */
1361 while (1) { /* as may dev portion of any element */
1362 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1363 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1364 cando_by_name(S_IWUSR,0,elt) ) {
1365 MgTAINTEDDIR_on(mg);
1366 return 0;
1367 }
1368 }
1369 if ((cp = strchr(elt, ':')) != NULL)
1370 *cp = '\0';
1371 if (my_trnlnm(elt, eltbuf, j++))
1372 elt = eltbuf;
1373 else
1374 break;
1375 }
1376 j = 0;
1377 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1378 }
1379 #endif /* VMS */
1380 if (s && memEQs(key, klen, "PATH")) {
1381 const char * const strend = s + len;
1382 #ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */
1383 const char path_sep = PL_perllib_sep;
1384 #else
1385 const char path_sep = ':';
1386 #endif
1387
1388 #ifndef __VMS
1389 /* Does this apply for VMS?
1390 * Empty PATH on linux is treated same as ".", which is forbidden
1391 * under taint. So check if the PATH variable is empty. */
1392 if (!len) {
1393 MgTAINTEDDIR_on(mg);
1394 return 0;
1395 }
1396 #endif
1397 /* set MGf_TAINTEDDIR if any component of the new path is
1398 * relative or world-writeable */
1399 while (s < strend) {
1400 char tmpbuf[256];
1401 Stat_t st;
1402 I32 i;
1403 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
1404 s, strend, path_sep, &i);
1405 s++;
1406 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1407 #ifdef __VMS
1408 /* no colon thus no device name -- assume relative path */
1409 || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
1410 /* Using Unix separator, e.g. under bash, so act line Unix */
1411 || (PL_perllib_sep == ':' && *tmpbuf != '/')
1412 #else
1413 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1414 || s == strend /* trailing empty component -- same as "." */
1415 #endif
1416 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1417 MgTAINTEDDIR_on(mg);
1418 return 0;
1419 }
1420 }
1421 }
1422 }
1423 #endif /* neither OS2 nor WIN32 */
1424
1425 return 0;
1426 }
1427
1428 int
Perl_magic_clearenv(pTHX_ SV * sv,MAGIC * mg)1429 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1430 {
1431 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1432 PERL_UNUSED_ARG(sv);
1433 my_setenv(MgPV_nolen_const(mg),NULL);
1434 return 0;
1435 }
1436
1437 int
Perl_magic_set_all_env(pTHX_ SV * sv,MAGIC * mg)1438 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1439 {
1440 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1441 PERL_UNUSED_ARG(mg);
1442 #if defined(VMS)
1443 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1444 #else
1445 if (PL_localizing) {
1446 HE* entry;
1447 my_clearenv();
1448 hv_iterinit(MUTABLE_HV(sv));
1449 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1450 I32 keylen;
1451 my_setenv(hv_iterkey(entry, &keylen),
1452 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1453 }
1454 }
1455 #endif
1456 return 0;
1457 }
1458
1459 int
Perl_magic_clear_all_env(pTHX_ SV * sv,MAGIC * mg)1460 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1461 {
1462 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1463 PERL_UNUSED_ARG(sv);
1464 PERL_UNUSED_ARG(mg);
1465 #if defined(VMS)
1466 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1467 #else
1468 my_clearenv();
1469 #endif
1470 return 0;
1471 }
1472
1473 #ifdef HAS_SIGPROCMASK
1474 static void
restore_sigmask(pTHX_ SV * save_sv)1475 restore_sigmask(pTHX_ SV *save_sv)
1476 {
1477 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1478 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1479 }
1480 #endif
1481 int
Perl_magic_getsig(pTHX_ SV * sv,MAGIC * mg)1482 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1483 {
1484 /* Are we fetching a signal entry? */
1485 int i = (I16)mg->mg_private;
1486
1487 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1488
1489 if (!i) {
1490 STRLEN siglen;
1491 const char * sig = MgPV_const(mg, siglen);
1492 mg->mg_private = i = whichsig_pvn(sig, siglen);
1493 }
1494
1495 if (i > 0) {
1496 if(PL_psig_ptr[i])
1497 sv_setsv(sv,PL_psig_ptr[i]);
1498 else {
1499 Sighandler_t sigstate = rsignal_state(i);
1500 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1501 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1502 sigstate = SIG_IGN;
1503 #endif
1504 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1505 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1506 sigstate = SIG_DFL;
1507 #endif
1508 /* cache state so we don't fetch it again */
1509 if(sigstate == (Sighandler_t) SIG_IGN)
1510 sv_setpvs(sv,"IGNORE");
1511 else
1512 sv_set_undef(sv);
1513 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1514 SvTEMP_off(sv);
1515 }
1516 }
1517 return 0;
1518 }
1519 int
Perl_magic_clearsig(pTHX_ SV * sv,MAGIC * mg)1520 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1521 {
1522 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1523
1524 magic_setsig(NULL, mg);
1525 return sv_unmagic(sv, mg->mg_type);
1526 }
1527
1528
1529 PERL_STACK_REALIGN
1530 #ifdef PERL_USE_3ARG_SIGHANDLER
1531 Signal_t
Perl_csighandler(int sig,Siginfo_t * sip,void * uap)1532 Perl_csighandler(int sig, Siginfo_t *sip, void *uap)
1533 {
1534 Perl_csighandler3(sig, sip, uap);
1535 }
1536 #else
1537 Signal_t
1538 Perl_csighandler(int sig)
1539 {
1540 Perl_csighandler3(sig, NULL, NULL);
1541 }
1542 #endif
1543
1544 Signal_t
Perl_csighandler1(int sig)1545 Perl_csighandler1(int sig)
1546 {
1547 Perl_csighandler3(sig, NULL, NULL);
1548 }
1549
1550 /* Handler intended to directly handle signal calls from the kernel.
1551 * (Depending on configuration, the kernel may actually call one of the
1552 * wrappers csighandler() or csighandler1() instead.)
1553 * It either queues up the signal or dispatches it immediately depending
1554 * on whether safe signals are enabled and whether the signal is capable
1555 * of being deferred (e.g. SEGV isn't).
1556 */
1557
1558 Signal_t
Perl_csighandler3(int sig,Siginfo_t * sip PERL_UNUSED_DECL,void * uap PERL_UNUSED_DECL)1559 Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1560 {
1561 #ifdef PERL_GET_SIG_CONTEXT
1562 dTHXa(PERL_GET_SIG_CONTEXT);
1563 #else
1564 dTHX;
1565 #endif
1566
1567 #ifdef PERL_USE_3ARG_SIGHANDLER
1568 #if defined(__cplusplus) && defined(__GNUC__)
1569 /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
1570 * parameters would be warned about. */
1571 PERL_UNUSED_ARG(sip);
1572 PERL_UNUSED_ARG(uap);
1573 #endif
1574 #endif
1575
1576 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1577 (void) rsignal(sig, PL_csighandlerp);
1578 if (PL_sig_ignoring[sig]) return;
1579 #endif
1580 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1581 if (PL_sig_defaulting[sig])
1582 #ifdef KILL_BY_SIGPRC
1583 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1584 #else
1585 exit(1);
1586 #endif
1587 #endif
1588 if (
1589 #ifdef SIGILL
1590 sig == SIGILL ||
1591 #endif
1592 #ifdef SIGBUS
1593 sig == SIGBUS ||
1594 #endif
1595 #ifdef SIGSEGV
1596 sig == SIGSEGV ||
1597 #endif
1598 #ifdef SIGFPE
1599 sig == SIGFPE ||
1600 #endif
1601 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1602 /* Call the perl level handler now--
1603 * with risk we may be in malloc() or being destructed etc. */
1604 {
1605 if (PL_sighandlerp == Perl_sighandler)
1606 /* default handler, so can call perly_sighandler() directly
1607 * rather than via Perl_sighandler, passing the extra
1608 * 'safe = false' arg
1609 */
1610 Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */);
1611 else
1612 #ifdef PERL_USE_3ARG_SIGHANDLER
1613 (*PL_sighandlerp)(sig, NULL, NULL);
1614 #else
1615 (*PL_sighandlerp)(sig);
1616 #endif
1617 }
1618 else {
1619 if (!PL_psig_pend) return;
1620 /* Set a flag to say this signal is pending, that is awaiting delivery after
1621 * the current Perl opcode completes */
1622 PL_psig_pend[sig]++;
1623
1624 #ifndef SIG_PENDING_DIE_COUNT
1625 # define SIG_PENDING_DIE_COUNT 120
1626 #endif
1627 /* Add one to say _a_ signal is pending */
1628 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1629 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1630 (unsigned long)SIG_PENDING_DIE_COUNT);
1631 }
1632 }
1633
1634 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1635 void
Perl_csighandler_init(void)1636 Perl_csighandler_init(void)
1637 {
1638 int sig;
1639 if (PL_sig_handlers_initted) return;
1640
1641 for (sig = 1; sig < SIG_SIZE; sig++) {
1642 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1643 dTHX;
1644 PL_sig_defaulting[sig] = 1;
1645 (void) rsignal(sig, PL_csighandlerp);
1646 #endif
1647 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1648 PL_sig_ignoring[sig] = 0;
1649 #endif
1650 }
1651 PL_sig_handlers_initted = 1;
1652 }
1653 #endif
1654
1655 #if defined HAS_SIGPROCMASK
1656 static void
unblock_sigmask(pTHX_ void * newset)1657 unblock_sigmask(pTHX_ void* newset)
1658 {
1659 PERL_UNUSED_CONTEXT;
1660 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1661 }
1662 #endif
1663
1664 void
Perl_despatch_signals(pTHX)1665 Perl_despatch_signals(pTHX)
1666 {
1667 int sig;
1668 PL_sig_pending = 0;
1669 for (sig = 1; sig < SIG_SIZE; sig++) {
1670 if (PL_psig_pend[sig]) {
1671 dSAVE_ERRNO;
1672 #ifdef HAS_SIGPROCMASK
1673 /* From sigaction(2) (FreeBSD man page):
1674 * | Signal routines normally execute with the signal that
1675 * | caused their invocation blocked, but other signals may
1676 * | yet occur.
1677 * Emulation of this behavior (from within Perl) is enabled
1678 * using sigprocmask
1679 */
1680 int was_blocked;
1681 sigset_t newset, oldset;
1682
1683 sigemptyset(&newset);
1684 sigaddset(&newset, sig);
1685 sigprocmask(SIG_BLOCK, &newset, &oldset);
1686 was_blocked = sigismember(&oldset, sig);
1687 if (!was_blocked) {
1688 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1689 ENTER;
1690 SAVEFREESV(save_sv);
1691 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1692 }
1693 #endif
1694 PL_psig_pend[sig] = 0;
1695 if (PL_sighandlerp == Perl_sighandler)
1696 /* default handler, so can call perly_sighandler() directly
1697 * rather than via Perl_sighandler, passing the extra
1698 * 'safe = true' arg
1699 */
1700 Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */);
1701 else
1702 #ifdef PERL_USE_3ARG_SIGHANDLER
1703 (*PL_sighandlerp)(sig, NULL, NULL);
1704 #else
1705 (*PL_sighandlerp)(sig);
1706 #endif
1707
1708 #ifdef HAS_SIGPROCMASK
1709 if (!was_blocked)
1710 LEAVE;
1711 #endif
1712 RESTORE_ERRNO;
1713 }
1714 }
1715 }
1716
1717 /* sv of NULL signifies that we're acting as magic_clearsig. */
1718 int
Perl_magic_setsig(pTHX_ SV * sv,MAGIC * mg)1719 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1720 {
1721 I32 i;
1722 SV** svp = NULL;
1723 /* Need to be careful with SvREFCNT_dec(), because that can have side
1724 * effects (due to closures). We must make sure that the new disposition
1725 * is in place before it is called.
1726 */
1727 SV* to_dec = NULL;
1728 STRLEN len;
1729 #ifdef HAS_SIGPROCMASK
1730 sigset_t set, save;
1731 SV* save_sv;
1732 #endif
1733 const char *s = MgPV_const(mg,len);
1734
1735 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1736
1737 if (*s == '_') {
1738 if (memEQs(s, len, "__DIE__"))
1739 svp = &PL_diehook;
1740 else if (memEQs(s, len, "__WARN__")
1741 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1742 /* Merge the existing behaviours, which are as follows:
1743 magic_setsig, we always set svp to &PL_warnhook
1744 (hence we always change the warnings handler)
1745 For magic_clearsig, we don't change the warnings handler if it's
1746 set to the &PL_warnhook. */
1747 svp = &PL_warnhook;
1748 }
1749 else if (sv) {
1750 SV *tmp = sv_newmortal();
1751 Perl_croak(aTHX_ "No such hook: %s",
1752 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1753 }
1754 i = 0;
1755 if (svp && *svp) {
1756 if (*svp != PERL_WARNHOOK_FATAL)
1757 to_dec = *svp;
1758 *svp = NULL;
1759 }
1760 }
1761 else {
1762 i = (I16)mg->mg_private;
1763 if (!i) {
1764 i = whichsig_pvn(s, len); /* ...no, a brick */
1765 mg->mg_private = (U16)i;
1766 }
1767 if (i <= 0) {
1768 if (sv) {
1769 SV *tmp = sv_newmortal();
1770 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1771 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1772 }
1773 return 0;
1774 }
1775 #ifdef HAS_SIGPROCMASK
1776 /* Avoid having the signal arrive at a bad time, if possible. */
1777 sigemptyset(&set);
1778 sigaddset(&set,i);
1779 sigprocmask(SIG_BLOCK, &set, &save);
1780 ENTER;
1781 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1782 SAVEFREESV(save_sv);
1783 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1784 #endif
1785 PERL_ASYNC_CHECK();
1786 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1787 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1788 #endif
1789 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1790 PL_sig_ignoring[i] = 0;
1791 #endif
1792 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1793 PL_sig_defaulting[i] = 0;
1794 #endif
1795 to_dec = PL_psig_ptr[i];
1796 if (sv) {
1797 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1798 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1799
1800 /* Signals don't change name during the program's execution, so once
1801 they're cached in the appropriate slot of PL_psig_name, they can
1802 stay there.
1803
1804 Ideally we'd find some way of making SVs at (C) compile time, or
1805 at least, doing most of the work. */
1806 if (!PL_psig_name[i]) {
1807 const char* name = PL_sig_name[i];
1808 PL_psig_name[i] = newSVpvn(name, strlen(name));
1809 SvREADONLY_on(PL_psig_name[i]);
1810 }
1811 } else {
1812 SvREFCNT_dec(PL_psig_name[i]);
1813 PL_psig_name[i] = NULL;
1814 PL_psig_ptr[i] = NULL;
1815 }
1816 }
1817 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1818 if (i) {
1819 (void)rsignal(i, PL_csighandlerp);
1820 }
1821 else {
1822 *svp = SvREFCNT_inc_simple_NN(sv);
1823 }
1824 } else {
1825 if (sv && SvOK(sv)) {
1826 s = SvPV_force(sv, len);
1827 } else {
1828 sv = NULL;
1829 }
1830 if (sv && memEQs(s, len,"IGNORE")) {
1831 if (i) {
1832 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1833 PL_sig_ignoring[i] = 1;
1834 (void)rsignal(i, PL_csighandlerp);
1835 #else
1836 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1837 #endif
1838 }
1839 }
1840 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1841 if (i) {
1842 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1843 PL_sig_defaulting[i] = 1;
1844 (void)rsignal(i, PL_csighandlerp);
1845 #else
1846 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1847 #endif
1848 }
1849 }
1850 else {
1851 /*
1852 * We should warn if HINT_STRICT_REFS, but without
1853 * access to a known hint bit in a known OP, we can't
1854 * tell whether HINT_STRICT_REFS is in force or not.
1855 */
1856 if (!memchr(s, ':', len) && !memchr(s, '\'', len))
1857 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1858 SV_GMAGIC);
1859 if (i)
1860 (void)rsignal(i, PL_csighandlerp);
1861 else
1862 *svp = SvREFCNT_inc_simple_NN(sv);
1863 }
1864 }
1865
1866 #ifdef HAS_SIGPROCMASK
1867 if(i)
1868 LEAVE;
1869 #endif
1870 SvREFCNT_dec(to_dec);
1871 return 0;
1872 }
1873
1874 int
Perl_magic_setsigall(pTHX_ SV * sv,MAGIC * mg)1875 Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg)
1876 {
1877 PERL_ARGS_ASSERT_MAGIC_SETSIGALL;
1878 PERL_UNUSED_ARG(mg);
1879
1880 if (PL_localizing == 2) {
1881 HV* hv = (HV*)sv;
1882 HE* current;
1883 hv_iterinit(hv);
1884 while ((current = hv_iternext(hv))) {
1885 SV* sigelem = hv_iterval(hv, current);
1886 mg_set(sigelem);
1887 }
1888 }
1889 return 0;
1890 }
1891
1892 int
Perl_magic_clearhook(pTHX_ SV * sv,MAGIC * mg)1893 Perl_magic_clearhook(pTHX_ SV *sv, MAGIC *mg)
1894 {
1895 PERL_ARGS_ASSERT_MAGIC_CLEARHOOK;
1896
1897 magic_sethook(NULL, mg);
1898 return sv_unmagic(sv, mg->mg_type);
1899 }
1900
1901 /* sv of NULL signifies that we're acting as magic_clearhook. */
1902 int
Perl_magic_sethook(pTHX_ SV * sv,MAGIC * mg)1903 Perl_magic_sethook(pTHX_ SV *sv, MAGIC *mg)
1904 {
1905 SV** svp = NULL;
1906 STRLEN len;
1907 const char *s = MgPV_const(mg,len);
1908
1909 PERL_ARGS_ASSERT_MAGIC_SETHOOK;
1910
1911 if (memEQs(s, len, "require__before")) {
1912 svp = &PL_hook__require__before;
1913 }
1914 else if (memEQs(s, len, "require__after")) {
1915 svp = &PL_hook__require__after;
1916 }
1917 else {
1918 SV *tmp = sv_newmortal();
1919 Perl_croak(aTHX_ "Attempt to set unknown hook '%s' in %%{^HOOK}",
1920 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1921 }
1922 if (sv && SvOK(sv) && (!SvROK(sv) || SvTYPE(SvRV(sv))!= SVt_PVCV))
1923 croak("${^HOOK}{%.*s} may only be a CODE reference or undef", (int)len, s);
1924
1925 if (svp) {
1926 if (*svp)
1927 SvREFCNT_dec(*svp);
1928
1929 if (sv)
1930 *svp = SvREFCNT_inc_simple_NN(sv);
1931 else
1932 *svp = NULL;
1933 }
1934
1935 return 0;
1936 }
1937
1938 int
Perl_magic_sethookall(pTHX_ SV * sv,MAGIC * mg)1939 Perl_magic_sethookall(pTHX_ SV* sv, MAGIC* mg)
1940 {
1941 PERL_ARGS_ASSERT_MAGIC_SETHOOKALL;
1942 PERL_UNUSED_ARG(mg);
1943
1944 if (PL_localizing == 1) {
1945 SAVEGENERICSV(PL_hook__require__before);
1946 PL_hook__require__before = NULL;
1947 SAVEGENERICSV(PL_hook__require__after);
1948 PL_hook__require__after = NULL;
1949 }
1950 else
1951 if (PL_localizing == 2) {
1952 HV* hv = (HV*)sv;
1953 HE* current;
1954 hv_iterinit(hv);
1955 while ((current = hv_iternext(hv))) {
1956 SV* hookelem = hv_iterval(hv, current);
1957 mg_set(hookelem);
1958 }
1959 }
1960 return 0;
1961 }
1962
1963 int
Perl_magic_clearhookall(pTHX_ SV * sv,MAGIC * mg)1964 Perl_magic_clearhookall(pTHX_ SV* sv, MAGIC* mg)
1965 {
1966 PERL_ARGS_ASSERT_MAGIC_CLEARHOOKALL;
1967 PERL_UNUSED_ARG(mg);
1968 PERL_UNUSED_ARG(sv);
1969
1970 SvREFCNT_dec_set_NULL(PL_hook__require__before);
1971
1972 SvREFCNT_dec_set_NULL(PL_hook__require__after);
1973
1974 return 0;
1975 }
1976
1977
1978 int
Perl_magic_setisa(pTHX_ SV * sv,MAGIC * mg)1979 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1980 {
1981 PERL_ARGS_ASSERT_MAGIC_SETISA;
1982 PERL_UNUSED_ARG(sv);
1983
1984 /* Skip _isaelem because _isa will handle it shortly */
1985 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1986 return 0;
1987
1988 return magic_clearisa(NULL, mg);
1989 }
1990
1991 /* sv of NULL signifies that we're acting as magic_setisa. */
1992 int
Perl_magic_clearisa(pTHX_ SV * sv,MAGIC * mg)1993 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1994 {
1995 HV* stash;
1996 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1997
1998 /* Bail out if destruction is going on */
1999 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
2000
2001 if (sv)
2002 av_clear(MUTABLE_AV(sv));
2003
2004 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
2005 /* This occurs with setisa_elem magic, which calls this
2006 same function. */
2007 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
2008
2009 assert(mg);
2010 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
2011 SV **svp = AvARRAY((AV *)mg->mg_obj);
2012 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
2013 while (items--) {
2014 stash = GvSTASH((GV *)*svp++);
2015 if (stash && HvHasENAME(stash)) mro_isa_changed_in(stash);
2016 }
2017
2018 return 0;
2019 }
2020
2021 stash = GvSTASH(
2022 (const GV *)mg->mg_obj
2023 );
2024
2025 /* The stash may have been detached from the symbol table, so check its
2026 name before doing anything. */
2027 if (stash && HvHasENAME(stash))
2028 mro_isa_changed_in(stash);
2029
2030 return 0;
2031 }
2032
2033 int
Perl_magic_getnkeys(pTHX_ SV * sv,MAGIC * mg)2034 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
2035 {
2036 HV * const hv = MUTABLE_HV(LvTARG(sv));
2037 I32 i = 0;
2038
2039 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
2040 PERL_UNUSED_ARG(mg);
2041
2042 if (hv) {
2043 (void) hv_iterinit(hv);
2044 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
2045 i = HvUSEDKEYS(hv);
2046 else {
2047 while (hv_iternext(hv))
2048 i++;
2049 }
2050 }
2051
2052 sv_setiv(sv, (IV)i);
2053 return 0;
2054 }
2055
2056 int
Perl_magic_setnkeys(pTHX_ SV * sv,MAGIC * mg)2057 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
2058 {
2059 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
2060 PERL_UNUSED_ARG(mg);
2061 if (LvTARG(sv)) {
2062 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
2063 }
2064 return 0;
2065 }
2066
2067 /*
2068 =for apidoc_section $magic
2069 =for apidoc magic_methcall
2070
2071 Invoke a magic method (like FETCH).
2072
2073 C<sv> and C<mg> are the tied thingy and the tie magic.
2074
2075 C<meth> is the name of the method to call.
2076
2077 C<argc> is the number of args (in addition to $self) to pass to the method.
2078
2079 The C<flags> can be:
2080
2081 G_DISCARD invoke method with G_DISCARD flag and don't
2082 return a value
2083 G_UNDEF_FILL fill the stack with argc pointers to
2084 PL_sv_undef
2085
2086 The arguments themselves are any values following the C<flags> argument.
2087
2088 Returns the SV (if any) returned by the method, or C<NULL> on failure.
2089
2090
2091 =cut
2092 */
2093
2094 SV*
Perl_magic_methcall(pTHX_ SV * sv,const MAGIC * mg,SV * meth,U32 flags,U32 argc,...)2095 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
2096 U32 argc, ...)
2097 {
2098 dSP;
2099 SV* ret = NULL;
2100
2101 PERL_ARGS_ASSERT_MAGIC_METHCALL;
2102
2103 ENTER;
2104
2105 if (flags & G_WRITING_TO_STDERR) {
2106 SAVETMPS;
2107
2108 save_re_context();
2109 SAVESPTR(PL_stderrgv);
2110 PL_stderrgv = NULL;
2111 }
2112
2113 PUSHSTACKi(PERLSI_MAGIC);
2114 PUSHMARK(SP);
2115
2116 /* EXTEND() expects a signed argc; don't wrap when casting */
2117 assert(argc <= I32_MAX);
2118 EXTEND(SP, (I32)argc+1);
2119 PUSHs(SvTIED_obj(sv, mg));
2120 if (flags & G_UNDEF_FILL) {
2121 while (argc--) {
2122 PUSHs(&PL_sv_undef);
2123 }
2124 } else if (argc > 0) {
2125 va_list args;
2126 va_start(args, argc);
2127
2128 do {
2129 SV *const this_sv = va_arg(args, SV *);
2130 PUSHs(this_sv);
2131 } while (--argc);
2132
2133 va_end(args);
2134 }
2135 PUTBACK;
2136 if (flags & G_DISCARD) {
2137 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
2138 }
2139 else {
2140 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
2141 ret = *PL_stack_sp--;
2142 }
2143 POPSTACK;
2144 if (flags & G_WRITING_TO_STDERR)
2145 FREETMPS;
2146 LEAVE;
2147 return ret;
2148 }
2149
2150 /* wrapper for magic_methcall that creates the first arg */
2151
2152 STATIC SV*
S_magic_methcall1(pTHX_ SV * sv,const MAGIC * mg,SV * meth,U32 flags,int n,SV * val)2153 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
2154 int n, SV *val)
2155 {
2156 SV* arg1 = NULL;
2157
2158 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
2159
2160 if (mg->mg_ptr) {
2161 if (mg->mg_len >= 0) {
2162 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
2163 }
2164 else if (mg->mg_len == HEf_SVKEY)
2165 arg1 = MUTABLE_SV(mg->mg_ptr);
2166 }
2167 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
2168 arg1 = newSViv((IV)(mg->mg_len));
2169 sv_2mortal(arg1);
2170 }
2171 if (!arg1) {
2172 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
2173 }
2174 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
2175 }
2176
2177 STATIC int
S_magic_methpack(pTHX_ SV * sv,const MAGIC * mg,SV * meth)2178 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
2179 {
2180 SV* ret;
2181
2182 PERL_ARGS_ASSERT_MAGIC_METHPACK;
2183
2184 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
2185 if (ret)
2186 sv_setsv(sv, ret);
2187 return 0;
2188 }
2189
2190 int
Perl_magic_getpack(pTHX_ SV * sv,MAGIC * mg)2191 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
2192 {
2193 PERL_ARGS_ASSERT_MAGIC_GETPACK;
2194
2195 if (mg->mg_type == PERL_MAGIC_tiedelem)
2196 mg->mg_flags |= MGf_GSKIP;
2197 magic_methpack(sv,mg,SV_CONST(FETCH));
2198 return 0;
2199 }
2200
2201 int
Perl_magic_setpack(pTHX_ SV * sv,MAGIC * mg)2202 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
2203 {
2204 MAGIC *tmg;
2205 SV *val;
2206
2207 PERL_ARGS_ASSERT_MAGIC_SETPACK;
2208
2209 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
2210 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
2211 * public flags indicate its value based on copying from $val. Doing
2212 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
2213 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
2214 * wrong if $val happened to be tainted, as sv hasn't got magic
2215 * enabled, even though taint magic is in the chain. In which case,
2216 * fake up a temporary tainted value (this is easier than temporarily
2217 * re-enabling magic on sv). */
2218
2219 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
2220 && (tmg->mg_len & 1))
2221 {
2222 val = sv_mortalcopy(sv);
2223 SvTAINTED_on(val);
2224 }
2225 else
2226 val = sv;
2227
2228 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
2229 return 0;
2230 }
2231
2232 int
Perl_magic_clearpack(pTHX_ SV * sv,MAGIC * mg)2233 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
2234 {
2235 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2236
2237 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
2238 return magic_methpack(sv,mg,SV_CONST(DELETE));
2239 }
2240
2241
2242 U32
Perl_magic_sizepack(pTHX_ SV * sv,MAGIC * mg)2243 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
2244 {
2245 I32 retval = 0;
2246 SV* retsv;
2247
2248 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2249
2250 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
2251 if (retsv) {
2252 retval = SvIV(retsv)-1;
2253 if (retval < -1)
2254 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
2255 }
2256 return (U32) retval;
2257 }
2258
2259 int
Perl_magic_wipepack(pTHX_ SV * sv,MAGIC * mg)2260 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
2261 {
2262 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2263
2264 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
2265 return 0;
2266 }
2267
2268 int
Perl_magic_nextpack(pTHX_ SV * sv,MAGIC * mg,SV * key)2269 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
2270 {
2271 SV* ret;
2272
2273 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2274
2275 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
2276 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
2277 if (ret)
2278 sv_setsv(key,ret);
2279 return 0;
2280 }
2281
2282 int
Perl_magic_existspack(pTHX_ SV * sv,const MAGIC * mg)2283 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
2284 {
2285 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2286
2287 return magic_methpack(sv,mg,SV_CONST(EXISTS));
2288 }
2289
2290 SV *
Perl_magic_scalarpack(pTHX_ HV * hv,MAGIC * mg)2291 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2292 {
2293 SV *retval;
2294 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2295 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2296
2297 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2298
2299 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2300 SV *key;
2301 if (HvEITER_get(hv))
2302 /* we are in an iteration so the hash cannot be empty */
2303 return &PL_sv_yes;
2304 /* no xhv_eiter so now use FIRSTKEY */
2305 key = sv_newmortal();
2306 magic_nextpack(MUTABLE_SV(hv), mg, key);
2307 HvEITER_set(hv, NULL); /* need to reset iterator */
2308 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2309 }
2310
2311 /* there is a SCALAR method that we can call */
2312 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
2313 if (!retval)
2314 retval = &PL_sv_undef;
2315 return retval;
2316 }
2317
2318 int
Perl_magic_setdbline(pTHX_ SV * sv,MAGIC * mg)2319 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2320 {
2321 SV **svp;
2322
2323 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2324
2325 /* The magic ptr/len for the debugger's hash should always be an SV. */
2326 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2327 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
2328 (IV)mg->mg_len, mg->mg_ptr);
2329 }
2330
2331 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2332 setting/clearing debugger breakpoints is not a hot path. */
2333 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2334 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2335
2336 if (svp && SvIOKp(*svp)) {
2337 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2338 if (o) {
2339 #ifdef PERL_DEBUG_READONLY_OPS
2340 Slab_to_rw(OpSLAB(o));
2341 #endif
2342 /* set or clear breakpoint in the relevant control op */
2343 if (SvTRUE(sv))
2344 o->op_flags |= OPf_SPECIAL;
2345 else
2346 o->op_flags &= ~OPf_SPECIAL;
2347 #ifdef PERL_DEBUG_READONLY_OPS
2348 Slab_to_ro(OpSLAB(o));
2349 #endif
2350 }
2351 }
2352 return 0;
2353 }
2354
2355 int
Perl_magic_getarylen(pTHX_ SV * sv,const MAGIC * mg)2356 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2357 {
2358 AV * const obj = MUTABLE_AV(mg->mg_obj);
2359
2360 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2361
2362 if (obj) {
2363 sv_setiv(sv, AvFILL(obj));
2364 } else {
2365 sv_set_undef(sv);
2366 }
2367 return 0;
2368 }
2369
2370 int
Perl_magic_setarylen(pTHX_ SV * sv,MAGIC * mg)2371 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2372 {
2373 AV * const obj = MUTABLE_AV(mg->mg_obj);
2374
2375 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2376
2377 if (obj) {
2378 av_fill(obj, SvIV(sv));
2379 } else {
2380 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2381 "Attempt to set length of freed array");
2382 }
2383 return 0;
2384 }
2385
2386 int
Perl_magic_cleararylen_p(pTHX_ SV * sv,MAGIC * mg)2387 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2388 {
2389 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2390 PERL_UNUSED_ARG(sv);
2391 PERL_UNUSED_CONTEXT;
2392
2393 /* Reset the iterator when the array is cleared */
2394 if (sizeof(IV) == sizeof(SSize_t)) {
2395 *((IV *) &(mg->mg_len)) = 0;
2396 } else {
2397 if (mg->mg_ptr)
2398 *((IV *) mg->mg_ptr) = 0;
2399 }
2400
2401 return 0;
2402 }
2403
2404 int
Perl_magic_freearylen_p(pTHX_ SV * sv,MAGIC * mg)2405 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2406 {
2407 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2408 PERL_UNUSED_ARG(sv);
2409
2410 /* during global destruction, mg_obj may already have been freed */
2411 if (PL_in_clean_all)
2412 return 0;
2413
2414 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2415
2416 if (mg) {
2417 /* arylen scalar holds a pointer back to the array, but doesn't own a
2418 reference. Hence the we (the array) are about to go away with it
2419 still pointing at us. Clear its pointer, else it would be pointing
2420 at free memory. See the comment in sv_magic about reference loops,
2421 and why it can't own a reference to us. */
2422 mg->mg_obj = 0;
2423 }
2424 return 0;
2425 }
2426
2427 int
Perl_magic_getpos(pTHX_ SV * sv,MAGIC * mg)2428 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2429 {
2430 SV* const lsv = LvTARG(sv);
2431 MAGIC * const found = mg_find_mglob(lsv);
2432
2433 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2434 PERL_UNUSED_ARG(mg);
2435
2436 if (found && found->mg_len != -1) {
2437 STRLEN i = found->mg_len;
2438 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2439 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2440 sv_setuv(sv, i);
2441 return 0;
2442 }
2443 sv_set_undef(sv);
2444 return 0;
2445 }
2446
2447 int
Perl_magic_setpos(pTHX_ SV * sv,MAGIC * mg)2448 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2449 {
2450 SV* const lsv = LvTARG(sv);
2451 SSize_t pos;
2452 STRLEN len;
2453 MAGIC* found;
2454 const char *s;
2455
2456 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2457 PERL_UNUSED_ARG(mg);
2458
2459 found = mg_find_mglob(lsv);
2460 if (!found) {
2461 if (!SvOK(sv))
2462 return 0;
2463 found = sv_magicext_mglob(lsv);
2464 }
2465 else if (!SvOK(sv)) {
2466 found->mg_len = -1;
2467 return 0;
2468 }
2469 s = SvPV_const(lsv, len);
2470
2471 pos = SvIV(sv);
2472
2473 if (DO_UTF8(lsv)) {
2474 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2475 if (ulen)
2476 len = ulen;
2477 }
2478
2479 if (pos < 0) {
2480 pos += len;
2481 if (pos < 0)
2482 pos = 0;
2483 }
2484 else if (pos > (SSize_t)len)
2485 pos = len;
2486
2487 found->mg_len = pos;
2488 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2489
2490 return 0;
2491 }
2492
2493 int
Perl_magic_getsubstr(pTHX_ SV * sv,MAGIC * mg)2494 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2495 {
2496 STRLEN len;
2497 SV * const lsv = LvTARG(sv);
2498 const char * const tmps = SvPV_const(lsv,len);
2499 STRLEN offs = LvTARGOFF(sv);
2500 STRLEN rem = LvTARGLEN(sv);
2501 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2502 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
2503
2504 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2505 PERL_UNUSED_ARG(mg);
2506
2507 if (!translate_substr_offsets(
2508 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2509 negoff ? -(IV)offs : (IV)offs, !negoff,
2510 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2511 )) {
2512 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2513 sv_set_undef(sv);
2514 return 0;
2515 }
2516
2517 if (SvUTF8(lsv))
2518 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2519 sv_setpvn(sv, tmps + offs, rem);
2520 if (SvUTF8(lsv))
2521 SvUTF8_on(sv);
2522 return 0;
2523 }
2524
2525 int
Perl_magic_setsubstr(pTHX_ SV * sv,MAGIC * mg)2526 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2527 {
2528 STRLEN len, lsv_len, oldtarglen, newtarglen;
2529 const char * const tmps = SvPV_const(sv, len);
2530 SV * const lsv = LvTARG(sv);
2531 STRLEN lvoff = LvTARGOFF(sv);
2532 STRLEN lvlen = LvTARGLEN(sv);
2533 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2534 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
2535
2536 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2537 PERL_UNUSED_ARG(mg);
2538
2539 SvGETMAGIC(lsv);
2540 if (SvROK(lsv))
2541 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2542 "Attempt to use reference as lvalue in substr"
2543 );
2544 SvPV_force_nomg(lsv,lsv_len);
2545 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2546 if (!translate_substr_offsets(
2547 lsv_len,
2548 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2549 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2550 ))
2551 Perl_croak(aTHX_ "substr outside of string");
2552 oldtarglen = lvlen;
2553 if (DO_UTF8(sv)) {
2554 sv_utf8_upgrade_nomg(lsv);
2555 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2556 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2557 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2558 SvUTF8_on(lsv);
2559 }
2560 else if (SvUTF8(lsv)) {
2561 const char *utf8;
2562 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2563 newtarglen = len;
2564 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2565 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2566 Safefree(utf8);
2567 }
2568 else {
2569 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2570 newtarglen = len;
2571 }
2572 if (!neglen) LvTARGLEN(sv) = newtarglen;
2573 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2574
2575 return 0;
2576 }
2577
2578 int
Perl_magic_gettaint(pTHX_ SV * sv,MAGIC * mg)2579 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2580 {
2581 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2582 PERL_UNUSED_ARG(sv);
2583 #ifdef NO_TAINT_SUPPORT
2584 PERL_UNUSED_ARG(mg);
2585 #endif
2586
2587 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2588 return 0;
2589 }
2590
2591 int
Perl_magic_settaint(pTHX_ SV * sv,MAGIC * mg)2592 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2593 {
2594 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2595 PERL_UNUSED_ARG(sv);
2596
2597 /* update taint status */
2598 if (TAINT_get)
2599 mg->mg_len |= 1;
2600 else
2601 mg->mg_len &= ~1;
2602 return 0;
2603 }
2604
2605 int
Perl_magic_getvec(pTHX_ SV * sv,MAGIC * mg)2606 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2607 {
2608 SV * const lsv = LvTARG(sv);
2609 char errflags = LvFLAGS(sv);
2610
2611 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2612 PERL_UNUSED_ARG(mg);
2613
2614 /* non-zero errflags implies deferred out-of-range condition */
2615 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
2616 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2617
2618 return 0;
2619 }
2620
2621 int
Perl_magic_setvec(pTHX_ SV * sv,MAGIC * mg)2622 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2623 {
2624 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2625 PERL_UNUSED_ARG(mg);
2626 do_vecset(sv); /* XXX slurp this routine */
2627 return 0;
2628 }
2629
2630 SV *
Perl_defelem_target(pTHX_ SV * sv,MAGIC * mg)2631 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2632 {
2633 SV *targ = NULL;
2634 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2635 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2636 assert(mg);
2637 if (LvTARGLEN(sv)) {
2638 if (mg->mg_obj) {
2639 SV * const ahv = LvTARG(sv);
2640 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2641 if (he)
2642 targ = HeVAL(he);
2643 }
2644 else if (LvSTARGOFF(sv) >= 0) {
2645 AV *const av = MUTABLE_AV(LvTARG(sv));
2646 if (LvSTARGOFF(sv) <= AvFILL(av))
2647 {
2648 if (SvRMAGICAL(av)) {
2649 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2650 targ = svp ? *svp : NULL;
2651 }
2652 else
2653 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2654 }
2655 }
2656 if (targ && (targ != &PL_sv_undef)) {
2657 /* somebody else defined it for us */
2658 SvREFCNT_dec(LvTARG(sv));
2659 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2660 LvTARGLEN(sv) = 0;
2661 SvREFCNT_dec(mg->mg_obj);
2662 mg->mg_obj = NULL;
2663 mg->mg_flags &= ~MGf_REFCOUNTED;
2664 }
2665 return targ;
2666 }
2667 else
2668 return LvTARG(sv);
2669 }
2670
2671 int
Perl_magic_getdefelem(pTHX_ SV * sv,MAGIC * mg)2672 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2673 {
2674 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2675
2676 sv_setsv(sv, defelem_target(sv, mg));
2677 return 0;
2678 }
2679
2680 int
Perl_magic_setdefelem(pTHX_ SV * sv,MAGIC * mg)2681 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2682 {
2683 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2684 PERL_UNUSED_ARG(mg);
2685 if (LvTARGLEN(sv))
2686 vivify_defelem(sv);
2687 if (LvTARG(sv)) {
2688 sv_setsv(LvTARG(sv), sv);
2689 SvSETMAGIC(LvTARG(sv));
2690 }
2691 return 0;
2692 }
2693
2694 void
Perl_vivify_defelem(pTHX_ SV * sv)2695 Perl_vivify_defelem(pTHX_ SV *sv)
2696 {
2697 MAGIC *mg;
2698 SV *value = NULL;
2699
2700 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2701
2702 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2703 return;
2704 if (mg->mg_obj) {
2705 SV * const ahv = LvTARG(sv);
2706 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2707 if (he)
2708 value = HeVAL(he);
2709 if (!value || value == &PL_sv_undef)
2710 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2711 }
2712 else if (LvSTARGOFF(sv) < 0)
2713 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2714 else {
2715 AV *const av = MUTABLE_AV(LvTARG(sv));
2716 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2717 LvTARG(sv) = NULL; /* array can't be extended */
2718 else {
2719 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2720 if (!svp || !(value = *svp))
2721 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2722 }
2723 }
2724 SvREFCNT_inc_simple_void(value);
2725 SvREFCNT_dec(LvTARG(sv));
2726 LvTARG(sv) = value;
2727 LvTARGLEN(sv) = 0;
2728 SvREFCNT_dec(mg->mg_obj);
2729 mg->mg_obj = NULL;
2730 mg->mg_flags &= ~MGf_REFCOUNTED;
2731 }
2732
2733 int
Perl_magic_setnonelem(pTHX_ SV * sv,MAGIC * mg)2734 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
2735 {
2736 PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
2737 PERL_UNUSED_ARG(mg);
2738 sv_unmagic(sv, PERL_MAGIC_nonelem);
2739 return 0;
2740 }
2741
2742 int
Perl_magic_killbackrefs(pTHX_ SV * sv,MAGIC * mg)2743 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2744 {
2745 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2746 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2747 return 0;
2748 }
2749
2750 int
Perl_magic_setmglob(pTHX_ SV * sv,MAGIC * mg)2751 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2752 {
2753 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2754 PERL_UNUSED_CONTEXT;
2755 PERL_UNUSED_ARG(sv);
2756 mg->mg_len = -1;
2757 return 0;
2758 }
2759
2760
2761 int
Perl_magic_freemglob(pTHX_ SV * sv,MAGIC * mg)2762 Perl_magic_freemglob(pTHX_ SV *sv, MAGIC *mg)
2763 {
2764 PERL_ARGS_ASSERT_MAGIC_FREEMGLOB;
2765 PERL_UNUSED_ARG(sv);
2766
2767 /* pos() magic uses mg_len as a string position rather than a buffer
2768 * length, and mg_ptr is currently unused, so skip freeing.
2769 */
2770 assert(mg->mg_type == PERL_MAGIC_regex_global && mg->mg_len >= -1);
2771 mg->mg_ptr = NULL;
2772 return 0;
2773 }
2774
2775
2776 int
Perl_magic_setuvar(pTHX_ SV * sv,MAGIC * mg)2777 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2778 {
2779 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2780
2781 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2782
2783 if (uf && uf->uf_set)
2784 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2785 return 0;
2786 }
2787
2788 int
Perl_magic_setregexp(pTHX_ SV * sv,MAGIC * mg)2789 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2790 {
2791 const char type = mg->mg_type;
2792
2793 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2794
2795 assert( type == PERL_MAGIC_fm
2796 || type == PERL_MAGIC_qr
2797 || type == PERL_MAGIC_bm);
2798 return sv_unmagic(sv, type);
2799 }
2800
2801 #ifdef USE_LOCALE_COLLATE
2802 int
Perl_magic_setcollxfrm(pTHX_ SV * sv,MAGIC * mg)2803 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2804 {
2805 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2806
2807 /*
2808 * RenE<eacute> Descartes said "I think not."
2809 * and vanished with a faint plop.
2810 */
2811 PERL_UNUSED_CONTEXT;
2812 PERL_UNUSED_ARG(sv);
2813 if (mg->mg_ptr) {
2814 Safefree(mg->mg_ptr);
2815 mg->mg_ptr = NULL;
2816 mg->mg_len = -1;
2817 }
2818 return 0;
2819 }
2820
2821 int
Perl_magic_freecollxfrm(pTHX_ SV * sv,MAGIC * mg)2822 Perl_magic_freecollxfrm(pTHX_ SV *sv, MAGIC *mg)
2823 {
2824 PERL_ARGS_ASSERT_MAGIC_FREECOLLXFRM;
2825 PERL_UNUSED_ARG(sv);
2826
2827 /* Collate magic uses mg_len as a string length rather than a buffer
2828 * length, so we need to free even with mg_len == 0: hence we can't
2829 * rely on standard magic free handling */
2830 if (mg->mg_len >= 0) {
2831 assert(mg->mg_type == PERL_MAGIC_collxfrm);
2832 Safefree(mg->mg_ptr);
2833 mg->mg_ptr = NULL;
2834 }
2835
2836 return 0;
2837 }
2838 #endif /* USE_LOCALE_COLLATE */
2839
2840 /* Just clear the UTF-8 cache data. */
2841 int
Perl_magic_setutf8(pTHX_ SV * sv,MAGIC * mg)2842 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2843 {
2844 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2845 PERL_UNUSED_CONTEXT;
2846 PERL_UNUSED_ARG(sv);
2847 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2848 mg->mg_ptr = NULL;
2849 mg->mg_len = -1; /* The mg_len holds the len cache. */
2850 return 0;
2851 }
2852
2853 int
Perl_magic_freeutf8(pTHX_ SV * sv,MAGIC * mg)2854 Perl_magic_freeutf8(pTHX_ SV *sv, MAGIC *mg)
2855 {
2856 PERL_ARGS_ASSERT_MAGIC_FREEUTF8;
2857 PERL_UNUSED_ARG(sv);
2858
2859 /* utf8 magic uses mg_len as a string length rather than a buffer
2860 * length, so we need to free even with mg_len == 0: hence we can't
2861 * rely on standard magic free handling */
2862 assert(mg->mg_type == PERL_MAGIC_utf8 && mg->mg_len >= -1);
2863 Safefree(mg->mg_ptr);
2864 mg->mg_ptr = NULL;
2865 return 0;
2866 }
2867
2868
2869 int
Perl_magic_setlvref(pTHX_ SV * sv,MAGIC * mg)2870 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2871 {
2872 const char *bad = NULL;
2873 PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2874 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2875 switch (mg->mg_private & OPpLVREF_TYPE) {
2876 case OPpLVREF_SV:
2877 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2878 bad = " SCALAR";
2879 break;
2880 case OPpLVREF_AV:
2881 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2882 bad = "n ARRAY";
2883 break;
2884 case OPpLVREF_HV:
2885 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2886 bad = " HASH";
2887 break;
2888 case OPpLVREF_CV:
2889 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2890 bad = " CODE";
2891 }
2892 if (bad)
2893 /* diag_listed_as: Assigned value is not %s reference */
2894 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2895 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2896 case 0:
2897 {
2898 SV * const old = PAD_SV(mg->mg_len);
2899 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2900 SvREFCNT_dec(old);
2901 break;
2902 }
2903 case SVt_PVGV:
2904 gv_setref(mg->mg_obj, sv);
2905 SvSETMAGIC(mg->mg_obj);
2906 break;
2907 case SVt_PVAV:
2908 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2909 SvREFCNT_inc_simple_NN(SvRV(sv)));
2910 break;
2911 case SVt_PVHV:
2912 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2913 SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2914 }
2915 if (mg->mg_flags & MGf_PERSIST)
2916 NOOP; /* This sv is in use as an iterator var and will be reused,
2917 so we must leave the magic. */
2918 else
2919 /* This sv could be returned by the assignment op, so clear the
2920 magic, as lvrefs are an implementation detail that must not be
2921 leaked to the user. */
2922 sv_unmagic(sv, PERL_MAGIC_lvref);
2923 return 0;
2924 }
2925
2926 static void
S_set_dollarzero(pTHX_ SV * sv)2927 S_set_dollarzero(pTHX_ SV *sv)
2928 PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2929 {
2930 const char *s;
2931 STRLEN len;
2932 #ifdef HAS_SETPROCTITLE
2933 /* The BSDs don't show the argv[] in ps(1) output, they
2934 * show a string from the process struct and provide
2935 * the setproctitle() routine to manipulate that. */
2936 if (PL_origalen != 1) {
2937 s = SvPV_const(sv, len);
2938 # if __FreeBSD_version > 410001 || defined(__DragonFly__)
2939 /* The leading "-" removes the "perl: " prefix,
2940 * but not the "(perl) suffix from the ps(1)
2941 * output, because that's what ps(1) shows if the
2942 * argv[] is modified. */
2943 setproctitle("-%s", s);
2944 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2945 /* This doesn't really work if you assume that
2946 * $0 = 'foobar'; will wipe out 'perl' from the $0
2947 * because in ps(1) output the result will be like
2948 * sprintf("perl: %s (perl)", s)
2949 * I guess this is a security feature:
2950 * one (a user process) cannot get rid of the original name.
2951 * --jhi */
2952 setproctitle("%s", s);
2953 # endif
2954 }
2955 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2956 if (PL_origalen != 1) {
2957 union pstun un;
2958 s = SvPV_const(sv, len);
2959 un.pst_command = (char *)s;
2960 pstat(PSTAT_SETCMD, un, len, 0, 0);
2961 }
2962 #else
2963 if (PL_origalen > 1) {
2964 I32 i;
2965 /* PL_origalen is set in perl_parse(). */
2966 s = SvPV_force(sv,len);
2967 if (len >= (STRLEN)PL_origalen-1) {
2968 /* Longer than original, will be truncated. We assume that
2969 * PL_origalen bytes are available. */
2970 Copy(s, PL_origargv[0], PL_origalen-1, char);
2971 }
2972 else {
2973 /* Shorter than original, will be padded. */
2974 #ifdef PERL_DARWIN
2975 /* Special case for Mac OS X: see [perl #38868] */
2976 const int pad = 0;
2977 #else
2978 /* Is the space counterintuitive? Yes.
2979 * (You were expecting \0?)
2980 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2981 * --jhi */
2982 const int pad = ' ';
2983 #endif
2984 Copy(s, PL_origargv[0], len, char);
2985 PL_origargv[0][len] = 0;
2986 memset(PL_origargv[0] + len + 1,
2987 pad, PL_origalen - len - 1);
2988 }
2989 PL_origargv[0][PL_origalen-1] = 0;
2990 for (i = 1; i < PL_origargc; i++)
2991 PL_origargv[i] = 0;
2992 #ifdef HAS_PRCTL_SET_NAME
2993 /* Set the legacy process name in addition to the POSIX name on Linux */
2994 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2995 /* diag_listed_as: SKIPME */
2996 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2997 }
2998 #endif
2999 }
3000 #endif
3001 }
3002
3003 int
Perl_magic_set(pTHX_ SV * sv,MAGIC * mg)3004 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
3005 {
3006 I32 paren;
3007 const REGEXP * rx;
3008 I32 i;
3009 STRLEN len;
3010 MAGIC *tmg;
3011
3012 PERL_ARGS_ASSERT_MAGIC_SET;
3013
3014 if (!mg->mg_ptr) {
3015 paren = mg->mg_len;
3016 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
3017 setparen_got_rx:
3018 CALLREG_NUMBUF_STORE((REGEXP *)rx,paren,sv);
3019 } else {
3020 /* Croak with a READONLY error when a numbered match var is
3021 * set without a previous pattern match. Unless it's C<local $1>
3022 */
3023 croakparen:
3024 if (!PL_localizing) {
3025 Perl_croak_no_modify();
3026 }
3027 }
3028 return 0;
3029 }
3030
3031 switch (*mg->mg_ptr) {
3032 case '\001': /* ^A */
3033 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
3034 else SvOK_off(PL_bodytarget);
3035 FmLINES(PL_bodytarget) = 0;
3036 if (SvPOK(PL_bodytarget)) {
3037 char *s = SvPVX(PL_bodytarget);
3038 char *e = SvEND(PL_bodytarget);
3039 while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
3040 FmLINES(PL_bodytarget)++;
3041 s++;
3042 }
3043 }
3044 /* mg_set() has temporarily made sv non-magical */
3045 if (TAINTING_get) {
3046 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
3047 SvTAINTED_on(PL_bodytarget);
3048 else
3049 SvTAINTED_off(PL_bodytarget);
3050 }
3051 break;
3052 case '\003': /* ^C */
3053 PL_minus_c = cBOOL(SvIV(sv));
3054 break;
3055
3056 case '\004': /* ^D */
3057 #ifdef DEBUGGING
3058 {
3059 const char *s = SvPV_nolen_const(sv);
3060 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
3061 if (DEBUG_x_TEST || DEBUG_B_TEST)
3062 dump_all_perl(!DEBUG_B_TEST);
3063 }
3064 #else
3065 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
3066 #endif
3067 break;
3068 case '\005': /* ^E */
3069 if (*(mg->mg_ptr+1) == '\0') {
3070 #ifdef VMS
3071 set_vaxc_errno(SvIV(sv));
3072 #elif defined(WIN32)
3073 SetLastError( SvIV(sv) );
3074 #elif defined(OS2)
3075 os2_setsyserrno(SvIV(sv));
3076 #else
3077 /* will anyone ever use this? */
3078 SETERRNO(SvIV(sv), 4);
3079 #endif
3080 }
3081 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
3082 Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
3083 break;
3084 case '\006': /* ^F */
3085 if (mg->mg_ptr[1] == '\0') {
3086 PL_maxsysfd = SvIV(sv);
3087 }
3088 break;
3089 case '\010': /* ^H */
3090 {
3091 U32 save_hints = PL_hints;
3092 PL_hints = SvUV(sv);
3093
3094 /* If wasn't UTF-8, and now is, notify the parser */
3095 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
3096 notify_parser_that_changed_to_utf8();
3097 }
3098 }
3099 break;
3100 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3101 Safefree(PL_inplace);
3102 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
3103 break;
3104 case '\016': /* ^N */
3105 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
3106 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
3107 goto croakparen;
3108 case '\017': /* ^O */
3109 if (*(mg->mg_ptr+1) == '\0') {
3110 Safefree(PL_osname);
3111 PL_osname = NULL;
3112 if (SvOK(sv)) {
3113 TAINT_PROPER("assigning to $^O");
3114 PL_osname = savesvpv(sv);
3115 }
3116 }
3117 else if (strEQ(mg->mg_ptr, "\017PEN")) {
3118 STRLEN len;
3119 const char *const start = SvPV(sv, len);
3120 const char *out = (const char*)memchr(start, '\0', len);
3121 SV *tmp;
3122
3123
3124 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
3125 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
3126
3127 /* Opening for input is more common than opening for output, so
3128 ensure that hints for input are sooner on linked list. */
3129 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
3130 SvUTF8(sv))
3131 : newSVpvs_flags("", SvUTF8(sv));
3132 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
3133 mg_set(tmp);
3134
3135 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
3136 SvUTF8(sv));
3137 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
3138 mg_set(tmp);
3139 }
3140 break;
3141 case '\020': /* ^P */
3142 PL_perldb = SvIV(sv);
3143 if (PL_perldb && !PL_DBsingle)
3144 init_debugger();
3145 break;
3146 case '\024': /* ^T */
3147 #ifdef BIG_TIME
3148 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
3149 #else
3150 PL_basetime = (Time_t)SvIV(sv);
3151 #endif
3152 break;
3153 case '\025': /* ^UTF8CACHE */
3154 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
3155 PL_utf8cache = (signed char) sv_2iv(sv);
3156 }
3157 break;
3158 case '\027': /* ^W & $^WARNING_BITS */
3159 if (*(mg->mg_ptr+1) == '\0') {
3160 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
3161 i = SvIV(sv);
3162 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
3163 | (i ? G_WARN_ON : G_WARN_OFF) ;
3164 }
3165 }
3166 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
3167 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
3168 if (!SvPOK(sv)) {
3169 free_and_set_cop_warnings(&PL_compiling, pWARN_STD);
3170 break;
3171 }
3172 {
3173 STRLEN len, i;
3174 int not_none = 0, not_all = 0;
3175 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
3176 for (i = 0 ; i < len ; ++i) {
3177 not_none |= ptr[i];
3178 not_all |= ptr[i] ^ 0x55;
3179 }
3180 if (!not_none) {
3181 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
3182 } else if (len >= WARNsize && !not_all) {
3183 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
3184 PL_dowarn |= G_WARN_ONCE ;
3185 }
3186 else {
3187 STRLEN len;
3188 const char *const p = SvPV_const(sv, len);
3189
3190 free_and_set_cop_warnings(
3191 &PL_compiling,
3192 Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
3193 p, len)
3194 );
3195
3196 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
3197 PL_dowarn |= G_WARN_ONCE ;
3198 }
3199 }
3200 }
3201 }
3202 break;
3203 case '.':
3204 if (PL_localizing) {
3205 if (PL_localizing == 1)
3206 SAVESPTR(PL_last_in_gv);
3207 }
3208 else if (SvOK(sv) && GvIO(PL_last_in_gv))
3209 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
3210 break;
3211 case '^':
3212 {
3213 IO * const io = GvIO(PL_defoutgv);
3214 if (!io)
3215 break;
3216
3217 Safefree(IoTOP_NAME(io));
3218 IoTOP_NAME(io) = savesvpv(sv);
3219 IoTOP_GV(io) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3220 }
3221 break;
3222 case '~':
3223 {
3224 IO * const io = GvIO(PL_defoutgv);
3225 if (!io)
3226 break;
3227
3228 Safefree(IoFMT_NAME(io));
3229 IoFMT_NAME(io) = savesvpv(sv);
3230 IoFMT_GV(io) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3231 }
3232 break;
3233 case '=':
3234 {
3235 IO * const io = GvIO(PL_defoutgv);
3236 if (!io)
3237 break;
3238
3239 IoPAGE_LEN(io) = (SvIV(sv));
3240 }
3241 break;
3242 case '-':
3243 {
3244 IO * const io = GvIO(PL_defoutgv);
3245 if (!io)
3246 break;
3247
3248 IoLINES_LEFT(io) = (SvIV(sv));
3249 if (IoLINES_LEFT(io) < 0L)
3250 IoLINES_LEFT(io) = 0L;
3251 }
3252 break;
3253 case '%':
3254 {
3255 IO * const io = GvIO(PL_defoutgv);
3256 if (!io)
3257 break;
3258
3259 IoPAGE(io) = (SvIV(sv));
3260 }
3261 break;
3262 case '|':
3263 {
3264 IO * const io = GvIO(PL_defoutgv);
3265 if(!io)
3266 break;
3267 if ((SvIV(sv)) == 0)
3268 IoFLAGS(io) &= ~IOf_FLUSH;
3269 else {
3270 if (!(IoFLAGS(io) & IOf_FLUSH)) {
3271 PerlIO *ofp = IoOFP(io);
3272 if (ofp)
3273 (void)PerlIO_flush(ofp);
3274 IoFLAGS(io) |= IOf_FLUSH;
3275 }
3276 }
3277 }
3278 break;
3279 case '/':
3280 {
3281 if (SvROK(sv)) {
3282 SV *referent = SvRV(sv);
3283 const char *reftype = sv_reftype(referent, 0);
3284 /* XXX: dodgy type check: This leaves me feeling dirty, but
3285 * the alternative is to copy pretty much the entire
3286 * sv_reftype() into this routine, or to do a full string
3287 * comparison on the return of sv_reftype() both of which
3288 * make me feel worse! NOTE, do not modify this comment
3289 * without reviewing the corresponding comment in
3290 * sv_reftype(). - Yves */
3291 if (reftype[0] == 'S' || reftype[0] == 'L') {
3292 IV val = SvIV(referent);
3293 if (val <= 0) {
3294 sv_setsv(sv, PL_rs);
3295 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3296 val < 0 ? "a negative integer" : "zero");
3297 }
3298 } else {
3299 sv_setsv(sv, PL_rs);
3300 /* diag_listed_as: Setting $/ to %s reference is forbidden */
3301 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3302 *reftype == 'A' ? "n" : "", reftype);
3303 }
3304 }
3305 SvREFCNT_dec(PL_rs);
3306 PL_rs = newSVsv(sv);
3307 }
3308 break;
3309 case '\\':
3310 SvREFCNT_dec(PL_ors_sv);
3311 if (SvOK(sv)) {
3312 PL_ors_sv = newSVsv(sv);
3313 }
3314 else {
3315 PL_ors_sv = NULL;
3316 }
3317 break;
3318 case '[':
3319 if (SvIV(sv) != 0)
3320 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3321 break;
3322 case '?':
3323 #ifdef COMPLEX_STATUS
3324 if (PL_localizing == 2) {
3325 SvUPGRADE(sv, SVt_PVLV);
3326 PL_statusvalue = LvTARGOFF(sv);
3327 PL_statusvalue_vms = LvTARGLEN(sv);
3328 }
3329 else
3330 #endif
3331 #ifdef VMSISH_STATUS
3332 if (VMSISH_STATUS)
3333 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3334 else
3335 #endif
3336 STATUS_UNIX_EXIT_SET(SvIV(sv));
3337 break;
3338 case '!':
3339 {
3340 #ifdef VMS
3341 # define PERL_VMS_BANG vaxc$errno
3342 #else
3343 # define PERL_VMS_BANG 0
3344 #endif
3345 #if defined(WIN32)
3346 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3347 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3348 #else
3349 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3350 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3351 #endif
3352 }
3353 break;
3354 case '<':
3355 {
3356 /* XXX $< currently silently ignores failures */
3357 const Uid_t new_uid = SvUID(sv);
3358 PL_delaymagic_uid = new_uid;
3359 if (PL_delaymagic) {
3360 PL_delaymagic |= DM_RUID;
3361 break; /* don't do magic till later */
3362 }
3363 #ifdef HAS_SETRUID
3364 PERL_UNUSED_RESULT(setruid(new_uid));
3365 #elif defined(HAS_SETREUID)
3366 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3367 #elif defined(HAS_SETRESUID)
3368 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3369 #else
3370 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
3371 # ifdef PERL_DARWIN
3372 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3373 if (new_uid != 0 && PerlProc_getuid() == 0)
3374 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3375 # endif
3376 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3377 } else {
3378 Perl_croak(aTHX_ "setruid() not implemented");
3379 }
3380 #endif
3381 break;
3382 }
3383 case '>':
3384 {
3385 /* XXX $> currently silently ignores failures */
3386 const Uid_t new_euid = SvUID(sv);
3387 PL_delaymagic_euid = new_euid;
3388 if (PL_delaymagic) {
3389 PL_delaymagic |= DM_EUID;
3390 break; /* don't do magic till later */
3391 }
3392 #ifdef HAS_SETEUID
3393 PERL_UNUSED_RESULT(seteuid(new_euid));
3394 #elif defined(HAS_SETREUID)
3395 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3396 #elif defined(HAS_SETRESUID)
3397 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3398 #else
3399 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
3400 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3401 else {
3402 Perl_croak(aTHX_ "seteuid() not implemented");
3403 }
3404 #endif
3405 break;
3406 }
3407 case '(':
3408 {
3409 /* XXX $( currently silently ignores failures */
3410 const Gid_t new_gid = SvGID(sv);
3411 PL_delaymagic_gid = new_gid;
3412 if (PL_delaymagic) {
3413 PL_delaymagic |= DM_RGID;
3414 break; /* don't do magic till later */
3415 }
3416 #ifdef HAS_SETRGID
3417 PERL_UNUSED_RESULT(setrgid(new_gid));
3418 #elif defined(HAS_SETREGID)
3419 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3420 #elif defined(HAS_SETRESGID)
3421 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3422 #else
3423 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
3424 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3425 else {
3426 Perl_croak(aTHX_ "setrgid() not implemented");
3427 }
3428 #endif
3429 break;
3430 }
3431 case ')':
3432 {
3433 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3434 * but you can override it if you need to.
3435 */
3436 #ifndef INVALID_GID
3437 #define INVALID_GID ((Gid_t)-1)
3438 #endif
3439 /* XXX $) currently silently ignores failures */
3440 Gid_t new_egid;
3441 #ifdef HAS_SETGROUPS
3442 {
3443 const char *p = SvPV_const(sv, len);
3444 Groups_t *gary = NULL;
3445 const char* p_end = p + len;
3446 const char* endptr = p_end;
3447 UV uv;
3448 #ifdef _SC_NGROUPS_MAX
3449 int maxgrp = sysconf(_SC_NGROUPS_MAX);
3450
3451 if (maxgrp < 0)
3452 maxgrp = NGROUPS;
3453 #else
3454 int maxgrp = NGROUPS;
3455 #endif
3456
3457 while (isSPACE(*p))
3458 ++p;
3459 if (grok_atoUV(p, &uv, &endptr))
3460 new_egid = (Gid_t)uv;
3461 else {
3462 new_egid = INVALID_GID;
3463 endptr = NULL;
3464 }
3465 for (i = 0; i < maxgrp; ++i) {
3466 if (endptr == NULL)
3467 break;
3468 p = endptr;
3469 endptr = p_end;
3470 while (isSPACE(*p))
3471 ++p;
3472 if (!*p)
3473 break;
3474 if (!gary)
3475 Newx(gary, i + 1, Groups_t);
3476 else
3477 Renew(gary, i + 1, Groups_t);
3478 if (grok_atoUV(p, &uv, &endptr))
3479 gary[i] = (Groups_t)uv;
3480 else {
3481 gary[i] = INVALID_GID;
3482 endptr = NULL;
3483 }
3484 }
3485 if (i)
3486 PERL_UNUSED_RESULT(setgroups(i, gary));
3487 Safefree(gary);
3488 }
3489 #else /* HAS_SETGROUPS */
3490 new_egid = SvGID(sv);
3491 #endif /* HAS_SETGROUPS */
3492 PL_delaymagic_egid = new_egid;
3493 if (PL_delaymagic) {
3494 PL_delaymagic |= DM_EGID;
3495 break; /* don't do magic till later */
3496 }
3497 #ifdef HAS_SETEGID
3498 PERL_UNUSED_RESULT(setegid(new_egid));
3499 #elif defined(HAS_SETREGID)
3500 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3501 #elif defined(HAS_SETRESGID)
3502 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3503 #else
3504 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
3505 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3506 else {
3507 Perl_croak(aTHX_ "setegid() not implemented");
3508 }
3509 #endif
3510 break;
3511 }
3512 case ':':
3513 PL_chopset = SvPV_force(sv,len);
3514 break;
3515 case '$': /* $$ */
3516 /* Store the pid in mg->mg_obj so we can tell when a fork has
3517 occurred. mg->mg_obj points to *$ by default, so clear it. */
3518 if (isGV(mg->mg_obj)) {
3519 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3520 SvREFCNT_dec(mg->mg_obj);
3521 mg->mg_flags |= MGf_REFCOUNTED;
3522 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3523 }
3524 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3525 break;
3526 case '0':
3527 if (!sv_utf8_downgrade(sv, /* fail_ok */ TRUE)) {
3528
3529 /* Since we are going to set the string's UTF8-encoded form
3530 as the process name we should update $0 itself to contain
3531 that same (UTF8-encoded) value. */
3532 sv_utf8_encode(GvSV(mg->mg_obj));
3533
3534 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "$0");
3535 }
3536
3537 LOCK_DOLLARZERO_MUTEX;
3538 S_set_dollarzero(aTHX_ sv);
3539 UNLOCK_DOLLARZERO_MUTEX;
3540 break;
3541 }
3542 return 0;
3543 }
3544
3545 /*
3546 =for apidoc_section $signals
3547 =for apidoc whichsig
3548 =for apidoc_item whichsig_pv
3549 =for apidoc_item whichsig_pvn
3550 =for apidoc_item whichsig_sv
3551
3552 These all convert a signal name into its corresponding signal number;
3553 returning -1 if no corresponding number was found.
3554
3555 They differ only in the source of the signal name:
3556
3557 C<whichsig_pv> takes the name from the C<NUL>-terminated string starting at
3558 C<sig>.
3559
3560 C<whichsig> is merely a different spelling, a synonym, of C<whichsig_pv>.
3561
3562 C<whichsig_pvn> takes the name from the string starting at C<sig>, with length
3563 C<len> bytes.
3564
3565 C<whichsig_sv> takes the name from the PV stored in the SV C<sigsv>.
3566
3567 =cut
3568 */
3569
3570 I32
Perl_whichsig_sv(pTHX_ SV * sigsv)3571 Perl_whichsig_sv(pTHX_ SV *sigsv)
3572 {
3573 const char *sigpv;
3574 STRLEN siglen;
3575 PERL_ARGS_ASSERT_WHICHSIG_SV;
3576 sigpv = SvPV_const(sigsv, siglen);
3577 return whichsig_pvn(sigpv, siglen);
3578 }
3579
3580 I32
Perl_whichsig_pv(pTHX_ const char * sig)3581 Perl_whichsig_pv(pTHX_ const char *sig)
3582 {
3583 PERL_ARGS_ASSERT_WHICHSIG_PV;
3584 return whichsig_pvn(sig, strlen(sig));
3585 }
3586
3587 I32
Perl_whichsig_pvn(pTHX_ const char * sig,STRLEN len)3588 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3589 {
3590 char* const* sigv;
3591
3592 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3593 PERL_UNUSED_CONTEXT;
3594
3595 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3596 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3597 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3598 #ifdef SIGCLD
3599 if (memEQs(sig, len, "CHLD"))
3600 return SIGCLD;
3601 #endif
3602 #ifdef SIGCHLD
3603 if (memEQs(sig, len, "CLD"))
3604 return SIGCHLD;
3605 #endif
3606 return -1;
3607 }
3608
3609
3610 /* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3():
3611 * these three function are intended to be called by the OS as 'C' level
3612 * signal handler functions in the case where unsafe signals are being
3613 * used - i.e. they immediately invoke Perl_perly_sighandler() to call the
3614 * perl-level sighandler, rather than deferring.
3615 * In fact, the core itself will normally use Perl_csighandler as the
3616 * OS-level handler; that function will then decide whether to queue the
3617 * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these
3618 * functions are more useful for e.g. POSIX.xs when it wants explicit
3619 * control of what's happening.
3620 */
3621
3622
3623 #ifdef PERL_USE_3ARG_SIGHANDLER
3624
3625 Signal_t
Perl_sighandler(int sig,Siginfo_t * sip,void * uap)3626 Perl_sighandler(int sig, Siginfo_t *sip, void *uap)
3627 {
3628 Perl_perly_sighandler(sig, sip, uap, 0);
3629 }
3630
3631 #else
3632
3633 Signal_t
Perl_sighandler(int sig)3634 Perl_sighandler(int sig)
3635 {
3636 Perl_perly_sighandler(sig, NULL, NULL, 0);
3637 }
3638
3639 #endif
3640
3641 Signal_t
Perl_sighandler1(int sig)3642 Perl_sighandler1(int sig)
3643 {
3644 Perl_perly_sighandler(sig, NULL, NULL, 0);
3645 }
3646
3647 Signal_t
Perl_sighandler3(int sig,Siginfo_t * sip PERL_UNUSED_DECL,void * uap PERL_UNUSED_DECL)3648 Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
3649 {
3650 Perl_perly_sighandler(sig, sip, uap, 0);
3651 }
3652
3653
3654 /* Invoke the perl-level signal handler. This function is called either
3655 * directly from one of the C-level signals handlers (Perl_sighandler or
3656 * Perl_csighandler), or for safe signals, later from
3657 * Perl_despatch_signals() at a suitable safe point during execution.
3658 *
3659 * 'safe' is a boolean indicating the latter call path.
3660 */
3661
3662 Signal_t
Perl_perly_sighandler(int sig,Siginfo_t * sip PERL_UNUSED_DECL,void * uap PERL_UNUSED_DECL,bool safe)3663 Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL,
3664 void *uap PERL_UNUSED_DECL, bool safe)
3665 {
3666 #ifdef PERL_GET_SIG_CONTEXT
3667 dTHXa(PERL_GET_SIG_CONTEXT);
3668 #else
3669 dTHX;
3670 #endif
3671 dSP;
3672 GV *gv = NULL;
3673 SV *sv = NULL;
3674 SV * const tSv = PL_Sv;
3675 CV *cv = NULL;
3676 OP *myop = PL_op;
3677 U32 flags = 0;
3678 XPV * const tXpv = PL_Xpv;
3679 I32 old_ss_ix = PL_savestack_ix;
3680 SV *errsv_save = NULL;
3681
3682
3683 if (!PL_psig_ptr[sig]) {
3684 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3685 PL_sig_name[sig]);
3686 exit(sig);
3687 }
3688
3689 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3690 /* Max number of items pushed there is 3*n or 4. We cannot fix
3691 infinity, so we fix 4 (in fact 5): */
3692 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3693 flags |= 1;
3694 PL_savestack_ix += 5; /* Protect save in progress. */
3695 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3696 }
3697 }
3698 /* sv_2cv is too complicated, try a simpler variant first: */
3699 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3700 || SvTYPE(cv) != SVt_PVCV) {
3701 HV *st;
3702 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3703 }
3704
3705 if (!cv || !CvROOT(cv)) {
3706 const HEK * const hek = gv
3707 ? GvENAME_HEK(gv)
3708 : cv && CvNAMED(cv)
3709 ? CvNAME_HEK(cv)
3710 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3711 if (hek)
3712 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3713 "SIG%s handler \"%" HEKf "\" not defined.\n",
3714 PL_sig_name[sig], HEKfARG(hek));
3715 /* diag_listed_as: SIG%s handler "%s" not defined */
3716 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3717 "SIG%s handler \"__ANON__\" not defined.\n",
3718 PL_sig_name[sig]);
3719 goto cleanup;
3720 }
3721
3722 sv = PL_psig_name[sig]
3723 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3724 : newSVpv(PL_sig_name[sig],0);
3725 flags |= 8;
3726 SAVEFREESV(sv);
3727
3728 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3729 /* make sure our assumption about the size of the SAVEs are correct:
3730 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3731 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3732 }
3733
3734 PUSHSTACKi(PERLSI_SIGNAL);
3735 PUSHMARK(SP);
3736 PUSHs(sv);
3737
3738 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3739 {
3740 struct sigaction oact;
3741
3742 if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3743 HV *sih = newHV();
3744 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3745 /* The siginfo fields signo, code, errno, pid, uid,
3746 * addr, status, and band are defined by POSIX/SUSv3. */
3747 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3748 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3749 # ifdef HAS_SIGINFO_SI_ERRNO
3750 (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
3751 # endif
3752 # ifdef HAS_SIGINFO_SI_STATUS
3753 (void)hv_stores(sih, "status", newSViv(sip->si_status));
3754 # endif
3755 # ifdef HAS_SIGINFO_SI_UID
3756 {
3757 SV *uid = newSV(0);
3758 sv_setuid(uid, sip->si_uid);
3759 (void)hv_stores(sih, "uid", uid);
3760 }
3761 # endif
3762 # ifdef HAS_SIGINFO_SI_PID
3763 (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
3764 # endif
3765 # ifdef HAS_SIGINFO_SI_ADDR
3766 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3767 # endif
3768 # ifdef HAS_SIGINFO_SI_BAND
3769 (void)hv_stores(sih, "band", newSViv(sip->si_band));
3770 # endif
3771 EXTEND(SP, 2);
3772 PUSHs(rv);
3773 mPUSHp((char *)sip, sizeof(*sip));
3774
3775 }
3776 }
3777 #endif
3778
3779 PUTBACK;
3780
3781 errsv_save = newSVsv(ERRSV);
3782
3783 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3784
3785 POPSTACK;
3786 {
3787 SV * const errsv = ERRSV;
3788 if (SvTRUE_NN(errsv)) {
3789 SvREFCNT_dec(errsv_save);
3790
3791 /* Handler "died", for example to get out of a restart-able read().
3792 * Before we re-do that on its behalf re-enable the signal which was
3793 * blocked by the system when we entered.
3794 */
3795 # ifdef HAS_SIGPROCMASK
3796 if (!safe) {
3797 /* safe signals called via dispatch_signals() set up a
3798 * savestack destructor, unblock_sigmask(), to
3799 * automatically unblock the handler at the end. If
3800 * instead we get here directly, we have to do it
3801 * ourselves
3802 */
3803 sigset_t set;
3804 sigemptyset(&set);
3805 sigaddset(&set,sig);
3806 sigprocmask(SIG_UNBLOCK, &set, NULL);
3807 }
3808 # else
3809 /* Not clear if this will work */
3810 /* XXX not clear if this should be protected by 'if (safe)'
3811 * too */
3812
3813 (void)rsignal(sig, SIG_IGN);
3814 (void)rsignal(sig, PL_csighandlerp);
3815 # endif
3816
3817 die_sv(errsv);
3818 }
3819 else {
3820 sv_setsv(errsv, errsv_save);
3821 SvREFCNT_dec(errsv_save);
3822 }
3823 }
3824
3825 cleanup:
3826 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3827 PL_savestack_ix = old_ss_ix;
3828 if (flags & 8)
3829 SvREFCNT_dec_NN(sv);
3830 PL_op = myop; /* Apparently not needed... */
3831
3832 PL_Sv = tSv; /* Restore global temporaries. */
3833 PL_Xpv = tXpv;
3834 return;
3835 }
3836
3837
3838 static void
S_restore_magic(pTHX_ const void * p)3839 S_restore_magic(pTHX_ const void *p)
3840 {
3841 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3842 SV* const sv = mgs->mgs_sv;
3843 bool bumped;
3844
3845 if (!sv)
3846 return;
3847
3848 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3849 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3850 if (mgs->mgs_flags)
3851 SvFLAGS(sv) |= mgs->mgs_flags;
3852 else
3853 mg_magical(sv);
3854 }
3855
3856 bumped = mgs->mgs_bumped;
3857 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3858
3859 /* If we're still on top of the stack, pop us off. (That condition
3860 * will be satisfied if restore_magic was called explicitly, but *not*
3861 * if it's being called via leave_scope.)
3862 * The reason for doing this is that otherwise, things like sv_2cv()
3863 * may leave alloc gunk on the savestack, and some code
3864 * (e.g. sighandler) doesn't expect that...
3865 */
3866 if (PL_savestack_ix == mgs->mgs_ss_ix)
3867 {
3868 UV popval = SSPOPUV;
3869 assert(popval == SAVEt_DESTRUCTOR_X);
3870 PL_savestack_ix -= 2;
3871 popval = SSPOPUV;
3872 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3873 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3874 }
3875 if (bumped) {
3876 if (SvREFCNT(sv) == 1) {
3877 /* We hold the last reference to this SV, which implies that the
3878 SV was deleted as a side effect of the routines we called.
3879 So artificially keep it alive a bit longer.
3880 We avoid turning on the TEMP flag, which can cause the SV's
3881 buffer to get stolen (and maybe other stuff). */
3882 sv_2mortal(sv);
3883 SvTEMP_off(sv);
3884 }
3885 else
3886 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3887 }
3888 }
3889
3890 /* clean up the mess created by Perl_sighandler().
3891 * Note that this is only called during an exit in a signal handler;
3892 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3893 * skipped over. */
3894
3895 static void
S_unwind_handler_stack(pTHX_ const void * p)3896 S_unwind_handler_stack(pTHX_ const void *p)
3897 {
3898 PERL_UNUSED_ARG(p);
3899
3900 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3901 }
3902
3903 /*
3904 =for apidoc_section $magic
3905 =for apidoc magic_sethint
3906
3907 Triggered by a store to C<%^H>, records the key/value pair to
3908 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3909 anything that would need a deep copy. Maybe we should warn if we find a
3910 reference.
3911
3912 =cut
3913 */
3914 int
Perl_magic_sethint(pTHX_ SV * sv,MAGIC * mg)3915 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3916 {
3917 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3918 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3919
3920 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3921
3922 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3923 an alternative leaf in there, with PL_compiling.cop_hints being used if
3924 it's NULL. If needed for threads, the alternative could lock a mutex,
3925 or take other more complex action. */
3926
3927 /* Something changed in %^H, so it will need to be restored on scope exit.
3928 Doing this here saves a lot of doing it manually in perl code (and
3929 forgetting to do it, and consequent subtle errors. */
3930 PL_hints |= HINT_LOCALIZE_HH;
3931 CopHINTHASH_set(&PL_compiling,
3932 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3933 magic_sethint_feature(key, NULL, 0, sv, 0);
3934 return 0;
3935 }
3936
3937 /*
3938 =for apidoc magic_clearhint
3939
3940 Triggered by a delete from C<%^H>, records the key to
3941 C<PL_compiling.cop_hints_hash>.
3942
3943 =cut
3944 */
3945 int
Perl_magic_clearhint(pTHX_ SV * sv,MAGIC * mg)3946 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3947 {
3948 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3949 PERL_UNUSED_ARG(sv);
3950
3951 PL_hints |= HINT_LOCALIZE_HH;
3952 CopHINTHASH_set(&PL_compiling,
3953 mg->mg_len == HEf_SVKEY
3954 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3955 MUTABLE_SV(mg->mg_ptr), 0, 0)
3956 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3957 mg->mg_ptr, mg->mg_len, 0, 0));
3958 if (mg->mg_len == HEf_SVKEY)
3959 magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE);
3960 else
3961 magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE);
3962 return 0;
3963 }
3964
3965 /*
3966 =for apidoc magic_clearhints
3967
3968 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3969
3970 =cut
3971 */
3972 int
Perl_magic_clearhints(pTHX_ SV * sv,MAGIC * mg)3973 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3974 {
3975 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3976 PERL_UNUSED_ARG(sv);
3977 PERL_UNUSED_ARG(mg);
3978 cophh_free(CopHINTHASH_get(&PL_compiling));
3979 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3980 CLEARFEATUREBITS();
3981 return 0;
3982 }
3983
3984 int
Perl_magic_copycallchecker(pTHX_ SV * sv,MAGIC * mg,SV * nsv,const char * name,I32 namlen)3985 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3986 const char *name, I32 namlen)
3987 {
3988 MAGIC *nmg;
3989
3990 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3991 PERL_UNUSED_ARG(sv);
3992 PERL_UNUSED_ARG(name);
3993 PERL_UNUSED_ARG(namlen);
3994
3995 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3996 nmg = mg_find(nsv, mg->mg_type);
3997 assert(nmg);
3998 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3999 nmg->mg_ptr = mg->mg_ptr;
4000 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
4001 nmg->mg_flags |= MGf_REFCOUNTED;
4002 return 1;
4003 }
4004
4005 int
Perl_magic_setdebugvar(pTHX_ SV * sv,MAGIC * mg)4006 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
4007 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
4008
4009 #if DBVARMG_SINGLE != 0
4010 assert(mg->mg_private >= DBVARMG_SINGLE);
4011 #endif
4012 assert(mg->mg_private < DBVARMG_COUNT);
4013
4014 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
4015
4016 return 1;
4017 }
4018
4019 int
Perl_magic_getdebugvar(pTHX_ SV * sv,MAGIC * mg)4020 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
4021 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
4022
4023 #if DBVARMG_SINGLE != 0
4024 assert(mg->mg_private >= DBVARMG_SINGLE);
4025 #endif
4026 assert(mg->mg_private < DBVARMG_COUNT);
4027 sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
4028
4029 return 0;
4030 }
4031
4032 /*
4033 * ex: set ts=8 sts=4 sw=4 et:
4034 */
4035