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 #ifndef PERL_MICRO
1474 #ifdef HAS_SIGPROCMASK
1475 static void
restore_sigmask(pTHX_ SV * save_sv)1476 restore_sigmask(pTHX_ SV *save_sv)
1477 {
1478 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1479 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1480 }
1481 #endif
1482 int
Perl_magic_getsig(pTHX_ SV * sv,MAGIC * mg)1483 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1484 {
1485 /* Are we fetching a signal entry? */
1486 int i = (I16)mg->mg_private;
1487
1488 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1489
1490 if (!i) {
1491 STRLEN siglen;
1492 const char * sig = MgPV_const(mg, siglen);
1493 mg->mg_private = i = whichsig_pvn(sig, siglen);
1494 }
1495
1496 if (i > 0) {
1497 if(PL_psig_ptr[i])
1498 sv_setsv(sv,PL_psig_ptr[i]);
1499 else {
1500 Sighandler_t sigstate = rsignal_state(i);
1501 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1502 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1503 sigstate = SIG_IGN;
1504 #endif
1505 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1506 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1507 sigstate = SIG_DFL;
1508 #endif
1509 /* cache state so we don't fetch it again */
1510 if(sigstate == (Sighandler_t) SIG_IGN)
1511 sv_setpvs(sv,"IGNORE");
1512 else
1513 sv_set_undef(sv);
1514 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1515 SvTEMP_off(sv);
1516 }
1517 }
1518 return 0;
1519 }
1520 int
Perl_magic_clearsig(pTHX_ SV * sv,MAGIC * mg)1521 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1522 {
1523 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1524
1525 magic_setsig(NULL, mg);
1526 return sv_unmagic(sv, mg->mg_type);
1527 }
1528
1529
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
Perl_csighandler(int sig)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 #endif /* !PERL_MICRO */
1874
1875 int
Perl_magic_setsigall(pTHX_ SV * sv,MAGIC * mg)1876 Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg)
1877 {
1878 PERL_ARGS_ASSERT_MAGIC_SETSIGALL;
1879 PERL_UNUSED_ARG(mg);
1880
1881 if (PL_localizing == 2) {
1882 HV* hv = (HV*)sv;
1883 HE* current;
1884 hv_iterinit(hv);
1885 while ((current = hv_iternext(hv))) {
1886 SV* sigelem = hv_iterval(hv, current);
1887 mg_set(sigelem);
1888 }
1889 }
1890 return 0;
1891 }
1892
1893 int
Perl_magic_clearhook(pTHX_ SV * sv,MAGIC * mg)1894 Perl_magic_clearhook(pTHX_ SV *sv, MAGIC *mg)
1895 {
1896 PERL_ARGS_ASSERT_MAGIC_CLEARHOOK;
1897
1898 magic_sethook(NULL, mg);
1899 return sv_unmagic(sv, mg->mg_type);
1900 }
1901
1902 /* sv of NULL signifies that we're acting as magic_clearhook. */
1903 int
Perl_magic_sethook(pTHX_ SV * sv,MAGIC * mg)1904 Perl_magic_sethook(pTHX_ SV *sv, MAGIC *mg)
1905 {
1906 SV** svp = NULL;
1907 STRLEN len;
1908 const char *s = MgPV_const(mg,len);
1909
1910 PERL_ARGS_ASSERT_MAGIC_SETHOOK;
1911
1912 if (memEQs(s, len, "require__before")) {
1913 svp = &PL_hook__require__before;
1914 }
1915 else if (memEQs(s, len, "require__after")) {
1916 svp = &PL_hook__require__after;
1917 }
1918 else {
1919 SV *tmp = sv_newmortal();
1920 Perl_croak(aTHX_ "Attempt to set unknown hook '%s' in %%{^HOOK}",
1921 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1922 }
1923 if (sv && SvOK(sv) && (!SvROK(sv) || SvTYPE(SvRV(sv))!= SVt_PVCV))
1924 croak("${^HOOK}{%.*s} may only be a CODE reference or undef", (int)len, s);
1925
1926 if (svp) {
1927 if (*svp)
1928 SvREFCNT_dec(*svp);
1929
1930 if (sv)
1931 *svp = SvREFCNT_inc_simple_NN(sv);
1932 else
1933 *svp = NULL;
1934 }
1935
1936 return 0;
1937 }
1938
1939 int
Perl_magic_sethookall(pTHX_ SV * sv,MAGIC * mg)1940 Perl_magic_sethookall(pTHX_ SV* sv, MAGIC* mg)
1941 {
1942 PERL_ARGS_ASSERT_MAGIC_SETHOOKALL;
1943 PERL_UNUSED_ARG(mg);
1944
1945 if (PL_localizing == 1) {
1946 SAVEGENERICSV(PL_hook__require__before);
1947 PL_hook__require__before = NULL;
1948 SAVEGENERICSV(PL_hook__require__after);
1949 PL_hook__require__after = NULL;
1950 }
1951 else
1952 if (PL_localizing == 2) {
1953 HV* hv = (HV*)sv;
1954 HE* current;
1955 hv_iterinit(hv);
1956 while ((current = hv_iternext(hv))) {
1957 SV* hookelem = hv_iterval(hv, current);
1958 mg_set(hookelem);
1959 }
1960 }
1961 return 0;
1962 }
1963
1964 int
Perl_magic_clearhookall(pTHX_ SV * sv,MAGIC * mg)1965 Perl_magic_clearhookall(pTHX_ SV* sv, MAGIC* mg)
1966 {
1967 PERL_ARGS_ASSERT_MAGIC_CLEARHOOKALL;
1968 PERL_UNUSED_ARG(mg);
1969 PERL_UNUSED_ARG(sv);
1970
1971 SvREFCNT_dec_set_NULL(PL_hook__require__before);
1972
1973 SvREFCNT_dec_set_NULL(PL_hook__require__after);
1974
1975 return 0;
1976 }
1977
1978
1979 int
Perl_magic_setisa(pTHX_ SV * sv,MAGIC * mg)1980 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1981 {
1982 PERL_ARGS_ASSERT_MAGIC_SETISA;
1983 PERL_UNUSED_ARG(sv);
1984
1985 /* Skip _isaelem because _isa will handle it shortly */
1986 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1987 return 0;
1988
1989 return magic_clearisa(NULL, mg);
1990 }
1991
1992 /* sv of NULL signifies that we're acting as magic_setisa. */
1993 int
Perl_magic_clearisa(pTHX_ SV * sv,MAGIC * mg)1994 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1995 {
1996 HV* stash;
1997 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1998
1999 /* Bail out if destruction is going on */
2000 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
2001
2002 if (sv)
2003 av_clear(MUTABLE_AV(sv));
2004
2005 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
2006 /* This occurs with setisa_elem magic, which calls this
2007 same function. */
2008 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
2009
2010 assert(mg);
2011 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
2012 SV **svp = AvARRAY((AV *)mg->mg_obj);
2013 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
2014 while (items--) {
2015 stash = GvSTASH((GV *)*svp++);
2016 if (stash && HvHasENAME(stash)) mro_isa_changed_in(stash);
2017 }
2018
2019 return 0;
2020 }
2021
2022 stash = GvSTASH(
2023 (const GV *)mg->mg_obj
2024 );
2025
2026 /* The stash may have been detached from the symbol table, so check its
2027 name before doing anything. */
2028 if (stash && HvHasENAME(stash))
2029 mro_isa_changed_in(stash);
2030
2031 return 0;
2032 }
2033
2034 int
Perl_magic_getnkeys(pTHX_ SV * sv,MAGIC * mg)2035 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
2036 {
2037 HV * const hv = MUTABLE_HV(LvTARG(sv));
2038 I32 i = 0;
2039
2040 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
2041 PERL_UNUSED_ARG(mg);
2042
2043 if (hv) {
2044 (void) hv_iterinit(hv);
2045 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
2046 i = HvUSEDKEYS(hv);
2047 else {
2048 while (hv_iternext(hv))
2049 i++;
2050 }
2051 }
2052
2053 sv_setiv(sv, (IV)i);
2054 return 0;
2055 }
2056
2057 int
Perl_magic_setnkeys(pTHX_ SV * sv,MAGIC * mg)2058 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
2059 {
2060 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
2061 PERL_UNUSED_ARG(mg);
2062 if (LvTARG(sv)) {
2063 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
2064 }
2065 return 0;
2066 }
2067
2068 /*
2069 =for apidoc_section $magic
2070 =for apidoc magic_methcall
2071
2072 Invoke a magic method (like FETCH).
2073
2074 C<sv> and C<mg> are the tied thingy and the tie magic.
2075
2076 C<meth> is the name of the method to call.
2077
2078 C<argc> is the number of args (in addition to $self) to pass to the method.
2079
2080 The C<flags> can be:
2081
2082 G_DISCARD invoke method with G_DISCARD flag and don't
2083 return a value
2084 G_UNDEF_FILL fill the stack with argc pointers to
2085 PL_sv_undef
2086
2087 The arguments themselves are any values following the C<flags> argument.
2088
2089 Returns the SV (if any) returned by the method, or C<NULL> on failure.
2090
2091
2092 =cut
2093 */
2094
2095 SV*
Perl_magic_methcall(pTHX_ SV * sv,const MAGIC * mg,SV * meth,U32 flags,U32 argc,...)2096 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
2097 U32 argc, ...)
2098 {
2099 dSP;
2100 SV* ret = NULL;
2101
2102 PERL_ARGS_ASSERT_MAGIC_METHCALL;
2103
2104 ENTER;
2105
2106 if (flags & G_WRITING_TO_STDERR) {
2107 SAVETMPS;
2108
2109 save_re_context();
2110 SAVESPTR(PL_stderrgv);
2111 PL_stderrgv = NULL;
2112 }
2113
2114 PUSHSTACKi(PERLSI_MAGIC);
2115 PUSHMARK(SP);
2116
2117 /* EXTEND() expects a signed argc; don't wrap when casting */
2118 assert(argc <= I32_MAX);
2119 EXTEND(SP, (I32)argc+1);
2120 PUSHs(SvTIED_obj(sv, mg));
2121 if (flags & G_UNDEF_FILL) {
2122 while (argc--) {
2123 PUSHs(&PL_sv_undef);
2124 }
2125 } else if (argc > 0) {
2126 va_list args;
2127 va_start(args, argc);
2128
2129 do {
2130 SV *const this_sv = va_arg(args, SV *);
2131 PUSHs(this_sv);
2132 } while (--argc);
2133
2134 va_end(args);
2135 }
2136 PUTBACK;
2137 if (flags & G_DISCARD) {
2138 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
2139 }
2140 else {
2141 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
2142 ret = *PL_stack_sp--;
2143 }
2144 POPSTACK;
2145 if (flags & G_WRITING_TO_STDERR)
2146 FREETMPS;
2147 LEAVE;
2148 return ret;
2149 }
2150
2151 /* wrapper for magic_methcall that creates the first arg */
2152
2153 STATIC SV*
S_magic_methcall1(pTHX_ SV * sv,const MAGIC * mg,SV * meth,U32 flags,int n,SV * val)2154 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
2155 int n, SV *val)
2156 {
2157 SV* arg1 = NULL;
2158
2159 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
2160
2161 if (mg->mg_ptr) {
2162 if (mg->mg_len >= 0) {
2163 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
2164 }
2165 else if (mg->mg_len == HEf_SVKEY)
2166 arg1 = MUTABLE_SV(mg->mg_ptr);
2167 }
2168 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
2169 arg1 = newSViv((IV)(mg->mg_len));
2170 sv_2mortal(arg1);
2171 }
2172 if (!arg1) {
2173 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
2174 }
2175 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
2176 }
2177
2178 STATIC int
S_magic_methpack(pTHX_ SV * sv,const MAGIC * mg,SV * meth)2179 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
2180 {
2181 SV* ret;
2182
2183 PERL_ARGS_ASSERT_MAGIC_METHPACK;
2184
2185 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
2186 if (ret)
2187 sv_setsv(sv, ret);
2188 return 0;
2189 }
2190
2191 int
Perl_magic_getpack(pTHX_ SV * sv,MAGIC * mg)2192 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
2193 {
2194 PERL_ARGS_ASSERT_MAGIC_GETPACK;
2195
2196 if (mg->mg_type == PERL_MAGIC_tiedelem)
2197 mg->mg_flags |= MGf_GSKIP;
2198 magic_methpack(sv,mg,SV_CONST(FETCH));
2199 return 0;
2200 }
2201
2202 int
Perl_magic_setpack(pTHX_ SV * sv,MAGIC * mg)2203 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
2204 {
2205 MAGIC *tmg;
2206 SV *val;
2207
2208 PERL_ARGS_ASSERT_MAGIC_SETPACK;
2209
2210 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
2211 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
2212 * public flags indicate its value based on copying from $val. Doing
2213 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
2214 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
2215 * wrong if $val happened to be tainted, as sv hasn't got magic
2216 * enabled, even though taint magic is in the chain. In which case,
2217 * fake up a temporary tainted value (this is easier than temporarily
2218 * re-enabling magic on sv). */
2219
2220 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
2221 && (tmg->mg_len & 1))
2222 {
2223 val = sv_mortalcopy(sv);
2224 SvTAINTED_on(val);
2225 }
2226 else
2227 val = sv;
2228
2229 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
2230 return 0;
2231 }
2232
2233 int
Perl_magic_clearpack(pTHX_ SV * sv,MAGIC * mg)2234 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
2235 {
2236 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2237
2238 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
2239 return magic_methpack(sv,mg,SV_CONST(DELETE));
2240 }
2241
2242
2243 U32
Perl_magic_sizepack(pTHX_ SV * sv,MAGIC * mg)2244 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
2245 {
2246 I32 retval = 0;
2247 SV* retsv;
2248
2249 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2250
2251 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
2252 if (retsv) {
2253 retval = SvIV(retsv)-1;
2254 if (retval < -1)
2255 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
2256 }
2257 return (U32) retval;
2258 }
2259
2260 int
Perl_magic_wipepack(pTHX_ SV * sv,MAGIC * mg)2261 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
2262 {
2263 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2264
2265 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
2266 return 0;
2267 }
2268
2269 int
Perl_magic_nextpack(pTHX_ SV * sv,MAGIC * mg,SV * key)2270 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
2271 {
2272 SV* ret;
2273
2274 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2275
2276 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
2277 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
2278 if (ret)
2279 sv_setsv(key,ret);
2280 return 0;
2281 }
2282
2283 int
Perl_magic_existspack(pTHX_ SV * sv,const MAGIC * mg)2284 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
2285 {
2286 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2287
2288 return magic_methpack(sv,mg,SV_CONST(EXISTS));
2289 }
2290
2291 SV *
Perl_magic_scalarpack(pTHX_ HV * hv,MAGIC * mg)2292 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2293 {
2294 SV *retval;
2295 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2296 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2297
2298 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2299
2300 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2301 SV *key;
2302 if (HvEITER_get(hv))
2303 /* we are in an iteration so the hash cannot be empty */
2304 return &PL_sv_yes;
2305 /* no xhv_eiter so now use FIRSTKEY */
2306 key = sv_newmortal();
2307 magic_nextpack(MUTABLE_SV(hv), mg, key);
2308 HvEITER_set(hv, NULL); /* need to reset iterator */
2309 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2310 }
2311
2312 /* there is a SCALAR method that we can call */
2313 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
2314 if (!retval)
2315 retval = &PL_sv_undef;
2316 return retval;
2317 }
2318
2319 int
Perl_magic_setdbline(pTHX_ SV * sv,MAGIC * mg)2320 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2321 {
2322 SV **svp;
2323
2324 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2325
2326 /* The magic ptr/len for the debugger's hash should always be an SV. */
2327 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2328 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
2329 (IV)mg->mg_len, mg->mg_ptr);
2330 }
2331
2332 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2333 setting/clearing debugger breakpoints is not a hot path. */
2334 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2335 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2336
2337 if (svp && SvIOKp(*svp)) {
2338 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2339 if (o) {
2340 #ifdef PERL_DEBUG_READONLY_OPS
2341 Slab_to_rw(OpSLAB(o));
2342 #endif
2343 /* set or clear breakpoint in the relevant control op */
2344 if (SvTRUE(sv))
2345 o->op_flags |= OPf_SPECIAL;
2346 else
2347 o->op_flags &= ~OPf_SPECIAL;
2348 #ifdef PERL_DEBUG_READONLY_OPS
2349 Slab_to_ro(OpSLAB(o));
2350 #endif
2351 }
2352 }
2353 return 0;
2354 }
2355
2356 int
Perl_magic_getarylen(pTHX_ SV * sv,const MAGIC * mg)2357 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2358 {
2359 AV * const obj = MUTABLE_AV(mg->mg_obj);
2360
2361 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2362
2363 if (obj) {
2364 sv_setiv(sv, AvFILL(obj));
2365 } else {
2366 sv_set_undef(sv);
2367 }
2368 return 0;
2369 }
2370
2371 int
Perl_magic_setarylen(pTHX_ SV * sv,MAGIC * mg)2372 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2373 {
2374 AV * const obj = MUTABLE_AV(mg->mg_obj);
2375
2376 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2377
2378 if (obj) {
2379 av_fill(obj, SvIV(sv));
2380 } else {
2381 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2382 "Attempt to set length of freed array");
2383 }
2384 return 0;
2385 }
2386
2387 int
Perl_magic_cleararylen_p(pTHX_ SV * sv,MAGIC * mg)2388 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2389 {
2390 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2391 PERL_UNUSED_ARG(sv);
2392 PERL_UNUSED_CONTEXT;
2393
2394 /* Reset the iterator when the array is cleared */
2395 if (sizeof(IV) == sizeof(SSize_t)) {
2396 *((IV *) &(mg->mg_len)) = 0;
2397 } else {
2398 if (mg->mg_ptr)
2399 *((IV *) mg->mg_ptr) = 0;
2400 }
2401
2402 return 0;
2403 }
2404
2405 int
Perl_magic_freearylen_p(pTHX_ SV * sv,MAGIC * mg)2406 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2407 {
2408 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2409 PERL_UNUSED_ARG(sv);
2410
2411 /* during global destruction, mg_obj may already have been freed */
2412 if (PL_in_clean_all)
2413 return 0;
2414
2415 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2416
2417 if (mg) {
2418 /* arylen scalar holds a pointer back to the array, but doesn't own a
2419 reference. Hence the we (the array) are about to go away with it
2420 still pointing at us. Clear its pointer, else it would be pointing
2421 at free memory. See the comment in sv_magic about reference loops,
2422 and why it can't own a reference to us. */
2423 mg->mg_obj = 0;
2424 }
2425 return 0;
2426 }
2427
2428 int
Perl_magic_getpos(pTHX_ SV * sv,MAGIC * mg)2429 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2430 {
2431 SV* const lsv = LvTARG(sv);
2432 MAGIC * const found = mg_find_mglob(lsv);
2433
2434 PERL_ARGS_ASSERT_MAGIC_GETPOS;
2435 PERL_UNUSED_ARG(mg);
2436
2437 if (found && found->mg_len != -1) {
2438 STRLEN i = found->mg_len;
2439 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2440 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2441 sv_setuv(sv, i);
2442 return 0;
2443 }
2444 sv_set_undef(sv);
2445 return 0;
2446 }
2447
2448 int
Perl_magic_setpos(pTHX_ SV * sv,MAGIC * mg)2449 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2450 {
2451 SV* const lsv = LvTARG(sv);
2452 SSize_t pos;
2453 STRLEN len;
2454 MAGIC* found;
2455 const char *s;
2456
2457 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2458 PERL_UNUSED_ARG(mg);
2459
2460 found = mg_find_mglob(lsv);
2461 if (!found) {
2462 if (!SvOK(sv))
2463 return 0;
2464 found = sv_magicext_mglob(lsv);
2465 }
2466 else if (!SvOK(sv)) {
2467 found->mg_len = -1;
2468 return 0;
2469 }
2470 s = SvPV_const(lsv, len);
2471
2472 pos = SvIV(sv);
2473
2474 if (DO_UTF8(lsv)) {
2475 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2476 if (ulen)
2477 len = ulen;
2478 }
2479
2480 if (pos < 0) {
2481 pos += len;
2482 if (pos < 0)
2483 pos = 0;
2484 }
2485 else if (pos > (SSize_t)len)
2486 pos = len;
2487
2488 found->mg_len = pos;
2489 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2490
2491 return 0;
2492 }
2493
2494 int
Perl_magic_getsubstr(pTHX_ SV * sv,MAGIC * mg)2495 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2496 {
2497 STRLEN len;
2498 SV * const lsv = LvTARG(sv);
2499 const char * const tmps = SvPV_const(lsv,len);
2500 STRLEN offs = LvTARGOFF(sv);
2501 STRLEN rem = LvTARGLEN(sv);
2502 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2503 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
2504
2505 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2506 PERL_UNUSED_ARG(mg);
2507
2508 if (!translate_substr_offsets(
2509 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2510 negoff ? -(IV)offs : (IV)offs, !negoff,
2511 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2512 )) {
2513 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2514 sv_set_undef(sv);
2515 return 0;
2516 }
2517
2518 if (SvUTF8(lsv))
2519 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2520 sv_setpvn(sv, tmps + offs, rem);
2521 if (SvUTF8(lsv))
2522 SvUTF8_on(sv);
2523 return 0;
2524 }
2525
2526 int
Perl_magic_setsubstr(pTHX_ SV * sv,MAGIC * mg)2527 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2528 {
2529 STRLEN len, lsv_len, oldtarglen, newtarglen;
2530 const char * const tmps = SvPV_const(sv, len);
2531 SV * const lsv = LvTARG(sv);
2532 STRLEN lvoff = LvTARGOFF(sv);
2533 STRLEN lvlen = LvTARGLEN(sv);
2534 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2535 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
2536
2537 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2538 PERL_UNUSED_ARG(mg);
2539
2540 SvGETMAGIC(lsv);
2541 if (SvROK(lsv))
2542 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2543 "Attempt to use reference as lvalue in substr"
2544 );
2545 SvPV_force_nomg(lsv,lsv_len);
2546 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2547 if (!translate_substr_offsets(
2548 lsv_len,
2549 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2550 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2551 ))
2552 Perl_croak(aTHX_ "substr outside of string");
2553 oldtarglen = lvlen;
2554 if (DO_UTF8(sv)) {
2555 sv_utf8_upgrade_nomg(lsv);
2556 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2557 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2558 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2559 SvUTF8_on(lsv);
2560 }
2561 else if (SvUTF8(lsv)) {
2562 const char *utf8;
2563 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2564 newtarglen = len;
2565 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2566 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2567 Safefree(utf8);
2568 }
2569 else {
2570 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2571 newtarglen = len;
2572 }
2573 if (!neglen) LvTARGLEN(sv) = newtarglen;
2574 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2575
2576 return 0;
2577 }
2578
2579 int
Perl_magic_gettaint(pTHX_ SV * sv,MAGIC * mg)2580 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2581 {
2582 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2583 PERL_UNUSED_ARG(sv);
2584 #ifdef NO_TAINT_SUPPORT
2585 PERL_UNUSED_ARG(mg);
2586 #endif
2587
2588 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2589 return 0;
2590 }
2591
2592 int
Perl_magic_settaint(pTHX_ SV * sv,MAGIC * mg)2593 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2594 {
2595 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2596 PERL_UNUSED_ARG(sv);
2597
2598 /* update taint status */
2599 if (TAINT_get)
2600 mg->mg_len |= 1;
2601 else
2602 mg->mg_len &= ~1;
2603 return 0;
2604 }
2605
2606 int
Perl_magic_getvec(pTHX_ SV * sv,MAGIC * mg)2607 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2608 {
2609 SV * const lsv = LvTARG(sv);
2610 char errflags = LvFLAGS(sv);
2611
2612 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2613 PERL_UNUSED_ARG(mg);
2614
2615 /* non-zero errflags implies deferred out-of-range condition */
2616 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
2617 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2618
2619 return 0;
2620 }
2621
2622 int
Perl_magic_setvec(pTHX_ SV * sv,MAGIC * mg)2623 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2624 {
2625 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2626 PERL_UNUSED_ARG(mg);
2627 do_vecset(sv); /* XXX slurp this routine */
2628 return 0;
2629 }
2630
2631 SV *
Perl_defelem_target(pTHX_ SV * sv,MAGIC * mg)2632 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2633 {
2634 SV *targ = NULL;
2635 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2636 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2637 assert(mg);
2638 if (LvTARGLEN(sv)) {
2639 if (mg->mg_obj) {
2640 SV * const ahv = LvTARG(sv);
2641 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2642 if (he)
2643 targ = HeVAL(he);
2644 }
2645 else if (LvSTARGOFF(sv) >= 0) {
2646 AV *const av = MUTABLE_AV(LvTARG(sv));
2647 if (LvSTARGOFF(sv) <= AvFILL(av))
2648 {
2649 if (SvRMAGICAL(av)) {
2650 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2651 targ = svp ? *svp : NULL;
2652 }
2653 else
2654 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2655 }
2656 }
2657 if (targ && (targ != &PL_sv_undef)) {
2658 /* somebody else defined it for us */
2659 SvREFCNT_dec(LvTARG(sv));
2660 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2661 LvTARGLEN(sv) = 0;
2662 SvREFCNT_dec(mg->mg_obj);
2663 mg->mg_obj = NULL;
2664 mg->mg_flags &= ~MGf_REFCOUNTED;
2665 }
2666 return targ;
2667 }
2668 else
2669 return LvTARG(sv);
2670 }
2671
2672 int
Perl_magic_getdefelem(pTHX_ SV * sv,MAGIC * mg)2673 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2674 {
2675 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2676
2677 sv_setsv(sv, defelem_target(sv, mg));
2678 return 0;
2679 }
2680
2681 int
Perl_magic_setdefelem(pTHX_ SV * sv,MAGIC * mg)2682 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2683 {
2684 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2685 PERL_UNUSED_ARG(mg);
2686 if (LvTARGLEN(sv))
2687 vivify_defelem(sv);
2688 if (LvTARG(sv)) {
2689 sv_setsv(LvTARG(sv), sv);
2690 SvSETMAGIC(LvTARG(sv));
2691 }
2692 return 0;
2693 }
2694
2695 void
Perl_vivify_defelem(pTHX_ SV * sv)2696 Perl_vivify_defelem(pTHX_ SV *sv)
2697 {
2698 MAGIC *mg;
2699 SV *value = NULL;
2700
2701 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2702
2703 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2704 return;
2705 if (mg->mg_obj) {
2706 SV * const ahv = LvTARG(sv);
2707 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2708 if (he)
2709 value = HeVAL(he);
2710 if (!value || value == &PL_sv_undef)
2711 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2712 }
2713 else if (LvSTARGOFF(sv) < 0)
2714 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2715 else {
2716 AV *const av = MUTABLE_AV(LvTARG(sv));
2717 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2718 LvTARG(sv) = NULL; /* array can't be extended */
2719 else {
2720 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2721 if (!svp || !(value = *svp))
2722 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2723 }
2724 }
2725 SvREFCNT_inc_simple_void(value);
2726 SvREFCNT_dec(LvTARG(sv));
2727 LvTARG(sv) = value;
2728 LvTARGLEN(sv) = 0;
2729 SvREFCNT_dec(mg->mg_obj);
2730 mg->mg_obj = NULL;
2731 mg->mg_flags &= ~MGf_REFCOUNTED;
2732 }
2733
2734 int
Perl_magic_setnonelem(pTHX_ SV * sv,MAGIC * mg)2735 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
2736 {
2737 PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
2738 PERL_UNUSED_ARG(mg);
2739 sv_unmagic(sv, PERL_MAGIC_nonelem);
2740 return 0;
2741 }
2742
2743 int
Perl_magic_killbackrefs(pTHX_ SV * sv,MAGIC * mg)2744 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2745 {
2746 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2747 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2748 return 0;
2749 }
2750
2751 int
Perl_magic_setmglob(pTHX_ SV * sv,MAGIC * mg)2752 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2753 {
2754 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2755 PERL_UNUSED_CONTEXT;
2756 PERL_UNUSED_ARG(sv);
2757 mg->mg_len = -1;
2758 return 0;
2759 }
2760
2761
2762 int
Perl_magic_freemglob(pTHX_ SV * sv,MAGIC * mg)2763 Perl_magic_freemglob(pTHX_ SV *sv, MAGIC *mg)
2764 {
2765 PERL_ARGS_ASSERT_MAGIC_FREEMGLOB;
2766 PERL_UNUSED_ARG(sv);
2767
2768 /* pos() magic uses mg_len as a string position rather than a buffer
2769 * length, and mg_ptr is currently unused, so skip freeing.
2770 */
2771 assert(mg->mg_type == PERL_MAGIC_regex_global && mg->mg_len >= -1);
2772 mg->mg_ptr = NULL;
2773 return 0;
2774 }
2775
2776
2777 int
Perl_magic_setuvar(pTHX_ SV * sv,MAGIC * mg)2778 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2779 {
2780 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2781
2782 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2783
2784 if (uf && uf->uf_set)
2785 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2786 return 0;
2787 }
2788
2789 int
Perl_magic_setregexp(pTHX_ SV * sv,MAGIC * mg)2790 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2791 {
2792 const char type = mg->mg_type;
2793
2794 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2795
2796 assert( type == PERL_MAGIC_fm
2797 || type == PERL_MAGIC_qr
2798 || type == PERL_MAGIC_bm);
2799 return sv_unmagic(sv, type);
2800 }
2801
2802 #ifdef USE_LOCALE_COLLATE
2803 int
Perl_magic_setcollxfrm(pTHX_ SV * sv,MAGIC * mg)2804 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2805 {
2806 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2807
2808 /*
2809 * RenE<eacute> Descartes said "I think not."
2810 * and vanished with a faint plop.
2811 */
2812 PERL_UNUSED_CONTEXT;
2813 PERL_UNUSED_ARG(sv);
2814 if (mg->mg_ptr) {
2815 Safefree(mg->mg_ptr);
2816 mg->mg_ptr = NULL;
2817 mg->mg_len = -1;
2818 }
2819 return 0;
2820 }
2821
2822 int
Perl_magic_freecollxfrm(pTHX_ SV * sv,MAGIC * mg)2823 Perl_magic_freecollxfrm(pTHX_ SV *sv, MAGIC *mg)
2824 {
2825 PERL_ARGS_ASSERT_MAGIC_FREECOLLXFRM;
2826 PERL_UNUSED_ARG(sv);
2827
2828 /* Collate magic uses mg_len as a string length rather than a buffer
2829 * length, so we need to free even with mg_len == 0: hence we can't
2830 * rely on standard magic free handling */
2831 if (mg->mg_len >= 0) {
2832 assert(mg->mg_type == PERL_MAGIC_collxfrm);
2833 Safefree(mg->mg_ptr);
2834 mg->mg_ptr = NULL;
2835 }
2836
2837 return 0;
2838 }
2839 #endif /* USE_LOCALE_COLLATE */
2840
2841 /* Just clear the UTF-8 cache data. */
2842 int
Perl_magic_setutf8(pTHX_ SV * sv,MAGIC * mg)2843 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2844 {
2845 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2846 PERL_UNUSED_CONTEXT;
2847 PERL_UNUSED_ARG(sv);
2848 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2849 mg->mg_ptr = NULL;
2850 mg->mg_len = -1; /* The mg_len holds the len cache. */
2851 return 0;
2852 }
2853
2854 int
Perl_magic_freeutf8(pTHX_ SV * sv,MAGIC * mg)2855 Perl_magic_freeutf8(pTHX_ SV *sv, MAGIC *mg)
2856 {
2857 PERL_ARGS_ASSERT_MAGIC_FREEUTF8;
2858 PERL_UNUSED_ARG(sv);
2859
2860 /* utf8 magic uses mg_len as a string length rather than a buffer
2861 * length, so we need to free even with mg_len == 0: hence we can't
2862 * rely on standard magic free handling */
2863 assert(mg->mg_type == PERL_MAGIC_utf8 && mg->mg_len >= -1);
2864 Safefree(mg->mg_ptr);
2865 mg->mg_ptr = NULL;
2866 return 0;
2867 }
2868
2869
2870 int
Perl_magic_setlvref(pTHX_ SV * sv,MAGIC * mg)2871 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2872 {
2873 const char *bad = NULL;
2874 PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2875 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2876 switch (mg->mg_private & OPpLVREF_TYPE) {
2877 case OPpLVREF_SV:
2878 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2879 bad = " SCALAR";
2880 break;
2881 case OPpLVREF_AV:
2882 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2883 bad = "n ARRAY";
2884 break;
2885 case OPpLVREF_HV:
2886 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2887 bad = " HASH";
2888 break;
2889 case OPpLVREF_CV:
2890 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2891 bad = " CODE";
2892 }
2893 if (bad)
2894 /* diag_listed_as: Assigned value is not %s reference */
2895 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2896 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2897 case 0:
2898 {
2899 SV * const old = PAD_SV(mg->mg_len);
2900 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2901 SvREFCNT_dec(old);
2902 break;
2903 }
2904 case SVt_PVGV:
2905 gv_setref(mg->mg_obj, sv);
2906 SvSETMAGIC(mg->mg_obj);
2907 break;
2908 case SVt_PVAV:
2909 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2910 SvREFCNT_inc_simple_NN(SvRV(sv)));
2911 break;
2912 case SVt_PVHV:
2913 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2914 SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2915 }
2916 if (mg->mg_flags & MGf_PERSIST)
2917 NOOP; /* This sv is in use as an iterator var and will be reused,
2918 so we must leave the magic. */
2919 else
2920 /* This sv could be returned by the assignment op, so clear the
2921 magic, as lvrefs are an implementation detail that must not be
2922 leaked to the user. */
2923 sv_unmagic(sv, PERL_MAGIC_lvref);
2924 return 0;
2925 }
2926
2927 static void
S_set_dollarzero(pTHX_ SV * sv)2928 S_set_dollarzero(pTHX_ SV *sv)
2929 PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2930 {
2931 const char *s;
2932 STRLEN len;
2933 #ifdef HAS_SETPROCTITLE
2934 /* The BSDs don't show the argv[] in ps(1) output, they
2935 * show a string from the process struct and provide
2936 * the setproctitle() routine to manipulate that. */
2937 if (PL_origalen != 1) {
2938 s = SvPV_const(sv, len);
2939 # if __FreeBSD_version > 410001 || defined(__DragonFly__)
2940 /* The leading "-" removes the "perl: " prefix,
2941 * but not the "(perl) suffix from the ps(1)
2942 * output, because that's what ps(1) shows if the
2943 * argv[] is modified. */
2944 setproctitle("-%s", s);
2945 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2946 /* This doesn't really work if you assume that
2947 * $0 = 'foobar'; will wipe out 'perl' from the $0
2948 * because in ps(1) output the result will be like
2949 * sprintf("perl: %s (perl)", s)
2950 * I guess this is a security feature:
2951 * one (a user process) cannot get rid of the original name.
2952 * --jhi */
2953 setproctitle("%s", s);
2954 # endif
2955 }
2956 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2957 if (PL_origalen != 1) {
2958 union pstun un;
2959 s = SvPV_const(sv, len);
2960 un.pst_command = (char *)s;
2961 pstat(PSTAT_SETCMD, un, len, 0, 0);
2962 }
2963 #else
2964 if (PL_origalen > 1) {
2965 I32 i;
2966 /* PL_origalen is set in perl_parse(). */
2967 s = SvPV_force(sv,len);
2968 if (len >= (STRLEN)PL_origalen-1) {
2969 /* Longer than original, will be truncated. We assume that
2970 * PL_origalen bytes are available. */
2971 Copy(s, PL_origargv[0], PL_origalen-1, char);
2972 }
2973 else {
2974 /* Shorter than original, will be padded. */
2975 #ifdef PERL_DARWIN
2976 /* Special case for Mac OS X: see [perl #38868] */
2977 const int pad = 0;
2978 #else
2979 /* Is the space counterintuitive? Yes.
2980 * (You were expecting \0?)
2981 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2982 * --jhi */
2983 const int pad = ' ';
2984 #endif
2985 Copy(s, PL_origargv[0], len, char);
2986 PL_origargv[0][len] = 0;
2987 memset(PL_origargv[0] + len + 1,
2988 pad, PL_origalen - len - 1);
2989 }
2990 PL_origargv[0][PL_origalen-1] = 0;
2991 for (i = 1; i < PL_origargc; i++)
2992 PL_origargv[i] = 0;
2993 #ifdef HAS_PRCTL_SET_NAME
2994 /* Set the legacy process name in addition to the POSIX name on Linux */
2995 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2996 /* diag_listed_as: SKIPME */
2997 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2998 }
2999 #endif
3000 }
3001 #endif
3002 }
3003
3004 int
Perl_magic_set(pTHX_ SV * sv,MAGIC * mg)3005 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
3006 {
3007 I32 paren;
3008 const REGEXP * rx;
3009 I32 i;
3010 STRLEN len;
3011 MAGIC *tmg;
3012
3013 PERL_ARGS_ASSERT_MAGIC_SET;
3014
3015 if (!mg->mg_ptr) {
3016 paren = mg->mg_len;
3017 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
3018 setparen_got_rx:
3019 CALLREG_NUMBUF_STORE((REGEXP *)rx,paren,sv);
3020 } else {
3021 /* Croak with a READONLY error when a numbered match var is
3022 * set without a previous pattern match. Unless it's C<local $1>
3023 */
3024 croakparen:
3025 if (!PL_localizing) {
3026 Perl_croak_no_modify();
3027 }
3028 }
3029 return 0;
3030 }
3031
3032 switch (*mg->mg_ptr) {
3033 case '\001': /* ^A */
3034 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
3035 else SvOK_off(PL_bodytarget);
3036 FmLINES(PL_bodytarget) = 0;
3037 if (SvPOK(PL_bodytarget)) {
3038 char *s = SvPVX(PL_bodytarget);
3039 char *e = SvEND(PL_bodytarget);
3040 while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
3041 FmLINES(PL_bodytarget)++;
3042 s++;
3043 }
3044 }
3045 /* mg_set() has temporarily made sv non-magical */
3046 if (TAINTING_get) {
3047 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
3048 SvTAINTED_on(PL_bodytarget);
3049 else
3050 SvTAINTED_off(PL_bodytarget);
3051 }
3052 break;
3053 case '\003': /* ^C */
3054 PL_minus_c = cBOOL(SvIV(sv));
3055 break;
3056
3057 case '\004': /* ^D */
3058 #ifdef DEBUGGING
3059 {
3060 const char *s = SvPV_nolen_const(sv);
3061 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
3062 if (DEBUG_x_TEST || DEBUG_B_TEST)
3063 dump_all_perl(!DEBUG_B_TEST);
3064 }
3065 #else
3066 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
3067 #endif
3068 break;
3069 case '\005': /* ^E */
3070 if (*(mg->mg_ptr+1) == '\0') {
3071 #ifdef VMS
3072 set_vaxc_errno(SvIV(sv));
3073 #elif defined(WIN32)
3074 SetLastError( SvIV(sv) );
3075 #elif defined(OS2)
3076 os2_setsyserrno(SvIV(sv));
3077 #else
3078 /* will anyone ever use this? */
3079 SETERRNO(SvIV(sv), 4);
3080 #endif
3081 }
3082 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
3083 Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
3084 break;
3085 case '\006': /* ^F */
3086 if (mg->mg_ptr[1] == '\0') {
3087 PL_maxsysfd = SvIV(sv);
3088 }
3089 break;
3090 case '\010': /* ^H */
3091 {
3092 U32 save_hints = PL_hints;
3093 PL_hints = SvUV(sv);
3094
3095 /* If wasn't UTF-8, and now is, notify the parser */
3096 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
3097 notify_parser_that_changed_to_utf8();
3098 }
3099 }
3100 break;
3101 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3102 Safefree(PL_inplace);
3103 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
3104 break;
3105 case '\016': /* ^N */
3106 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
3107 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
3108 goto croakparen;
3109 case '\017': /* ^O */
3110 if (*(mg->mg_ptr+1) == '\0') {
3111 Safefree(PL_osname);
3112 PL_osname = NULL;
3113 if (SvOK(sv)) {
3114 TAINT_PROPER("assigning to $^O");
3115 PL_osname = savesvpv(sv);
3116 }
3117 }
3118 else if (strEQ(mg->mg_ptr, "\017PEN")) {
3119 STRLEN len;
3120 const char *const start = SvPV(sv, len);
3121 const char *out = (const char*)memchr(start, '\0', len);
3122 SV *tmp;
3123
3124
3125 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
3126 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
3127
3128 /* Opening for input is more common than opening for output, so
3129 ensure that hints for input are sooner on linked list. */
3130 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
3131 SvUTF8(sv))
3132 : newSVpvs_flags("", SvUTF8(sv));
3133 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
3134 mg_set(tmp);
3135
3136 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
3137 SvUTF8(sv));
3138 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
3139 mg_set(tmp);
3140 }
3141 break;
3142 case '\020': /* ^P */
3143 PL_perldb = SvIV(sv);
3144 if (PL_perldb && !PL_DBsingle)
3145 init_debugger();
3146 break;
3147 case '\024': /* ^T */
3148 #ifdef BIG_TIME
3149 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
3150 #else
3151 PL_basetime = (Time_t)SvIV(sv);
3152 #endif
3153 break;
3154 case '\025': /* ^UTF8CACHE */
3155 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
3156 PL_utf8cache = (signed char) sv_2iv(sv);
3157 }
3158 break;
3159 case '\027': /* ^W & $^WARNING_BITS */
3160 if (*(mg->mg_ptr+1) == '\0') {
3161 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
3162 i = SvIV(sv);
3163 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
3164 | (i ? G_WARN_ON : G_WARN_OFF) ;
3165 }
3166 }
3167 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
3168 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
3169 if (!SvPOK(sv)) {
3170 free_and_set_cop_warnings(&PL_compiling, pWARN_STD);
3171 break;
3172 }
3173 {
3174 STRLEN len, i;
3175 int not_none = 0, not_all = 0;
3176 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
3177 for (i = 0 ; i < len ; ++i) {
3178 not_none |= ptr[i];
3179 not_all |= ptr[i] ^ 0x55;
3180 }
3181 if (!not_none) {
3182 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
3183 } else if (len >= WARNsize && !not_all) {
3184 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
3185 PL_dowarn |= G_WARN_ONCE ;
3186 }
3187 else {
3188 STRLEN len;
3189 const char *const p = SvPV_const(sv, len);
3190
3191 free_and_set_cop_warnings(
3192 &PL_compiling,
3193 Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
3194 p, len)
3195 );
3196
3197 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
3198 PL_dowarn |= G_WARN_ONCE ;
3199 }
3200 }
3201 }
3202 }
3203 break;
3204 case '.':
3205 if (PL_localizing) {
3206 if (PL_localizing == 1)
3207 SAVESPTR(PL_last_in_gv);
3208 }
3209 else if (SvOK(sv) && GvIO(PL_last_in_gv))
3210 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
3211 break;
3212 case '^':
3213 {
3214 IO * const io = GvIO(PL_defoutgv);
3215 if (!io)
3216 break;
3217
3218 Safefree(IoTOP_NAME(io));
3219 IoTOP_NAME(io) = savesvpv(sv);
3220 IoTOP_GV(io) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3221 }
3222 break;
3223 case '~':
3224 {
3225 IO * const io = GvIO(PL_defoutgv);
3226 if (!io)
3227 break;
3228
3229 Safefree(IoFMT_NAME(io));
3230 IoFMT_NAME(io) = savesvpv(sv);
3231 IoFMT_GV(io) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3232 }
3233 break;
3234 case '=':
3235 {
3236 IO * const io = GvIO(PL_defoutgv);
3237 if (!io)
3238 break;
3239
3240 IoPAGE_LEN(io) = (SvIV(sv));
3241 }
3242 break;
3243 case '-':
3244 {
3245 IO * const io = GvIO(PL_defoutgv);
3246 if (!io)
3247 break;
3248
3249 IoLINES_LEFT(io) = (SvIV(sv));
3250 if (IoLINES_LEFT(io) < 0L)
3251 IoLINES_LEFT(io) = 0L;
3252 }
3253 break;
3254 case '%':
3255 {
3256 IO * const io = GvIO(PL_defoutgv);
3257 if (!io)
3258 break;
3259
3260 IoPAGE(io) = (SvIV(sv));
3261 }
3262 break;
3263 case '|':
3264 {
3265 IO * const io = GvIO(PL_defoutgv);
3266 if(!io)
3267 break;
3268 if ((SvIV(sv)) == 0)
3269 IoFLAGS(io) &= ~IOf_FLUSH;
3270 else {
3271 if (!(IoFLAGS(io) & IOf_FLUSH)) {
3272 PerlIO *ofp = IoOFP(io);
3273 if (ofp)
3274 (void)PerlIO_flush(ofp);
3275 IoFLAGS(io) |= IOf_FLUSH;
3276 }
3277 }
3278 }
3279 break;
3280 case '/':
3281 {
3282 if (SvROK(sv)) {
3283 SV *referent = SvRV(sv);
3284 const char *reftype = sv_reftype(referent, 0);
3285 /* XXX: dodgy type check: This leaves me feeling dirty, but
3286 * the alternative is to copy pretty much the entire
3287 * sv_reftype() into this routine, or to do a full string
3288 * comparison on the return of sv_reftype() both of which
3289 * make me feel worse! NOTE, do not modify this comment
3290 * without reviewing the corresponding comment in
3291 * sv_reftype(). - Yves */
3292 if (reftype[0] == 'S' || reftype[0] == 'L') {
3293 IV val = SvIV(referent);
3294 if (val <= 0) {
3295 sv_setsv(sv, PL_rs);
3296 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3297 val < 0 ? "a negative integer" : "zero");
3298 }
3299 } else {
3300 sv_setsv(sv, PL_rs);
3301 /* diag_listed_as: Setting $/ to %s reference is forbidden */
3302 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3303 *reftype == 'A' ? "n" : "", reftype);
3304 }
3305 }
3306 SvREFCNT_dec(PL_rs);
3307 PL_rs = newSVsv(sv);
3308 }
3309 break;
3310 case '\\':
3311 SvREFCNT_dec(PL_ors_sv);
3312 if (SvOK(sv)) {
3313 PL_ors_sv = newSVsv(sv);
3314 }
3315 else {
3316 PL_ors_sv = NULL;
3317 }
3318 break;
3319 case '[':
3320 if (SvIV(sv) != 0)
3321 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3322 break;
3323 case '?':
3324 #ifdef COMPLEX_STATUS
3325 if (PL_localizing == 2) {
3326 SvUPGRADE(sv, SVt_PVLV);
3327 PL_statusvalue = LvTARGOFF(sv);
3328 PL_statusvalue_vms = LvTARGLEN(sv);
3329 }
3330 else
3331 #endif
3332 #ifdef VMSISH_STATUS
3333 if (VMSISH_STATUS)
3334 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3335 else
3336 #endif
3337 STATUS_UNIX_EXIT_SET(SvIV(sv));
3338 break;
3339 case '!':
3340 {
3341 #ifdef VMS
3342 # define PERL_VMS_BANG vaxc$errno
3343 #else
3344 # define PERL_VMS_BANG 0
3345 #endif
3346 #if defined(WIN32)
3347 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3348 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3349 #else
3350 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3351 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3352 #endif
3353 }
3354 break;
3355 case '<':
3356 {
3357 /* XXX $< currently silently ignores failures */
3358 const Uid_t new_uid = SvUID(sv);
3359 PL_delaymagic_uid = new_uid;
3360 if (PL_delaymagic) {
3361 PL_delaymagic |= DM_RUID;
3362 break; /* don't do magic till later */
3363 }
3364 #ifdef HAS_SETRUID
3365 PERL_UNUSED_RESULT(setruid(new_uid));
3366 #elif defined(HAS_SETREUID)
3367 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3368 #elif defined(HAS_SETRESUID)
3369 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3370 #else
3371 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
3372 # ifdef PERL_DARWIN
3373 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3374 if (new_uid != 0 && PerlProc_getuid() == 0)
3375 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3376 # endif
3377 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3378 } else {
3379 Perl_croak(aTHX_ "setruid() not implemented");
3380 }
3381 #endif
3382 break;
3383 }
3384 case '>':
3385 {
3386 /* XXX $> currently silently ignores failures */
3387 const Uid_t new_euid = SvUID(sv);
3388 PL_delaymagic_euid = new_euid;
3389 if (PL_delaymagic) {
3390 PL_delaymagic |= DM_EUID;
3391 break; /* don't do magic till later */
3392 }
3393 #ifdef HAS_SETEUID
3394 PERL_UNUSED_RESULT(seteuid(new_euid));
3395 #elif defined(HAS_SETREUID)
3396 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3397 #elif defined(HAS_SETRESUID)
3398 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3399 #else
3400 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
3401 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3402 else {
3403 Perl_croak(aTHX_ "seteuid() not implemented");
3404 }
3405 #endif
3406 break;
3407 }
3408 case '(':
3409 {
3410 /* XXX $( currently silently ignores failures */
3411 const Gid_t new_gid = SvGID(sv);
3412 PL_delaymagic_gid = new_gid;
3413 if (PL_delaymagic) {
3414 PL_delaymagic |= DM_RGID;
3415 break; /* don't do magic till later */
3416 }
3417 #ifdef HAS_SETRGID
3418 PERL_UNUSED_RESULT(setrgid(new_gid));
3419 #elif defined(HAS_SETREGID)
3420 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3421 #elif defined(HAS_SETRESGID)
3422 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3423 #else
3424 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
3425 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3426 else {
3427 Perl_croak(aTHX_ "setrgid() not implemented");
3428 }
3429 #endif
3430 break;
3431 }
3432 case ')':
3433 {
3434 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3435 * but you can override it if you need to.
3436 */
3437 #ifndef INVALID_GID
3438 #define INVALID_GID ((Gid_t)-1)
3439 #endif
3440 /* XXX $) currently silently ignores failures */
3441 Gid_t new_egid;
3442 #ifdef HAS_SETGROUPS
3443 {
3444 const char *p = SvPV_const(sv, len);
3445 Groups_t *gary = NULL;
3446 const char* p_end = p + len;
3447 const char* endptr = p_end;
3448 UV uv;
3449 #ifdef _SC_NGROUPS_MAX
3450 int maxgrp = sysconf(_SC_NGROUPS_MAX);
3451
3452 if (maxgrp < 0)
3453 maxgrp = NGROUPS;
3454 #else
3455 int maxgrp = NGROUPS;
3456 #endif
3457
3458 while (isSPACE(*p))
3459 ++p;
3460 if (grok_atoUV(p, &uv, &endptr))
3461 new_egid = (Gid_t)uv;
3462 else {
3463 new_egid = INVALID_GID;
3464 endptr = NULL;
3465 }
3466 for (i = 0; i < maxgrp; ++i) {
3467 if (endptr == NULL)
3468 break;
3469 p = endptr;
3470 endptr = p_end;
3471 while (isSPACE(*p))
3472 ++p;
3473 if (!*p)
3474 break;
3475 if (!gary)
3476 Newx(gary, i + 1, Groups_t);
3477 else
3478 Renew(gary, i + 1, Groups_t);
3479 if (grok_atoUV(p, &uv, &endptr))
3480 gary[i] = (Groups_t)uv;
3481 else {
3482 gary[i] = INVALID_GID;
3483 endptr = NULL;
3484 }
3485 }
3486 if (i)
3487 PERL_UNUSED_RESULT(setgroups(i, gary));
3488 Safefree(gary);
3489 }
3490 #else /* HAS_SETGROUPS */
3491 new_egid = SvGID(sv);
3492 #endif /* HAS_SETGROUPS */
3493 PL_delaymagic_egid = new_egid;
3494 if (PL_delaymagic) {
3495 PL_delaymagic |= DM_EGID;
3496 break; /* don't do magic till later */
3497 }
3498 #ifdef HAS_SETEGID
3499 PERL_UNUSED_RESULT(setegid(new_egid));
3500 #elif defined(HAS_SETREGID)
3501 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3502 #elif defined(HAS_SETRESGID)
3503 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3504 #else
3505 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
3506 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3507 else {
3508 Perl_croak(aTHX_ "setegid() not implemented");
3509 }
3510 #endif
3511 break;
3512 }
3513 case ':':
3514 PL_chopset = SvPV_force(sv,len);
3515 break;
3516 case '$': /* $$ */
3517 /* Store the pid in mg->mg_obj so we can tell when a fork has
3518 occurred. mg->mg_obj points to *$ by default, so clear it. */
3519 if (isGV(mg->mg_obj)) {
3520 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3521 SvREFCNT_dec(mg->mg_obj);
3522 mg->mg_flags |= MGf_REFCOUNTED;
3523 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3524 }
3525 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3526 break;
3527 case '0':
3528 if (!sv_utf8_downgrade(sv, /* fail_ok */ TRUE)) {
3529
3530 /* Since we are going to set the string's UTF8-encoded form
3531 as the process name we should update $0 itself to contain
3532 that same (UTF8-encoded) value. */
3533 sv_utf8_encode(GvSV(mg->mg_obj));
3534
3535 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "$0");
3536 }
3537
3538 LOCK_DOLLARZERO_MUTEX;
3539 S_set_dollarzero(aTHX_ sv);
3540 UNLOCK_DOLLARZERO_MUTEX;
3541 break;
3542 }
3543 return 0;
3544 }
3545
3546 /*
3547 =for apidoc_section $signals
3548 =for apidoc whichsig
3549 =for apidoc_item whichsig_pv
3550 =for apidoc_item whichsig_pvn
3551 =for apidoc_item whichsig_sv
3552
3553 These all convert a signal name into its corresponding signal number;
3554 returning -1 if no corresponding number was found.
3555
3556 They differ only in the source of the signal name:
3557
3558 C<whichsig_pv> takes the name from the C<NUL>-terminated string starting at
3559 C<sig>.
3560
3561 C<whichsig> is merely a different spelling, a synonym, of C<whichsig_pv>.
3562
3563 C<whichsig_pvn> takes the name from the string starting at C<sig>, with length
3564 C<len> bytes.
3565
3566 C<whichsig_sv> takes the name from the PV stored in the SV C<sigsv>.
3567
3568 =cut
3569 */
3570
3571 I32
Perl_whichsig_sv(pTHX_ SV * sigsv)3572 Perl_whichsig_sv(pTHX_ SV *sigsv)
3573 {
3574 const char *sigpv;
3575 STRLEN siglen;
3576 PERL_ARGS_ASSERT_WHICHSIG_SV;
3577 sigpv = SvPV_const(sigsv, siglen);
3578 return whichsig_pvn(sigpv, siglen);
3579 }
3580
3581 I32
Perl_whichsig_pv(pTHX_ const char * sig)3582 Perl_whichsig_pv(pTHX_ const char *sig)
3583 {
3584 PERL_ARGS_ASSERT_WHICHSIG_PV;
3585 return whichsig_pvn(sig, strlen(sig));
3586 }
3587
3588 I32
Perl_whichsig_pvn(pTHX_ const char * sig,STRLEN len)3589 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3590 {
3591 char* const* sigv;
3592
3593 PERL_ARGS_ASSERT_WHICHSIG_PVN;
3594 PERL_UNUSED_CONTEXT;
3595
3596 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3597 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3598 return PL_sig_num[sigv - (char* const*)PL_sig_name];
3599 #ifdef SIGCLD
3600 if (memEQs(sig, len, "CHLD"))
3601 return SIGCLD;
3602 #endif
3603 #ifdef SIGCHLD
3604 if (memEQs(sig, len, "CLD"))
3605 return SIGCHLD;
3606 #endif
3607 return -1;
3608 }
3609
3610
3611 /* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3():
3612 * these three function are intended to be called by the OS as 'C' level
3613 * signal handler functions in the case where unsafe signals are being
3614 * used - i.e. they immediately invoke Perl_perly_sighandler() to call the
3615 * perl-level sighandler, rather than deferring.
3616 * In fact, the core itself will normally use Perl_csighandler as the
3617 * OS-level handler; that function will then decide whether to queue the
3618 * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these
3619 * functions are more useful for e.g. POSIX.xs when it wants explicit
3620 * control of what's happening.
3621 */
3622
3623
3624 #ifdef PERL_USE_3ARG_SIGHANDLER
3625
3626 Signal_t
Perl_sighandler(int sig,Siginfo_t * sip,void * uap)3627 Perl_sighandler(int sig, Siginfo_t *sip, void *uap)
3628 {
3629 Perl_perly_sighandler(sig, sip, uap, 0);
3630 }
3631
3632 #else
3633
3634 Signal_t
Perl_sighandler(int sig)3635 Perl_sighandler(int sig)
3636 {
3637 Perl_perly_sighandler(sig, NULL, NULL, 0);
3638 }
3639
3640 #endif
3641
3642 Signal_t
Perl_sighandler1(int sig)3643 Perl_sighandler1(int sig)
3644 {
3645 Perl_perly_sighandler(sig, NULL, NULL, 0);
3646 }
3647
3648 Signal_t
Perl_sighandler3(int sig,Siginfo_t * sip PERL_UNUSED_DECL,void * uap PERL_UNUSED_DECL)3649 Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
3650 {
3651 Perl_perly_sighandler(sig, sip, uap, 0);
3652 }
3653
3654
3655 /* Invoke the perl-level signal handler. This function is called either
3656 * directly from one of the C-level signals handlers (Perl_sighandler or
3657 * Perl_csighandler), or for safe signals, later from
3658 * Perl_despatch_signals() at a suitable safe point during execution.
3659 *
3660 * 'safe' is a boolean indicating the latter call path.
3661 */
3662
3663 Signal_t
Perl_perly_sighandler(int sig,Siginfo_t * sip PERL_UNUSED_DECL,void * uap PERL_UNUSED_DECL,bool safe)3664 Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL,
3665 void *uap PERL_UNUSED_DECL, bool safe)
3666 {
3667 #ifdef PERL_GET_SIG_CONTEXT
3668 dTHXa(PERL_GET_SIG_CONTEXT);
3669 #else
3670 dTHX;
3671 #endif
3672 dSP;
3673 GV *gv = NULL;
3674 SV *sv = NULL;
3675 SV * const tSv = PL_Sv;
3676 CV *cv = NULL;
3677 OP *myop = PL_op;
3678 U32 flags = 0;
3679 XPV * const tXpv = PL_Xpv;
3680 I32 old_ss_ix = PL_savestack_ix;
3681 SV *errsv_save = NULL;
3682
3683
3684 if (!PL_psig_ptr[sig]) {
3685 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3686 PL_sig_name[sig]);
3687 exit(sig);
3688 }
3689
3690 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3691 /* Max number of items pushed there is 3*n or 4. We cannot fix
3692 infinity, so we fix 4 (in fact 5): */
3693 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3694 flags |= 1;
3695 PL_savestack_ix += 5; /* Protect save in progress. */
3696 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3697 }
3698 }
3699 /* sv_2cv is too complicated, try a simpler variant first: */
3700 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3701 || SvTYPE(cv) != SVt_PVCV) {
3702 HV *st;
3703 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3704 }
3705
3706 if (!cv || !CvROOT(cv)) {
3707 const HEK * const hek = gv
3708 ? GvENAME_HEK(gv)
3709 : cv && CvNAMED(cv)
3710 ? CvNAME_HEK(cv)
3711 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3712 if (hek)
3713 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3714 "SIG%s handler \"%" HEKf "\" not defined.\n",
3715 PL_sig_name[sig], HEKfARG(hek));
3716 /* diag_listed_as: SIG%s handler "%s" not defined */
3717 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3718 "SIG%s handler \"__ANON__\" not defined.\n",
3719 PL_sig_name[sig]);
3720 goto cleanup;
3721 }
3722
3723 sv = PL_psig_name[sig]
3724 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3725 : newSVpv(PL_sig_name[sig],0);
3726 flags |= 8;
3727 SAVEFREESV(sv);
3728
3729 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3730 /* make sure our assumption about the size of the SAVEs are correct:
3731 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3732 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3733 }
3734
3735 PUSHSTACKi(PERLSI_SIGNAL);
3736 PUSHMARK(SP);
3737 PUSHs(sv);
3738
3739 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3740 {
3741 struct sigaction oact;
3742
3743 if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3744 HV *sih = newHV();
3745 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3746 /* The siginfo fields signo, code, errno, pid, uid,
3747 * addr, status, and band are defined by POSIX/SUSv3. */
3748 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3749 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3750 # ifdef HAS_SIGINFO_SI_ERRNO
3751 (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
3752 # endif
3753 # ifdef HAS_SIGINFO_SI_STATUS
3754 (void)hv_stores(sih, "status", newSViv(sip->si_status));
3755 # endif
3756 # ifdef HAS_SIGINFO_SI_UID
3757 {
3758 SV *uid = newSV(0);
3759 sv_setuid(uid, sip->si_uid);
3760 (void)hv_stores(sih, "uid", uid);
3761 }
3762 # endif
3763 # ifdef HAS_SIGINFO_SI_PID
3764 (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
3765 # endif
3766 # ifdef HAS_SIGINFO_SI_ADDR
3767 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3768 # endif
3769 # ifdef HAS_SIGINFO_SI_BAND
3770 (void)hv_stores(sih, "band", newSViv(sip->si_band));
3771 # endif
3772 EXTEND(SP, 2);
3773 PUSHs(rv);
3774 mPUSHp((char *)sip, sizeof(*sip));
3775
3776 }
3777 }
3778 #endif
3779
3780 PUTBACK;
3781
3782 errsv_save = newSVsv(ERRSV);
3783
3784 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3785
3786 POPSTACK;
3787 {
3788 SV * const errsv = ERRSV;
3789 if (SvTRUE_NN(errsv)) {
3790 SvREFCNT_dec(errsv_save);
3791
3792 #ifndef PERL_MICRO
3793 /* Handler "died", for example to get out of a restart-able read().
3794 * Before we re-do that on its behalf re-enable the signal which was
3795 * blocked by the system when we entered.
3796 */
3797 # ifdef HAS_SIGPROCMASK
3798 if (!safe) {
3799 /* safe signals called via dispatch_signals() set up a
3800 * savestack destructor, unblock_sigmask(), to
3801 * automatically unblock the handler at the end. If
3802 * instead we get here directly, we have to do it
3803 * ourselves
3804 */
3805 sigset_t set;
3806 sigemptyset(&set);
3807 sigaddset(&set,sig);
3808 sigprocmask(SIG_UNBLOCK, &set, NULL);
3809 }
3810 # else
3811 /* Not clear if this will work */
3812 /* XXX not clear if this should be protected by 'if (safe)'
3813 * too */
3814
3815 (void)rsignal(sig, SIG_IGN);
3816 (void)rsignal(sig, PL_csighandlerp);
3817 # endif
3818 #endif /* !PERL_MICRO */
3819
3820 die_sv(errsv);
3821 }
3822 else {
3823 sv_setsv(errsv, errsv_save);
3824 SvREFCNT_dec(errsv_save);
3825 }
3826 }
3827
3828 cleanup:
3829 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3830 PL_savestack_ix = old_ss_ix;
3831 if (flags & 8)
3832 SvREFCNT_dec_NN(sv);
3833 PL_op = myop; /* Apparently not needed... */
3834
3835 PL_Sv = tSv; /* Restore global temporaries. */
3836 PL_Xpv = tXpv;
3837 return;
3838 }
3839
3840
3841 static void
S_restore_magic(pTHX_ const void * p)3842 S_restore_magic(pTHX_ const void *p)
3843 {
3844 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3845 SV* const sv = mgs->mgs_sv;
3846 bool bumped;
3847
3848 if (!sv)
3849 return;
3850
3851 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3852 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3853 if (mgs->mgs_flags)
3854 SvFLAGS(sv) |= mgs->mgs_flags;
3855 else
3856 mg_magical(sv);
3857 }
3858
3859 bumped = mgs->mgs_bumped;
3860 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3861
3862 /* If we're still on top of the stack, pop us off. (That condition
3863 * will be satisfied if restore_magic was called explicitly, but *not*
3864 * if it's being called via leave_scope.)
3865 * The reason for doing this is that otherwise, things like sv_2cv()
3866 * may leave alloc gunk on the savestack, and some code
3867 * (e.g. sighandler) doesn't expect that...
3868 */
3869 if (PL_savestack_ix == mgs->mgs_ss_ix)
3870 {
3871 UV popval = SSPOPUV;
3872 assert(popval == SAVEt_DESTRUCTOR_X);
3873 PL_savestack_ix -= 2;
3874 popval = SSPOPUV;
3875 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3876 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3877 }
3878 if (bumped) {
3879 if (SvREFCNT(sv) == 1) {
3880 /* We hold the last reference to this SV, which implies that the
3881 SV was deleted as a side effect of the routines we called.
3882 So artificially keep it alive a bit longer.
3883 We avoid turning on the TEMP flag, which can cause the SV's
3884 buffer to get stolen (and maybe other stuff). */
3885 sv_2mortal(sv);
3886 SvTEMP_off(sv);
3887 }
3888 else
3889 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3890 }
3891 }
3892
3893 /* clean up the mess created by Perl_sighandler().
3894 * Note that this is only called during an exit in a signal handler;
3895 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3896 * skipped over. */
3897
3898 static void
S_unwind_handler_stack(pTHX_ const void * p)3899 S_unwind_handler_stack(pTHX_ const void *p)
3900 {
3901 PERL_UNUSED_ARG(p);
3902
3903 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3904 }
3905
3906 /*
3907 =for apidoc_section $magic
3908 =for apidoc magic_sethint
3909
3910 Triggered by a store to C<%^H>, records the key/value pair to
3911 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3912 anything that would need a deep copy. Maybe we should warn if we find a
3913 reference.
3914
3915 =cut
3916 */
3917 int
Perl_magic_sethint(pTHX_ SV * sv,MAGIC * mg)3918 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3919 {
3920 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3921 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3922
3923 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3924
3925 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3926 an alternative leaf in there, with PL_compiling.cop_hints being used if
3927 it's NULL. If needed for threads, the alternative could lock a mutex,
3928 or take other more complex action. */
3929
3930 /* Something changed in %^H, so it will need to be restored on scope exit.
3931 Doing this here saves a lot of doing it manually in perl code (and
3932 forgetting to do it, and consequent subtle errors. */
3933 PL_hints |= HINT_LOCALIZE_HH;
3934 CopHINTHASH_set(&PL_compiling,
3935 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3936 magic_sethint_feature(key, NULL, 0, sv, 0);
3937 return 0;
3938 }
3939
3940 /*
3941 =for apidoc magic_clearhint
3942
3943 Triggered by a delete from C<%^H>, records the key to
3944 C<PL_compiling.cop_hints_hash>.
3945
3946 =cut
3947 */
3948 int
Perl_magic_clearhint(pTHX_ SV * sv,MAGIC * mg)3949 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3950 {
3951 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3952 PERL_UNUSED_ARG(sv);
3953
3954 PL_hints |= HINT_LOCALIZE_HH;
3955 CopHINTHASH_set(&PL_compiling,
3956 mg->mg_len == HEf_SVKEY
3957 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3958 MUTABLE_SV(mg->mg_ptr), 0, 0)
3959 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3960 mg->mg_ptr, mg->mg_len, 0, 0));
3961 if (mg->mg_len == HEf_SVKEY)
3962 magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE);
3963 else
3964 magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE);
3965 return 0;
3966 }
3967
3968 /*
3969 =for apidoc magic_clearhints
3970
3971 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3972
3973 =cut
3974 */
3975 int
Perl_magic_clearhints(pTHX_ SV * sv,MAGIC * mg)3976 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3977 {
3978 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3979 PERL_UNUSED_ARG(sv);
3980 PERL_UNUSED_ARG(mg);
3981 cophh_free(CopHINTHASH_get(&PL_compiling));
3982 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3983 CLEARFEATUREBITS();
3984 return 0;
3985 }
3986
3987 int
Perl_magic_copycallchecker(pTHX_ SV * sv,MAGIC * mg,SV * nsv,const char * name,I32 namlen)3988 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3989 const char *name, I32 namlen)
3990 {
3991 MAGIC *nmg;
3992
3993 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3994 PERL_UNUSED_ARG(sv);
3995 PERL_UNUSED_ARG(name);
3996 PERL_UNUSED_ARG(namlen);
3997
3998 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3999 nmg = mg_find(nsv, mg->mg_type);
4000 assert(nmg);
4001 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
4002 nmg->mg_ptr = mg->mg_ptr;
4003 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
4004 nmg->mg_flags |= MGf_REFCOUNTED;
4005 return 1;
4006 }
4007
4008 int
Perl_magic_setdebugvar(pTHX_ SV * sv,MAGIC * mg)4009 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
4010 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
4011
4012 #if DBVARMG_SINGLE != 0
4013 assert(mg->mg_private >= DBVARMG_SINGLE);
4014 #endif
4015 assert(mg->mg_private < DBVARMG_COUNT);
4016
4017 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
4018
4019 return 1;
4020 }
4021
4022 int
Perl_magic_getdebugvar(pTHX_ SV * sv,MAGIC * mg)4023 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
4024 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
4025
4026 #if DBVARMG_SINGLE != 0
4027 assert(mg->mg_private >= DBVARMG_SINGLE);
4028 #endif
4029 assert(mg->mg_private < DBVARMG_COUNT);
4030 sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
4031
4032 return 0;
4033 }
4034
4035 /*
4036 * ex: set ts=8 sts=4 sw=4 et:
4037 */
4038