This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 5
[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
LW
165 if (items-- > 0) {
166 char *s = SvPV(*mark, tmplen);
167 sv_setpvn(sv, s, tmplen);
168 mark++;
169 }
79072805
LW
170 else
171 sv_setpv(sv,"");
172 len = delimlen;
173 if (len) {
174 for (; items > 0; items--,mark++) {
175 sv_catpvn(sv,delim,len);
176 sv_catsv(sv,*mark);
177 }
178 }
179 else {
180 for (; items > 0; items--,mark++)
181 sv_catsv(sv,*mark);
182 }
183 SvSETMAGIC(sv);
184}
185
186void
187do_sprintf(sv,len,sarg)
188register SV *sv;
189register I32 len;
190register SV **sarg;
191{
192 register char *s;
193 register char *t;
194 register char *f;
195 bool dolong;
196#ifdef QUAD
197 bool doquad;
198#endif /* QUAD */
199 char ch;
200 register char *send;
201 register SV *arg;
202 char *xs;
203 I32 xlen;
204 I32 pre;
205 I32 post;
206 double value;
463ee0b2 207 STRLEN arglen;
79072805
LW
208
209 sv_setpv(sv,"");
210 len--; /* don't count pattern string */
463ee0b2
LW
211 t = s = SvPV(*sarg, arglen);
212 send = s + arglen;
79072805
LW
213 sarg++;
214 for ( ; ; len--) {
215
216 /*SUPPRESS 560*/
217 if (len <= 0 || !(arg = *sarg++))
218 arg = &sv_no;
219
220 /*SUPPRESS 530*/
221 for ( ; t < send && *t != '%'; t++) ;
222 if (t >= send)
223 break; /* end of run_format string, ignore extra args */
224 f = t;
225 *buf = '\0';
226 xs = buf;
227#ifdef QUAD
228 doquad =
229#endif /* QUAD */
230 dolong = FALSE;
231 pre = post = 0;
232 for (t++; t < send; t++) {
233 switch (*t) {
234 default:
235 ch = *(++t);
236 *t = '\0';
237 (void)sprintf(xs,f);
238 len++, sarg--;
239 xlen = strlen(xs);
240 break;
241 case '0': case '1': case '2': case '3': case '4':
242 case '5': case '6': case '7': case '8': case '9':
243 case '.': case '#': case '-': case '+': case ' ':
244 continue;
463ee0b2 245 case 'l':
79072805
LW
246#ifdef QUAD
247 if (dolong) {
248 dolong = FALSE;
249 doquad = TRUE;
250 } else
251#endif
252 dolong = TRUE;
253 continue;
254 case 'c':
255 ch = *(++t);
256 *t = '\0';
463ee0b2 257 xlen = SvIV(arg);
79072805
LW
258 if (strEQ(f,"%c")) { /* some printfs fail on null chars */
259 *xs = xlen;
260 xs[1] = '\0';
261 xlen = 1;
262 }
263 else {
264 (void)sprintf(xs,f,xlen);
265 xlen = strlen(xs);
266 }
267 break;
268 case 'D':
269 dolong = TRUE;
270 /* FALL THROUGH */
271 case 'd':
272 ch = *(++t);
273 *t = '\0';
274#ifdef QUAD
275 if (doquad)
463ee0b2 276 (void)sprintf(buf,s,(quad)SvNV(arg));
79072805
LW
277 else
278#endif
279 if (dolong)
463ee0b2 280 (void)sprintf(xs,f,(long)SvNV(arg));
79072805 281 else
463ee0b2 282 (void)sprintf(xs,f,SvIV(arg));
79072805
LW
283 xlen = strlen(xs);
284 break;
285 case 'X': case 'O':
286 dolong = TRUE;
287 /* FALL THROUGH */
288 case 'x': case 'o': case 'u':
289 ch = *(++t);
290 *t = '\0';
463ee0b2 291 value = SvNV(arg);
79072805
LW
292#ifdef QUAD
293 if (doquad)
294 (void)sprintf(buf,s,(unsigned quad)value);
295 else
296#endif
297 if (dolong)
298 (void)sprintf(xs,f,U_L(value));
299 else
300 (void)sprintf(xs,f,U_I(value));
301 xlen = strlen(xs);
302 break;
303 case 'E': case 'e': case 'f': case 'G': case 'g':
304 ch = *(++t);
305 *t = '\0';
463ee0b2 306 (void)sprintf(xs,f,SvNV(arg));
79072805
LW
307 xlen = strlen(xs);
308 break;
309 case 's':
310 ch = *(++t);
311 *t = '\0';
463ee0b2
LW
312 xs = SvPV(arg, arglen);
313 xlen = (I32)arglen;
79072805
LW
314 if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
315 break; /* so handle simple cases */
316 }
317 else if (f[1] == '-') {
93a17b20 318 char *mp = strchr(f, '.');
79072805
LW
319 I32 min = atoi(f+2);
320
321 if (mp) {
322 I32 max = atoi(mp+1);
323
324 if (xlen > max)
325 xlen = max;
326 }
327 if (xlen < min)
328 post = min - xlen;
329 break;
330 }
331 else if (isDIGIT(f[1])) {
93a17b20 332 char *mp = strchr(f, '.');
79072805
LW
333 I32 min = atoi(f+1);
334
335 if (mp) {
336 I32 max = atoi(mp+1);
337
338 if (xlen > max)
339 xlen = max;
340 }
341 if (xlen < min)
342 pre = min - xlen;
343 break;
344 }
345 strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
346 *t = ch;
347 (void)sprintf(buf,tokenbuf+64,xs);
348 xs = buf;
349 xlen = strlen(xs);
350 break;
351 }
352 /* end of switch, copy results */
353 *t = ch;
354 SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
355 sv_catpvn(sv, s, f - s);
356 if (pre) {
463ee0b2 357 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
79072805
LW
358 SvCUR(sv) += pre;
359 }
360 sv_catpvn(sv, xs, xlen);
361 if (post) {
463ee0b2 362 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
79072805
LW
363 SvCUR(sv) += post;
364 }
365 s = t;
366 break; /* break from for loop */
367 }
368 }
369 sv_catpvn(sv, s, t - s);
370 SvSETMAGIC(sv);
371}
372
373void
374do_vecset(sv)
375SV *sv;
376{
377 SV *targ = LvTARG(sv);
378 register I32 offset;
379 register I32 size;
463ee0b2
LW
380 register unsigned char *s = (unsigned char*)SvPVX(targ);
381 register unsigned long lval = U_L(SvNV(sv));
79072805
LW
382 I32 mask;
383
384 offset = LvTARGOFF(sv);
385 size = LvTARGLEN(sv);
386 if (size < 8) {
387 mask = (1 << size) - 1;
388 size = offset & 7;
389 lval &= mask;
390 offset >>= 3;
391 s[offset] &= ~(mask << size);
392 s[offset] |= lval << size;
393 }
394 else {
395 if (size == 8)
396 s[offset] = lval & 255;
397 else if (size == 16) {
398 s[offset] = (lval >> 8) & 255;
399 s[offset+1] = lval & 255;
400 }
401 else if (size == 32) {
402 s[offset] = (lval >> 24) & 255;
403 s[offset+1] = (lval >> 16) & 255;
404 s[offset+2] = (lval >> 8) & 255;
405 s[offset+3] = lval & 255;
406 }
407 }
408}
409
410void
411do_chop(astr,sv)
412register SV *astr;
413register SV *sv;
414{
415 register char *tmps;
416 register I32 i;
417 AV *ary;
463ee0b2 418 HV *hv;
79072805 419 HE *entry;
463ee0b2 420 STRLEN len;
79072805
LW
421
422 if (!sv)
423 return;
ed6116ce
LW
424 if (SvTHINKFIRST(sv)) {
425 if (SvREADONLY(sv))
426 croak("Can't chop readonly value");
427 if (SvROK(sv))
428 sv_unref(sv);
429 }
79072805
LW
430 if (SvTYPE(sv) == SVt_PVAV) {
431 I32 max;
432 SV **array = AvARRAY(sv);
433 max = AvFILL(sv);
434 for (i = 0; i <= max; i++)
435 do_chop(astr,array[i]);
436 return;
437 }
438 if (SvTYPE(sv) == SVt_PVHV) {
463ee0b2
LW
439 hv = (HV*)sv;
440 (void)hv_iterinit(hv);
79072805 441 /*SUPPRESS 560*/
463ee0b2
LW
442 while (entry = hv_iternext(hv))
443 do_chop(astr,hv_iterval(hv,entry));
79072805
LW
444 return;
445 }
463ee0b2
LW
446 tmps = SvPV(sv, len);
447 if (tmps && len) {
448 tmps += len - 1;
79072805
LW
449 sv_setpvn(astr,tmps,1); /* remember last char */
450 *tmps = '\0'; /* wipe it out */
463ee0b2 451 SvCUR_set(sv, tmps - SvPVX(sv));
79072805
LW
452 SvNOK_off(sv);
453 SvSETMAGIC(sv);
454 }
455 else
456 sv_setpvn(astr,"",0);
457}
458
459void
460do_vop(optype,sv,left,right)
461I32 optype;
462SV *sv;
463SV *left;
464SV *right;
465{
466#ifdef LIBERAL
467 register long *dl;
468 register long *ll;
469 register long *rl;
470#endif
471 register char *dc;
463ee0b2
LW
472 STRLEN leftlen;
473 STRLEN rightlen;
474 register char *lc = SvPV(left, leftlen);
475 register char *rc = SvPV(right, rightlen);
79072805
LW
476 register I32 len;
477
ed6116ce
LW
478 if (SvTHINKFIRST(sv)) {
479 if (SvREADONLY(sv))
480 croak("Can't do %s to readonly value", op_name[optype]);
481 if (SvROK(sv))
482 sv_unref(sv);
483 }
93a17b20 484 len = leftlen < rightlen ? leftlen : rightlen;
79072805
LW
485 if (SvTYPE(sv) < SVt_PV)
486 sv_upgrade(sv, SVt_PV);
487 if (SvCUR(sv) > len)
488 SvCUR_set(sv, len);
489 else if (SvCUR(sv) < len) {
490 SvGROW(sv,len);
463ee0b2 491 (void)memzero(SvPVX(sv) + SvCUR(sv), len - SvCUR(sv));
79072805
LW
492 SvCUR_set(sv, len);
493 }
494 SvPOK_only(sv);
463ee0b2 495 dc = SvPVX(sv);
79072805
LW
496 if (!dc) {
497 sv_setpvn(sv,"",0);
463ee0b2 498 dc = SvPVX(sv);
79072805
LW
499 }
500#ifdef LIBERAL
501 if (len >= sizeof(long)*4 &&
502 !((long)dc % sizeof(long)) &&
503 !((long)lc % sizeof(long)) &&
504 !((long)rc % sizeof(long))) /* It's almost always aligned... */
505 {
506 I32 remainder = len % (sizeof(long)*4);
507 len /= (sizeof(long)*4);
508
509 dl = (long*)dc;
510 ll = (long*)lc;
511 rl = (long*)rc;
512
513 switch (optype) {
514 case OP_BIT_AND:
515 while (len--) {
516 *dl++ = *ll++ & *rl++;
517 *dl++ = *ll++ & *rl++;
518 *dl++ = *ll++ & *rl++;
519 *dl++ = *ll++ & *rl++;
520 }
521 break;
522 case OP_XOR:
523 while (len--) {
524 *dl++ = *ll++ ^ *rl++;
525 *dl++ = *ll++ ^ *rl++;
526 *dl++ = *ll++ ^ *rl++;
527 *dl++ = *ll++ ^ *rl++;
528 }
529 break;
530 case OP_BIT_OR:
531 while (len--) {
532 *dl++ = *ll++ | *rl++;
533 *dl++ = *ll++ | *rl++;
534 *dl++ = *ll++ | *rl++;
535 *dl++ = *ll++ | *rl++;
536 }
537 }
538
539 dc = (char*)dl;
540 lc = (char*)ll;
541 rc = (char*)rl;
542
543 len = remainder;
544 }
545#endif
546 switch (optype) {
547 case OP_BIT_AND:
548 while (len--)
549 *dc++ = *lc++ & *rc++;
550 break;
551 case OP_XOR:
552 while (len--)
553 *dc++ = *lc++ ^ *rc++;
554 goto mop_up;
555 case OP_BIT_OR:
556 while (len--)
557 *dc++ = *lc++ | *rc++;
558 mop_up:
559 len = SvCUR(sv);
93a17b20 560 if (rightlen > len)
463ee0b2 561 sv_catpvn(sv, SvPVX(right) + len, rightlen - len);
93a17b20 562 else if (leftlen > len)
463ee0b2 563 sv_catpvn(sv, SvPVX(left) + len, leftlen - len);
79072805
LW
564 break;
565 }
566}
463ee0b2
LW
567
568OP *
569do_kv(ARGS)
570dARGS
571{
572 dSP;
573 HV *hv = (HV*)POPs;
574 register AV *ary = stack;
575 I32 i;
576 register HE *entry;
577 char *tmps;
578 SV *tmpstr;
579 I32 dokeys = (op->op_type == OP_KEYS || op->op_type == OP_RV2HV);
580 I32 dovalues = (op->op_type == OP_VALUES || op->op_type == OP_RV2HV);
581
582 if (!hv)
583 RETURN;
584 if (GIMME != G_ARRAY) {
585 dTARGET;
586
587 if (!SvMAGICAL(hv) || !mg_find((SV*)hv,'P'))
588 i = HvKEYS(hv);
589 else {
590 i = 0;
591 (void)hv_iterinit(hv);
592 /*SUPPRESS 560*/
593 while (entry = hv_iternext(hv)) {
594 i++;
595 }
596 }
597 PUSHi( i );
598 RETURN;
599 }
600
601 /* Guess how much room we need. hv_max may be a few too many. Oh well. */
602 EXTEND(sp, HvMAX(hv) * (dokeys + dovalues));
603
604 (void)hv_iterinit(hv);
605
606 PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
607 while (entry = hv_iternext(hv)) {
608 SPAGAIN;
609 if (dokeys) {
610 tmps = hv_iterkey(entry,&i); /* won't clobber stack_sp */
611 if (!i)
612 tmps = "";
613 XPUSHs(sv_2mortal(newSVpv(tmps,i)));
614 }
615 if (dovalues) {
616 tmpstr = NEWSV(45,0);
617 PUTBACK;
618 sv_setsv(tmpstr,hv_iterval(hv,entry));
619 SPAGAIN;
620 DEBUG_H( {
621 sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
622 HvMAX(hv)+1,entry->hent_hash & HvMAX(hv));
623 sv_setpv(tmpstr,buf);
624 } )
625 XPUSHs(sv_2mortal(tmpstr));
626 }
627 PUTBACK;
628 }
629 return NORMAL;
630}
631