tr/// returns histogram

This was on the Todo, so I had a look at it. I've tried to keep within
the do_trans_XX_operation thing, which may not have been such a good
idea. On the other hand, I don't think we'd be better off special-casing
in pp.c; your mileage may vary. I've not managed to work out how to
convert it to Unicode as well, but I'm hoping someone else will have a
look at that if I don't have time. Here's a patch, anyway, it works.
Be sure to regen headers.

% perl -le '$_=q/abcdbaa/; %a=tr/abc/def/; print "$k,$v\n" while each %a"'
a,3
b,2
c,1

diff -ruN perl5.5.660/doop.c perl5.5.660-new/doop.c
--- perl5.5.660/doop.c	Mon Feb  7 04:32:59 2000
+++ perl5.5.660-new/doop.c	Sun Feb 20 02:57:55 2000
@@ -131,6 +131,85 @@
 
     return matches;
 }
+STATIC I32
+S_do_trans_CC_histogram(pTHX_ SV *sv)
+{
+	dSP;
+    U8 *s;
+    U8 *send;
+    U8 *d;
+	HV *histo;
+    STRLEN len;
+    short *tbl;
+    I32 ch;
+	SV *value;
+	char *key; 
+	I32 keylen;
+	
+    tbl = (short*)cPVOP->op_pv;
+
+	histo = newHV();
+	
+    if (!tbl)
+	Perl_croak(aTHX_ "panic: do_trans");
+
+    s = (U8*)SvPV(sv, len);
+    send = s + len;
+
+    d = s;
+    if (PL_op->op_private & OPpTRANS_SQUASH) {
+	U8* p = send;
+
+	while (s < send) {
+	    if ((ch = tbl[*s]) >= 0) {
+		/* $histo{$ch}++ - A Prime Example of Why Perl is not C */
+		if(hv_exists(histo,s,1))
+			(void)hv_store(histo, s, 1, 
+				newSViv(1+SvIV((hv_fetch(histo,s,1,FALSE))[0])),0);
+		 else 
+			(void)hv_store(histo,s,1,newSViv(1),0);
+
+		*d = ch;
+		if (p != d - 1 || *p != *d)
+		    p = d++;
+		}
+	    else if (ch == -1)		/* -1 is unmapped character */
+		*d++ = *s;		/* -2 is delete character */
+	    s++;
+	}
+	}
+    else {
+	while (s < send) {
+	    if ((ch = tbl[*s]) >= 0) {
+		if(hv_exists(histo,s,1))
+			(void)hv_store(histo, s, 1, 
+				newSViv(1+SvIV((hv_fetch(histo,s,1,FALSE))[0])),0);
+		 else 
+			(void)hv_store(histo,s,1,newSViv(1),0);
+		*d = ch;
+		d++;
+	    }
+	    else if (ch == -1)		/* -1 is unmapped character */
+		*d++ = *s;		/* -2 is delete character */
+	    s++;
+	}
+    }
+    *d = '\0';
+    SvCUR_set(sv, d - (U8*)SvPVX(sv));
+    SvSETMAGIC(sv);
+
+	/* Take care of pushing the hash onto the stack */
+	
+	(void)hv_iterinit(histo);
+	while(value=hv_iternextsv(histo,&key,&keylen)) {
+		XPUSHs(sv_2mortal(newSVpv(key,keylen)));
+		XPUSHs(sv_2mortal(newSViv(SvIV(value))));
+	}
+	PUTBACK;
+
+	hv_undef(histo);
+    return -1;
+}
 
 STATIC I32
 S_do_trans_UU_simple(pTHX_ SV *sv)
@@ -596,6 +675,13 @@
 
     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 
+	if (GIMME == G_ARRAY) {
+		if (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
+			Perl_croak(aTHX_ "Not yet here");
+		else
+			return do_trans_CC_histogram(sv);
+	}
+	
     switch (PL_op->op_private & 63) {
     case 0:
 	return do_trans_CC_simple(sv);
diff -ruN perl5.5.660/embed.pl perl5.5.660-new/embed.pl
--- perl5.5.660/embed.pl	Wed Feb 16 21:42:30 2000
+++ perl5.5.660-new/embed.pl	Thu Feb 17 23:38:44 2000
@@ -2153,6 +2153,7 @@
 s	|I32	|do_trans_CC_simple	|SV *sv
 s	|I32	|do_trans_CC_count	|SV *sv
 s	|I32	|do_trans_CC_complex	|SV *sv
+s	|I32	|do_trans_CC_histogram	|SV *sv
 s	|I32	|do_trans_UU_simple	|SV *sv
 s	|I32	|do_trans_UU_count	|SV *sv
 s	|I32	|do_trans_UU_complex	|SV *sv
diff -ruN perl5.5.660/opcode.pl perl5.5.660-new/opcode.pl
--- perl5.5.660/opcode.pl	Thu Jan 13 06:03:56 2000
+++ perl5.5.660-new/opcode.pl	Thu Feb 17 23:29:47 2000
@@ -392,7 +392,7 @@
 qr		pattern quote (qr//)	ck_match	s/
 subst		substitution (s///)	ck_null		dis/	S
 substcont	substitution iterator	ck_null		dis|	
-trans		transliteration (tr///)	ck_null		is"	S
+trans		transliteration (tr///)	ck_null		i"	S
 
 # Lvalue operators.
 # sassign is special-cased for op class
diff -ruN perl5.5.660/pp.c perl5.5.660-new/pp.c
--- perl5.5.660/pp.c	Mon Feb  7 15:37:51 2000
+++ perl5.5.660-new/pp.c	Sun Feb 20 02:24:28 2000
@@ -726,6 +726,7 @@
 {
     djSP; dTARG;
     SV *sv;
+	IV retval;
 
     if (PL_op->op_flags & OPf_STACKED)
 	sv = POPs;
@@ -734,8 +735,12 @@
 	EXTEND(SP,1);
     }
     TARG = sv_newmortal();
-    PUSHi(do_trans(sv));
-    RETURN;
+    retval = (IV)do_trans(sv);
+	if (retval >0) {
+		PUSHs(newSViv(retval));
+		PUTBACK;
+	}
+	return NORMAL;
 }
 
 /* Lvalue operators. */

-- 
`And when you've been *plonk*ed by Simon C., you've been *plonked*
by someone who knows when, and why, and how.' - Mike Andrews, asr

• tr/// returns histogram by simon
• Smoke [5.9.0] 20717 PASS freebsd 5.0-release (i386/1 cpu) by kane