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