This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[asperl] various tweaks
[perl5.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
9607fc9c 3 * Copyright (c) 1991-1997, 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
15#include "EXTERN.h"
16#include "perl.h"
17
e6d9441c 18/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW
19#ifdef I_UNISTD
20# include <unistd.h>
21#endif
a0d0e21e 22
5cd24f17 23#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
188ea221
CS
24# ifndef NGROUPS
25# define NGROUPS 32
26# endif
27#endif
28
c07a80fd
PP
29/*
30 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
31 */
32
76e3520e
GS
33#ifdef PERL_OBJECT
34static void UnwindHandler(void *pPerl, void *ptr)
35{
36 ((CPerlObj*)pPerl)->unwind_handler_stack(ptr);
37}
38
39static void RestoreMagic(void *pPerl, void *ptr)
40{
41 ((CPerlObj*)pPerl)->restore_magic(ptr);
42}
43#define UNWINDHANDLER UnwindHandler
44#define RESTOREMAGIC RestoreMagic
45#define VTBL this->*vtbl
46
47#else
c07a80fd
PP
48struct magic_state {
49 SV* mgs_sv;
50 U32 mgs_flags;
51};
52typedef struct magic_state MGS;
53
54static void restore_magic _((void *p));
76e3520e
GS
55#define UNWINDHANDLER unwind_handler_stack
56#define RESTOREMAGIC restore_magic
57#define VTBL *vtbl
c07a80fd 58
76e3520e
GS
59#endif
60
61STATIC void
8ac85365 62save_magic(MGS *mgs, SV *sv)
c07a80fd 63{
c07a80fd
PP
64 assert(SvMAGICAL(sv));
65
c07a80fd
PP
66 mgs->mgs_sv = sv;
67 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
76e3520e 68 SAVEDESTRUCTOR(RESTOREMAGIC, mgs);
c07a80fd
PP
69
70 SvMAGICAL_off(sv);
71 SvREADONLY_off(sv);
72 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
c07a80fd
PP
73}
74
76e3520e 75STATIC void
8ac85365 76restore_magic(void *p)
c07a80fd 77{
48e43a1c 78 MGS* mgs = (MGS*)p;
c07a80fd
PP
79 SV* sv = mgs->mgs_sv;
80
81 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
82 {
83 if (mgs->mgs_flags)
84 SvFLAGS(sv) |= mgs->mgs_flags;
85 else
86 mg_magical(sv);
87 if (SvGMAGICAL(sv))
88 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
89 }
c07a80fd
PP
90}
91
8990e307 92void
8ac85365 93mg_magical(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) {
76e3520e 99 if ((vtbl->svt_get != NULL) && !(mg->mg_flags & MGf_GSKIP))
8990e307
LW
100 SvGMAGICAL_on(sv);
101 if (vtbl->svt_set)
102 SvSMAGICAL_on(sv);
76e3520e 103 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || (vtbl->svt_clear != NULL))
8990e307
LW
104 SvRMAGICAL_on(sv);
105 }
106 }
107}
108
79072805 109int
8ac85365 110mg_get(SV *sv)
79072805 111{
48e43a1c 112 MGS mgs;
79072805 113 MAGIC* mg;
c6496cc7 114 MAGIC** mgp;
760ac839 115 int mgp_valid = 0;
463ee0b2 116
c07a80fd 117 ENTER;
48e43a1c 118 save_magic(&mgs, sv);
463ee0b2 119
c6496cc7
PP
120 mgp = &SvMAGIC(sv);
121 while ((mg = *mgp) != 0) {
79072805 122 MGVTBL* vtbl = mg->mg_virtual;
76e3520e
GS
123 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && (vtbl->svt_get != NULL)) {
124 (VTBL->svt_get)(sv, mg);
c6496cc7 125 /* Ignore this magic if it's been deleted */
48e43a1c
CS
126 if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) &&
127 (mg->mg_flags & MGf_GSKIP))
128 mgs.mgs_flags = 0;
a0d0e21e 129 }
c6496cc7 130 /* Advance to next magic (complicated by possible deletion) */
760ac839 131 if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) {
c6496cc7 132 mgp = &mg->mg_moremagic;
760ac839
LW
133 mgp_valid = 1;
134 }
135 else
136 mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
79072805 137 }
463ee0b2 138
c07a80fd 139 LEAVE;
79072805
LW
140 return 0;
141}
142
143int
8ac85365 144mg_set(SV *sv)
79072805 145{
48e43a1c 146 MGS mgs;
79072805 147 MAGIC* mg;
463ee0b2
LW
148 MAGIC* nextmg;
149
c07a80fd 150 ENTER;
48e43a1c 151 save_magic(&mgs, sv);
463ee0b2
LW
152
153 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
79072805 154 MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 155 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e
LW
156 if (mg->mg_flags & MGf_GSKIP) {
157 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
48e43a1c 158 mgs.mgs_flags = 0;
a0d0e21e 159 }
76e3520e
GS
160 if (vtbl && (vtbl->svt_set != NULL))
161 (VTBL->svt_set)(sv, mg);
79072805 162 }
463ee0b2 163
c07a80fd 164 LEAVE;
79072805
LW
165 return 0;
166}
167
168U32
8ac85365 169mg_len(SV *sv)
79072805
LW
170{
171 MAGIC* mg;
748a9306 172 char *junk;
463ee0b2 173 STRLEN len;
463ee0b2 174
79072805
LW
175 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
176 MGVTBL* vtbl = mg->mg_virtual;
76e3520e 177 if (vtbl && (vtbl->svt_len != NULL)) {
48e43a1c
CS
178 MGS mgs;
179
c07a80fd 180 ENTER;
48e43a1c 181 save_magic(&mgs, sv);
a0d0e21e 182 /* omit MGf_GSKIP -- not changed here */
76e3520e 183 len = (VTBL->svt_len)(sv, mg);
c07a80fd 184 LEAVE;
85e6fe83
LW
185 return len;
186 }
187 }
188
748a9306 189 junk = SvPV(sv, len);
463ee0b2 190 return len;
79072805
LW
191}
192
93965878
NIS
193I32
194mg_size(SV *sv)
195{
196 MAGIC* mg;
197 I32 len;
198
199 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
200 MGVTBL* vtbl = mg->mg_virtual;
201 if (vtbl && vtbl->svt_len) {
202 MGS mgs;
203 ENTER;
204 /* omit MGf_GSKIP -- not changed here */
205 len = (*vtbl->svt_len)(sv, mg);
206 LEAVE;
207 return len;
208 }
209 }
210
211 switch(SvTYPE(sv)) {
212 case SVt_PVAV:
213 len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
214 return len;
215 case SVt_PVHV:
216 /* FIXME */
217 default:
218 croak("Size magic not implemented");
219 break;
220 }
221 return 0;
222}
223
79072805 224int
8ac85365 225mg_clear(SV *sv)
79072805 226{
48e43a1c 227 MGS mgs;
79072805 228 MAGIC* mg;
463ee0b2 229
c07a80fd 230 ENTER;
48e43a1c 231 save_magic(&mgs, sv);
463ee0b2 232
79072805
LW
233 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
234 MGVTBL* vtbl = mg->mg_virtual;
a0d0e21e
LW
235 /* omit GSKIP -- never set here */
236
76e3520e
GS
237 if (vtbl && (vtbl->svt_clear != NULL))
238 (VTBL->svt_clear)(sv, mg);
79072805 239 }
463ee0b2 240
c07a80fd 241 LEAVE;
79072805
LW
242 return 0;
243}
244
93a17b20 245MAGIC*
8ac85365 246mg_find(SV *sv, int type)
93a17b20
LW
247{
248 MAGIC* mg;
93a17b20
LW
249 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
250 if (mg->mg_type == type)
251 return mg;
252 }
253 return 0;
254}
255
79072805 256int
8ac85365 257mg_copy(SV *sv, SV *nsv, char *key, I32 klen)
79072805 258{
463ee0b2 259 int count = 0;
79072805 260 MAGIC* mg;
463ee0b2
LW
261 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
262 if (isUPPER(mg->mg_type)) {
a0d0e21e 263 sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen);
463ee0b2 264 count++;
79072805 265 }
79072805 266 }
463ee0b2 267 return count;
79072805
LW
268}
269
270int
8ac85365 271mg_free(SV *sv)
79072805
LW
272{
273 MAGIC* mg;
274 MAGIC* moremagic;
275 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
276 MGVTBL* vtbl = mg->mg_virtual;
277 moremagic = mg->mg_moremagic;
76e3520e
GS
278 if (vtbl && (vtbl->svt_free != NULL))
279 (VTBL->svt_free)(sv, mg);
93a17b20 280 if (mg->mg_ptr && mg->mg_type != 'g')
76e3520e 281 if (mg->mg_length >= 0)
88e89b8a 282 Safefree(mg->mg_ptr);
76e3520e 283 else if (mg->mg_length == HEf_SVKEY)
88e89b8a 284 SvREFCNT_dec((SV*)mg->mg_ptr);
85e6fe83 285 if (mg->mg_flags & MGf_REFCOUNTED)
8990e307 286 SvREFCNT_dec(mg->mg_obj);
79072805
LW
287 Safefree(mg);
288 }
289 SvMAGIC(sv) = 0;
290 return 0;
291}
292
293#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
294#include <signal.h>
295#endif
296
93a17b20 297U32
8ac85365 298magic_len(SV *sv, MAGIC *mg)
93a17b20 299{
a863c7d1 300 dTHR;
93a17b20
LW
301 register I32 paren;
302 register char *s;
303 register I32 i;
bbce6d69 304 register REGEXP *rx;
748a9306 305 char *t;
93a17b20
LW
306
307 switch (*mg->mg_ptr) {
308 case '1': case '2': case '3': case '4':
309 case '5': case '6': case '7': case '8': case '9': case '&':
bbce6d69 310 if (curpm && (rx = curpm->op_pmregexp)) {
93a17b20
LW
311 paren = atoi(mg->mg_ptr);
312 getparen:
bbce6d69
PP
313 if (paren <= rx->nparens &&
314 (s = rx->startp[paren]) &&
315 (t = rx->endp[paren]))
316 {
748a9306 317 i = t - s;
71be2cbc 318 if (i >= 0)
93a17b20 319 return i;
93a17b20 320 }
93a17b20 321 }
748a9306 322 return 0;
93a17b20 323 case '+':
bbce6d69
PP
324 if (curpm && (rx = curpm->op_pmregexp)) {
325 paren = rx->lastparen;
13f57bf8
CS
326 if (paren)
327 goto getparen;
93a17b20 328 }
748a9306 329 return 0;
93a17b20 330 case '`':
bbce6d69 331 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8 332 if ((s = rx->subbeg) && rx->startp[0]) {
bbce6d69 333 i = rx->startp[0] - s;
71be2cbc 334 if (i >= 0)
93a17b20 335 return i;
93a17b20 336 }
93a17b20 337 }
748a9306 338 return 0;
93a17b20 339 case '\'':
bbce6d69 340 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8
CS
341 if (rx->subend && (s = rx->endp[0])) {
342 i = rx->subend - s;
343 if (i >= 0)
5cd24f17 344 return i;
93a17b20 345 }
93a17b20 346 }
748a9306 347 return 0;
93a17b20
LW
348 case ',':
349 return (STRLEN)ofslen;
350 case '\\':
351 return (STRLEN)orslen;
352 }
353 magic_get(sv,mg);
354 if (!SvPOK(sv) && SvNIOK(sv))
463ee0b2 355 sv_2pv(sv, &na);
93a17b20
LW
356 if (SvPOK(sv))
357 return SvCUR(sv);
358 return 0;
359}
360
79072805 361int
8ac85365 362magic_get(SV *sv, MAGIC *mg)
79072805 363{
a863c7d1 364 dTHR;
79072805
LW
365 register I32 paren;
366 register char *s;
367 register I32 i;
bbce6d69 368 register REGEXP *rx;
748a9306 369 char *t;
79072805
LW
370
371 switch (*mg->mg_ptr) {
748a9306
LW
372 case '\001': /* ^A */
373 sv_setsv(sv, bodytarget);
374 break;
79072805 375 case '\004': /* ^D */
188ea221 376 sv_setiv(sv, (IV)(debug & 32767));
79072805 377 break;
28f23441
PP
378 case '\005': /* ^E */
379#ifdef VMS
380 {
381# include <descrip.h>
382# include <starlet.h>
383 char msg[255];
384 $DESCRIPTOR(msgdsc,msg);
946ec16e 385 sv_setnv(sv,(double) vaxc$errno);
28f23441
PP
386 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
387 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
388 else
389 sv_setpv(sv,"");
390 }
391#else
88e89b8a 392#ifdef OS2
fb73857a
PP
393 if (!(_emx_env & 0x200)) { /* Under DOS */
394 sv_setnv(sv, (double)errno);
395 sv_setpv(sv, errno ? Strerror(errno) : "");
396 } else {
397 if (errno != errno_isOS2)
398 Perl_rc = _syserrno();
399 sv_setnv(sv, (double)Perl_rc);
400 sv_setpv(sv, os2error(Perl_rc));
401 }
88e89b8a 402#else
22fae026
TM
403#ifdef WIN32
404 {
405 DWORD dwErr = GetLastError();
406 sv_setnv(sv, (double)dwErr);
407 if (dwErr)
76e3520e
GS
408 {
409#ifdef PERL_OBJECT
410 char *sMsg;
411 DWORD dwLen;
412 PerlProc_GetSysMsg(sMsg, dwLen, dwErr);
413 sv_setpvn(sv, sMsg, dwLen);
414 PerlProc_FreeBuf(sMsg);
415#else
22fae026 416 win32_str_os_error(sv, dwErr);
76e3520e
GS
417#endif
418 }
22fae026
TM
419 else
420 sv_setpv(sv, "");
421 SetLastError(dwErr);
422 }
423#else
946ec16e 424 sv_setnv(sv, (double)errno);
28f23441
PP
425 sv_setpv(sv, errno ? Strerror(errno) : "");
426#endif
88e89b8a 427#endif
22fae026 428#endif
946ec16e 429 SvNOK_on(sv); /* what a wonderful hack! */
28f23441 430 break;
79072805 431 case '\006': /* ^F */
188ea221 432 sv_setiv(sv, (IV)maxsysfd);
79072805 433 break;
a0d0e21e 434 case '\010': /* ^H */
188ea221 435 sv_setiv(sv, (IV)hints);
a0d0e21e 436 break;
79072805
LW
437 case '\t': /* ^I */
438 if (inplace)
439 sv_setpv(sv, inplace);
440 else
188ea221 441 sv_setsv(sv, &sv_undef);
79072805 442 break;
28f23441 443 case '\017': /* ^O */
188ea221 444 sv_setpv(sv, osname);
28f23441 445 break;
79072805 446 case '\020': /* ^P */
188ea221 447 sv_setiv(sv, (IV)perldb);
79072805 448 break;
fb73857a 449 case '\023': /* ^S */
d58bf5aa
MB
450 {
451 dTHR;
452 if (lex_state != LEX_NOTPARSING)
453 SvOK_off(sv);
454 else if (in_eval)
455 sv_setiv(sv, 1);
456 else
457 sv_setiv(sv, 0);
458 }
fb73857a 459 break;
79072805 460 case '\024': /* ^T */
88e89b8a 461#ifdef BIG_TIME
188ea221 462 sv_setnv(sv, basetime);
88e89b8a 463#else
188ea221 464 sv_setiv(sv, (IV)basetime);
88e89b8a 465#endif
79072805
LW
466 break;
467 case '\027': /* ^W */
188ea221 468 sv_setiv(sv, (IV)dowarn);
79072805
LW
469 break;
470 case '1': case '2': case '3': case '4':
471 case '5': case '6': case '7': case '8': case '9': case '&':
bbce6d69 472 if (curpm && (rx = curpm->op_pmregexp)) {
a863c7d1
MB
473 /*
474 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
475 * XXX Does the new way break anything?
476 */
477 paren = atoi(mg->mg_ptr);
79072805 478 getparen:
bbce6d69
PP
479 if (paren <= rx->nparens &&
480 (s = rx->startp[paren]) &&
481 (t = rx->endp[paren]))
482 {
748a9306 483 i = t - s;
13f57bf8 484 getrx:
748a9306 485 if (i >= 0) {
13f57bf8
CS
486 bool was_tainted;
487 if (tainting) {
488 was_tainted = tainted;
489 tainted = FALSE;
490 }
79072805 491 sv_setpvn(sv,s,i);
13f57bf8 492 if (tainting)
c277df42 493 tainted = was_tainted || RX_MATCH_TAINTED(rx);
748a9306
LW
494 break;
495 }
79072805 496 }
79072805 497 }
748a9306 498 sv_setsv(sv,&sv_undef);
79072805
LW
499 break;
500 case '+':
bbce6d69
PP
501 if (curpm && (rx = curpm->op_pmregexp)) {
502 paren = rx->lastparen;
a0d0e21e
LW
503 if (paren)
504 goto getparen;
79072805 505 }
748a9306 506 sv_setsv(sv,&sv_undef);
79072805
LW
507 break;
508 case '`':
bbce6d69 509 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8 510 if ((s = rx->subbeg) && rx->startp[0]) {
bbce6d69 511 i = rx->startp[0] - s;
13f57bf8 512 goto getrx;
79072805 513 }
79072805 514 }
748a9306 515 sv_setsv(sv,&sv_undef);
79072805
LW
516 break;
517 case '\'':
bbce6d69 518 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8
CS
519 if (rx->subend && (s = rx->endp[0])) {
520 i = rx->subend - s;
521 goto getrx;
79072805 522 }
79072805 523 }
748a9306 524 sv_setsv(sv,&sv_undef);
79072805
LW
525 break;
526 case '.':
527#ifndef lint
a0d0e21e 528 if (GvIO(last_in_gv)) {
188ea221 529 sv_setiv(sv, (IV)IoLINES(GvIO(last_in_gv)));
79072805
LW
530 }
531#endif
532 break;
533 case '?':
809a5acc
MB
534 {
535 dTHR;
536 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 537#ifdef COMPLEX_STATUS
809a5acc
MB
538 LvTARGOFF(sv) = statusvalue;
539 LvTARGLEN(sv) = statusvalue_vms;
ff0cee69 540#endif
809a5acc 541 }
79072805
LW
542 break;
543 case '^':
a0d0e21e 544 s = IoTOP_NAME(GvIOp(defoutgv));
79072805
LW
545 if (s)
546 sv_setpv(sv,s);
547 else {
548 sv_setpv(sv,GvENAME(defoutgv));
549 sv_catpv(sv,"_TOP");
550 }
551 break;
552 case '~':
a0d0e21e 553 s = IoFMT_NAME(GvIOp(defoutgv));
79072805
LW
554 if (!s)
555 s = GvENAME(defoutgv);
556 sv_setpv(sv,s);
557 break;
558#ifndef lint
559 case '=':
188ea221 560 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(defoutgv)));
79072805
LW
561 break;
562 case '-':
188ea221 563 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(defoutgv)));
79072805
LW
564 break;
565 case '%':
188ea221 566 sv_setiv(sv, (IV)IoPAGE(GvIOp(defoutgv)));
79072805
LW
567 break;
568#endif
569 case ':':
570 break;
571 case '/':
572 break;
573 case '[':
0f15f207 574 WITH_THR(sv_setiv(sv, (IV)curcop->cop_arybase));
79072805
LW
575 break;
576 case '|':
188ea221 577 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
578 break;
579 case ',':
580 sv_setpvn(sv,ofs,ofslen);
581 break;
582 case '\\':
583 sv_setpvn(sv,ors,orslen);
584 break;
585 case '#':
586 sv_setpv(sv,ofmt);
587 break;
588 case '!':
a5f75d66 589#ifdef VMS
946ec16e 590 sv_setnv(sv, (double)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 591 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 592#else
88e89b8a
PP
593 {
594 int saveerrno = errno;
946ec16e 595 sv_setnv(sv, (double)errno);
88e89b8a
PP
596#ifdef OS2
597 if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
598 else
a5f75d66 599#endif
2304df62 600 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
601 errno = saveerrno;
602 }
603#endif
946ec16e 604 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
605 break;
606 case '<':
188ea221 607 sv_setiv(sv, (IV)uid);
79072805
LW
608 break;
609 case '>':
188ea221 610 sv_setiv(sv, (IV)euid);
79072805
LW
611 break;
612 case '(':
188ea221 613 sv_setiv(sv, (IV)gid);
fc36a67e 614 sv_setpvf(sv, "%Vd", (IV)gid);
79072805
LW
615 goto add_groups;
616 case ')':
188ea221 617 sv_setiv(sv, (IV)egid);
fc36a67e 618 sv_setpvf(sv, "%Vd", (IV)egid);
79072805 619 add_groups:
79072805 620#ifdef HAS_GETGROUPS
79072805 621 {
a0d0e21e 622 Groups_t gary[NGROUPS];
79072805 623 i = getgroups(NGROUPS,gary);
46fc3d4c 624 while (--i >= 0)
fc36a67e 625 sv_catpvf(sv, " %Vd", (IV)gary[i]);
79072805
LW
626 }
627#endif
29355cf7 628 SvIOK_on(sv); /* what a wonderful hack! */
79072805
LW
629 break;
630 case '*':
631 break;
632 case '0':
633 break;
a863c7d1
MB
634#ifdef USE_THREADS
635 case '@':
38a03e6e 636 sv_setsv(sv, thr->errsv);
a863c7d1
MB
637 break;
638#endif /* USE_THREADS */
79072805 639 }
a0d0e21e 640 return 0;
79072805
LW
641}
642
643int
8ac85365 644magic_getuvar(SV *sv, MAGIC *mg)
79072805
LW
645{
646 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
647
648 if (uf && uf->uf_val)
649 (*uf->uf_val)(uf->uf_index, sv);
650 return 0;
651}
652
653int
8ac85365 654magic_setenv(SV *sv, MAGIC *mg)
79072805
LW
655{
656 register char *s;
88e89b8a 657 char *ptr;
5aabfad6 658 STRLEN len, klen;
a0d0e21e 659 I32 i;
1e422769 660
a0d0e21e 661 s = SvPV(sv,len);
5aabfad6 662 ptr = MgPV(mg,klen);
88e89b8a 663 my_setenv(ptr, s);
1e422769 664
a0d0e21e
LW
665#ifdef DYNAMIC_ENV_FETCH
666 /* We just undefd an environment var. Is a replacement */
667 /* waiting in the wings? */
668 if (!len) {
5aabfad6
PP
669 SV **valp;
670 if ((valp = hv_fetch(GvHVn(envgv), ptr, klen, FALSE)))
671 s = SvPV(*valp, len);
a0d0e21e
LW
672 }
673#endif
1e422769 674
39e571d4 675#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
676 /* And you'll never guess what the dog had */
677 /* in its mouth... */
463ee0b2 678 if (tainting) {
1e422769
PP
679 MgTAINTEDDIR_off(mg);
680#ifdef VMS
5aabfad6 681 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1e422769
PP
682 char pathbuf[256], eltbuf[256], *cp, *elt = s;
683 struct stat sbuf;
684 int i = 0, j = 0;
685
686 do { /* DCL$PATH may be a search list */
687 while (1) { /* as may dev portion of any element */
688 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
689 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
690 cando_by_name(S_IWUSR,0,elt) ) {
691 MgTAINTEDDIR_on(mg);
692 return 0;
693 }
694 }
695 if ((cp = strchr(elt, ':')) != Nullch)
696 *cp = '\0';
697 if (my_trnlnm(elt, eltbuf, j++))
698 elt = eltbuf;
699 else
700 break;
701 }
702 j = 0;
703 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
704 }
705#endif /* VMS */
5aabfad6 706 if (s && klen == 4 && strEQ(ptr,"PATH")) {
a0d0e21e 707 char *strend = s + len;
463ee0b2
LW
708
709 while (s < strend) {
96827780 710 char tmpbuf[256];
1e422769 711 struct stat st;
96827780 712 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 713 s, strend, ':', &i);
463ee0b2 714 s++;
96827780
MB
715 if (i >= sizeof tmpbuf /* too long -- assume the worst */
716 || *tmpbuf != '/'
717 || (Stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 718 MgTAINTEDDIR_on(mg);
1e422769
PP
719 return 0;
720 }
463ee0b2 721 }
79072805
LW
722 }
723 }
39e571d4 724#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 725
79072805
LW
726 return 0;
727}
728
729int
8ac85365 730magic_clearenv(SV *sv, MAGIC *mg)
85e6fe83 731{
5aabfad6 732 my_setenv(MgPV(mg,na),Nullch);
85e6fe83
LW
733 return 0;
734}
735
88e89b8a 736int
8ac85365 737magic_set_all_env(SV *sv, MAGIC *mg)
fb73857a
PP
738{
739#if defined(VMS)
740 die("Can't make list assignment to %%ENV on this system");
741#else
d58bf5aa 742 dTHR;
fb73857a
PP
743 if (localizing) {
744 HE* entry;
745 magic_clear_all_env(sv,mg);
746 hv_iterinit((HV*)sv);
747 while (entry = hv_iternext((HV*)sv)) {
748 I32 keylen;
749 my_setenv(hv_iterkey(entry, &keylen),
750 SvPV(hv_iterval((HV*)sv, entry), na));
751 }
752 }
753#endif
754 return 0;
755}
756
757int
8ac85365 758magic_clear_all_env(SV *sv, MAGIC *mg)
66b1d557 759{
3e3baf6d
TB
760#if defined(VMS)
761 die("Can't make list assignment to %%ENV on this system");
762#else
763#ifdef WIN32
764 char *envv = GetEnvironmentStrings();
765 char *cur = envv;
766 STRLEN len;
767 while (*cur) {
768 char *end = strchr(cur,'=');
769 if (end && end != cur) {
770 *end = '\0';
771 my_setenv(cur,Nullch);
772 *end = '=';
773 cur += strlen(end+1)+1;
774 }
775 else if ((len = strlen(cur)))
776 cur += len+1;
777 }
778 FreeEnvironmentStrings(envv);
66b1d557
HM
779#else
780 I32 i;
781
782 if (environ == origenviron)
783 New(901, environ, 1, char*);
784 else
785 for (i = 0; environ[i]; i++)
786 Safefree(environ[i]);
787 environ[0] = Nullch;
788
66b1d557 789#endif
3e3baf6d
TB
790#endif
791 return 0;
66b1d557
HM
792}
793
794int
8ac85365 795magic_getsig(SV *sv, MAGIC *mg)
88e89b8a
PP
796{
797 I32 i;
798 /* Are we fetching a signal entry? */
5aabfad6 799 i = whichsig(MgPV(mg,na));
88e89b8a
PP
800 if (i) {
801 if(psig_ptr[i])
802 sv_setsv(sv,psig_ptr[i]);
803 else {
ff68c719
PP
804 Sighandler_t sigstate = rsignal_state(i);
805
88e89b8a 806 /* cache state so we don't fetch it again */
ff68c719 807 if(sigstate == SIG_IGN)
88e89b8a
PP
808 sv_setpv(sv,"IGNORE");
809 else
810 sv_setsv(sv,&sv_undef);
811 psig_ptr[i] = SvREFCNT_inc(sv);
812 SvTEMP_off(sv);
813 }
814 }
815 return 0;
816}
817int
8ac85365 818magic_clearsig(SV *sv, MAGIC *mg)
88e89b8a
PP
819{
820 I32 i;
821 /* Are we clearing a signal entry? */
5aabfad6 822 i = whichsig(MgPV(mg,na));
88e89b8a
PP
823 if (i) {
824 if(psig_ptr[i]) {
825 SvREFCNT_dec(psig_ptr[i]);
826 psig_ptr[i]=0;
827 }
828 if(psig_name[i]) {
829 SvREFCNT_dec(psig_name[i]);
830 psig_name[i]=0;
831 }
832 }
833 return 0;
834}
3d37d572 835
85e6fe83 836int
8ac85365 837magic_setsig(SV *sv, MAGIC *mg)
79072805 838{
11343788 839 dTHR;
79072805
LW
840 register char *s;
841 I32 i;
748a9306 842 SV** svp;
a0d0e21e 843
5aabfad6 844 s = MgPV(mg,na);
748a9306
LW
845 if (*s == '_') {
846 if (strEQ(s,"__DIE__"))
847 svp = &diehook;
848 else if (strEQ(s,"__WARN__"))
849 svp = &warnhook;
850 else if (strEQ(s,"__PARSE__"))
851 svp = &parsehook;
852 else
853 croak("No such hook: %s", s);
854 i = 0;
4633a7c4
LW
855 if (*svp) {
856 SvREFCNT_dec(*svp);
857 *svp = 0;
858 }
748a9306
LW
859 }
860 else {
861 i = whichsig(s); /* ...no, a brick */
862 if (!i) {
863 if (dowarn || strEQ(s,"ALARM"))
864 warn("No such signal: SIG%s", s);
865 return 0;
866 }
ff0cee69
PP
867 SvREFCNT_dec(psig_name[i]);
868 SvREFCNT_dec(psig_ptr[i]);
88e89b8a 869 psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 870 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
ff0cee69 871 psig_name[i] = newSVpv(s, strlen(s));
88e89b8a 872 SvREADONLY_on(psig_name[i]);
748a9306 873 }
a0d0e21e 874 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
748a9306 875 if (i)
c23142e2 876 (void)rsignal(i, sighandlerp);
748a9306
LW
877 else
878 *svp = SvREFCNT_inc(sv);
a0d0e21e
LW
879 return 0;
880 }
881 s = SvPV_force(sv,na);
748a9306
LW
882 if (strEQ(s,"IGNORE")) {
883 if (i)
ff68c719 884 (void)rsignal(i, SIG_IGN);
748a9306
LW
885 else
886 *svp = 0;
887 }
888 else if (strEQ(s,"DEFAULT") || !*s) {
889 if (i)
ff68c719 890 (void)rsignal(i, SIG_DFL);
748a9306
LW
891 else
892 *svp = 0;
893 }
79072805 894 else {
5aabfad6
PP
895 /*
896 * We should warn if HINT_STRICT_REFS, but without
897 * access to a known hint bit in a known OP, we can't
898 * tell whether HINT_STRICT_REFS is in force or not.
899 */
46fc3d4c
PP
900 if (!strchr(s,':') && !strchr(s,'\''))
901 sv_setpv(sv, form("main::%s", s));
748a9306 902 if (i)
c23142e2 903 (void)rsignal(i, sighandlerp);
748a9306
LW
904 else
905 *svp = SvREFCNT_inc(sv);
79072805
LW
906 }
907 return 0;
908}
909
910int
8ac85365 911magic_setisa(SV *sv, MAGIC *mg)
79072805 912{
a0231f0e
MB
913 HV *stash;
914 SV **svp;
915 I32 fill;
916 HV *basefields = Nullhv;
917 GV **gvp;
918 GV *gv;
919 HE *he;
920 static char *FIELDS = "FIELDS";
921
463ee0b2 922 sub_generation++;
a0231f0e
MB
923
924 if (mg->mg_type == 'i')
925 return 0; /* Ignore lower-case version of the magic */
926
927 stash = GvSTASH(mg->mg_obj);
928 svp = AvARRAY((AV*)sv);
93965878
NIS
929
930 /* NOTE: No support for tied ISA */
931 for (fill = AvFILLp((AV*)sv); fill >= 0; fill--, svp++) {
a0231f0e
MB
932 HV *basestash = gv_stashsv(*svp, FALSE);
933
934 if (!basestash) {
935 if (dowarn)
936 warn("No such package \"%_\" in @ISA assignment", *svp);
937 continue;
938 }
939 gvp = (GV**)hv_fetch(basestash, FIELDS, 6, FALSE);
940 if (gvp && *gvp && GvHV(*gvp)) {
941 if (basefields)
942 croak("Can't multiply inherit %%FIELDS");
943 basefields = GvHV(*gvp);
944 }
945 }
946
947 if (!basefields)
948 return 0;
949
950 gv = (GV*)*hv_fetch(stash, FIELDS, 6, TRUE);
951 if (!isGV(gv))
952 gv_init(gv, stash, FIELDS, 6, TRUE);
953 if (!GvHV(gv))
954 GvHV(gv) = newHV();
955 if (HvKEYS(GvHV(gv)))
956 croak("Inherited %%FIELDS can't override existing %%FIELDS");
957
958 hv_iterinit(GvHV(gv));
959 while ((he = hv_iternext(basefields)))
960 hv_store(GvHV(gv), HeKEY(he), HeKLEN(he), HeVAL(he), HeHASH(he));
961
463ee0b2
LW
962 return 0;
963}
964
a0d0e21e
LW
965#ifdef OVERLOAD
966
463ee0b2 967int
8ac85365 968magic_setamagic(SV *sv, MAGIC *mg)
463ee0b2 969{
a0d0e21e
LW
970 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
971 amagic_generation++;
463ee0b2 972
a0d0e21e
LW
973 return 0;
974}
975#endif /* OVERLOAD */
463ee0b2 976
946ec16e 977int
8ac85365 978magic_setnkeys(SV *sv, MAGIC *mg)
946ec16e
PP
979{
980 if (LvTARG(sv)) {
981 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
982 LvTARG(sv) = Nullsv; /* Don't allow a ref to reassign this. */
983 }
984 return 0;
93965878 985}
946ec16e 986
a0d0e21e 987static int
93965878 988magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW
989{
990 dSP;
463ee0b2 991
a0d0e21e 992 PUSHMARK(sp);
93965878 993 EXTEND(sp, n);
a0d0e21e 994 PUSHs(mg->mg_obj);
93965878
NIS
995 if (n > 1) {
996 if (mg->mg_ptr) {
6b6eec5b
GS
997 if (mg->mg_length >= 0)
998 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_length)));
999 else if (mg->mg_length == HEf_SVKEY)
93965878
NIS
1000 PUSHs((SV*)mg->mg_ptr);
1001 }
1002 else if (mg->mg_type == 'p') {
6b6eec5b 1003 PUSHs(sv_2mortal(newSViv(mg->mg_length)));
93965878
NIS
1004 }
1005 }
1006 if (n > 2) {
1007 PUSHs(val);
88e89b8a 1008 }
463ee0b2
LW
1009 PUTBACK;
1010
93965878 1011 return perl_call_method(meth, flags);
946ec16e
PP
1012}
1013
76e3520e 1014STATIC int
8ac85365 1015magic_methpack(SV *sv, MAGIC *mg, char *meth)
a0d0e21e
LW
1016{
1017 dSP;
463ee0b2 1018
a0d0e21e
LW
1019 ENTER;
1020 SAVETMPS;
463ee0b2 1021
93965878 1022 if (magic_methcall(mg, meth, G_SCALAR, 2, NULL)) {
a0d0e21e 1023 sv_setsv(sv, *stack_sp--);
93965878 1024 }
463ee0b2 1025
a0d0e21e
LW
1026 FREETMPS;
1027 LEAVE;
1028 return 0;
1029}
463ee0b2 1030
a0d0e21e 1031int
8ac85365 1032magic_getpack(SV *sv, MAGIC *mg)
a0d0e21e
LW
1033{
1034 magic_methpack(sv,mg,"FETCH");
1035 if (mg->mg_ptr)
1036 mg->mg_flags |= MGf_GSKIP;
463ee0b2
LW
1037 return 0;
1038}
1039
1040int
8ac85365 1041magic_setpack(SV *sv, MAGIC *mg)
a60c0954
NIS
1042{
1043 ENTER;
93965878 1044 magic_methcall(mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
a60c0954 1045 LEAVE;
463ee0b2
LW
1046 return 0;
1047}
1048
1049int
8ac85365 1050magic_clearpack(SV *sv, MAGIC *mg)
463ee0b2 1051{
a0d0e21e
LW
1052 return magic_methpack(sv,mg,"DELETE");
1053}
463ee0b2 1054
93965878
NIS
1055
1056U32
1057magic_sizepack(SV *sv, MAGIC *mg)
1058{
1059 dTHR;
1060 U32 retval = 0;
1061
1062 ENTER;
1063 SAVETMPS;
1064 if (magic_methcall(mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1065 sv = *stack_sp--;
a60c0954 1066 retval = (U32) SvIV(sv)-1;
93965878
NIS
1067 }
1068 FREETMPS;
1069 LEAVE;
1070 return retval;
1071}
1072
8ac85365 1073int magic_wipepack(SV *sv, MAGIC *mg)
a0d0e21e
LW
1074{
1075 dSP;
463ee0b2 1076
a0d0e21e
LW
1077 PUSHMARK(sp);
1078 XPUSHs(mg->mg_obj);
463ee0b2 1079 PUTBACK;
a60c0954 1080 ENTER;
a0d0e21e 1081 perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
a60c0954 1082 LEAVE;
463ee0b2
LW
1083 return 0;
1084}
1085
1086int
8ac85365 1087magic_nextpack(SV *sv, MAGIC *mg, SV *key)
463ee0b2 1088{
463ee0b2 1089 dSP;
a0d0e21e 1090 char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1091
1092 ENTER;
a0d0e21e
LW
1093 SAVETMPS;
1094 PUSHMARK(sp);
1095 EXTEND(sp, 2);
1096 PUSHs(mg->mg_obj);
463ee0b2
LW
1097 if (SvOK(key))
1098 PUSHs(key);
1099 PUTBACK;
1100
a0d0e21e
LW
1101 if (perl_call_method(meth, G_SCALAR))
1102 sv_setsv(key, *stack_sp--);
463ee0b2 1103
a0d0e21e
LW
1104 FREETMPS;
1105 LEAVE;
79072805
LW
1106 return 0;
1107}
1108
1109int
8ac85365 1110magic_existspack(SV *sv, MAGIC *mg)
a0d0e21e
LW
1111{
1112 return magic_methpack(sv,mg,"EXISTS");
1113}
1114
1115int
8ac85365 1116magic_setdbline(SV *sv, MAGIC *mg)
79072805 1117{
11343788 1118 dTHR;
79072805
LW
1119 OP *o;
1120 I32 i;
1121 GV* gv;
1122 SV** svp;
1123
1124 gv = DBline;
1125 i = SvTRUE(sv);
188ea221 1126 svp = av_fetch(GvAV(gv),
5aabfad6 1127 atoi(MgPV(mg,na)), FALSE);
8990e307 1128 if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
93a17b20 1129 o->op_private = i;
79072805
LW
1130 else
1131 warn("Can't break at that line\n");
1132 return 0;
1133}
1134
1135int
8ac85365 1136magic_getarylen(SV *sv, MAGIC *mg)
79072805 1137{
0f15f207 1138 dTHR;
a0d0e21e 1139 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
79072805
LW
1140 return 0;
1141}
1142
1143int
8ac85365 1144magic_setarylen(SV *sv, MAGIC *mg)
79072805 1145{
0f15f207 1146 dTHR;
a0d0e21e
LW
1147 av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
1148 return 0;
1149}
1150
1151int
8ac85365 1152magic_getpos(SV *sv, MAGIC *mg)
a0d0e21e
LW
1153{
1154 SV* lsv = LvTARG(sv);
1155
1156 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1157 mg = mg_find(lsv, 'g');
76e3520e 1158 if (mg && mg->mg_length >= 0) {
0f15f207 1159 dTHR;
76e3520e 1160 sv_setiv(sv, mg->mg_length + curcop->cop_arybase);
a0d0e21e
LW
1161 return 0;
1162 }
1163 }
1164 (void)SvOK_off(sv);
1165 return 0;
1166}
1167
1168int
8ac85365 1169magic_setpos(SV *sv, MAGIC *mg)
a0d0e21e
LW
1170{
1171 SV* lsv = LvTARG(sv);
1172 SSize_t pos;
1173 STRLEN len;
1174
1175 mg = 0;
1176
1177 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1178 mg = mg_find(lsv, 'g');
1179 if (!mg) {
1180 if (!SvOK(sv))
1181 return 0;
1182 sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1183 mg = mg_find(lsv, 'g');
1184 }
1185 else if (!SvOK(sv)) {
76e3520e 1186 mg->mg_length = -1;
a0d0e21e
LW
1187 return 0;
1188 }
1189 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1190
0f15f207 1191 WITH_THR(pos = SvIV(sv) - curcop->cop_arybase);
a0d0e21e
LW
1192 if (pos < 0) {
1193 pos += len;
1194 if (pos < 0)
1195 pos = 0;
1196 }
1197 else if (pos > len)
1198 pos = len;
76e3520e 1199 mg->mg_length = pos;
71be2cbc 1200 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1201
79072805
LW
1202 return 0;
1203}
1204
1205int
8ac85365 1206magic_getglob(SV *sv, MAGIC *mg)
79072805 1207{
8646b087
PP
1208 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1209 SvFAKE_off(sv);
946ec16e 1210 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1211 SvFAKE_on(sv);
1212 }
1213 else
946ec16e 1214 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1215 return 0;
1216}
1217
1218int
8ac85365 1219magic_setglob(SV *sv, MAGIC *mg)
79072805
LW
1220{
1221 register char *s;
1222 GV* gv;
1223
1224 if (!SvOK(sv))
1225 return 0;
463ee0b2 1226 s = SvPV(sv, na);
79072805
LW
1227 if (*s == '*' && s[1])
1228 s++;
85e6fe83 1229 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
79072805
LW
1230 if (sv == (SV*)gv)
1231 return 0;
1232 if (GvGP(sv))
88e89b8a 1233 gp_free((GV*)sv);
79072805 1234 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1235 return 0;
1236}
1237
1238int
8ac85365 1239magic_setsubstr(SV *sv, MAGIC *mg)
79072805 1240{
8990e307
LW
1241 STRLEN len;
1242 char *tmps = SvPV(sv,len);
1243 sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
79072805
LW
1244 return 0;
1245}
1246
1247int
8ac85365 1248magic_gettaint(SV *sv, MAGIC *mg)
463ee0b2 1249{
a863c7d1 1250 dTHR;
76e3520e
GS
1251 TAINT_IF((mg->mg_length & 1) ||
1252 (mg->mg_length & 2) && mg->mg_obj == sv); /* kludge */
463ee0b2
LW
1253 return 0;
1254}
1255
1256int
8ac85365 1257magic_settaint(SV *sv, MAGIC *mg)
463ee0b2 1258{
11343788 1259 dTHR;
748a9306
LW
1260 if (localizing) {
1261 if (localizing == 1)
76e3520e 1262 mg->mg_length <<= 1;
748a9306 1263 else
76e3520e 1264 mg->mg_length >>= 1;
a0d0e21e 1265 }
748a9306 1266 else if (tainted)
76e3520e 1267 mg->mg_length |= 1;
748a9306 1268 else
76e3520e 1269 mg->mg_length &= ~1;
463ee0b2
LW
1270 return 0;
1271}
1272
1273int
8ac85365 1274magic_setvec(SV *sv, MAGIC *mg)
79072805
LW
1275{
1276 do_vecset(sv); /* XXX slurp this routine */
1277 return 0;
1278}
1279
1280int
8ac85365 1281magic_getdefelem(SV *sv, MAGIC *mg)
5f05dabc 1282{
71be2cbc 1283 SV *targ = Nullsv;
5f05dabc 1284 if (LvTARGLEN(sv)) {
68dc0745
PP
1285 if (mg->mg_obj) {
1286 HV* hv = (HV*)LvTARG(sv);
1287 HE* he = hv_fetch_ent(hv, mg->mg_obj, FALSE, 0);
1288 if (he)
1289 targ = HeVAL(he);
1290 }
1291 else {
93965878 1292 AV* av = (AV*)LvTARG(sv);
68dc0745
PP
1293 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1294 targ = AvARRAY(av)[LvTARGOFF(sv)];
1295 }
1296 if (targ && targ != &sv_undef) {
e858de61 1297 dTHR; /* just for SvREFCNT_dec */
68dc0745
PP
1298 /* somebody else defined it for us */
1299 SvREFCNT_dec(LvTARG(sv));
1300 LvTARG(sv) = SvREFCNT_inc(targ);
1301 LvTARGLEN(sv) = 0;
1302 SvREFCNT_dec(mg->mg_obj);
1303 mg->mg_obj = Nullsv;
1304 mg->mg_flags &= ~MGf_REFCOUNTED;
1305 }
5f05dabc 1306 }
71be2cbc
PP
1307 else
1308 targ = LvTARG(sv);
1309 sv_setsv(sv, targ ? targ : &sv_undef);
1310 return 0;
1311}
1312
1313int
8ac85365 1314magic_setdefelem(SV *sv, MAGIC *mg)
71be2cbc
PP
1315{
1316 if (LvTARGLEN(sv))
68dc0745
PP
1317 vivify_defelem(sv);
1318 if (LvTARG(sv)) {
5f05dabc 1319 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1320 SvSETMAGIC(LvTARG(sv));
1321 }
5f05dabc
PP
1322 return 0;
1323}
1324
1325int
8ac85365 1326magic_freedefelem(SV *sv, MAGIC *mg)
5f05dabc
PP
1327{
1328 SvREFCNT_dec(LvTARG(sv));
71be2cbc
PP
1329 return 0;
1330}
1331
1332void
8ac85365 1333vivify_defelem(SV *sv)
71be2cbc 1334{
e858de61 1335 dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/
68dc0745
PP
1336 MAGIC* mg;
1337 SV* value;
71be2cbc 1338
68dc0745 1339 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
71be2cbc 1340 return;
68dc0745
PP
1341 if (mg->mg_obj) {
1342 HV* hv = (HV*)LvTARG(sv);
1343 HE* he = hv_fetch_ent(hv, mg->mg_obj, TRUE, 0);
1344 if (!he || (value = HeVAL(he)) == &sv_undef)
1345 croak(no_helem, SvPV(mg->mg_obj, na));
71be2cbc 1346 }
68dc0745
PP
1347 else {
1348 AV* av = (AV*)LvTARG(sv);
5aabfad6 1349 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
1350 LvTARG(sv) = Nullsv; /* array can't be extended */
1351 else {
1352 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1353 if (!svp || (value = *svp) == &sv_undef)
1354 croak(no_aelem, (I32)LvTARGOFF(sv));
1355 }
1356 }
3e3baf6d 1357 (void)SvREFCNT_inc(value);
68dc0745
PP
1358 SvREFCNT_dec(LvTARG(sv));
1359 LvTARG(sv) = value;
71be2cbc 1360 LvTARGLEN(sv) = 0;
68dc0745
PP
1361 SvREFCNT_dec(mg->mg_obj);
1362 mg->mg_obj = Nullsv;
1363 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
1364}
1365
1366int
8ac85365 1367magic_setmglob(SV *sv, MAGIC *mg)
93a17b20 1368{
76e3520e 1369 mg->mg_length = -1;
c6496cc7 1370 SvSCREAM_off(sv);
93a17b20
LW
1371 return 0;
1372}
1373
1374int
8ac85365 1375magic_setbm(SV *sv, MAGIC *mg)
79072805 1376{
463ee0b2 1377 sv_unmagic(sv, 'B');
79072805
LW
1378 SvVALID_off(sv);
1379 return 0;
1380}
1381
1382int
8ac85365 1383magic_setfm(SV *sv, MAGIC *mg)
55497cff
PP
1384{
1385 sv_unmagic(sv, 'f');
1386 SvCOMPILED_off(sv);
1387 return 0;
1388}
1389
1390int
8ac85365 1391magic_setuvar(SV *sv, MAGIC *mg)
79072805
LW
1392{
1393 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1394
1395 if (uf && uf->uf_set)
1396 (*uf->uf_set)(uf->uf_index, sv);
1397 return 0;
1398}
1399
c277df42
IZ
1400int
1401magic_freeregexp(SV *sv, MAGIC *mg)
1402{
1403 regexp *re = (regexp *)mg->mg_obj;
1404 ReREFCNT_dec(re);
1405 return 0;
1406}
1407
7a4c00b4 1408#ifdef USE_LOCALE_COLLATE
79072805 1409int
8ac85365 1410magic_setcollxfrm(SV *sv, MAGIC *mg)
bbce6d69
PP
1411{
1412 /*
1413 * René Descartes said "I think not."
1414 * and vanished with a faint plop.
1415 */
7a4c00b4
PP
1416 if (mg->mg_ptr) {
1417 Safefree(mg->mg_ptr);
1418 mg->mg_ptr = NULL;
76e3520e 1419 mg->mg_length = -1;
7a4c00b4 1420 }
bbce6d69
PP
1421 return 0;
1422}
7a4c00b4 1423#endif /* USE_LOCALE_COLLATE */
bbce6d69
PP
1424
1425int
8ac85365 1426magic_set(SV *sv, MAGIC *mg)
79072805 1427{
11343788 1428 dTHR;
79072805
LW
1429 register char *s;
1430 I32 i;
8990e307 1431 STRLEN len;
79072805 1432 switch (*mg->mg_ptr) {
748a9306
LW
1433 case '\001': /* ^A */
1434 sv_setsv(bodytarget, sv);
1435 break;
79072805 1436 case '\004': /* ^D */
8990e307 1437 debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
79072805
LW
1438 DEBUG_x(dump_all());
1439 break;
28f23441
PP
1440 case '\005': /* ^E */
1441#ifdef VMS
1442 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1443#else
22fae026
TM
1444#ifdef WIN32
1445 SetLastError( SvIV(sv) );
1446#else
f86702cc
PP
1447 /* will anyone ever use this? */
1448 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
28f23441 1449#endif
22fae026 1450#endif
28f23441 1451 break;
79072805 1452 case '\006': /* ^F */
463ee0b2 1453 maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1454 break;
a0d0e21e
LW
1455 case '\010': /* ^H */
1456 hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1457 break;
79072805
LW
1458 case '\t': /* ^I */
1459 if (inplace)
1460 Safefree(inplace);
1461 if (SvOK(sv))
a0d0e21e 1462 inplace = savepv(SvPV(sv,na));
79072805
LW
1463 else
1464 inplace = Nullch;
1465 break;
28f23441
PP
1466 case '\017': /* ^O */
1467 if (osname)
1468 Safefree(osname);
1469 if (SvOK(sv))
1470 osname = savepv(SvPV(sv,na));
1471 else
1472 osname = Nullch;
1473 break;
79072805 1474 case '\020': /* ^P */
84902520 1475 perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1476 break;
1477 case '\024': /* ^T */
88e89b8a
PP
1478#ifdef BIG_TIME
1479 basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1480#else
85e6fe83 1481 basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 1482#endif
79072805
LW
1483 break;
1484 case '\027': /* ^W */
463ee0b2 1485 dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1486 break;
1487 case '.':
748a9306
LW
1488 if (localizing) {
1489 if (localizing == 1)
1490 save_sptr((SV**)&last_in_gv);
1491 }
88e89b8a 1492 else if (SvOK(sv) && GvIO(last_in_gv))
a0d0e21e 1493 IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
79072805
LW
1494 break;
1495 case '^':
a0d0e21e
LW
1496 Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1497 IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1498 IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1499 break;
1500 case '~':
a0d0e21e
LW
1501 Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1502 IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1503 IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1504 break;
1505 case '=':
a0d0e21e 1506 IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1507 break;
1508 case '-':
a0d0e21e
LW
1509 IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1510 if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1511 IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
79072805
LW
1512 break;
1513 case '%':
a0d0e21e 1514 IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1515 break;
1516 case '|':
4b65379b
CS
1517 {
1518 IO *io = GvIOp(defoutgv);
1519 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1520 IoFLAGS(io) &= ~IOf_FLUSH;
1521 else {
1522 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1523 PerlIO *ofp = IoOFP(io);
1524 if (ofp)
1525 (void)PerlIO_flush(ofp);
1526 IoFLAGS(io) |= IOf_FLUSH;
1527 }
1528 }
79072805
LW
1529 }
1530 break;
1531 case '*':
463ee0b2 1532 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1533 multiline = (i != 0);
1534 break;
1535 case '/':
c07a80fd
PP
1536 SvREFCNT_dec(nrs);
1537 nrs = newSVsv(sv);
1538 SvREFCNT_dec(rs);
1539 rs = SvREFCNT_inc(nrs);
79072805
LW
1540 break;
1541 case '\\':
1542 if (ors)
1543 Safefree(ors);
e3c19b7b
CS
1544 if (SvOK(sv) || SvGMAGICAL(sv))
1545 ors = savepv(SvPV(sv,orslen));
1546 else {
1547 ors = Nullch;
1548 orslen = 0;
1549 }
79072805
LW
1550 break;
1551 case ',':
1552 if (ofs)
1553 Safefree(ofs);
a0d0e21e 1554 ofs = savepv(SvPV(sv, ofslen));
79072805
LW
1555 break;
1556 case '#':
1557 if (ofmt)
1558 Safefree(ofmt);
a0d0e21e 1559 ofmt = savepv(SvPV(sv,na));
79072805
LW
1560 break;
1561 case '[':
a0d0e21e 1562 compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1563 break;
1564 case '?':
ff0cee69
PP
1565#ifdef COMPLEX_STATUS
1566 if (localizing == 2) {
1567 statusvalue = LvTARGOFF(sv);
1568 statusvalue_vms = LvTARGLEN(sv);
1569 }
1570 else
1571#endif
1572#ifdef VMSISH_STATUS
1573 if (VMSISH_STATUS)
1574 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1575 else
1576#endif
1577 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1578 break;
1579 case '!':
f86702cc
PP
1580 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),
1581 (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
79072805
LW
1582 break;
1583 case '<':
463ee0b2 1584 uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1585 if (delaymagic) {
1586 delaymagic |= DM_RUID;
1587 break; /* don't do magic till later */
1588 }
1589#ifdef HAS_SETRUID
85e6fe83 1590 (void)setruid((Uid_t)uid);
79072805
LW
1591#else
1592#ifdef HAS_SETREUID
85e6fe83 1593 (void)setreuid((Uid_t)uid, (Uid_t)-1);
748a9306 1594#else
85e6fe83
LW
1595#ifdef HAS_SETRESUID
1596 (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
79072805
LW
1597#else
1598 if (uid == euid) /* special case $< = $> */
76e3520e 1599 (void)PerlProc_setuid(uid);
a0d0e21e 1600 else {
76e3520e 1601 uid = (I32)PerlProc_getuid();
463ee0b2 1602 croak("setruid() not implemented");
a0d0e21e 1603 }
79072805
LW
1604#endif
1605#endif
85e6fe83 1606#endif
76e3520e 1607 uid = (I32)PerlProc_getuid();
4633a7c4 1608 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1609 break;
1610 case '>':
463ee0b2 1611 euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1612 if (delaymagic) {
1613 delaymagic |= DM_EUID;
1614 break; /* don't do magic till later */
1615 }
1616#ifdef HAS_SETEUID
85e6fe83 1617 (void)seteuid((Uid_t)euid);
79072805
LW
1618#else
1619#ifdef HAS_SETREUID
85e6fe83
LW
1620 (void)setreuid((Uid_t)-1, (Uid_t)euid);
1621#else
1622#ifdef HAS_SETRESUID
1623 (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
79072805
LW
1624#else
1625 if (euid == uid) /* special case $> = $< */
76e3520e 1626 PerlProc_setuid(euid);
a0d0e21e 1627 else {
76e3520e 1628 euid = (I32)PerlProc_geteuid();
463ee0b2 1629 croak("seteuid() not implemented");
a0d0e21e 1630 }
79072805
LW
1631#endif
1632#endif
85e6fe83 1633#endif
76e3520e 1634 euid = (I32)PerlProc_geteuid();
4633a7c4 1635 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1636 break;
1637 case '(':
463ee0b2 1638 gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1639 if (delaymagic) {
1640 delaymagic |= DM_RGID;
1641 break; /* don't do magic till later */
1642 }
1643#ifdef HAS_SETRGID
85e6fe83 1644 (void)setrgid((Gid_t)gid);
79072805
LW
1645#else
1646#ifdef HAS_SETREGID
85e6fe83
LW
1647 (void)setregid((Gid_t)gid, (Gid_t)-1);
1648#else
1649#ifdef HAS_SETRESGID
1650 (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
79072805
LW
1651#else
1652 if (gid == egid) /* special case $( = $) */
76e3520e 1653 (void)PerlProc_setgid(gid);
748a9306 1654 else {
76e3520e 1655 gid = (I32)PerlProc_getgid();
463ee0b2 1656 croak("setrgid() not implemented");
748a9306 1657 }
79072805
LW
1658#endif
1659#endif
85e6fe83 1660#endif
76e3520e 1661 gid = (I32)PerlProc_getgid();
4633a7c4 1662 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1663 break;
1664 case ')':
5cd24f17
PP
1665#ifdef HAS_SETGROUPS
1666 {
1667 char *p = SvPV(sv, na);
1668 Groups_t gary[NGROUPS];
1669
1670 SET_NUMERIC_STANDARD();
1671 while (isSPACE(*p))
1672 ++p;
1673 egid = I_V(atof(p));
1674 for (i = 0; i < NGROUPS; ++i) {
1675 while (*p && !isSPACE(*p))
1676 ++p;
1677 while (isSPACE(*p))
1678 ++p;
1679 if (!*p)
1680 break;
1681 gary[i] = I_V(atof(p));
1682 }
8cc95fdb
PP
1683 if (i)
1684 (void)setgroups(i, gary);
5cd24f17
PP
1685 }
1686#else /* HAS_SETGROUPS */
463ee0b2 1687 egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 1688#endif /* HAS_SETGROUPS */
79072805
LW
1689 if (delaymagic) {
1690 delaymagic |= DM_EGID;
1691 break; /* don't do magic till later */
1692 }
1693#ifdef HAS_SETEGID
85e6fe83 1694 (void)setegid((Gid_t)egid);
79072805
LW
1695#else
1696#ifdef HAS_SETREGID
85e6fe83
LW
1697 (void)setregid((Gid_t)-1, (Gid_t)egid);
1698#else
1699#ifdef HAS_SETRESGID
1700 (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
79072805
LW
1701#else
1702 if (egid == gid) /* special case $) = $( */
76e3520e 1703 (void)PerlProc_setgid(egid);
748a9306 1704 else {
76e3520e 1705 egid = (I32)PerlProc_getegid();
463ee0b2 1706 croak("setegid() not implemented");
748a9306 1707 }
79072805
LW
1708#endif
1709#endif
85e6fe83 1710#endif
76e3520e 1711 egid = (I32)PerlProc_getegid();
4633a7c4 1712 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1713 break;
1714 case ':':
a0d0e21e 1715 chopset = SvPV_force(sv,na);
79072805
LW
1716 break;
1717 case '0':
1718 if (!origalen) {
1719 s = origargv[0];
1720 s += strlen(s);
1721 /* See if all the arguments are contiguous in memory */
1722 for (i = 1; i < origargc; i++) {
fb73857a
PP
1723 if (origargv[i] == s + 1
1724#ifdef OS2
1725 || origargv[i] == s + 2
1726#endif
1727 )
79072805 1728 s += strlen(++s); /* this one is ok too */
fb73857a
PP
1729 else
1730 break;
79072805 1731 }
bbce6d69 1732 /* can grab env area too? */
fb73857a
PP
1733 if (origenviron && (origenviron[0] == s + 1
1734#ifdef OS2
1735 || (origenviron[0] == s + 9 && (s += 8))
1736#endif
1737 )) {
66b1d557 1738 my_setenv("NoNe SuCh", Nullch);
79072805
LW
1739 /* force copy of environment */
1740 for (i = 0; origenviron[i]; i++)
1741 if (origenviron[i] == s + 1)
1742 s += strlen(++s);
fb73857a
PP
1743 else
1744 break;
79072805
LW
1745 }
1746 origalen = s - origargv[0];
1747 }
a0d0e21e 1748 s = SvPV_force(sv,len);
8990e307 1749 i = len;
79072805
LW
1750 if (i >= origalen) {
1751 i = origalen;
fb73857a
PP
1752 /* don't allow system to limit $0 seen by script */
1753 /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
79072805 1754 Copy(s, origargv[0], i, char);
fb73857a
PP
1755 s = origargv[0]+i;
1756 *s = '\0';
79072805
LW
1757 }
1758 else {
1759 Copy(s, origargv[0], i, char);
1760 s = origargv[0]+i;
1761 *s++ = '\0';
1762 while (++i < origalen)
8990e307
LW
1763 *s++ = ' ';
1764 s = origargv[0]+i;
ed6116ce 1765 for (i = 1; i < origargc; i++)
8990e307 1766 origargv[i] = Nullch;
79072805
LW
1767 }
1768 break;
a863c7d1
MB
1769#ifdef USE_THREADS
1770 case '@':
38a03e6e 1771 sv_setsv(thr->errsv, sv);
a863c7d1
MB
1772 break;
1773#endif /* USE_THREADS */
79072805
LW
1774 }
1775 return 0;
1776}
1777
f93b4edd
MB
1778#ifdef USE_THREADS
1779int
8ac85365 1780magic_mutexfree(SV *sv, MAGIC *mg)
f93b4edd
MB
1781{
1782 dTHR;
bc1f4c86
MB
1783 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n",
1784 (unsigned long)thr, (unsigned long)sv);)
f93b4edd
MB
1785 if (MgOWNER(mg))
1786 croak("panic: magic_mutexfree");
1787 MUTEX_DESTROY(MgMUTEXP(mg));
1788 COND_DESTROY(MgCONDP(mg));
e55aaa0e 1789 SvREFCNT_dec(sv);
f93b4edd
MB
1790 return 0;
1791}
1792#endif /* USE_THREADS */
1793
79072805 1794I32
8ac85365 1795whichsig(char *sig)
79072805
LW
1796{
1797 register char **sigv;
1798
1799 for (sigv = sig_name+1; *sigv; sigv++)
1800 if (strEQ(sig,*sigv))
8e07c86e 1801 return sig_num[sigv - sig_name];
79072805
LW
1802#ifdef SIGCLD
1803 if (strEQ(sig,"CHLD"))
1804 return SIGCLD;
1805#endif
1806#ifdef SIGCHLD
1807 if (strEQ(sig,"CLD"))
1808 return SIGCHLD;
1809#endif
1810 return 0;
1811}
1812
84902520
TB
1813static SV* sig_sv;
1814
76e3520e 1815STATIC void
8ac85365 1816unwind_handler_stack(void *p)
84902520 1817{
ff26ac79 1818 dTHR;
84902520
TB
1819 U32 flags = *(U32*)p;
1820
1821 if (flags & 1)
1822 savestack_ix -= 5; /* Unprotect save in progress. */
1823 /* cxstack_ix-- Not needed, die already unwound it. */
1824 if (flags & 64)
1825 SvREFCNT_dec(sig_sv);
1826}
1827
ecfc5424 1828Signal_t
8ac85365 1829sighandler(int sig)
79072805
LW
1830{
1831 dSP;
00d579c5 1832 GV *gv = Nullgv;
a0d0e21e 1833 HV *st;
84902520 1834 SV *sv, *tSv = Sv;
00d579c5 1835 CV *cv = Nullcv;
79072805 1836 AV *oldstack;
84902520
TB
1837 OP *myop = op;
1838 U32 flags = 0;
1839 I32 o_save_i = savestack_ix, type;
c09156bb 1840 PERL_CONTEXT *cx;
84902520
TB
1841 XPV *tXpv = Xpv;
1842
1843 if (savestack_ix + 15 <= savestack_max)
1844 flags |= 1;
1845 if (cxstack_ix < cxstack_max - 2)
1846 flags |= 2;
1847 if (markstack_ptr < markstack_max - 2)
1848 flags |= 4;
1849 if (retstack_ix < retstack_max - 2)
1850 flags |= 8;
1851 if (scopestack_ix < scopestack_max - 3)
1852 flags |= 16;
1853
1854 if (flags & 2) { /* POPBLOCK may decrease cxstack too early. */
1855 cxstack_ix++; /* Protect from overwrite. */
1856 cx = &cxstack[cxstack_ix];
1857 type = cx->cx_type; /* Can be during partial write. */
1858 cx->cx_type = CXt_NULL; /* Make it safe for unwind. */
1859 }
ff0cee69
PP
1860 if (!psig_ptr[sig])
1861 die("Signal SIG%s received, but no signal handler set.\n",
1862 sig_name[sig]);
1863
84902520
TB
1864 /* Max number of items pushed there is 3*n or 4. We cannot fix
1865 infinity, so we fix 4 (in fact 5): */
1866 if (flags & 1) {
1867 savestack_ix += 5; /* Protect save in progress. */
1868 o_save_i = savestack_ix;
76e3520e 1869 SAVEDESTRUCTOR(UNWINDHANDLER, (void*)&flags);
84902520
TB
1870 }
1871 if (flags & 4)
1872 markstack_ptr++; /* Protect mark. */
1873 if (flags & 8) {
1874 retstack_ix++;
1875 retstack[retstack_ix] = NULL;
1876 }
1877 if (flags & 16)
1878 scopestack_ix += 1;
1879 /* sv_2cv is too complicated, try a simpler variant first: */
1880 if (!SvROK(psig_ptr[sig]) || !(cv = (CV*)SvRV(psig_ptr[sig]))
1881 || SvTYPE(cv) != SVt_PVCV)
1882 cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
1883
a0d0e21e 1884 if (!cv || !CvROOT(cv)) {
79072805
LW
1885 if (dowarn)
1886 warn("SIG%s handler \"%s\" not defined.\n",
00d579c5
GS
1887 sig_name[sig], (gv ? GvENAME(gv)
1888 : ((cv && CvGV(cv))
1889 ? GvENAME(CvGV(cv))
1890 : "__ANON__")));
1891 goto cleanup;
79072805
LW
1892 }
1893
88e89b8a
PP
1894 oldstack = curstack;
1895 if (curstack != signalstack)
93965878 1896 AvFILLp(signalstack) = 0;
88e89b8a 1897 SWITCHSTACK(curstack, signalstack);
79072805 1898
84902520 1899 if(psig_name[sig]) {
88e89b8a 1900 sv = SvREFCNT_inc(psig_name[sig]);
84902520
TB
1901 flags |= 64;
1902 sig_sv = sv;
1903 } else {
ff0cee69
PP
1904 sv = sv_newmortal();
1905 sv_setpv(sv,sig_name[sig]);
88e89b8a 1906 }
a0d0e21e 1907 PUSHMARK(sp);
79072805 1908 PUSHs(sv);
79072805 1909 PUTBACK;
a0d0e21e
LW
1910
1911 perl_call_sv((SV*)cv, G_DISCARD);
79072805
LW
1912
1913 SWITCHSTACK(signalstack, oldstack);
00d579c5 1914cleanup:
84902520
TB
1915 if (flags & 1)
1916 savestack_ix -= 8; /* Unprotect save in progress. */
1917 if (flags & 2) {
1918 cxstack[cxstack_ix].cx_type = type;
1919 cxstack_ix -= 1;
1920 }
1921 if (flags & 4)
1922 markstack_ptr--;
1923 if (flags & 8)
1924 retstack_ix--;
1925 if (flags & 16)
1926 scopestack_ix -= 1;
1927 if (flags & 64)
1928 SvREFCNT_dec(sv);
1929 op = myop; /* Apparently not needed... */
1930
1931 Sv = tSv; /* Restore global temporaries. */
1932 Xpv = tXpv;
79072805
LW
1933 return;
1934}
4e35701f
NIS
1935
1936