Commit | Line | Data |
79072805 |
1 | /* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:21:48 $ |
2 | * |
3 | * Copyright (c) 1993, Larry Wall |
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 | * |
8 | * $Log: hash.c,v $ |
9 | */ |
10 | |
11 | #include "EXTERN.h" |
12 | #include "perl.h" |
13 | |
14 | int |
15 | mg_get(sv) |
16 | SV* sv; |
17 | { |
18 | MAGIC* mg; |
463ee0b2 |
19 | |
20 | SvMAGICAL_off(sv); |
21 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
22 | SvFLAGS(sv) |= SvPRIVATE(sv) & (SVf_IOK|SVf_NOK|SVf_POK); |
23 | SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
24 | |
79072805 |
25 | for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
26 | MGVTBL* vtbl = mg->mg_virtual; |
27 | if (vtbl && vtbl->svt_get) |
28 | (*vtbl->svt_get)(sv, mg); |
29 | } |
463ee0b2 |
30 | |
31 | SvMAGICAL_on(sv); |
32 | SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
33 | SvPRIVATE(sv) |= SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK); |
34 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
35 | |
79072805 |
36 | return 0; |
37 | } |
38 | |
39 | int |
40 | mg_set(sv) |
41 | SV* sv; |
42 | { |
43 | MAGIC* mg; |
463ee0b2 |
44 | MAGIC* nextmg; |
45 | |
46 | SvMAGICAL_off(sv); |
47 | |
48 | for (mg = SvMAGIC(sv); mg; mg = nextmg) { |
79072805 |
49 | MGVTBL* vtbl = mg->mg_virtual; |
463ee0b2 |
50 | nextmg = mg->mg_moremagic; /* it may delete itself */ |
79072805 |
51 | if (vtbl && vtbl->svt_set) |
52 | (*vtbl->svt_set)(sv, mg); |
53 | } |
463ee0b2 |
54 | |
55 | if (SvMAGIC(sv)) { |
56 | SvMAGICAL_on(sv); |
57 | /* SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); */ |
58 | SvPRIVATE(sv) |= SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK); |
59 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
60 | } |
61 | |
79072805 |
62 | return 0; |
63 | } |
64 | |
65 | U32 |
66 | mg_len(sv) |
67 | SV* sv; |
68 | { |
69 | MAGIC* mg; |
463ee0b2 |
70 | char *s; |
71 | STRLEN len; |
72 | |
73 | SvMAGICAL_off(sv); |
74 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
75 | SvFLAGS(sv) |= SvPRIVATE(sv) & (SVf_IOK|SVf_NOK|SVf_POK); |
76 | SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
77 | |
79072805 |
78 | for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
79 | MGVTBL* vtbl = mg->mg_virtual; |
80 | if (vtbl && vtbl->svt_len) |
81 | return (*vtbl->svt_len)(sv, mg); |
82 | } |
93a17b20 |
83 | mg_get(sv); |
463ee0b2 |
84 | s = SvPV(sv, len); |
85 | |
86 | SvMAGICAL_on(sv); |
87 | SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
88 | SvPRIVATE(sv) |= SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK); |
89 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
90 | |
91 | return len; |
79072805 |
92 | } |
93 | |
94 | int |
95 | mg_clear(sv) |
96 | SV* sv; |
97 | { |
98 | MAGIC* mg; |
463ee0b2 |
99 | |
100 | SvMAGICAL_off(sv); |
101 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
102 | SvFLAGS(sv) |= SvPRIVATE(sv) & (SVf_IOK|SVf_NOK|SVf_POK); |
103 | SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
104 | |
79072805 |
105 | for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
106 | MGVTBL* vtbl = mg->mg_virtual; |
107 | if (vtbl && vtbl->svt_clear) |
108 | (*vtbl->svt_clear)(sv, mg); |
109 | } |
463ee0b2 |
110 | |
111 | SvMAGICAL_on(sv); |
112 | SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
113 | SvPRIVATE(sv) |= SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK); |
114 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); |
115 | |
79072805 |
116 | return 0; |
117 | } |
118 | |
93a17b20 |
119 | MAGIC* |
120 | mg_find(sv, type) |
121 | SV* sv; |
122 | char type; |
123 | { |
124 | MAGIC* mg; |
93a17b20 |
125 | for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
126 | if (mg->mg_type == type) |
127 | return mg; |
128 | } |
129 | return 0; |
130 | } |
131 | |
79072805 |
132 | int |
463ee0b2 |
133 | mg_copy(sv, nsv, key, klen) |
79072805 |
134 | SV* sv; |
463ee0b2 |
135 | SV* nsv; |
136 | char *key; |
137 | STRLEN klen; |
79072805 |
138 | { |
463ee0b2 |
139 | int count = 0; |
79072805 |
140 | MAGIC* mg; |
463ee0b2 |
141 | for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
142 | if (isUPPER(mg->mg_type)) { |
143 | sv_magic(nsv, mg->mg_obj, tolower(mg->mg_type), key, klen); |
144 | count++; |
79072805 |
145 | } |
79072805 |
146 | } |
463ee0b2 |
147 | return count; |
79072805 |
148 | } |
149 | |
150 | int |
463ee0b2 |
151 | mg_free(sv) |
79072805 |
152 | SV* sv; |
153 | { |
154 | MAGIC* mg; |
155 | MAGIC* moremagic; |
156 | for (mg = SvMAGIC(sv); mg; mg = moremagic) { |
157 | MGVTBL* vtbl = mg->mg_virtual; |
158 | moremagic = mg->mg_moremagic; |
159 | if (vtbl && vtbl->svt_free) |
160 | (*vtbl->svt_free)(sv, mg); |
93a17b20 |
161 | if (mg->mg_ptr && mg->mg_type != 'g') |
79072805 |
162 | Safefree(mg->mg_ptr); |
463ee0b2 |
163 | sv_free(mg->mg_obj); |
79072805 |
164 | Safefree(mg); |
165 | } |
166 | SvMAGIC(sv) = 0; |
167 | return 0; |
168 | } |
169 | |
170 | #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) |
171 | #include <signal.h> |
172 | #endif |
173 | |
174 | #ifdef VOIDSIG |
175 | #define handlertype void |
176 | #else |
177 | #define handlertype int |
178 | #endif |
179 | |
180 | static handlertype sighandler(); |
181 | |
93a17b20 |
182 | U32 |
183 | magic_len(sv, mg) |
184 | SV *sv; |
185 | MAGIC *mg; |
186 | { |
187 | register I32 paren; |
188 | register char *s; |
189 | register I32 i; |
190 | |
191 | switch (*mg->mg_ptr) { |
192 | case '1': case '2': case '3': case '4': |
193 | case '5': case '6': case '7': case '8': case '9': case '&': |
194 | if (curpm) { |
195 | paren = atoi(mg->mg_ptr); |
196 | getparen: |
197 | if (curpm->op_pmregexp && |
198 | paren <= curpm->op_pmregexp->nparens && |
199 | (s = curpm->op_pmregexp->startp[paren]) ) { |
200 | i = curpm->op_pmregexp->endp[paren] - s; |
201 | if (i >= 0) |
202 | return i; |
203 | else |
204 | return 0; |
205 | } |
206 | else |
207 | return 0; |
208 | } |
209 | break; |
210 | case '+': |
211 | if (curpm) { |
212 | paren = curpm->op_pmregexp->lastparen; |
213 | goto getparen; |
214 | } |
215 | break; |
216 | case '`': |
217 | if (curpm) { |
218 | if (curpm->op_pmregexp && |
219 | (s = curpm->op_pmregexp->subbeg) ) { |
220 | i = curpm->op_pmregexp->startp[0] - s; |
221 | if (i >= 0) |
222 | return i; |
223 | else |
224 | return 0; |
225 | } |
226 | else |
227 | return 0; |
228 | } |
229 | break; |
230 | case '\'': |
231 | if (curpm) { |
232 | if (curpm->op_pmregexp && |
233 | (s = curpm->op_pmregexp->endp[0]) ) { |
234 | return (STRLEN) (curpm->op_pmregexp->subend - s); |
235 | } |
236 | else |
237 | return 0; |
238 | } |
239 | break; |
240 | case ',': |
241 | return (STRLEN)ofslen; |
242 | case '\\': |
243 | return (STRLEN)orslen; |
244 | } |
245 | magic_get(sv,mg); |
246 | if (!SvPOK(sv) && SvNIOK(sv)) |
463ee0b2 |
247 | sv_2pv(sv, &na); |
93a17b20 |
248 | if (SvPOK(sv)) |
249 | return SvCUR(sv); |
250 | return 0; |
251 | } |
252 | |
79072805 |
253 | int |
254 | magic_get(sv, mg) |
255 | SV *sv; |
256 | MAGIC *mg; |
257 | { |
258 | register I32 paren; |
259 | register char *s; |
260 | register I32 i; |
261 | |
262 | switch (*mg->mg_ptr) { |
263 | case '\004': /* ^D */ |
264 | sv_setiv(sv,(I32)(debug & 32767)); |
265 | break; |
266 | case '\006': /* ^F */ |
267 | sv_setiv(sv,(I32)maxsysfd); |
268 | break; |
269 | case '\t': /* ^I */ |
270 | if (inplace) |
271 | sv_setpv(sv, inplace); |
272 | else |
273 | sv_setsv(sv,&sv_undef); |
274 | break; |
275 | case '\020': /* ^P */ |
276 | sv_setiv(sv,(I32)perldb); |
277 | break; |
278 | case '\024': /* ^T */ |
279 | sv_setiv(sv,(I32)basetime); |
280 | break; |
281 | case '\027': /* ^W */ |
282 | sv_setiv(sv,(I32)dowarn); |
283 | break; |
284 | case '1': case '2': case '3': case '4': |
285 | case '5': case '6': case '7': case '8': case '9': case '&': |
286 | if (curpm) { |
287 | paren = atoi(GvENAME(mg->mg_obj)); |
288 | getparen: |
289 | if (curpm->op_pmregexp && |
290 | paren <= curpm->op_pmregexp->nparens && |
291 | (s = curpm->op_pmregexp->startp[paren]) ) { |
292 | i = curpm->op_pmregexp->endp[paren] - s; |
293 | if (i >= 0) |
294 | sv_setpvn(sv,s,i); |
295 | else |
296 | sv_setsv(sv,&sv_undef); |
297 | } |
298 | else |
299 | sv_setsv(sv,&sv_undef); |
300 | } |
301 | break; |
302 | case '+': |
303 | if (curpm) { |
304 | paren = curpm->op_pmregexp->lastparen; |
305 | goto getparen; |
306 | } |
307 | break; |
308 | case '`': |
309 | if (curpm) { |
310 | if (curpm->op_pmregexp && |
311 | (s = curpm->op_pmregexp->subbeg) ) { |
312 | i = curpm->op_pmregexp->startp[0] - s; |
313 | if (i >= 0) |
314 | sv_setpvn(sv,s,i); |
315 | else |
316 | sv_setpvn(sv,"",0); |
317 | } |
318 | else |
319 | sv_setpvn(sv,"",0); |
320 | } |
321 | break; |
322 | case '\'': |
323 | if (curpm) { |
324 | if (curpm->op_pmregexp && |
325 | (s = curpm->op_pmregexp->endp[0]) ) { |
326 | sv_setpvn(sv,s, curpm->op_pmregexp->subend - s); |
327 | } |
328 | else |
329 | sv_setpvn(sv,"",0); |
330 | } |
331 | break; |
332 | case '.': |
333 | #ifndef lint |
334 | if (last_in_gv && GvIO(last_in_gv)) { |
335 | sv_setiv(sv,(I32)GvIO(last_in_gv)->lines); |
336 | } |
337 | #endif |
338 | break; |
339 | case '?': |
340 | sv_setiv(sv,(I32)statusvalue); |
341 | break; |
342 | case '^': |
343 | s = GvIO(defoutgv)->top_name; |
344 | if (s) |
345 | sv_setpv(sv,s); |
346 | else { |
347 | sv_setpv(sv,GvENAME(defoutgv)); |
348 | sv_catpv(sv,"_TOP"); |
349 | } |
350 | break; |
351 | case '~': |
352 | s = GvIO(defoutgv)->fmt_name; |
353 | if (!s) |
354 | s = GvENAME(defoutgv); |
355 | sv_setpv(sv,s); |
356 | break; |
357 | #ifndef lint |
358 | case '=': |
359 | sv_setiv(sv,(I32)GvIO(defoutgv)->page_len); |
360 | break; |
361 | case '-': |
362 | sv_setiv(sv,(I32)GvIO(defoutgv)->lines_left); |
363 | break; |
364 | case '%': |
365 | sv_setiv(sv,(I32)GvIO(defoutgv)->page); |
366 | break; |
367 | #endif |
368 | case ':': |
369 | break; |
370 | case '/': |
371 | break; |
372 | case '[': |
373 | sv_setiv(sv,(I32)arybase); |
374 | break; |
375 | case '|': |
376 | if (!GvIO(defoutgv)) |
377 | GvIO(defoutgv) = newIO(); |
378 | sv_setiv(sv, (GvIO(defoutgv)->flags & IOf_FLUSH) != 0 ); |
379 | break; |
380 | case ',': |
381 | sv_setpvn(sv,ofs,ofslen); |
382 | break; |
383 | case '\\': |
384 | sv_setpvn(sv,ors,orslen); |
385 | break; |
386 | case '#': |
387 | sv_setpv(sv,ofmt); |
388 | break; |
389 | case '!': |
390 | sv_setnv(sv,(double)errno); |
391 | sv_setpv(sv, errno ? strerror(errno) : ""); |
392 | SvNOK_on(sv); /* what a wonderful hack! */ |
393 | break; |
394 | case '<': |
395 | sv_setiv(sv,(I32)uid); |
396 | break; |
397 | case '>': |
398 | sv_setiv(sv,(I32)euid); |
399 | break; |
400 | case '(': |
401 | s = buf; |
402 | (void)sprintf(s,"%d",(int)gid); |
403 | goto add_groups; |
404 | case ')': |
405 | s = buf; |
406 | (void)sprintf(s,"%d",(int)egid); |
407 | add_groups: |
408 | while (*s) s++; |
409 | #ifdef HAS_GETGROUPS |
410 | #ifndef NGROUPS |
411 | #define NGROUPS 32 |
412 | #endif |
413 | { |
414 | GROUPSTYPE gary[NGROUPS]; |
415 | |
416 | i = getgroups(NGROUPS,gary); |
417 | while (--i >= 0) { |
418 | (void)sprintf(s," %ld", (long)gary[i]); |
419 | while (*s) s++; |
420 | } |
421 | } |
422 | #endif |
423 | sv_setpv(sv,buf); |
424 | break; |
425 | case '*': |
426 | break; |
427 | case '0': |
428 | break; |
429 | } |
430 | } |
431 | |
432 | int |
433 | magic_getuvar(sv, mg) |
434 | SV *sv; |
435 | MAGIC *mg; |
436 | { |
437 | struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr; |
438 | |
439 | if (uf && uf->uf_val) |
440 | (*uf->uf_val)(uf->uf_index, sv); |
441 | return 0; |
442 | } |
443 | |
444 | int |
445 | magic_setenv(sv,mg) |
446 | SV* sv; |
447 | MAGIC* mg; |
448 | { |
449 | register char *s; |
450 | I32 i; |
463ee0b2 |
451 | s = SvPVX(sv); |
79072805 |
452 | my_setenv(mg->mg_ptr,s); |
453 | /* And you'll never guess what the dog had */ |
454 | /* in its mouth... */ |
463ee0b2 |
455 | if (tainting) { |
456 | if (s && strEQ(mg->mg_ptr,"PATH")) { |
457 | char *strend = SvEND(sv); |
458 | |
459 | while (s < strend) { |
460 | s = cpytill(tokenbuf,s,strend,':',&i); |
461 | s++; |
462 | if (*tokenbuf != '/' |
463 | || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) ) |
464 | SvPRIVATE(sv) |= SVp_TAINTEDDIR; |
465 | } |
79072805 |
466 | } |
467 | } |
79072805 |
468 | return 0; |
469 | } |
470 | |
471 | int |
472 | magic_setsig(sv,mg) |
473 | SV* sv; |
474 | MAGIC* mg; |
475 | { |
476 | register char *s; |
477 | I32 i; |
463ee0b2 |
478 | s = SvPVX(sv); |
79072805 |
479 | i = whichsig(mg->mg_ptr); /* ...no, a brick */ |
480 | if (!i && (dowarn || strEQ(mg->mg_ptr,"ALARM"))) |
481 | warn("No such signal: SIG%s", mg->mg_ptr); |
482 | if (strEQ(s,"IGNORE")) |
483 | #ifndef lint |
484 | (void)signal(i,SIG_IGN); |
485 | #else |
486 | ; |
487 | #endif |
488 | else if (strEQ(s,"DEFAULT") || !*s) |
489 | (void)signal(i,SIG_DFL); |
490 | else { |
491 | (void)signal(i,sighandler); |
93a17b20 |
492 | if (!strchr(s,'\'')) { |
79072805 |
493 | sprintf(tokenbuf, "main'%s",s); |
494 | sv_setpv(sv,tokenbuf); |
495 | } |
496 | } |
497 | return 0; |
498 | } |
499 | |
500 | int |
463ee0b2 |
501 | magic_setisa(sv,mg) |
79072805 |
502 | SV* sv; |
503 | MAGIC* mg; |
504 | { |
463ee0b2 |
505 | sub_generation++; |
506 | return 0; |
507 | } |
508 | |
509 | int |
510 | magic_getpack(sv,mg) |
511 | SV* sv; |
512 | MAGIC* mg; |
513 | { |
514 | SV* rv = mg->mg_obj; |
515 | HV* stash = SvSTASH((SV*)SvANY(rv)); |
516 | GV* gv = gv_fetchmethod(stash, "fetch"); |
517 | dSP; |
518 | BINOP myop; |
519 | |
520 | if (!gv || !GvCV(gv)) { |
521 | croak("No fetch method for magical variable in package \"%s\"", |
522 | HvNAME(stash)); |
523 | } |
524 | Zero(&myop, 1, BINOP); |
525 | myop.op_last = (OP *) &myop; |
526 | myop.op_next = Nullop; |
527 | myop.op_flags = OPf_STACKED; |
528 | |
529 | ENTER; |
530 | SAVESPTR(op); |
531 | op = (OP *) &myop; |
532 | PUTBACK; |
533 | pp_pushmark(); |
534 | |
535 | EXTEND(sp, 4); |
536 | PUSHs(gv); |
537 | PUSHs(rv); |
538 | if (mg->mg_ptr) |
539 | PUSHs(sv_mortalcopy(newSVpv(mg->mg_ptr, mg->mg_len))); |
540 | else if (mg->mg_len >= 0) |
541 | PUSHs(sv_mortalcopy(newSViv(mg->mg_len))); |
542 | PUTBACK; |
543 | |
544 | if (op = pp_entersubr()) |
545 | run(); |
546 | LEAVE; |
547 | SPAGAIN; |
548 | |
549 | sv_setsv(sv, POPs); |
550 | PUTBACK; |
551 | |
552 | return 0; |
553 | } |
554 | |
555 | int |
556 | magic_setpack(sv,mg) |
557 | SV* sv; |
558 | MAGIC* mg; |
559 | { |
560 | SV* rv = mg->mg_obj; |
561 | HV* stash = SvSTASH((SV*)SvANY(rv)); |
562 | GV* gv = gv_fetchmethod(stash, "store"); |
563 | dSP; |
564 | BINOP myop; |
565 | |
566 | if (!gv || !GvCV(gv)) { |
567 | croak("No store method for magical variable in package \"%s\"", |
568 | HvNAME(stash)); |
569 | } |
570 | Zero(&myop, 1, BINOP); |
571 | myop.op_last = (OP *) &myop; |
572 | myop.op_next = Nullop; |
573 | myop.op_flags = OPf_STACKED; |
574 | |
575 | ENTER; |
576 | SAVESPTR(op); |
577 | op = (OP *) &myop; |
578 | PUTBACK; |
579 | pp_pushmark(); |
580 | |
581 | EXTEND(sp, 4); |
582 | PUSHs(gv); |
583 | PUSHs(rv); |
584 | if (mg->mg_ptr) |
585 | PUSHs(sv_mortalcopy(newSVpv(mg->mg_ptr, mg->mg_len))); |
586 | else if (mg->mg_len >= 0) |
587 | PUSHs(sv_mortalcopy(newSViv(mg->mg_len))); |
588 | PUSHs(sv); |
589 | PUTBACK; |
590 | |
591 | if (op = pp_entersubr()) |
592 | run(); |
593 | LEAVE; |
594 | SPAGAIN; |
595 | |
596 | POPs; |
597 | PUTBACK; |
598 | |
599 | return 0; |
600 | } |
601 | |
602 | int |
603 | magic_clearpack(sv,mg) |
604 | SV* sv; |
605 | MAGIC* mg; |
606 | { |
607 | SV* rv = mg->mg_obj; |
608 | HV* stash = SvSTASH((SV*)SvANY(rv)); |
609 | GV* gv = gv_fetchmethod(stash, "delete"); |
610 | dSP; |
611 | BINOP myop; |
612 | |
613 | if (!gv || !GvCV(gv)) { |
614 | croak("No delete method for magical variable in package \"%s\"", |
615 | HvNAME(stash)); |
616 | } |
617 | Zero(&myop, 1, BINOP); |
618 | myop.op_last = (OP *) &myop; |
619 | myop.op_next = Nullop; |
620 | myop.op_flags = OPf_STACKED; |
621 | |
622 | ENTER; |
623 | SAVESPTR(op); |
624 | op = (OP *) &myop; |
625 | PUTBACK; |
626 | pp_pushmark(); |
627 | |
628 | EXTEND(sp, 4); |
629 | PUSHs(gv); |
630 | PUSHs(rv); |
631 | if (mg->mg_ptr) |
632 | PUSHs(sv_mortalcopy(newSVpv(mg->mg_ptr, mg->mg_len))); |
633 | else |
634 | PUSHs(sv_mortalcopy(newSViv(mg->mg_len))); |
635 | PUTBACK; |
636 | |
637 | if (op = pp_entersubr()) |
638 | run(); |
639 | LEAVE; |
640 | SPAGAIN; |
641 | |
642 | sv_setsv(sv, POPs); |
643 | PUTBACK; |
644 | |
645 | return 0; |
646 | } |
647 | |
648 | int |
649 | magic_nextpack(sv,mg,key) |
650 | SV* sv; |
651 | MAGIC* mg; |
652 | SV* key; |
653 | { |
654 | SV* rv = mg->mg_obj; |
655 | HV* stash = SvSTASH((SV*)SvANY(rv)); |
656 | GV* gv = gv_fetchmethod(stash, SvOK(key) ? "nextkey" : "firstkey"); |
657 | dSP; |
658 | BINOP myop; |
659 | |
660 | if (!gv || !GvCV(gv)) { |
661 | croak("No fetch method for magical variable in package \"%s\"", |
662 | HvNAME(stash)); |
663 | } |
664 | Zero(&myop, 1, BINOP); |
665 | myop.op_last = (OP *) &myop; |
666 | myop.op_next = Nullop; |
667 | myop.op_flags = OPf_STACKED; |
668 | |
669 | ENTER; |
670 | SAVESPTR(op); |
671 | op = (OP *) &myop; |
672 | PUTBACK; |
673 | pp_pushmark(); |
674 | |
675 | EXTEND(sp, 4); |
676 | PUSHs(gv); |
677 | PUSHs(rv); |
678 | if (SvOK(key)) |
679 | PUSHs(key); |
680 | PUTBACK; |
681 | |
682 | if (op = pp_entersubr()) |
683 | run(); |
684 | LEAVE; |
685 | SPAGAIN; |
686 | |
687 | sv_setsv(key, POPs); |
688 | PUTBACK; |
689 | |
79072805 |
690 | return 0; |
691 | } |
692 | |
693 | int |
694 | magic_setdbline(sv,mg) |
695 | SV* sv; |
696 | MAGIC* mg; |
697 | { |
698 | OP *o; |
699 | I32 i; |
700 | GV* gv; |
701 | SV** svp; |
702 | |
703 | gv = DBline; |
704 | i = SvTRUE(sv); |
705 | svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE); |
93a17b20 |
706 | if (svp && SvIOK(*svp) && (o = (OP*)SvSTASH(*svp))) |
707 | o->op_private = i; |
79072805 |
708 | else |
709 | warn("Can't break at that line\n"); |
710 | return 0; |
711 | } |
712 | |
713 | int |
714 | magic_getarylen(sv,mg) |
715 | SV* sv; |
716 | MAGIC* mg; |
717 | { |
718 | sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + arybase); |
719 | return 0; |
720 | } |
721 | |
722 | int |
723 | magic_setarylen(sv,mg) |
724 | SV* sv; |
725 | MAGIC* mg; |
726 | { |
463ee0b2 |
727 | av_fill((AV*)mg->mg_obj, (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) - arybase); |
79072805 |
728 | return 0; |
729 | } |
730 | |
731 | int |
732 | magic_getglob(sv,mg) |
733 | SV* sv; |
734 | MAGIC* mg; |
735 | { |
736 | gv_efullname(sv,((GV*)sv));/* a gv value, be nice */ |
737 | return 0; |
738 | } |
739 | |
740 | int |
741 | magic_setglob(sv,mg) |
742 | SV* sv; |
743 | MAGIC* mg; |
744 | { |
745 | register char *s; |
746 | GV* gv; |
747 | |
748 | if (!SvOK(sv)) |
749 | return 0; |
463ee0b2 |
750 | s = SvPV(sv, na); |
79072805 |
751 | if (*s == '*' && s[1]) |
752 | s++; |
753 | gv = gv_fetchpv(s,TRUE); |
754 | if (sv == (SV*)gv) |
755 | return 0; |
756 | if (GvGP(sv)) |
757 | gp_free(sv); |
758 | GvGP(sv) = gp_ref(GvGP(gv)); |
759 | if (!GvAV(gv)) |
760 | gv_AVadd(gv); |
761 | if (!GvHV(gv)) |
762 | gv_HVadd(gv); |
763 | if (!GvIO(gv)) |
764 | GvIO(gv) = newIO(); |
765 | return 0; |
766 | } |
767 | |
768 | int |
769 | magic_setsubstr(sv,mg) |
770 | SV* sv; |
771 | MAGIC* mg; |
772 | { |
463ee0b2 |
773 | char *tmps = SvPVX(sv); |
79072805 |
774 | if (!tmps) |
775 | tmps = ""; |
776 | sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps,SvCUR(sv)); |
777 | return 0; |
778 | } |
779 | |
780 | int |
463ee0b2 |
781 | magic_gettaint(sv,mg) |
782 | SV* sv; |
783 | MAGIC* mg; |
784 | { |
785 | tainted = TRUE; |
786 | return 0; |
787 | } |
788 | |
789 | int |
790 | magic_settaint(sv,mg) |
791 | SV* sv; |
792 | MAGIC* mg; |
793 | { |
794 | if (!tainted) |
795 | sv_unmagic(sv, 't'); |
796 | return 0; |
797 | } |
798 | |
799 | int |
79072805 |
800 | magic_setvec(sv,mg) |
801 | SV* sv; |
802 | MAGIC* mg; |
803 | { |
804 | do_vecset(sv); /* XXX slurp this routine */ |
805 | return 0; |
806 | } |
807 | |
808 | int |
93a17b20 |
809 | magic_setmglob(sv,mg) |
810 | SV* sv; |
811 | MAGIC* mg; |
812 | { |
813 | mg->mg_ptr = 0; |
814 | mg->mg_len = 0; |
815 | return 0; |
816 | } |
817 | |
818 | int |
79072805 |
819 | magic_setbm(sv,mg) |
820 | SV* sv; |
821 | MAGIC* mg; |
822 | { |
463ee0b2 |
823 | sv_unmagic(sv, 'B'); |
79072805 |
824 | SvVALID_off(sv); |
825 | return 0; |
826 | } |
827 | |
828 | int |
829 | magic_setuvar(sv,mg) |
830 | SV* sv; |
831 | MAGIC* mg; |
832 | { |
833 | struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr; |
834 | |
835 | if (uf && uf->uf_set) |
836 | (*uf->uf_set)(uf->uf_index, sv); |
837 | return 0; |
838 | } |
839 | |
840 | int |
841 | magic_set(sv,mg) |
842 | SV* sv; |
843 | MAGIC* mg; |
844 | { |
845 | register char *s; |
846 | I32 i; |
847 | switch (*mg->mg_ptr) { |
848 | case '\004': /* ^D */ |
463ee0b2 |
849 | debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 32768; |
79072805 |
850 | DEBUG_x(dump_all()); |
851 | break; |
852 | case '\006': /* ^F */ |
463ee0b2 |
853 | maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); |
79072805 |
854 | break; |
855 | case '\t': /* ^I */ |
856 | if (inplace) |
857 | Safefree(inplace); |
858 | if (SvOK(sv)) |
463ee0b2 |
859 | inplace = savestr(SvPVX(sv)); |
79072805 |
860 | else |
861 | inplace = Nullch; |
862 | break; |
863 | case '\020': /* ^P */ |
463ee0b2 |
864 | i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); |
79072805 |
865 | if (i != perldb) { |
866 | if (perldb) |
867 | oldlastpm = curpm; |
868 | else |
869 | curpm = oldlastpm; |
870 | } |
871 | perldb = i; |
872 | break; |
873 | case '\024': /* ^T */ |
463ee0b2 |
874 | basetime = (time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); |
79072805 |
875 | break; |
876 | case '\027': /* ^W */ |
463ee0b2 |
877 | dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); |
79072805 |
878 | break; |
879 | case '.': |
880 | if (localizing) |
881 | save_sptr((SV**)&last_in_gv); |
882 | break; |
883 | case '^': |
884 | Safefree(GvIO(defoutgv)->top_name); |
463ee0b2 |
885 | GvIO(defoutgv)->top_name = s = savestr(SvPVX(sv)); |
79072805 |
886 | GvIO(defoutgv)->top_gv = gv_fetchpv(s,TRUE); |
887 | break; |
888 | case '~': |
889 | Safefree(GvIO(defoutgv)->fmt_name); |
463ee0b2 |
890 | GvIO(defoutgv)->fmt_name = s = savestr(SvPVX(sv)); |
79072805 |
891 | GvIO(defoutgv)->fmt_gv = gv_fetchpv(s,TRUE); |
892 | break; |
893 | case '=': |
463ee0b2 |
894 | GvIO(defoutgv)->page_len = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); |
79072805 |
895 | break; |
896 | case '-': |
463ee0b2 |
897 | GvIO(defoutgv)->lines_left = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); |
79072805 |
898 | if (GvIO(defoutgv)->lines_left < 0L) |
899 | GvIO(defoutgv)->lines_left = 0L; |
900 | break; |
901 | case '%': |
463ee0b2 |
902 | GvIO(defoutgv)->page = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); |
79072805 |
903 | break; |
904 | case '|': |
905 | if (!GvIO(defoutgv)) |
906 | GvIO(defoutgv) = newIO(); |
907 | GvIO(defoutgv)->flags &= ~IOf_FLUSH; |
463ee0b2 |
908 | if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) { |
79072805 |
909 | GvIO(defoutgv)->flags |= IOf_FLUSH; |
910 | } |
911 | break; |
912 | case '*': |
463ee0b2 |
913 | i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); |
79072805 |
914 | multiline = (i != 0); |
915 | break; |
916 | case '/': |
917 | if (SvPOK(sv)) { |
463ee0b2 |
918 | nrs = rs = SvPVX(sv); |
93a17b20 |
919 | nrslen = rslen = SvCUR(sv); |
79072805 |
920 | if (rspara = !rslen) { |
93a17b20 |
921 | nrs = rs = "\n\n"; |
922 | nrslen = rslen = 2; |
79072805 |
923 | } |
93a17b20 |
924 | nrschar = rschar = rs[rslen - 1]; |
79072805 |
925 | } |
926 | else { |
93a17b20 |
927 | nrschar = rschar = 0777; /* fake a non-existent char */ |
928 | nrslen = rslen = 1; |
79072805 |
929 | } |
930 | break; |
931 | case '\\': |
932 | if (ors) |
933 | Safefree(ors); |
463ee0b2 |
934 | ors = savestr(SvPVX(sv)); |
79072805 |
935 | orslen = SvCUR(sv); |
936 | break; |
937 | case ',': |
938 | if (ofs) |
939 | Safefree(ofs); |
463ee0b2 |
940 | ofs = savestr(SvPVX(sv)); |
79072805 |
941 | ofslen = SvCUR(sv); |
942 | break; |
943 | case '#': |
944 | if (ofmt) |
945 | Safefree(ofmt); |
463ee0b2 |
946 | ofmt = savestr(SvPVX(sv)); |
79072805 |
947 | break; |
948 | case '[': |
463ee0b2 |
949 | arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); |
79072805 |
950 | break; |
951 | case '?': |
463ee0b2 |
952 | statusvalue = U_S(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); |
79072805 |
953 | break; |
954 | case '!': |
463ee0b2 |
955 | errno = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); /* will anyone ever use this? */ |
79072805 |
956 | break; |
957 | case '<': |
463ee0b2 |
958 | uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); |
79072805 |
959 | if (delaymagic) { |
960 | delaymagic |= DM_RUID; |
961 | break; /* don't do magic till later */ |
962 | } |
963 | #ifdef HAS_SETRUID |
964 | (void)setruid((UIDTYPE)uid); |
965 | #else |
966 | #ifdef HAS_SETREUID |
967 | (void)setreuid((UIDTYPE)uid, (UIDTYPE)-1); |
968 | #else |
969 | if (uid == euid) /* special case $< = $> */ |
970 | (void)setuid(uid); |
971 | else |
463ee0b2 |
972 | croak("setruid() not implemented"); |
79072805 |
973 | #endif |
974 | #endif |
463ee0b2 |
975 | uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); |
976 | tainting |= (euid != uid || egid != gid); |
79072805 |
977 | break; |
978 | case '>': |
463ee0b2 |
979 | euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); |
79072805 |
980 | if (delaymagic) { |
981 | delaymagic |= DM_EUID; |
982 | break; /* don't do magic till later */ |
983 | } |
984 | #ifdef HAS_SETEUID |
985 | (void)seteuid((UIDTYPE)euid); |
986 | #else |
987 | #ifdef HAS_SETREUID |
988 | (void)setreuid((UIDTYPE)-1, (UIDTYPE)euid); |
989 | #else |
990 | if (euid == uid) /* special case $> = $< */ |
991 | setuid(euid); |
992 | else |
463ee0b2 |
993 | croak("seteuid() not implemented"); |
79072805 |
994 | #endif |
995 | #endif |
996 | euid = (I32)geteuid(); |
463ee0b2 |
997 | tainting |= (euid != uid || egid != gid); |
79072805 |
998 | break; |
999 | case '(': |
463ee0b2 |
1000 | gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); |
79072805 |
1001 | if (delaymagic) { |
1002 | delaymagic |= DM_RGID; |
1003 | break; /* don't do magic till later */ |
1004 | } |
1005 | #ifdef HAS_SETRGID |
1006 | (void)setrgid((GIDTYPE)gid); |
1007 | #else |
1008 | #ifdef HAS_SETREGID |
1009 | (void)setregid((GIDTYPE)gid, (GIDTYPE)-1); |
1010 | #else |
1011 | if (gid == egid) /* special case $( = $) */ |
1012 | (void)setgid(gid); |
1013 | else |
463ee0b2 |
1014 | croak("setrgid() not implemented"); |
79072805 |
1015 | #endif |
1016 | #endif |
1017 | gid = (I32)getgid(); |
463ee0b2 |
1018 | tainting |= (euid != uid || egid != gid); |
79072805 |
1019 | break; |
1020 | case ')': |
463ee0b2 |
1021 | egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); |
79072805 |
1022 | if (delaymagic) { |
1023 | delaymagic |= DM_EGID; |
1024 | break; /* don't do magic till later */ |
1025 | } |
1026 | #ifdef HAS_SETEGID |
1027 | (void)setegid((GIDTYPE)egid); |
1028 | #else |
1029 | #ifdef HAS_SETREGID |
1030 | (void)setregid((GIDTYPE)-1, (GIDTYPE)egid); |
1031 | #else |
1032 | if (egid == gid) /* special case $) = $( */ |
1033 | (void)setgid(egid); |
1034 | else |
463ee0b2 |
1035 | croak("setegid() not implemented"); |
79072805 |
1036 | #endif |
1037 | #endif |
1038 | egid = (I32)getegid(); |
463ee0b2 |
1039 | tainting |= (euid != uid || egid != gid); |
79072805 |
1040 | break; |
1041 | case ':': |
463ee0b2 |
1042 | chopset = SvPVX(sv); |
79072805 |
1043 | break; |
1044 | case '0': |
1045 | if (!origalen) { |
1046 | s = origargv[0]; |
1047 | s += strlen(s); |
1048 | /* See if all the arguments are contiguous in memory */ |
1049 | for (i = 1; i < origargc; i++) { |
1050 | if (origargv[i] == s + 1) |
1051 | s += strlen(++s); /* this one is ok too */ |
1052 | } |
1053 | if (origenviron[0] == s + 1) { /* can grab env area too? */ |
1054 | my_setenv("NoNeSuCh", Nullch); |
1055 | /* force copy of environment */ |
1056 | for (i = 0; origenviron[i]; i++) |
1057 | if (origenviron[i] == s + 1) |
1058 | s += strlen(++s); |
1059 | } |
1060 | origalen = s - origargv[0]; |
1061 | } |
463ee0b2 |
1062 | s = SvPVX(sv); |
79072805 |
1063 | i = SvCUR(sv); |
1064 | if (i >= origalen) { |
1065 | i = origalen; |
1066 | SvCUR_set(sv, i); |
1067 | *SvEND(sv) = '\0'; |
1068 | Copy(s, origargv[0], i, char); |
1069 | } |
1070 | else { |
1071 | Copy(s, origargv[0], i, char); |
1072 | s = origargv[0]+i; |
1073 | *s++ = '\0'; |
1074 | while (++i < origalen) |
1075 | *s++ = ' '; |
1076 | } |
1077 | break; |
1078 | } |
1079 | return 0; |
1080 | } |
1081 | |
1082 | I32 |
1083 | whichsig(sig) |
1084 | char *sig; |
1085 | { |
1086 | register char **sigv; |
1087 | |
1088 | for (sigv = sig_name+1; *sigv; sigv++) |
1089 | if (strEQ(sig,*sigv)) |
1090 | return sigv - sig_name; |
1091 | #ifdef SIGCLD |
1092 | if (strEQ(sig,"CHLD")) |
1093 | return SIGCLD; |
1094 | #endif |
1095 | #ifdef SIGCHLD |
1096 | if (strEQ(sig,"CLD")) |
1097 | return SIGCHLD; |
1098 | #endif |
1099 | return 0; |
1100 | } |
1101 | |
1102 | static handlertype |
1103 | sighandler(sig) |
1104 | I32 sig; |
1105 | { |
1106 | dSP; |
1107 | GV *gv; |
1108 | SV *sv; |
1109 | CV *cv; |
1110 | CONTEXT *cx; |
1111 | AV *oldstack; |
1112 | I32 hasargs = 1; |
1113 | I32 items = 1; |
1114 | I32 gimme = G_SCALAR; |
1115 | |
1116 | #ifdef OS2 /* or anybody else who requires SIG_ACK */ |
1117 | signal(sig, SIG_ACK); |
1118 | #endif |
1119 | |
1120 | gv = gv_fetchpv( |
463ee0b2 |
1121 | SvPVx(*hv_fetch(GvHVn(siggv),sig_name[sig],strlen(sig_name[sig]), |
1122 | TRUE), na), TRUE); |
79072805 |
1123 | cv = GvCV(gv); |
1124 | if (!cv && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) { |
1125 | if (sig_name[sig][1] == 'H') |
463ee0b2 |
1126 | gv = gv_fetchpv(SvPVx(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE), na), |
79072805 |
1127 | TRUE); |
1128 | else |
463ee0b2 |
1129 | gv = gv_fetchpv(SvPVx(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE), na), |
79072805 |
1130 | TRUE); |
1131 | cv = GvCV(gv); /* gag */ |
1132 | } |
1133 | if (!cv) { |
1134 | if (dowarn) |
1135 | warn("SIG%s handler \"%s\" not defined.\n", |
1136 | sig_name[sig], GvENAME(gv) ); |
1137 | return; |
1138 | } |
1139 | |
1140 | oldstack = stack; |
1141 | SWITCHSTACK(stack, signalstack); |
1142 | |
1143 | sv = sv_mortalcopy(&sv_undef); |
1144 | sv_setpv(sv,sig_name[sig]); |
1145 | PUSHs(sv); |
1146 | |
1147 | ENTER; |
1148 | SAVETMPS; |
1149 | |
1150 | push_return(op); |
1151 | push_return(0); |
1152 | PUSHBLOCK(cx, CXt_SUB, sp); |
1153 | PUSHSUB(cx); |
1154 | cx->blk_sub.savearray = GvAV(defgv); |
1155 | cx->blk_sub.argarray = av_fake(items, sp); |
1156 | GvAV(defgv) = cx->blk_sub.argarray; |
1157 | CvDEPTH(cv)++; |
1158 | if (CvDEPTH(cv) >= 2) { |
1159 | if (CvDEPTH(cv) == 100 && dowarn) |
1160 | warn("Deep recursion on subroutine \"%s\"",GvENAME(gv)); |
1161 | } |
1162 | op = CvSTART(cv); |
1163 | PUTBACK; |
1164 | run(); /* Does the LEAVE for us. */ |
1165 | |
1166 | SWITCHSTACK(signalstack, oldstack); |
1167 | op = pop_return(); |
1168 | |
1169 | return; |
1170 | } |