File Coverage

mg.c
Criterion Covered Total %
statement 1073 1207 88.9
branch 929 1412 65.8
condition n/a
subroutine n/a
total 2002 2619 76.4


line stmt bran cond sub time code
1           /* mg.c
2           *
3           * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4           * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5           *
6           * You may distribute under the terms of either the GNU General Public
7           * License or the Artistic License, as specified in the README file.
8           *
9           */
10            
11           /*
12           * Sam sat on the ground and put his head in his hands. 'I wish I had never
13           * come here, and I don't want to see no more magic,' he said, and fell silent.
14           *
15           * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
16           */
17            
18           /*
19           =head1 Magical Functions
20            
21           "Magic" is special data attached to SV structures in order to give them
22           "magical" properties. When any Perl code tries to read from, or assign to,
23           an SV marked as magical, it calls the 'get' or 'set' function associated
24           with that SV's magic. A get is called prior to reading an SV, in order to
25           give it a chance to update its internal value (get on $. writes the line
26           number of the last read filehandle into to the SV's IV slot), while
27           set is called after an SV has been written to, in order to allow it to make
28           use of its changed value (set on $/ copies the SV's new value to the
29           PL_rs global variable).
30            
31           Magic is implemented as a linked list of MAGIC structures attached to the
32           SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33           of functions that implement the get(), set(), length() etc functions,
34           plus space for some flags and pointers. For example, a tied variable has
35           a MAGIC structure that contains a pointer to the object associated with the
36           tie.
37            
38           */
39            
40           #include "EXTERN.h"
41           #define PERL_IN_MG_C
42           #include "perl.h"
43            
44           #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
45           # ifdef I_GRP
46           # include
47           # endif
48           #endif
49            
50           #if defined(HAS_SETGROUPS)
51           # ifndef NGROUPS
52           # define NGROUPS 32
53           # endif
54           #endif
55            
56           #ifdef __hpux
57           # include
58           #endif
59            
60           #ifdef HAS_PRCTL_SET_NAME
61           # include
62           #endif
63            
64           #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
65           Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
66           #else
67           Signal_t Perl_csighandler(int sig);
68           #endif
69            
70           #ifdef __Lynx__
71           /* Missing protos on LynxOS */
72           void setruid(uid_t id);
73           void seteuid(uid_t id);
74           void setrgid(uid_t id);
75           void setegid(uid_t id);
76           #endif
77            
78           /*
79           * Pre-magic setup and post-magic takedown.
80           * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81           */
82            
83           struct magic_state {
84           SV* mgs_sv;
85           I32 mgs_ss_ix;
86           U32 mgs_magical;
87           bool mgs_readonly;
88           bool mgs_bumped;
89           };
90           /* MGS is typedef'ed to struct magic_state in perl.h */
91            
92           STATIC void
93 113850077         S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
94           {
95           dVAR;
96           MGS* mgs;
97           bool bumped = FALSE;
98            
99           PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
100            
101           assert(SvMAGICAL(sv));
102            
103           /* we shouldn't really be called here with RC==0, but it can sometimes
104           * happen via mg_clear() (which also shouldn't be called when RC==0,
105           * but it can happen). Handle this case gracefully(ish) by not RC++
106           * and thus avoiding the resultant double free */
107 113850077 50       if (SvREFCNT(sv) > 0) {
108           /* guard against sv getting freed midway through the mg clearing,
109           * by holding a private reference for the duration. */
110 113850077         SvREFCNT_inc_simple_void_NN(sv);
111           bumped = TRUE;
112           }
113            
114 113850077         SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
115            
116 113850077         mgs = SSPTR(mgs_ix, MGS*);
117 113850077         mgs->mgs_sv = sv;
118 113850077         mgs->mgs_magical = SvMAGICAL(sv);
119 113850077         mgs->mgs_readonly = SvREADONLY(sv) != 0;
120 113850077         mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
121 113850077         mgs->mgs_bumped = bumped;
122            
123 113850077         SvFLAGS(sv) &= ~flags;
124 113850077         SvREADONLY_off(sv);
125 113850077         }
126            
127           #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
128            
129           /*
130           =for apidoc mg_magical
131            
132           Turns on the magical status of an SV. See C.
133            
134           =cut
135           */
136            
137           void
138 108262592         Perl_mg_magical(pTHX_ SV *sv)
139           {
140           const MAGIC* mg;
141           PERL_ARGS_ASSERT_MG_MAGICAL;
142           PERL_UNUSED_CONTEXT;
143            
144 108262592         SvMAGICAL_off(sv);
145 108262592 100       if ((mg = SvMAGIC(sv))) {
146           do {
147 110011290         const MGVTBL* const vtbl = mg->mg_virtual;
148 110011290 100       if (vtbl) {
149 109729950 100       if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
    100        
150 43874425         SvGMAGICAL_on(sv);
151 109729950 100       if (vtbl->svt_set)
152 88786568         SvSMAGICAL_on(sv);
153 109729950 100       if (vtbl->svt_clear)
154 29035927         SvRMAGICAL_on(sv);
155           }
156 110011290 100       } while ((mg = mg->mg_moremagic));
157 108262586 100       if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
158 21184458         SvRMAGICAL_on(sv);
159           }
160 108262592         }
161            
162           /*
163           =for apidoc mg_get
164            
165           Do magic before a value is retrieved from the SV. The type of SV must
166           be >= SVt_PVMG. See C.
167            
168           =cut
169           */
170            
171           int
172 69245964         Perl_mg_get(pTHX_ SV *sv)
173           {
174           dVAR;
175 69245964         const I32 mgs_ix = SSNEW(sizeof(MGS));
176           bool saved = FALSE;
177           bool have_new = 0;
178           MAGIC *newmg, *head, *cur, *mg;
179            
180           PERL_ARGS_ASSERT_MG_GET;
181            
182 69245964 100       if (PL_localizing == 1 && sv == DEFSV) return 0;
    100        
    100        
183            
184           /* We must call svt_get(sv, mg) for each valid entry in the linked
185           list of magic. svt_get() may delete the current entry, add new
186           magic to the head of the list, or upgrade the SV. AMS 20010810 */
187            
188 69245934         newmg = cur = head = mg = SvMAGIC(sv);
189 172517790 100       while (mg) {
190 69264266         const MGVTBL * const vtbl = mg->mg_virtual;
191 69264266         MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
192            
193 69264266 50       if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
    100        
194            
195           /* taint's mg get is so dumb it doesn't need flag saving */
196 69246102 100       if (!saved && mg->mg_type != PERL_MAGIC_taint) {
    100        
197 68118238         save_magic(mgs_ix, sv);
198           saved = TRUE;
199           }
200            
201 69246102         vtbl->svt_get(aTHX_ sv, mg);
202            
203           /* guard against magic having been deleted - eg FETCH calling
204           * untie */
205 69246024 100       if (!SvMAGIC(sv)) {
206 10         (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
207 10         break;
208           }
209            
210           /* recalculate flags if this entry was deleted. */
211 69246014 100       if (mg->mg_flags & MGf_GSKIP)
212 2296125         (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
213           }
214 18164 50       else if (vtbl == &PL_vtbl_utf8) {
215           /* get-magic can reallocate the PV */
216           magic_setutf8(sv, mg);
217           }
218            
219           mg = nextmg;
220            
221 69264178 100       if (have_new) {
222           /* Have we finished with the new entries we saw? Start again
223           where we left off (unless there are more new entries). */
224 2 50       if (mg == head) {
225           have_new = 0;
226           mg = cur;
227           head = newmg;
228           }
229           }
230            
231           /* Were any new entries added? */
232 69264178 50       if (!have_new && (newmg = SvMAGIC(sv)) != head) {
    100        
233           have_new = 1;
234           cur = mg;
235           mg = newmg;
236 35247379         (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
237           }
238           }
239            
240 69245856 100       if (saved)
241 68682023         restore_magic(INT2PTR(void *, (IV)mgs_ix));
242            
243           return 0;
244           }
245            
246           /*
247           =for apidoc mg_set
248            
249           Do magic after a value is assigned to the SV. See C.
250            
251           =cut
252           */
253            
254           int
255 42137736         Perl_mg_set(pTHX_ SV *sv)
256           {
257           dVAR;
258 42137736         const I32 mgs_ix = SSNEW(sizeof(MGS));
259           MAGIC* mg;
260           MAGIC* nextmg;
261            
262           PERL_ARGS_ASSERT_MG_SET;
263            
264 42137736 100       if (PL_localizing == 2 && sv == DEFSV) return 0;
    50        
    100        
265            
266 42097406         save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
267            
268 105133130 100       for (mg = SvMAGIC(sv); mg; mg = nextmg) {
269 42098218         const MGVTBL* vtbl = mg->mg_virtual;
270 42098218         nextmg = mg->mg_moremagic; /* it may delete itself */
271 42098218 100       if (mg->mg_flags & MGf_GSKIP) {
272 776         mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
273 776         (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
274           }
275 42098218 100       if (PL_localizing == 2
276 12995516 100       && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
277 12         continue;
278 42098206 100       if (vtbl && vtbl->svt_set)
    100        
279 42098180         vtbl->svt_set(aTHX_ sv, mg);
280           }
281            
282 42097258         restore_magic(INT2PTR(void*, (IV)mgs_ix));
283 42117423         return 0;
284           }
285            
286           /*
287           =for apidoc mg_length
288            
289           Reports on the SV's length in bytes, calling length magic if available,
290           but does not set the UTF8 flag on the sv. It will fall back to 'get'
291           magic if there is no 'length' magic, but with no indication as to
292           whether it called 'get' magic. It assumes the sv is a PVMG or
293           higher. Use sv_len() instead.
294            
295           =cut
296           */
297            
298           U32
299 0         Perl_mg_length(pTHX_ SV *sv)
300           {
301           dVAR;
302           MAGIC* mg;
303           STRLEN len;
304            
305           PERL_ARGS_ASSERT_MG_LENGTH;
306            
307 0 0       for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
308 0         const MGVTBL * const vtbl = mg->mg_virtual;
309 0 0       if (vtbl && vtbl->svt_len) {
    0        
310 0         const I32 mgs_ix = SSNEW(sizeof(MGS));
311 0         save_magic(mgs_ix, sv);
312           /* omit MGf_GSKIP -- not changed here */
313 0         len = vtbl->svt_len(aTHX_ sv, mg);
314 0         restore_magic(INT2PTR(void*, (IV)mgs_ix));
315 0         return len;
316           }
317           }
318            
319 0 0       (void)SvPV_const(sv, len);
320 0         return len;
321           }
322            
323           I32
324 122276         Perl_mg_size(pTHX_ SV *sv)
325           {
326           MAGIC* mg;
327            
328           PERL_ARGS_ASSERT_MG_SIZE;
329            
330 242718 100       for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
331 122456         const MGVTBL* const vtbl = mg->mg_virtual;
332 122456 50       if (vtbl && vtbl->svt_len) {
    100        
333 2014         const I32 mgs_ix = SSNEW(sizeof(MGS));
334           I32 len;
335 2014         save_magic(mgs_ix, sv);
336           /* omit MGf_GSKIP -- not changed here */
337 2014         len = vtbl->svt_len(aTHX_ sv, mg);
338 2004         restore_magic(INT2PTR(void*, (IV)mgs_ix));
339 62135         return len;
340           }
341           }
342            
343 120262 50       switch(SvTYPE(sv)) {
344           case SVt_PVAV:
345 120262         return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
346           case SVt_PVHV:
347           /* FIXME */
348           default:
349 0         Perl_croak(aTHX_ "Size magic not implemented");
350           break;
351           }
352           return 0;
353           }
354            
355           /*
356           =for apidoc mg_clear
357            
358           Clear something magical that the SV represents. See C.
359            
360           =cut
361           */
362            
363           int
364 3632419         Perl_mg_clear(pTHX_ SV *sv)
365           {
366 3632419         const I32 mgs_ix = SSNEW(sizeof(MGS));
367           MAGIC* mg;
368           MAGIC *nextmg;
369            
370           PERL_ARGS_ASSERT_MG_CLEAR;
371            
372 3632419         save_magic(mgs_ix, sv);
373            
374 9063086 100       for (mg = SvMAGIC(sv); mg; mg = nextmg) {
375 3632465         const MGVTBL* const vtbl = mg->mg_virtual;
376           /* omit GSKIP -- never set here */
377            
378 3632465         nextmg = mg->mg_moremagic; /* it may delete itself */
379            
380 3632465 100       if (vtbl && vtbl->svt_clear)
    100        
381 3632457         vtbl->svt_clear(aTHX_ sv, mg);
382           }
383            
384 3632407         restore_magic(INT2PTR(void*, (IV)mgs_ix));
385 3632407         return 0;
386           }
387            
388           static MAGIC*
389           S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
390           {
391           PERL_UNUSED_CONTEXT;
392            
393           assert(flags <= 1);
394            
395 913872221 50       if (sv) {
    0        
    50        
    50        
    100        
    0        
    0        
    50        
    50        
    50        
    50        
396           MAGIC *mg;
397            
398           assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
399            
400 1723687413 50       for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
    0        
    50        
    50        
    50        
    0        
    0        
    50        
    100        
    100        
    100        
401 899997147 50       if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
    0        
    100        
    50        
    50        
    0        
    0        
    100        
    100        
    50        
    100        
    100        
402           return mg;
403           }
404           }
405           }
406            
407           return NULL;
408           }
409            
410           /*
411           =for apidoc mg_find
412            
413           Finds the magic pointer for type matching the SV. See C.
414            
415           =cut
416           */
417            
418           MAGIC*
419 886244481         Perl_mg_find(pTHX_ const SV *sv, int type)
420           {
421 886244481         return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
422           }
423            
424           /*
425           =for apidoc mg_findext
426            
427           Finds the magic pointer of C with the given C for the C. See
428           C.
429            
430           =cut
431           */
432            
433           MAGIC*
434 20         Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
435           {
436 20         return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
437           }
438            
439           MAGIC *
440 32401847         Perl_mg_find_mglob(pTHX_ SV *sv)
441           {
442           PERL_ARGS_ASSERT_MG_FIND_MGLOB;
443 32401847 100       if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
    100        
444           /* This sv is only a delegate. //g magic must be attached to
445           its target. */
446 18         vivify_defelem(sv);
447 18         sv = LvTARG(sv);
448           }
449 32401847 100       if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
    100        
450 29995203         return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0);
451           return NULL;
452           }
453            
454           /*
455           =for apidoc mg_copy
456            
457           Copies the magic from one SV to another. See C.
458            
459           =cut
460           */
461            
462           int
463 8651937         Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
464           {
465           int count = 0;
466           MAGIC* mg;
467            
468           PERL_ARGS_ASSERT_MG_COPY;
469            
470 17304396 100       for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
471 8652459         const MGVTBL* const vtbl = mg->mg_virtual;
472 8652459 100       if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
    50        
473 2         count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
474           }
475           else {
476 8652457         const char type = mg->mg_type;
477 8652457 100       if (isUPPER(type) && type != PERL_MAGIC_uvar) {
478 8611679 50       sv_magic(nsv,
    100        
    50        
    100        
    100        
479           (type == PERL_MAGIC_tied)
480           ? SvTIED_obj(sv, mg)
481           : (type == PERL_MAGIC_regdata && mg->mg_obj)
482           ? sv
483           : mg->mg_obj,
484           toLOWER(type), key, klen);
485 8611679         count++;
486           }
487           }
488           }
489 8651937         return count;
490           }
491            
492           /*
493           =for apidoc mg_localize
494            
495           Copy some of the magic from an existing SV to new localized version of that
496           SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
497           taint, pos).
498            
499           If setmagic is false then no set magic will be called on the new (empty) SV.
500           This typically means that assignment will soon follow (e.g. 'local $x = $y'),
501           and that will handle the magic.
502            
503           =cut
504           */
505            
506           void
507 13035848         Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
508           {
509           dVAR;
510           MAGIC *mg;
511            
512           PERL_ARGS_ASSERT_MG_LOCALIZE;
513            
514 13035848 100       if (nsv == DEFSV)
    100        
515 13035848         return;
516            
517 25991046 100       for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
518 12995524         const MGVTBL* const vtbl = mg->mg_virtual;
519 12995524 100       if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
520 24         continue;
521          
522 12995500 50       if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
    0        
523 0         (void)vtbl->svt_local(aTHX_ nsv, mg);
524           else
525 12995500         sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
526           mg->mg_ptr, mg->mg_len);
527            
528           /* container types should remain read-only across localization */
529 12995500         SvFLAGS(nsv) |= SvREADONLY(sv);
530           }
531            
532 12995522 100       if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
    100        
533 12995500         SvFLAGS(nsv) |= SvMAGICAL(sv);
534 12995500 100       if (setmagic) {
535 12989178         PL_localizing = 1;
536 12989178 100       SvSETMAGIC(nsv);
537 12989178         PL_localizing = 0;
538           }
539           }
540           }
541            
542           #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
543           static void
544 39862801         S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
545           {
546 39862801         const MGVTBL* const vtbl = mg->mg_virtual;
547 39862801 100       if (vtbl && vtbl->svt_free)
    100        
548 15416         vtbl->svt_free(aTHX_ sv, mg);
549 39862801 100       if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
    50        
550 25327532 100       if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
    100        
551 15158900         Safefree(mg->mg_ptr);
552 10168632 100       else if (mg->mg_len == HEf_SVKEY)
553 9457561         SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
554           }
555 39862801 100       if (mg->mg_flags & MGf_REFCOUNTED)
556 2667003         SvREFCNT_dec(mg->mg_obj);
557 39862801         Safefree(mg);
558 39862801         }
559            
560           /*
561           =for apidoc mg_free
562            
563           Free any magic storage used by the SV. See C.
564            
565           =cut
566           */
567            
568           int
569 40526303         Perl_mg_free(pTHX_ SV *sv)
570           {
571           MAGIC* mg;
572           MAGIC* moremagic;
573            
574           PERL_ARGS_ASSERT_MG_FREE;
575            
576 100578629 100       for (mg = SvMAGIC(sv); mg; mg = moremagic) {
577 39862791         moremagic = mg->mg_moremagic;
578 39862791         mg_free_struct(sv, mg);
579 39862791         SvMAGIC_set(sv, moremagic);
580           }
581 40526303         SvMAGIC_set(sv, NULL);
582 40526303         SvMAGICAL_off(sv);
583 40526303         return 0;
584           }
585            
586           /*
587           =for apidoc Am|void|mg_free_type|SV *sv|int how
588            
589           Remove any magic of type I from the SV I. See L.
590            
591           =cut
592           */
593            
594           void
595 12         Perl_mg_free_type(pTHX_ SV *sv, int how)
596           {
597           MAGIC *mg, *prevmg, *moremg;
598           PERL_ARGS_ASSERT_MG_FREE_TYPE;
599 36 100       for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
600           MAGIC *newhead;
601 18         moremg = mg->mg_moremagic;
602 18 100       if (mg->mg_type == how) {
603           /* temporarily move to the head of the magic chain, in case
604           custom free code relies on this historical aspect of mg_free */
605 10 100       if (prevmg) {
606 2         prevmg->mg_moremagic = moremg;
607 2         mg->mg_moremagic = SvMAGIC(sv);
608 2         SvMAGIC_set(sv, mg);
609           }
610 10         newhead = mg->mg_moremagic;
611 10         mg_free_struct(sv, mg);
612 14         SvMAGIC_set(sv, newhead);
613           mg = prevmg;
614           }
615           }
616 12         mg_magical(sv);
617 12         }
618            
619           #include
620            
621           U32
622 274         Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
623           {
624           dVAR;
625           PERL_UNUSED_ARG(sv);
626            
627           PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
628            
629 274 100       if (PL_curpm) {
630 254         const REGEXP * const rx = PM_GETRE(PL_curpm);
631 254 50       if (rx) {
632 254 100       if (mg->mg_obj) { /* @+ */
633           /* return the number possible */
634 124         return RX_NPARENS(rx);
635           } else { /* @- */
636 130         I32 paren = RX_LASTPAREN(rx);
637            
638           /* return the last filled */
639 195 50       while ( paren >= 0
640 130 50       && (RX_OFFS(rx)[paren].start == -1
641 130 50       || RX_OFFS(rx)[paren].end == -1) )
642 0         paren--;
643 202         return (U32)paren;
644           }
645           }
646           }
647            
648           return (U32)-1;
649           }
650            
651           /* @-, @+ */
652            
653           int
654 133520         Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
655           {
656           dVAR;
657            
658           PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
659            
660 133520 50       if (PL_curpm) {
661 133520         const REGEXP * const rx = PM_GETRE(PL_curpm);
662 133520 50       if (rx) {
663 133520         const I32 paren = mg->mg_len;
664           SSize_t s;
665           SSize_t t;
666 133520 50       if (paren < 0)
667           return 0;
668 200280 50       if (paren <= (I32)RX_NPARENS(rx) &&
    100        
669 200024 50       (s = RX_OFFS(rx)[paren].start) != -1 &&
670 133264         (t = RX_OFFS(rx)[paren].end) != -1)
671           {
672           SSize_t i;
673 133264 100       if (mg->mg_obj) /* @+ */
674           i = t;
675           else /* @- */
676           i = s;
677            
678 133264 100       if (RX_MATCH_UTF8(rx)) {
679 8444         const char * const b = RX_SUBBEG(rx);
680 8444 50       if (b)
681 12666         i = RX_SUBCOFFSET(rx) +
682 12666         utf8_length((U8*)b,
683           (U8*)(b-RX_SUBOFFSET(rx)+i));
684           }
685            
686 133264         sv_setuv(sv, i);
687 133264         return 0;
688           }
689           }
690           }
691 256         sv_setsv(sv, NULL);
692 66888         return 0;
693           }
694            
695           /* @-, @+ */
696            
697           int
698 0         Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
699           {
700           PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
701           PERL_UNUSED_ARG(sv);
702           PERL_UNUSED_ARG(mg);
703 0         Perl_croak_no_modify();
704           NORETURN_FUNCTION_END;
705           }
706            
707           #define SvRTRIM(sv) STMT_START { \
708           if (SvPOK(sv)) { \
709           STRLEN len = SvCUR(sv); \
710           char * const p = SvPVX(sv); \
711           while (len > 0 && isSPACE(p[len-1])) \
712           --len; \
713           SvCUR_set(sv, len); \
714           p[len] = '\0'; \
715           } \
716           } STMT_END
717            
718           void
719 458         Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
720           {
721           PERL_ARGS_ASSERT_EMULATE_COP_IO;
722            
723 458 100       if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
724 432         sv_setsv(sv, &PL_sv_undef);
725           else {
726 26         sv_setpvs(sv, "");
727 26         SvUTF8_off(sv);
728 26 50       if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
729 26         SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
730           assert(value);
731 26         sv_catsv(sv, value);
732           }
733 26         sv_catpvs(sv, "\0");
734 26 50       if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
735 26         SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
736           assert(value);
737 26         sv_catsv(sv, value);
738           }
739           }
740 458         }
741            
742           #ifdef VMS
743           #include
744           #include
745           #endif
746            
747           int
748 65176561         Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
749           {
750           dVAR;
751           I32 paren;
752           const char *s = NULL;
753           REGEXP *rx;
754 65176561         const char * const remaining = mg->mg_ptr + 1;
755 65176561         const char nextchar = *remaining;
756            
757           PERL_ARGS_ASSERT_MAGIC_GET;
758            
759 65176561         switch (*mg->mg_ptr) {
760           case '\001': /* ^A */
761 2324 100       if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
    50        
    50        
762 730         else sv_setsv(sv, &PL_sv_undef);
763 2324 50       if (SvTAINTED(PL_bodytarget))
    0        
764 0 0       SvTAINTED_on(sv);
765           break;
766           case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
767 523510 100       if (nextchar == '\0') {
768 523482         sv_setiv(sv, (IV)PL_minus_c);
769           }
770 28 50       else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
771 28         sv_setiv(sv, (IV)STATUS_NATIVE);
772           }
773           break;
774            
775           case '\004': /* ^D */
776 271318         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
777 271318         break;
778           case '\005': /* ^E */
779 86480 100       if (nextchar == '\0') {
780           #if defined(VMS)
781           {
782           char msg[255];
783           $DESCRIPTOR(msgdsc,msg);
784           sv_setnv(sv,(NV) vaxc$errno);
785           if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
786           sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
787           else
788           sv_setpvs(sv,"");
789           }
790           #elif defined(OS2)
791           if (!(_emx_env & 0x200)) { /* Under DOS */
792           sv_setnv(sv, (NV)errno);
793           sv_setpv(sv, errno ? Strerror(errno) : "");
794           } else {
795           if (errno != errno_isOS2) {
796           const int tmp = _syserrno();
797           if (tmp) /* 2nd call to _syserrno() makes it 0 */
798           Perl_rc = tmp;
799           }
800           sv_setnv(sv, (NV)Perl_rc);
801           sv_setpv(sv, os2error(Perl_rc));
802           }
803           #elif defined(WIN32)
804           {
805           const DWORD dwErr = GetLastError();
806           sv_setnv(sv, (NV)dwErr);
807           if (dwErr) {
808           PerlProc_GetOSError(sv, dwErr);
809           }
810           else
811           sv_setpvs(sv, "");
812           SetLastError(dwErr);
813           }
814           #else
815           {
816 71558         dSAVE_ERRNO;
817 71558         sv_setnv(sv, (NV)errno);
818 71558 100       sv_setpv(sv, errno ? Strerror(errno) : "");
819 71558         RESTORE_ERRNO;
820           }
821           #endif
822 71558 50       SvRTRIM(sv);
    100        
    50        
823 71558         SvNOK_on(sv); /* what a wonderful hack! */
824           }
825 14922 50       else if (strEQ(remaining, "NCODING"))
826 14922         sv_setsv(sv, PL_encoding);
827           break;
828           case '\006': /* ^F */
829 448         sv_setiv(sv, (IV)PL_maxsysfd);
830 448         break;
831           case '\007': /* ^GLOBAL_PHASE */
832 14 50       if (strEQ(remaining, "LOBAL_PHASE")) {
833 14         sv_setpvn(sv, PL_phase_names[PL_phase],
834           strlen(PL_phase_names[PL_phase]));
835           }
836           break;
837           case '\010': /* ^H */
838 2266398         sv_setiv(sv, (IV)PL_hints);
839 2266398         break;
840           case '\011': /* ^I */ /* NOT \t in EBCDIC */
841 20         sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
842 20         break;
843           case '\014': /* ^LAST_FH */
844 0 0       if (strEQ(remaining, "AST_FH")) {
845 0 0       if (PL_last_in_gv) {
846           assert(isGV_with_GP(PL_last_in_gv));
847 0 0       SV_CHECK_THINKFIRST_COW_DROP(sv);
848 0 0       prepare_SV_for_RV(sv);
    0        
    0        
    0        
    0        
    0        
849 0 0       SvOK_off(sv);
850 0         SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv));
851 0         SvROK_on(sv);
852 0         sv_rvweaken(sv);
853           }
854 0         else sv_setsv_nomg(sv, NULL);
855           }
856           break;
857           case '\017': /* ^O & ^OPEN */
858 1118700 100       if (nextchar == '\0') {
859 1118242         sv_setpv(sv, PL_osname);
860 1118242 100       SvTAINTED_off(sv);
861           }
862 458 50       else if (strEQ(remaining, "PEN")) {
    50        
    50        
    50        
863 458         Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
864           }
865           break;
866           case '\020':
867 5908 100       if (nextchar == '\0') { /* ^P */
868 5550         sv_setiv(sv, (IV)PL_perldb);
869 358 100       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
870            
871           paren = RX_BUFF_IDX_CARET_PREMATCH;
872           goto do_numbuf_fetch;
873 48 50       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
874           paren = RX_BUFF_IDX_CARET_POSTMATCH;
875           goto do_numbuf_fetch;
876           }
877           break;
878           case '\023': /* ^S */
879 448 50       if (nextchar == '\0') {
880 448 100       if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
    50        
881 368 50       SvOK_off(sv);
882 80 100       else if (PL_in_eval)
883 52         sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
884           else
885 28         sv_setiv(sv, 0);
886           }
887           break;
888           case '\024': /* ^T */
889 34052 100       if (nextchar == '\0') {
890           #ifdef BIG_TIME
891           sv_setnv(sv, PL_basetime);
892           #else
893 730         sv_setiv(sv, (IV)PL_basetime);
894           #endif
895           }
896 33322 50       else if (strEQ(remaining, "AINT"))
897 33322 100       sv_setiv(sv, TAINTING_get
    100        
    50        
898           ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
899           : 0);
900           break;
901           case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
902 606 100       if (strEQ(remaining, "NICODE"))
903 338         sv_setuv(sv, (UV) PL_unicode);
904 268 100       else if (strEQ(remaining, "TF8LOCALE"))
905 256         sv_setuv(sv, (UV) PL_utf8locale);
906 12 50       else if (strEQ(remaining, "TF8CACHE"))
907 12         sv_setiv(sv, (IV) PL_utf8cache);
908           break;
909           case '\027': /* ^W & $^WARNING_BITS */
910 8950204 100       if (nextchar == '\0')
911 8451886 100       sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
912 498318 50       else if (strEQ(remaining, "ARNING_BITS")) {
913 498318 100       if (PL_compiling.cop_warnings == pWARN_NONE) {
914 638         sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
915           }
916 497680 100       else if (PL_compiling.cop_warnings == pWARN_STD) {
917 237804         sv_setsv(sv, &PL_sv_undef);
918 237804         break;
919           }
920 259876 100       else if (PL_compiling.cop_warnings == pWARN_ALL) {
921           /* Get the bit mask for $warnings::Bits{all}, because
922           * it could have been extended by warnings::register */
923 212080         HV * const bits = get_hv("warnings::Bits", 0);
924 212080 50       SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
925 212080 50       if (bits_all)
926 212080         sv_copypv(sv, *bits_all);
927           else
928 0         sv_setpvn(sv, WARN_ALLstring, WARNsize);
929           }
930           else {
931 47796         sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
932           *PL_compiling.cop_warnings);
933           }
934           }
935           break;
936           case '\015': /* $^MATCH */
937 52 50       if (strEQ(remaining, "ATCH")) {
938           paren = RX_BUFF_IDX_CARET_FULLMATCH;
939           goto do_numbuf_fetch;
940           }
941            
942           case '1': case '2': case '3': case '4':
943           case '5': case '6': case '7': case '8': case '9': case '&':
944           /*
945           * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
946           * XXX Does the new way break anything?
947           */
948 46410391         paren = atoi(mg->mg_ptr); /* $& is in [0] */
949           do_numbuf_fetch:
950 46422869 100       if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
    50        
951 46420713         CALLREG_NUMBUF_FETCH(rx,paren,sv);
952 46420713         break;
953           }
954 2156         sv_setsv(sv,&PL_sv_undef);
955 2156         break;
956           case '+':
957 10550 50       if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
    50        
958 10550         paren = RX_LASTPAREN(rx);
959 10550 100       if (paren)
960           goto do_numbuf_fetch;
961           }
962 2         sv_setsv(sv,&PL_sv_undef);
963 2         break;
964           case '\016': /* ^N */
965 572 50       if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
    50        
966 572         paren = RX_LASTCLOSEPAREN(rx);
967 572 100       if (paren)
968           goto do_numbuf_fetch;
969           }
970 2         sv_setsv(sv,&PL_sv_undef);
971 2         break;
972           case '`':
973           paren = RX_BUFF_IDX_PREMATCH;
974           goto do_numbuf_fetch;
975           case '\'':
976           paren = RX_BUFF_IDX_POSTMATCH;
977 876         goto do_numbuf_fetch;
978           case '.':
979 1287856 100       if (GvIO(PL_last_in_gv)) {
    100        
    50        
    100        
980 532718         sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
981           }
982           break;
983           case '?':
984           {
985 45782         sv_setiv(sv, (IV)STATUS_CURRENT);
986           #ifdef COMPLEX_STATUS
987           SvUPGRADE(sv, SVt_PVLV);
988           LvTARGOFF(sv) = PL_statusvalue;
989           LvTARGLEN(sv) = PL_statusvalue_vms;
990           #endif
991           }
992 45782         break;
993           case '^':
994 18 50       if (GvIOp(PL_defoutgv))
995 18         s = IoTOP_NAME(GvIOp(PL_defoutgv));
996 18 100       if (s)
997 6         sv_setpv(sv,s);
998           else {
999 12 50       sv_setpv(sv,GvENAME(PL_defoutgv));
1000 12         sv_catpvs(sv,"_TOP");
1001           }
1002           break;
1003           case '~':
1004 52 50       if (GvIOp(PL_defoutgv))
1005 52         s = IoFMT_NAME(GvIOp(PL_defoutgv));
1006 52 100       if (!s)
1007 18 50       s = GvENAME(PL_defoutgv);
1008 52         sv_setpv(sv,s);
1009 52         break;
1010           case '=':
1011 24 50       if (GvIO(PL_defoutgv))
    50        
    50        
    50        
1012 24         sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1013           break;
1014           case '-':
1015 22 50       if (GvIO(PL_defoutgv))
    50        
    50        
    50        
1016 22         sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1017           break;
1018           case '%':
1019 16 50       if (GvIO(PL_defoutgv))
    50        
    50        
    50        
1020 16         sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1021           break;
1022           case ':':
1023           break;
1024           case '/':
1025           break;
1026           case '[':
1027 0         sv_setiv(sv, 0);
1028 0         break;
1029           case '|':
1030 2284 50       if (GvIO(PL_defoutgv))
    50        
    50        
    50        
1031 2284         sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1032           break;
1033           case '\\':
1034 1077656 100       if (PL_ors_sv)
1035 2614         sv_copypv(sv, PL_ors_sv);
1036           else
1037 1075042         sv_setsv(sv, &PL_sv_undef);
1038           break;
1039           case '$': /* $$ */
1040           {
1041 372454         IV const pid = (IV)PerlProc_getpid();
1042 372454 100       if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
    50        
    100        
1043           /* never set manually, or at least not since last fork */
1044 372452         sv_setiv(sv, pid);
1045           /* never unsafe, even if reading in a tainted expression */
1046 372452 100       SvTAINTED_off(sv);
1047           }
1048           /* else a value has been assigned manually, so do nothing */
1049           }
1050           break;
1051            
1052           case '!':
1053           {
1054 2401776         dSAVE_ERRNO;
1055           #ifdef VMS
1056           sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1057           #else
1058 2401776         sv_setnv(sv, (NV)errno);
1059           #endif
1060           #ifdef OS2
1061           if (errno == errno_isOS2 || errno == errno_isOS2_set)
1062           sv_setpv(sv, os2error(Perl_rc));
1063           else
1064           #endif
1065 2401776 100       if (! errno) {
1066 1913186         sv_setpvs(sv, "");
1067           }
1068           else {
1069            
1070           /* Strerror can return NULL on some platforms, which will result in
1071           * 'sv' not being considered SvOK. The SvNOK_on() below will cause
1072           * just the number part to be valid */
1073 488590         sv_setpv(sv, Strerror(errno));
1074            
1075           /* In some locales the error string may come back as UTF-8, in
1076           * which case we should turn on that flag. This didn't use to
1077           * happen, and to avoid any possible backward compatibility issues,
1078           * we don't turn on the flag unless we have to. So the flag stays
1079           * off for an entirely ASCII string. We assume that if the string
1080           * looks like UTF-8, it really is UTF-8: "text in any other
1081           * encoding that uses bytes with the high bit set is extremely
1082           * unlikely to pass a UTF-8 validity test"
1083           * (http://en.wikipedia.org/wiki/Charset_detection). There is a
1084           * potential that we will get it wrong however, especially on short
1085           * error message text. (If it turns out to be necessary, we could
1086           * also keep track if the current LC_MESSAGES locale is UTF-8) */
1087 488590 50       if (SvOK(sv) /* It could be that Strerror returned invalid */
    0        
    0        
1088 488590 50       && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
1089 0 0       && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
1090           {
1091 0         SvUTF8_on(sv);
1092           }
1093           }
1094 2401776         RESTORE_ERRNO;
1095           }
1096            
1097 2401776 50       SvRTRIM(sv);
    100        
    50        
1098 2401776         SvNOK_on(sv); /* what a wonderful hack! */
1099 2401776         break;
1100           case '<':
1101 610         sv_setuid(sv, PerlProc_getuid());
1102 610         break;
1103           case '>':
1104 790         sv_setuid(sv, PerlProc_geteuid());
1105 790         break;
1106           case '(':
1107 18         sv_setgid(sv, PerlProc_getgid());
1108 18         goto add_groups;
1109           case ')':
1110 140         sv_setgid(sv, PerlProc_getegid());
1111           add_groups:
1112           #ifdef HAS_GETGROUPS
1113           {
1114           Groups_t *gary = NULL;
1115           I32 i, num_groups = getgroups(0, gary);
1116 158 50       Newx(gary, num_groups, Groups_t);
1117           num_groups = getgroups(num_groups, gary);
1118 474 100       for (i = 0; i < num_groups; i++)
1119 316         Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1120 158         Safefree(gary);
1121           }
1122 158         (void)SvIOK_on(sv); /* what a wonderful hack! */
1123           #endif
1124 158         break;
1125           case '0':
1126           break;
1127           }
1128 65176561         return 0;
1129           }
1130            
1131           int
1132 80688         Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1133           {
1134 80688         struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1135            
1136           PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1137            
1138 80688 50       if (uf && uf->uf_val)
    100        
1139 80682         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1140 80688         return 0;
1141           }
1142            
1143           int
1144 365952         Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1145 365952 50       {
1146           dVAR;
1147           STRLEN len = 0, klen;
1148 365952 100       const char * const key = MgPV_const(mg,klen);
    50        
1149           const char *s = "";
1150            
1151           PERL_ARGS_ASSERT_MAGIC_SETENV;
1152            
1153 182976         SvGETMAGIC(sv);
1154 365952 100       if (SvOK(sv)) {
    50        
    50        
1155           /* defined environment variables are byte strings; unfortunately
1156           there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1157 362566 50       (void)SvPV_force_nomg_nolen(sv);
1158 362566         sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1159 362566 50       if (SvUTF8(sv)) {
1160 0         Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1161 0         SvUTF8_off(sv);
1162           }
1163 362566         s = SvPVX(sv);
1164 362566         len = SvCUR(sv);
1165           }
1166 365952         my_setenv(key, s); /* does the deed */
1167            
1168           #ifdef DYNAMIC_ENV_FETCH
1169           /* We just undefd an environment var. Is a replacement */
1170           /* waiting in the wings? */
1171           if (!len) {
1172           SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1173           if (valp)
1174           s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1175           }
1176           #endif
1177            
1178           #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1179           /* And you'll never guess what the dog had */
1180           /* in its mouth... */
1181 365952 100       if (TAINTING_get) {
1182 2         MgTAINTEDDIR_off(mg);
1183           #ifdef VMS
1184           if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
1185           char pathbuf[256], eltbuf[256], *cp, *elt;
1186           int i = 0, j = 0;
1187            
1188           my_strlcpy(eltbuf, s, sizeof(eltbuf));
1189           elt = eltbuf;
1190           do { /* DCL$PATH may be a search list */
1191           while (1) { /* as may dev portion of any element */
1192           if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1193           if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1194           cando_by_name(S_IWUSR,0,elt) ) {
1195           MgTAINTEDDIR_on(mg);
1196           return 0;
1197           }
1198           }
1199           if ((cp = strchr(elt, ':')) != NULL)
1200           *cp = '\0';
1201           if (my_trnlnm(elt, eltbuf, j++))
1202           elt = eltbuf;
1203           else
1204           break;
1205           }
1206           j = 0;
1207           } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1208           }
1209           #endif /* VMS */
1210 2 50       if (s && klen == 4 && strEQ(key,"PATH")) {
    50        
    0        
1211 0         const char * const strend = s + len;
1212            
1213 182976 0       while (s < strend) {
1214           char tmpbuf[256];
1215           Stat_t st;
1216           I32 i;
1217           #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1218           const char path_sep = '|';
1219           #else
1220           const char path_sep = ':';
1221           #endif
1222 0         s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1223           s, strend, path_sep, &i);
1224 0         s++;
1225 0 0       if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1226           #ifdef VMS
1227           || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1228           #else
1229 0 0       || *tmpbuf != '/' /* no starting slash -- assume relative path */
1230           #endif
1231 0 0       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
    0        
1232 0         MgTAINTEDDIR_on(mg);
1233 0         return 0;
1234           }
1235           }
1236           }
1237           }
1238           #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1239            
1240           return 0;
1241           }
1242            
1243           int
1244 63878         Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1245           {
1246           PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1247           PERL_UNUSED_ARG(sv);
1248 63878 100       my_setenv(MgPV_nolen_const(mg),NULL);
    50        
1249 63878         return 0;
1250           }
1251            
1252           int
1253 10152         Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1254           {
1255           dVAR;
1256           PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1257           PERL_UNUSED_ARG(mg);
1258           #if defined(VMS)
1259           Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1260           #else
1261 10152 50       if (PL_localizing) {
1262           HE* entry;
1263 10152         my_clearenv();
1264 10152         hv_iterinit(MUTABLE_HV(sv));
1265 384922 100       while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1266           I32 keylen;
1267 369694 50       my_setenv(hv_iterkey(entry, &keylen),
1268           SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1269           }
1270           }
1271           #endif
1272 10152         return 0;
1273           }
1274            
1275           int
1276 4636         Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1277           {
1278           dVAR;
1279           PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1280           PERL_UNUSED_ARG(sv);
1281           PERL_UNUSED_ARG(mg);
1282           #if defined(VMS)
1283           Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1284           #else
1285 4636         my_clearenv();
1286           #endif
1287 4636         return 0;
1288           }
1289            
1290           #ifndef PERL_MICRO
1291           #ifdef HAS_SIGPROCMASK
1292           static void
1293 4518         restore_sigmask(pTHX_ SV *save_sv)
1294           {
1295 4518 50       const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1296 4518         (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1297 4518         }
1298           #endif
1299           int
1300 315260         Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1301           {
1302           dVAR;
1303           /* Are we fetching a signal entry? */
1304 315260         int i = (I16)mg->mg_private;
1305            
1306           PERL_ARGS_ASSERT_MAGIC_GETSIG;
1307            
1308 315260 100       if (!i) {
1309           STRLEN siglen;
1310 169724 100       const char * sig = MgPV_const(mg, siglen);
    50        
1311 169724         mg->mg_private = i = whichsig_pvn(sig, siglen);
1312           }
1313            
1314 315260 100       if (i > 0) {
1315 2602 100       if(PL_psig_ptr[i])
1316 2396         sv_setsv(sv,PL_psig_ptr[i]);
1317           else {
1318 206         Sighandler_t sigstate = rsignal_state(i);
1319           #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1320           if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1321           sigstate = SIG_IGN;
1322           #endif
1323           #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1324           if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1325           sigstate = SIG_DFL;
1326           #endif
1327           /* cache state so we don't fetch it again */
1328 206 100       if(sigstate == (Sighandler_t) SIG_IGN)
1329 10         sv_setpvs(sv,"IGNORE");
1330           else
1331 196         sv_setsv(sv,&PL_sv_undef);
1332 206         PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1333 206         SvTEMP_off(sv);
1334           }
1335           }
1336 315260         return 0;
1337           }
1338           int
1339 2924102         Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1340           {
1341           PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1342            
1343 2924102         magic_setsig(NULL, mg);
1344 2924102         return sv_unmagic(sv, mg->mg_type);
1345           }
1346            
1347           Signal_t
1348           #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1349 154         Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1350           #else
1351           Perl_csighandler(int sig)
1352           #endif
1353           {
1354           #ifdef PERL_GET_SIG_CONTEXT
1355           dTHXa(PERL_GET_SIG_CONTEXT);
1356           #else
1357           dTHX;
1358           #endif
1359           #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1360           (void) rsignal(sig, PL_csighandlerp);
1361           if (PL_sig_ignoring[sig]) return;
1362           #endif
1363           #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1364           if (PL_sig_defaulting[sig])
1365           #ifdef KILL_BY_SIGPRC
1366           exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1367           #else
1368           exit(1);
1369           #endif
1370           #endif
1371 154 50       if (
1372           #ifdef SIGILL
1373 308         sig == SIGILL ||
1374           #endif
1375           #ifdef SIGBUS
1376 231 50       sig == SIGBUS ||
1377           #endif
1378           #ifdef SIGSEGV
1379 154 50       sig == SIGSEGV ||
1380           #endif
1381           (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1382           /* Call the perl level handler now--
1383           * with risk we may be in malloc() or being destructed etc. */
1384           #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1385 0         (*PL_sighandlerp)(sig, NULL, NULL);
1386           #else
1387           (*PL_sighandlerp)(sig);
1388           #endif
1389           else {
1390 308 50       if (!PL_psig_pend) return;
1391           /* Set a flag to say this signal is pending, that is awaiting delivery after
1392           * the current Perl opcode completes */
1393 154         PL_psig_pend[sig]++;
1394            
1395           #ifndef SIG_PENDING_DIE_COUNT
1396           # define SIG_PENDING_DIE_COUNT 120
1397           #endif
1398           /* Add one to say _a_ signal is pending */
1399 154 50       if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1400 0         Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1401           (unsigned long)SIG_PENDING_DIE_COUNT);
1402           }
1403           }
1404            
1405           #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1406           void
1407           Perl_csighandler_init(void)
1408           {
1409           int sig;
1410           if (PL_sig_handlers_initted) return;
1411            
1412           for (sig = 1; sig < SIG_SIZE; sig++) {
1413           #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1414           dTHX;
1415           PL_sig_defaulting[sig] = 1;
1416           (void) rsignal(sig, PL_csighandlerp);
1417           #endif
1418           #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1419           PL_sig_ignoring[sig] = 0;
1420           #endif
1421           }
1422           PL_sig_handlers_initted = 1;
1423           }
1424           #endif
1425            
1426           #if defined HAS_SIGPROCMASK
1427           static void
1428 150         unblock_sigmask(pTHX_ void* newset)
1429           {
1430 150         sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1431 150         }
1432           #endif
1433            
1434           void
1435 154         Perl_despatch_signals(pTHX)
1436           {
1437           dVAR;
1438           int sig;
1439 154         PL_sig_pending = 0;
1440 8896 100       for (sig = 1; sig < SIG_SIZE; sig++) {
1441 8772 100       if (PL_psig_pend[sig]) {
1442 154         dSAVE_ERRNO;
1443           #ifdef HAS_SIGPROCMASK
1444           /* From sigaction(2) (FreeBSD man page):
1445           * | Signal routines normally execute with the signal that
1446           * | caused their invocation blocked, but other signals may
1447           * | yet occur.
1448           * Emulation of this behavior (from within Perl) is enabled
1449           * using sigprocmask
1450           */
1451           int was_blocked;
1452           sigset_t newset, oldset;
1453            
1454 154         sigemptyset(&newset);
1455 154         sigaddset(&newset, sig);
1456 154         sigprocmask(SIG_BLOCK, &newset, &oldset);
1457 154         was_blocked = sigismember(&oldset, sig);
1458 154 100       if (!was_blocked) {
1459 150         SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1460 150         ENTER;
1461 150         SAVEFREESV(save_sv);
1462 150 50       SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1463           }
1464           #endif
1465 154         PL_psig_pend[sig] = 0;
1466           #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1467 154         (*PL_sighandlerp)(sig, NULL, NULL);
1468           #else
1469           (*PL_sighandlerp)(sig);
1470           #endif
1471           #ifdef HAS_SIGPROCMASK
1472 124 100       if (!was_blocked)
1473 122         LEAVE;
1474           #endif
1475 124         RESTORE_ERRNO;
1476           }
1477           }
1478 124         }
1479            
1480           /* sv of NULL signifies that we're acting as magic_clearsig. */
1481           int
1482 3814323         Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1483           {
1484           dVAR;
1485           I32 i;
1486           SV** svp = NULL;
1487           /* Need to be careful with SvREFCNT_dec(), because that can have side
1488           * effects (due to closures). We must make sure that the new disposition
1489           * is in place before it is called.
1490           */
1491           SV* to_dec = NULL;
1492           STRLEN len;
1493           #ifdef HAS_SIGPROCMASK
1494           sigset_t set, save;
1495           SV* save_sv;
1496           #endif
1497 3814323 100       const char *s = MgPV_const(mg,len);
    50        
1498            
1499           PERL_ARGS_ASSERT_MAGIC_SETSIG;
1500            
1501 3814323 100       if (*s == '_') {
1502 3809777 100       if (memEQs(s, len, "__DIE__"))
    100        
1503           svp = &PL_diehook;
1504 1151434 100       else if (memEQs(s, len, "__WARN__")
    50        
1505 1151428 100       && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
    50        
1506           /* Merge the existing behaviours, which are as follows:
1507           magic_setsig, we always set svp to &PL_warnhook
1508           (hence we always change the warnings handler)
1509           For magic_clearsig, we don't change the warnings handler if it's
1510           set to the &PL_warnhook. */
1511           svp = &PL_warnhook;
1512 6 50       } else if (sv) {
1513 6         SV *tmp = sv_newmortal();
1514 6         Perl_croak(aTHX_ "No such hook: %s",
1515           pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1516           }
1517           i = 0;
1518 3809771 50       if (svp && *svp) {
    100        
1519 603909 50       if (*svp != PERL_WARNHOOK_FATAL)
1520 603909         to_dec = *svp;
1521 603909         *svp = NULL;
1522           }
1523           }
1524           else {
1525 4546         i = (I16)mg->mg_private;
1526 4546 100       if (!i) {
1527 2652         i = whichsig_pvn(s, len); /* ...no, a brick */
1528 2652         mg->mg_private = (U16)i;
1529           }
1530 4546 100       if (i <= 0) {
1531 28 50       if (sv) {
1532 28         SV *tmp = sv_newmortal();
1533 28         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1534           pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1535           }
1536           return 0;
1537           }
1538           #ifdef HAS_SIGPROCMASK
1539           /* Avoid having the signal arrive at a bad time, if possible. */
1540 4518         sigemptyset(&set);
1541 4518         sigaddset(&set,i);
1542 4518         sigprocmask(SIG_BLOCK, &set, &save);
1543 4518         ENTER;
1544 4518         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1545 4518         SAVEFREESV(save_sv);
1546 4518         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1547           #endif
1548 4518 50       PERL_ASYNC_CHECK();
1549           #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1550           if (!PL_sig_handlers_initted) Perl_csighandler_init();
1551           #endif
1552           #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1553           PL_sig_ignoring[i] = 0;
1554           #endif
1555           #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1556           PL_sig_defaulting[i] = 0;
1557           #endif
1558 4518         to_dec = PL_psig_ptr[i];
1559 4518 100       if (sv) {
1560 4504         PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1561 4504         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1562            
1563           /* Signals don't change name during the program's execution, so once
1564           they're cached in the appropriate slot of PL_psig_name, they can
1565           stay there.
1566            
1567           Ideally we'd find some way of making SVs at (C) compile time, or
1568           at least, doing most of the work. */
1569 4504 100       if (!PL_psig_name[i]) {
1570 960         PL_psig_name[i] = newSVpvn(s, len);
1571 960         SvREADONLY_on(PL_psig_name[i]);
1572           }
1573           } else {
1574 14         SvREFCNT_dec(PL_psig_name[i]);
1575 14         PL_psig_name[i] = NULL;
1576 14         PL_psig_ptr[i] = NULL;
1577           }
1578           }
1579 3814289 100       if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
    50        
    0        
    100        
1580 606749 100       if (i) {
1581 2236         (void)rsignal(i, PL_csighandlerp);
1582           }
1583           else
1584 604513         *svp = SvREFCNT_inc_simple_NN(sv);
1585           } else {
1586 3207540 100       if (sv && SvOK(sv)) {
    100        
    50        
    50        
1587 1606 50       s = SvPV_force(sv, len);
1588           } else {
1589           sv = NULL;
1590           }
1591 3207540 100       if (sv && memEQs(s, len,"IGNORE")) {
    100        
    100        
1592 700 50       if (i) {
1593           #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1594           PL_sig_ignoring[i] = 1;
1595           (void)rsignal(i, PL_csighandlerp);
1596           #else
1597 700         (void)rsignal(i, (Sighandler_t) SIG_IGN);
1598           #endif
1599           }
1600           }
1601 3206840 100       else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
    100        
    100        
    100        
1602 3206796 100       if (i) {
1603           #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1604           PL_sig_defaulting[i] = 1;
1605           (void)rsignal(i, PL_csighandlerp);
1606           #else
1607 1540         (void)rsignal(i, (Sighandler_t) SIG_DFL);
1608           #endif
1609           }
1610           }
1611           else {
1612           /*
1613           * We should warn if HINT_STRICT_REFS, but without
1614           * access to a known hint bit in a known OP, we can't
1615           * tell whether HINT_STRICT_REFS is in force or not.
1616           */
1617 44 100       if (!strchr(s,':') && !strchr(s,'\''))
    50        
1618 32         Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1619           SV_GMAGIC);
1620 44 100       if (i)
1621 42         (void)rsignal(i, PL_csighandlerp);
1622           else
1623 2         *svp = SvREFCNT_inc_simple_NN(sv);
1624           }
1625           }
1626            
1627           #ifdef HAS_SIGPROCMASK
1628 3814289 100       if(i)
1629 4518         LEAVE;
1630           #endif
1631 3814289         SvREFCNT_dec(to_dec);
1632 3814303         return 0;
1633           }
1634           #endif /* !PERL_MICRO */
1635            
1636           int
1637 880654         Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1638           {
1639           dVAR;
1640           PERL_ARGS_ASSERT_MAGIC_SETISA;
1641           PERL_UNUSED_ARG(sv);
1642            
1643           /* Skip _isaelem because _isa will handle it shortly */
1644 880654 100       if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
    100        
1645           return 0;
1646            
1647 704319         return magic_clearisa(NULL, mg);
1648           }
1649            
1650           /* sv of NULL signifies that we're acting as magic_setisa. */
1651           int
1652 510076         Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1653           {
1654           dVAR;
1655           HV* stash;
1656            
1657           PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1658            
1659           /* Bail out if destruction is going on */
1660 510076 50       if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1661            
1662 510076 100       if (sv)
1663 16         av_clear(MUTABLE_AV(sv));
1664            
1665 510076 100       if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
    100        
1666           /* This occurs with setisa_elem magic, which calls this
1667           same function. */
1668 8         mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1669            
1670 510076 100       if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1671 74         SV **svp = AvARRAY((AV *)mg->mg_obj);
1672 74         I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1673 341 100       while (items--) {
1674 230         stash = GvSTASH((GV *)*svp++);
1675 230 100       if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
    50        
    50        
    50        
    50        
    50        
    50        
    50        
1676           }
1677            
1678           return 0;
1679           }
1680            
1681 510002         stash = GvSTASH(
1682           (const GV *)mg->mg_obj
1683           );
1684            
1685           /* The stash may have been detached from the symbol table, so check its
1686           name before doing anything. */
1687 510002 100       if (stash && HvENAME_get(stash))
    50        
    50        
    50        
    50        
    100        
    50        
    50        
1688 510037         mro_isa_changed_in(stash);
1689            
1690           return 0;
1691           }
1692            
1693           int
1694 172         Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1695           {
1696 172         HV * const hv = MUTABLE_HV(LvTARG(sv));
1697           I32 i = 0;
1698            
1699           PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1700           PERL_UNUSED_ARG(mg);
1701            
1702 172 50       if (hv) {
1703 172         (void) hv_iterinit(hv);
1704 172 50       if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
    0        
1705 172 100       i = HvUSEDKEYS(hv);
1706           else {
1707 0 0       while (hv_iternext(hv))
1708 0         i++;
1709           }
1710           }
1711            
1712 172         sv_setiv(sv, (IV)i);
1713 172         return 0;
1714           }
1715            
1716           int
1717 14         Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1718           {
1719           PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1720           PERL_UNUSED_ARG(mg);
1721 14 50       if (LvTARG(sv)) {
1722 14 100       hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1723           }
1724 14         return 0;
1725           }
1726            
1727           /*
1728           =for apidoc magic_methcall
1729            
1730           Invoke a magic method (like FETCH).
1731            
1732           C and C are the tied thingy and the tie magic.
1733            
1734           C is the name of the method to call.
1735            
1736           C is the number of args (in addition to $self) to pass to the method.
1737            
1738           The C can be:
1739            
1740           G_DISCARD invoke method with G_DISCARD flag and don't
1741           return a value
1742           G_UNDEF_FILL fill the stack with argc pointers to
1743           PL_sv_undef
1744            
1745           The arguments themselves are any values following the C argument.
1746            
1747           Returns the SV (if any) returned by the method, or NULL on failure.
1748            
1749            
1750           =cut
1751           */
1752            
1753           SV*
1754 4422851         Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1755           U32 argc, ...)
1756 4422851 50       {
1757           dVAR;
1758 4422851         dSP;
1759           SV* ret = NULL;
1760            
1761           PERL_ARGS_ASSERT_MAGIC_METHCALL;
1762            
1763 4422851         ENTER;
1764            
1765 4422851 100       if (flags & G_WRITING_TO_STDERR) {
1766 16         SAVETMPS;
1767            
1768 16         save_re_context();
1769 16         SAVESPTR(PL_stderrgv);
1770 16         PL_stderrgv = NULL;
1771           }
1772            
1773 4422851 100       PUSHSTACKi(PERLSI_MAGIC);
1774 4422851 50       PUSHMARK(SP);
1775            
1776 2211246         EXTEND(SP, argc+1);
1777 4422851 100       PUSHs(SvTIED_obj(sv, mg));
1778 4422851 50       if (flags & G_UNDEF_FILL) {
1779 0 0       while (argc--) {
1780 0         PUSHs(&PL_sv_undef);
1781           }
1782 4422851 100       } else if (argc > 0) {
1783           va_list args;
1784 4416005         va_start(args, argc);
1785            
1786           do {
1787 4426311 100       SV *const sv = va_arg(args, SV *);
1788 4426311         PUSHs(sv);
1789 4426311 100       } while (--argc);
1790            
1791 4416005         va_end(args);
1792           }
1793 4422851         PUTBACK;
1794 4422851 100       if (flags & G_DISCARD) {
1795 11750         call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1796           }
1797           else {
1798 4411101 50       if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1799 4411005         ret = *PL_stack_sp--;
1800           }
1801 4422711 50       POPSTACK;
1802 4422711 100       if (flags & G_WRITING_TO_STDERR)
1803 14 50       FREETMPS;
1804 4422711         LEAVE;
1805 4422711         return ret;
1806           }
1807            
1808           /* wrapper for magic_methcall that creates the first arg */
1809            
1810           STATIC SV*
1811 2400907         S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1812           int n, SV *val)
1813           {
1814           dVAR;
1815           SV* arg1 = NULL;
1816            
1817           PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1818            
1819 2400907 100       if (mg->mg_ptr) {
1820 2390457 100       if (mg->mg_len >= 0) {
1821 12         arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1822           }
1823 2390445 50       else if (mg->mg_len == HEf_SVKEY)
1824 2390445         arg1 = MUTABLE_SV(mg->mg_ptr);
1825           }
1826 10450 100       else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1827 6454         arg1 = newSViv((IV)(mg->mg_len));
1828 6454         sv_2mortal(arg1);
1829           }
1830 2400907 100       if (!arg1) {
1831 3996         return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1832           }
1833 2398866         return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1834           }
1835            
1836           STATIC int
1837 2388063         S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
1838           {
1839           dVAR;
1840           SV* ret;
1841            
1842           PERL_ARGS_ASSERT_MAGIC_METHPACK;
1843            
1844 2388063         ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1845 2387979 50       if (ret)
1846 2387979         sv_setsv(sv, ret);
1847 2387977         return 0;
1848           }
1849            
1850           int
1851 2297595         Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1852           {
1853           PERL_ARGS_ASSERT_MAGIC_GETPACK;
1854            
1855 2297595 100       if (mg->mg_type == PERL_MAGIC_tiedelem)
1856 2296137         mg->mg_flags |= MGf_GSKIP;
1857 2297595 100       magic_methpack(sv,mg,SV_CONST(FETCH));
1858 2297517         return 0;
1859           }
1860            
1861           int
1862 11104         Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1863           {
1864           dVAR;
1865           MAGIC *tmg;
1866           SV *val;
1867            
1868           PERL_ARGS_ASSERT_MAGIC_SETPACK;
1869            
1870           /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1871           * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1872           * public flags indicate its value based on copying from $val. Doing
1873           * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1874           * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1875           * wrong if $val happened to be tainted, as sv hasn't got magic
1876           * enabled, even though taint magic is in the chain. In which case,
1877           * fake up a temporary tainted value (this is easier than temporarily
1878           * re-enabling magic on sv). */
1879            
1880 11104 50       if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
    0        
1881 0 0       && (tmg->mg_len & 1))
1882           {
1883 0         val = sv_mortalcopy(sv);
1884 0 0       SvTAINTED_on(val);
1885           }
1886           else
1887           val = sv;
1888            
1889 11104 100       magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
1890 11066         return 0;
1891           }
1892            
1893           int
1894 1610         Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1895           {
1896           PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1897            
1898 1610 100       if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
1899 1608 100       return magic_methpack(sv,mg,SV_CONST(DELETE));
1900           }
1901            
1902            
1903           U32
1904 1740         Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1905           {
1906           dVAR;
1907           I32 retval = 0;
1908           SV* retsv;
1909            
1910           PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1911            
1912 1740 100       retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
1913 1732 50       if (retsv) {
1914 1732 50       retval = SvIV(retsv)-1;
1915 1732 100       if (retval < -1)
1916 2         Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1917           }
1918 1730         return (U32) retval;
1919           }
1920            
1921           int
1922 312         Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1923           {
1924           dVAR;
1925            
1926           PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1927            
1928 312 100       Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
1929 308         return 0;
1930           }
1931            
1932           int
1933 2021206         Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1934           {
1935           dVAR;
1936           SV* ret;
1937            
1938           PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1939            
1940 2022828 50       ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
    50        
    100        
1941 4040790 100       : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
    100        
1942 2021202 50       if (ret)
1943 2021202         sv_setsv(key,ret);
1944 2021202         return 0;
1945           }
1946            
1947           int
1948 88862         Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1949           {
1950           PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1951            
1952 88862 100       return magic_methpack(sv,mg,SV_CONST(EXISTS));
1953           }
1954            
1955           SV *
1956 40         Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1957           {
1958           dVAR;
1959           SV *retval;
1960 40 50       SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1961 40         HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1962          
1963           PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1964            
1965 40 100       if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1966           SV *key;
1967 10 100       if (HvEITER_get(hv))
    100        
1968           /* we are in an iteration so the hash cannot be empty */
1969           return &PL_sv_yes;
1970           /* no xhv_eiter so now use FIRSTKEY */
1971 8         key = sv_newmortal();
1972 8         magic_nextpack(MUTABLE_SV(hv), mg, key);
1973 8         HvEITER_set(hv, NULL); /* need to reset iterator */
1974 8 100       return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
    50        
    50        
1975           }
1976          
1977           /* there is a SCALAR method that we can call */
1978 30 100       retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
1979 30 50       if (!retval)
1980           retval = &PL_sv_undef;
1981 35         return retval;
1982           }
1983            
1984           int
1985 130         Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1986           {
1987           dVAR;
1988           SV **svp;
1989            
1990           PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1991            
1992           /* The magic ptr/len for the debugger's hash should always be an SV. */
1993 130 50       if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
1994 0         Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'",
1995           mg->mg_len, mg->mg_ptr);
1996           }
1997            
1998           /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
1999           setting/clearing debugger breakpoints is not a hot path. */
2000 130         svp = av_fetch(GvAV(PL_DBline), sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2001            
2002 130 50       if (svp && SvIOKp(*svp)) {
    50        
2003 130         OP * const o = INT2PTR(OP*,SvIVX(*svp));
2004 130 50       if (o) {
2005           #ifdef PERL_DEBUG_READONLY_OPS
2006           Slab_to_rw(OpSLAB(o));
2007           #endif
2008           /* set or clear breakpoint in the relevant control op */
2009 130 50       if (SvTRUE(sv))
    50        
    0        
    50        
    0        
    0        
    50        
    50        
    100        
    100        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
2010 118         o->op_flags |= OPf_SPECIAL;
2011           else
2012 12         o->op_flags &= ~OPf_SPECIAL;
2013           #ifdef PERL_DEBUG_READONLY_OPS
2014           Slab_to_ro(OpSLAB(o));
2015           #endif
2016           }
2017           }
2018 130         return 0;
2019           }
2020            
2021           int
2022 354         Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2023           {
2024           dVAR;
2025 354         AV * const obj = MUTABLE_AV(mg->mg_obj);
2026            
2027           PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2028            
2029 354 100       if (obj) {
2030 338 50       sv_setiv(sv, AvFILL(obj));
2031           } else {
2032 16         sv_setsv(sv, NULL);
2033           }
2034 354         return 0;
2035           }
2036            
2037           int
2038 50210         Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2039           {
2040           dVAR;
2041 50210         AV * const obj = MUTABLE_AV(mg->mg_obj);
2042            
2043           PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2044            
2045 50210 100       if (obj) {
2046 50190 100       av_fill(obj, SvIV(sv));
2047           } else {
2048 20         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2049           "Attempt to set length of freed array");
2050           }
2051 50208         return 0;
2052           }
2053            
2054           int
2055 14778         Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2056           {
2057           dVAR;
2058            
2059           PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2060           PERL_UNUSED_ARG(sv);
2061            
2062           /* Reset the iterator when the array is cleared */
2063           #if IVSIZE == I32SIZE
2064           *((IV *) &(mg->mg_len)) = 0;
2065           #else
2066 14778 100       if (mg->mg_ptr)
2067 10         *((IV *) mg->mg_ptr) = 0;
2068           #endif
2069            
2070 14778         return 0;
2071           }
2072            
2073           int
2074 15240         Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2075           {
2076           dVAR;
2077            
2078           PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2079           PERL_UNUSED_ARG(sv);
2080            
2081           /* during global destruction, mg_obj may already have been freed */
2082 15240 50       if (PL_in_clean_all)
2083           return 0;
2084            
2085 15240         mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2086            
2087 15240 100       if (mg) {
2088           /* arylen scalar holds a pointer back to the array, but doesn't own a
2089           reference. Hence the we (the array) are about to go away with it
2090           still pointing at us. Clear its pointer, else it would be pointing
2091           at free memory. See the comment in sv_magic about reference loops,
2092           and why it can't own a reference to us. */
2093 15231         mg->mg_obj = 0;
2094           }
2095           return 0;
2096           }
2097            
2098           int
2099 9316         Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2100           {
2101           dVAR;
2102 9316         SV* const lsv = LvTARG(sv);
2103 9316         MAGIC * const found = mg_find_mglob(lsv);
2104            
2105           PERL_ARGS_ASSERT_MAGIC_GETPOS;
2106           PERL_UNUSED_ARG(mg);
2107            
2108 9316 100       if (found && found->mg_len != -1) {
    100        
2109 9182         STRLEN i = found->mg_len;
2110 9182 100       if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
    100        
    50        
2111 2         i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2112 9182         sv_setuv(sv, i);
2113 9182         return 0;
2114           }
2115 134         sv_setsv(sv,NULL);
2116 4725         return 0;
2117           }
2118            
2119           int
2120 74644         Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2121           {
2122           dVAR;
2123 74644         SV* const lsv = LvTARG(sv);
2124           SSize_t pos;
2125           STRLEN len;
2126           STRLEN ulen = 0;
2127           MAGIC* found;
2128           const char *s;
2129            
2130           PERL_ARGS_ASSERT_MAGIC_SETPOS;
2131           PERL_UNUSED_ARG(mg);
2132            
2133 74644         found = mg_find_mglob(lsv);
2134 74644 100       if (!found) {
2135 63544 100       if (!SvOK(sv))
    50        
    50        
2136           return 0;
2137 63246         found = sv_magicext_mglob(lsv);
2138           }
2139 11100 100       else if (!SvOK(sv)) {
    50        
    50        
2140 46         found->mg_len = -1;
2141 46         return 0;
2142           }
2143 74300 100       s = SvPV_const(lsv, len);
2144            
2145 74300 100       pos = SvIV(sv);
2146            
2147 74300 100       if (DO_UTF8(lsv)) {
    50        
2148 1046 100       ulen = sv_or_pv_len_utf8(lsv, s, len);
    100        
    50        
    50        
2149 1046 50       if (ulen)
2150 1046         len = ulen;
2151           }
2152            
2153 74300 50       if (pos < 0) {
2154 0         pos += len;
2155 0 0       if (pos < 0)
2156           pos = 0;
2157           }
2158 74300 100       else if (pos > (SSize_t)len)
2159 4         pos = len;
2160            
2161 74300         found->mg_len = pos;
2162 74300         found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2163            
2164 74472         return 0;
2165           }
2166            
2167           int
2168 65064         Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2169           {
2170           STRLEN len;
2171 65064         SV * const lsv = LvTARG(sv);
2172 65064 100       const char * const tmps = SvPV_const(lsv,len);
2173 65064         STRLEN offs = LvTARGOFF(sv);
2174 65064         STRLEN rem = LvTARGLEN(sv);
2175 65064         const bool negoff = LvFLAGS(sv) & 1;
2176 65064         const bool negrem = LvFLAGS(sv) & 2;
2177            
2178           PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2179           PERL_UNUSED_ARG(mg);
2180            
2181 65064 100       if (!translate_substr_offsets(
    100        
    100        
    50        
    100        
    50        
    100        
    100        
2182           SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2183           negoff ? -(IV)offs : (IV)offs, !negoff,
2184           negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2185           )) {
2186 2         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2187 2         sv_setsv_nomg(sv, &PL_sv_undef);
2188 2         return 0;
2189           }
2190            
2191 65062 100       if (SvUTF8(lsv))
2192 4002         offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2193 65062         sv_setpvn(sv, tmps + offs, rem);
2194 65062 100       if (SvUTF8(lsv))
2195 33866         SvUTF8_on(sv);
2196           return 0;
2197           }
2198            
2199           int
2200 4120         Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2201 4120 50       {
2202           dVAR;
2203           STRLEN len, lsv_len, oldtarglen, newtarglen;
2204 4120 100       const char * const tmps = SvPV_const(sv, len);
2205 4120         SV * const lsv = LvTARG(sv);
2206 4120         STRLEN lvoff = LvTARGOFF(sv);
2207 4120         STRLEN lvlen = LvTARGLEN(sv);
2208 4120         const bool negoff = LvFLAGS(sv) & 1;
2209 4120         const bool neglen = LvFLAGS(sv) & 2;
2210            
2211           PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2212           PERL_UNUSED_ARG(mg);
2213            
2214 2060         SvGETMAGIC(lsv);
2215 4120 100       if (SvROK(lsv))
2216 6         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2217           "Attempt to use reference as lvalue in substr"
2218           );
2219 4120 100       SvPV_force_nomg(lsv,lsv_len);
2220 4120 100       if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2221 4120 100       if (!translate_substr_offsets(
    100        
    50        
2222           lsv_len,
2223           negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2224           neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2225           ))
2226 0         Perl_croak(aTHX_ "substr outside of string");
2227 4120         oldtarglen = lvlen;
2228 4120 100       if (DO_UTF8(sv)) {
    50        
2229 6         sv_utf8_upgrade_nomg(lsv);
2230 6         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2231 6         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2232 6 50       newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
    100        
    50        
    50        
2233 6         SvUTF8_on(lsv);
2234           }
2235 4114 100       else if (SvUTF8(lsv)) {
2236           const char *utf8;
2237 4         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2238 4         newtarglen = len;
2239 4         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2240 4         sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2241 4         Safefree(utf8);
2242           }
2243           else {
2244 4110         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2245 4110         newtarglen = len;
2246           }
2247 4120 100       if (!neglen) LvTARGLEN(sv) = newtarglen;
2248 4120 100       if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
2249            
2250 4120         return 0;
2251           }
2252            
2253           int
2254 1127864         Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2255           {
2256           dVAR;
2257            
2258           PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2259           PERL_UNUSED_ARG(sv);
2260           #ifdef NO_TAINT_SUPPORT
2261           PERL_UNUSED_ARG(mg);
2262           #endif
2263            
2264 1127864 100       TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
    100        
2265 1127864         return 0;
2266           }
2267            
2268           int
2269 7044         Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2270           {
2271           dVAR;
2272            
2273           PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2274           PERL_UNUSED_ARG(sv);
2275            
2276           /* update taint status */
2277 7044 100       if (TAINT_get)
2278 5402         mg->mg_len |= 1;
2279           else
2280 1642         mg->mg_len &= ~1;
2281 7044         return 0;
2282           }
2283            
2284           int
2285 40         Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2286           {
2287 40         SV * const lsv = LvTARG(sv);
2288            
2289           PERL_ARGS_ASSERT_MAGIC_GETVEC;
2290           PERL_UNUSED_ARG(mg);
2291            
2292 40         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2293            
2294 40         return 0;
2295           }
2296            
2297           int
2298 5038378         Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2299           {
2300           PERL_ARGS_ASSERT_MAGIC_SETVEC;
2301           PERL_UNUSED_ARG(mg);
2302 5038378         do_vecset(sv); /* XXX slurp this routine */
2303 5038374         return 0;
2304           }
2305            
2306           SV *
2307 120360         Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2308           {
2309           dVAR;
2310           SV *targ = NULL;
2311           PERL_ARGS_ASSERT_DEFELEM_TARGET;
2312 120360 100       if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2313           assert(mg);
2314 120360 100       if (LvTARGLEN(sv)) {
2315 92928 100       if (mg->mg_obj) {
2316 65876         SV * const ahv = LvTARG(sv);
2317 65876         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2318 65876 100       if (he)
2319 2         targ = HeVAL(he);
2320           }
2321 27052 100       else if (LvSTARGOFF(sv) >= 0) {
2322 27044         AV *const av = MUTABLE_AV(LvTARG(sv));
2323 27044 50       if (LvSTARGOFF(sv) <= AvFILL(av))
    100        
2324 26608         targ = AvARRAY(av)[LvSTARGOFF(sv)];
2325           }
2326 92928 100       if (targ && (targ != &PL_sv_undef)) {
    50        
2327           /* somebody else defined it for us */
2328 2         SvREFCNT_dec(LvTARG(sv));
2329 2         LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2330 2         LvTARGLEN(sv) = 0;
2331 2         SvREFCNT_dec(mg->mg_obj);
2332 2         mg->mg_obj = NULL;
2333 2         mg->mg_flags &= ~MGf_REFCOUNTED;
2334           }
2335           return targ;
2336           }
2337           else
2338 73896         return LvTARG(sv);
2339           }
2340            
2341           int
2342 120350         Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2343           {
2344           PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2345            
2346 120350         sv_setsv(sv, defelem_target(sv, mg));
2347 120350         return 0;
2348           }
2349            
2350           int
2351 27212         Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2352           {
2353           PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2354           PERL_UNUSED_ARG(mg);
2355 27212 100       if (LvTARGLEN(sv))
2356 27130         vivify_defelem(sv);
2357 27204 50       if (LvTARG(sv)) {
2358 27204         sv_setsv(LvTARG(sv), sv);
2359 27204 100       SvSETMAGIC(LvTARG(sv));
2360           }
2361 27204         return 0;
2362           }
2363            
2364           void
2365 27164         Perl_vivify_defelem(pTHX_ SV *sv)
2366           {
2367           dVAR;
2368           MAGIC *mg;
2369           SV *value = NULL;
2370            
2371           PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2372            
2373 54304 100       if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
    50        
2374 27156         return;
2375 27140 100       if (mg->mg_obj) {
2376 522         SV * const ahv = LvTARG(sv);
2377 522         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2378 522 50       if (he)
2379 522         value = HeVAL(he);
2380 522 50       if (!value || value == &PL_sv_undef)
    50        
2381 0         Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2382           }
2383 26618 100       else if (LvSTARGOFF(sv) < 0)
2384 8         Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2385           else {
2386 26610         AV *const av = MUTABLE_AV(LvTARG(sv));
2387 26610 100       if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
    50        
    50        
2388 0         LvTARG(sv) = NULL; /* array can't be extended */
2389           else {
2390 26610         SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2391 26610 50       if (!svp || !(value = *svp))
    50        
2392 0         Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2393           }
2394           }
2395 27132 50       SvREFCNT_inc_simple_void(value);
2396 27132         SvREFCNT_dec(LvTARG(sv));
2397 27132         LvTARG(sv) = value;
2398 27132         LvTARGLEN(sv) = 0;
2399 27132         SvREFCNT_dec(mg->mg_obj);
2400 27132         mg->mg_obj = NULL;
2401 27132         mg->mg_flags &= ~MGf_REFCOUNTED;
2402           }
2403            
2404           int
2405 1550402         Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2406           {
2407           PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2408 1550402         Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2409 1550402         return 0;
2410           }
2411            
2412           int
2413 4621591         Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2414           {
2415           PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2416           PERL_UNUSED_CONTEXT;
2417           PERL_UNUSED_ARG(sv);
2418 4621591         mg->mg_len = -1;
2419 4621591         return 0;
2420           }
2421            
2422           int
2423 40106         Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2424           {
2425 40106         const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2426            
2427           PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2428            
2429 40106 50       if (uf && uf->uf_set)
    100        
2430 40102         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2431 40106         return 0;
2432           }
2433            
2434           int
2435 252         Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2436           {
2437 252         const char type = mg->mg_type;
2438            
2439           PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2440            
2441 252 50       if (type == PERL_MAGIC_qr) {
2442 252 50       } else if (type == PERL_MAGIC_bm) {
2443 0         SvTAIL_off(sv);
2444 0         SvVALID_off(sv);
2445           } else {
2446           assert(type == PERL_MAGIC_fm);
2447           }
2448 252         return sv_unmagic(sv, type);
2449           }
2450            
2451           #ifdef USE_LOCALE_COLLATE
2452           int
2453 0         Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2454           {
2455           PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2456            
2457           /*
2458           * RenE Descartes said "I think not."
2459           * and vanished with a faint plop.
2460           */
2461           PERL_UNUSED_CONTEXT;
2462           PERL_UNUSED_ARG(sv);
2463 0 0       if (mg->mg_ptr) {
2464 0         Safefree(mg->mg_ptr);
2465 0         mg->mg_ptr = NULL;
2466 0         mg->mg_len = -1;
2467           }
2468 0         return 0;
2469           }
2470           #endif /* USE_LOCALE_COLLATE */
2471            
2472           /* Just clear the UTF-8 cache data. */
2473           int
2474 103680         Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2475           {
2476           PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2477           PERL_UNUSED_CONTEXT;
2478           PERL_UNUSED_ARG(sv);
2479 103680         Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2480 103680         mg->mg_ptr = NULL;
2481 51840         mg->mg_len = -1; /* The mg_len holds the len cache. */
2482 103680         return 0;
2483           }
2484            
2485           int
2486 29860388         Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2487           {
2488           dVAR;
2489           const char *s;
2490           I32 paren;
2491           const REGEXP * rx;
2492 29860388         const char * const remaining = mg->mg_ptr + 1;
2493           I32 i;
2494           STRLEN len;
2495           MAGIC *tmg;
2496            
2497           PERL_ARGS_ASSERT_MAGIC_SET;
2498            
2499 29860388         switch (*mg->mg_ptr) {
2500           case '\015': /* $^MATCH */
2501 0 0       if (strEQ(remaining, "ATCH"))
2502           goto do_match;
2503           case '`': /* ${^PREMATCH} caught below */
2504           do_prematch:
2505           paren = RX_BUFF_IDX_PREMATCH;
2506           goto setparen;
2507           case '\'': /* ${^POSTMATCH} caught below */
2508           do_postmatch:
2509           paren = RX_BUFF_IDX_POSTMATCH;
2510 0         goto setparen;
2511           case '&':
2512           do_match:
2513           paren = RX_BUFF_IDX_FULLMATCH;
2514 0         goto setparen;
2515           case '1': case '2': case '3': case '4':
2516           case '5': case '6': case '7': case '8': case '9':
2517 297568         paren = atoi(mg->mg_ptr);
2518           setparen:
2519 297568 100       if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
    50        
2520           setparen_got_rx:
2521 294292         CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2522           } else {
2523           /* Croak with a READONLY error when a numbered match var is
2524           * set without a previous pattern match. Unless it's C
2525           */
2526           croakparen:
2527 3276 100       if (!PL_localizing) {
2528 8         Perl_croak_no_modify();
2529           }
2530           }
2531           break;
2532           case '\001': /* ^A */
2533 3194 100       if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
    50        
    50        
2534 1598 100       else SvOK_off(PL_bodytarget);
2535 3194         FmLINES(PL_bodytarget) = 0;
2536 3194 100       if (SvPOK(PL_bodytarget)) {
2537 1596         char *s = SvPVX(PL_bodytarget);
2538 2414 100       while ( ((s = strchr(s, '\n'))) ) {
2539 20         FmLINES(PL_bodytarget)++;
2540 20         s++;
2541           }
2542           }
2543           /* mg_set() has temporarily made sv non-magical */
2544 3194 50       if (TAINTING_get) {
2545 0 0       if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
    0        
2546 0 0       SvTAINTED_on(PL_bodytarget);
2547           else
2548 0 0       SvTAINTED_off(PL_bodytarget);
2549           }
2550           break;
2551           case '\003': /* ^C */
2552 8 100       PL_minus_c = cBOOL(SvIV(sv));
2553 8         break;
2554            
2555           case '\004': /* ^D */
2556           #ifdef DEBUGGING
2557           s = SvPV_nolen_const(sv);
2558           PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2559           if (DEBUG_x_TEST || DEBUG_B_TEST)
2560           dump_all_perl(!DEBUG_B_TEST);
2561           #else
2562 388 50       PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2563           #endif
2564 388         break;
2565           case '\005': /* ^E */
2566 171852 100       if (*(mg->mg_ptr+1) == '\0') {
2567           #ifdef VMS
2568           set_vaxc_errno(SvIV(sv));
2569           #else
2570           # ifdef WIN32
2571           SetLastError( SvIV(sv) );
2572           # else
2573           # ifdef OS2
2574           os2_setsyserrno(SvIV(sv));
2575           # else
2576           /* will anyone ever use this? */
2577 141972 100       SETERRNO(SvIV(sv), 4);
2578           # endif
2579           # endif
2580           #endif
2581           }
2582 29880 50       else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2583 29880         SvREFCNT_dec(PL_encoding);
2584 29880 100       if (SvOK(sv) || SvGMAGICAL(sv)) {
    50        
    50        
    50        
2585 11530         PL_encoding = newSVsv(sv);
2586           }
2587           else {
2588 18350         PL_encoding = NULL;
2589           }
2590           }
2591           break;
2592           case '\006': /* ^F */
2593 1294 100       PL_maxsysfd = SvIV(sv);
2594 1294         break;
2595           case '\010': /* ^H */
2596 2240448 100       PL_hints = SvIV(sv);
2597 2240448         break;
2598           case '\011': /* ^I */ /* NOT \t in EBCDIC */
2599 46         Safefree(PL_inplace);
2600 46 100       PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
    50        
    50        
2601 46         break;
2602           case '\016': /* ^N */
2603 0 0       if (PL_curpm && (rx = PM_GETRE(PL_curpm))
    0        
2604 0 0       && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2605           goto croakparen;
2606           case '\017': /* ^O */
2607 646 100       if (*(mg->mg_ptr+1) == '\0') {
2608 214         Safefree(PL_osname);
2609 214         PL_osname = NULL;
2610 214 100       if (SvOK(sv)) {
    50        
    50        
2611 210 100       TAINT_PROPER("assigning to $^O");
2612 210         PL_osname = savesvpv(sv);
2613           }
2614           }
2615 432 50       else if (strEQ(mg->mg_ptr, "\017PEN")) {
2616           STRLEN len;
2617 432 50       const char *const start = SvPV(sv, len);
2618 432         const char *out = (const char*)memchr(start, '\0', len);
2619           SV *tmp;
2620            
2621            
2622 432         PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2623 432         PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2624            
2625           /* Opening for input is more common than opening for output, so
2626           ensure that hints for input are sooner on linked list. */
2627 432         tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2628           SvUTF8(sv))
2629 648 50       : newSVpvs_flags("", SvUTF8(sv));
2630 432         (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2631 432         mg_set(tmp);
2632            
2633 432 50       tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2634           SvUTF8(sv));
2635 432         (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2636 432         mg_set(tmp);
2637           }
2638           break;
2639           case '\020': /* ^P */
2640 4762 50       if (*remaining == '\0') { /* ^P */
2641 4762 100       PL_perldb = SvIV(sv);
2642 4762 100       if (PL_perldb && !PL_DBsingle)
    100        
2643 4678         init_debugger();
2644           break;
2645 0 0       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2646           goto do_prematch;
2647 0 0       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2648           goto do_postmatch;
2649           }
2650           break;
2651           case '\024': /* ^T */
2652           #ifdef BIG_TIME
2653           PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2654           #else
2655 0 0       PL_basetime = (Time_t)SvIV(sv);
2656           #endif
2657 0         break;
2658           case '\025': /* ^UTF8CACHE */
2659 36 50       if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2660 36         PL_utf8cache = (signed char) sv_2iv(sv);
2661           }
2662           break;
2663           case '\027': /* ^W & $^WARNING_BITS */
2664 16831824 100       if (*(mg->mg_ptr+1) == '\0') {
2665 16463772 100       if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2666 16460234 100       i = SvIV(sv);
2667 24690351         PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2668 16460234         | (i ? G_WARN_ON : G_WARN_OFF) ;
2669           }
2670           }
2671 368052 50       else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2672 368052 100       if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2673 367822 100       if (!SvPOK(sv)) {
2674 8         PL_compiling.cop_warnings = pWARN_STD;
2675 8         break;
2676           }
2677           {
2678           STRLEN len, i;
2679           int accumulate = 0 ;
2680           int any_fatals = 0 ;
2681 367814 50       const char * const ptr = SvPV_const(sv, len) ;
2682 5900894 100       for (i = 0 ; i < len ; ++i) {
2683 5533080         accumulate |= ptr[i] ;
2684 5533080         any_fatals |= (ptr[i] & 0xAA) ;
2685           }
2686 367814 100       if (!accumulate) {
2687 5482 100       if (!specialWARN(PL_compiling.cop_warnings))
    100        
2688 100         PerlMemShared_free(PL_compiling.cop_warnings);
2689 5482         PL_compiling.cop_warnings = pWARN_NONE;
2690           }
2691           /* Yuck. I can't see how to abstract this: */
2692 362332 50       else if (isWARN_on(
    100        
2693           ((STRLEN *)SvPV_nolen_const(sv)) - 1,
2694           WARN_ALL)
2695 212676 100       && !any_fatals)
2696           {
2697 212510 100       if (!specialWARN(PL_compiling.cop_warnings))
    100        
2698 36         PerlMemShared_free(PL_compiling.cop_warnings);
2699 212510         PL_compiling.cop_warnings = pWARN_ALL;
2700 212510         PL_dowarn |= G_WARN_ONCE ;
2701           }
2702           else {
2703           STRLEN len;
2704 149822 50       const char *const p = SvPV_const(sv, len);
2705            
2706           PL_compiling.cop_warnings
2707 149822         = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2708           p, len);
2709            
2710 149822 100       if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2711 122432         PL_dowarn |= G_WARN_ONCE ;
2712           }
2713            
2714           }
2715           }
2716           }
2717           break;
2718           case '.':
2719 1531772 100       if (PL_localizing) {
2720 1510560 100       if (PL_localizing == 1)
2721 755280         SAVESPTR(PL_last_in_gv);
2722           }
2723 21212 50       else if (SvOK(sv) && GvIO(PL_last_in_gv))
    0        
    0        
    100        
    100        
    50        
    50        
2724 6846 50       IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2725           break;
2726           case '^':
2727 46         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2728 46         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2729 46         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2730 46         break;
2731           case '~':
2732 182         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2733 182         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2734 182         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2735 182         break;
2736           case '=':
2737 38 100       IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2738 38         break;
2739           case '-':
2740 12 50       IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2741 12 50       if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2742 0         IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2743           break;
2744           case '%':
2745 2 50       IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2746 2         break;
2747           case '|':
2748           {
2749 25998 50       IO * const io = GvIO(PL_defoutgv);
    50        
    50        
2750 25998 50       if(!io)
2751           break;
2752 25998 100       if ((SvIV(sv)) == 0)
    100        
2753 1234         IoFLAGS(io) &= ~IOf_FLUSH;
2754           else {
2755 24764 100       if (!(IoFLAGS(io) & IOf_FLUSH)) {
2756 20072         PerlIO *ofp = IoOFP(io);
2757 20072 100       if (ofp)
2758 19758         (void)PerlIO_flush(ofp);
2759 20072         IoFLAGS(io) |= IOf_FLUSH;
2760           }
2761           }
2762           }
2763           break;
2764           case '/':
2765 658050         SvREFCNT_dec(PL_rs);
2766 658050         PL_rs = newSVsv(sv);
2767 658050         break;
2768           case '\\':
2769 3217944         SvREFCNT_dec(PL_ors_sv);
2770 3217944 100       if (SvOK(sv)) {
    50        
    50        
2771 44280         PL_ors_sv = newSVsv(sv);
2772           }
2773           else {
2774 3173664         PL_ors_sv = NULL;
2775           }
2776           break;
2777           case '[':
2778 2 50       if (SvIV(sv) != 0)
    50        
2779 2         Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2780           break;
2781           case '?':
2782           #ifdef COMPLEX_STATUS
2783           if (PL_localizing == 2) {
2784           SvUPGRADE(sv, SVt_PVLV);
2785           PL_statusvalue = LvTARGOFF(sv);
2786           PL_statusvalue_vms = LvTARGLEN(sv);
2787           }
2788           else
2789           #endif
2790           #ifdef VMSISH_STATUS
2791           if (VMSISH_STATUS)
2792           STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2793           else
2794           #endif
2795 68170 100       STATUS_UNIX_EXIT_SET(SvIV(sv));
    100        
2796           break;
2797           case '!':
2798           {
2799           #ifdef VMS
2800           # define PERL_VMS_BANG vaxc$errno
2801           #else
2802           # define PERL_VMS_BANG 0
2803           #endif
2804 4805852 100       SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
    100        
    50        
    50        
2805           (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2806           }
2807 4805852         break;
2808           case '<':
2809           {
2810 0 0       const Uid_t new_uid = SvUID(sv);
2811 0         PL_delaymagic_uid = new_uid;
2812 0 0       if (PL_delaymagic) {
2813 0         PL_delaymagic |= DM_RUID;
2814 0         break; /* don't do magic till later */
2815           }
2816           #ifdef HAS_SETRUID
2817           (void)setruid(new_uid);
2818           #else
2819           #ifdef HAS_SETREUID
2820 0         (void)setreuid(new_uid, (Uid_t)-1);
2821           #else
2822           #ifdef HAS_SETRESUID
2823           (void)setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
2824           #else
2825           if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
2826           #ifdef PERL_DARWIN
2827           /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2828           if (new_uid != 0 && PerlProc_getuid() == 0)
2829           (void)PerlProc_setuid(0);
2830           #endif
2831           (void)PerlProc_setuid(new_uid);
2832           } else {
2833           Perl_croak(aTHX_ "setruid() not implemented");
2834           }
2835           #endif
2836           #endif
2837           #endif
2838 0         break;
2839           }
2840           case '>':
2841           {
2842 8 50       const Uid_t new_euid = SvUID(sv);
2843 8         PL_delaymagic_euid = new_euid;
2844 8 50       if (PL_delaymagic) {
2845 0         PL_delaymagic |= DM_EUID;
2846 0         break; /* don't do magic till later */
2847           }
2848           #ifdef HAS_SETEUID
2849 8         (void)seteuid(new_euid);
2850           #else
2851           #ifdef HAS_SETREUID
2852           (void)setreuid((Uid_t)-1, new_euid);
2853           #else
2854           #ifdef HAS_SETRESUID
2855           (void)setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
2856           #else
2857           if (new_euid == PerlProc_getuid()) /* special case $> = $< */
2858           PerlProc_setuid(new_euid);
2859           else {
2860           Perl_croak(aTHX_ "seteuid() not implemented");
2861           }
2862           #endif
2863           #endif
2864           #endif
2865 8         break;
2866           }
2867           case '(':
2868           {
2869 0 0       const Gid_t new_gid = SvGID(sv);
2870 0         PL_delaymagic_gid = new_gid;
2871 0 0       if (PL_delaymagic) {
2872 0         PL_delaymagic |= DM_RGID;
2873 0         break; /* don't do magic till later */
2874           }
2875           #ifdef HAS_SETRGID
2876           (void)setrgid(new_gid);
2877           #else
2878           #ifdef HAS_SETREGID
2879 0         (void)setregid(new_gid, (Gid_t)-1);
2880           #else
2881           #ifdef HAS_SETRESGID
2882           (void)setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
2883           #else
2884           if (new_gid == PerlProc_getegid()) /* special case $( = $) */
2885           (void)PerlProc_setgid(new_gid);
2886           else {
2887           Perl_croak(aTHX_ "setrgid() not implemented");
2888           }
2889           #endif
2890           #endif
2891           #endif
2892 0         break;
2893           }
2894           case ')':
2895           {
2896           Gid_t new_egid;
2897           #ifdef HAS_SETGROUPS
2898           {
2899 0 0       const char *p = SvPV_const(sv, len);
2900           Groups_t *gary = NULL;
2901           #ifdef _SC_NGROUPS_MAX
2902 0         int maxgrp = sysconf(_SC_NGROUPS_MAX);
2903            
2904 0 0       if (maxgrp < 0)
2905           maxgrp = NGROUPS;
2906           #else
2907           int maxgrp = NGROUPS;
2908           #endif
2909            
2910 0 0       while (isSPACE(*p))
2911 0         ++p;
2912 0         new_egid = (Gid_t)Atol(p);
2913 0 0       for (i = 0; i < maxgrp; ++i) {
2914 0 0       while (*p && !isSPACE(*p))
    0        
2915 0         ++p;
2916 0 0       while (isSPACE(*p))
2917 0         ++p;
2918 0 0       if (!*p)
2919           break;
2920 0 0       if(!gary)
2921 0 0       Newx(gary, i + 1, Groups_t);
2922           else
2923 0 0       Renew(gary, i + 1, Groups_t);
2924 0         gary[i] = (Groups_t)Atol(p);
2925           }
2926 0 0       if (i)
2927 0         (void)setgroups(i, gary);
2928 0         Safefree(gary);
2929           }
2930           #else /* HAS_SETGROUPS */
2931           new_egid = SvGID(sv);
2932           #endif /* HAS_SETGROUPS */
2933 0         PL_delaymagic_egid = new_egid;
2934 0 0       if (PL_delaymagic) {
2935 0         PL_delaymagic |= DM_EGID;
2936 0         break; /* don't do magic till later */
2937           }
2938           #ifdef HAS_SETEGID
2939 0         (void)setegid(new_egid);
2940           #else
2941           #ifdef HAS_SETREGID
2942           (void)setregid((Gid_t)-1, new_egid);
2943           #else
2944           #ifdef HAS_SETRESGID
2945           (void)setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
2946           #else
2947           if (new_egid == PerlProc_getgid()) /* special case $) = $( */
2948           (void)PerlProc_setgid(new_egid);
2949           else {
2950           Perl_croak(aTHX_ "setegid() not implemented");
2951           }
2952           #endif
2953           #endif
2954           #endif
2955 0         break;
2956           }
2957           case ':':
2958 60 50       PL_chopset = SvPV_force(sv,len);
2959 60         break;
2960           case '$': /* $$ */
2961           /* Store the pid in mg->mg_obj so we can tell when a fork has
2962           occurred. mg->mg_obj points to *$ by default, so clear it. */
2963 2 50       if (isGV(mg->mg_obj)) {
2964 2 50       if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2965 0         SvREFCNT_dec(mg->mg_obj);
2966 2         mg->mg_flags |= MGf_REFCOUNTED;
2967 2         mg->mg_obj = newSViv((IV)PerlProc_getpid());
2968           }
2969 0         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2970           break;
2971           case '0':
2972           LOCK_DOLLARZERO_MUTEX;
2973           #ifdef HAS_SETPROCTITLE
2974           /* The BSDs don't show the argv[] in ps(1) output, they
2975           * show a string from the process struct and provide
2976           * the setproctitle() routine to manipulate that. */
2977           if (PL_origalen != 1) {
2978           s = SvPV_const(sv, len);
2979           # if __FreeBSD_version > 410001
2980           /* The leading "-" removes the "perl: " prefix,
2981           * but not the "(perl) suffix from the ps(1)
2982           * output, because that's what ps(1) shows if the
2983           * argv[] is modified. */
2984           setproctitle("-%s", s);
2985           # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2986           /* This doesn't really work if you assume that
2987           * $0 = 'foobar'; will wipe out 'perl' from the $0
2988           * because in ps(1) output the result will be like
2989           * sprintf("perl: %s (perl)", s)
2990           * I guess this is a security feature:
2991           * one (a user process) cannot get rid of the original name.
2992           * --jhi */
2993           setproctitle("%s", s);
2994           # endif
2995           }
2996           #elif defined(__hpux) && defined(PSTAT_SETCMD)
2997           if (PL_origalen != 1) {
2998           union pstun un;
2999           s = SvPV_const(sv, len);
3000           un.pst_command = (char *)s;
3001           pstat(PSTAT_SETCMD, un, len, 0, 0);
3002           }
3003           #else
3004 184 50       if (PL_origalen > 1) {
3005           /* PL_origalen is set in perl_parse(). */
3006 184 100       s = SvPV_force(sv,len);
3007 184 50       if (len >= (STRLEN)PL_origalen-1) {
3008           /* Longer than original, will be truncated. We assume that
3009           * PL_origalen bytes are available. */
3010 0         Copy(s, PL_origargv[0], PL_origalen-1, char);
3011           }
3012           else {
3013           /* Shorter than original, will be padded. */
3014           #ifdef PERL_DARWIN
3015           /* Special case for Mac OS X: see [perl #38868] */
3016           const int pad = 0;
3017           #else
3018           /* Is the space counterintuitive? Yes.
3019           * (You were expecting \0?)
3020           * Does it work? Seems to. (In Linux 2.4.20 at least.)
3021           * --jhi */
3022           const int pad = ' ';
3023           #endif
3024 184         Copy(s, PL_origargv[0], len, char);
3025 184         PL_origargv[0][len] = 0;
3026 184         memset(PL_origargv[0] + len + 1,
3027 184         pad, PL_origalen - len - 1);
3028           }
3029 184         PL_origargv[0][PL_origalen-1] = 0;
3030 934 100       for (i = 1; i < PL_origargc; i++)
3031 750         PL_origargv[i] = 0;
3032           #ifdef HAS_PRCTL_SET_NAME
3033           /* Set the legacy process name in addition to the POSIX name on Linux */
3034 184 50       if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3035           /* diag_listed_as: SKIPME */
3036 0         Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3037           }
3038           #endif
3039           }
3040           #endif
3041           UNLOCK_DOLLARZERO_MUTEX;
3042           break;
3043           }
3044 29860378         return 0;
3045           }
3046            
3047           I32
3048 4         Perl_whichsig_sv(pTHX_ SV *sigsv)
3049           {
3050           const char *sigpv;
3051           STRLEN siglen;
3052           PERL_ARGS_ASSERT_WHICHSIG_SV;
3053           PERL_UNUSED_CONTEXT;
3054 4 50       sigpv = SvPV_const(sigsv, siglen);
3055 4         return whichsig_pvn(sigpv, siglen);
3056           }
3057            
3058           I32
3059 16         Perl_whichsig_pv(pTHX_ const char *sig)
3060           {
3061           PERL_ARGS_ASSERT_WHICHSIG_PV;
3062           PERL_UNUSED_CONTEXT;
3063 16         return whichsig_pvn(sig, strlen(sig));
3064           }
3065            
3066           I32
3067 172492         Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3068           {
3069           char* const* sigv;
3070            
3071           PERL_ARGS_ASSERT_WHICHSIG_PVN;
3072           PERL_UNUSED_CONTEXT;
3073            
3074 11911794 100       for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3075 11742250 100       if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
    100        
3076 2948         return PL_sig_num[sigv - (char* const*)PL_sig_name];
3077           #ifdef SIGCLD
3078 169544 100       if (memEQs(sig, len, "CHLD"))
    50        
3079           return SIGCLD;
3080           #endif
3081           #ifdef SIGCHLD
3082 169544 100       if (memEQs(sig, len, "CLD"))
    50        
3083           return SIGCHLD;
3084           #endif
3085 171018         return -1;
3086           }
3087            
3088           Signal_t
3089           #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3090 182         Perl_sighandler(int sig, siginfo_t *sip, void *uap)
3091           #else
3092           Perl_sighandler(int sig)
3093           #endif
3094           {
3095           #ifdef PERL_GET_SIG_CONTEXT
3096           dTHXa(PERL_GET_SIG_CONTEXT);
3097           #else
3098           dTHX;
3099           #endif
3100 182         dSP;
3101 182         GV *gv = NULL;
3102           SV *sv = NULL;
3103 182         SV * const tSv = PL_Sv;
3104           CV *cv = NULL;
3105 182         OP *myop = PL_op;
3106           U32 flags = 0;
3107 182         XPV * const tXpv = PL_Xpv;
3108 182         I32 old_ss_ix = PL_savestack_ix;
3109           SV *errsv_save = NULL;
3110            
3111            
3112 182 50       if (!PL_psig_ptr[sig]) {
3113 0 0       PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
    0        
    0        
    0        
3114           PL_sig_name[sig]);
3115 0         exit(sig);
3116           }
3117            
3118 182 50       if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3119           /* Max number of items pushed there is 3*n or 4. We cannot fix
3120           infinity, so we fix 4 (in fact 5): */
3121 0 0       if (PL_savestack_ix + 15 <= PL_savestack_max) {
3122           flags |= 1;
3123 0         PL_savestack_ix += 5; /* Protect save in progress. */
3124 0         SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3125           }
3126           }
3127           /* sv_2cv is too complicated, try a simpler variant first: */
3128 182 100       if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
    50        
3129 150 50       || SvTYPE(cv) != SVt_PVCV) {
3130           HV *st;
3131 32         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3132           }
3133            
3134 182 50       if (!cv || !CvROOT(cv)) {
    100        
3135 10 50       Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3136 6 50       PL_sig_name[sig], (gv ? GvENAME(gv)
3137 0 0       : ((cv && CvGV(cv))
3138 0 0       ? GvENAME(CvGV(cv))
3139 0 0       : "__ANON__")));
3140 4         goto cleanup;
3141           }
3142            
3143 178         sv = PL_psig_name[sig]
3144 178         ? SvREFCNT_inc_NN(PL_psig_name[sig])
3145 178 50       : newSVpv(PL_sig_name[sig],0);
3146 178         flags |= 8;
3147 178         SAVEFREESV(sv);
3148            
3149           if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3150           /* make sure our assumption about the size of the SAVEs are correct:
3151           * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3152           assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3153           }
3154            
3155 178 100       PUSHSTACKi(PERLSI_SIGNAL);
3156 178 50       PUSHMARK(SP);
3157 178         PUSHs(sv);
3158           #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3159           {
3160           struct sigaction oact;
3161            
3162 178 50       if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
    100        
3163 4         if (sip) {
3164 2         HV *sih = newHV();
3165 2         SV *rv = newRV_noinc(MUTABLE_SV(sih));
3166           /* The siginfo fields signo, code, errno, pid, uid,
3167           * addr, status, and band are defined by POSIX/SUSv3. */
3168 2         (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3169 2         (void)hv_stores(sih, "code", newSViv(sip->si_code));
3170           #if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
3171           hv_stores(sih, "errno", newSViv(sip->si_errno));
3172           hv_stores(sih, "status", newSViv(sip->si_status));
3173           hv_stores(sih, "uid", newSViv(sip->si_uid));
3174           hv_stores(sih, "pid", newSViv(sip->si_pid));
3175           hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3176           hv_stores(sih, "band", newSViv(sip->si_band));
3177           #endif
3178 1         EXTEND(SP, 2);
3179 2         PUSHs(rv);
3180 2         mPUSHp((char *)sip, sizeof(*sip));
3181           }
3182            
3183           }
3184           }
3185           #endif
3186 178         PUTBACK;
3187            
3188 178 50       errsv_save = newSVsv(ERRSV);
3189            
3190 178         call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3191            
3192 172 50       POPSTACK;
3193           {
3194 172 50       SV * const errsv = ERRSV;
3195 172 50       if (SvTRUE_NN(errsv)) {
    50        
    0        
    0        
    50        
    50        
    100        
    50        
    0        
    0        
    0        
    0        
    0        
    0        
    100        
3196 28         SvREFCNT_dec(errsv_save);
3197           #ifndef PERL_MICRO
3198           /* Handler "died", for example to get out of a restart-able read().
3199           * Before we re-do that on its behalf re-enable the signal which was
3200           * blocked by the system when we entered.
3201           */
3202           #ifdef HAS_SIGPROCMASK
3203           #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3204 28 100       if (sip || uap)
3205           #endif
3206           {
3207           sigset_t set;
3208 4         sigemptyset(&set);
3209 4         sigaddset(&set,sig);
3210 4         sigprocmask(SIG_UNBLOCK, &set, NULL);
3211           }
3212           #else
3213           /* Not clear if this will work */
3214           (void)rsignal(sig, SIG_IGN);
3215           (void)rsignal(sig, PL_csighandlerp);
3216           #endif
3217           #endif /* !PERL_MICRO */
3218 28         die_sv(errsv);
3219           }
3220           else {
3221 144         sv_setsv(errsv, errsv_save);
3222 144         SvREFCNT_dec(errsv_save);
3223           }
3224           }
3225            
3226           cleanup:
3227           /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3228 148         PL_savestack_ix = old_ss_ix;
3229 148 100       if (flags & 8)
3230           SvREFCNT_dec_NN(sv);
3231 148         PL_op = myop; /* Apparently not needed... */
3232            
3233 148         PL_Sv = tSv; /* Restore global temporaries. */
3234 148         PL_Xpv = tXpv;
3235 148         return;
3236           }
3237            
3238            
3239           static void
3240 114607277         S_restore_magic(pTHX_ const void *p)
3241           {
3242           dVAR;
3243 114607277         MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3244 114607277         SV* const sv = mgs->mgs_sv;
3245           bool bumped;
3246            
3247 114607277 100       if (!sv)
3248 114607277         return;
3249            
3250 113850077 50       if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
    100        
3251 110925713         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3252           #ifdef PERL_OLD_COPY_ON_WRITE
3253           /* While magic was saved (and off) sv_setsv may well have seen
3254           this SV as a prime candidate for COW. */
3255           if (SvIsCOW(sv))
3256           sv_force_normal_flags(sv, 0);
3257           #endif
3258 110925713 100       if (mgs->mgs_readonly)
3259 45216         SvREADONLY_on(sv);
3260 110925713 100       if (mgs->mgs_magical)
3261 108628810         SvFLAGS(sv) |= mgs->mgs_magical;
3262           else
3263 2296903         mg_magical(sv);
3264           }
3265            
3266 113850077         bumped = mgs->mgs_bumped;
3267 113850077         mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3268            
3269           /* If we're still on top of the stack, pop us off. (That condition
3270           * will be satisfied if restore_magic was called explicitly, but *not*
3271           * if it's being called via leave_scope.)
3272           * The reason for doing this is that otherwise, things like sv_2cv()
3273           * may leave alloc gunk on the savestack, and some code
3274           * (e.g. sighandler) doesn't expect that...
3275           */
3276 113850077 100       if (PL_savestack_ix == mgs->mgs_ss_ix)
3277           {
3278 113092629         UV popval = SSPOPUV;
3279           assert(popval == SAVEt_DESTRUCTOR_X);
3280 113092629         PL_savestack_ix -= 2;
3281 113092629         popval = SSPOPUV;
3282           assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3283 113092629         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3284           }
3285 113850077 50       if (bumped) {
3286 113850077 100       if (SvREFCNT(sv) == 1) {
3287           /* We hold the last reference to this SV, which implies that the
3288           SV was deleted as a side effect of the routines we called.
3289           So artificially keep it alive a bit longer.
3290           We avoid turning on the TEMP flag, which can cause the SV's
3291           buffer to get stolen (and maybe other stuff). */
3292 4         sv_2mortal(sv);
3293 4         SvTEMP_off(sv);
3294           }
3295           else
3296           SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3297           }
3298           }
3299            
3300           /* clean up the mess created by Perl_sighandler().
3301           * Note that this is only called during an exit in a signal handler;
3302           * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3303           * skipped over. */
3304            
3305           static void
3306 0         S_unwind_handler_stack(pTHX_ const void *p)
3307           {
3308           dVAR;
3309           PERL_UNUSED_ARG(p);
3310            
3311 0         PL_savestack_ix -= 5; /* Unprotect save in progress. */
3312 0         }
3313            
3314           /*
3315           =for apidoc magic_sethint
3316            
3317           Triggered by a store to %^H, records the key/value pair to
3318           C. It is assumed that hints aren't storing
3319           anything that would need a deep copy. Maybe we should warn if we find a
3320           reference.
3321            
3322           =cut
3323           */
3324           int
3325 113008         Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3326           {
3327           dVAR;
3328 168580         SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3329 113474 100       : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3330            
3331           PERL_ARGS_ASSERT_MAGIC_SETHINT;
3332            
3333           /* mg->mg_obj isn't being used. If needed, it would be possible to store
3334           an alternative leaf in there, with PL_compiling.cop_hints being used if
3335           it's NULL. If needed for threads, the alternative could lock a mutex,
3336           or take other more complex action. */
3337            
3338           /* Something changed in %^H, so it will need to be restored on scope exit.
3339           Doing this here saves a lot of doing it manually in perl code (and
3340           forgetting to do it, and consequent subtle errors. */
3341 113008         PL_hints |= HINT_LOCALIZE_HH;
3342 113008         CopHINTHASH_set(&PL_compiling,
3343           cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3344 113008         return 0;
3345           }
3346            
3347           /*
3348           =for apidoc magic_clearhint
3349            
3350           Triggered by a delete from %^H, records the key to
3351           C.
3352            
3353           =cut
3354           */
3355           int
3356 31998         Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3357           {
3358           dVAR;
3359            
3360           PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3361           PERL_UNUSED_ARG(sv);
3362            
3363 31998         PL_hints |= HINT_LOCALIZE_HH;
3364 31998 50       CopHINTHASH_set(&PL_compiling,
3365           mg->mg_len == HEf_SVKEY
3366           ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3367           MUTABLE_SV(mg->mg_ptr), 0, 0)
3368           : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3369           mg->mg_ptr, mg->mg_len, 0, 0));
3370 31998         return 0;
3371           }
3372            
3373           /*
3374           =for apidoc magic_clearhints
3375            
3376           Triggered by clearing %^H, resets C.
3377            
3378           =cut
3379           */
3380           int
3381 591119         Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3382           {
3383           PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3384           PERL_UNUSED_ARG(sv);
3385           PERL_UNUSED_ARG(mg);
3386 591119         cophh_free(CopHINTHASH_get(&PL_compiling));
3387 591119         CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3388 591119         return 0;
3389           }
3390            
3391           int
3392 2         Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3393           const char *name, I32 namlen)
3394           {
3395           MAGIC *nmg;
3396            
3397           PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3398           PERL_UNUSED_ARG(sv);
3399           PERL_UNUSED_ARG(name);
3400           PERL_UNUSED_ARG(namlen);
3401            
3402 2         sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3403 2         nmg = mg_find(nsv, mg->mg_type);
3404 2 50       if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3405 2         nmg->mg_ptr = mg->mg_ptr;
3406 4         nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3407 2         nmg->mg_flags |= MGf_REFCOUNTED;
3408 2         return 1;
3409 47285541         }
3410            
3411           /*
3412           * Local variables:
3413           * c-indentation-style: bsd
3414           * c-basic-offset: 4
3415           * indent-tabs-mode: nil
3416           * End:
3417           *
3418           * ex: set ts=8 sts=4 sw=4 et:
3419           */