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