This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
When restoring localised values, call set only on container magic.
[perl5.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
7272f7c1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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/*
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."
79072805
LW
14 */
15
ccfc67b7
JH
16/*
17=head1 Magical Functions
166f8a29
DM
18
19"Magic" is special data attached to SV structures in order to give them
20"magical" properties. When any Perl code tries to read from, or assign to,
21an SV marked as magical, it calls the 'get' or 'set' function associated
22with that SV's magic. A get is called prior to reading an SV, in order to
ddfa107c 23give it a chance to update its internal value (get on $. writes the line
166f8a29
DM
24number of the last read filehandle into to the SV's IV slot), while
25set is called after an SV has been written to, in order to allow it to make
ddfa107c 26use of its changed value (set on $/ copies the SV's new value to the
166f8a29
DM
27PL_rs global variable).
28
29Magic is implemented as a linked list of MAGIC structures attached to the
30SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31of functions that implement the get(), set(), length() etc functions,
32plus space for some flags and pointers. For example, a tied variable has
33a MAGIC structure that contains a pointer to the object associated with the
34tie.
35
ccfc67b7
JH
36*/
37
79072805 38#include "EXTERN.h"
864dbfa3 39#define PERL_IN_MG_C
79072805
LW
40#include "perl.h"
41
5cd24f17 42#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
b7953727
JH
43# ifdef I_GRP
44# include <grp.h>
45# endif
188ea221
CS
46#endif
47
757f63d8
SP
48#if defined(HAS_SETGROUPS)
49# ifndef NGROUPS
50# define NGROUPS 32
51# endif
52#endif
53
17aa7f3d
JH
54#ifdef __hpux
55# include <sys/pstat.h>
56#endif
57
8aad04aa
JH
58#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59Signal_t Perl_csighandler(int sig, ...);
60#else
e69880a5 61Signal_t Perl_csighandler(int sig);
8aad04aa 62#endif
e69880a5 63
9cffb111
OS
64#ifdef __Lynx__
65/* Missing protos on LynxOS */
66void setruid(uid_t id);
67void seteuid(uid_t id);
68void setrgid(uid_t id);
69void setegid(uid_t id);
70#endif
71
c07a80fd
PP
72/*
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
74 */
75
76struct magic_state {
77 SV* mgs_sv;
78 U32 mgs_flags;
455ece5e 79 I32 mgs_ss_ix;
c07a80fd 80};
455ece5e 81/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e
GS
82
83STATIC void
8fb26106 84S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
c07a80fd 85{
97aff369 86 dVAR;
455ece5e 87 MGS* mgs;
c07a80fd 88 assert(SvMAGICAL(sv));
d8b2590f
NC
89 /* Turning READONLY off for a copy-on-write scalar (including shared
90 hash keys) is a bad idea. */
765f542d 91 if (SvIsCOW(sv))
9a265e59 92 sv_force_normal_flags(sv, 0);
c07a80fd 93
8772537c 94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
455ece5e
AD
95
96 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd
PP
97 mgs->mgs_sv = sv;
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
455ece5e 99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
c07a80fd
PP
100
101 SvMAGICAL_off(sv);
102 SvREADONLY_off(sv);
085bde85
NC
103 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
104 /* No public flags are set, so promote any private flags to public. */
105 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
106 }
c07a80fd
PP
107}
108
954c1994
GS
109/*
110=for apidoc mg_magical
111
112Turns on the magical status of an SV. See C<sv_magic>.
113
114=cut
115*/
116
8990e307 117void
864dbfa3 118Perl_mg_magical(pTHX_ SV *sv)
8990e307 119{
e1ec3a88 120 const MAGIC* mg;
96a5add6 121 PERL_UNUSED_CONTEXT;
8990e307 122 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 123 const MGVTBL* const vtbl = mg->mg_virtual;
8990e307 124 if (vtbl) {
2b260de0 125 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
8990e307
LW
126 SvGMAGICAL_on(sv);
127 if (vtbl->svt_set)
128 SvSMAGICAL_on(sv);
2b260de0 129 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
8990e307
LW
130 SvRMAGICAL_on(sv);
131 }
132 }
133}
134
2767dea0
DM
135
136/* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
137
138STATIC bool
139S_is_container_magic(const MAGIC *mg)
140{
141 switch (mg->mg_type) {
142 case PERL_MAGIC_bm:
143 case PERL_MAGIC_fm:
144 case PERL_MAGIC_regex_global:
145 case PERL_MAGIC_nkeys:
146#ifdef USE_LOCALE_COLLATE
147 case PERL_MAGIC_collxfrm:
148#endif
149 case PERL_MAGIC_qr:
150 case PERL_MAGIC_taint:
151 case PERL_MAGIC_vec:
152 case PERL_MAGIC_vstring:
153 case PERL_MAGIC_utf8:
154 case PERL_MAGIC_substr:
155 case PERL_MAGIC_defelem:
156 case PERL_MAGIC_arylen:
157 case PERL_MAGIC_pos:
158 case PERL_MAGIC_backref:
159 case PERL_MAGIC_arylen_p:
160 case PERL_MAGIC_rhash:
161 case PERL_MAGIC_symtab:
162 return 0;
163 default:
164 return 1;
165 }
166}
167
954c1994
GS
168/*
169=for apidoc mg_get
170
171Do magic after a value is retrieved from the SV. See C<sv_magic>.
172
173=cut
174*/
175
79072805 176int
864dbfa3 177Perl_mg_get(pTHX_ SV *sv)
79072805 178{
97aff369 179 dVAR;
35a4481c 180 const I32 mgs_ix = SSNEW(sizeof(MGS));
fe2774ed 181 const bool was_temp = (bool)SvTEMP(sv);
0723351e 182 int have_new = 0;
ff76feab 183 MAGIC *newmg, *head, *cur, *mg;
20135930 184 /* guard against sv having being freed midway by holding a private
6683b158
NC
185 reference. */
186
187 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
188 cause the SV's buffer to get stolen (and maybe other stuff).
189 So restore it.
190 */
46da273f 191 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
6683b158
NC
192 if (!was_temp) {
193 SvTEMP_off(sv);
194 }
195
455ece5e 196 save_magic(mgs_ix, sv);
463ee0b2 197
ff76feab
AMS
198 /* We must call svt_get(sv, mg) for each valid entry in the linked
199 list of magic. svt_get() may delete the current entry, add new
200 magic to the head of the list, or upgrade the SV. AMS 20010810 */
201
202 newmg = cur = head = mg = SvMAGIC(sv);
203 while (mg) {
35a4481c 204 const MGVTBL * const vtbl = mg->mg_virtual;
ff76feab 205
2b260de0 206 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
316ad4fe 207 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
b77f7d40 208
58f82c5c
DM
209 /* guard against magic having been deleted - eg FETCH calling
210 * untie */
211 if (!SvMAGIC(sv))
212 break;
b77f7d40 213
ff76feab
AMS
214 /* Don't restore the flags for this entry if it was deleted. */
215 if (mg->mg_flags & MGf_GSKIP)
216 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
a0d0e21e 217 }
ff76feab
AMS
218
219 mg = mg->mg_moremagic;
220
0723351e 221 if (have_new) {
ff76feab
AMS
222 /* Have we finished with the new entries we saw? Start again
223 where we left off (unless there are more new entries). */
224 if (mg == head) {
0723351e 225 have_new = 0;
ff76feab
AMS
226 mg = cur;
227 head = newmg;
228 }
229 }
230
231 /* Were any new entries added? */
0723351e
NC
232 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
233 have_new = 1;
ff76feab
AMS
234 cur = mg;
235 mg = newmg;
760ac839 236 }
79072805 237 }
463ee0b2 238
8772537c 239 restore_magic(INT2PTR(void *, (IV)mgs_ix));
6683b158
NC
240
241 if (SvREFCNT(sv) == 1) {
242 /* We hold the last reference to this SV, which implies that the
243 SV was deleted as a side effect of the routines we called. */
0c34ef67 244 SvOK_off(sv);
6683b158 245 }
79072805
LW
246 return 0;
247}
248
954c1994
GS
249/*
250=for apidoc mg_set
251
252Do magic after a value is assigned to the SV. See C<sv_magic>.
253
254=cut
255*/
256
79072805 257int
864dbfa3 258Perl_mg_set(pTHX_ SV *sv)
79072805 259{
97aff369 260 dVAR;
35a4481c 261 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 262 MAGIC* mg;
463ee0b2
LW
263 MAGIC* nextmg;
264
455ece5e 265 save_magic(mgs_ix, sv);
463ee0b2
LW
266
267 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
e1ec3a88 268 const MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 269 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e
LW
270 if (mg->mg_flags & MGf_GSKIP) {
271 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
455ece5e 272 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
a0d0e21e 273 }
e7cbf6c6
DM
274 if (PL_localizing == 2 && !S_is_container_magic(mg))
275 continue;
2b260de0 276 if (vtbl && vtbl->svt_set)
fc0dc3b3 277 CALL_FPTR(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
287Report on the SV's length. See C<sv_magic>.
288
289=cut
290*/
291
79072805 292U32
864dbfa3 293Perl_mg_length(pTHX_ SV *sv)
79072805 294{
97aff369 295 dVAR;
79072805 296 MAGIC* mg;
463ee0b2 297 STRLEN len;
463ee0b2 298
79072805 299 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 300 const MGVTBL * const vtbl = mg->mg_virtual;
2b260de0 301 if (vtbl && vtbl->svt_len) {
35a4481c 302 const I32 mgs_ix = SSNEW(sizeof(MGS));
455ece5e 303 save_magic(mgs_ix, sv);
a0d0e21e 304 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 305 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
8772537c 306 restore_magic(INT2PTR(void*, (IV)mgs_ix));
85e6fe83
LW
307 return len;
308 }
309 }
310
35a4481c 311 if (DO_UTF8(sv)) {
10516c54 312 const U8 *s = (U8*)SvPV_const(sv, len);
f5a63d97 313 len = utf8_length(s, s + len);
5636d518
DB
314 }
315 else
10516c54 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
93965878 325 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 326 const MGVTBL* const vtbl = mg->mg_virtual;
2b260de0 327 if (vtbl && vtbl->svt_len) {
35a4481c
AL
328 const I32 mgs_ix = SSNEW(sizeof(MGS));
329 I32 len;
455ece5e 330 save_magic(mgs_ix, sv);
93965878 331 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 332 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
8772537c 333 restore_magic(INT2PTR(void*, (IV)mgs_ix));
93965878
NIS
334 return len;
335 }
336 }
337
338 switch(SvTYPE(sv)) {
339 case SVt_PVAV:
35a4481c 340 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
93965878
NIS
341 case SVt_PVHV:
342 /* FIXME */
343 default:
cea2e8a9 344 Perl_croak(aTHX_ "Size magic not implemented");
93965878
NIS
345 break;
346 }
347 return 0;
348}
349
954c1994
GS
350/*
351=for apidoc mg_clear
352
353Clear something magical that the SV represents. See C<sv_magic>.
354
355=cut
356*/
357
79072805 358int
864dbfa3 359Perl_mg_clear(pTHX_ SV *sv)
79072805 360{
35a4481c 361 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 362 MAGIC* mg;
463ee0b2 363
455ece5e 364 save_magic(mgs_ix, sv);
463ee0b2 365
79072805 366 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 367 const MGVTBL* const vtbl = mg->mg_virtual;
a0d0e21e 368 /* omit GSKIP -- never set here */
727405f8 369
2b260de0 370 if (vtbl && vtbl->svt_clear)
fc0dc3b3 371 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
79072805 372 }
463ee0b2 373
8772537c 374 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW
375 return 0;
376}
377
954c1994
GS
378/*
379=for apidoc mg_find
380
381Finds the magic pointer for type matching the SV. See C<sv_magic>.
382
383=cut
384*/
385
93a17b20 386MAGIC*
35a4481c 387Perl_mg_find(pTHX_ const SV *sv, int type)
93a17b20 388{
96a5add6 389 PERL_UNUSED_CONTEXT;
35a4481c
AL
390 if (sv) {
391 MAGIC *mg;
392 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
393 if (mg->mg_type == type)
394 return mg;
395 }
93a17b20 396 }
5f66b61c 397 return NULL;
93a17b20
LW
398}
399
954c1994
GS
400/*
401=for apidoc mg_copy
402
403Copies the magic from one SV to another. See C<sv_magic>.
404
405=cut
406*/
407
79072805 408int
864dbfa3 409Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 410{
463ee0b2 411 int count = 0;
79072805 412 MAGIC* mg;
463ee0b2 413 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 414 const MGVTBL* const vtbl = mg->mg_virtual;
68795e93
NIS
415 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
416 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
417 }
823a54a3
AL
418 else {
419 const char type = mg->mg_type;
1e73acc8 420 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
823a54a3
AL
421 sv_magic(nsv,
422 (type == PERL_MAGIC_tied)
423 ? SvTIED_obj(sv, mg)
424 : (type == PERL_MAGIC_regdata && mg->mg_obj)
425 ? sv
426 : mg->mg_obj,
427 toLOWER(type), key, klen);
428 count++;
429 }
79072805 430 }
79072805 431 }
463ee0b2 432 return count;
79072805
LW
433}
434
954c1994 435/*
0cbee0a4
DM
436=for apidoc mg_localize
437
438Copy some of the magic from an existing SV to new localized version of
439that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
440doesn't (eg taint, pos).
441
442=cut
443*/
444
445void
446Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
447{
97aff369 448 dVAR;
0cbee0a4
DM
449 MAGIC *mg;
450 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
2b1b43ea 451 const MGVTBL* const vtbl = mg->mg_virtual;
2767dea0 452 if (!S_is_container_magic(mg))
0cbee0a4 453 continue;
0cbee0a4 454
a5063e7c
DM
455 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
456 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
457 else
0cbee0a4
DM
458 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
459 mg->mg_ptr, mg->mg_len);
a5063e7c 460
0cbee0a4
DM
461 /* container types should remain read-only across localization */
462 SvFLAGS(nsv) |= SvREADONLY(sv);
463 }
464
465 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
466 SvFLAGS(nsv) |= SvMAGICAL(sv);
467 PL_localizing = 1;
468 SvSETMAGIC(nsv);
469 PL_localizing = 0;
470 }
471}
472
473/*
954c1994
GS
474=for apidoc mg_free
475
476Free any magic storage used by the SV. See C<sv_magic>.
477
478=cut
479*/
480
79072805 481int
864dbfa3 482Perl_mg_free(pTHX_ SV *sv)
79072805
LW
483{
484 MAGIC* mg;
485 MAGIC* moremagic;
486 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
35a4481c 487 const MGVTBL* const vtbl = mg->mg_virtual;
79072805 488 moremagic = mg->mg_moremagic;
2b260de0 489 if (vtbl && vtbl->svt_free)
fc0dc3b3 490 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
14befaf4 491 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
979acdb5 492 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
88e89b8a 493 Safefree(mg->mg_ptr);
565764a8 494 else if (mg->mg_len == HEf_SVKEY)
88e89b8a 495 SvREFCNT_dec((SV*)mg->mg_ptr);
d460ef45 496 }
b881518d
JH
497 if (mg->mg_flags & MGf_REFCOUNTED)
498 SvREFCNT_dec(mg->mg_obj);
79072805
LW
499 Safefree(mg);
500 }
b162af07 501 SvMAGIC_set(sv, NULL);
79072805
LW
502 return 0;
503}
504
79072805 505#include <signal.h>
79072805 506
942e002e 507U32
864dbfa3 508Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 509{
97aff369 510 dVAR;
8772537c 511 PERL_UNUSED_ARG(sv);
6cef1e77 512
0bd48802
AL
513 if (PL_curpm) {
514 register const REGEXP * const rx = PM_GETRE(PL_curpm);
515 if (rx) {
a678b0e4
YO
516 if (mg->mg_obj) { /* @+ */
517 /* return the number possible */
518 return rx->nparens;
519 } else { /* @- */
520 I32 paren = rx->lastparen;
521
522 /* return the last filled */
f46c4081
RGS
523 while ( paren >= 0
524 && (rx->startp[paren] == -1 || rx->endp[paren] == -1) )
525 paren--;
a678b0e4
YO
526 return (U32)paren;
527 }
0bd48802 528 }
8f580fb8 529 }
ac27b0f5 530
942e002e 531 return (U32)-1;
6cef1e77
IZ
532}
533
534int
864dbfa3 535Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 536{
97aff369 537 dVAR;
0bd48802
AL
538 if (PL_curpm) {
539 register const REGEXP * const rx = PM_GETRE(PL_curpm);
540 if (rx) {
541 register const I32 paren = mg->mg_len;
542 register I32 s;
543 register I32 t;
544 if (paren < 0)
545 return 0;
546 if (paren <= (I32)rx->nparens &&
547 (s = rx->startp[paren]) != -1 &&
548 (t = rx->endp[paren]) != -1)
549 {
550 register I32 i;
551 if (mg->mg_obj) /* @+ */
552 i = t;
553 else /* @- */
554 i = s;
555
556 if (i > 0 && RX_MATCH_UTF8(rx)) {
557 const char * const b = rx->subbeg;
558 if (b)
f5a63d97 559 i = utf8_length((U8*)b, (U8*)(b+i));
0bd48802 560 }
727405f8 561
0bd48802 562 sv_setiv(sv, i);
1aa99e6b 563 }
0bd48802 564 }
6cef1e77
IZ
565 }
566 return 0;
567}
568
e4b89193 569int
a29d06ed
MG
570Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
571{
d4c19fe8
AL
572 PERL_UNUSED_ARG(sv);
573 PERL_UNUSED_ARG(mg);
a29d06ed 574 Perl_croak(aTHX_ PL_no_modify);
0dbb1585 575 NORETURN_FUNCTION_END;
a29d06ed
MG
576}
577
93a17b20 578U32
864dbfa3 579Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
93a17b20 580{
97aff369 581 dVAR;
93a17b20 582 register I32 paren;
93a17b20 583 register I32 i;
dd374669 584 register const REGEXP *rx;
a197cbdd 585 I32 s1, t1;
93a17b20
LW
586
587 switch (*mg->mg_ptr) {
588 case '1': case '2': case '3': case '4':
589 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 590 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 591
ffc61ed2 592 paren = atoi(mg->mg_ptr); /* $& is in [0] */
93a17b20 593 getparen:
eb160463 594 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ
595 (s1 = rx->startp[paren]) != -1 &&
596 (t1 = rx->endp[paren]) != -1)
bbce6d69 597 {
cf93c79d 598 i = t1 - s1;
a197cbdd 599 getlen:
a30b2f1f 600 if (i > 0 && RX_MATCH_UTF8(rx)) {
a28509cc 601 const char * const s = rx->subbeg + s1;
768c67ee
JH
602 const U8 *ep;
603 STRLEN el;
ffc61ed2 604
6d5fa195 605 i = t1 - s1;
768c67ee
JH
606 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
607 i = el;
a197cbdd 608 }
ffc61ed2 609 if (i < 0)
0844c848 610 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
ffc61ed2 611 return i;
93a17b20 612 }
235bddc8
NIS
613 else {
614 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 615 report_uninit(sv);
235bddc8
NIS
616 }
617 }
618 else {
619 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 620 report_uninit(sv);
93a17b20 621 }
748a9306 622 return 0;
93a17b20 623 case '+':
aaa362c4 624 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 625 paren = rx->lastparen;
13f57bf8
CS
626 if (paren)
627 goto getparen;
93a17b20 628 }
748a9306 629 return 0;
a01268b5
JH
630 case '\016': /* ^N */
631 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
632 paren = rx->lastcloseparen;
633 if (paren)
634 goto getparen;
635 }
636 return 0;
93a17b20 637 case '`':
aaa362c4 638 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
639 if (rx->startp[0] != -1) {
640 i = rx->startp[0];
a197cbdd
GS
641 if (i > 0) {
642 s1 = 0;
643 t1 = i;
644 goto getlen;
645 }
93a17b20 646 }
93a17b20 647 }
748a9306 648 return 0;
93a17b20 649 case '\'':
aaa362c4 650 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
651 if (rx->endp[0] != -1) {
652 i = rx->sublen - rx->endp[0];
a197cbdd
GS
653 if (i > 0) {
654 s1 = rx->endp[0];
655 t1 = rx->sublen;
656 goto getlen;
657 }
93a17b20 658 }
93a17b20 659 }
748a9306 660 return 0;
93a17b20
LW
661 }
662 magic_get(sv,mg);
2d8e6c8d 663 if (!SvPOK(sv) && SvNIOK(sv)) {
8b6b16e7 664 sv_2pv(sv, 0);
2d8e6c8d 665 }
93a17b20
LW
666 if (SvPOK(sv))
667 return SvCUR(sv);
668 return 0;
669}
670
ad3296c6 671#define SvRTRIM(sv) STMT_START { \
eae92ea0
GA
672 if (SvPOK(sv)) { \
673 STRLEN len = SvCUR(sv); \
674 char * const p = SvPVX(sv); \
8e6b4db6
PC
675 while (len > 0 && isSPACE(p[len-1])) \
676 --len; \
677 SvCUR_set(sv, len); \
678 p[len] = '\0'; \
679 } \
ad3296c6
SH
680} STMT_END
681
8b850bd5
NC
682void
683Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
684{
685 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
686 sv_setsv(sv, &PL_sv_undef);
687 else {
688 sv_setpvs(sv, "");
689 SvUTF8_off(sv);
690 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
691 SV *const value = Perl_refcounted_he_fetch(aTHX_
692 c->cop_hints_hash,
693 0, "open<", 5, 0, 0);
694 assert(value);
695 sv_catsv(sv, value);
696 }
697 sv_catpvs(sv, "\0");
698 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
699 SV *const value = Perl_refcounted_he_fetch(aTHX_
700 c->cop_hints_hash,
701 0, "open>", 5, 0, 0);
702 assert(value);
703 sv_catsv(sv, value);
704 }
705 }
706}
707
79072805 708int
864dbfa3 709Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805 710{
27da23d5 711 dVAR;
79072805 712 register I32 paren;
35272f84 713 register char *s = NULL;
d9f97599 714 register REGEXP *rx;
823a54a3
AL
715 const char * const remaining = mg->mg_ptr + 1;
716 const char nextchar = *remaining;
79072805
LW
717
718 switch (*mg->mg_ptr) {
748a9306 719 case '\001': /* ^A */
3280af22 720 sv_setsv(sv, PL_bodytarget);
748a9306 721 break;
e5218da5 722 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
823a54a3 723 if (nextchar == '\0') {
e5218da5
GA
724 sv_setiv(sv, (IV)PL_minus_c);
725 }
823a54a3 726 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
e5218da5
GA
727 sv_setiv(sv, (IV)STATUS_NATIVE);
728 }
49460fe6
NIS
729 break;
730
79072805 731 case '\004': /* ^D */
aea4f609 732 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
79072805 733 break;
28f23441 734 case '\005': /* ^E */
823a54a3 735 if (nextchar == '\0') {
4b645107 736#if defined(MACOS_TRADITIONAL)
0a378802
JH
737 {
738 char msg[256];
727405f8 739
0a378802 740 sv_setnv(sv,(double)gMacPerl_OSErr);
727405f8 741 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
0a378802 742 }
4b645107 743#elif defined(VMS)
0a378802
JH
744 {
745# include <descrip.h>
746# include <starlet.h>
747 char msg[255];
748 $DESCRIPTOR(msgdsc,msg);
749 sv_setnv(sv,(NV) vaxc$errno);
750 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
751 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
752 else
c69006e4 753 sv_setpvn(sv,"",0);
0a378802 754 }
4b645107 755#elif defined(OS2)
0a378802
JH
756 if (!(_emx_env & 0x200)) { /* Under DOS */
757 sv_setnv(sv, (NV)errno);
758 sv_setpv(sv, errno ? Strerror(errno) : "");
759 } else {
760 if (errno != errno_isOS2) {
823a54a3 761 const int tmp = _syserrno();
0a378802
JH
762 if (tmp) /* 2nd call to _syserrno() makes it 0 */
763 Perl_rc = tmp;
764 }
765 sv_setnv(sv, (NV)Perl_rc);
766 sv_setpv(sv, os2error(Perl_rc));
767 }
4b645107 768#elif defined(WIN32)
0a378802 769 {
d4c19fe8 770 const DWORD dwErr = GetLastError();
0a378802 771 sv_setnv(sv, (NV)dwErr);
823a54a3 772 if (dwErr) {
0a378802
JH
773 PerlProc_GetOSError(sv, dwErr);
774 }
775 else
c69006e4 776 sv_setpvn(sv, "", 0);
0a378802
JH
777 SetLastError(dwErr);
778 }
22fae026 779#else
f6c8f21d 780 {
8772537c 781 const int saveerrno = errno;
f6c8f21d 782 sv_setnv(sv, (NV)errno);
666ea192 783 sv_setpv(sv, errno ? Strerror(errno) : "");
f6c8f21d
RGS
784 errno = saveerrno;
785 }
28f23441 786#endif
ad3296c6 787 SvRTRIM(sv);
0a378802
JH
788 SvNOK_on(sv); /* what a wonderful hack! */
789 }
823a54a3 790 else if (strEQ(remaining, "NCODING"))
0a378802
JH
791 sv_setsv(sv, PL_encoding);
792 break;
79072805 793 case '\006': /* ^F */
3280af22 794 sv_setiv(sv, (IV)PL_maxsysfd);
79072805 795 break;
a0d0e21e 796 case '\010': /* ^H */
3280af22 797 sv_setiv(sv, (IV)PL_hints);
a0d0e21e 798 break;
9d116dd7 799 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
800 if (PL_inplace)
801 sv_setpv(sv, PL_inplace);
79072805 802 else
3280af22 803 sv_setsv(sv, &PL_sv_undef);
79072805 804 break;
ac27b0f5 805 case '\017': /* ^O & ^OPEN */
823a54a3 806 if (nextchar == '\0') {
ac27b0f5 807 sv_setpv(sv, PL_osname);
3511154c
DM
808 SvTAINTED_off(sv);
809 }
823a54a3 810 else if (strEQ(remaining, "PEN")) {
8b850bd5 811 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
ac27b0f5 812 }
28f23441 813 break;
cde0cee5
YO
814 case '\020':
815 if (nextchar == '\0') { /* ^P */
816 sv_setiv(sv, (IV)PL_perldb);
817 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
818 goto do_prematch_fetch;
819 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
820 goto do_postmatch_fetch;
821 }
79072805 822 break;
fb73857a 823 case '\023': /* ^S */
823a54a3 824 if (nextchar == '\0') {
3280af22 825 if (PL_lex_state != LEX_NOTPARSING)
0c34ef67 826 SvOK_off(sv);
3280af22 827 else if (PL_in_eval)
6dc8a9e4 828 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
a4268c0a
AMS
829 else
830 sv_setiv(sv, 0);
d58bf5aa 831 }
fb73857a 832 break;
79072805 833 case '\024': /* ^T */
823a54a3 834 if (nextchar == '\0') {
88e89b8a 835#ifdef BIG_TIME
7c36658b 836 sv_setnv(sv, PL_basetime);
88e89b8a 837#else
7c36658b 838 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 839#endif
7c36658b 840 }
823a54a3 841 else if (strEQ(remaining, "AINT"))
9aa05f58
RGS
842 sv_setiv(sv, PL_tainting
843 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
844 : 0);
7c36658b 845 break;
e07ea26a 846 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
823a54a3 847 if (strEQ(remaining, "NICODE"))
a05d7ebb 848 sv_setuv(sv, (UV) PL_unicode);
823a54a3 849 else if (strEQ(remaining, "TF8LOCALE"))
7cebcbc0 850 sv_setuv(sv, (UV) PL_utf8locale);
e07ea26a
NC
851 else if (strEQ(remaining, "TF8CACHE"))
852 sv_setiv(sv, (IV) PL_utf8cache);
fde18df1
JH
853 break;
854 case '\027': /* ^W & $^WARNING_BITS */
823a54a3 855 if (nextchar == '\0')
4438c4b7 856 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
823a54a3 857 else if (strEQ(remaining, "ARNING_BITS")) {
013b78e8 858 if (PL_compiling.cop_warnings == pWARN_NONE) {
4438c4b7 859 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
013b78e8
RGS
860 }
861 else if (PL_compiling.cop_warnings == pWARN_STD) {
666ea192
JH
862 sv_setpvn(
863 sv,
864 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
865 WARNsize
866 );
013b78e8 867 }
d3a7d8c7 868 else if (PL_compiling.cop_warnings == pWARN_ALL) {
75b6c4ca
RGS
869 /* Get the bit mask for $warnings::Bits{all}, because
870 * it could have been extended by warnings::register */
823a54a3 871 HV * const bits=get_hv("warnings::Bits", FALSE);
f5a63d97
AL
872 if (bits) {
873 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
874 if (bits_all)
875 sv_setsv(sv, *bits_all);
75b6c4ca
RGS
876 }
877 else {
878 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
879 }
ac27b0f5 880 }
4438c4b7 881 else {
72dc9ed5
NC
882 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
883 *PL_compiling.cop_warnings);
ac27b0f5 884 }
d3a7d8c7 885 SvPOK_only(sv);
4438c4b7 886 }
79072805 887 break;
cde0cee5
YO
888 case '\015': /* $^MATCH */
889 if (strEQ(remaining, "ATCH")) {
79072805
LW
890 case '1': case '2': case '3': case '4':
891 case '5': case '6': case '7': case '8': case '9': case '&':
cde0cee5
YO
892 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
893 /*
894 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
895 * XXX Does the new way break anything?
896 */
897 paren = atoi(mg->mg_ptr); /* $& is in [0] */
93b32b6d 898 CALLREG_NUMBUF(rx,paren,sv);
cde0cee5
YO
899 break;
900 }
901 sv_setsv(sv,&PL_sv_undef);
79072805
LW
902 }
903 break;
904 case '+':
aaa362c4 905 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
44a2ac75 906 if (rx->lastparen) {
93b32b6d 907 CALLREG_NUMBUF(rx,rx->lastparen,sv);
44a2ac75
YO
908 break;
909 }
79072805 910 }
3280af22 911 sv_setsv(sv,&PL_sv_undef);
79072805 912 break;
a01268b5
JH
913 case '\016': /* ^N */
914 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
44a2ac75 915 if (rx->lastcloseparen) {
93b32b6d 916 CALLREG_NUMBUF(rx,rx->lastcloseparen,sv);
44a2ac75
YO
917 break;
918 }
919
a01268b5
JH
920 }
921 sv_setsv(sv,&PL_sv_undef);
922 break;
79072805 923 case '`':
cde0cee5 924 do_prematch_fetch:
aaa362c4 925 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
93b32b6d
YO
926 CALLREG_NUMBUF(rx,-2,sv);
927 break;
79072805 928 }
3280af22 929 sv_setsv(sv,&PL_sv_undef);
79072805
LW
930 break;
931 case '\'':
cde0cee5 932 do_postmatch_fetch:
aaa362c4 933 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
93b32b6d
YO
934 CALLREG_NUMBUF(rx,-1,sv);
935 break;
79072805 936 }
3280af22 937 sv_setsv(sv,&PL_sv_undef);
79072805
LW
938 break;
939 case '.':
3280af22 940 if (GvIO(PL_last_in_gv)) {
357c8808 941 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805 942 }
79072805
LW
943 break;
944 case '?':
809a5acc 945 {
809a5acc 946 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 947#ifdef COMPLEX_STATUS
6b88bc9c
GS
948 LvTARGOFF(sv) = PL_statusvalue;
949 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 950#endif
809a5acc 951 }
79072805
LW
952 break;
953 case '^':
0daa599b
RGS
954 if (GvIOp(PL_defoutgv))
955 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
956 if (s)
957 sv_setpv(sv,s);
958 else {
3280af22 959 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805
LW
960 sv_catpv(sv,"_TOP");
961 }
962 break;
963 case '~':
0daa599b
RGS
964 if (GvIOp(PL_defoutgv))
965 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 966 if (!s)
3280af22 967 s = GvENAME(PL_defoutgv);
79072805
LW
968 sv_setpv(sv,s);
969 break;
79072805 970 case '=':
0daa599b
RGS
971 if (GvIOp(PL_defoutgv))
972 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
973 break;
974 case '-':
0daa599b
RGS
975 if (GvIOp(PL_defoutgv))
976 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
977 break;
978 case '%':
0daa599b
RGS
979 if (GvIOp(PL_defoutgv))
980 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805 981 break;
79072805
LW
982 case ':':
983 break;
984 case '/':
985 break;
986 case '[':
11206fdd 987 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
79072805
LW
988 break;
989 case '|':
0daa599b
RGS
990 if (GvIOp(PL_defoutgv))
991 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
992 break;
993 case ',':
79072805
LW
994 break;
995 case '\\':
b2ce0fda 996 if (PL_ors_sv)
f28098ff 997 sv_copypv(sv, PL_ors_sv);
79072805 998 break;
79072805 999 case '!':
a5f75d66 1000#ifdef VMS
65202027 1001 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 1002 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 1003#else
88e89b8a 1004 {
8772537c 1005 const int saveerrno = errno;
65202027 1006 sv_setnv(sv, (NV)errno);
88e89b8a 1007#ifdef OS2
ed344e4f
IZ
1008 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1009 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 1010 else
a5f75d66 1011#endif
666ea192 1012 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
1013 errno = saveerrno;
1014 }
1015#endif
ad3296c6 1016 SvRTRIM(sv);
946ec16e 1017 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
1018 break;
1019 case '<':
3280af22 1020 sv_setiv(sv, (IV)PL_uid);
79072805
LW
1021 break;
1022 case '>':
3280af22 1023 sv_setiv(sv, (IV)PL_euid);
79072805
LW
1024 break;
1025 case '(':
3280af22 1026 sv_setiv(sv, (IV)PL_gid);
79072805
LW
1027 goto add_groups;
1028 case ')':
3280af22 1029 sv_setiv(sv, (IV)PL_egid);
79072805 1030 add_groups:
79072805 1031#ifdef HAS_GETGROUPS
79072805 1032 {
57d7c65e 1033 Groups_t *gary = NULL;
fb45abb2 1034 I32 i, num_groups = getgroups(0, gary);
57d7c65e
JC
1035 Newx(gary, num_groups, Groups_t);
1036 num_groups = getgroups(num_groups, gary);
fb45abb2
GA
1037 for (i = 0; i < num_groups; i++)
1038 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
57d7c65e 1039 Safefree(gary);
79072805 1040 }
155aba94 1041 (void)SvIOK_on(sv); /* what a wonderful hack! */
cd70abae 1042#endif
79072805 1043 break;
cd39f2b6 1044#ifndef MACOS_TRADITIONAL
79072805
LW
1045 case '0':
1046 break;
cd39f2b6 1047#endif
79072805 1048 }
a0d0e21e 1049 return 0;
79072805
LW
1050}
1051
1052int
864dbfa3 1053Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 1054{
8772537c 1055 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
1056
1057 if (uf && uf->uf_val)
24f81a43 1058 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
1059 return 0;
1060}
1061
1062int
864dbfa3 1063Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 1064{
27da23d5 1065 dVAR;
9ae3433d 1066 STRLEN len = 0, klen;
666ea192 1067 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
fabdb6c0 1068 const char * const ptr = MgPV_const(mg,klen);
88e89b8a 1069 my_setenv(ptr, s);
1e422769 1070
a0d0e21e
LW
1071#ifdef DYNAMIC_ENV_FETCH
1072 /* We just undefd an environment var. Is a replacement */
1073 /* waiting in the wings? */
1074 if (!len) {
fabdb6c0
AL
1075 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1076 if (valp)
4ab59fcc 1077 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
a0d0e21e
LW
1078 }
1079#endif
1e422769 1080
39e571d4 1081#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
1082 /* And you'll never guess what the dog had */
1083 /* in its mouth... */
3280af22 1084 if (PL_tainting) {
1e422769
PP
1085 MgTAINTEDDIR_off(mg);
1086#ifdef VMS
5aabfad6 1087 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
b8ffc8df 1088 char pathbuf[256], eltbuf[256], *cp, *elt;
c623ac67 1089 Stat_t sbuf;
1e422769
PP
1090 int i = 0, j = 0;
1091
6fca0082 1092 my_strlcpy(eltbuf, s, sizeof(eltbuf));
b8ffc8df 1093 elt = eltbuf;
1e422769
PP
1094 do { /* DCL$PATH may be a search list */
1095 while (1) { /* as may dev portion of any element */
1096 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1097 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1098 cando_by_name(S_IWUSR,0,elt) ) {
1099 MgTAINTEDDIR_on(mg);
1100 return 0;
1101 }
1102 }
bd61b366 1103 if ((cp = strchr(elt, ':')) != NULL)
1e422769
PP
1104 *cp = '\0';
1105 if (my_trnlnm(elt, eltbuf, j++))
1106 elt = eltbuf;
1107 else
1108 break;
1109 }
1110 j = 0;
1111 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1112 }
1113#endif /* VMS */
5aabfad6 1114 if (s && klen == 4 && strEQ(ptr,"PATH")) {
8772537c 1115 const char * const strend = s + len;
463ee0b2
LW
1116
1117 while (s < strend) {
96827780 1118 char tmpbuf[256];
c623ac67 1119 Stat_t st;
5f74f29c 1120 I32 i;
f5a63d97
AL
1121#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1122 const char path_sep = '|';
1123#else
1124 const char path_sep = ':';
1125#endif
96827780 1126 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
427eaa01 1127 s, strend, path_sep, &i);
463ee0b2 1128 s++;
bb7a0f54 1129 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
326b5008
CB
1130#ifdef VMS
1131 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1132#else
1133 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1134#endif
c6ed36e1 1135 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1136 MgTAINTEDDIR_on(mg);
1e422769
PP
1137 return 0;
1138 }
463ee0b2 1139 }
79072805
LW
1140 }
1141 }
39e571d4 1142#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1143
79072805
LW
1144 return 0;
1145}
1146
1147int
864dbfa3 1148Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1149{
8772537c 1150 PERL_UNUSED_ARG(sv);
bd61b366 1151 my_setenv(MgPV_nolen_const(mg),NULL);
85e6fe83
LW
1152 return 0;
1153}
1154
88e89b8a 1155int
864dbfa3 1156Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1157{
97aff369 1158 dVAR;
65e66c80 1159 PERL_UNUSED_ARG(mg);
b0269e46 1160#if defined(VMS)
cea2e8a9 1161 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1162#else
3280af22 1163 if (PL_localizing) {
fb73857a 1164 HE* entry;
b0269e46 1165 my_clearenv();
fb73857a 1166 hv_iterinit((HV*)sv);
155aba94 1167 while ((entry = hv_iternext((HV*)sv))) {
fb73857a
PP
1168 I32 keylen;
1169 my_setenv(hv_iterkey(entry, &keylen),
b83604b4 1170 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
fb73857a
PP
1171 }
1172 }
1173#endif
1174 return 0;
1175}
1176
1177int
864dbfa3 1178Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1179{
27da23d5 1180 dVAR;
8772537c
AL
1181 PERL_UNUSED_ARG(sv);
1182 PERL_UNUSED_ARG(mg);
b0269e46
AB
1183#if defined(VMS)
1184 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1185#else
1186 my_clearenv();
1187#endif
3e3baf6d 1188 return 0;
66b1d557
HM
1189}
1190
64ca3a65 1191#ifndef PERL_MICRO
2d4fcd5e
AJ
1192#ifdef HAS_SIGPROCMASK
1193static void
1194restore_sigmask(pTHX_ SV *save_sv)
1195{
0bd48802 1196 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
f5a63d97 1197 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
2d4fcd5e
AJ
1198}
1199#endif
66b1d557 1200int
864dbfa3 1201Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1202{
97aff369 1203 dVAR;
88e89b8a 1204 /* Are we fetching a signal entry? */
8772537c 1205 const I32 i = whichsig(MgPV_nolen_const(mg));
e02bfb16 1206 if (i > 0) {
22c35a8c
GS
1207 if(PL_psig_ptr[i])
1208 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1209 else {
46da273f 1210 Sighandler_t sigstate = rsignal_state(i);
23ada85b 1211#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
46da273f
AL
1212 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1213 sigstate = SIG_IGN;
2e34cc90
CL
1214#endif
1215#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
46da273f
AL
1216 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1217 sigstate = SIG_DFL;
85b332e2 1218#endif
88e89b8a 1219 /* cache state so we don't fetch it again */
8aad04aa 1220 if(sigstate == (Sighandler_t) SIG_IGN)
6502358f 1221 sv_setpvs(sv,"IGNORE");
88e89b8a 1222 else
3280af22 1223 sv_setsv(sv,&PL_sv_undef);
46da273f 1224 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a
PP
1225 SvTEMP_off(sv);
1226 }
1227 }
1228 return 0;
1229}
1230int
864dbfa3 1231Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1232{
2d4fcd5e
AJ
1233 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1234 * refactoring might be in order.
1235 */
27da23d5 1236 dVAR;
8772537c
AL
1237 register const char * const s = MgPV_nolen_const(mg);
1238 PERL_UNUSED_ARG(sv);
2d4fcd5e 1239 if (*s == '_') {
cbbf8932 1240 SV** svp = NULL;
2d4fcd5e
AJ
1241 if (strEQ(s,"__DIE__"))
1242 svp = &PL_diehook;
b274dc4e 1243 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
2d4fcd5e 1244 svp = &PL_warnhook;
27da23d5 1245 if (svp && *svp) {
b274dc4e 1246 SV *const to_dec = *svp;
cbbf8932 1247 *svp = NULL;
b274dc4e 1248 SvREFCNT_dec(to_dec);
2d4fcd5e
AJ
1249 }
1250 }
1251 else {
2d4fcd5e 1252 /* Are we clearing a signal entry? */
8772537c 1253 const I32 i = whichsig(s);
e02bfb16 1254 if (i > 0) {
2d4fcd5e
AJ
1255#ifdef HAS_SIGPROCMASK
1256 sigset_t set, save;
1257 SV* save_sv;
1258 /* Avoid having the signal arrive at a bad time, if possible. */
1259 sigemptyset(&set);
1260 sigaddset(&set,i);
1261 sigprocmask(SIG_BLOCK, &set, &save);
1262 ENTER;
1263 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1264 SAVEFREESV(save_sv);
1265 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1266#endif
1267 PERL_ASYNC_CHECK();
1268#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1269 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2d4fcd5e
AJ
1270#endif
1271#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1272 PL_sig_defaulting[i] = 1;
5c1546dc 1273 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1274#else
8aad04aa 1275 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2d4fcd5e
AJ
1276#endif
1277 if(PL_psig_name[i]) {
1278 SvREFCNT_dec(PL_psig_name[i]);
1279 PL_psig_name[i]=0;
1280 }
1281 if(PL_psig_ptr[i]) {
6136c704 1282 SV * const to_dec=PL_psig_ptr[i];
2d4fcd5e
AJ
1283 PL_psig_ptr[i]=0;
1284 LEAVE;
1285 SvREFCNT_dec(to_dec);
1286 }
1287 else
1288 LEAVE;
1289 }
88e89b8a
PP
1290 }
1291 return 0;
1292}
3d37d572 1293
acd15b85
CB
1294/*
1295 * The signal handling nomenclature has gotten a bit confusing since the advent of
1296 * safe signals. S_raise_signal only raises signals by analogy with what the
1297 * underlying system's signal mechanism does. It might be more proper to say that
1298 * it defers signals that have already been raised and caught.
1299 *
1300 * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
1301 * in the sense of being on the system's signal queue in between raising and delivery.
1302 * They are only pending on Perl's deferral list, i.e., they track deferred signals
1303 * awaiting delivery after the current Perl opcode completes and say nothing about
1304 * signals raised but not yet caught in the underlying signal implementation.
1305 */
1306
2563cec5
IZ
1307#ifndef SIG_PENDING_DIE_COUNT
1308# define SIG_PENDING_DIE_COUNT 120
1309#endif
1310
dd374669
AL
1311static void
1312S_raise_signal(pTHX_ int sig)
0a8e0eff 1313{
97aff369 1314 dVAR;
0a8e0eff
NIS
1315 /* Set a flag to say this signal is pending */
1316 PL_psig_pend[sig]++;
1317 /* And one to say _a_ signal is pending */
2563cec5
IZ
1318 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1319 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1320 (unsigned long)SIG_PENDING_DIE_COUNT);
0a8e0eff
NIS
1321}
1322
1323Signal_t
8aad04aa
JH
1324#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1325Perl_csighandler(int sig, ...)
1326#else
0a8e0eff 1327Perl_csighandler(int sig)
8aad04aa 1328#endif
0a8e0eff 1329{
1018e26f
NIS
1330#ifdef PERL_GET_SIG_CONTEXT
1331 dTHXa(PERL_GET_SIG_CONTEXT);
1332#else
85b332e2
CL
1333 dTHX;
1334#endif
23ada85b 1335#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1336 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1337 if (PL_sig_ignoring[sig]) return;
85b332e2 1338#endif
2e34cc90 1339#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1340 if (PL_sig_defaulting[sig])
2e34cc90
CL
1341#ifdef KILL_BY_SIGPRC
1342 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1343#else
1344 exit(1);
1345#endif
1346#endif
853d2c32
RGS
1347 if (
1348#ifdef SIGILL
1349 sig == SIGILL ||
1350#endif
1351#ifdef SIGBUS
1352 sig == SIGBUS ||
1353#endif
1354#ifdef SIGSEGV
1355 sig == SIGSEGV ||
1356#endif
1357 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
4ffa73a3
JH
1358 /* Call the perl level handler now--
1359 * with risk we may be in malloc() etc. */
1360 (*PL_sighandlerp)(sig);
1361 else
dd374669 1362 S_raise_signal(aTHX_ sig);
0a8e0eff
NIS
1363}
1364
2e34cc90
CL
1365#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1366void
1367Perl_csighandler_init(void)
1368{
1369 int sig;
27da23d5 1370 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1371
1372 for (sig = 1; sig < SIG_SIZE; sig++) {
1373#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1374 dTHX;
27da23d5 1375 PL_sig_defaulting[sig] = 1;
5c1546dc 1376 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1377#endif
1378#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1379 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1380#endif
1381 }
27da23d5 1382 PL_sig_handlers_initted = 1;
2e34cc90
CL
1383}
1384#endif
1385
0a8e0eff
NIS
1386void
1387Perl_despatch_signals(pTHX)
1388{
97aff369 1389 dVAR;
0a8e0eff
NIS
1390 int sig;
1391 PL_sig_pending = 0;
1392 for (sig = 1; sig < SIG_SIZE; sig++) {
1393 if (PL_psig_pend[sig]) {
25da4428
JH
1394 PERL_BLOCKSIG_ADD(set, sig);
1395 PL_psig_pend[sig] = 0;
1396 PERL_BLOCKSIG_BLOCK(set);
f5203343 1397 (*PL_sighandlerp)(sig);
25da4428 1398 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS
1399 }
1400 }
1401}
1402
85e6fe83 1403int
864dbfa3 1404Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1405{
27da23d5 1406 dVAR;
79072805 1407 I32 i;
cbbf8932 1408 SV** svp = NULL;
2d4fcd5e
AJ
1409 /* Need to be careful with SvREFCNT_dec(), because that can have side
1410 * effects (due to closures). We must make sure that the new disposition
1411 * is in place before it is called.
1412 */
cbbf8932 1413 SV* to_dec = NULL;
e72dc28c 1414 STRLEN len;
2d4fcd5e
AJ
1415#ifdef HAS_SIGPROCMASK
1416 sigset_t set, save;
1417 SV* save_sv;
1418#endif
a0d0e21e 1419
d5263905 1420 register const char *s = MgPV_const(mg,len);
748a9306
LW
1421 if (*s == '_') {
1422 if (strEQ(s,"__DIE__"))
3280af22 1423 svp = &PL_diehook;
748a9306 1424 else if (strEQ(s,"__WARN__"))
3280af22 1425 svp = &PL_warnhook;
748a9306 1426 else
cea2e8a9 1427 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1428 i = 0;
4633a7c4 1429 if (*svp) {
9289f461
RGS
1430 if (*svp != PERL_WARNHOOK_FATAL)
1431 to_dec = *svp;
cbbf8932 1432 *svp = NULL;
4633a7c4 1433 }
748a9306
LW
1434 }
1435 else {
1436 i = whichsig(s); /* ...no, a brick */
86d86cad 1437 if (i <= 0) {
e476b1b5 1438 if (ckWARN(WARN_SIGNAL))
9014280d 1439 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1440 return 0;
1441 }
2d4fcd5e
AJ
1442#ifdef HAS_SIGPROCMASK
1443 /* Avoid having the signal arrive at a bad time, if possible. */
1444 sigemptyset(&set);
1445 sigaddset(&set,i);
1446 sigprocmask(SIG_BLOCK, &set, &save);
1447 ENTER;
1448 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1449 SAVEFREESV(save_sv);
1450 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1451#endif
1452 PERL_ASYNC_CHECK();
2e34cc90 1453#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1454 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1455#endif
23ada85b 1456#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1457 PL_sig_ignoring[i] = 0;
85b332e2 1458#endif
2e34cc90 1459#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1460 PL_sig_defaulting[i] = 0;
2e34cc90 1461#endif
22c35a8c 1462 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1463 to_dec = PL_psig_ptr[i];
46da273f 1464 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a 1465 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1466 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1467 SvREADONLY_on(PL_psig_name[i]);
748a9306 1468 }
a0d0e21e 1469 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1470 if (i) {
5c1546dc 1471 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1472#ifdef HAS_SIGPROCMASK
1473 LEAVE;
1474#endif
1475 }
748a9306 1476 else
b37c2d43 1477 *svp = SvREFCNT_inc_simple_NN(sv);
2d4fcd5e
AJ
1478 if(to_dec)
1479 SvREFCNT_dec(to_dec);
a0d0e21e
LW
1480 return 0;
1481 }
baf38871 1482 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
748a9306 1483 if (strEQ(s,"IGNORE")) {
85b332e2 1484 if (i) {
23ada85b 1485#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1486 PL_sig_ignoring[i] = 1;
5c1546dc 1487 (void)rsignal(i, PL_csighandlerp);
85b332e2 1488#else
8aad04aa 1489 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1490#endif
2d4fcd5e 1491 }
748a9306
LW
1492 }
1493 else if (strEQ(s,"DEFAULT") || !*s) {
1494 if (i)
2e34cc90
CL
1495#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1496 {
27da23d5 1497 PL_sig_defaulting[i] = 1;
5c1546dc 1498 (void)rsignal(i, PL_csighandlerp);
2e34cc90
CL
1499 }
1500#else
8aad04aa 1501 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1502#endif
748a9306 1503 }
79072805 1504 else {
5aabfad6
PP
1505 /*
1506 * We should warn if HINT_STRICT_REFS, but without
1507 * access to a known hint bit in a known OP, we can't
1508 * tell whether HINT_STRICT_REFS is in force or not.
1509 */
46fc3d4c 1510 if (!strchr(s,':') && !strchr(s,'\''))
89529cee 1511 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
748a9306 1512 if (i)
5c1546dc 1513 (void)rsignal(i, PL_csighandlerp);
748a9306 1514 else
46da273f 1515 *svp = SvREFCNT_inc_simple_NN(sv);
79072805 1516 }
2d4fcd5e
AJ
1517#ifdef HAS_SIGPROCMASK
1518 if(i)
1519 LEAVE;
1520#endif
1521 if(to_dec)
1522 SvREFCNT_dec(to_dec);
79072805
LW
1523 return 0;
1524}
64ca3a65 1525#endif /* !PERL_MICRO */
79072805
LW
1526
1527int
864dbfa3 1528Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1529{
97aff369 1530 dVAR;
8772537c
AL
1531 PERL_UNUSED_ARG(sv);
1532 PERL_UNUSED_ARG(mg);
3280af22 1533 PL_sub_generation++;
463ee0b2
LW
1534 return 0;
1535}
1536
1537int
864dbfa3 1538Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1539{
97aff369 1540 dVAR;
8772537c
AL
1541 PERL_UNUSED_ARG(sv);
1542 PERL_UNUSED_ARG(mg);
a0d0e21e 1543 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1544 PL_amagic_generation++;
463ee0b2 1545
a0d0e21e
LW
1546 return 0;
1547}
463ee0b2 1548
946ec16e 1549int
864dbfa3 1550Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1551{
dd374669 1552 HV * const hv = (HV*)LvTARG(sv);
6ff81951 1553 I32 i = 0;
8772537c 1554 PERL_UNUSED_ARG(mg);
7719e241 1555
6ff81951 1556 if (hv) {
497b47a8
JH
1557 (void) hv_iterinit(hv);
1558 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1559 i = HvKEYS(hv);
1560 else {
1561 while (hv_iternext(hv))
1562 i++;
1563 }
6ff81951
GS
1564 }
1565
1566 sv_setiv(sv, (IV)i);
1567 return 0;
1568}
1569
1570int
864dbfa3 1571Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1572{
8772537c 1573 PERL_UNUSED_ARG(mg);
946ec16e
PP
1574 if (LvTARG(sv)) {
1575 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1576 }
1577 return 0;
ac27b0f5 1578}
946ec16e 1579
e336de0d 1580/* caller is responsible for stack switching/cleanup */
565764a8 1581STATIC int
e1ec3a88 1582S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
a0d0e21e 1583{
97aff369 1584 dVAR;
a0d0e21e 1585 dSP;
463ee0b2 1586
924508f0
GS
1587 PUSHMARK(SP);
1588 EXTEND(SP, n);
33c27489 1589 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1590 if (n > 1) {
93965878 1591 if (mg->mg_ptr) {
565764a8 1592 if (mg->mg_len >= 0)
79cb57f6 1593 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1594 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1595 PUSHs((SV*)mg->mg_ptr);
1596 }
14befaf4 1597 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1598 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1599 }
1600 }
1601 if (n > 2) {
1602 PUSHs(val);
88e89b8a 1603 }
463ee0b2
LW
1604 PUTBACK;
1605
864dbfa3 1606 return call_method(meth, flags);
946ec16e
PP
1607}
1608
76e3520e 1609STATIC int
e1ec3a88 1610S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1611{
27da23d5 1612 dVAR; dSP;
463ee0b2 1613
a0d0e21e
LW
1614 ENTER;
1615 SAVETMPS;
e788e7d3 1616 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1617
33c27489 1618 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1619 sv_setsv(sv, *PL_stack_sp--);
93965878 1620 }
463ee0b2 1621
d3acc0f7 1622 POPSTACK;
a0d0e21e
LW
1623 FREETMPS;
1624 LEAVE;
1625 return 0;
1626}
463ee0b2 1627
a0d0e21e 1628int
864dbfa3 1629Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1630{
a0d0e21e
LW
1631 if (mg->mg_ptr)
1632 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1633 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1634 return 0;
1635}
1636
1637int
864dbfa3 1638Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1639{
27da23d5 1640 dVAR; dSP;
a60c0954 1641 ENTER;
e788e7d3 1642 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1643 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1644 POPSTACK;
a60c0954 1645 LEAVE;
463ee0b2
LW
1646 return 0;
1647}
1648
1649int
864dbfa3 1650Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1651{
a0d0e21e
LW
1652 return magic_methpack(sv,mg,"DELETE");
1653}
463ee0b2 1654
93965878
NIS
1655
1656U32
864dbfa3 1657Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1658{
27da23d5 1659 dVAR; dSP;
93965878
NIS
1660 U32 retval = 0;
1661
1662 ENTER;
1663 SAVETMPS;
e788e7d3 1664 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1665 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1666 sv = *PL_stack_sp--;
a60c0954 1667 retval = (U32) SvIV(sv)-1;
93965878 1668 }
d3acc0f7 1669 POPSTACK;
93965878
NIS
1670 FREETMPS;
1671 LEAVE;
1672 return retval;
1673}
1674
cea2e8a9
GS
1675int
1676Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1677{
27da23d5 1678 dVAR; dSP;
463ee0b2 1679
e336de0d 1680 ENTER;
e788e7d3 1681 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1682 PUSHMARK(SP);
33c27489 1683 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1684 PUTBACK;
864dbfa3 1685 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1686 POPSTACK;
a60c0954 1687 LEAVE;
a3bcc51e 1688
463ee0b2
LW
1689 return 0;
1690}
1691
1692int
864dbfa3 1693Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1694{
27da23d5 1695 dVAR; dSP;
666ea192 1696 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1697
1698 ENTER;
a0d0e21e 1699 SAVETMPS;
e788e7d3 1700 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1701 PUSHMARK(SP);
1702 EXTEND(SP, 2);
33c27489 1703 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1704 if (SvOK(key))
1705 PUSHs(key);
1706 PUTBACK;
1707
864dbfa3 1708 if (call_method(meth, G_SCALAR))
3280af22 1709 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1710
d3acc0f7 1711 POPSTACK;
a0d0e21e
LW
1712 FREETMPS;
1713 LEAVE;
79072805
LW
1714 return 0;
1715}
1716
1717int
1146e912 1718Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
a0d0e21e
LW
1719{
1720 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1721}
a0d0e21e 1722
a3bcc51e
TP
1723SV *
1724Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1725{
27da23d5 1726 dVAR; dSP;
5fcbf73d 1727 SV *retval;
8772537c
AL
1728 SV * const tied = SvTIED_obj((SV*)hv, mg);
1729 HV * const pkg = SvSTASH((SV*)SvRV(tied));
a3bcc51e
TP
1730
1731 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1732 SV *key;
bfcb3514 1733 if (HvEITER_get(hv))
a3bcc51e
TP
1734 /* we are in an iteration so the hash cannot be empty */
1735 return &PL_sv_yes;
1736 /* no xhv_eiter so now use FIRSTKEY */
1737 key = sv_newmortal();
1738 magic_nextpack((SV*)hv, mg, key);
bfcb3514 1739 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1740 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1741 }
1742
1743 /* there is a SCALAR method that we can call */
1744 ENTER;
1745 PUSHSTACKi(PERLSI_MAGIC);
1746 PUSHMARK(SP);
1747 EXTEND(SP, 1);
1748 PUSHs(tied);
1749 PUTBACK;
1750
1751 if (call_method("SCALAR", G_SCALAR))
1752 retval = *PL_stack_sp--;
5fcbf73d
AL
1753 else
1754 retval = &PL_sv_undef;
a3bcc51e
TP
1755 POPSTACK;
1756 LEAVE;
1757 return retval;
1758}
1759
a0d0e21e 1760int
864dbfa3 1761Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1762{
97aff369 1763 dVAR;
8772537c
AL
1764 GV * const gv = PL_DBline;
1765 const I32 i = SvTRUE(sv);
1766 SV ** const svp = av_fetch(GvAV(gv),
01b8bcb7 1767 atoi(MgPV_nolen_const(mg)), FALSE);
8772537c
AL
1768 if (svp && SvIOKp(*svp)) {
1769 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1770 if (o) {
1771 /* set or clear breakpoint in the relevant control op */
1772 if (i)
1773 o->op_flags |= OPf_SPECIAL;
1774 else
1775 o->op_flags &= ~OPf_SPECIAL;
1776 }
5df8de69 1777 }
79072805
LW
1778 return 0;
1779}
1780
1781int
8772537c 1782Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 1783{
97aff369 1784 dVAR;
8772537c 1785 const AV * const obj = (AV*)mg->mg_obj;
83bf042f 1786 if (obj) {
fc15ae8f 1787 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
83bf042f
NC
1788 } else {
1789 SvOK_off(sv);
1790 }
79072805
LW
1791 return 0;
1792}
1793
1794int
864dbfa3 1795Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1796{
97aff369 1797 dVAR;
8772537c 1798 AV * const obj = (AV*)mg->mg_obj;
83bf042f 1799 if (obj) {
fc15ae8f 1800 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
83bf042f
NC
1801 } else {
1802 if (ckWARN(WARN_MISC))
1803 Perl_warner(aTHX_ packWARN(WARN_MISC),
1804 "Attempt to set length of freed array");
1805 }
1806 return 0;
1807}
1808
1809int
1810Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1811{
97aff369 1812 dVAR;
53c1dcc0 1813 PERL_UNUSED_ARG(sv);
94f3782b
DM
1814 /* during global destruction, mg_obj may already have been freed */
1815 if (PL_in_clean_all)
1ea47f64 1816 return 0;
94f3782b 1817
83bf042f
NC
1818 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1819
1820 if (mg) {
1821 /* arylen scalar holds a pointer back to the array, but doesn't own a
1822 reference. Hence the we (the array) are about to go away with it
1823 still pointing at us. Clear its pointer, else it would be pointing
1824 at free memory. See the comment in sv_magic about reference loops,
1825 and why it can't own a reference to us. */
1826 mg->mg_obj = 0;
1827 }
a0d0e21e
LW
1828 return 0;
1829}
1830
1831int
864dbfa3 1832Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1833{
97aff369 1834 dVAR;
8772537c 1835 SV* const lsv = LvTARG(sv);
3881461a 1836 PERL_UNUSED_ARG(mg);
ac27b0f5 1837
a0d0e21e 1838 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
3881461a
AL
1839 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1840 if (found && found->mg_len >= 0) {
1841 I32 i = found->mg_len;
7e2040f0 1842 if (DO_UTF8(lsv))
a0ed51b3 1843 sv_pos_b2u(lsv, &i);
fc15ae8f 1844 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
a0d0e21e
LW
1845 return 0;
1846 }
1847 }
0c34ef67 1848 SvOK_off(sv);
a0d0e21e
LW
1849 return 0;
1850}
1851
1852int
864dbfa3 1853Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1854{
97aff369 1855 dVAR;
8772537c 1856 SV* const lsv = LvTARG(sv);
a0d0e21e
LW
1857 SSize_t pos;
1858 STRLEN len;
c00206c8 1859 STRLEN ulen = 0;
53d44271 1860 MAGIC* found;
a0d0e21e 1861
3881461a 1862 PERL_UNUSED_ARG(mg);
ac27b0f5 1863
a0d0e21e 1864 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
3881461a
AL
1865 found = mg_find(lsv, PERL_MAGIC_regex_global);
1866 else
1867 found = NULL;
1868 if (!found) {
a0d0e21e
LW
1869 if (!SvOK(sv))
1870 return 0;
d83f0a82
NC
1871#ifdef PERL_OLD_COPY_ON_WRITE
1872 if (SvIsCOW(lsv))
1873 sv_force_normal_flags(lsv, 0);
1874#endif
3881461a 1875 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
53d44271 1876 NULL, 0);
a0d0e21e
LW
1877 }
1878 else if (!SvOK(sv)) {
3881461a 1879 found->mg_len = -1;
a0d0e21e
LW
1880 return 0;
1881 }
1882 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1883
fc15ae8f 1884 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
a0ed51b3 1885
7e2040f0 1886 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1887 ulen = sv_len_utf8(lsv);
1888 if (ulen)
1889 len = ulen;
a0ed51b3
LW
1890 }
1891
a0d0e21e
LW
1892 if (pos < 0) {
1893 pos += len;
1894 if (pos < 0)
1895 pos = 0;
1896 }
eb160463 1897 else if (pos > (SSize_t)len)
a0d0e21e 1898 pos = len;
a0ed51b3
LW
1899
1900 if (ulen) {
1901 I32 p = pos;
1902 sv_pos_u2b(lsv, &p, 0);
1903 pos = p;
1904 }
727405f8 1905
3881461a
AL
1906 found->mg_len = pos;
1907 found->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1908
79072805
LW
1909 return 0;
1910}
1911
1912int
864dbfa3 1913Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1914{
79072805 1915 GV* gv;
8772537c
AL
1916 PERL_UNUSED_ARG(mg);
1917
79072805
LW
1918 if (!SvOK(sv))
1919 return 0;
2e5b91de 1920 if (isGV_with_GP(sv)) {
180488f8
NC
1921 /* We're actually already a typeglob, so don't need the stuff below.
1922 */
1923 return 0;
1924 }
f776e3cd 1925 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
79072805
LW
1926 if (sv == (SV*)gv)
1927 return 0;
1928 if (GvGP(sv))
88e89b8a 1929 gp_free((GV*)sv);
79072805 1930 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1931 return 0;
1932}
1933
1934int
864dbfa3 1935Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1936{
1937 STRLEN len;
35a4481c 1938 SV * const lsv = LvTARG(sv);
b83604b4 1939 const char * const tmps = SvPV_const(lsv,len);
6ff81951
GS
1940 I32 offs = LvTARGOFF(sv);
1941 I32 rem = LvTARGLEN(sv);
8772537c 1942 PERL_UNUSED_ARG(mg);
6ff81951 1943
9aa983d2
JH
1944 if (SvUTF8(lsv))
1945 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1946 if (offs > (I32)len)
6ff81951 1947 offs = len;
eb160463 1948 if (rem + offs > (I32)len)
6ff81951
GS
1949 rem = len - offs;
1950 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1951 if (SvUTF8(lsv))
2ef4b674 1952 SvUTF8_on(sv);
6ff81951
GS
1953 return 0;
1954}
1955
1956int
864dbfa3 1957Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1958{
97aff369 1959 dVAR;
9aa983d2 1960 STRLEN len;
5fcbf73d 1961 const char * const tmps = SvPV_const(sv, len);
dd374669 1962 SV * const lsv = LvTARG(sv);
9aa983d2
JH
1963 I32 lvoff = LvTARGOFF(sv);
1964 I32 lvlen = LvTARGLEN(sv);
8772537c 1965 PERL_UNUSED_ARG(mg);
075a4a2b 1966
1aa99e6b 1967 if (DO_UTF8(sv)) {
9aa983d2
JH
1968 sv_utf8_upgrade(lsv);
1969 sv_pos_u2b(lsv, &lvoff, &lvlen);
1970 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 1971 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2
JH
1972 SvUTF8_on(lsv);
1973 }
9bf12eaf 1974 else if (lsv && SvUTF8(lsv)) {
5fcbf73d 1975 const char *utf8;
9aa983d2 1976 sv_pos_u2b(lsv, &lvoff, &lvlen);
b76f3ce2 1977 LvTARGLEN(sv) = len;
5fcbf73d
AL
1978 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1979 sv_insert(lsv, lvoff, lvlen, utf8, len);
1980 Safefree(utf8);
1aa99e6b 1981 }
b76f3ce2
GB
1982 else {
1983 sv_insert(lsv, lvoff, lvlen, tmps, len);
1984 LvTARGLEN(sv) = len;
1985 }
1986
1aa99e6b 1987
79072805
LW
1988 return 0;
1989}
1990
1991int
864dbfa3 1992Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1993{
97aff369 1994 dVAR;
8772537c 1995 PERL_UNUSED_ARG(sv);
27cc343c 1996 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW
1997 return 0;
1998}
1999
2000int
864dbfa3 2001Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2002{
97aff369 2003 dVAR;
8772537c 2004 PERL_UNUSED_ARG(sv);
0a9c116b
DM
2005 /* update taint status unless we're restoring at scope exit */
2006 if (PL_localizing != 2) {
2007 if (PL_tainted)
2008 mg->mg_len |= 1;
2009 else
2010 mg->mg_len &= ~1;
2011 }
463ee0b2
LW
2012 return 0;
2013}
2014
2015int
864dbfa3 2016Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 2017{
35a4481c 2018 SV * const lsv = LvTARG(sv);
8772537c 2019 PERL_UNUSED_ARG(mg);
6ff81951 2020
6136c704
AL
2021 if (lsv)
2022 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2023 else
0c34ef67 2024 SvOK_off(sv);
6ff81951 2025
6ff81951
GS
2026 return 0;
2027}
2028
2029int
864dbfa3 2030Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 2031{
8772537c 2032 PERL_UNUSED_ARG(mg);
79072805
LW
2033 do_vecset(sv); /* XXX slurp this routine */
2034 return 0;
2035}
2036
2037int
864dbfa3 2038Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 2039{
97aff369 2040 dVAR;
a0714e2c 2041 SV *targ = NULL;
5f05dabc 2042 if (LvTARGLEN(sv)) {
68dc0745 2043 if (mg->mg_obj) {
8772537c
AL
2044 SV * const ahv = LvTARG(sv);
2045 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
6d822dc4
MS
2046 if (he)
2047 targ = HeVAL(he);
68dc0745
PP
2048 }
2049 else {
8772537c 2050 AV* const av = (AV*)LvTARG(sv);
68dc0745
PP
2051 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2052 targ = AvARRAY(av)[LvTARGOFF(sv)];
2053 }
46da273f 2054 if (targ && (targ != &PL_sv_undef)) {
68dc0745
PP
2055 /* somebody else defined it for us */
2056 SvREFCNT_dec(LvTARG(sv));
b37c2d43 2057 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
68dc0745
PP
2058 LvTARGLEN(sv) = 0;
2059 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2060 mg->mg_obj = NULL;
68dc0745
PP
2061 mg->mg_flags &= ~MGf_REFCOUNTED;
2062 }
5f05dabc 2063 }
71be2cbc
PP
2064 else
2065 targ = LvTARG(sv);
3280af22 2066 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
2067 return 0;
2068}
2069
2070int
864dbfa3 2071Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2072{
8772537c 2073 PERL_UNUSED_ARG(mg);
71be2cbc 2074 if (LvTARGLEN(sv))
68dc0745
PP
2075 vivify_defelem(sv);
2076 if (LvTARG(sv)) {
5f05dabc 2077 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
2078 SvSETMAGIC(LvTARG(sv));
2079 }
5f05dabc
PP
2080 return 0;
2081}
2082
71be2cbc 2083void
864dbfa3 2084Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2085{
97aff369 2086 dVAR;
74e13ce4 2087 MAGIC *mg;
a0714e2c 2088 SV *value = NULL;
71be2cbc 2089
14befaf4 2090 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2091 return;
68dc0745 2092 if (mg->mg_obj) {
8772537c
AL
2093 SV * const ahv = LvTARG(sv);
2094 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
6d822dc4
MS
2095 if (he)
2096 value = HeVAL(he);
3280af22 2097 if (!value || value == &PL_sv_undef)
be2597df 2098 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
71be2cbc 2099 }
68dc0745 2100 else {
8772537c 2101 AV* const av = (AV*)LvTARG(sv);
5aabfad6 2102 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
a0714e2c 2103 LvTARG(sv) = NULL; /* array can't be extended */
68dc0745 2104 else {
d4c19fe8 2105 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2106 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2107 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
2108 }
2109 }
b37c2d43 2110 SvREFCNT_inc_simple_void(value);
68dc0745
PP
2111 SvREFCNT_dec(LvTARG(sv));
2112 LvTARG(sv) = value;
71be2cbc 2113 LvTARGLEN(sv) = 0;
68dc0745 2114 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2115 mg->mg_obj = NULL;
68dc0745 2116 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2117}
2118
2119int
864dbfa3 2120Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2121{
86f55936 2122 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
810b8aa5
GS
2123}
2124
2125int
864dbfa3 2126Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2127{
96a5add6 2128 PERL_UNUSED_CONTEXT;
565764a8 2129 mg->mg_len = -1;
c6496cc7 2130 SvSCREAM_off(sv);
93a17b20
LW
2131 return 0;
2132}
2133
2134int
864dbfa3 2135Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 2136{
8772537c 2137 PERL_UNUSED_ARG(mg);
14befaf4 2138 sv_unmagic(sv, PERL_MAGIC_bm);
b84d1fce 2139 SvTAIL_off(sv);
79072805
LW
2140 SvVALID_off(sv);
2141 return 0;
2142}
2143
2144int
864dbfa3 2145Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 2146{
8772537c 2147 PERL_UNUSED_ARG(mg);
14befaf4 2148 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
2149 SvCOMPILED_off(sv);
2150 return 0;
2151}
2152
2153int
864dbfa3 2154Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2155{
35a4481c 2156 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
2157
2158 if (uf && uf->uf_set)
24f81a43 2159 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2160 return 0;
2161}
2162
c277df42 2163int
faf82a0b
AE
2164Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2165{
8772537c 2166 PERL_UNUSED_ARG(mg);
faf82a0b
AE
2167 sv_unmagic(sv, PERL_MAGIC_qr);
2168 return 0;
2169}
2170
2171int
864dbfa3 2172Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42 2173{
97aff369 2174 dVAR;
8772537c
AL
2175 regexp * const re = (regexp *)mg->mg_obj;
2176 PERL_UNUSED_ARG(sv);
2177
c277df42
IZ
2178 ReREFCNT_dec(re);
2179 return 0;
2180}
2181
7a4c00b4 2182#ifdef USE_LOCALE_COLLATE
79072805 2183int
864dbfa3 2184Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
2185{
2186 /*
838b5b74 2187 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2188 * and vanished with a faint plop.
2189 */
96a5add6 2190 PERL_UNUSED_CONTEXT;
8772537c 2191 PERL_UNUSED_ARG(sv);
7a4c00b4
PP
2192 if (mg->mg_ptr) {
2193 Safefree(mg->mg_ptr);
2194 mg->mg_ptr = NULL;
565764a8 2195 mg->mg_len = -1;
7a4c00b4 2196 }
bbce6d69
PP
2197 return 0;
2198}
7a4c00b4 2199#endif /* USE_LOCALE_COLLATE */
bbce6d69 2200
7e8c5dac
HS
2201/* Just clear the UTF-8 cache data. */
2202int
2203Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2204{
96a5add6 2205 PERL_UNUSED_CONTEXT;
8772537c 2206 PERL_UNUSED_ARG(sv);
7e8c5dac 2207 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
3881461a 2208 mg->mg_ptr = NULL;
7e8c5dac
HS
2209 mg->mg_len = -1; /* The mg_len holds the len cache. */
2210 return 0;
2211}
2212
bbce6d69 2213int
864dbfa3 2214Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2215{
97aff369 2216 dVAR;
e1ec3a88 2217 register const char *s;
79072805 2218 I32 i;
8990e307 2219 STRLEN len;
79072805 2220 switch (*mg->mg_ptr) {
748a9306 2221 case '\001': /* ^A */
3280af22 2222 sv_setsv(PL_bodytarget, sv);
748a9306 2223 break;
49460fe6 2224 case '\003': /* ^C */
38ab35f8 2225 PL_minus_c = (bool)SvIV(sv);
49460fe6
NIS
2226 break;
2227
79072805 2228 case '\004': /* ^D */
b4ab917c 2229#ifdef DEBUGGING
b83604b4 2230 s = SvPV_nolen_const(sv);
ddcf8bc1 2231 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2232 DEBUG_x(dump_all());
b4ab917c 2233#else
38ab35f8 2234 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
b4ab917c 2235#endif
79072805 2236 break;
28f23441 2237 case '\005': /* ^E */
d0063567 2238 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2239#ifdef MACOS_TRADITIONAL
38ab35f8 2240 gMacPerl_OSErr = SvIV(sv);
28f23441 2241#else
cd39f2b6 2242# ifdef VMS
38ab35f8 2243 set_vaxc_errno(SvIV(sv));
048c1ddf 2244# else
cd39f2b6 2245# ifdef WIN32
d0063567 2246 SetLastError( SvIV(sv) );
cd39f2b6 2247# else
9fed8b87 2248# ifdef OS2
38ab35f8 2249 os2_setsyserrno(SvIV(sv));
9fed8b87 2250# else
d0063567 2251 /* will anyone ever use this? */
38ab35f8 2252 SETERRNO(SvIV(sv), 4);
cd39f2b6 2253# endif
048c1ddf
IZ
2254# endif
2255# endif
22fae026 2256#endif
d0063567
DK
2257 }
2258 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2259 if (PL_encoding)
2260 SvREFCNT_dec(PL_encoding);
2261 if (SvOK(sv) || SvGMAGICAL(sv)) {
2262 PL_encoding = newSVsv(sv);
2263 }
2264 else {
a0714e2c 2265 PL_encoding = NULL;
d0063567
DK
2266 }
2267 }
2268 break;
79072805 2269 case '\006': /* ^F */
38ab35f8 2270 PL_maxsysfd = SvIV(sv);
79072805 2271 break;
a0d0e21e 2272 case '\010': /* ^H */
38ab35f8 2273 PL_hints = SvIV(sv);
a0d0e21e 2274 break;
9d116dd7 2275 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d 2276 Safefree(PL_inplace);
bd61b366 2277 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
da78da6e 2278 break;
28f23441 2279 case '\017': /* ^O */
ac27b0f5 2280 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d 2281 Safefree(PL_osname);
bd61b366 2282 PL_osname = NULL;
3511154c
DM
2283 if (SvOK(sv)) {
2284 TAINT_PROPER("assigning to $^O");
2e0de35c 2285 PL_osname = savesvpv(sv);
3511154c 2286 }
ac27b0f5
NIS
2287 }
2288 else if (strEQ(mg->mg_ptr, "\017PEN")) {
8b850bd5
NC
2289 STRLEN len;
2290 const char *const start = SvPV(sv, len);
b54fc2b6 2291 const char *out = (const char*)memchr(start, '\0', len);
8b850bd5
NC
2292 SV *tmp;
2293 struct refcounted_he *tmp_he;
2294
2295
2296 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2297 PL_hints
2298 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2299
2300 /* Opening for input is more common than opening for output, so
2301 ensure that hints for input are sooner on linked list. */
2302 tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2303 : newSVpvs(""));
2304 SvFLAGS(tmp) |= SvUTF8(sv);
2305
2306 tmp_he
2307 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2308 sv_2mortal(newSVpvs("open>")), tmp);
2309
2310 /* The UTF-8 setting is carried over */
2311 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2312
11bcd5da 2313 PL_compiling.cop_hints_hash
8b850bd5
NC
2314 = Perl_refcounted_he_new(aTHX_ tmp_he,
2315 sv_2mortal(newSVpvs("open<")), tmp);
ac27b0f5 2316 }
28f23441 2317 break;
79072805 2318 case '\020': /* ^P */
38ab35f8 2319 PL_perldb = SvIV(sv);
f2a7f298 2320 if (PL_perldb && !PL_DBsingle)
1ee4443e 2321 init_debugger();
79072805
LW
2322 break;
2323 case '\024': /* ^T */
88e89b8a 2324#ifdef BIG_TIME
6b88bc9c 2325 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2326#else
38ab35f8 2327 PL_basetime = (Time_t)SvIV(sv);
88e89b8a 2328#endif
79072805 2329 break;
e07ea26a
NC
2330 case '\025': /* ^UTF8CACHE */
2331 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2332 PL_utf8cache = (signed char) sv_2iv(sv);
2333 }
2334 break;
fde18df1 2335 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2336 if (*(mg->mg_ptr+1) == '\0') {
2337 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
38ab35f8 2338 i = SvIV(sv);
ac27b0f5 2339 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2340 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2341 }
599cee73 2342 }
0a378802 2343 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2344 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2345 if (!SvPOK(sv) && PL_localizing) {
2346 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2347 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2348 break;
2349 }
f4fc7782 2350 {
b5477537 2351 STRLEN len, i;
d3a7d8c7 2352 int accumulate = 0 ;
f4fc7782 2353 int any_fatals = 0 ;
b83604b4 2354 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2355 for (i = 0 ; i < len ; ++i) {
2356 accumulate |= ptr[i] ;
2357 any_fatals |= (ptr[i] & 0xAA) ;
2358 }
4243c432
NC
2359 if (!accumulate) {
2360 if (!specialWARN(PL_compiling.cop_warnings))
2361 PerlMemShared_free(PL_compiling.cop_warnings);
2362 PL_compiling.cop_warnings = pWARN_NONE;
2363 }
72dc9ed5
NC
2364 /* Yuck. I can't see how to abstract this: */
2365 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2366 WARN_ALL) && !any_fatals) {
4243c432
NC
2367 if (!specialWARN(PL_compiling.cop_warnings))
2368 PerlMemShared_free(PL_compiling.cop_warnings);
f4fc7782
JH
2369 PL_compiling.cop_warnings = pWARN_ALL;
2370 PL_dowarn |= G_WARN_ONCE ;
727405f8 2371 }
d3a7d8c7 2372 else {
72dc9ed5
NC
2373 STRLEN len;
2374 const char *const p = SvPV_const(sv, len);
2375
2376 PL_compiling.cop_warnings
8ee4cf24 2377 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
72dc9ed5
NC
2378 p, len);
2379
d3a7d8c7
GS
2380 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2381 PL_dowarn |= G_WARN_ONCE ;
2382 }
f4fc7782 2383
d3a7d8c7 2384 }
4438c4b7 2385 }
971a9dd3 2386 }
79072805
LW
2387 break;
2388 case '.':
3280af22
NIS
2389 if (PL_localizing) {
2390 if (PL_localizing == 1)
7766f137 2391 SAVESPTR(PL_last_in_gv);
748a9306 2392 }
3280af22 2393 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2394 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2395 break;
2396 case '^':
3280af22 2397 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2398 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
f776e3cd 2399 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2400 break;
2401 case '~':
3280af22 2402 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2403 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
f776e3cd 2404 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2405 break;
2406 case '=':
38ab35f8 2407 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2408 break;
2409 case '-':
38ab35f8 2410 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
3280af22
NIS
2411 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2412 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2413 break;
2414 case '%':
38ab35f8 2415 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2416 break;
2417 case '|':
4b65379b 2418 {
8772537c 2419 IO * const io = GvIOp(PL_defoutgv);
720f287d
AB
2420 if(!io)
2421 break;
38ab35f8 2422 if ((SvIV(sv)) == 0)
4b65379b
CS
2423 IoFLAGS(io) &= ~IOf_FLUSH;
2424 else {
2425 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2426 PerlIO *ofp = IoOFP(io);
2427 if (ofp)
2428 (void)PerlIO_flush(ofp);
2429 IoFLAGS(io) |= IOf_FLUSH;
2430 }
2431 }
79072805
LW
2432 }
2433 break;
79072805 2434 case '/':
3280af22 2435 SvREFCNT_dec(PL_rs);
8bfdd7d9 2436 PL_rs = newSVsv(sv);
79072805
LW
2437 break;
2438 case '\\':
7889fe52
NIS
2439 if (PL_ors_sv)
2440 SvREFCNT_dec(PL_ors_sv);
009c130f 2441 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2442 PL_ors_sv = newSVsv(sv);
009c130f 2443 }
e3c19b7b 2444 else {
a0714e2c 2445 PL_ors_sv = NULL;
e3c19b7b 2446 }
79072805
LW
2447 break;
2448 case ',':
7889fe52
NIS
2449 if (PL_ofs_sv)
2450 SvREFCNT_dec(PL_ofs_sv);
2451 if (SvOK(sv) || SvGMAGICAL(sv)) {
2452 PL_ofs_sv = newSVsv(sv);
2453 }
2454 else {
a0714e2c 2455 PL_ofs_sv = NULL;
7889fe52 2456 }
79072805 2457 break;
79072805 2458 case '[':
38ab35f8 2459 CopARYBASE_set(&PL_compiling, SvIV(sv));
79072805
LW
2460 break;
2461 case '?':
ff0cee69 2462#ifdef COMPLEX_STATUS
6b88bc9c
GS
2463 if (PL_localizing == 2) {
2464 PL_statusvalue = LvTARGOFF(sv);
2465 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2466 }
2467 else
2468#endif
2469#ifdef VMSISH_STATUS
2470 if (VMSISH_STATUS)
fb38d079 2471 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
ff0cee69
PP
2472 else
2473#endif
38ab35f8 2474 STATUS_UNIX_EXIT_SET(SvIV(sv));
79072805
LW
2475 break;
2476 case '!':
93189314
JH
2477 {
2478#ifdef VMS
2479# define PERL_VMS_BANG vaxc$errno
2480#else
2481# define PERL_VMS_BANG 0
2482#endif
91487cfc 2483 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2484 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2485 }
79072805
LW
2486 break;
2487 case '<':
38ab35f8 2488 PL_uid = SvIV(sv);
3280af22
NIS
2489 if (PL_delaymagic) {
2490 PL_delaymagic |= DM_RUID;
79072805
LW
2491 break; /* don't do magic till later */
2492 }
2493#ifdef HAS_SETRUID
b28d0864 2494 (void)setruid((Uid_t)PL_uid);
79072805
LW
2495#else
2496#ifdef HAS_SETREUID
3280af22 2497 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2498#else
85e6fe83 2499#ifdef HAS_SETRESUID
b28d0864 2500 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2501#else
75870ed3 2502 if (PL_uid == PL_euid) { /* special case $< = $> */
2503#ifdef PERL_DARWIN
2504 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2505 if (PL_uid != 0 && PerlProc_getuid() == 0)
2506 (void)PerlProc_setuid(0);
2507#endif
b28d0864 2508 (void)PerlProc_setuid(PL_uid);
75870ed3 2509 } else {
d8eceb89 2510 PL_uid = PerlProc_getuid();
cea2e8a9 2511 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2512 }
79072805
LW
2513#endif
2514#endif
85e6fe83 2515#endif
d8eceb89 2516 PL_uid = PerlProc_getuid();
3280af22 2517 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2518 break;
2519 case '>':
38ab35f8 2520 PL_euid = SvIV(sv);
3280af22
NIS
2521 if (PL_delaymagic) {
2522 PL_delaymagic |= DM_EUID;
79072805
LW
2523 break; /* don't do magic till later */
2524 }
2525#ifdef HAS_SETEUID
3280af22 2526 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2527#else
2528#ifdef HAS_SETREUID
b28d0864 2529 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2530#else
2531#ifdef HAS_SETRESUID
6b88bc9c 2532 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2533#else
b28d0864
NIS
2534 if (PL_euid == PL_uid) /* special case $> = $< */
2535 PerlProc_setuid(PL_euid);
a0d0e21e 2536 else {
e8ee3774 2537 PL_euid = PerlProc_geteuid();
cea2e8a9 2538 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2539 }
79072805
LW
2540#endif
2541#endif
85e6fe83 2542#endif
d8eceb89 2543 PL_euid = PerlProc_geteuid();
3280af22 2544 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2545 break;
2546 case '(':
38ab35f8 2547 PL_gid = SvIV(sv);
3280af22
NIS
2548 if (PL_delaymagic) {
2549 PL_delaymagic |= DM_RGID;
79072805
LW
2550 break; /* don't do magic till later */
2551 }
2552#ifdef HAS_SETRGID
b28d0864 2553 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2554#else
2555#ifdef HAS_SETREGID
3280af22 2556 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2557#else
2558#ifdef HAS_SETRESGID
b28d0864 2559 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2560#else
b28d0864
NIS
2561 if (PL_gid == PL_egid) /* special case $( = $) */
2562 (void)PerlProc_setgid(PL_gid);
748a9306 2563 else {
d8eceb89 2564 PL_gid = PerlProc_getgid();
cea2e8a9 2565 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2566 }
79072805
LW
2567#endif
2568#endif
85e6fe83 2569#endif
d8eceb89 2570 PL_gid = PerlProc_getgid();
3280af22 2571 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2572 break;
2573 case ')':
5cd24f17
PP
2574#ifdef HAS_SETGROUPS
2575 {
b83604b4 2576 const char *p = SvPV_const(sv, len);
757f63d8
SP
2577 Groups_t *gary = NULL;
2578
2579 while (isSPACE(*p))
2580 ++p;
2581 PL_egid = Atol(p);
2582 for (i = 0; i < NGROUPS; ++i) {
2583 while (*p && !isSPACE(*p))
2584 ++p;
2585 while (isSPACE(*p))
2586 ++p;
2587 if (!*p)
2588 break;
2589 if(!gary)
2590 Newx(gary, i + 1, Groups_t);
2591 else
2592 Renew(gary, i + 1, Groups_t);
2593 gary[i] = Atol(p);
2594 }
2595 if (i)
2596 (void)setgroups(i, gary);
f5a63d97 2597 Safefree(gary);
5cd24f17
PP
2598 }
2599#else /* HAS_SETGROUPS */
38ab35f8 2600 PL_egid = SvIV(sv);
5cd24f17 2601#endif /* HAS_SETGROUPS */
3280af22
NIS
2602 if (PL_delaymagic) {
2603 PL_delaymagic |= DM_EGID;
79072805
LW
2604 break; /* don't do magic till later */
2605 }
2606#ifdef HAS_SETEGID
3280af22 2607 (void)setegid((Gid_t)PL_egid);
79072805
LW
2608#else
2609#ifdef HAS_SETREGID
b28d0864 2610 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2611#else
2612#ifdef HAS_SETRESGID
b28d0864 2613 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2614#else
b28d0864
NIS
2615 if (PL_egid == PL_gid) /* special case $) = $( */
2616 (void)PerlProc_setgid(PL_egid);
748a9306 2617 else {
d8eceb89 2618 PL_egid = PerlProc_getegid();
cea2e8a9 2619 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2620 }
79072805
LW
2621#endif
2622#endif
85e6fe83 2623#endif
d8eceb89 2624 PL_egid = PerlProc_getegid();
3280af22 2625 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2626 break;
2627 case ':':
2d8e6c8d 2628 PL_chopset = SvPV_force(sv,len);
79072805 2629 break;
cd39f2b6 2630#ifndef MACOS_TRADITIONAL
79072805 2631 case '0':
e2975953 2632 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2633#ifdef HAS_SETPROCTITLE
2634 /* The BSDs don't show the argv[] in ps(1) output, they
2635 * show a string from the process struct and provide
2636 * the setproctitle() routine to manipulate that. */
a2722ac9 2637 if (PL_origalen != 1) {
b83604b4 2638 s = SvPV_const(sv, len);
98b76f99 2639# if __FreeBSD_version > 410001
9aad2c0e 2640 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2641 * but not the "(perl) suffix from the ps(1)
2642 * output, because that's what ps(1) shows if the
2643 * argv[] is modified. */
6f2ad931 2644 setproctitle("-%s", s);
9aad2c0e 2645# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2646 /* This doesn't really work if you assume that
2647 * $0 = 'foobar'; will wipe out 'perl' from the $0
2648 * because in ps(1) output the result will be like
2649 * sprintf("perl: %s (perl)", s)
2650 * I guess this is a security feature:
2651 * one (a user process) cannot get rid of the original name.
2652 * --jhi */
2653 setproctitle("%s", s);
2654# endif
2655 }
9d3968b2 2656#elif defined(__hpux) && defined(PSTAT_SETCMD)
a2722ac9 2657 if (PL_origalen != 1) {
17aa7f3d 2658 union pstun un;
b83604b4 2659 s = SvPV_const(sv, len);
6867be6d 2660 un.pst_command = (char *)s;
17aa7f3d
JH
2661 pstat(PSTAT_SETCMD, un, len, 0, 0);
2662 }
9d3968b2 2663#else
2d2af554
GA
2664 if (PL_origalen > 1) {
2665 /* PL_origalen is set in perl_parse(). */
2666 s = SvPV_force(sv,len);
2667 if (len >= (STRLEN)PL_origalen-1) {
2668 /* Longer than original, will be truncated. We assume that
2669 * PL_origalen bytes are available. */
2670 Copy(s, PL_origargv[0], PL_origalen-1, char);
2671 }
2672 else {
2673 /* Shorter than original, will be padded. */
235ac35d 2674#ifdef PERL_DARWIN
60777a0d
JH
2675 /* Special case for Mac OS X: see [perl #38868] */
2676 const int pad = 0;
235ac35d 2677#else
8a89a4f1
MB
2678 /* Is the space counterintuitive? Yes.
2679 * (You were expecting \0?)
2680 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2681 * --jhi */
60777a0d 2682 const int pad = ' ';
235ac35d 2683#endif
60777a0d
JH
2684 Copy(s, PL_origargv[0], len, char);
2685 PL_origargv[0][len] = 0;
2686 memset(PL_origargv[0] + len + 1,
2687 pad, PL_origalen - len - 1);
2d2af554
GA
2688 }
2689 PL_origargv[0][PL_origalen-1] = 0;
2690 for (i = 1; i < PL_origargc; i++)
2691 PL_origargv[i] = 0;
79072805 2692 }
9d3968b2 2693#endif
e2975953 2694 UNLOCK_DOLLARZERO_MUTEX;
79072805 2695 break;
cd39f2b6 2696#endif
79072805
LW
2697 }
2698 return 0;
2699}
2700
2701I32
35a4481c 2702Perl_whichsig(pTHX_ const char *sig)
79072805 2703{
aadb217d 2704 register char* const* sigv;
96a5add6 2705 PERL_UNUSED_CONTEXT;
79072805 2706
aadb217d 2707 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 2708 if (strEQ(sig,*sigv))
aadb217d 2709 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
2710#ifdef SIGCLD
2711 if (strEQ(sig,"CHLD"))
2712 return SIGCLD;
2713#endif
2714#ifdef SIGCHLD
2715 if (strEQ(sig,"CLD"))
2716 return SIGCHLD;
2717#endif
7f1236c0 2718 return -1;
79072805
LW
2719}
2720
ecfc5424 2721Signal_t
1e82f5a6 2722#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
8aad04aa 2723Perl_sighandler(int sig, ...)
1e82f5a6
SH
2724#else
2725Perl_sighandler(int sig)
2726#endif
79072805 2727{
1018e26f
NIS
2728#ifdef PERL_GET_SIG_CONTEXT
2729 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2730#else
cea2e8a9 2731 dTHX;
71d280e3 2732#endif
79072805 2733 dSP;
a0714e2c
SS
2734 GV *gv = NULL;
2735 SV *sv = NULL;
8772537c 2736 SV * const tSv = PL_Sv;
601f1833 2737 CV *cv = NULL;
533c011a 2738 OP *myop = PL_op;
84902520 2739 U32 flags = 0;
8772537c 2740 XPV * const tXpv = PL_Xpv;
71d280e3 2741
3280af22 2742 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2743 flags |= 1;
3280af22 2744 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2745 flags |= 4;
3280af22 2746 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2747 flags |= 16;
2748
727405f8 2749 if (!PL_psig_ptr[sig]) {
99ef548b 2750 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2751 PL_sig_name[sig]);
2752 exit(sig);
2753 }
ff0cee69 2754
84902520
TB
2755 /* Max number of items pushed there is 3*n or 4. We cannot fix
2756 infinity, so we fix 4 (in fact 5): */
2757 if (flags & 1) {
3280af22 2758 PL_savestack_ix += 5; /* Protect save in progress. */
8772537c 2759 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
84902520 2760 }
ac27b0f5 2761 if (flags & 4)
3280af22 2762 PL_markstack_ptr++; /* Protect mark. */
84902520 2763 if (flags & 16)
3280af22 2764 PL_scopestack_ix += 1;
84902520 2765 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2766 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
8772537c
AL
2767 || SvTYPE(cv) != SVt_PVCV) {
2768 HV *st;
f2c0649b 2769 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 2770 }
84902520 2771
a0d0e21e 2772 if (!cv || !CvROOT(cv)) {
599cee73 2773 if (ckWARN(WARN_SIGNAL))
9014280d 2774 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2775 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2776 : ((cv && CvGV(cv))
2777 ? GvENAME(CvGV(cv))
2778 : "__ANON__")));
2779 goto cleanup;
79072805
LW
2780 }
2781
22c35a8c 2782 if(PL_psig_name[sig]) {
b37c2d43 2783 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
84902520 2784 flags |= 64;
df3728a2 2785#if !defined(PERL_IMPLICIT_CONTEXT)
27da23d5 2786 PL_sig_sv = sv;
df3728a2 2787#endif
84902520 2788 } else {
ff0cee69 2789 sv = sv_newmortal();
22c35a8c 2790 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2791 }
e336de0d 2792
e788e7d3 2793 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2794 PUSHMARK(SP);
79072805 2795 PUSHs(sv);
8aad04aa
JH
2796#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2797 {
2798 struct sigaction oact;
2799
2800 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2801 siginfo_t *sip;
2802 va_list args;
2803
2804 va_start(args, sig);
2805 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2806 if (sip) {
2807 HV *sih = newHV();
2808 SV *rv = newRV_noinc((SV*)sih);
2809 /* The siginfo fields signo, code, errno, pid, uid,
2810 * addr, status, and band are defined by POSIX/SUSv3. */
2811 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2812 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
79dec0f4 2813#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. */
ea1bde16 2814 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
79dec0f4 2815 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
8aad04aa
JH
2816 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2817 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2818 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
8aad04aa 2819 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
79dec0f4 2820#endif
8aad04aa
JH
2821 EXTEND(SP, 2);
2822 PUSHs((SV*)rv);
10edeb5d 2823 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
8aad04aa 2824 }
b4552a27 2825
31427afe 2826 va_end(args);
8aad04aa
JH
2827 }
2828 }
2829#endif
79072805 2830 PUTBACK;
a0d0e21e 2831
1b266415 2832 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2833
d3acc0f7 2834 POPSTACK;
1b266415 2835 if (SvTRUE(ERRSV)) {
1d615522 2836#ifndef PERL_MICRO
983dbef6 2837#ifdef HAS_SIGPROCMASK
1b266415
NIS
2838 /* Handler "died", for example to get out of a restart-able read().
2839 * Before we re-do that on its behalf re-enable the signal which was
2840 * blocked by the system when we entered.
2841 */
2842 sigset_t set;
2843 sigemptyset(&set);
2844 sigaddset(&set,sig);
2845 sigprocmask(SIG_UNBLOCK, &set, NULL);
2846#else
2847 /* Not clear if this will work */
2848 (void)rsignal(sig, SIG_IGN);
5c1546dc 2849 (void)rsignal(sig, PL_csighandlerp);
1b266415 2850#endif
1d615522 2851#endif /* !PERL_MICRO */
bd61b366 2852 Perl_die(aTHX_ NULL);
1b266415 2853 }
00d579c5 2854cleanup:
84902520 2855 if (flags & 1)
3280af22 2856 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2857 if (flags & 4)
3280af22 2858 PL_markstack_ptr--;
84902520 2859 if (flags & 16)
3280af22 2860 PL_scopestack_ix -= 1;
84902520
TB
2861 if (flags & 64)
2862 SvREFCNT_dec(sv);
533c011a 2863 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2864
3280af22
NIS
2865 PL_Sv = tSv; /* Restore global temporaries. */
2866 PL_Xpv = tXpv;
53bb94e2 2867 return;
79072805 2868}
4e35701f
NIS
2869
2870
51371543 2871static void
8772537c 2872S_restore_magic(pTHX_ const void *p)
51371543 2873{
97aff369 2874 dVAR;
8772537c
AL
2875 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2876 SV* const sv = mgs->mgs_sv;
51371543
GS
2877
2878 if (!sv)
2879 return;
2880
2881 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2882 {
f8c7b90f 2883#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
2884 /* While magic was saved (and off) sv_setsv may well have seen
2885 this SV as a prime candidate for COW. */
2886 if (SvIsCOW(sv))
e424a81e 2887 sv_force_normal_flags(sv, 0);
f9701176
NC
2888#endif
2889
51371543
GS
2890 if (mgs->mgs_flags)
2891 SvFLAGS(sv) |= mgs->mgs_flags;
2892 else
2893 mg_magical(sv);
2b77b520
YST
2894 if (SvGMAGICAL(sv)) {
2895 /* downgrade public flags to private,
2896 and discard any other private flags */
2897
10edeb5d
JH
2898 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2899 if (pubflags) {
2900 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2901 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2b77b520
YST
2902 }
2903 }
51371543
GS
2904 }
2905
2906 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2907
2908 /* If we're still on top of the stack, pop us off. (That condition
2909 * will be satisfied if restore_magic was called explicitly, but *not*
2910 * if it's being called via leave_scope.)
2911 * The reason for doing this is that otherwise, things like sv_2cv()
2912 * may leave alloc gunk on the savestack, and some code
2913 * (e.g. sighandler) doesn't expect that...
2914 */
2915 if (PL_savestack_ix == mgs->mgs_ss_ix)
2916 {
2917 I32 popval = SSPOPINT;
c76ac1ee 2918 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2919 PL_savestack_ix -= 2;
2920 popval = SSPOPINT;
2921 assert(popval == SAVEt_ALLOC);
2922 popval = SSPOPINT;
2923 PL_savestack_ix -= popval;
2924 }
2925
2926}
2927
2928static void
8772537c 2929S_unwind_handler_stack(pTHX_ const void *p)
51371543 2930{
27da23d5 2931 dVAR;
e1ec3a88 2932 const U32 flags = *(const U32*)p;
51371543
GS
2933
2934 if (flags & 1)
2935 PL_savestack_ix -= 5; /* Unprotect save in progress. */
df3728a2 2936#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 2937 if (flags & 64)
27da23d5 2938 SvREFCNT_dec(PL_sig_sv);
df3728a2 2939#endif
51371543 2940}
1018e26f 2941
66610fdd 2942/*
b3ca2e83
NC
2943=for apidoc magic_sethint
2944
2945Triggered by a store to %^H, records the key/value pair to
c28fe1ec
NC
2946C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2947anything that would need a deep copy. Maybe we should warn if we find a
2948reference.
b3ca2e83
NC
2949
2950=cut
2951*/
2952int
2953Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2954{
2955 dVAR;
2956 assert(mg->mg_len == HEf_SVKEY);
2957
e6e3e454
NC
2958 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2959 an alternative leaf in there, with PL_compiling.cop_hints being used if
2960 it's NULL. If needed for threads, the alternative could lock a mutex,
2961 or take other more complex action. */
2962
5b9c0671
NC
2963 /* Something changed in %^H, so it will need to be restored on scope exit.
2964 Doing this here saves a lot of doing it manually in perl code (and
2965 forgetting to do it, and consequent subtle errors. */
2966 PL_hints |= HINT_LOCALIZE_HH;
c28fe1ec
NC
2967 PL_compiling.cop_hints_hash
2968 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
ec2a1de7 2969 (SV *)mg->mg_ptr, sv);
b3ca2e83
NC
2970 return 0;
2971}
2972
2973/*
2974=for apidoc magic_sethint
2975
c28fe1ec
NC
2976Triggered by a delete from %^H, records the key to
2977C<PL_compiling.cop_hints_hash>.
b3ca2e83
NC
2978
2979=cut
2980*/
2981int
2982Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2983{
2984 dVAR;
f5a63d97
AL
2985 PERL_UNUSED_ARG(sv);
2986
b3ca2e83
NC
2987 assert(mg->mg_len == HEf_SVKEY);
2988
b3f24c00
MHM
2989 PERL_UNUSED_ARG(sv);
2990
5b9c0671 2991 PL_hints |= HINT_LOCALIZE_HH;
c28fe1ec
NC
2992 PL_compiling.cop_hints_hash
2993 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
b3ca2e83
NC
2994 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2995 return 0;
2996}
2997
2998/*
66610fdd
RGS
2999 * Local variables:
3000 * c-indentation-style: bsd
3001 * c-basic-offset: 4
3002 * indent-tabs-mode: t
3003 * End:
3004 *
37442d52
RGS
3005 * ex: set ts=8 sts=4 sw=4 noet:
3006 */