146bd24393b4f65f6580f0769876dd84acc0a8e0
[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 = SvPV(*mark, tmplen);
167         sv_setpvn(sv, s, tmplen);
168         mark++;
169     }
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
186 void
187 do_sprintf(sv,len,sarg)
188 register SV *sv;
189 register I32 len;
190 register 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;
207     STRLEN arglen;
208
209     sv_setpv(sv,"");
210     len--;                      /* don't count pattern string */
211     t = s = SvPV(*sarg, arglen);
212     send = s + arglen;
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;
245             case 'l':
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';
257                 xlen = SvIV(arg);
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)
276                     (void)sprintf(buf,s,(quad)SvNV(arg));
277                 else
278 #endif
279                 if (dolong)
280                     (void)sprintf(xs,f,(long)SvNV(arg));
281                 else
282                     (void)sprintf(xs,f,SvIV(arg));
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';
291                 value = SvNV(arg);
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';
306                 (void)sprintf(xs,f,SvNV(arg));
307                 xlen = strlen(xs);
308                 break;
309             case 's':
310                 ch = *(++t);
311                 *t = '\0';
312                 xs = SvPV(arg, arglen);
313                 xlen = (I32)arglen;
314                 if (strEQ(f,"%s")) {    /* some printfs fail on >128 chars */
315                     break;              /* so handle simple cases */
316                 }
317                 else if (f[1] == '-') {
318                     char *mp = strchr(f, '.');
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])) {
332                     char *mp = strchr(f, '.');
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) {
357                 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
358                 SvCUR(sv) += pre;
359             }
360             sv_catpvn(sv, xs, xlen);
361             if (post) {
362                 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
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
373 void
374 do_vecset(sv)
375 SV *sv;
376 {
377     SV *targ = LvTARG(sv);
378     register I32 offset;
379     register I32 size;
380     register unsigned char *s = (unsigned char*)SvPVX(targ);
381     register unsigned long lval = U_L(SvNV(sv));
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
410 void
411 do_chop(astr,sv)
412 register SV *astr;
413 register SV *sv;
414 {
415     register char *tmps;
416     register I32 i;
417     AV *ary;
418     HV *hv;
419     HE *entry;
420     STRLEN len;
421
422     if (!sv)
423         return;
424     if (SvTHINKFIRST(sv)) {
425         if (SvREADONLY(sv))
426             croak("Can't chop readonly value");
427         if (SvROK(sv))
428             sv_unref(sv);
429     }
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) {
439         hv = (HV*)sv;
440         (void)hv_iterinit(hv);
441         /*SUPPRESS 560*/
442         while (entry = hv_iternext(hv))
443             do_chop(astr,hv_iterval(hv,entry));
444         return;
445     }
446     tmps = SvPV(sv, len);
447     if (tmps && len) {
448         tmps += len - 1;
449         sv_setpvn(astr,tmps,1); /* remember last char */
450         *tmps = '\0';                           /* wipe it out */
451         SvCUR_set(sv, tmps - SvPVX(sv));
452         SvNOK_off(sv);
453         SvSETMAGIC(sv);
454     }
455     else
456         sv_setpvn(astr,"",0);
457 }
458
459 void
460 do_vop(optype,sv,left,right)
461 I32 optype;
462 SV *sv;
463 SV *left;
464 SV *right;
465 {
466 #ifdef LIBERAL
467     register long *dl;
468     register long *ll;
469     register long *rl;
470 #endif
471     register char *dc;
472     STRLEN leftlen;
473     STRLEN rightlen;
474     register char *lc = SvPV(left, leftlen);
475     register char *rc = SvPV(right, rightlen);
476     register I32 len;
477
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     }
484     len = leftlen < rightlen ? leftlen : rightlen;
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);
491         (void)memzero(SvPVX(sv) + SvCUR(sv), len - SvCUR(sv));
492         SvCUR_set(sv, len);
493     }
494     SvPOK_only(sv);
495     dc = SvPVX(sv);
496     if (!dc) {
497         sv_setpvn(sv,"",0);
498         dc = SvPVX(sv);
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);
560         if (rightlen > len)
561             sv_catpvn(sv, SvPVX(right) + len, rightlen - len);
562         else if (leftlen > len)
563             sv_catpvn(sv, SvPVX(left) + len, leftlen - len);
564         break;
565     }
566 }
567
568 OP *
569 do_kv(ARGS)
570 dARGS
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