perl 5.0 alpha 3
[perl.git] / doop.c
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
71 static void doencodes();
72
73 #ifdef BUGGY_MSC
74  #pragma intrinsic(memcmp)
75 #endif /* BUGGY_MSC */
76
77 I32
78 do_trans(sv,arg)
79 SV *sv;
80 OP *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);
92     send = s + SvCUROK(sv);
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
131 void
132 do_join(sv,del,mark,sp)
133 register SV *sv;
134 SV *del;
135 register SV **mark;
136 register SV **sp;
137 {
138     SV **oldmark = mark;
139     register I32 items = sp - mark;
140     register char *delim = SvPVn(del);
141     register STRLEN len;
142     I32 delimlen = SvCUROK(del);
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
185 void
186 do_sprintf(sv,len,sarg)
187 register SV *sv;
188 register I32 len;
189 register 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);
210     send = s + SvCUROK(*sarg);
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] == '-') {
319                     char *mp = strchr(f, '.');
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])) {
333                     char *mp = strchr(f, '.');
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
374 void
375 do_vecset(sv)
376 SV *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
411 void
412 do_chop(astr,sv)
413 register SV *astr;
414 register 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);
441     if (tmps && SvCUROK(sv)) {
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
453 void
454 do_vop(optype,sv,left,right)
455 I32 optype;
456 SV *sv;
457 SV *left;
458 SV *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;
469     I32 leftlen = SvCUROK(left);
470     I32 rightlen = SvCUROK(right);
471
472     len = leftlen < rightlen ? leftlen : rightlen;
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);
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);
552         break;
553     }
554 }