perl 5.0 alpha 6
[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     STRLEN len;
90
91     tbl = (short*) cPVOP->op_pv;
92     s = SvPV(sv, len);
93     send = s + len;
94     if (!tbl || !s)
95         croak("panic: do_trans");
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';
126         SvCUR_set(sv, d - SvPVX(sv));
127     }
128     SvSETMAGIC(sv);
129     return matches;
130 }
131
132 void
133 do_join(sv,del,mark,sp)
134 register SV *sv;
135 SV *del;
136 register SV **mark;
137 register SV **sp;
138 {
139     SV **oldmark = mark;
140     register I32 items = sp - mark;
141     register STRLEN len;
142     STRLEN delimlen;
143     register char *delim = SvPV(del, delimlen);
144     STRLEN tmplen;
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) {
153                 SvPV(*mark, tmplen);
154                 len += tmplen;
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
165     if (items-- > 0) {
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, "");
174         mark++;
175     }
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
192 void
193 do_sprintf(sv,len,sarg)
194 register SV *sv;
195 register I32 len;
196 register 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;
213     STRLEN arglen;
214
215     sv_setpv(sv,"");
216     len--;                      /* don't count pattern string */
217     t = s = SvPV(*sarg, arglen);
218     send = s + arglen;
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;
251             case 'l':
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';
263                 xlen = SvIV(arg);
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)
282                     (void)sprintf(buf,s,(quad)SvNV(arg));
283                 else
284 #endif
285                 if (dolong)
286                     (void)sprintf(xs,f,(long)SvNV(arg));
287                 else
288                     (void)sprintf(xs,f,SvIV(arg));
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';
297                 value = SvNV(arg);
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';
312                 (void)sprintf(xs,f,SvNV(arg));
313                 xlen = strlen(xs);
314                 break;
315             case 's':
316                 ch = *(++t);
317                 *t = '\0';
318                 xs = SvPV(arg, arglen);
319                 xlen = (I32)arglen;
320                 if (strEQ(f,"%s")) {    /* some printfs fail on >128 chars */
321                     break;              /* so handle simple cases */
322                 }
323                 else if (f[1] == '-') {
324                     char *mp = strchr(f, '.');
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])) {
338                     char *mp = strchr(f, '.');
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) {
363                 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
364                 SvCUR(sv) += pre;
365             }
366             sv_catpvn(sv, xs, xlen);
367             if (post) {
368                 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
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
379 void
380 do_vecset(sv)
381 SV *sv;
382 {
383     SV *targ = LvTARG(sv);
384     register I32 offset;
385     register I32 size;
386     register unsigned char *s;
387     register unsigned long lval;
388     I32 mask;
389
390     if (!targ)
391         return;
392     s = (unsigned char*)SvPVX(targ);
393     lval = U_L(SvNV(sv));
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
420 void
421 do_chop(astr,sv)
422 register SV *astr;
423 register SV *sv;
424 {
425     register char *tmps;
426     register I32 i;
427     AV *ary;
428     HV *hv;
429     HE *entry;
430     STRLEN len;
431
432     if (!sv)
433         return;
434     if (SvTHINKFIRST(sv)) {
435         if (SvREADONLY(sv))
436             croak("Can't chop readonly value");
437         if (SvROK(sv))
438             sv_unref(sv);
439     }
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) {
449         hv = (HV*)sv;
450         (void)hv_iterinit(hv);
451         /*SUPPRESS 560*/
452         while (entry = hv_iternext(hv))
453             do_chop(astr,hv_iterval(hv,entry));
454         return;
455     }
456     tmps = SvPV(sv, len);
457     if (tmps && len) {
458         tmps += len - 1;
459         sv_setpvn(astr,tmps,1); /* remember last char */
460         *tmps = '\0';                           /* wipe it out */
461         SvCUR_set(sv, tmps - SvPVX(sv));
462         SvNOK_off(sv);
463         SvSETMAGIC(sv);
464     }
465     else
466         sv_setpvn(astr,"",0);
467 }
468
469 void
470 do_vop(optype,sv,left,right)
471 I32 optype;
472 SV *sv;
473 SV *left;
474 SV *right;
475 {
476 #ifdef LIBERAL
477     register long *dl;
478     register long *ll;
479     register long *rl;
480 #endif
481     register char *dc;
482     STRLEN leftlen;
483     STRLEN rightlen;
484     register char *lc = SvPV(left, leftlen);
485     register char *rc = SvPV(right, rightlen);
486     register I32 len;
487
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     }
494     len = leftlen < rightlen ? leftlen : rightlen;
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);
501         (void)memzero(SvPVX(sv) + SvCUR(sv), len - SvCUR(sv));
502         SvCUR_set(sv, len);
503     }
504     SvPOK_only(sv);
505     dc = SvPVX(sv);
506     if (!dc) {
507         sv_setpvn(sv,"",0);
508         dc = SvPVX(sv);
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);
570         if (rightlen > len)
571             sv_catpvn(sv, SvPVX(right) + len, rightlen - len);
572         else if (leftlen > len)
573             sv_catpvn(sv, SvPVX(left) + len, leftlen - len);
574         break;
575     }
576 }
577
578 OP *
579 do_kv(ARGS)
580 dARGS
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
597         if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
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