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