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