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