This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 9
[perl5.git] / doop.c
CommitLineData
79072805
LW
1/* $RCSfile: doarg.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:37 $
2 *
3 * Copyright (c) 1991, 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: doarg.c,v $
9 * Revision 4.1 92/08/07 17:19:37 lwall
10 * Stage 6 Snapshot
11 *
12 * Revision 4.0.1.7 92/06/11 21:07:11 lwall
13 * patch34: join with null list attempted negative allocation
14 * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd "
15 *
16 * Revision 4.0.1.6 92/06/08 12:34:30 lwall
17 * patch20: removed implicit int declarations on funcions
18 * patch20: pattern modifiers i and o didn't interact right
19 * patch20: join() now pre-extends target string to avoid excessive copying
20 * patch20: fixed confusion between a *var's real name and its effective name
21 * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly
22 * patch20: usersub routines didn't reclaim temp values soon enough
23 * patch20: ($<,$>) = ... didn't work on some architectures
24 * patch20: added Atari ST portability
25 *
26 * Revision 4.0.1.5 91/11/11 16:31:58 lwall
27 * patch19: added little-endian pack/unpack options
28 *
29 * Revision 4.0.1.4 91/11/05 16:35:06 lwall
30 * patch11: /$foo/o optimizer could access deallocated data
31 * patch11: minimum match length calculation in regexp is now cumulative
32 * patch11: added some support for 64-bit integers
33 * patch11: prepared for ctype implementations that don't define isascii()
34 * patch11: sprintf() now supports any length of s field
35 * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work
36 * patch11: defined(&$foo) and undef(&$foo) didn't work
37 *
38 * Revision 4.0.1.3 91/06/10 01:18:41 lwall
39 * patch10: pack(hh,1) dumped core
40 *
41 * Revision 4.0.1.2 91/06/07 10:42:17 lwall
42 * patch4: new copyright notice
43 * patch4: // wouldn't use previous pattern if it started with a null character
44 * patch4: //o and s///o now optimize themselves fully at runtime
45 * patch4: added global modifier for pattern matches
46 * patch4: undef @array disabled "@array" interpolation
47 * patch4: chop("") was returning "\0" rather than ""
48 * patch4: vector logical operations &, | and ^ sometimes returned null string
49 * patch4: syscall couldn't pass numbers with most significant bit set on sparcs
50 *
51 * Revision 4.0.1.1 91/04/11 17:40:14 lwall
52 * patch1: fixed undefined environ problem
53 * patch1: fixed debugger coredump on subroutines
54 *
55 * Revision 4.0 91/03/20 01:06:42 lwall
56 * 4.0 baseline.
57 *
58 */
59
60#include "EXTERN.h"
61#include "perl.h"
62
63#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
64#include <signal.h>
65#endif
66
67#ifdef BUGGY_MSC
68 #pragma function(memcmp)
69#endif /* BUGGY_MSC */
70
71static void doencodes();
72
73#ifdef BUGGY_MSC
74 #pragma intrinsic(memcmp)
75#endif /* BUGGY_MSC */
76
77I32
78do_trans(sv,arg)
79SV *sv;
80OP *arg;
81{
82 register short *tbl;
83 register char *s;
84 register I32 matches = 0;
85 register I32 ch;
86 register char *send;
87 register char *d;
88 register I32 squash = op->op_private & OPpTRANS_SQUASH;
463ee0b2 89 STRLEN len;
79072805
LW
90
91 tbl = (short*) cPVOP->op_pv;
463ee0b2
LW
92 s = SvPV(sv, len);
93 send = s + len;
79072805 94 if (!tbl || !s)
463ee0b2 95 croak("panic: do_trans");
79072805
LW
96 DEBUG_t( deb("2.TBL\n"));
97 if (!op->op_private) {
98 while (s < send) {
99 if ((ch = tbl[*s & 0377]) >= 0) {
100 matches++;
101 *s = ch;
102 }
103 s++;
104 }
105 }
106 else {
107 d = s;
108 while (s < send) {
109 if ((ch = tbl[*s & 0377]) >= 0) {
110 *d = ch;
111 if (matches++ && squash) {
112 if (d[-1] == *d)
113 matches--;
114 else
115 d++;
116 }
117 else
118 d++;
119 }
120 else if (ch == -1) /* -1 is unmapped character */
121 *d++ = *s; /* -2 is delete character */
122 s++;
123 }
124 matches += send - d; /* account for disappeared chars */
125 *d = '\0';
463ee0b2 126 SvCUR_set(sv, d - SvPVX(sv));
79072805
LW
127 }
128 SvSETMAGIC(sv);
129 return matches;
130}
131
132void
133do_join(sv,del,mark,sp)
134register SV *sv;
135SV *del;
136register SV **mark;
137register SV **sp;
138{
139 SV **oldmark = mark;
140 register I32 items = sp - mark;
79072805 141 register STRLEN len;
463ee0b2
LW
142 STRLEN delimlen;
143 register char *delim = SvPV(del, delimlen);
144 STRLEN tmplen;
79072805
LW
145
146 mark++;
147 len = (items > 0 ? (delimlen * (items - 1) ) : 0);
148 if (SvTYPE(sv) < SVt_PV)
149 sv_upgrade(sv, SVt_PV);
150 if (SvLEN(sv) < len + items) { /* current length is way too short */
151 while (items-- > 0) {
152 if (*mark) {
463ee0b2
LW
153 SvPV(*mark, tmplen);
154 len += tmplen;
79072805
LW
155 }
156 mark++;
157 }
158 SvGROW(sv, len + 1); /* so try to pre-extend */
159
160 mark = oldmark;
161 items = sp - mark;;
162 ++mark;
163 }
164
463ee0b2 165 if (items-- > 0) {
8990e307
LW
166 char *s;
167
168 if (*mark) {
169 s = SvPV(*mark, tmplen);
170 sv_setpvn(sv, s, tmplen);
171 }
172 else
173 sv_setpv(sv, "");
463ee0b2
LW
174 mark++;
175 }
79072805
LW
176 else
177 sv_setpv(sv,"");
178 len = delimlen;
179 if (len) {
180 for (; items > 0; items--,mark++) {
181 sv_catpvn(sv,delim,len);
182 sv_catsv(sv,*mark);
183 }
184 }
185 else {
186 for (; items > 0; items--,mark++)
187 sv_catsv(sv,*mark);
188 }
189 SvSETMAGIC(sv);
190}
191
192void
193do_sprintf(sv,len,sarg)
194register SV *sv;
195register I32 len;
196register SV **sarg;
197{
198 register char *s;
199 register char *t;
200 register char *f;
201 bool dolong;
202#ifdef QUAD
203 bool doquad;
204#endif /* QUAD */
205 char ch;
206 register char *send;
207 register SV *arg;
208 char *xs;
209 I32 xlen;
210 I32 pre;
211 I32 post;
212 double value;
463ee0b2 213 STRLEN arglen;
79072805
LW
214
215 sv_setpv(sv,"");
216 len--; /* don't count pattern string */
463ee0b2
LW
217 t = s = SvPV(*sarg, arglen);
218 send = s + arglen;
79072805
LW
219 sarg++;
220 for ( ; ; len--) {
221
222 /*SUPPRESS 560*/
223 if (len <= 0 || !(arg = *sarg++))
224 arg = &sv_no;
225
226 /*SUPPRESS 530*/
227 for ( ; t < send && *t != '%'; t++) ;
228 if (t >= send)
229 break; /* end of run_format string, ignore extra args */
230 f = t;
231 *buf = '\0';
232 xs = buf;
233#ifdef QUAD
234 doquad =
235#endif /* QUAD */
236 dolong = FALSE;
237 pre = post = 0;
238 for (t++; t < send; t++) {
239 switch (*t) {
240 default:
241 ch = *(++t);
242 *t = '\0';
243 (void)sprintf(xs,f);
244 len++, sarg--;
245 xlen = strlen(xs);
246 break;
247 case '0': case '1': case '2': case '3': case '4':
248 case '5': case '6': case '7': case '8': case '9':
249 case '.': case '#': case '-': case '+': case ' ':
250 continue;
463ee0b2 251 case 'l':
79072805
LW
252#ifdef QUAD
253 if (dolong) {
254 dolong = FALSE;
255 doquad = TRUE;
256 } else
257#endif
258 dolong = TRUE;
259 continue;
260 case 'c':
261 ch = *(++t);
262 *t = '\0';
463ee0b2 263 xlen = SvIV(arg);
79072805
LW
264 if (strEQ(f,"%c")) { /* some printfs fail on null chars */
265 *xs = xlen;
266 xs[1] = '\0';
267 xlen = 1;
268 }
269 else {
270 (void)sprintf(xs,f,xlen);
271 xlen = strlen(xs);
272 }
273 break;
274 case 'D':
275 dolong = TRUE;
276 /* FALL THROUGH */
277 case 'd':
278 ch = *(++t);
279 *t = '\0';
280#ifdef QUAD
281 if (doquad)
463ee0b2 282 (void)sprintf(buf,s,(quad)SvNV(arg));
79072805
LW
283 else
284#endif
285 if (dolong)
463ee0b2 286 (void)sprintf(xs,f,(long)SvNV(arg));
79072805 287 else
463ee0b2 288 (void)sprintf(xs,f,SvIV(arg));
79072805
LW
289 xlen = strlen(xs);
290 break;
291 case 'X': case 'O':
292 dolong = TRUE;
293 /* FALL THROUGH */
294 case 'x': case 'o': case 'u':
295 ch = *(++t);
296 *t = '\0';
463ee0b2 297 value = SvNV(arg);
79072805
LW
298#ifdef QUAD
299 if (doquad)
300 (void)sprintf(buf,s,(unsigned quad)value);
301 else
302#endif
303 if (dolong)
304 (void)sprintf(xs,f,U_L(value));
305 else
306 (void)sprintf(xs,f,U_I(value));
307 xlen = strlen(xs);
308 break;
309 case 'E': case 'e': case 'f': case 'G': case 'g':
310 ch = *(++t);
311 *t = '\0';
463ee0b2 312 (void)sprintf(xs,f,SvNV(arg));
79072805
LW
313 xlen = strlen(xs);
314 break;
315 case 's':
316 ch = *(++t);
317 *t = '\0';
463ee0b2
LW
318 xs = SvPV(arg, arglen);
319 xlen = (I32)arglen;
79072805
LW
320 if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
321 break; /* so handle simple cases */
322 }
323 else if (f[1] == '-') {
93a17b20 324 char *mp = strchr(f, '.');
79072805
LW
325 I32 min = atoi(f+2);
326
327 if (mp) {
328 I32 max = atoi(mp+1);
329
330 if (xlen > max)
331 xlen = max;
332 }
333 if (xlen < min)
334 post = min - xlen;
335 break;
336 }
337 else if (isDIGIT(f[1])) {
93a17b20 338 char *mp = strchr(f, '.');
79072805
LW
339 I32 min = atoi(f+1);
340
341 if (mp) {
342 I32 max = atoi(mp+1);
343
344 if (xlen > max)
345 xlen = max;
346 }
347 if (xlen < min)
348 pre = min - xlen;
349 break;
350 }
351 strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
352 *t = ch;
353 (void)sprintf(buf,tokenbuf+64,xs);
354 xs = buf;
355 xlen = strlen(xs);
356 break;
357 }
358 /* end of switch, copy results */
359 *t = ch;
360 SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
361 sv_catpvn(sv, s, f - s);
362 if (pre) {
463ee0b2 363 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
79072805
LW
364 SvCUR(sv) += pre;
365 }
366 sv_catpvn(sv, xs, xlen);
367 if (post) {
463ee0b2 368 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
79072805
LW
369 SvCUR(sv) += post;
370 }
371 s = t;
372 break; /* break from for loop */
373 }
374 }
375 sv_catpvn(sv, s, t - s);
376 SvSETMAGIC(sv);
377}
378
379void
380do_vecset(sv)
381SV *sv;
382{
383 SV *targ = LvTARG(sv);
384 register I32 offset;
385 register I32 size;
8990e307
LW
386 register unsigned char *s;
387 register unsigned long lval;
79072805
LW
388 I32 mask;
389
8990e307
LW
390 if (!targ)
391 return;
392 s = (unsigned char*)SvPVX(targ);
393 lval = U_L(SvNV(sv));
79072805
LW
394 offset = LvTARGOFF(sv);
395 size = LvTARGLEN(sv);
396 if (size < 8) {
397 mask = (1 << size) - 1;
398 size = offset & 7;
399 lval &= mask;
400 offset >>= 3;
401 s[offset] &= ~(mask << size);
402 s[offset] |= lval << size;
403 }
404 else {
405 if (size == 8)
406 s[offset] = lval & 255;
407 else if (size == 16) {
408 s[offset] = (lval >> 8) & 255;
409 s[offset+1] = lval & 255;
410 }
411 else if (size == 32) {
412 s[offset] = (lval >> 24) & 255;
413 s[offset+1] = (lval >> 16) & 255;
414 s[offset+2] = (lval >> 8) & 255;
415 s[offset+3] = lval & 255;
416 }
417 }
418}
419
420void
421do_chop(astr,sv)
422register SV *astr;
423register SV *sv;
424{
425 register char *tmps;
426 register I32 i;
427 AV *ary;
463ee0b2 428 HV *hv;
79072805 429 HE *entry;
463ee0b2 430 STRLEN len;
79072805
LW
431
432 if (!sv)
433 return;
ed6116ce
LW
434 if (SvTHINKFIRST(sv)) {
435 if (SvREADONLY(sv))
436 croak("Can't chop readonly value");
437 if (SvROK(sv))
438 sv_unref(sv);
439 }
79072805
LW
440 if (SvTYPE(sv) == SVt_PVAV) {
441 I32 max;
442 SV **array = AvARRAY(sv);
443 max = AvFILL(sv);
444 for (i = 0; i <= max; i++)
445 do_chop(astr,array[i]);
446 return;
447 }
448 if (SvTYPE(sv) == SVt_PVHV) {
463ee0b2
LW
449 hv = (HV*)sv;
450 (void)hv_iterinit(hv);
79072805 451 /*SUPPRESS 560*/
463ee0b2
LW
452 while (entry = hv_iternext(hv))
453 do_chop(astr,hv_iterval(hv,entry));
79072805
LW
454 return;
455 }
463ee0b2
LW
456 tmps = SvPV(sv, len);
457 if (tmps && len) {
458 tmps += len - 1;
79072805
LW
459 sv_setpvn(astr,tmps,1); /* remember last char */
460 *tmps = '\0'; /* wipe it out */
463ee0b2 461 SvCUR_set(sv, tmps - SvPVX(sv));
79072805
LW
462 SvNOK_off(sv);
463 SvSETMAGIC(sv);
464 }
465 else
466 sv_setpvn(astr,"",0);
467}
468
469void
470do_vop(optype,sv,left,right)
471I32 optype;
472SV *sv;
473SV *left;
474SV *right;
475{
476#ifdef LIBERAL
477 register long *dl;
478 register long *ll;
479 register long *rl;
480#endif
481 register char *dc;
463ee0b2
LW
482 STRLEN leftlen;
483 STRLEN rightlen;
484 register char *lc = SvPV(left, leftlen);
485 register char *rc = SvPV(right, rightlen);
79072805
LW
486 register I32 len;
487
ed6116ce
LW
488 if (SvTHINKFIRST(sv)) {
489 if (SvREADONLY(sv))
490 croak("Can't do %s to readonly value", op_name[optype]);
491 if (SvROK(sv))
492 sv_unref(sv);
493 }
93a17b20 494 len = leftlen < rightlen ? leftlen : rightlen;
79072805
LW
495 if (SvTYPE(sv) < SVt_PV)
496 sv_upgrade(sv, SVt_PV);
497 if (SvCUR(sv) > len)
498 SvCUR_set(sv, len);
499 else if (SvCUR(sv) < len) {
500 SvGROW(sv,len);
463ee0b2 501 (void)memzero(SvPVX(sv) + SvCUR(sv), len - SvCUR(sv));
79072805
LW
502 SvCUR_set(sv, len);
503 }
504 SvPOK_only(sv);
463ee0b2 505 dc = SvPVX(sv);
79072805
LW
506 if (!dc) {
507 sv_setpvn(sv,"",0);
463ee0b2 508 dc = SvPVX(sv);
79072805
LW
509 }
510#ifdef LIBERAL
511 if (len >= sizeof(long)*4 &&
512 !((long)dc % sizeof(long)) &&
513 !((long)lc % sizeof(long)) &&
514 !((long)rc % sizeof(long))) /* It's almost always aligned... */
515 {
516 I32 remainder = len % (sizeof(long)*4);
517 len /= (sizeof(long)*4);
518
519 dl = (long*)dc;
520 ll = (long*)lc;
521 rl = (long*)rc;
522
523 switch (optype) {
524 case OP_BIT_AND:
525 while (len--) {
526 *dl++ = *ll++ & *rl++;
527 *dl++ = *ll++ & *rl++;
528 *dl++ = *ll++ & *rl++;
529 *dl++ = *ll++ & *rl++;
530 }
531 break;
532 case OP_XOR:
533 while (len--) {
534 *dl++ = *ll++ ^ *rl++;
535 *dl++ = *ll++ ^ *rl++;
536 *dl++ = *ll++ ^ *rl++;
537 *dl++ = *ll++ ^ *rl++;
538 }
539 break;
540 case OP_BIT_OR:
541 while (len--) {
542 *dl++ = *ll++ | *rl++;
543 *dl++ = *ll++ | *rl++;
544 *dl++ = *ll++ | *rl++;
545 *dl++ = *ll++ | *rl++;
546 }
547 }
548
549 dc = (char*)dl;
550 lc = (char*)ll;
551 rc = (char*)rl;
552
553 len = remainder;
554 }
555#endif
556 switch (optype) {
557 case OP_BIT_AND:
558 while (len--)
559 *dc++ = *lc++ & *rc++;
560 break;
561 case OP_XOR:
562 while (len--)
563 *dc++ = *lc++ ^ *rc++;
564 goto mop_up;
565 case OP_BIT_OR:
566 while (len--)
567 *dc++ = *lc++ | *rc++;
568 mop_up:
569 len = SvCUR(sv);
93a17b20 570 if (rightlen > len)
463ee0b2 571 sv_catpvn(sv, SvPVX(right) + len, rightlen - len);
93a17b20 572 else if (leftlen > len)
463ee0b2 573 sv_catpvn(sv, SvPVX(left) + len, leftlen - len);
79072805
LW
574 break;
575 }
576}
463ee0b2
LW
577
578OP *
579do_kv(ARGS)
580dARGS
581{
582 dSP;
583 HV *hv = (HV*)POPs;
584 register AV *ary = stack;
585 I32 i;
586 register HE *entry;
587 char *tmps;
588 SV *tmpstr;
589 I32 dokeys = (op->op_type == OP_KEYS || op->op_type == OP_RV2HV);
590 I32 dovalues = (op->op_type == OP_VALUES || op->op_type == OP_RV2HV);
591
592 if (!hv)
593 RETURN;
594 if (GIMME != G_ARRAY) {
595 dTARGET;
596
8990e307 597 if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
463ee0b2
LW
598 i = HvKEYS(hv);
599 else {
600 i = 0;
601 (void)hv_iterinit(hv);
602 /*SUPPRESS 560*/
603 while (entry = hv_iternext(hv)) {
604 i++;
605 }
606 }
607 PUSHi( i );
608 RETURN;
609 }
610
611 /* Guess how much room we need. hv_max may be a few too many. Oh well. */
612 EXTEND(sp, HvMAX(hv) * (dokeys + dovalues));
613
614 (void)hv_iterinit(hv);
615
616 PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
617 while (entry = hv_iternext(hv)) {
618 SPAGAIN;
619 if (dokeys) {
620 tmps = hv_iterkey(entry,&i); /* won't clobber stack_sp */
621 if (!i)
622 tmps = "";
623 XPUSHs(sv_2mortal(newSVpv(tmps,i)));
624 }
625 if (dovalues) {
626 tmpstr = NEWSV(45,0);
627 PUTBACK;
628 sv_setsv(tmpstr,hv_iterval(hv,entry));
629 SPAGAIN;
630 DEBUG_H( {
631 sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
632 HvMAX(hv)+1,entry->hent_hash & HvMAX(hv));
633 sv_setpv(tmpstr,buf);
634 } )
635 XPUSHs(sv_2mortal(tmpstr));
636 }
637 PUTBACK;
638 }
639 return NORMAL;
640}
641