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