This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 3
[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;
89
90 tbl = (short*) cPVOP->op_pv;
91 s = SvPVn(sv);
93a17b20 92 send = s + SvCUROK(sv);
79072805
LW
93 if (!tbl || !s)
94 fatal("panic: do_trans");
95 DEBUG_t( deb("2.TBL\n"));
96 if (!op->op_private) {
97 while (s < send) {
98 if ((ch = tbl[*s & 0377]) >= 0) {
99 matches++;
100 *s = ch;
101 }
102 s++;
103 }
104 }
105 else {
106 d = s;
107 while (s < send) {
108 if ((ch = tbl[*s & 0377]) >= 0) {
109 *d = ch;
110 if (matches++ && squash) {
111 if (d[-1] == *d)
112 matches--;
113 else
114 d++;
115 }
116 else
117 d++;
118 }
119 else if (ch == -1) /* -1 is unmapped character */
120 *d++ = *s; /* -2 is delete character */
121 s++;
122 }
123 matches += send - d; /* account for disappeared chars */
124 *d = '\0';
125 SvCUR_set(sv, d - SvPV(sv));
126 }
127 SvSETMAGIC(sv);
128 return matches;
129}
130
131void
132do_join(sv,del,mark,sp)
133register SV *sv;
134SV *del;
135register SV **mark;
136register SV **sp;
137{
138 SV **oldmark = mark;
139 register I32 items = sp - mark;
140 register char *delim = SvPVn(del);
141 register STRLEN len;
93a17b20 142 I32 delimlen = SvCUROK(del);
79072805
LW
143
144 mark++;
145 len = (items > 0 ? (delimlen * (items - 1) ) : 0);
146 if (SvTYPE(sv) < SVt_PV)
147 sv_upgrade(sv, SVt_PV);
148 if (SvLEN(sv) < len + items) { /* current length is way too short */
149 while (items-- > 0) {
150 if (*mark) {
151 if (!SvPOK(*mark)) {
152 sv_2pv(*mark);
153 if (!SvPOK(*mark))
154 *mark = &sv_no;
155 }
156 len += SvCUR((*mark));
157 }
158 mark++;
159 }
160 SvGROW(sv, len + 1); /* so try to pre-extend */
161
162 mark = oldmark;
163 items = sp - mark;;
164 ++mark;
165 }
166
167 if (items-- > 0)
168 sv_setsv(sv, *mark++);
169 else
170 sv_setpv(sv,"");
171 len = delimlen;
172 if (len) {
173 for (; items > 0; items--,mark++) {
174 sv_catpvn(sv,delim,len);
175 sv_catsv(sv,*mark);
176 }
177 }
178 else {
179 for (; items > 0; items--,mark++)
180 sv_catsv(sv,*mark);
181 }
182 SvSETMAGIC(sv);
183}
184
185void
186do_sprintf(sv,len,sarg)
187register SV *sv;
188register I32 len;
189register SV **sarg;
190{
191 register char *s;
192 register char *t;
193 register char *f;
194 bool dolong;
195#ifdef QUAD
196 bool doquad;
197#endif /* QUAD */
198 char ch;
199 register char *send;
200 register SV *arg;
201 char *xs;
202 I32 xlen;
203 I32 pre;
204 I32 post;
205 double value;
206
207 sv_setpv(sv,"");
208 len--; /* don't count pattern string */
209 t = s = SvPVn(*sarg);
93a17b20 210 send = s + SvCUROK(*sarg);
79072805
LW
211 sarg++;
212 for ( ; ; len--) {
213
214 /*SUPPRESS 560*/
215 if (len <= 0 || !(arg = *sarg++))
216 arg = &sv_no;
217
218 /*SUPPRESS 530*/
219 for ( ; t < send && *t != '%'; t++) ;
220 if (t >= send)
221 break; /* end of run_format string, ignore extra args */
222 f = t;
223 *buf = '\0';
224 xs = buf;
225#ifdef QUAD
226 doquad =
227#endif /* QUAD */
228 dolong = FALSE;
229 pre = post = 0;
230 for (t++; t < send; t++) {
231 switch (*t) {
232 default:
233 ch = *(++t);
234 *t = '\0';
235 (void)sprintf(xs,f);
236 len++, sarg--;
237 xlen = strlen(xs);
238 break;
239 case '0': case '1': case '2': case '3': case '4':
240 case '5': case '6': case '7': case '8': case '9':
241 case '.': case '#': case '-': case '+': case ' ':
242 continue;
243 case 'lXXX':
244#ifdef QUAD
245 if (dolong) {
246 dolong = FALSE;
247 doquad = TRUE;
248 } else
249#endif
250 dolong = TRUE;
251 continue;
252 case 'c':
253 ch = *(++t);
254 *t = '\0';
255 xlen = SvIVn(arg);
256 if (strEQ(f,"%c")) { /* some printfs fail on null chars */
257 *xs = xlen;
258 xs[1] = '\0';
259 xlen = 1;
260 }
261 else {
262 (void)sprintf(xs,f,xlen);
263 xlen = strlen(xs);
264 }
265 break;
266 case 'D':
267 dolong = TRUE;
268 /* FALL THROUGH */
269 case 'd':
270 ch = *(++t);
271 *t = '\0';
272#ifdef QUAD
273 if (doquad)
274 (void)sprintf(buf,s,(quad)SvNVn(arg));
275 else
276#endif
277 if (dolong)
278 (void)sprintf(xs,f,(long)SvNVn(arg));
279 else
280 (void)sprintf(xs,f,SvIVn(arg));
281 xlen = strlen(xs);
282 break;
283 case 'X': case 'O':
284 dolong = TRUE;
285 /* FALL THROUGH */
286 case 'x': case 'o': case 'u':
287 ch = *(++t);
288 *t = '\0';
289 value = SvNVn(arg);
290#ifdef QUAD
291 if (doquad)
292 (void)sprintf(buf,s,(unsigned quad)value);
293 else
294#endif
295 if (dolong)
296 (void)sprintf(xs,f,U_L(value));
297 else
298 (void)sprintf(xs,f,U_I(value));
299 xlen = strlen(xs);
300 break;
301 case 'E': case 'e': case 'f': case 'G': case 'g':
302 ch = *(++t);
303 *t = '\0';
304 (void)sprintf(xs,f,SvNVn(arg));
305 xlen = strlen(xs);
306 break;
307 case 's':
308 ch = *(++t);
309 *t = '\0';
310 xs = SvPVn(arg);
311 if (SvPOK(arg))
312 xlen = SvCUR(arg);
313 else
314 xlen = strlen(xs);
315 if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
316 break; /* so handle simple cases */
317 }
318 else if (f[1] == '-') {
93a17b20 319 char *mp = strchr(f, '.');
79072805
LW
320 I32 min = atoi(f+2);
321
322 if (mp) {
323 I32 max = atoi(mp+1);
324
325 if (xlen > max)
326 xlen = max;
327 }
328 if (xlen < min)
329 post = min - xlen;
330 break;
331 }
332 else if (isDIGIT(f[1])) {
93a17b20 333 char *mp = strchr(f, '.');
79072805
LW
334 I32 min = atoi(f+1);
335
336 if (mp) {
337 I32 max = atoi(mp+1);
338
339 if (xlen > max)
340 xlen = max;
341 }
342 if (xlen < min)
343 pre = min - xlen;
344 break;
345 }
346 strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
347 *t = ch;
348 (void)sprintf(buf,tokenbuf+64,xs);
349 xs = buf;
350 xlen = strlen(xs);
351 break;
352 }
353 /* end of switch, copy results */
354 *t = ch;
355 SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
356 sv_catpvn(sv, s, f - s);
357 if (pre) {
358 repeatcpy(SvPV(sv) + SvCUR(sv), " ", 1, pre);
359 SvCUR(sv) += pre;
360 }
361 sv_catpvn(sv, xs, xlen);
362 if (post) {
363 repeatcpy(SvPV(sv) + SvCUR(sv), " ", 1, post);
364 SvCUR(sv) += post;
365 }
366 s = t;
367 break; /* break from for loop */
368 }
369 }
370 sv_catpvn(sv, s, t - s);
371 SvSETMAGIC(sv);
372}
373
374void
375do_vecset(sv)
376SV *sv;
377{
378 SV *targ = LvTARG(sv);
379 register I32 offset;
380 register I32 size;
381 register unsigned char *s = (unsigned char*)SvPV(targ);
382 register unsigned long lval = U_L(SvNVn(sv));
383 I32 mask;
384
385 offset = LvTARGOFF(sv);
386 size = LvTARGLEN(sv);
387 if (size < 8) {
388 mask = (1 << size) - 1;
389 size = offset & 7;
390 lval &= mask;
391 offset >>= 3;
392 s[offset] &= ~(mask << size);
393 s[offset] |= lval << size;
394 }
395 else {
396 if (size == 8)
397 s[offset] = lval & 255;
398 else if (size == 16) {
399 s[offset] = (lval >> 8) & 255;
400 s[offset+1] = lval & 255;
401 }
402 else if (size == 32) {
403 s[offset] = (lval >> 24) & 255;
404 s[offset+1] = (lval >> 16) & 255;
405 s[offset+2] = (lval >> 8) & 255;
406 s[offset+3] = lval & 255;
407 }
408 }
409}
410
411void
412do_chop(astr,sv)
413register SV *astr;
414register SV *sv;
415{
416 register char *tmps;
417 register I32 i;
418 AV *ary;
419 HV *hash;
420 HE *entry;
421
422 if (!sv)
423 return;
424 if (SvTYPE(sv) == SVt_PVAV) {
425 I32 max;
426 SV **array = AvARRAY(sv);
427 max = AvFILL(sv);
428 for (i = 0; i <= max; i++)
429 do_chop(astr,array[i]);
430 return;
431 }
432 if (SvTYPE(sv) == SVt_PVHV) {
433 hash = (HV*)sv;
434 (void)hv_iterinit(hash);
435 /*SUPPRESS 560*/
436 while (entry = hv_iternext(hash))
437 do_chop(astr,hv_iterval(hash,entry));
438 return;
439 }
440 tmps = SvPVn(sv);
93a17b20 441 if (tmps && SvCUROK(sv)) {
79072805
LW
442 tmps += SvCUR(sv) - 1;
443 sv_setpvn(astr,tmps,1); /* remember last char */
444 *tmps = '\0'; /* wipe it out */
445 SvCUR_set(sv, tmps - SvPV(sv));
446 SvNOK_off(sv);
447 SvSETMAGIC(sv);
448 }
449 else
450 sv_setpvn(astr,"",0);
451}
452
453void
454do_vop(optype,sv,left,right)
455I32 optype;
456SV *sv;
457SV *left;
458SV *right;
459{
460#ifdef LIBERAL
461 register long *dl;
462 register long *ll;
463 register long *rl;
464#endif
465 register char *dc;
466 register char *lc = SvPVn(left);
467 register char *rc = SvPVn(right);
468 register I32 len;
93a17b20
LW
469 I32 leftlen = SvCUROK(left);
470 I32 rightlen = SvCUROK(right);
79072805 471
93a17b20 472 len = leftlen < rightlen ? leftlen : rightlen;
79072805
LW
473 if (SvTYPE(sv) < SVt_PV)
474 sv_upgrade(sv, SVt_PV);
475 if (SvCUR(sv) > len)
476 SvCUR_set(sv, len);
477 else if (SvCUR(sv) < len) {
478 SvGROW(sv,len);
479 (void)memzero(SvPV(sv) + SvCUR(sv), len - SvCUR(sv));
480 SvCUR_set(sv, len);
481 }
482 SvPOK_only(sv);
483 dc = SvPV(sv);
484 if (!dc) {
485 sv_setpvn(sv,"",0);
486 dc = SvPV(sv);
487 }
488#ifdef LIBERAL
489 if (len >= sizeof(long)*4 &&
490 !((long)dc % sizeof(long)) &&
491 !((long)lc % sizeof(long)) &&
492 !((long)rc % sizeof(long))) /* It's almost always aligned... */
493 {
494 I32 remainder = len % (sizeof(long)*4);
495 len /= (sizeof(long)*4);
496
497 dl = (long*)dc;
498 ll = (long*)lc;
499 rl = (long*)rc;
500
501 switch (optype) {
502 case OP_BIT_AND:
503 while (len--) {
504 *dl++ = *ll++ & *rl++;
505 *dl++ = *ll++ & *rl++;
506 *dl++ = *ll++ & *rl++;
507 *dl++ = *ll++ & *rl++;
508 }
509 break;
510 case OP_XOR:
511 while (len--) {
512 *dl++ = *ll++ ^ *rl++;
513 *dl++ = *ll++ ^ *rl++;
514 *dl++ = *ll++ ^ *rl++;
515 *dl++ = *ll++ ^ *rl++;
516 }
517 break;
518 case OP_BIT_OR:
519 while (len--) {
520 *dl++ = *ll++ | *rl++;
521 *dl++ = *ll++ | *rl++;
522 *dl++ = *ll++ | *rl++;
523 *dl++ = *ll++ | *rl++;
524 }
525 }
526
527 dc = (char*)dl;
528 lc = (char*)ll;
529 rc = (char*)rl;
530
531 len = remainder;
532 }
533#endif
534 switch (optype) {
535 case OP_BIT_AND:
536 while (len--)
537 *dc++ = *lc++ & *rc++;
538 break;
539 case OP_XOR:
540 while (len--)
541 *dc++ = *lc++ ^ *rc++;
542 goto mop_up;
543 case OP_BIT_OR:
544 while (len--)
545 *dc++ = *lc++ | *rc++;
546 mop_up:
547 len = SvCUR(sv);
93a17b20
LW
548 if (rightlen > len)
549 sv_catpvn(sv, SvPV(right) + len, rightlen - len);
550 else if (leftlen > len)
551 sv_catpvn(sv, SvPV(left) + len, leftlen - len);
79072805
LW
552 break;
553 }
554}