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