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