This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Re: [perl #21505] 5.8.0 lib/Config test failure due to compiler flag
[perl5.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
4c79ee7a 3 * Copyright (c) 1991-2003, Larry Wall
79072805
LW		 4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e
LW		 8 */
9
10/*
11 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
12 * come here, and I don't want to see no more magic,' he said, and fell silent."
79072805
LW		 13 */
14
ccfc67b7
JH		 15/*
16=head1 Magical Functions
17*/
18
79072805 19#include "EXTERN.h"
864dbfa3 20#define PERL_IN_MG_C
79072805
LW		 21#include "perl.h"
22
5cd24f17 23#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
188ea221
CS		 24# ifndef NGROUPS
25# define NGROUPS 32
26# endif
b7953727
JH		 27# ifdef I_GRP
28# include <grp.h>
29# endif
188ea221
CS		 30#endif
31
17aa7f3d
JH		 32#ifdef __hpux
33# include <sys/pstat.h>
34#endif
35
e69880a5
CB		 36Signal_t Perl_csighandler(int sig);
37
23ada85b 38/* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
85b332e2 39#if !defined(HAS_SIGACTION) && defined(VMS)
23ada85b 40# define FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2 41#endif
2e34cc90 42/* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
7719e241 43#if defined(KILL_BY_SIGPRC)
2e34cc90
CL		 44# define FAKE_DEFAULT_SIGNAL_HANDLERS
45#endif
85b332e2 46
acfe0abc
GS		 47static void restore_magic(pTHX_ void *p);
48static void unwind_handler_stack(pTHX_ void *p);
51371543 49
c07a80fd 50/*
51 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
52 */
53
54struct magic_state {
55 SV* mgs_sv;
56 U32 mgs_flags;
455ece5e 57 I32 mgs_ss_ix;
c07a80fd 58};
455ece5e 59/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e
GS		 60
61STATIC void
8fb26106 62S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
c07a80fd 63{
455ece5e 64 MGS* mgs;
c07a80fd 65 assert(SvMAGICAL(sv));
765f542d
NC		 66#ifdef PERL_COPY_ON_WRITE
67 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
68 if (SvIsCOW(sv))
69 sv_force_normal(sv);
70#endif
c07a80fd 71
685f876f 72 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
455ece5e
AD		 73
74 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd 75 mgs->mgs_sv = sv;
76 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
455ece5e 77 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
c07a80fd 78
79 SvMAGICAL_off(sv);
80 SvREADONLY_off(sv);
06759ea0 81 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
c07a80fd 82}
83
954c1994
GS		 84/*
85=for apidoc mg_magical
86
87Turns on the magical status of an SV. See C<sv_magic>.
88
89=cut
90*/
91
8990e307 92void
864dbfa3 93Perl_mg_magical(pTHX_ SV *sv)
8990e307
LW		 94{
95 MAGIC* mg;
96 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
97 MGVTBL* vtbl = mg->mg_virtual;
98 if (vtbl) {
2b260de0 99 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
8990e307
LW		 100 SvGMAGICAL_on(sv);
101 if (vtbl->svt_set)
102 SvSMAGICAL_on(sv);
2b260de0 103 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
8990e307
LW		 104 SvRMAGICAL_on(sv);
105 }
106 }
107}
108
954c1994
GS		 109/*
110=for apidoc mg_get
111
112Do magic after a value is retrieved from the SV. See C<sv_magic>.
113
114=cut
115*/
116
79072805 117int
864dbfa3 118Perl_mg_get(pTHX_ SV *sv)
79072805 119{
ff76feab
AMS		 120 int new = 0;
121 MAGIC *newmg, *head, *cur, *mg;
122 I32 mgs_ix = SSNEW(sizeof(MGS));
463ee0b2 123
455ece5e 124 save_magic(mgs_ix, sv);
463ee0b2 125
ff76feab
AMS		 126 /* We must call svt_get(sv, mg) for each valid entry in the linked
127 list of magic. svt_get() may delete the current entry, add new
128 magic to the head of the list, or upgrade the SV. AMS 20010810 */
129
130 newmg = cur = head = mg = SvMAGIC(sv);
131 while (mg) {
132 MGVTBL *vtbl = mg->mg_virtual;
133
2b260de0 134 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
316ad4fe 135 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
ff76feab
AMS		 136 /* Don't restore the flags for this entry if it was deleted. */
137 if (mg->mg_flags & MGf_GSKIP)
138 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
a0d0e21e 139 }
ff76feab
AMS		 140
141 mg = mg->mg_moremagic;
142
143 if (new) {
144 /* Have we finished with the new entries we saw? Start again
145 where we left off (unless there are more new entries). */
146 if (mg == head) {
147 new = 0;
148 mg = cur;
149 head = newmg;
150 }
151 }
152
153 /* Were any new entries added? */
154 if (!new && (newmg = SvMAGIC(sv)) != head) {
155 new = 1;
156 cur = mg;
157 mg = newmg;
760ac839 158 }
79072805 159 }
463ee0b2 160
acfe0abc 161 restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
79072805
LW		 162 return 0;
163}
164
954c1994
GS		 165/*
166=for apidoc mg_set
167
168Do magic after a value is assigned to the SV. See C<sv_magic>.
169
170=cut
171*/
172
79072805 173int
864dbfa3 174Perl_mg_set(pTHX_ SV *sv)
79072805 175{
8fb26106 176 I32 mgs_ix;
79072805 177 MAGIC* mg;
463ee0b2
LW		 178 MAGIC* nextmg;
179
455ece5e
AD		 180 mgs_ix = SSNEW(sizeof(MGS));
181 save_magic(mgs_ix, sv);
463ee0b2
LW		 182
183 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
79072805 184 MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 185 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e
LW		 186 if (mg->mg_flags & MGf_GSKIP) {
187 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
455ece5e 188 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
a0d0e21e 189 }
2b260de0 190 if (vtbl && vtbl->svt_set)
fc0dc3b3 191 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
79072805 192 }
463ee0b2 193
acfe0abc 194 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
79072805
LW		 195 return 0;
196}
197
954c1994
GS		 198/*
199=for apidoc mg_length
200
201Report on the SV's length. See C<sv_magic>.
202
203=cut
204*/
205
79072805 206U32
864dbfa3 207Perl_mg_length(pTHX_ SV *sv)
79072805
LW		 208{
209 MAGIC* mg;
463ee0b2 210 STRLEN len;
463ee0b2 211
79072805
LW		 212 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
213 MGVTBL* vtbl = mg->mg_virtual;
2b260de0 214 if (vtbl && vtbl->svt_len) {
8fb26106 215 I32 mgs_ix;
48e43a1c 216
455ece5e
AD		 217 mgs_ix = SSNEW(sizeof(MGS));
218 save_magic(mgs_ix, sv);
a0d0e21e 219 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 220 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
acfe0abc 221 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
85e6fe83
LW		 222 return len;
223 }
224 }
225
7719e241 226 if (DO_UTF8(sv))
5636d518
DB		 227 {
228 U8 *s = (U8*)SvPV(sv, len);
229 len = Perl_utf8_length(aTHX_ s, s + len);
230 }
231 else
232 (void)SvPV(sv, len);
463ee0b2 233 return len;
79072805
LW		 234}
235
8fb26106 236I32
864dbfa3 237Perl_mg_size(pTHX_ SV *sv)
93965878
NIS		 238{
239 MAGIC* mg;
240 I32 len;
ac27b0f5 241
93965878
NIS		 242 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
243 MGVTBL* vtbl = mg->mg_virtual;
2b260de0 244 if (vtbl && vtbl->svt_len) {
8fb26106 245 I32 mgs_ix;
455ece5e
AD		 246
247 mgs_ix = SSNEW(sizeof(MGS));
248 save_magic(mgs_ix, sv);
93965878 249 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 250 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
acfe0abc 251 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
93965878
NIS		 252 return len;
253 }
254 }
255
256 switch(SvTYPE(sv)) {
257 case SVt_PVAV:
258 len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
259 return len;
260 case SVt_PVHV:
261 /* FIXME */
262 default:
cea2e8a9 263 Perl_croak(aTHX_ "Size magic not implemented");
93965878
NIS		 264 break;
265 }
266 return 0;
267}
268
954c1994
GS		 269/*
270=for apidoc mg_clear
271
272Clear something magical that the SV represents. See C<sv_magic>.
273
274=cut
275*/
276
79072805 277int
864dbfa3 278Perl_mg_clear(pTHX_ SV *sv)
79072805 279{
8fb26106 280 I32 mgs_ix;
79072805 281 MAGIC* mg;
463ee0b2 282
455ece5e
AD		 283 mgs_ix = SSNEW(sizeof(MGS));
284 save_magic(mgs_ix, sv);
463ee0b2 285
79072805
LW		 286 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
287 MGVTBL* vtbl = mg->mg_virtual;
a0d0e21e 288 /* omit GSKIP -- never set here */
727405f8 289
2b260de0 290 if (vtbl && vtbl->svt_clear)
fc0dc3b3 291 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
79072805 292 }
463ee0b2 293
acfe0abc 294 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
79072805
LW		 295 return 0;
296}
297
954c1994
GS		 298/*
299=for apidoc mg_find
300
301Finds the magic pointer for type matching the SV. See C<sv_magic>.
302
303=cut
304*/
305
93a17b20 306MAGIC*
864dbfa3 307Perl_mg_find(pTHX_ SV *sv, int type)
93a17b20
LW		 308{
309 MAGIC* mg;
3f8f4626
DC		 310 if (!sv)
311 return 0;
93a17b20
LW		 312 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
313 if (mg->mg_type == type)
314 return mg;
315 }
316 return 0;
317}
318
954c1994
GS		 319/*
320=for apidoc mg_copy
321
322Copies the magic from one SV to another. See C<sv_magic>.
323
324=cut
325*/
326
79072805 327int
864dbfa3 328Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 329{
463ee0b2 330 int count = 0;
79072805 331 MAGIC* mg;
463ee0b2 332 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
68795e93
NIS		 333 MGVTBL* vtbl = mg->mg_virtual;
334 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
335 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
336 }
337 else if (isUPPER(mg->mg_type)) {
33c27489 338 sv_magic(nsv,
14befaf4
DM		 339 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
340 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
341 ? sv : mg->mg_obj,
33c27489 342 toLOWER(mg->mg_type), key, klen);
463ee0b2 343 count++;
79072805 344 }
79072805 345 }
463ee0b2 346 return count;
79072805
LW		 347}
348
954c1994
GS		 349/*
350=for apidoc mg_free
351
352Free any magic storage used by the SV. See C<sv_magic>.
353
354=cut
355*/
356
79072805 357int
864dbfa3 358Perl_mg_free(pTHX_ SV *sv)
79072805
LW		 359{
360 MAGIC* mg;
361 MAGIC* moremagic;
362 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
363 MGVTBL* vtbl = mg->mg_virtual;
364 moremagic = mg->mg_moremagic;
2b260de0 365 if (vtbl && vtbl->svt_free)
fc0dc3b3 366 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
14befaf4 367 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
7719e241 368 if (mg->mg_len > 0)
88e89b8a 369 Safefree(mg->mg_ptr);
565764a8 370 else if (mg->mg_len == HEf_SVKEY)
88e89b8a 371 SvREFCNT_dec((SV*)mg->mg_ptr);
d460ef45 372 }
b881518d
JH		 373 if (mg->mg_flags & MGf_REFCOUNTED)
374 SvREFCNT_dec(mg->mg_obj);
79072805
LW		 375 Safefree(mg);
376 }
377 SvMAGIC(sv) = 0;
378 return 0;
379}
380
d460ef45 381
79072805
LW		 382#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
383#include <signal.h>
384#endif
385
942e002e 386U32
864dbfa3 387Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 388{
6cef1e77 389 register REGEXP *rx;
6cef1e77 390
aaa362c4 391 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
8f580fb8
IZ		 392 if (mg->mg_obj) /* @+ */
393 return rx->nparens;
394 else /* @- */
395 return rx->lastparen;
396 }
ac27b0f5 397
942e002e 398 return (U32)-1;
6cef1e77
IZ		 399}
400
401int
864dbfa3 402Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 403{
6cef1e77 404 register I32 paren;
cf93c79d 405 register I32 s;
6cef1e77
IZ		 406 register I32 i;
407 register REGEXP *rx;
cf93c79d 408 I32 t;
6cef1e77 409
aaa362c4 410 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
6cef1e77
IZ		 411 paren = mg->mg_len;
412 if (paren < 0)
413 return 0;
eb160463 414 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ		 415 (s = rx->startp[paren]) != -1 &&
416 (t = rx->endp[paren]) != -1)
6cef1e77
IZ		 417 {
418 if (mg->mg_obj) /* @+ */
cf93c79d 419 i = t;
6cef1e77 420 else /* @- */
cf93c79d 421 i = s;
727405f8 422
a30b2f1f 423 if (i > 0 && RX_MATCH_UTF8(rx)) {
1aa99e6b 424 char *b = rx->subbeg;
0064a8a9
JH		 425 if (b)
426 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
1aa99e6b 427 }
0064a8a9
JH		 428
429 sv_setiv(sv, i);
6cef1e77
IZ		 430 }
431 }
432 return 0;
433}
434
e4b89193 435int
a29d06ed
MG		 436Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
437{
a29d06ed 438 Perl_croak(aTHX_ PL_no_modify);
e4b89193
GS		 439 /* NOT REACHED */
440 return 0;
a29d06ed
MG		 441}
442
93a17b20 443U32
864dbfa3 444Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
93a17b20
LW		 445{
446 register I32 paren;
93a17b20 447 register I32 i;
d9f97599 448 register REGEXP *rx;
a197cbdd 449 I32 s1, t1;
93a17b20
LW		 450
451 switch (*mg->mg_ptr) {
452 case '1': case '2': case '3': case '4':
453 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 454 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 455
ffc61ed2 456 paren = atoi(mg->mg_ptr); /* $& is in [0] */
93a17b20 457 getparen:
eb160463 458 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ		 459 (s1 = rx->startp[paren]) != -1 &&
460 (t1 = rx->endp[paren]) != -1)
bbce6d69 461 {
cf93c79d 462 i = t1 - s1;
a197cbdd 463 getlen:
a30b2f1f 464 if (i > 0 && RX_MATCH_UTF8(rx)) {
ffc61ed2 465 char *s = rx->subbeg + s1;
a197cbdd 466 char *send = rx->subbeg + t1;
ffc61ed2 467
6d5fa195 468 i = t1 - s1;
60425c38
JH		 469 if (is_utf8_string((U8*)s, i))
470 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
a197cbdd 471 }
ffc61ed2 472 if (i < 0)
0844c848 473 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
ffc61ed2 474 return i;
93a17b20 475 }
235bddc8
NIS		 476 else {
477 if (ckWARN(WARN_UNINITIALIZED))
478 report_uninit();
479 }
480 }
481 else {
482 if (ckWARN(WARN_UNINITIALIZED))
483 report_uninit();
93a17b20 484 }
748a9306 485 return 0;
93a17b20 486 case '+':
aaa362c4 487 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 488 paren = rx->lastparen;
13f57bf8
CS		 489 if (paren)
490 goto getparen;
93a17b20 491 }
748a9306 492 return 0;
a01268b5
JH		 493 case '\016': /* ^N */
494 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
495 paren = rx->lastcloseparen;
496 if (paren)
497 goto getparen;
498 }
499 return 0;
93a17b20 500 case '`':
aaa362c4 501 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ		 502 if (rx->startp[0] != -1) {
503 i = rx->startp[0];
a197cbdd
GS		 504 if (i > 0) {
505 s1 = 0;
506 t1 = i;
507 goto getlen;
508 }
93a17b20 509 }
93a17b20 510 }
748a9306 511 return 0;
93a17b20 512 case '\'':
aaa362c4 513 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ		 514 if (rx->endp[0] != -1) {
515 i = rx->sublen - rx->endp[0];
a197cbdd
GS		 516 if (i > 0) {
517 s1 = rx->endp[0];
518 t1 = rx->sublen;
519 goto getlen;
520 }
93a17b20 521 }
93a17b20 522 }
748a9306 523 return 0;
93a17b20
LW		 524 }
525 magic_get(sv,mg);
2d8e6c8d
GS		 526 if (!SvPOK(sv) && SvNIOK(sv)) {
527 STRLEN n_a;
528 sv_2pv(sv, &n_a);
529 }
93a17b20
LW		 530 if (SvPOK(sv))
531 return SvCUR(sv);
532 return 0;
533}
534
79072805 535int
864dbfa3 536Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805
LW		 537{
538 register I32 paren;
539 register char *s;
540 register I32 i;
d9f97599 541 register REGEXP *rx;
79072805
LW		 542
543 switch (*mg->mg_ptr) {
748a9306 544 case '\001': /* ^A */
3280af22 545 sv_setsv(sv, PL_bodytarget);
748a9306 546 break;
49460fe6
NIS		 547 case '\003': /* ^C */
548 sv_setiv(sv, (IV)PL_minus_c);
549 break;
550
79072805 551 case '\004': /* ^D */
aea4f609 552 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
d056ab3f 553#if defined(YYDEBUG) && defined(DEBUGGING)
aea4f609 554 PL_yydebug = DEBUG_p_TEST;
d056ab3f 555#endif
79072805 556 break;
28f23441 557 case '\005': /* ^E */
0a378802 558 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 559#ifdef MACOS_TRADITIONAL
0a378802
JH		 560 {
561 char msg[256];
727405f8 562
0a378802 563 sv_setnv(sv,(double)gMacPerl_OSErr);
727405f8 564 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
0a378802 565 }
727405f8 566#else
28f23441 567#ifdef VMS
0a378802
JH		 568 {
569# include <descrip.h>
570# include <starlet.h>
571 char msg[255];
572 $DESCRIPTOR(msgdsc,msg);
573 sv_setnv(sv,(NV) vaxc$errno);
574 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
575 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
576 else
577 sv_setpv(sv,"");
578 }
28f23441 579#else
88e89b8a 580#ifdef OS2
0a378802
JH		 581 if (!(_emx_env & 0x200)) { /* Under DOS */
582 sv_setnv(sv, (NV)errno);
583 sv_setpv(sv, errno ? Strerror(errno) : "");
584 } else {
585 if (errno != errno_isOS2) {
586 int tmp = _syserrno();
587 if (tmp) /* 2nd call to _syserrno() makes it 0 */
588 Perl_rc = tmp;
589 }
590 sv_setnv(sv, (NV)Perl_rc);
591 sv_setpv(sv, os2error(Perl_rc));
592 }
88e89b8a 593#else
22fae026 594#ifdef WIN32
0a378802
JH		 595 {
596 DWORD dwErr = GetLastError();
597 sv_setnv(sv, (NV)dwErr);
598 if (dwErr)
599 {
600 PerlProc_GetOSError(sv, dwErr);
601 }
602 else
603 sv_setpv(sv, "");
604 SetLastError(dwErr);
605 }
22fae026 606#else
0a378802
JH		 607 sv_setnv(sv, (NV)errno);
608 sv_setpv(sv, errno ? Strerror(errno) : "");
28f23441 609#endif
88e89b8a 610#endif
22fae026 611#endif
cd39f2b6 612#endif
0a378802
JH		 613 SvNOK_on(sv); /* what a wonderful hack! */
614 }
615 else if (strEQ(mg->mg_ptr+1, "NCODING"))
616 sv_setsv(sv, PL_encoding);
617 break;
79072805 618 case '\006': /* ^F */
3280af22 619 sv_setiv(sv, (IV)PL_maxsysfd);
79072805 620 break;
a0d0e21e 621 case '\010': /* ^H */
3280af22 622 sv_setiv(sv, (IV)PL_hints);
a0d0e21e 623 break;
9d116dd7 624 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS		 625 if (PL_inplace)
626 sv_setpv(sv, PL_inplace);
79072805 627 else
3280af22 628 sv_setsv(sv, &PL_sv_undef);
79072805 629 break;
ac27b0f5
NIS		 630 case '\017': /* ^O & ^OPEN */
631 if (*(mg->mg_ptr+1) == '\0')
632 sv_setpv(sv, PL_osname);
633 else if (strEQ(mg->mg_ptr, "\017PEN")) {
634 if (!PL_compiling.cop_io)
635 sv_setsv(sv, &PL_sv_undef);
636 else {
637 sv_setsv(sv, PL_compiling.cop_io);
638 }
639 }
28f23441 640 break;
79072805 641 case '\020': /* ^P */
3280af22 642 sv_setiv(sv, (IV)PL_perldb);
79072805 643 break;
fb73857a 644 case '\023': /* ^S */
4ffa73a3 645 if (*(mg->mg_ptr+1) == '\0') {
3280af22 646 if (PL_lex_state != LEX_NOTPARSING)
155aba94 647 (void)SvOK_off(sv);
3280af22 648 else if (PL_in_eval)
6dc8a9e4 649 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
a4268c0a
AMS		 650 else
651 sv_setiv(sv, 0);
d58bf5aa 652 }
fb73857a 653 break;
79072805 654 case '\024': /* ^T */
7c36658b 655 if (*(mg->mg_ptr+1) == '\0') {
88e89b8a 656#ifdef BIG_TIME
7c36658b 657 sv_setnv(sv, PL_basetime);
88e89b8a 658#else
7c36658b 659 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 660#endif
7c36658b
MS		 661 }
662 else if (strEQ(mg->mg_ptr, "\024AINT"))
9aa05f58
RGS		 663 sv_setiv(sv, PL_tainting
664 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
665 : 0);
7c36658b 666 break;
a05d7ebb
JH		 667 case '\025': /* $^UNICODE */
668 if (strEQ(mg->mg_ptr, "\025NICODE"))
669 sv_setuv(sv, (UV) PL_unicode);
fde18df1
JH		 670 break;
671 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH		 672 if (*(mg->mg_ptr+1) == '\0')
673 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
0a378802 674 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
d3a7d8c7
GS		 675 if (PL_compiling.cop_warnings == pWARN_NONE ||
676 PL_compiling.cop_warnings == pWARN_STD)
4438c4b7
JH		 677 {
678 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
679 }
d3a7d8c7 680 else if (PL_compiling.cop_warnings == pWARN_ALL) {
75b6c4ca
RGS		 681 /* Get the bit mask for $warnings::Bits{all}, because
682 * it could have been extended by warnings::register */
683 SV **bits_all;
684 HV *bits=get_hv("warnings::Bits", FALSE);
685 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
686 sv_setsv(sv, *bits_all);
687 }
688 else {
689 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
690 }
ac27b0f5 691 }
4438c4b7
JH		 692 else {
693 sv_setsv(sv, PL_compiling.cop_warnings);
ac27b0f5 694 }
d3a7d8c7 695 SvPOK_only(sv);
4438c4b7 696 }
79072805
LW		 697 break;
698 case '1': case '2': case '3': case '4':
699 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 700 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ		 701 I32 s1, t1;
702
a863c7d1
MB		 703 /*
704 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
705 * XXX Does the new way break anything?
706 */
ffc61ed2 707 paren = atoi(mg->mg_ptr); /* $& is in [0] */
79072805 708 getparen:
eb160463 709 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ		 710 (s1 = rx->startp[paren]) != -1 &&
711 (t1 = rx->endp[paren]) != -1)
bbce6d69 712 {
cf93c79d
IZ		 713 i = t1 - s1;
714 s = rx->subbeg + s1;
01ec43d0 715 if (!rx->subbeg)
c2e66d9e
GS		 716 break;
717
13f57bf8 718 getrx:
748a9306 719 if (i >= 0) {
cf93c79d 720 sv_setpvn(sv, s, i);
a30b2f1f 721 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
7e2040f0
GS		 722 SvUTF8_on(sv);
723 else
724 SvUTF8_off(sv);
e9814ee1
HS		 725 if (PL_tainting) {
726 if (RX_MATCH_TAINTED(rx)) {
727 MAGIC* mg = SvMAGIC(sv);
728 MAGIC* mgt;
729 PL_tainted = 1;
730 SvMAGIC(sv) = mg->mg_moremagic;
731 SvTAINT(sv);
732 if ((mgt = SvMAGIC(sv))) {
733 mg->mg_moremagic = mgt;
734 SvMAGIC(sv) = mg;
735 }
736 } else
737 SvTAINTED_off(sv);
738 }
748a9306
LW		 739 break;
740 }
79072805 741 }
79072805 742 }
3280af22 743 sv_setsv(sv,&PL_sv_undef);
79072805
LW		 744 break;
745 case '+':
aaa362c4 746 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 747 paren = rx->lastparen;
a0d0e21e
LW		 748 if (paren)
749 goto getparen;
79072805 750 }
3280af22 751 sv_setsv(sv,&PL_sv_undef);
79072805 752 break;
a01268b5
JH		 753 case '\016': /* ^N */
754 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
755 paren = rx->lastcloseparen;
756 if (paren)
757 goto getparen;
758 }
759 sv_setsv(sv,&PL_sv_undef);
760 break;
79072805 761 case '`':
aaa362c4 762 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ		 763 if ((s = rx->subbeg) && rx->startp[0] != -1) {
764 i = rx->startp[0];
13f57bf8 765 goto getrx;
79072805 766 }
79072805 767 }
3280af22 768 sv_setsv(sv,&PL_sv_undef);
79072805
LW		 769 break;
770 case '\'':
aaa362c4 771 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ		 772 if (rx->subbeg && rx->endp[0] != -1) {
773 s = rx->subbeg + rx->endp[0];
774 i = rx->sublen - rx->endp[0];
13f57bf8 775 goto getrx;
79072805 776 }
79072805 777 }
3280af22 778 sv_setsv(sv,&PL_sv_undef);
79072805
LW		 779 break;
780 case '.':
781#ifndef lint
3280af22 782 if (GvIO(PL_last_in_gv)) {
357c8808 783 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805
LW		 784 }
785#endif
786 break;
787 case '?':
809a5acc 788 {
809a5acc 789 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 790#ifdef COMPLEX_STATUS
6b88bc9c
GS		 791 LvTARGOFF(sv) = PL_statusvalue;
792 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 793#endif
809a5acc 794 }
79072805
LW		 795 break;
796 case '^':
3280af22 797 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW		 798 if (s)
799 sv_setpv(sv,s);
800 else {
3280af22 801 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805
LW		 802 sv_catpv(sv,"_TOP");
803 }
804 break;
805 case '~':
3280af22 806 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 807 if (!s)
3280af22 808 s = GvENAME(PL_defoutgv);
79072805
LW		 809 sv_setpv(sv,s);
810 break;
811#ifndef lint
812 case '=':
3280af22 813 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW		 814 break;
815 case '-':
3280af22 816 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW		 817 break;
818 case '%':
3280af22 819 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805
LW		 820 break;
821#endif
822 case ':':
823 break;
824 case '/':
825 break;
826 case '[':
3280af22 827 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
79072805
LW		 828 break;
829 case '|':
3280af22 830 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW		 831 break;
832 case ',':
79072805
LW		 833 break;
834 case '\\':
b2ce0fda 835 if (PL_ors_sv)
f28098ff 836 sv_copypv(sv, PL_ors_sv);
79072805
LW		 837 break;
838 case '#':
3280af22 839 sv_setpv(sv,PL_ofmt);
79072805
LW		 840 break;
841 case '!':
a5f75d66 842#ifdef VMS
65202027 843 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 844 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 845#else
88e89b8a 846 {
847 int saveerrno = errno;
65202027 848 sv_setnv(sv, (NV)errno);
88e89b8a 849#ifdef OS2
ed344e4f
IZ		 850 if (errno == errno_isOS2 || errno == errno_isOS2_set)
851 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 852 else
a5f75d66 853#endif
2304df62 854 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a 855 errno = saveerrno;
856 }
857#endif
946ec16e 858 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW		 859 break;
860 case '<':
3280af22 861 sv_setiv(sv, (IV)PL_uid);
79072805
LW		 862 break;
863 case '>':
3280af22 864 sv_setiv(sv, (IV)PL_euid);
79072805
LW		 865 break;
866 case '(':
3280af22 867 sv_setiv(sv, (IV)PL_gid);
a52cb5f7 868#ifdef HAS_GETGROUPS
785fb66b 869 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
a52cb5f7 870#endif
79072805
LW		 871 goto add_groups;
872 case ')':
3280af22 873 sv_setiv(sv, (IV)PL_egid);
a52cb5f7 874#ifdef HAS_GETGROUPS
785fb66b 875 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
a52cb5f7 876#endif
79072805 877 add_groups:
79072805 878#ifdef HAS_GETGROUPS
79072805 879 {
a0d0e21e 880 Groups_t gary[NGROUPS];
79072805 881 i = getgroups(NGROUPS,gary);
46fc3d4c 882 while (--i >= 0)
785fb66b 883 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
79072805
LW		 884 }
885#endif
155aba94 886 (void)SvIOK_on(sv); /* what a wonderful hack! */
79072805
LW		 887 break;
888 case '*':
889 break;
cd39f2b6 890#ifndef MACOS_TRADITIONAL
79072805
LW		 891 case '0':
892 break;
cd39f2b6 893#endif
79072805 894 }
a0d0e21e 895 return 0;
79072805
LW		 896}
897
898int
864dbfa3 899Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW		 900{
901 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
902
903 if (uf && uf->uf_val)
24f81a43 904 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW		 905 return 0;
906}
907
908int
864dbfa3 909Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805
LW		 910{
911 register char *s;
88e89b8a 912 char *ptr;
5aabfad6 913 STRLEN len, klen;
1e422769 914
a0d0e21e 915 s = SvPV(sv,len);
5aabfad6 916 ptr = MgPV(mg,klen);
88e89b8a 917 my_setenv(ptr, s);
1e422769 918
a0d0e21e
LW		 919#ifdef DYNAMIC_ENV_FETCH
920 /* We just undefd an environment var. Is a replacement */
921 /* waiting in the wings? */
922 if (!len) {
5aabfad6 923 SV **valp;
6b88bc9c 924 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
5aabfad6 925 s = SvPV(*valp, len);
a0d0e21e
LW		 926 }
927#endif
1e422769 928
39e571d4 929#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW		 930 /* And you'll never guess what the dog had */
931 /* in its mouth... */
3280af22 932 if (PL_tainting) {
1e422769 933 MgTAINTEDDIR_off(mg);
934#ifdef VMS
5aabfad6 935 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1e422769 936 char pathbuf[256], eltbuf[256], *cp, *elt = s;
c623ac67 937 Stat_t sbuf;
1e422769 938 int i = 0, j = 0;
939
940 do { /* DCL$PATH may be a search list */
941 while (1) { /* as may dev portion of any element */
942 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
943 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
944 cando_by_name(S_IWUSR,0,elt) ) {
945 MgTAINTEDDIR_on(mg);
946 return 0;
947 }
948 }
949 if ((cp = strchr(elt, ':')) != Nullch)
950 *cp = '\0';
951 if (my_trnlnm(elt, eltbuf, j++))
952 elt = eltbuf;
953 else
954 break;
955 }
956 j = 0;
957 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
958 }
959#endif /* VMS */
5aabfad6 960 if (s && klen == 4 && strEQ(ptr,"PATH")) {
a0d0e21e 961 char *strend = s + len;
463ee0b2
LW		 962
963 while (s < strend) {
96827780 964 char tmpbuf[256];
c623ac67 965 Stat_t st;
5f74f29c 966 I32 i;
96827780 967 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 968 s, strend, ':', &i);
463ee0b2 969 s++;
96827780
MB		 970 if (i >= sizeof tmpbuf /* too long -- assume the worst */
971 || *tmpbuf != '/'
c6ed36e1 972 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 973 MgTAINTEDDIR_on(mg);
1e422769 974 return 0;
975 }
463ee0b2 976 }
79072805
LW		 977 }
978 }
39e571d4 979#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 980
79072805
LW		 981 return 0;
982}
983
984int
864dbfa3 985Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 986{
2d8e6c8d
GS		 987 STRLEN n_a;
988 my_setenv(MgPV(mg,n_a),Nullch);
85e6fe83
LW		 989 return 0;
990}
991
88e89b8a 992int
864dbfa3 993Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 994{
995#if defined(VMS)
cea2e8a9 996 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 997#else
3280af22 998 if (PL_localizing) {
fb73857a 999 HE* entry;
2d8e6c8d 1000 STRLEN n_a;
fb73857a 1001 magic_clear_all_env(sv,mg);
1002 hv_iterinit((HV*)sv);
155aba94 1003 while ((entry = hv_iternext((HV*)sv))) {
fb73857a 1004 I32 keylen;
1005 my_setenv(hv_iterkey(entry, &keylen),
2d8e6c8d 1006 SvPV(hv_iterval((HV*)sv, entry), n_a));
fb73857a 1007 }
1008 }
1009#endif
1010 return 0;
1011}
1012
1013int
864dbfa3 1014Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1015{
ed79a026 1016#if defined(VMS) || defined(EPOC)
cea2e8a9 1017 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
3e3baf6d 1018#else
4efc5df6 1019# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
7766f137 1020 PerlEnv_clearenv();
4efc5df6
GS		 1021# else
1022# ifdef USE_ENVIRON_ARRAY
1023# if defined(USE_ITHREADS)
1024 /* only the parent thread can clobber the process environment */
1025 if (PL_curinterp == aTHX)
1026# endif
1027 {
1028# ifndef PERL_USE_SAFE_PUTENV
66b1d557
HM		 1029 I32 i;
1030
3280af22 1031 if (environ == PL_origenviron)
f2517201 1032 environ = (char**)safesysmalloc(sizeof(char*));
66b1d557
HM		 1033 else
1034 for (i = 0; environ[i]; i++)
f2517201 1035 safesysfree(environ[i]);
4efc5df6 1036# endif /* PERL_USE_SAFE_PUTENV */
f2517201 1037
66b1d557 1038 environ[0] = Nullch;
4efc5df6
GS		 1039 }
1040# endif /* USE_ENVIRON_ARRAY */
052c2dc6
JH		 1041# endif /* PERL_IMPLICIT_SYS || WIN32 */
1042#endif /* VMS || EPC */
3e3baf6d 1043 return 0;
66b1d557
HM		 1044}
1045
2e34cc90
CL		 1046#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1047static int sig_handlers_initted = 0;
1048#endif
7719e241 1049#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2
CL		 1050static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
1051#endif
2e34cc90
CL		 1052#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1053static int sig_defaulting[SIG_SIZE];
1054#endif
85b332e2 1055
64ca3a65 1056#ifndef PERL_MICRO
2d4fcd5e
AJ		 1057#ifdef HAS_SIGPROCMASK
1058static void
1059restore_sigmask(pTHX_ SV *save_sv)
1060{
1061 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1062 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1063}
1064#endif
66b1d557 1065int
864dbfa3 1066Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1067{
1068 I32 i;
2d8e6c8d 1069 STRLEN n_a;
88e89b8a 1070 /* Are we fetching a signal entry? */
2d8e6c8d 1071 i = whichsig(MgPV(mg,n_a));
88e89b8a 1072 if (i) {
22c35a8c
GS		 1073 if(PL_psig_ptr[i])
1074 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1075 else {
85b332e2 1076 Sighandler_t sigstate;
2e34cc90 1077 sigstate = rsignal_state(i);
23ada85b 1078#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
2e34cc90
CL		 1079 if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1080#endif
1081#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1082 if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
85b332e2 1083#endif
88e89b8a 1084 /* cache state so we don't fetch it again */
ff68c719 1085 if(sigstate == SIG_IGN)
88e89b8a 1086 sv_setpv(sv,"IGNORE");
1087 else
3280af22 1088 sv_setsv(sv,&PL_sv_undef);
22c35a8c 1089 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1090 SvTEMP_off(sv);
1091 }
1092 }
1093 return 0;
1094}
1095int
864dbfa3 1096Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1097{
2d4fcd5e
AJ		 1098 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1099 * refactoring might be in order.
1100 */
1101 register char *s;
2d8e6c8d 1102 STRLEN n_a;
2d4fcd5e
AJ		 1103 SV* to_dec;
1104 s = MgPV(mg,n_a);
1105 if (*s == '_') {
1106 SV** svp;
1107 if (strEQ(s,"__DIE__"))
1108 svp = &PL_diehook;
1109 else if (strEQ(s,"__WARN__"))
1110 svp = &PL_warnhook;
1111 else
1112 Perl_croak(aTHX_ "No such hook: %s", s);
1113 if (*svp) {
1114 to_dec = *svp;
1115 *svp = 0;
1116 SvREFCNT_dec(to_dec);
1117 }
1118 }
1119 else {
1120 I32 i;
1121 /* Are we clearing a signal entry? */
1122 i = whichsig(s);
1123 if (i) {
1124#ifdef HAS_SIGPROCMASK
1125 sigset_t set, save;
1126 SV* save_sv;
1127 /* Avoid having the signal arrive at a bad time, if possible. */
1128 sigemptyset(&set);
1129 sigaddset(&set,i);
1130 sigprocmask(SIG_BLOCK, &set, &save);
1131 ENTER;
1132 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1133 SAVEFREESV(save_sv);
1134 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1135#endif
1136 PERL_ASYNC_CHECK();
1137#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1138 if (!sig_handlers_initted) Perl_csighandler_init();
1139#endif
1140#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1141 sig_defaulting[i] = 1;
1142 (void)rsignal(i, &Perl_csighandler);
1143#else
1144 (void)rsignal(i, SIG_DFL);
1145#endif
1146 if(PL_psig_name[i]) {
1147 SvREFCNT_dec(PL_psig_name[i]);
1148 PL_psig_name[i]=0;
1149 }
1150 if(PL_psig_ptr[i]) {
1151 to_dec=PL_psig_ptr[i];
1152 PL_psig_ptr[i]=0;
1153 LEAVE;
1154 SvREFCNT_dec(to_dec);
1155 }
1156 else
1157 LEAVE;
1158 }
88e89b8a 1159 }
1160 return 0;
1161}
3d37d572 1162
0a8e0eff
NIS		 1163void
1164Perl_raise_signal(pTHX_ int sig)
1165{
1166 /* Set a flag to say this signal is pending */
1167 PL_psig_pend[sig]++;
1168 /* And one to say _a_ signal is pending */
1169 PL_sig_pending = 1;
1170}
1171
1172Signal_t
1173Perl_csighandler(int sig)
1174{
1018e26f
NIS		 1175#ifdef PERL_GET_SIG_CONTEXT
1176 dTHXa(PERL_GET_SIG_CONTEXT);
1177#else
85b332e2
CL		 1178 dTHX;
1179#endif
23ada85b 1180#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2
CL		 1181 (void) rsignal(sig, &Perl_csighandler);
1182 if (sig_ignoring[sig]) return;
1183#endif
2e34cc90 1184#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
7719e241 1185 if (sig_defaulting[sig])
2e34cc90
CL		 1186#ifdef KILL_BY_SIGPRC
1187 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1188#else
1189 exit(1);
1190#endif
1191#endif
4ffa73a3
JH		 1192 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1193 /* Call the perl level handler now--
1194 * with risk we may be in malloc() etc. */
1195 (*PL_sighandlerp)(sig);
1196 else
1197 Perl_raise_signal(aTHX_ sig);
0a8e0eff
NIS		 1198}
1199
2e34cc90
CL		 1200#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1201void
1202Perl_csighandler_init(void)
1203{
1204 int sig;
1205 if (sig_handlers_initted) return;
1206
1207 for (sig = 1; sig < SIG_SIZE; sig++) {
1208#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1209 dTHX;
2e34cc90
CL		 1210 sig_defaulting[sig] = 1;
1211 (void) rsignal(sig, &Perl_csighandler);
1212#endif
1213#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1214 sig_ignoring[sig] = 0;
1215#endif
1216 }
1217 sig_handlers_initted = 1;
1218}
1219#endif
1220
0a8e0eff
NIS		 1221void
1222Perl_despatch_signals(pTHX)
1223{
1224 int sig;
1225 PL_sig_pending = 0;
1226 for (sig = 1; sig < SIG_SIZE; sig++) {
1227 if (PL_psig_pend[sig]) {
25da4428
JH		 1228 PERL_BLOCKSIG_ADD(set, sig);
1229 PL_psig_pend[sig] = 0;
1230 PERL_BLOCKSIG_BLOCK(set);
f5203343 1231 (*PL_sighandlerp)(sig);
25da4428 1232 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS		 1233 }
1234 }
1235}
1236
85e6fe83 1237int
864dbfa3 1238Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805
LW		 1239{
1240 register char *s;
1241 I32 i;
b7953727 1242 SV** svp = 0;
2d4fcd5e
AJ		 1243 /* Need to be careful with SvREFCNT_dec(), because that can have side
1244 * effects (due to closures). We must make sure that the new disposition
1245 * is in place before it is called.
1246 */
1247 SV* to_dec = 0;
e72dc28c 1248 STRLEN len;
2d4fcd5e
AJ		 1249#ifdef HAS_SIGPROCMASK
1250 sigset_t set, save;
1251 SV* save_sv;
1252#endif
a0d0e21e 1253
e72dc28c 1254 s = MgPV(mg,len);
748a9306
LW		 1255 if (*s == '_') {
1256 if (strEQ(s,"__DIE__"))
3280af22 1257 svp = &PL_diehook;
748a9306 1258 else if (strEQ(s,"__WARN__"))
3280af22 1259 svp = &PL_warnhook;
748a9306 1260 else
cea2e8a9 1261 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1262 i = 0;
4633a7c4 1263 if (*svp) {
2d4fcd5e 1264 to_dec = *svp;
4633a7c4
LW		 1265 *svp = 0;
1266 }
748a9306
LW		 1267 }
1268 else {
1269 i = whichsig(s); /* ...no, a brick */
1270 if (!i) {
e476b1b5 1271 if (ckWARN(WARN_SIGNAL))
9014280d 1272 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW		 1273 return 0;
1274 }
2d4fcd5e
AJ		 1275#ifdef HAS_SIGPROCMASK
1276 /* Avoid having the signal arrive at a bad time, if possible. */
1277 sigemptyset(&set);
1278 sigaddset(&set,i);
1279 sigprocmask(SIG_BLOCK, &set, &save);
1280 ENTER;
1281 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1282 SAVEFREESV(save_sv);
1283 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1284#endif
1285 PERL_ASYNC_CHECK();
2e34cc90
CL		 1286#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1287 if (!sig_handlers_initted) Perl_csighandler_init();
1288#endif
23ada85b 1289#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2
CL		 1290 sig_ignoring[i] = 0;
1291#endif
2e34cc90 1292#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
2d4fcd5e 1293 sig_defaulting[i] = 0;
2e34cc90 1294#endif
22c35a8c 1295 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1296 to_dec = PL_psig_ptr[i];
22c35a8c 1297 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1298 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1299 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1300 SvREADONLY_on(PL_psig_name[i]);
748a9306 1301 }
a0d0e21e 1302 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1303 if (i) {
0a8e0eff 1304 (void)rsignal(i, &Perl_csighandler);
2d4fcd5e
AJ		 1305#ifdef HAS_SIGPROCMASK
1306 LEAVE;
1307#endif
1308 }
748a9306
LW		 1309 else
1310 *svp = SvREFCNT_inc(sv);
2d4fcd5e
AJ		 1311 if(to_dec)
1312 SvREFCNT_dec(to_dec);
a0d0e21e
LW		 1313 return 0;
1314 }
e72dc28c 1315 s = SvPV_force(sv,len);
748a9306 1316 if (strEQ(s,"IGNORE")) {
85b332e2 1317 if (i) {
23ada85b 1318#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
85b332e2
CL		 1319 sig_ignoring[i] = 1;
1320 (void)rsignal(i, &Perl_csighandler);
1321#else
ff68c719 1322 (void)rsignal(i, SIG_IGN);
85b332e2 1323#endif
2d4fcd5e 1324 }
748a9306
LW		 1325 }
1326 else if (strEQ(s,"DEFAULT") || !*s) {
1327 if (i)
2e34cc90
CL		 1328#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1329 {
1330 sig_defaulting[i] = 1;
1331 (void)rsignal(i, &Perl_csighandler);
1332 }
1333#else
ff68c719 1334 (void)rsignal(i, SIG_DFL);
2e34cc90 1335#endif
748a9306 1336 }
79072805 1337 else {
5aabfad6 1338 /*
1339 * We should warn if HINT_STRICT_REFS, but without
1340 * access to a known hint bit in a known OP, we can't
1341 * tell whether HINT_STRICT_REFS is in force or not.
1342 */
46fc3d4c 1343 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 1344 sv_insert(sv, 0, 0, "main::", 6);
748a9306 1345 if (i)
0a8e0eff 1346 (void)rsignal(i, &Perl_csighandler);
748a9306
LW		 1347 else
1348 *svp = SvREFCNT_inc(sv);
79072805 1349 }
2d4fcd5e
AJ		 1350#ifdef HAS_SIGPROCMASK
1351 if(i)
1352 LEAVE;
1353#endif
1354 if(to_dec)
1355 SvREFCNT_dec(to_dec);
79072805
LW		 1356 return 0;
1357}
64ca3a65 1358#endif /* !PERL_MICRO */
79072805
LW		 1359
1360int
864dbfa3 1361Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1362{
3280af22 1363 PL_sub_generation++;
463ee0b2
LW		 1364 return 0;
1365}
1366
1367int
864dbfa3 1368Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1369{
a0d0e21e 1370 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1371 PL_amagic_generation++;
463ee0b2 1372
a0d0e21e
LW		 1373 return 0;
1374}
463ee0b2 1375
946ec16e 1376int
864dbfa3 1377Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS		 1378{
1379 HV *hv = (HV*)LvTARG(sv);
6ff81951 1380 I32 i = 0;
7719e241 1381
6ff81951 1382 if (hv) {
497b47a8
JH		 1383 (void) hv_iterinit(hv);
1384 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1385 i = HvKEYS(hv);
1386 else {
1387 while (hv_iternext(hv))
1388 i++;
1389 }
6ff81951
GS		 1390 }
1391
1392 sv_setiv(sv, (IV)i);
1393 return 0;
1394}
1395
1396int
864dbfa3 1397Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1398{
1399 if (LvTARG(sv)) {
1400 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e 1401 }
1402 return 0;
ac27b0f5 1403}
946ec16e 1404
e336de0d 1405/* caller is responsible for stack switching/cleanup */
565764a8 1406STATIC int
cea2e8a9 1407S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW		 1408{
1409 dSP;
463ee0b2 1410
924508f0
GS		 1411 PUSHMARK(SP);
1412 EXTEND(SP, n);
33c27489 1413 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1414 if (n > 1) {
93965878 1415 if (mg->mg_ptr) {
565764a8 1416 if (mg->mg_len >= 0)
79cb57f6 1417 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1418 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS		 1419 PUSHs((SV*)mg->mg_ptr);
1420 }
14befaf4 1421 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1422 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS		 1423 }
1424 }
1425 if (n > 2) {
1426 PUSHs(val);
88e89b8a 1427 }
463ee0b2
LW		 1428 PUTBACK;
1429
864dbfa3 1430 return call_method(meth, flags);
946ec16e 1431}
1432
76e3520e 1433STATIC int
cea2e8a9 1434S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
a0d0e21e
LW		 1435{
1436 dSP;
463ee0b2 1437
a0d0e21e
LW		 1438 ENTER;
1439 SAVETMPS;
e788e7d3 1440 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1441
33c27489 1442 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1443 sv_setsv(sv, *PL_stack_sp--);
93965878 1444 }
463ee0b2 1445
d3acc0f7 1446 POPSTACK;
a0d0e21e
LW		 1447 FREETMPS;
1448 LEAVE;
1449 return 0;
1450}
463ee0b2 1451
a0d0e21e 1452int
864dbfa3 1453Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW		 1454{
1455 magic_methpack(sv,mg,"FETCH");
1456 if (mg->mg_ptr)
1457 mg->mg_flags |= MGf_GSKIP;
463ee0b2
LW		 1458 return 0;
1459}
1460
1461int
864dbfa3 1462Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d
GS		 1463{
1464 dSP;
a60c0954 1465 ENTER;
e788e7d3 1466 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1467 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1468 POPSTACK;
a60c0954 1469 LEAVE;
463ee0b2
LW		 1470 return 0;
1471}
1472
1473int
864dbfa3 1474Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1475{
a0d0e21e
LW		 1476 return magic_methpack(sv,mg,"DELETE");
1477}
463ee0b2 1478
93965878
NIS		 1479
1480U32
864dbfa3 1481Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1482{
e336de0d 1483 dSP;
93965878
NIS		 1484 U32 retval = 0;
1485
1486 ENTER;
1487 SAVETMPS;
e788e7d3 1488 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1489 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1490 sv = *PL_stack_sp--;
a60c0954 1491 retval = (U32) SvIV(sv)-1;
93965878 1492 }
d3acc0f7 1493 POPSTACK;
93965878
NIS		 1494 FREETMPS;
1495 LEAVE;
1496 return retval;
1497}
1498
cea2e8a9
GS		 1499int
1500Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW		 1501{
1502 dSP;
463ee0b2 1503
e336de0d 1504 ENTER;
e788e7d3 1505 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1506 PUSHMARK(SP);
33c27489 1507 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1508 PUTBACK;
864dbfa3 1509 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1510 POPSTACK;
a60c0954 1511 LEAVE;
463ee0b2
LW		 1512 return 0;
1513}
1514
1515int
864dbfa3 1516Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1517{
463ee0b2 1518 dSP;
dff6d3cd 1519 const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW		 1520
1521 ENTER;
a0d0e21e 1522 SAVETMPS;
e788e7d3 1523 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS		 1524 PUSHMARK(SP);
1525 EXTEND(SP, 2);
33c27489 1526 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW		 1527 if (SvOK(key))
1528 PUSHs(key);
1529 PUTBACK;
1530
864dbfa3 1531 if (call_method(meth, G_SCALAR))
3280af22 1532 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1533
d3acc0f7 1534 POPSTACK;
a0d0e21e
LW		 1535 FREETMPS;
1536 LEAVE;
79072805
LW		 1537 return 0;
1538}
1539
1540int
864dbfa3 1541Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW		 1542{
1543 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1544}
a0d0e21e
LW		 1545
1546int
864dbfa3 1547Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805
LW		 1548{
1549 OP *o;
1550 I32 i;
1551 GV* gv;
1552 SV** svp;
2d8e6c8d 1553 STRLEN n_a;
79072805 1554
3280af22 1555 gv = PL_DBline;
79072805 1556 i = SvTRUE(sv);
188ea221 1557 svp = av_fetch(GvAV(gv),
2d8e6c8d 1558 atoi(MgPV(mg,n_a)), FALSE);
5df8de69
DM		 1559 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1560 /* set or clear breakpoint in the relevant control op */
1561 if (i)
1562 o->op_flags |= OPf_SPECIAL;
1563 else
1564 o->op_flags &= ~OPf_SPECIAL;
1565 }
79072805
LW		 1566 return 0;
1567}
1568
1569int
864dbfa3 1570Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1571{
3280af22 1572 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
79072805
LW		 1573 return 0;
1574}
1575
1576int
864dbfa3 1577Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1578{
3280af22 1579 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
a0d0e21e
LW		 1580 return 0;
1581}
1582
1583int
864dbfa3 1584Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW		 1585{
1586 SV* lsv = LvTARG(sv);
ac27b0f5 1587
a0d0e21e 1588 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
14befaf4 1589 mg = mg_find(lsv, PERL_MAGIC_regex_global);
565764a8 1590 if (mg && mg->mg_len >= 0) {
a0ed51b3 1591 I32 i = mg->mg_len;
7e2040f0 1592 if (DO_UTF8(lsv))
a0ed51b3
LW		 1593 sv_pos_b2u(lsv, &i);
1594 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW		 1595 return 0;
1596 }
1597 }
1598 (void)SvOK_off(sv);
1599 return 0;
1600}
1601
1602int
864dbfa3 1603Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW		 1604{
1605 SV* lsv = LvTARG(sv);
1606 SSize_t pos;
1607 STRLEN len;
c00206c8 1608 STRLEN ulen = 0;
a0d0e21e
LW		 1609
1610 mg = 0;
ac27b0f5 1611
a0d0e21e 1612 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
14befaf4 1613 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW		 1614 if (!mg) {
1615 if (!SvOK(sv))
1616 return 0;
14befaf4
DM		 1617 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1618 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW		 1619 }
1620 else if (!SvOK(sv)) {
565764a8 1621 mg->mg_len = -1;
a0d0e21e
LW		 1622 return 0;
1623 }
1624 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1625
c485e607 1626 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3 1627
7e2040f0 1628 if (DO_UTF8(lsv)) {
a0ed51b3
LW		 1629 ulen = sv_len_utf8(lsv);
1630 if (ulen)
1631 len = ulen;
a0ed51b3
LW		 1632 }
1633
a0d0e21e
LW		 1634 if (pos < 0) {
1635 pos += len;
1636 if (pos < 0)
1637 pos = 0;
1638 }
eb160463 1639 else if (pos > (SSize_t)len)
a0d0e21e 1640 pos = len;
a0ed51b3
LW		 1641
1642 if (ulen) {
1643 I32 p = pos;
1644 sv_pos_u2b(lsv, &p, 0);
1645 pos = p;
1646 }
727405f8 1647
565764a8 1648 mg->mg_len = pos;
71be2cbc 1649 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1650
79072805
LW		 1651 return 0;
1652}
1653
1654int
864dbfa3 1655Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1656{
8646b087 1657 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1658 SvFAKE_off(sv);
946ec16e 1659 gv_efullname3(sv,((GV*)sv), "*");
8646b087 1660 SvFAKE_on(sv);
1661 }
1662 else
946ec16e 1663 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW		 1664 return 0;
1665}
1666
1667int
864dbfa3 1668Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805
LW		 1669{
1670 register char *s;
1671 GV* gv;
2d8e6c8d 1672 STRLEN n_a;
79072805
LW		 1673
1674 if (!SvOK(sv))
1675 return 0;
2d8e6c8d 1676 s = SvPV(sv, n_a);
79072805
LW		 1677 if (*s == '*' && s[1])
1678 s++;
85e6fe83 1679 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
79072805
LW		 1680 if (sv == (SV*)gv)
1681 return 0;
1682 if (GvGP(sv))
88e89b8a 1683 gp_free((GV*)sv);
79072805 1684 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW		 1685 return 0;
1686}
1687
1688int
864dbfa3 1689Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS		 1690{
1691 STRLEN len;
1692 SV *lsv = LvTARG(sv);
1693 char *tmps = SvPV(lsv,len);
1694 I32 offs = LvTARGOFF(sv);
1695 I32 rem = LvTARGLEN(sv);
1696
9aa983d2
JH		 1697 if (SvUTF8(lsv))
1698 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1699 if (offs > (I32)len)
6ff81951 1700 offs = len;
eb160463 1701 if (rem + offs > (I32)len)
6ff81951
GS		 1702 rem = len - offs;
1703 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1704 if (SvUTF8(lsv))
2ef4b674 1705 SvUTF8_on(sv);
6ff81951
GS		 1706 return 0;
1707}
1708
1709int
864dbfa3 1710Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1711{
9aa983d2
JH		 1712 STRLEN len;
1713 char *tmps = SvPV(sv, len);
1714 SV *lsv = LvTARG(sv);
1715 I32 lvoff = LvTARGOFF(sv);
1716 I32 lvlen = LvTARGLEN(sv);
075a4a2b 1717
1aa99e6b 1718 if (DO_UTF8(sv)) {
9aa983d2
JH		 1719 sv_utf8_upgrade(lsv);
1720 sv_pos_u2b(lsv, &lvoff, &lvlen);
1721 sv_insert(lsv, lvoff, lvlen, tmps, len);
1722 SvUTF8_on(lsv);
1723 }
9bf12eaf 1724 else if (lsv && SvUTF8(lsv)) {
9aa983d2 1725 sv_pos_u2b(lsv, &lvoff, &lvlen);
e95af362 1726 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
9aa983d2
JH		 1727 sv_insert(lsv, lvoff, lvlen, tmps, len);
1728 Safefree(tmps);
1aa99e6b
IH		 1729 }
1730 else
9aa983d2 1731 sv_insert(lsv, lvoff, lvlen, tmps, len);
1aa99e6b 1732
79072805
LW		 1733 return 0;
1734}
1735
1736int
864dbfa3 1737Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1738{
565764a8 1739 TAINT_IF((mg->mg_len & 1) ||
155aba94 1740 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
463ee0b2
LW		 1741 return 0;
1742}
1743
1744int
864dbfa3 1745Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1746{
3280af22
NIS		 1747 if (PL_localizing) {
1748 if (PL_localizing == 1)
565764a8 1749 mg->mg_len <<= 1;
748a9306 1750 else
565764a8 1751 mg->mg_len >>= 1;
a0d0e21e 1752 }
3280af22 1753 else if (PL_tainted)
565764a8 1754 mg->mg_len |= 1;
748a9306 1755 else
565764a8 1756 mg->mg_len &= ~1;
463ee0b2
LW		 1757 return 0;
1758}
1759
1760int
864dbfa3 1761Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS		 1762{
1763 SV *lsv = LvTARG(sv);
6ff81951
GS		 1764
1765 if (!lsv) {
155aba94 1766 (void)SvOK_off(sv);
6ff81951
GS		 1767 return 0;
1768 }
6ff81951 1769
81e118e0 1770 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951
GS		 1771 return 0;
1772}
1773
1774int
864dbfa3 1775Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805
LW		 1776{
1777 do_vecset(sv); /* XXX slurp this routine */
1778 return 0;
1779}
1780
1781int
864dbfa3 1782Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1783{
71be2cbc 1784 SV *targ = Nullsv;
5f05dabc 1785 if (LvTARGLEN(sv)) {
68dc0745 1786 if (mg->mg_obj) {
74e13ce4 1787 SV *ahv = LvTARG(sv);
6d822dc4
MS		 1788 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1789 if (he)
1790 targ = HeVAL(he);
68dc0745 1791 }
1792 else {
3c78fafa 1793 AV* av = (AV*)LvTARG(sv);
68dc0745 1794 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1795 targ = AvARRAY(av)[LvTARGOFF(sv)];
1796 }
3280af22 1797 if (targ && targ != &PL_sv_undef) {
68dc0745 1798 /* somebody else defined it for us */
1799 SvREFCNT_dec(LvTARG(sv));
1800 LvTARG(sv) = SvREFCNT_inc(targ);
1801 LvTARGLEN(sv) = 0;
1802 SvREFCNT_dec(mg->mg_obj);
1803 mg->mg_obj = Nullsv;
1804 mg->mg_flags &= ~MGf_REFCOUNTED;
1805 }
5f05dabc 1806 }
71be2cbc 1807 else
1808 targ = LvTARG(sv);
3280af22 1809 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc 1810 return 0;
1811}
1812
1813int
864dbfa3 1814Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 1815{
1816 if (LvTARGLEN(sv))
68dc0745 1817 vivify_defelem(sv);
1818 if (LvTARG(sv)) {
5f05dabc 1819 sv_setsv(LvTARG(sv), sv);
68dc0745 1820 SvSETMAGIC(LvTARG(sv));
1821 }
5f05dabc 1822 return 0;
1823}
1824
71be2cbc 1825void
864dbfa3 1826Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 1827{
74e13ce4
GS		 1828 MAGIC *mg;
1829 SV *value = Nullsv;
71be2cbc 1830
14befaf4 1831 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 1832 return;
68dc0745 1833 if (mg->mg_obj) {
74e13ce4 1834 SV *ahv = LvTARG(sv);
2d8e6c8d 1835 STRLEN n_a;
6d822dc4
MS		 1836 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1837 if (he)
1838 value = HeVAL(he);
3280af22 1839 if (!value || value == &PL_sv_undef)
cea2e8a9 1840 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
71be2cbc 1841 }
68dc0745 1842 else {
1843 AV* av = (AV*)LvTARG(sv);
5aabfad6 1844 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745 1845 LvTARG(sv) = Nullsv; /* array can't be extended */
1846 else {
1847 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 1848 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 1849 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745 1850 }
1851 }
3e3baf6d 1852 (void)SvREFCNT_inc(value);
68dc0745 1853 SvREFCNT_dec(LvTARG(sv));
1854 LvTARG(sv) = value;
71be2cbc 1855 LvTARGLEN(sv) = 0;
68dc0745 1856 SvREFCNT_dec(mg->mg_obj);
1857 mg->mg_obj = Nullsv;
1858 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc 1859}
1860
1861int
864dbfa3 1862Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5
GS		 1863{
1864 AV *av = (AV*)mg->mg_obj;
1865 SV **svp = AvARRAY(av);
1866 I32 i = AvFILLp(av);
1867 while (i >= 0) {
1868 if (svp[i] && svp[i] != &PL_sv_undef) {
1869 if (!SvWEAKREF(svp[i]))
cea2e8a9 1870 Perl_croak(aTHX_ "panic: magic_killbackrefs");
810b8aa5
GS		 1871 /* XXX Should we check that it hasn't changed? */
1872 SvRV(svp[i]) = 0;
155aba94 1873 (void)SvOK_off(svp[i]);
810b8aa5
GS		 1874 SvWEAKREF_off(svp[i]);
1875 svp[i] = &PL_sv_undef;
1876 }
1877 i--;
1878 }
1879 return 0;
1880}
1881
1882int
864dbfa3 1883Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 1884{
565764a8 1885 mg->mg_len = -1;
c6496cc7 1886 SvSCREAM_off(sv);
93a17b20
LW		 1887 return 0;
1888}
1889
1890int
864dbfa3 1891Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 1892{
14befaf4 1893 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW		 1894 SvVALID_off(sv);
1895 return 0;
1896}
1897
1898int
864dbfa3 1899Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 1900{
14befaf4 1901 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff 1902 SvCOMPILED_off(sv);
1903 return 0;
1904}
1905
1906int
864dbfa3 1907Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW		 1908{
1909 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1910
1911 if (uf && uf->uf_set)
24f81a43 1912 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW		 1913 return 0;
1914}
1915
c277df42 1916int
faf82a0b
AE		 1917Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
1918{
1919 sv_unmagic(sv, PERL_MAGIC_qr);
1920 return 0;
1921}
1922
1923int
864dbfa3 1924Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42
IZ		 1925{
1926 regexp *re = (regexp *)mg->mg_obj;
1927 ReREFCNT_dec(re);
1928 return 0;
1929}
1930
7a4c00b4 1931#ifdef USE_LOCALE_COLLATE
79072805 1932int
864dbfa3 1933Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69 1934{
1935 /*
838b5b74 1936 * RenE<eacute> Descartes said "I think not."
bbce6d69 1937 * and vanished with a faint plop.
1938 */
7a4c00b4 1939 if (mg->mg_ptr) {
1940 Safefree(mg->mg_ptr);
1941 mg->mg_ptr = NULL;
565764a8 1942 mg->mg_len = -1;
7a4c00b4 1943 }
bbce6d69 1944 return 0;
1945}
7a4c00b4 1946#endif /* USE_LOCALE_COLLATE */
bbce6d69 1947
7e8c5dac
HS		 1948/* Just clear the UTF-8 cache data. */
1949int
1950Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
1951{
1952 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
1953 mg->mg_ptr = 0;
1954 mg->mg_len = -1; /* The mg_len holds the len cache. */
1955 return 0;
1956}
1957
bbce6d69 1958int
864dbfa3 1959Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805
LW		 1960{
1961 register char *s;
1962 I32 i;
8990e307 1963 STRLEN len;
79072805 1964 switch (*mg->mg_ptr) {
748a9306 1965 case '\001': /* ^A */
3280af22 1966 sv_setsv(PL_bodytarget, sv);
748a9306 1967 break;
49460fe6 1968 case '\003': /* ^C */
eb160463 1969 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
49460fe6
NIS		 1970 break;
1971
79072805 1972 case '\004': /* ^D */
aea4f609 1973 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
79072805
LW		 1974 DEBUG_x(dump_all());
1975 break;
28f23441 1976 case '\005': /* ^E */
d0063567 1977 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 1978#ifdef MACOS_TRADITIONAL
d0063567 1979 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 1980#else
cd39f2b6 1981# ifdef VMS
d0063567 1982 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 1983# else
cd39f2b6 1984# ifdef WIN32
d0063567 1985 SetLastError( SvIV(sv) );
cd39f2b6 1986# else
9fed8b87 1987# ifdef OS2
d0063567 1988 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
9fed8b87 1989# else
d0063567
DK		 1990 /* will anyone ever use this? */
1991 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 1992# endif
048c1ddf
IZ		 1993# endif
1994# endif
22fae026 1995#endif
d0063567
DK		 1996 }
1997 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
1998 if (PL_encoding)
1999 SvREFCNT_dec(PL_encoding);
2000 if (SvOK(sv) || SvGMAGICAL(sv)) {
2001 PL_encoding = newSVsv(sv);
2002 }
2003 else {
2004 PL_encoding = Nullsv;
2005 }
2006 }
2007 break;
79072805 2008 case '\006': /* ^F */
3280af22 2009 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 2010 break;
a0d0e21e 2011 case '\010': /* ^H */
3280af22 2012 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 2013 break;
9d116dd7 2014 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS		 2015 if (PL_inplace)
2016 Safefree(PL_inplace);
79072805 2017 if (SvOK(sv))
2d8e6c8d 2018 PL_inplace = savepv(SvPV(sv,len));
79072805 2019 else
3280af22 2020 PL_inplace = Nullch;
79072805 2021 break;
28f23441 2022 case '\017': /* ^O */
ac27b0f5
NIS		 2023 if (*(mg->mg_ptr+1) == '\0') {
2024 if (PL_osname)
2025 Safefree(PL_osname);
2026 if (SvOK(sv))
2027 PL_osname = savepv(SvPV(sv,len));
2028 else
2029 PL_osname = Nullch;
2030 }
2031 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2032 if (!PL_compiling.cop_io)
2033 PL_compiling.cop_io = newSVsv(sv);
2034 else
2035 sv_setsv(PL_compiling.cop_io,sv);
2036 }
28f23441 2037 break;
79072805 2038 case '\020': /* ^P */
3280af22 2039 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1ee4443e
IZ		 2040 if (PL_perldb && !PL_DBsingle)
2041 init_debugger();
79072805
LW		 2042 break;
2043 case '\024': /* ^T */
88e89b8a 2044#ifdef BIG_TIME
6b88bc9c 2045 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2046#else
3280af22 2047 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 2048#endif
79072805 2049 break;
fde18df1 2050 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH		 2051 if (*(mg->mg_ptr+1) == '\0') {
2052 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2053 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 2054 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2055 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2056 }
599cee73 2057 }
0a378802 2058 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2059 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS		 2060 if (!SvPOK(sv) && PL_localizing) {
2061 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2062 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS		 2063 break;
2064 }
f4fc7782 2065 {
b5477537 2066 STRLEN len, i;
d3a7d8c7 2067 int accumulate = 0 ;
f4fc7782 2068 int any_fatals = 0 ;
d3a7d8c7 2069 char * ptr = (char*)SvPV(sv, len) ;
f4fc7782
JH		 2070 for (i = 0 ; i < len ; ++i) {
2071 accumulate |= ptr[i] ;
2072 any_fatals |= (ptr[i] & 0xAA) ;
2073 }
d3a7d8c7
GS		 2074 if (!accumulate)
2075 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782
JH		 2076 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2077 PL_compiling.cop_warnings = pWARN_ALL;
2078 PL_dowarn |= G_WARN_ONCE ;
727405f8 2079 }
d3a7d8c7
GS		 2080 else {
2081 if (specialWARN(PL_compiling.cop_warnings))
2082 PL_compiling.cop_warnings = newSVsv(sv) ;
2083 else
2084 sv_setsv(PL_compiling.cop_warnings, sv);
2085 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2086 PL_dowarn |= G_WARN_ONCE ;
2087 }
f4fc7782 2088
d3a7d8c7 2089 }
4438c4b7 2090 }
971a9dd3 2091 }
79072805
LW		 2092 break;
2093 case '.':
3280af22
NIS		 2094 if (PL_localizing) {
2095 if (PL_localizing == 1)
7766f137 2096 SAVESPTR(PL_last_in_gv);
748a9306 2097 }
3280af22 2098 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2099 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW		 2100 break;
2101 case '^':
3280af22 2102 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 2103 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 2104 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW		 2105 break;
2106 case '~':
3280af22 2107 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2d8e6c8d 2108 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
3280af22 2109 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW		 2110 break;
2111 case '=':
632db599 2112 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW		 2113 break;
2114 case '-':
632db599 2115 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
3280af22
NIS		 2116 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2117 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW		 2118 break;
2119 case '%':
632db599 2120 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW		 2121 break;
2122 case '|':
4b65379b 2123 {
3280af22 2124 IO *io = GvIOp(PL_defoutgv);
720f287d
AB		 2125 if(!io)
2126 break;
4b65379b
CS		 2127 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2128 IoFLAGS(io) &= ~IOf_FLUSH;
2129 else {
2130 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2131 PerlIO *ofp = IoOFP(io);
2132 if (ofp)
2133 (void)PerlIO_flush(ofp);
2134 IoFLAGS(io) |= IOf_FLUSH;
2135 }
2136 }
79072805
LW		 2137 }
2138 break;
2139 case '*':
463ee0b2 2140 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
3280af22 2141 PL_multiline = (i != 0);
79072805
LW		 2142 break;
2143 case '/':
3280af22 2144 SvREFCNT_dec(PL_rs);
8bfdd7d9 2145 PL_rs = newSVsv(sv);
79072805
LW		 2146 break;
2147 case '\\':
7889fe52
NIS		 2148 if (PL_ors_sv)
2149 SvREFCNT_dec(PL_ors_sv);
009c130f 2150 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2151 PL_ors_sv = newSVsv(sv);
009c130f 2152 }
e3c19b7b 2153 else {
7889fe52 2154 PL_ors_sv = Nullsv;
e3c19b7b 2155 }
79072805
LW		 2156 break;
2157 case ',':
7889fe52
NIS		 2158 if (PL_ofs_sv)
2159 SvREFCNT_dec(PL_ofs_sv);
2160 if (SvOK(sv) || SvGMAGICAL(sv)) {
2161 PL_ofs_sv = newSVsv(sv);
2162 }
2163 else {
2164 PL_ofs_sv = Nullsv;
2165 }
79072805
LW		 2166 break;
2167 case '#':
3280af22
NIS		 2168 if (PL_ofmt)
2169 Safefree(PL_ofmt);
2d8e6c8d 2170 PL_ofmt = savepv(SvPV(sv,len));
79072805
LW		 2171 break;
2172 case '[':
3280af22 2173 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW		 2174 break;
2175 case '?':
ff0cee69 2176#ifdef COMPLEX_STATUS
6b88bc9c
GS		 2177 if (PL_localizing == 2) {
2178 PL_statusvalue = LvTARGOFF(sv);
2179 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69 2180 }
2181 else
2182#endif
2183#ifdef VMSISH_STATUS
2184 if (VMSISH_STATUS)
2185 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2186 else
2187#endif
2188 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW		 2189 break;
2190 case '!':
93189314
JH		 2191 {
2192#ifdef VMS
2193# define PERL_VMS_BANG vaxc$errno
2194#else
2195# define PERL_VMS_BANG 0
2196#endif
91487cfc 2197 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH		 2198 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2199 }
79072805
LW		 2200 break;
2201 case '<':
3280af22
NIS		 2202 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2203 if (PL_delaymagic) {
2204 PL_delaymagic |= DM_RUID;
79072805
LW		 2205 break; /* don't do magic till later */
2206 }
2207#ifdef HAS_SETRUID
b28d0864 2208 (void)setruid((Uid_t)PL_uid);
79072805
LW		 2209#else
2210#ifdef HAS_SETREUID
3280af22 2211 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2212#else
85e6fe83 2213#ifdef HAS_SETRESUID
b28d0864 2214 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2215#else
b28d0864
NIS		 2216 if (PL_uid == PL_euid) /* special case $< = $> */
2217 (void)PerlProc_setuid(PL_uid);
a0d0e21e 2218 else {
d8eceb89 2219 PL_uid = PerlProc_getuid();
cea2e8a9 2220 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2221 }
79072805
LW		 2222#endif
2223#endif
85e6fe83 2224#endif
d8eceb89 2225 PL_uid = PerlProc_getuid();
3280af22 2226 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW		 2227 break;
2228 case '>':
3280af22
NIS		 2229 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2230 if (PL_delaymagic) {
2231 PL_delaymagic |= DM_EUID;
79072805
LW		 2232 break; /* don't do magic till later */
2233 }
2234#ifdef HAS_SETEUID
3280af22 2235 (void)seteuid((Uid_t)PL_euid);
79072805
LW		 2236#else
2237#ifdef HAS_SETREUID
b28d0864 2238 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW		 2239#else
2240#ifdef HAS_SETRESUID
6b88bc9c 2241 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2242#else
b28d0864
NIS		 2243 if (PL_euid == PL_uid) /* special case $> = $< */
2244 PerlProc_setuid(PL_euid);
a0d0e21e 2245 else {
e8ee3774 2246 PL_euid = PerlProc_geteuid();
cea2e8a9 2247 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2248 }
79072805
LW		 2249#endif
2250#endif
85e6fe83 2251#endif
d8eceb89 2252 PL_euid = PerlProc_geteuid();
3280af22 2253 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW		 2254 break;
2255 case '(':
3280af22
NIS		 2256 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2257 if (PL_delaymagic) {
2258 PL_delaymagic |= DM_RGID;
79072805
LW		 2259 break; /* don't do magic till later */
2260 }
2261#ifdef HAS_SETRGID
b28d0864 2262 (void)setrgid((Gid_t)PL_gid);
79072805
LW		 2263#else
2264#ifdef HAS_SETREGID
3280af22 2265 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW		 2266#else
2267#ifdef HAS_SETRESGID
b28d0864 2268 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2269#else
b28d0864
NIS		 2270 if (PL_gid == PL_egid) /* special case $( = $) */
2271 (void)PerlProc_setgid(PL_gid);
748a9306 2272 else {
d8eceb89 2273 PL_gid = PerlProc_getgid();
cea2e8a9 2274 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2275 }
79072805
LW		 2276#endif
2277#endif
85e6fe83 2278#endif
d8eceb89 2279 PL_gid = PerlProc_getgid();
3280af22 2280 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW		 2281 break;
2282 case ')':
5cd24f17 2283#ifdef HAS_SETGROUPS
2284 {
2d8e6c8d 2285 char *p = SvPV(sv, len);
5cd24f17 2286 Groups_t gary[NGROUPS];
2287
5cd24f17 2288 while (isSPACE(*p))
2289 ++p;
2d4389e4 2290 PL_egid = Atol(p);
5cd24f17 2291 for (i = 0; i < NGROUPS; ++i) {
2292 while (*p && !isSPACE(*p))
2293 ++p;
2294 while (isSPACE(*p))
2295 ++p;
2296 if (!*p)
2297 break;
2d4389e4 2298 gary[i] = Atol(p);
5cd24f17 2299 }
8cc95fdb 2300 if (i)
2301 (void)setgroups(i, gary);
5cd24f17 2302 }
2303#else /* HAS_SETGROUPS */
b28d0864 2304 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2305#endif /* HAS_SETGROUPS */
3280af22
NIS		 2306 if (PL_delaymagic) {
2307 PL_delaymagic |= DM_EGID;
79072805
LW		 2308 break; /* don't do magic till later */
2309 }
2310#ifdef HAS_SETEGID
3280af22 2311 (void)setegid((Gid_t)PL_egid);
79072805
LW		 2312#else
2313#ifdef HAS_SETREGID
b28d0864 2314 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW		 2315#else
2316#ifdef HAS_SETRESGID
b28d0864 2317 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2318#else
b28d0864
NIS		 2319 if (PL_egid == PL_gid) /* special case $) = $( */
2320 (void)PerlProc_setgid(PL_egid);
748a9306 2321 else {
d8eceb89 2322 PL_egid = PerlProc_getegid();
cea2e8a9 2323 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2324 }
79072805
LW		 2325#endif
2326#endif
85e6fe83 2327#endif
d8eceb89 2328 PL_egid = PerlProc_getegid();
3280af22 2329 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW		 2330 break;
2331 case ':':
2d8e6c8d 2332 PL_chopset = SvPV_force(sv,len);
79072805 2333 break;
cd39f2b6 2334#ifndef MACOS_TRADITIONAL
79072805 2335 case '0':
e2975953 2336 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS		 2337#ifdef HAS_SETPROCTITLE
2338 /* The BSDs don't show the argv[] in ps(1) output, they
2339 * show a string from the process struct and provide
2340 * the setproctitle() routine to manipulate that. */
2341 {
2342 s = SvPV(sv, len);
98b76f99 2343# if __FreeBSD_version > 410001
9aad2c0e 2344 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS		 2345 * but not the "(perl) suffix from the ps(1)
2346 * output, because that's what ps(1) shows if the
2347 * argv[] is modified. */
6f2ad931 2348 setproctitle("-%s", s);
9aad2c0e 2349# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS		 2350 /* This doesn't really work if you assume that
2351 * $0 = 'foobar'; will wipe out 'perl' from the $0
2352 * because in ps(1) output the result will be like
2353 * sprintf("perl: %s (perl)", s)
2354 * I guess this is a security feature:
2355 * one (a user process) cannot get rid of the original name.
2356 * --jhi */
2357 setproctitle("%s", s);
2358# endif
2359 }
2360#endif
17aa7f3d
JH		 2361#if defined(__hpux) && defined(PSTAT_SETCMD)
2362 {
2363 union pstun un;
2364 s = SvPV(sv, len);
2365 un.pst_command = s;
2366 pstat(PSTAT_SETCMD, un, len, 0, 0);
2367 }
2368#endif
3280af22
NIS		 2369 if (!PL_origalen) {
2370 s = PL_origargv[0];
79072805
LW		 2371 s += strlen(s);
2372 /* See if all the arguments are contiguous in memory */
3280af22
NIS		 2373 for (i = 1; i < PL_origargc; i++) {
2374 if (PL_origargv[i] == s + 1
fb73857a 2375#ifdef OS2
6b88bc9c 2376 || PL_origargv[i] == s + 2
ac27b0f5 2377#endif
fb73857a 2378 )
379c4362
GS		 2379 {
2380 ++s;
2381 s += strlen(s); /* this one is ok too */
2382 }
fb73857a 2383 else
2384 break;
79072805 2385 }
bbce6d69 2386 /* can grab env area too? */
4efc5df6
GS		 2387 if (PL_origenviron
2388#ifdef USE_ITHREADS
2389 && PL_curinterp == aTHX
2390#endif
2391 && (PL_origenviron[0] == s + 1))
2392 {
66b1d557 2393 my_setenv("NoNe SuCh", Nullch);
79072805 2394 /* force copy of environment */
3280af22 2395 for (i = 0; PL_origenviron[i]; i++)
379c4362
GS		 2396 if (PL_origenviron[i] == s + 1) {
2397 ++s;
2398 s += strlen(s);
2399 }
fb73857a 2400 else
2401 break;
79072805 2402 }
3280af22 2403 PL_origalen = s - PL_origargv[0];
79072805 2404 }
a0d0e21e 2405 s = SvPV_force(sv,len);
8990e307 2406 i = len;
eb160463 2407 if (i >= (I32)PL_origalen) {
3280af22 2408 i = PL_origalen;
fb73857a 2409 /* don't allow system to limit $0 seen by script */
2410 /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
3280af22
NIS		 2411 Copy(s, PL_origargv[0], i, char);
2412 s = PL_origargv[0]+i;
fb73857a 2413 *s = '\0';
79072805
LW		 2414 }
2415 else {
3280af22
NIS		 2416 Copy(s, PL_origargv[0], i, char);
2417 s = PL_origargv[0]+i;
79072805 2418 *s++ = '\0';
eb160463 2419 while (++i < (I32)PL_origalen)
f1c3b2ef 2420 *s++ = '\0';
3280af22
NIS		 2421 for (i = 1; i < PL_origargc; i++)
2422 PL_origargv[i] = Nullch;
79072805 2423 }
e2975953 2424 UNLOCK_DOLLARZERO_MUTEX;
79072805 2425 break;
cd39f2b6 2426#endif
79072805
LW		 2427 }
2428 return 0;
2429}
2430
2431I32
864dbfa3 2432Perl_whichsig(pTHX_ char *sig)
79072805
LW		 2433{
2434 register char **sigv;
2435
22c35a8c 2436 for (sigv = PL_sig_name+1; *sigv; sigv++)
79072805 2437 if (strEQ(sig,*sigv))
22c35a8c 2438 return PL_sig_num[sigv - PL_sig_name];
79072805
LW		 2439#ifdef SIGCLD
2440 if (strEQ(sig,"CHLD"))
2441 return SIGCLD;
2442#endif
2443#ifdef SIGCHLD
2444 if (strEQ(sig,"CLD"))
2445 return SIGCHLD;
2446#endif
2447 return 0;
2448}
2449
df3728a2 2450#if !defined(PERL_IMPLICIT_CONTEXT)
84902520 2451static SV* sig_sv;
df3728a2 2452#endif
84902520 2453
ecfc5424 2454Signal_t
cea2e8a9 2455Perl_sighandler(int sig)
79072805 2456{
1018e26f
NIS		 2457#ifdef PERL_GET_SIG_CONTEXT
2458 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2459#else
cea2e8a9 2460 dTHX;
71d280e3 2461#endif
79072805 2462 dSP;
00d579c5 2463 GV *gv = Nullgv;
a0d0e21e 2464 HV *st;
b7953727 2465 SV *sv = Nullsv, *tSv = PL_Sv;
00d579c5 2466 CV *cv = Nullcv;
533c011a 2467 OP *myop = PL_op;
84902520 2468 U32 flags = 0;
3280af22 2469 XPV *tXpv = PL_Xpv;
71d280e3 2470
3280af22 2471 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2472 flags |= 1;
3280af22 2473 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2474 flags |= 4;
3280af22 2475 if (PL_retstack_ix < PL_retstack_max - 2)
84902520 2476 flags |= 8;
3280af22 2477 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB		 2478 flags |= 16;
2479
727405f8 2480 if (!PL_psig_ptr[sig]) {
99ef548b 2481 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS		 2482 PL_sig_name[sig]);
2483 exit(sig);
2484 }
ff0cee69 2485
84902520
TB		 2486 /* Max number of items pushed there is 3*n or 4. We cannot fix
2487 infinity, so we fix 4 (in fact 5): */
2488 if (flags & 1) {
3280af22 2489 PL_savestack_ix += 5; /* Protect save in progress. */
c76ac1ee 2490 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
84902520 2491 }
ac27b0f5 2492 if (flags & 4)
3280af22 2493 PL_markstack_ptr++; /* Protect mark. */
84902520 2494 if (flags & 8) {
3280af22
NIS		 2495 PL_retstack_ix++;
2496 PL_retstack[PL_retstack_ix] = NULL;
84902520
TB		 2497 }
2498 if (flags & 16)
3280af22 2499 PL_scopestack_ix += 1;
84902520 2500 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2501 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
84902520 2502 || SvTYPE(cv) != SVt_PVCV)
22c35a8c 2503 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
84902520 2504
a0d0e21e 2505 if (!cv || !CvROOT(cv)) {
599cee73 2506 if (ckWARN(WARN_SIGNAL))
9014280d 2507 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2508 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS		 2509 : ((cv && CvGV(cv))
2510 ? GvENAME(CvGV(cv))
2511 : "__ANON__")));
2512 goto cleanup;
79072805
LW		 2513 }
2514
22c35a8c
GS		 2515 if(PL_psig_name[sig]) {
2516 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520 2517 flags |= 64;
df3728a2 2518#if !defined(PERL_IMPLICIT_CONTEXT)
84902520 2519 sig_sv = sv;
df3728a2 2520#endif
84902520 2521 } else {
ff0cee69 2522 sv = sv_newmortal();
22c35a8c 2523 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2524 }
e336de0d 2525
e788e7d3 2526 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2527 PUSHMARK(SP);
79072805 2528 PUSHs(sv);
79072805 2529 PUTBACK;
a0d0e21e 2530
1b266415 2531 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2532
d3acc0f7 2533 POPSTACK;
1b266415 2534 if (SvTRUE(ERRSV)) {
1d615522 2535#ifndef PERL_MICRO
983dbef6 2536#ifdef HAS_SIGPROCMASK
1b266415
NIS		 2537 /* Handler "died", for example to get out of a restart-able read().
2538 * Before we re-do that on its behalf re-enable the signal which was
2539 * blocked by the system when we entered.
2540 */
2541 sigset_t set;
2542 sigemptyset(&set);
2543 sigaddset(&set,sig);
2544 sigprocmask(SIG_UNBLOCK, &set, NULL);
2545#else
2546 /* Not clear if this will work */
2547 (void)rsignal(sig, SIG_IGN);
0a8e0eff 2548 (void)rsignal(sig, &Perl_csighandler);
1b266415 2549#endif
1d615522 2550#endif /* !PERL_MICRO */
b3fe4827 2551 Perl_die(aTHX_ Nullformat);
1b266415 2552 }
00d579c5 2553cleanup:
84902520 2554 if (flags & 1)
3280af22 2555 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2556 if (flags & 4)
3280af22 2557 PL_markstack_ptr--;
ac27b0f5 2558 if (flags & 8)
3280af22 2559 PL_retstack_ix--;
84902520 2560 if (flags & 16)
3280af22 2561 PL_scopestack_ix -= 1;
84902520
TB		 2562 if (flags & 64)
2563 SvREFCNT_dec(sv);
533c011a 2564 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2565
3280af22
NIS		 2566 PL_Sv = tSv; /* Restore global temporaries. */
2567 PL_Xpv = tXpv;
79072805
LW		 2568 return;
2569}
4e35701f
NIS		 2570
2571
51371543 2572static void
acfe0abc 2573restore_magic(pTHX_ void *p)
51371543 2574{
48944bdf 2575 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
51371543
GS		 2576 SV* sv = mgs->mgs_sv;
2577
2578 if (!sv)
2579 return;
2580
2581 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2582 {
2583 if (mgs->mgs_flags)
2584 SvFLAGS(sv) |= mgs->mgs_flags;
2585 else
2586 mg_magical(sv);
2587 if (SvGMAGICAL(sv))
2588 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2589 }
2590
2591 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2592
2593 /* If we're still on top of the stack, pop us off. (That condition
2594 * will be satisfied if restore_magic was called explicitly, but *not*
2595 * if it's being called via leave_scope.)
2596 * The reason for doing this is that otherwise, things like sv_2cv()
2597 * may leave alloc gunk on the savestack, and some code
2598 * (e.g. sighandler) doesn't expect that...
2599 */
2600 if (PL_savestack_ix == mgs->mgs_ss_ix)
2601 {
2602 I32 popval = SSPOPINT;
c76ac1ee 2603 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS		 2604 PL_savestack_ix -= 2;
2605 popval = SSPOPINT;
2606 assert(popval == SAVEt_ALLOC);
2607 popval = SSPOPINT;
2608 PL_savestack_ix -= popval;
2609 }
2610
2611}
2612
2613static void
acfe0abc 2614unwind_handler_stack(pTHX_ void *p)
51371543 2615{
51371543
GS		 2616 U32 flags = *(U32*)p;
2617
2618 if (flags & 1)
2619 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2620 /* cxstack_ix-- Not needed, die already unwound it. */
df3728a2 2621#if !defined(PERL_IMPLICIT_CONTEXT)
51371543
GS		 2622 if (flags & 64)
2623 SvREFCNT_dec(sig_sv);
df3728a2 2624#endif
51371543 2625}
1018e26f
NIS		 2626
2627
Unnamed repository; edit this file 'description' to name the repository.