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