This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
more conservative version of changes#2345,2346,2347; those break
[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;
e72dc28c 950 STRLEN len;
a0d0e21e 951
e72dc28c 952 s = MgPV(mg,len);
748a9306
LW
953 if (*s == '_') {
954 if (strEQ(s,"__DIE__"))
3280af22 955 svp = &PL_diehook;
748a9306 956 else if (strEQ(s,"__WARN__"))
3280af22 957 svp = &PL_warnhook;
748a9306 958 else if (strEQ(s,"__PARSE__"))
3280af22 959 svp = &PL_parsehook;
748a9306
LW
960 else
961 croak("No such hook: %s", s);
962 i = 0;
4633a7c4
LW
963 if (*svp) {
964 SvREFCNT_dec(*svp);
965 *svp = 0;
966 }
748a9306
LW
967 }
968 else {
969 i = whichsig(s); /* ...no, a brick */
970 if (!i) {
599cee73
PM
971 if (ckWARN(WARN_SIGNAL) || strEQ(s,"ALARM"))
972 warner(WARN_SIGNAL, "No such signal: SIG%s", s);
748a9306
LW
973 return 0;
974 }
22c35a8c
GS
975 SvREFCNT_dec(PL_psig_name[i]);
976 SvREFCNT_dec(PL_psig_ptr[i]);
977 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 978 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 979 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 980 SvREADONLY_on(PL_psig_name[i]);
748a9306 981 }
a0d0e21e 982 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
748a9306 983 if (i)
3280af22 984 (void)rsignal(i, PL_sighandlerp);
748a9306
LW
985 else
986 *svp = SvREFCNT_inc(sv);
a0d0e21e
LW
987 return 0;
988 }
e72dc28c 989 s = SvPV_force(sv,len);
748a9306
LW
990 if (strEQ(s,"IGNORE")) {
991 if (i)
ff68c719 992 (void)rsignal(i, SIG_IGN);
748a9306
LW
993 else
994 *svp = 0;
995 }
996 else if (strEQ(s,"DEFAULT") || !*s) {
997 if (i)
ff68c719 998 (void)rsignal(i, SIG_DFL);
748a9306
LW
999 else
1000 *svp = 0;
1001 }
79072805 1002 else {
5aabfad6
PP
1003 /*
1004 * We should warn if HINT_STRICT_REFS, but without
1005 * access to a known hint bit in a known OP, we can't
1006 * tell whether HINT_STRICT_REFS is in force or not.
1007 */
46fc3d4c 1008 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 1009 sv_insert(sv, 0, 0, "main::", 6);
748a9306 1010 if (i)
3280af22 1011 (void)rsignal(i, PL_sighandlerp);
748a9306
LW
1012 else
1013 *svp = SvREFCNT_inc(sv);
79072805
LW
1014 }
1015 return 0;
1016}
1017
1018int
8ac85365 1019magic_setisa(SV *sv, MAGIC *mg)
79072805 1020{
3280af22 1021 PL_sub_generation++;
463ee0b2
LW
1022 return 0;
1023}
1024
a0d0e21e
LW
1025#ifdef OVERLOAD
1026
463ee0b2 1027int
8ac85365 1028magic_setamagic(SV *sv, MAGIC *mg)
463ee0b2 1029{
a0d0e21e 1030 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1031 PL_amagic_generation++;
463ee0b2 1032
a0d0e21e
LW
1033 return 0;
1034}
1035#endif /* OVERLOAD */
463ee0b2 1036
946ec16e 1037int
6ff81951
GS
1038magic_getnkeys(SV *sv, MAGIC *mg)
1039{
1040 HV *hv = (HV*)LvTARG(sv);
1041 HE *entry;
1042 I32 i = 0;
1043
1044 if (hv) {
1045 (void) hv_iterinit(hv);
33c27489 1046 if (! SvTIED_mg((SV*)hv, 'P'))
6ff81951
GS
1047 i = HvKEYS(hv);
1048 else {
1049 /*SUPPRESS 560*/
1050 while (entry = hv_iternext(hv)) {
1051 i++;
1052 }
1053 }
1054 }
1055
1056 sv_setiv(sv, (IV)i);
1057 return 0;
1058}
1059
1060int
8ac85365 1061magic_setnkeys(SV *sv, MAGIC *mg)
946ec16e
PP
1062{
1063 if (LvTARG(sv)) {
1064 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1065 }
1066 return 0;
93965878 1067}
946ec16e 1068
e336de0d 1069/* caller is responsible for stack switching/cleanup */
565764a8 1070STATIC int
33c27489 1071magic_methcall(SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW
1072{
1073 dSP;
463ee0b2 1074
924508f0
GS
1075 PUSHMARK(SP);
1076 EXTEND(SP, n);
33c27489 1077 PUSHs(SvTIED_obj(sv, mg));
93965878
NIS
1078 if (n > 1) {
1079 if (mg->mg_ptr) {
565764a8
DL
1080 if (mg->mg_len >= 0)
1081 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
1082 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1083 PUSHs((SV*)mg->mg_ptr);
1084 }
1085 else if (mg->mg_type == 'p') {
565764a8 1086 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1087 }
1088 }
1089 if (n > 2) {
1090 PUSHs(val);
88e89b8a 1091 }
463ee0b2
LW
1092 PUTBACK;
1093
93965878 1094 return perl_call_method(meth, flags);
946ec16e
PP
1095}
1096
76e3520e 1097STATIC int
8ac85365 1098magic_methpack(SV *sv, MAGIC *mg, char *meth)
a0d0e21e
LW
1099{
1100 dSP;
463ee0b2 1101
a0d0e21e
LW
1102 ENTER;
1103 SAVETMPS;
e788e7d3 1104 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1105
33c27489 1106 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1107 sv_setsv(sv, *PL_stack_sp--);
93965878 1108 }
463ee0b2 1109
d3acc0f7 1110 POPSTACK;
a0d0e21e
LW
1111 FREETMPS;
1112 LEAVE;
1113 return 0;
1114}
463ee0b2 1115
a0d0e21e 1116int
8ac85365 1117magic_getpack(SV *sv, MAGIC *mg)
a0d0e21e
LW
1118{
1119 magic_methpack(sv,mg,"FETCH");
1120 if (mg->mg_ptr)
1121 mg->mg_flags |= MGf_GSKIP;
463ee0b2
LW
1122 return 0;
1123}
1124
1125int
8ac85365 1126magic_setpack(SV *sv, MAGIC *mg)
e336de0d
GS
1127{
1128 dSP;
a60c0954 1129 ENTER;
e788e7d3 1130 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1131 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1132 POPSTACK;
a60c0954 1133 LEAVE;
463ee0b2
LW
1134 return 0;
1135}
1136
1137int
8ac85365 1138magic_clearpack(SV *sv, MAGIC *mg)
463ee0b2 1139{
a0d0e21e
LW
1140 return magic_methpack(sv,mg,"DELETE");
1141}
463ee0b2 1142
93965878
NIS
1143
1144U32
1145magic_sizepack(SV *sv, MAGIC *mg)
1146{
e336de0d 1147 dSP;
93965878
NIS
1148 U32 retval = 0;
1149
1150 ENTER;
1151 SAVETMPS;
e788e7d3 1152 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1153 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1154 sv = *PL_stack_sp--;
a60c0954 1155 retval = (U32) SvIV(sv)-1;
93965878 1156 }
d3acc0f7 1157 POPSTACK;
93965878
NIS
1158 FREETMPS;
1159 LEAVE;
1160 return retval;
1161}
1162
8ac85365 1163int magic_wipepack(SV *sv, MAGIC *mg)
a0d0e21e
LW
1164{
1165 dSP;
463ee0b2 1166
e336de0d 1167 ENTER;
e788e7d3 1168 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1169 PUSHMARK(SP);
33c27489 1170 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1171 PUTBACK;
a0d0e21e 1172 perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1173 POPSTACK;
a60c0954 1174 LEAVE;
463ee0b2
LW
1175 return 0;
1176}
1177
1178int
8ac85365 1179magic_nextpack(SV *sv, MAGIC *mg, SV *key)
463ee0b2 1180{
463ee0b2 1181 dSP;
a0d0e21e 1182 char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1183
1184 ENTER;
a0d0e21e 1185 SAVETMPS;
e788e7d3 1186 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1187 PUSHMARK(SP);
1188 EXTEND(SP, 2);
33c27489 1189 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1190 if (SvOK(key))
1191 PUSHs(key);
1192 PUTBACK;
1193
a0d0e21e 1194 if (perl_call_method(meth, G_SCALAR))
3280af22 1195 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1196
d3acc0f7 1197 POPSTACK;
a0d0e21e
LW
1198 FREETMPS;
1199 LEAVE;
79072805
LW
1200 return 0;
1201}
1202
1203int
8ac85365 1204magic_existspack(SV *sv, MAGIC *mg)
a0d0e21e
LW
1205{
1206 return magic_methpack(sv,mg,"EXISTS");
1207}
1208
1209int
8ac85365 1210magic_setdbline(SV *sv, MAGIC *mg)
79072805 1211{
11343788 1212 dTHR;
79072805
LW
1213 OP *o;
1214 I32 i;
1215 GV* gv;
1216 SV** svp;
1217
3280af22 1218 gv = PL_DBline;
79072805 1219 i = SvTRUE(sv);
188ea221 1220 svp = av_fetch(GvAV(gv),
3280af22 1221 atoi(MgPV(mg,PL_na)), FALSE);
8990e307 1222 if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
93a17b20 1223 o->op_private = i;
79072805
LW
1224 else
1225 warn("Can't break at that line\n");
1226 return 0;
1227}
1228
1229int
8ac85365 1230magic_getarylen(SV *sv, MAGIC *mg)
79072805 1231{
0f15f207 1232 dTHR;
3280af22 1233 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
79072805
LW
1234 return 0;
1235}
1236
1237int
8ac85365 1238magic_setarylen(SV *sv, MAGIC *mg)
79072805 1239{
0f15f207 1240 dTHR;
3280af22 1241 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
a0d0e21e
LW
1242 return 0;
1243}
1244
1245int
8ac85365 1246magic_getpos(SV *sv, MAGIC *mg)
a0d0e21e
LW
1247{
1248 SV* lsv = LvTARG(sv);
1249
1250 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1251 mg = mg_find(lsv, 'g');
565764a8 1252 if (mg && mg->mg_len >= 0) {
0f15f207 1253 dTHR;
a0ed51b3
LW
1254 I32 i = mg->mg_len;
1255 if (IN_UTF8)
1256 sv_pos_b2u(lsv, &i);
1257 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW
1258 return 0;
1259 }
1260 }
1261 (void)SvOK_off(sv);
1262 return 0;
1263}
1264
1265int
8ac85365 1266magic_setpos(SV *sv, MAGIC *mg)
a0d0e21e
LW
1267{
1268 SV* lsv = LvTARG(sv);
1269 SSize_t pos;
1270 STRLEN len;
a0ed51b3 1271 STRLEN ulen;
c485e607 1272 dTHR;
a0d0e21e
LW
1273
1274 mg = 0;
1275
1276 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1277 mg = mg_find(lsv, 'g');
1278 if (!mg) {
1279 if (!SvOK(sv))
1280 return 0;
1281 sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1282 mg = mg_find(lsv, 'g');
1283 }
1284 else if (!SvOK(sv)) {
565764a8 1285 mg->mg_len = -1;
a0d0e21e
LW
1286 return 0;
1287 }
1288 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1289
c485e607 1290 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3
LW
1291
1292 if (IN_UTF8) {
1293 ulen = sv_len_utf8(lsv);
1294 if (ulen)
1295 len = ulen;
1296 else
1297 ulen = 0;
1298 }
1299
a0d0e21e
LW
1300 if (pos < 0) {
1301 pos += len;
1302 if (pos < 0)
1303 pos = 0;
1304 }
1305 else if (pos > len)
1306 pos = len;
a0ed51b3
LW
1307
1308 if (ulen) {
1309 I32 p = pos;
1310 sv_pos_u2b(lsv, &p, 0);
1311 pos = p;
1312 }
1313
565764a8 1314 mg->mg_len = pos;
71be2cbc 1315 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1316
79072805
LW
1317 return 0;
1318}
1319
1320int
8ac85365 1321magic_getglob(SV *sv, MAGIC *mg)
79072805 1322{
8646b087
PP
1323 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1324 SvFAKE_off(sv);
946ec16e 1325 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1326 SvFAKE_on(sv);
1327 }
1328 else
946ec16e 1329 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1330 return 0;
1331}
1332
1333int
8ac85365 1334magic_setglob(SV *sv, MAGIC *mg)
79072805
LW
1335{
1336 register char *s;
1337 GV* gv;
1338
1339 if (!SvOK(sv))
1340 return 0;
3280af22 1341 s = SvPV(sv, PL_na);
79072805
LW
1342 if (*s == '*' && s[1])
1343 s++;
85e6fe83 1344 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
79072805
LW
1345 if (sv == (SV*)gv)
1346 return 0;
1347 if (GvGP(sv))
88e89b8a 1348 gp_free((GV*)sv);
79072805 1349 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1350 return 0;
1351}
1352
1353int
6ff81951
GS
1354magic_getsubstr(SV *sv, MAGIC *mg)
1355{
1356 STRLEN len;
1357 SV *lsv = LvTARG(sv);
1358 char *tmps = SvPV(lsv,len);
1359 I32 offs = LvTARGOFF(sv);
1360 I32 rem = LvTARGLEN(sv);
1361
1362 if (offs > len)
1363 offs = len;
1364 if (rem + offs > len)
1365 rem = len - offs;
1366 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1367 return 0;
1368}
1369
1370int
8ac85365 1371magic_setsubstr(SV *sv, MAGIC *mg)
79072805 1372{
8990e307
LW
1373 STRLEN len;
1374 char *tmps = SvPV(sv,len);
1375 sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
79072805
LW
1376 return 0;
1377}
1378
1379int
8ac85365 1380magic_gettaint(SV *sv, MAGIC *mg)
463ee0b2 1381{
a863c7d1 1382 dTHR;
565764a8
DL
1383 TAINT_IF((mg->mg_len & 1) ||
1384 (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */
463ee0b2
LW
1385 return 0;
1386}
1387
1388int
8ac85365 1389magic_settaint(SV *sv, MAGIC *mg)
463ee0b2 1390{
11343788 1391 dTHR;
3280af22
NIS
1392 if (PL_localizing) {
1393 if (PL_localizing == 1)
565764a8 1394 mg->mg_len <<= 1;
748a9306 1395 else
565764a8 1396 mg->mg_len >>= 1;
a0d0e21e 1397 }
3280af22 1398 else if (PL_tainted)
565764a8 1399 mg->mg_len |= 1;
748a9306 1400 else
565764a8 1401 mg->mg_len &= ~1;
463ee0b2
LW
1402 return 0;
1403}
1404
1405int
6ff81951
GS
1406magic_getvec(SV *sv, MAGIC *mg)
1407{
1408 SV *lsv = LvTARG(sv);
1409 unsigned char *s;
1410 unsigned long retnum;
1411 STRLEN lsvlen;
1412 I32 len;
1413 I32 offset;
1414 I32 size;
1415
1416 if (!lsv) {
1417 SvOK_off(sv);
1418 return 0;
1419 }
1420 s = (unsigned char *) SvPV(lsv, lsvlen);
1421 offset = LvTARGOFF(sv);
1422 size = LvTARGLEN(sv);
1423 len = (offset + size + 7) / 8;
1424
1425 /* Copied from pp_vec() */
1426
1427 if (len > lsvlen) {
1428 if (size <= 8)
1429 retnum = 0;
1430 else {
1431 offset >>= 3;
1432 if (size == 16) {
1433 if (offset >= lsvlen)
1434 retnum = 0;
1435 else
1436 retnum = (unsigned long) s[offset] << 8;
1437 }
1438 else if (size == 32) {
1439 if (offset >= lsvlen)
1440 retnum = 0;
1441 else if (offset + 1 >= lsvlen)
1442 retnum = (unsigned long) s[offset] << 24;
1443 else if (offset + 2 >= lsvlen)
1444 retnum = ((unsigned long) s[offset] << 24) +
1445 ((unsigned long) s[offset + 1] << 16);
1446 else
1447 retnum = ((unsigned long) s[offset] << 24) +
1448 ((unsigned long) s[offset + 1] << 16) +
1449 (s[offset + 2] << 8);
1450 }
1451 }
1452 }
1453 else if (size < 8)
1454 retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1455 else {
1456 offset >>= 3;
1457 if (size == 8)
1458 retnum = s[offset];
1459 else if (size == 16)
1460 retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1461 else if (size == 32)
1462 retnum = ((unsigned long) s[offset] << 24) +
1463 ((unsigned long) s[offset + 1] << 16) +
1464 (s[offset + 2] << 8) + s[offset+3];
1465 }
1466
1467 sv_setuv(sv, (UV)retnum);
1468 return 0;
1469}
1470
1471int
8ac85365 1472magic_setvec(SV *sv, MAGIC *mg)
79072805
LW
1473{
1474 do_vecset(sv); /* XXX slurp this routine */
1475 return 0;
1476}
1477
1478int
8ac85365 1479magic_getdefelem(SV *sv, MAGIC *mg)
5f05dabc 1480{
71be2cbc 1481 SV *targ = Nullsv;
5f05dabc 1482 if (LvTARGLEN(sv)) {
68dc0745 1483 if (mg->mg_obj) {
74e13ce4
GS
1484 SV *ahv = LvTARG(sv);
1485 if (SvTYPE(ahv) == SVt_PVHV) {
1486 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1487 if (he)
1488 targ = HeVAL(he);
1489 }
1490 else {
1491 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
1492 if (svp)
1493 targ = *svp;
1494 }
68dc0745
PP
1495 }
1496 else {
3c78fafa 1497 AV* av = (AV*)LvTARG(sv);
68dc0745
PP
1498 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1499 targ = AvARRAY(av)[LvTARGOFF(sv)];
1500 }
3280af22 1501 if (targ && targ != &PL_sv_undef) {
e858de61 1502 dTHR; /* just for SvREFCNT_dec */
68dc0745
PP
1503 /* somebody else defined it for us */
1504 SvREFCNT_dec(LvTARG(sv));
1505 LvTARG(sv) = SvREFCNT_inc(targ);
1506 LvTARGLEN(sv) = 0;
1507 SvREFCNT_dec(mg->mg_obj);
1508 mg->mg_obj = Nullsv;
1509 mg->mg_flags &= ~MGf_REFCOUNTED;
1510 }
5f05dabc 1511 }
71be2cbc
PP
1512 else
1513 targ = LvTARG(sv);
3280af22 1514 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
1515 return 0;
1516}
1517
1518int
8ac85365 1519magic_setdefelem(SV *sv, MAGIC *mg)
71be2cbc
PP
1520{
1521 if (LvTARGLEN(sv))
68dc0745
PP
1522 vivify_defelem(sv);
1523 if (LvTARG(sv)) {
5f05dabc 1524 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1525 SvSETMAGIC(LvTARG(sv));
1526 }
5f05dabc
PP
1527 return 0;
1528}
1529
71be2cbc 1530void
8ac85365 1531vivify_defelem(SV *sv)
71be2cbc 1532{
e858de61 1533 dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/
74e13ce4
GS
1534 MAGIC *mg;
1535 SV *value = Nullsv;
71be2cbc 1536
68dc0745 1537 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
71be2cbc 1538 return;
68dc0745 1539 if (mg->mg_obj) {
74e13ce4
GS
1540 SV *ahv = LvTARG(sv);
1541 if (SvTYPE(ahv) == SVt_PVHV) {
af7f9c15 1542 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
74e13ce4
GS
1543 if (he)
1544 value = HeVAL(he);
1545 }
1546 else {
af7f9c15 1547 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
74e13ce4
GS
1548 if (svp)
1549 value = *svp;
1550 }
3280af22 1551 if (!value || value == &PL_sv_undef)
22c35a8c 1552 croak(PL_no_helem, SvPV(mg->mg_obj, PL_na));
71be2cbc 1553 }
68dc0745
PP
1554 else {
1555 AV* av = (AV*)LvTARG(sv);
5aabfad6 1556 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
1557 LvTARG(sv) = Nullsv; /* array can't be extended */
1558 else {
1559 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 1560 if (!svp || (value = *svp) == &PL_sv_undef)
22c35a8c 1561 croak(PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
1562 }
1563 }
3e3baf6d 1564 (void)SvREFCNT_inc(value);
68dc0745
PP
1565 SvREFCNT_dec(LvTARG(sv));
1566 LvTARG(sv) = value;
71be2cbc 1567 LvTARGLEN(sv) = 0;
68dc0745
PP
1568 SvREFCNT_dec(mg->mg_obj);
1569 mg->mg_obj = Nullsv;
1570 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
1571}
1572
1573int
8ac85365 1574magic_setmglob(SV *sv, MAGIC *mg)
93a17b20 1575{
565764a8 1576 mg->mg_len = -1;
c6496cc7 1577 SvSCREAM_off(sv);
93a17b20
LW
1578 return 0;
1579}
1580
1581int
8ac85365 1582magic_setbm(SV *sv, MAGIC *mg)
79072805 1583{
463ee0b2 1584 sv_unmagic(sv, 'B');
79072805
LW
1585 SvVALID_off(sv);
1586 return 0;
1587}
1588
1589int
8ac85365 1590magic_setfm(SV *sv, MAGIC *mg)
55497cff
PP
1591{
1592 sv_unmagic(sv, 'f');
1593 SvCOMPILED_off(sv);
1594 return 0;
1595}
1596
1597int
8ac85365 1598magic_setuvar(SV *sv, MAGIC *mg)
79072805
LW
1599{
1600 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1601
1602 if (uf && uf->uf_set)
1603 (*uf->uf_set)(uf->uf_index, sv);
1604 return 0;
1605}
1606
c277df42
IZ
1607int
1608magic_freeregexp(SV *sv, MAGIC *mg)
1609{
1610 regexp *re = (regexp *)mg->mg_obj;
1611 ReREFCNT_dec(re);
1612 return 0;
1613}
1614
7a4c00b4 1615#ifdef USE_LOCALE_COLLATE
79072805 1616int
8ac85365 1617magic_setcollxfrm(SV *sv, MAGIC *mg)
bbce6d69
PP
1618{
1619 /*
838b5b74 1620 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
1621 * and vanished with a faint plop.
1622 */
7a4c00b4
PP
1623 if (mg->mg_ptr) {
1624 Safefree(mg->mg_ptr);
1625 mg->mg_ptr = NULL;
565764a8 1626 mg->mg_len = -1;
7a4c00b4 1627 }
bbce6d69
PP
1628 return 0;
1629}
7a4c00b4 1630#endif /* USE_LOCALE_COLLATE */
bbce6d69
PP
1631
1632int
8ac85365 1633magic_set(SV *sv, MAGIC *mg)
79072805 1634{
11343788 1635 dTHR;
79072805
LW
1636 register char *s;
1637 I32 i;
8990e307 1638 STRLEN len;
79072805 1639 switch (*mg->mg_ptr) {
748a9306 1640 case '\001': /* ^A */
3280af22 1641 sv_setsv(PL_bodytarget, sv);
748a9306 1642 break;
599cee73
PM
1643 case '\002': /* ^B */
1644 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1645 if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize))
e24b16f9 1646 PL_compiling.cop_warnings = WARN_ALL;
599cee73 1647 else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize))
e24b16f9 1648 PL_compiling.cop_warnings = WARN_NONE;
599cee73 1649 else {
e24b16f9
GS
1650 if (PL_compiling.cop_warnings != WARN_NONE &&
1651 PL_compiling.cop_warnings != WARN_ALL)
1652 sv_setsv(PL_compiling.cop_warnings, sv);
599cee73 1653 else
e24b16f9 1654 PL_compiling.cop_warnings = newSVsv(sv) ;
599cee73
PM
1655 }
1656 }
1657 break;
79072805 1658 case '\004': /* ^D */
3280af22 1659 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
79072805
LW
1660 DEBUG_x(dump_all());
1661 break;
28f23441
PP
1662 case '\005': /* ^E */
1663#ifdef VMS
1664 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1665#else
22fae026
TM
1666#ifdef WIN32
1667 SetLastError( SvIV(sv) );
1668#else
f86702cc
PP
1669 /* will anyone ever use this? */
1670 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
28f23441 1671#endif
22fae026 1672#endif
28f23441 1673 break;
79072805 1674 case '\006': /* ^F */
3280af22 1675 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1676 break;
a0d0e21e 1677 case '\010': /* ^H */
3280af22 1678 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 1679 break;
9d116dd7 1680 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
1681 if (PL_inplace)
1682 Safefree(PL_inplace);
79072805 1683 if (SvOK(sv))
3280af22 1684 PL_inplace = savepv(SvPV(sv,PL_na));
79072805 1685 else
3280af22 1686 PL_inplace = Nullch;
79072805 1687 break;
28f23441 1688 case '\017': /* ^O */
3280af22
NIS
1689 if (PL_osname)
1690 Safefree(PL_osname);
28f23441 1691 if (SvOK(sv))
3280af22 1692 PL_osname = savepv(SvPV(sv,PL_na));
28f23441 1693 else
3280af22 1694 PL_osname = Nullch;
28f23441 1695 break;
79072805 1696 case '\020': /* ^P */
3280af22 1697 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1698 break;
1699 case '\024': /* ^T */
88e89b8a 1700#ifdef BIG_TIME
6b88bc9c 1701 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 1702#else
3280af22 1703 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 1704#endif
79072805
LW
1705 break;
1706 case '\027': /* ^W */
599cee73
PM
1707 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1708 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1709 PL_dowarn = (i ? G_WARN_ON : G_WARN_OFF) ;
1710 }
79072805
LW
1711 break;
1712 case '.':
3280af22
NIS
1713 if (PL_localizing) {
1714 if (PL_localizing == 1)
1715 save_sptr((SV**)&PL_last_in_gv);
748a9306 1716 }
3280af22
NIS
1717 else if (SvOK(sv) && GvIO(PL_last_in_gv))
1718 IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
79072805
LW
1719 break;
1720 case '^':
3280af22
NIS
1721 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
1722 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,PL_na));
1723 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1724 break;
1725 case '~':
3280af22
NIS
1726 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
1727 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,PL_na));
1728 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1729 break;
1730 case '=':
3280af22 1731 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1732 break;
1733 case '-':
3280af22
NIS
1734 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1735 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
1736 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
1737 break;
1738 case '%':
3280af22 1739 IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1740 break;
1741 case '|':
4b65379b 1742 {
3280af22 1743 IO *io = GvIOp(PL_defoutgv);
4b65379b
CS
1744 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1745 IoFLAGS(io) &= ~IOf_FLUSH;
1746 else {
1747 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1748 PerlIO *ofp = IoOFP(io);
1749 if (ofp)
1750 (void)PerlIO_flush(ofp);
1751 IoFLAGS(io) |= IOf_FLUSH;
1752 }
1753 }
79072805
LW
1754 }
1755 break;
1756 case '*':
463ee0b2 1757 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
3280af22 1758 PL_multiline = (i != 0);
79072805
LW
1759 break;
1760 case '/':
3280af22
NIS
1761 SvREFCNT_dec(PL_nrs);
1762 PL_nrs = newSVsv(sv);
1763 SvREFCNT_dec(PL_rs);
1764 PL_rs = SvREFCNT_inc(PL_nrs);
79072805
LW
1765 break;
1766 case '\\':
3280af22
NIS
1767 if (PL_ors)
1768 Safefree(PL_ors);
e3c19b7b 1769 if (SvOK(sv) || SvGMAGICAL(sv))
3280af22 1770 PL_ors = savepv(SvPV(sv,PL_orslen));
e3c19b7b 1771 else {
3280af22
NIS
1772 PL_ors = Nullch;
1773 PL_orslen = 0;
e3c19b7b 1774 }
79072805
LW
1775 break;
1776 case ',':
3280af22
NIS
1777 if (PL_ofs)
1778 Safefree(PL_ofs);
1779 PL_ofs = savepv(SvPV(sv, PL_ofslen));
79072805
LW
1780 break;
1781 case '#':
3280af22
NIS
1782 if (PL_ofmt)
1783 Safefree(PL_ofmt);
1784 PL_ofmt = savepv(SvPV(sv,PL_na));
79072805
LW
1785 break;
1786 case '[':
3280af22 1787 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1788 break;
1789 case '?':
ff0cee69 1790#ifdef COMPLEX_STATUS
6b88bc9c
GS
1791 if (PL_localizing == 2) {
1792 PL_statusvalue = LvTARGOFF(sv);
1793 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
1794 }
1795 else
1796#endif
1797#ifdef VMSISH_STATUS
1798 if (VMSISH_STATUS)
1799 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1800 else
1801#endif
1802 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1803 break;
1804 case '!':
78987ded 1805 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
f86702cc 1806 (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
79072805
LW
1807 break;
1808 case '<':
3280af22
NIS
1809 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1810 if (PL_delaymagic) {
1811 PL_delaymagic |= DM_RUID;
79072805
LW
1812 break; /* don't do magic till later */
1813 }
1814#ifdef HAS_SETRUID
b28d0864 1815 (void)setruid((Uid_t)PL_uid);
79072805
LW
1816#else
1817#ifdef HAS_SETREUID
3280af22 1818 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 1819#else
85e6fe83 1820#ifdef HAS_SETRESUID
b28d0864 1821 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 1822#else
b28d0864
NIS
1823 if (PL_uid == PL_euid) /* special case $< = $> */
1824 (void)PerlProc_setuid(PL_uid);
a0d0e21e 1825 else {
b28d0864 1826 PL_uid = (I32)PerlProc_getuid();
463ee0b2 1827 croak("setruid() not implemented");
a0d0e21e 1828 }
79072805
LW
1829#endif
1830#endif
85e6fe83 1831#endif
3280af22
NIS
1832 PL_uid = (I32)PerlProc_getuid();
1833 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1834 break;
1835 case '>':
3280af22
NIS
1836 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1837 if (PL_delaymagic) {
1838 PL_delaymagic |= DM_EUID;
79072805
LW
1839 break; /* don't do magic till later */
1840 }
1841#ifdef HAS_SETEUID
3280af22 1842 (void)seteuid((Uid_t)PL_euid);
79072805
LW
1843#else
1844#ifdef HAS_SETREUID
b28d0864 1845 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
1846#else
1847#ifdef HAS_SETRESUID
6b88bc9c 1848 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 1849#else
b28d0864
NIS
1850 if (PL_euid == PL_uid) /* special case $> = $< */
1851 PerlProc_setuid(PL_euid);
a0d0e21e 1852 else {
b28d0864 1853 PL_euid = (I32)PerlProc_geteuid();
463ee0b2 1854 croak("seteuid() not implemented");
a0d0e21e 1855 }
79072805
LW
1856#endif
1857#endif
85e6fe83 1858#endif
3280af22
NIS
1859 PL_euid = (I32)PerlProc_geteuid();
1860 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1861 break;
1862 case '(':
3280af22
NIS
1863 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1864 if (PL_delaymagic) {
1865 PL_delaymagic |= DM_RGID;
79072805
LW
1866 break; /* don't do magic till later */
1867 }
1868#ifdef HAS_SETRGID
b28d0864 1869 (void)setrgid((Gid_t)PL_gid);
79072805
LW
1870#else
1871#ifdef HAS_SETREGID
3280af22 1872 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
1873#else
1874#ifdef HAS_SETRESGID
b28d0864 1875 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 1876#else
b28d0864
NIS
1877 if (PL_gid == PL_egid) /* special case $( = $) */
1878 (void)PerlProc_setgid(PL_gid);
748a9306 1879 else {
b28d0864 1880 PL_gid = (I32)PerlProc_getgid();
463ee0b2 1881 croak("setrgid() not implemented");
748a9306 1882 }
79072805
LW
1883#endif
1884#endif
85e6fe83 1885#endif
3280af22
NIS
1886 PL_gid = (I32)PerlProc_getgid();
1887 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1888 break;
1889 case ')':
5cd24f17
PP
1890#ifdef HAS_SETGROUPS
1891 {
3280af22 1892 char *p = SvPV(sv, PL_na);
5cd24f17
PP
1893 Groups_t gary[NGROUPS];
1894
1895 SET_NUMERIC_STANDARD();
1896 while (isSPACE(*p))
1897 ++p;
3280af22 1898 PL_egid = I_V(atof(p));
5cd24f17
PP
1899 for (i = 0; i < NGROUPS; ++i) {
1900 while (*p && !isSPACE(*p))
1901 ++p;
1902 while (isSPACE(*p))
1903 ++p;
1904 if (!*p)
1905 break;
1906 gary[i] = I_V(atof(p));
1907 }
8cc95fdb
PP
1908 if (i)
1909 (void)setgroups(i, gary);
5cd24f17
PP
1910 }
1911#else /* HAS_SETGROUPS */
b28d0864 1912 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 1913#endif /* HAS_SETGROUPS */
3280af22
NIS
1914 if (PL_delaymagic) {
1915 PL_delaymagic |= DM_EGID;
79072805
LW
1916 break; /* don't do magic till later */
1917 }
1918#ifdef HAS_SETEGID
3280af22 1919 (void)setegid((Gid_t)PL_egid);
79072805
LW
1920#else
1921#ifdef HAS_SETREGID
b28d0864 1922 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
1923#else
1924#ifdef HAS_SETRESGID
b28d0864 1925 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 1926#else
b28d0864
NIS
1927 if (PL_egid == PL_gid) /* special case $) = $( */
1928 (void)PerlProc_setgid(PL_egid);
748a9306 1929 else {
b28d0864 1930 PL_egid = (I32)PerlProc_getegid();
463ee0b2 1931 croak("setegid() not implemented");
748a9306 1932 }
79072805
LW
1933#endif
1934#endif
85e6fe83 1935#endif
3280af22
NIS
1936 PL_egid = (I32)PerlProc_getegid();
1937 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
1938 break;
1939 case ':':
3280af22 1940 PL_chopset = SvPV_force(sv,PL_na);
79072805
LW
1941 break;
1942 case '0':
3280af22
NIS
1943 if (!PL_origalen) {
1944 s = PL_origargv[0];
79072805
LW
1945 s += strlen(s);
1946 /* See if all the arguments are contiguous in memory */
3280af22
NIS
1947 for (i = 1; i < PL_origargc; i++) {
1948 if (PL_origargv[i] == s + 1
fb73857a 1949#ifdef OS2
6b88bc9c 1950 || PL_origargv[i] == s + 2
fb73857a
PP
1951#endif
1952 )
379c4362
GS
1953 {
1954 ++s;
1955 s += strlen(s); /* this one is ok too */
1956 }
fb73857a
PP
1957 else
1958 break;
79072805 1959 }
bbce6d69 1960 /* can grab env area too? */
3280af22 1961 if (PL_origenviron && (PL_origenviron[0] == s + 1
fb73857a 1962#ifdef OS2
6b88bc9c 1963 || (PL_origenviron[0] == s + 9 && (s += 8))
fb73857a
PP
1964#endif
1965 )) {
66b1d557 1966 my_setenv("NoNe SuCh", Nullch);
79072805 1967 /* force copy of environment */
3280af22 1968 for (i = 0; PL_origenviron[i]; i++)
379c4362
GS
1969 if (PL_origenviron[i] == s + 1) {
1970 ++s;
1971 s += strlen(s);
1972 }
fb73857a
PP
1973 else
1974 break;
79072805 1975 }
3280af22 1976 PL_origalen = s - PL_origargv[0];
79072805 1977 }
a0d0e21e 1978 s = SvPV_force(sv,len);
8990e307 1979 i = len;
3280af22
NIS
1980 if (i >= PL_origalen) {
1981 i = PL_origalen;
fb73857a
PP
1982 /* don't allow system to limit $0 seen by script */
1983 /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
3280af22
NIS
1984 Copy(s, PL_origargv[0], i, char);
1985 s = PL_origargv[0]+i;
fb73857a 1986 *s = '\0';
79072805
LW
1987 }
1988 else {
3280af22
NIS
1989 Copy(s, PL_origargv[0], i, char);
1990 s = PL_origargv[0]+i;
79072805 1991 *s++ = '\0';
3280af22 1992 while (++i < PL_origalen)
8990e307 1993 *s++ = ' ';
3280af22
NIS
1994 s = PL_origargv[0]+i;
1995 for (i = 1; i < PL_origargc; i++)
1996 PL_origargv[i] = Nullch;
79072805
LW
1997 }
1998 break;
a863c7d1
MB
1999#ifdef USE_THREADS
2000 case '@':
38a03e6e 2001 sv_setsv(thr->errsv, sv);
a863c7d1
MB
2002 break;
2003#endif /* USE_THREADS */
79072805
LW
2004 }
2005 return 0;
2006}
2007
f93b4edd
MB
2008#ifdef USE_THREADS
2009int
8ac85365 2010magic_mutexfree(SV *sv, MAGIC *mg)
f93b4edd
MB
2011{
2012 dTHR;
8b73bbec 2013 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n",
bc1f4c86 2014 (unsigned long)thr, (unsigned long)sv);)
f93b4edd
MB
2015 if (MgOWNER(mg))
2016 croak("panic: magic_mutexfree");
2017 MUTEX_DESTROY(MgMUTEXP(mg));
2018 COND_DESTROY(MgCONDP(mg));
2019 return 0;
2020}
2021#endif /* USE_THREADS */
2022
79072805 2023I32
8ac85365 2024whichsig(char *sig)
79072805
LW
2025{
2026 register char **sigv;
2027
22c35a8c 2028 for (sigv = PL_sig_name+1; *sigv; sigv++)
79072805 2029 if (strEQ(sig,*sigv))
22c35a8c 2030 return PL_sig_num[sigv - PL_sig_name];
79072805
LW
2031#ifdef SIGCLD
2032 if (strEQ(sig,"CHLD"))
2033 return SIGCLD;
2034#endif
2035#ifdef SIGCHLD
2036 if (strEQ(sig,"CLD"))
2037 return SIGCHLD;
2038#endif
2039 return 0;
2040}
2041
84902520
TB
2042static SV* sig_sv;
2043
76e3520e 2044STATIC void
8ac85365 2045unwind_handler_stack(void *p)
84902520 2046{
ff26ac79 2047 dTHR;
84902520
TB
2048 U32 flags = *(U32*)p;
2049
2050 if (flags & 1)
3280af22 2051 PL_savestack_ix -= 5; /* Unprotect save in progress. */
84902520
TB
2052 /* cxstack_ix-- Not needed, die already unwound it. */
2053 if (flags & 64)
2054 SvREFCNT_dec(sig_sv);
2055}
2056
ecfc5424 2057Signal_t
8ac85365 2058sighandler(int sig)
79072805
LW
2059{
2060 dSP;
00d579c5 2061 GV *gv = Nullgv;
a0d0e21e 2062 HV *st;
3280af22 2063 SV *sv, *tSv = PL_Sv;
00d579c5 2064 CV *cv = Nullcv;
533c011a 2065 OP *myop = PL_op;
84902520 2066 U32 flags = 0;
3280af22
NIS
2067 I32 o_save_i = PL_savestack_ix, type;
2068 XPV *tXpv = PL_Xpv;
84902520 2069
3280af22 2070 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2071 flags |= 1;
3280af22 2072 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2073 flags |= 4;
3280af22 2074 if (PL_retstack_ix < PL_retstack_max - 2)
84902520 2075 flags |= 8;
3280af22 2076 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2077 flags |= 16;
2078
22c35a8c 2079 if (!PL_psig_ptr[sig])
ff0cee69 2080 die("Signal SIG%s received, but no signal handler set.\n",
22c35a8c 2081 PL_sig_name[sig]);
ff0cee69 2082
84902520
TB
2083 /* Max number of items pushed there is 3*n or 4. We cannot fix
2084 infinity, so we fix 4 (in fact 5): */
2085 if (flags & 1) {
3280af22
NIS
2086 PL_savestack_ix += 5; /* Protect save in progress. */
2087 o_save_i = PL_savestack_ix;
565764a8 2088 SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags);
84902520
TB
2089 }
2090 if (flags & 4)
3280af22 2091 PL_markstack_ptr++; /* Protect mark. */
84902520 2092 if (flags & 8) {
3280af22
NIS
2093 PL_retstack_ix++;
2094 PL_retstack[PL_retstack_ix] = NULL;
84902520
TB
2095 }
2096 if (flags & 16)
3280af22 2097 PL_scopestack_ix += 1;
84902520 2098 /* sv_2cv is too complicated, try a simpler variant first: */
22c35a8c 2099 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
84902520 2100 || SvTYPE(cv) != SVt_PVCV)
22c35a8c 2101 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
84902520 2102
a0d0e21e 2103 if (!cv || !CvROOT(cv)) {
599cee73
PM
2104 if (ckWARN(WARN_SIGNAL))
2105 warner(WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2106 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2107 : ((cv && CvGV(cv))
2108 ? GvENAME(CvGV(cv))
2109 : "__ANON__")));
2110 goto cleanup;
79072805
LW
2111 }
2112
22c35a8c
GS
2113 if(PL_psig_name[sig]) {
2114 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520
TB
2115 flags |= 64;
2116 sig_sv = sv;
2117 } else {
ff0cee69 2118 sv = sv_newmortal();
22c35a8c 2119 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2120 }
e336de0d 2121
e788e7d3 2122 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2123 PUSHMARK(SP);
79072805 2124 PUSHs(sv);
79072805 2125 PUTBACK;
a0d0e21e
LW
2126
2127 perl_call_sv((SV*)cv, G_DISCARD);
79072805 2128
d3acc0f7 2129 POPSTACK;
00d579c5 2130cleanup:
84902520 2131 if (flags & 1)
3280af22 2132 PL_savestack_ix -= 8; /* Unprotect save in progress. */
84902520 2133 if (flags & 4)
3280af22 2134 PL_markstack_ptr--;
84902520 2135 if (flags & 8)
3280af22 2136 PL_retstack_ix--;
84902520 2137 if (flags & 16)
3280af22 2138 PL_scopestack_ix -= 1;
84902520
TB
2139 if (flags & 64)
2140 SvREFCNT_dec(sv);
533c011a 2141 PL_op = myop; /* Apparently not needed... */
84902520 2142
3280af22
NIS
2143 PL_Sv = tSv; /* Restore global temporaries. */
2144 PL_Xpv = tXpv;
79072805
LW
2145 return;
2146}
4e35701f
NIS
2147
2148