perl 5.003_06: pod/perldiag.pod
[perl.git] / doop.c
1 /*    doop.c
2  *
3  *    Copyright (c) 1991-1994, 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  */
9
10 /*
11  * "'So that was the job I felt I had to do when I started,' thought Sam."
12  */
13
14 #include "EXTERN.h"
15 #include "perl.h"
16
17 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
18 #include <signal.h>
19 #endif
20
21 #ifdef BUGGY_MSC
22  #pragma function(memcmp)
23 #endif /* BUGGY_MSC */
24
25 #ifdef BUGGY_MSC
26  #pragma intrinsic(memcmp)
27 #endif /* BUGGY_MSC */
28
29 I32
30 do_trans(sv,arg)
31 SV *sv;
32 OP *arg;
33 {
34     register short *tbl;
35     register U8 *s;
36     register U8 *send;
37     register U8 *d;
38     register I32 ch;
39     register I32 matches = 0;
40     register I32 squash = op->op_private & OPpTRANS_SQUASH;
41     STRLEN len;
42
43     if (SvREADONLY(sv))
44         croak(no_modify);
45     tbl = (short*)cPVOP->op_pv;
46     s = (U8*)SvPV(sv, len);
47     if (!len)
48         return 0;
49     if (!SvPOKp(sv))
50         s = (U8*)SvPV_force(sv, len);
51     (void)SvPOK_only(sv);
52     send = s + len;
53     if (!tbl || !s)
54         croak("panic: do_trans");
55     DEBUG_t( deb("2.TBL\n"));
56     if (!op->op_private) {
57         while (s < send) {
58             if ((ch = tbl[*s]) >= 0) {
59                 matches++;
60                 *s = ch;
61             }
62             s++;
63         }
64     }
65     else {
66         d = s;
67         while (s < send) {
68             if ((ch = tbl[*s]) >= 0) {
69                 *d = ch;
70                 if (matches++ && squash) {
71                     if (d[-1] == *d)
72                         matches--;
73                     else
74                         d++;
75                 }
76                 else
77                     d++;
78             }
79             else if (ch == -1)          /* -1 is unmapped character */
80                 *d++ = *s;              /* -2 is delete character */
81             s++;
82         }
83         matches += send - d;    /* account for disappeared chars */
84         *d = '\0';
85         SvCUR_set(sv, d - (U8*)SvPVX(sv));
86     }
87     SvSETMAGIC(sv);
88     return matches;
89 }
90
91 void
92 do_join(sv,del,mark,sp)
93 register SV *sv;
94 SV *del;
95 register SV **mark;
96 register SV **sp;
97 {
98     SV **oldmark = mark;
99     register I32 items = sp - mark;
100     register STRLEN len;
101     STRLEN delimlen;
102     register char *delim = SvPV(del, delimlen);
103     STRLEN tmplen;
104
105     mark++;
106     len = (items > 0 ? (delimlen * (items - 1) ) : 0);
107     if (SvTYPE(sv) < SVt_PV)
108         sv_upgrade(sv, SVt_PV);
109     if (SvLEN(sv) < len + items) {      /* current length is way too short */
110         while (items-- > 0) {
111             if (*mark) {
112                 SvPV(*mark, tmplen);
113                 len += tmplen;
114             }
115             mark++;
116         }
117         SvGROW(sv, len + 1);            /* so try to pre-extend */
118
119         mark = oldmark;
120         items = sp - mark;;
121         ++mark;
122     }
123
124     if (items-- > 0) {
125         char *s;
126
127         if (*mark) {
128             s = SvPV(*mark, tmplen);
129             sv_setpvn(sv, s, tmplen);
130         }
131         else
132             sv_setpv(sv, "");
133         mark++;
134     }
135     else
136         sv_setpv(sv,"");
137     len = delimlen;
138     if (len) {
139         for (; items > 0; items--,mark++) {
140             sv_catpvn(sv,delim,len);
141             sv_catsv(sv,*mark);
142         }
143     }
144     else {
145         for (; items > 0; items--,mark++)
146             sv_catsv(sv,*mark);
147     }
148     SvSETMAGIC(sv);
149 }
150
151 void
152 do_sprintf(sv,len,sarg)
153 register SV *sv;
154 register I32 len;
155 register SV **sarg;
156 {
157     register char *s;
158     register char *t;
159     register char *f;
160     bool dolong;
161 #ifdef HAS_QUAD
162     bool doquad;
163 #endif /* HAS_QUAD */
164     char ch;
165     register char *send;
166     register SV *arg;
167     char *xs;
168     I32 xlen;
169     I32 pre;
170     I32 post;
171     double value;
172     STRLEN arglen;
173
174     sv_setpv(sv,"");
175     len--;                      /* don't count pattern string */
176     t = s = SvPV(*sarg, arglen);        /* XXX Don't know t is writeable */
177     send = s + arglen;
178     sarg++;
179     for ( ; ; len--) {
180
181         /*SUPPRESS 560*/
182         if (len <= 0 || !(arg = *sarg++))
183             arg = &sv_no;
184
185         /*SUPPRESS 530*/
186         for ( ; t < send && *t != '%'; t++) ;
187         if (t >= send)
188             break;              /* end of run_format string, ignore extra args */
189         f = t;
190         *buf = '\0';
191         xs = buf;
192 #ifdef HAS_QUAD
193         doquad =
194 #endif /* HAS_QUAD */
195         dolong = FALSE;
196         pre = post = 0;
197         for (t++; t < send; t++) {
198             switch (*t) {
199             default:
200                 ch = *(++t);
201                 *t = '\0';
202                 (void)sprintf(xs,f);
203                 len++, sarg--;
204                 xlen = strlen(xs);
205                 break;
206             case 'n': case '*':
207                 croak("Use of %c in printf format not supported", *t);
208
209             case '0': case '1': case '2': case '3': case '4':
210             case '5': case '6': case '7': case '8': case '9': 
211             case '.': case '#': case '-': case '+': case ' ':
212                 continue;
213             case 'l':
214 #ifdef HAS_QUAD
215                 if (dolong) {
216                     dolong = FALSE;
217                     doquad = TRUE;
218                 } else
219 #endif
220                 dolong = TRUE;
221                 continue;
222             case 'c':
223                 ch = *(++t);
224                 *t = '\0';
225                 xlen = SvIV(arg);
226                 if (strEQ(f,"%c")) { /* some printfs fail on null chars */
227                     *xs = xlen;
228                     xs[1] = '\0';
229                     xlen = 1;
230                 }
231                 else {
232                     (void)sprintf(xs,f,xlen);
233                     xlen = strlen(xs);
234                 }
235                 break;
236             case 'D':
237                 dolong = TRUE;
238                 /* FALL THROUGH */
239             case 'd':
240                 ch = *(++t);
241                 *t = '\0';
242 #ifdef HAS_QUAD
243                 if (doquad)
244                     (void)sprintf(buf,s,(Quad_t)SvNV(arg));
245                 else
246 #endif
247                 if (dolong)
248                     (void)sprintf(xs,f,(long)SvNV(arg));
249                 else
250                     (void)sprintf(xs,f,SvIV(arg));
251                 xlen = strlen(xs);
252                 break;
253             case 'X': case 'O':
254                 dolong = TRUE;
255                 /* FALL THROUGH */
256             case 'x': case 'o': case 'u':
257                 ch = *(++t);
258                 *t = '\0';
259                 value = SvNV(arg);
260 #ifdef HAS_QUAD
261                 if (doquad)
262                     (void)sprintf(buf,s,(unsigned Quad_t)value);
263                 else
264 #endif
265                 if (dolong)
266                     (void)sprintf(xs,f,U_L(value));
267                 else
268                     (void)sprintf(xs,f,U_I(value));
269                 xlen = strlen(xs);
270                 break;
271             case 'E': case 'e': case 'f': case 'G': case 'g':
272                 ch = *(++t);
273                 *t = '\0';
274                 (void)sprintf(xs,f,SvNV(arg));
275                 xlen = strlen(xs);
276                 break;
277             case 's':
278                 ch = *(++t);
279                 *t = '\0';
280                 xs = SvPV(arg, arglen);
281                 xlen = (I32)arglen;
282                 if (strEQ(f,"%s")) {    /* some printfs fail on >128 chars */
283                     break;              /* so handle simple cases */
284                 }
285                 else if (f[1] == '-') {
286                     char *mp = strchr(f, '.');
287                     I32 min = atoi(f+2);
288
289                     if (mp) {
290                         I32 max = atoi(mp+1);
291
292                         if (xlen > max)
293                             xlen = max;
294                     }
295                     if (xlen < min)
296                         post = min - xlen;
297                     break;
298                 }
299                 else if (isDIGIT(f[1])) {
300                     char *mp = strchr(f, '.');
301                     I32 min = atoi(f+1);
302
303                     if (mp) {
304                         I32 max = atoi(mp+1);
305
306                         if (xlen > max)
307                             xlen = max;
308                     }
309                     if (xlen < min)
310                         pre = min - xlen;
311                     break;
312                 }
313                 strcpy(tokenbuf+64,f);  /* sprintf($s,...$s...) */
314                 *t = ch;
315                 (void)sprintf(buf,tokenbuf+64,xs);
316                 xs = buf;
317                 xlen = strlen(xs);
318                 break;
319             }
320             /* end of switch, copy results */
321             *t = ch;
322             if (xs == buf && xlen >= sizeof(buf)) {     /* Ooops! */
323                 PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n");
324                 my_exit(1);
325             }
326             SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
327             sv_catpvn(sv, s, f - s);
328             if (pre) {
329                 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
330                 SvCUR(sv) += pre;
331             }
332             sv_catpvn(sv, xs, xlen);
333             if (post) {
334                 repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
335                 SvCUR(sv) += post;
336             }
337             s = t;
338             break;              /* break from for loop */
339         }
340     }
341     sv_catpvn(sv, s, t - s);
342     SvSETMAGIC(sv);
343 }
344
345 void
346 do_vecset(sv)
347 SV *sv;
348 {
349     SV *targ = LvTARG(sv);
350     register I32 offset;
351     register I32 size;
352     register unsigned char *s;
353     register unsigned long lval;
354     I32 mask;
355     STRLEN targlen;
356     STRLEN len;
357
358     if (!targ)
359         return;
360     s = (unsigned char*)SvPV_force(targ, targlen);
361     lval = U_L(SvNV(sv));
362     offset = LvTARGOFF(sv);
363     size = LvTARGLEN(sv);
364     
365     len = (offset + size + 7) / 8;
366     if (len > targlen) {
367         s = (unsigned char*)SvGROW(targ, len + 1);
368         (void)memzero(s + targlen, len - targlen + 1);
369         SvCUR_set(targ, len);
370     }
371     
372     if (size < 8) {
373         mask = (1 << size) - 1;
374         size = offset & 7;
375         lval &= mask;
376         offset >>= 3;
377         s[offset] &= ~(mask << size);
378         s[offset] |= lval << size;
379     }
380     else {
381         offset >>= 3;
382         if (size == 8)
383             s[offset] = lval & 255;
384         else if (size == 16) {
385             s[offset] = (lval >> 8) & 255;
386             s[offset+1] = lval & 255;
387         }
388         else if (size == 32) {
389             s[offset] = (lval >> 24) & 255;
390             s[offset+1] = (lval >> 16) & 255;
391             s[offset+2] = (lval >> 8) & 255;
392             s[offset+3] = lval & 255;
393         }
394     }
395 }
396
397 void
398 do_chop(astr,sv)
399 register SV *astr;
400 register SV *sv;
401 {
402     STRLEN len;
403     char *s;
404     
405     if (SvTYPE(sv) == SVt_PVAV) {
406         register I32 i;
407         I32 max;
408         AV* av = (AV*)sv;
409         max = AvFILL(av);
410         for (i = 0; i <= max; i++) {
411             sv = (SV*)av_fetch(av, i, FALSE);
412             if (sv && ((sv = *(SV**)sv), sv != &sv_undef))
413                 do_chop(astr, sv);
414         }
415         return;
416     }
417     if (SvTYPE(sv) == SVt_PVHV) {
418         HV* hv = (HV*)sv;
419         HE* entry;
420         (void)hv_iterinit(hv);
421         /*SUPPRESS 560*/
422         while (entry = hv_iternext(hv))
423             do_chop(astr,hv_iterval(hv,entry));
424         return;
425     }
426     s = SvPV(sv, len);
427     if (len && !SvPOK(sv))
428         s = SvPV_force(sv, len);
429     if (s && len) {
430         s += --len;
431         sv_setpvn(astr, s, 1);
432         *s = '\0';
433         SvCUR_set(sv, len);
434         SvNIOK_off(sv);
435     }
436     else
437         sv_setpvn(astr, "", 0);
438     SvSETMAGIC(sv);
439
440
441 I32
442 do_chomp(sv)
443 register SV *sv;
444 {
445     register I32 count;
446     STRLEN len;
447     char *s;
448
449     if (RsSNARF(rs))
450         return 0;
451     count = 0;
452     if (SvTYPE(sv) == SVt_PVAV) {
453         register I32 i;
454         I32 max;
455         AV* av = (AV*)sv;
456         max = AvFILL(av);
457         for (i = 0; i <= max; i++) {
458             sv = (SV*)av_fetch(av, i, FALSE);
459             if (sv && ((sv = *(SV**)sv), sv != &sv_undef))
460                 count += do_chomp(sv);
461         }
462         return count;
463     }
464     if (SvTYPE(sv) == SVt_PVHV) {
465         HV* hv = (HV*)sv;
466         HE* entry;
467         (void)hv_iterinit(hv);
468         /*SUPPRESS 560*/
469         while (entry = hv_iternext(hv))
470             count += do_chomp(hv_iterval(hv,entry));
471         return count;
472     }
473     s = SvPV(sv, len);
474     if (len && !SvPOKp(sv))
475         s = SvPV_force(sv, len);
476     if (s && len) {
477         s += --len;
478         if (RsPARA(rs)) {
479             if (*s != '\n')
480                 goto nope;
481             ++count;
482             while (len && s[-1] == '\n') {
483                 --len;
484                 --s;
485                 ++count;
486             }
487         }
488         else {
489             STRLEN rslen;
490             char *rsptr = SvPV(rs, rslen);
491             if (rslen == 1) {
492                 if (*s != *rsptr)
493                     goto nope;
494                 ++count;
495             }
496             else {
497                 if (len < rslen - 1)
498                     goto nope;
499                 len -= rslen - 1;
500                 s -= rslen - 1;
501                 if (memcmp(s, rsptr, rslen))
502                     goto nope;
503                 count += rslen;
504             }
505         }
506         *s = '\0';
507         SvCUR_set(sv, len);
508         SvNIOK_off(sv);
509     }
510   nope:
511     SvSETMAGIC(sv);
512     return count;
513
514
515 void
516 do_vop(optype,sv,left,right)
517 I32 optype;
518 SV *sv;
519 SV *left;
520 SV *right;
521 {
522 #ifdef LIBERAL
523     register long *dl;
524     register long *ll;
525     register long *rl;
526 #endif
527     register char *dc;
528     STRLEN leftlen;
529     STRLEN rightlen;
530     register char *lc = SvPV(left, leftlen);
531     register char *rc = SvPV(right, rightlen);
532     register I32 len;
533     I32 lensave;
534     char *lsave = lc;
535     char *rsave = rc;
536
537     dc = SvPV_force(sv,na);
538     len = leftlen < rightlen ? leftlen : rightlen;
539     lensave = len;
540     if (SvCUR(sv) < len) {
541         dc = SvGROW(sv,len + 1);
542         (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
543     }
544     SvCUR_set(sv, len);
545     (void)SvPOK_only(sv);
546 #ifdef LIBERAL
547     if (len >= sizeof(long)*4 &&
548         !((long)dc % sizeof(long)) &&
549         !((long)lc % sizeof(long)) &&
550         !((long)rc % sizeof(long)))     /* It's almost always aligned... */
551     {
552         I32 remainder = len % (sizeof(long)*4);
553         len /= (sizeof(long)*4);
554
555         dl = (long*)dc;
556         ll = (long*)lc;
557         rl = (long*)rc;
558
559         switch (optype) {
560         case OP_BIT_AND:
561             while (len--) {
562                 *dl++ = *ll++ & *rl++;
563                 *dl++ = *ll++ & *rl++;
564                 *dl++ = *ll++ & *rl++;
565                 *dl++ = *ll++ & *rl++;
566             }
567             break;
568         case OP_BIT_XOR:
569             while (len--) {
570                 *dl++ = *ll++ ^ *rl++;
571                 *dl++ = *ll++ ^ *rl++;
572                 *dl++ = *ll++ ^ *rl++;
573                 *dl++ = *ll++ ^ *rl++;
574             }
575             break;
576         case OP_BIT_OR:
577             while (len--) {
578                 *dl++ = *ll++ | *rl++;
579                 *dl++ = *ll++ | *rl++;
580                 *dl++ = *ll++ | *rl++;
581                 *dl++ = *ll++ | *rl++;
582             }
583         }
584
585         dc = (char*)dl;
586         lc = (char*)ll;
587         rc = (char*)rl;
588
589         len = remainder;
590     }
591 #endif
592     {
593         switch (optype) {
594         case OP_BIT_AND:
595             while (len--)
596                 *dc++ = *lc++ & *rc++;
597             break;
598         case OP_BIT_XOR:
599             while (len--)
600                 *dc++ = *lc++ ^ *rc++;
601             goto mop_up;
602         case OP_BIT_OR:
603             while (len--)
604                 *dc++ = *lc++ | *rc++;
605           mop_up:
606             len = lensave;
607             if (rightlen > len)
608                 sv_catpvn(sv, rsave + len, rightlen - len);
609             else if (leftlen > len)
610                 sv_catpvn(sv, lsave + len, leftlen - len);
611             else
612                 *SvEND(sv) = '\0';
613             break;
614         }
615     }
616 }
617
618 OP *
619 do_kv(ARGS)
620 dARGS
621 {
622     dSP;
623     HV *hv = (HV*)POPs;
624     register HE *entry;
625     SV *tmpstr;
626     I32 dokeys =   (op->op_type == OP_KEYS);
627     I32 dovalues = (op->op_type == OP_VALUES);
628
629     if (op->op_type == OP_RV2HV || op->op_type == OP_PADHV) 
630         dokeys = dovalues = TRUE;
631
632     if (!hv) {
633         if (op->op_flags & OPf_MOD) {   /* lvalue */
634             dTARGET;            /* make sure to clear its target here */
635             if (SvTYPE(TARG) == SVt_PVLV)
636                 LvTARG(TARG) = Nullsv;
637             PUSHs(TARG);
638         }
639         RETURN;
640     }
641
642     (void)hv_iterinit(hv);      /* always reset iterator regardless */
643
644     if (GIMME != G_ARRAY) {
645         I32 i;
646         dTARGET;
647
648         if (op->op_flags & OPf_MOD) {   /* lvalue */
649             if (SvTYPE(TARG) < SVt_PVLV) {
650                 sv_upgrade(TARG, SVt_PVLV);
651                 sv_magic(TARG, Nullsv, 'k', Nullch, 0);
652             }
653             LvTYPE(TARG) = 'k';
654             LvTARG(TARG) = (SV*)hv;
655             PUSHs(TARG);
656             RETURN;
657         }
658
659         if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
660             i = HvKEYS(hv);
661         else {
662             i = 0;
663             /*SUPPRESS 560*/
664             while (entry = hv_iternext(hv)) {
665                 i++;
666             }
667         }
668         PUSHi( i );
669         RETURN;
670     }
671
672     /* Guess how much room we need.  hv_max may be a few too many.  Oh well. */
673     EXTEND(sp, HvMAX(hv) * (dokeys + dovalues));
674
675     PUTBACK;    /* hv_iternext and hv_iterval might clobber stack_sp */
676     while (entry = hv_iternext(hv)) {
677         SPAGAIN;
678         if (dokeys)
679             XPUSHs(hv_iterkeysv(entry));        /* won't clobber stack_sp */
680         if (dovalues) {
681             tmpstr = NEWSV(45,0);
682             PUTBACK;
683             sv_setsv(tmpstr,hv_iterval(hv,entry));
684             SPAGAIN;
685             DEBUG_H( {
686                         sprintf(buf,"%d%%%d=%d\n", HeHASH(entry),
687                                 HvMAX(hv)+1, HeHASH(entry) & HvMAX(hv));
688                         sv_setpv(tmpstr,buf);
689             } )
690             XPUSHs(sv_2mortal(tmpstr));
691         }
692         PUTBACK;
693     }
694     return NORMAL;
695 }
696