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