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