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