Re: Patch for ASN.1 compressed integer in pack/unpack

3 files changed, 118 insertions, 1 deletions

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 6b378730e1..cb2d93fef1 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -1872,6 +1872,11 @@ follows:
 
     u	A uuencoded string.
 
+    w A BER compressed integer. Bytes give an unsigned integer base
+      128, most significant digit first, with as few digits as
+      possible, and with the bit 8 of each byte except the last set
+      to "1."
+
     x	A null byte.
     X	Back up a byte.
     @	Null fill to absolute position.
diff --git a/pp.c b/pp.c
index cc2ef0b0e9..48e332198b 100644
--- a/pp.c
+++ b/pp.c
@@ -2788,6 +2788,51 @@ PP(pp_unpack)
 		PUSHs(sv_2mortal(sv));
 	    }
 	    break;
+	case 'w':
+	    along = (strend - s) / sizeof(char);
+	    if (len > along)
+		len = along;
+	    EXTEND(SP, len);
+            { 
+              I8  bytes = 0;
+
+              auint = 0;
+              while  (len > 0) {
+                if (s >= strend) {
+                  if (auint) {
+                    DIE("Unterminated compressed integer");
+                  } else {
+                    break;
+                  }
+                }
+                auint = (auint << 7) | (*s & 0x7f);
+                if (!(*s & 0x80)) {
+                  sv = NEWSV(40, 0);
+                  sv_setiv(sv, (I32) auint);
+                  PUSHs(sv_2mortal(sv));
+                  len--;
+                  auint = 0;
+                  bytes = 0;
+                } else if (++bytes >= sizeof(auint)) {         /* promote to double */
+                  adouble = auint;
+
+                  while (*s &  0x80) {
+                    adouble = (adouble * 128) + (*(++s) & 0x7f);
+                    if (s >= strend) {
+                      DIE("Unterminated compressed integer");
+                    }
+                  }
+                  sv = NEWSV(40, 0);
+                  sv_setnv(sv, adouble);
+                  PUSHs(sv_2mortal(sv));
+                  len--;
+                  auint = 0;
+                  bytes = 0;
+                }
+                s++;
+              }
+            }
+	    break;
 	case 'P':
 	    EXTEND(SP, 1);
 	    if (sizeof(char*) > strend - s)
@@ -3263,6 +3308,42 @@ PP(pp_pack)
 		sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
 	    }
 	    break;
+	case 'w':
+            while (len-- > 0) {
+              fromstr = NEXTFROM;
+              adouble = floor((double)SvNV(fromstr));
+
+              if (adouble < 268435456) {           /* we can use integers */
+                unsigned char buf[4];              /* buffer for compressed int */
+                unsigned char *in = buf + 3;
+                auint = U_I(adouble);
+                do {
+                  *(in--) = (unsigned char) ((auint & 0x7f) |  0x80); 
+                  auint >>= 7;
+                } while (auint);
+                buf[3]  &= 0x7f;                   /* clear continue bit */
+                sv_catpvn(cat, (char*) in+1, buf+3-in);
+              } else {
+                unsigned char buf[sizeof(double)*2]; /* buffer for compressed int */
+                I8       msize = sizeof(double)*2; /* 8/7 would be enough */
+                unsigned char *in = buf + msize -1;
+                if (adouble<0) {
+                  croak("Cannot compress negative numbers");
+                }
+                do  {
+                  double next = adouble/128;
+                  *in = (unsigned char) (adouble - floor(next)*128);
+                  *in |= 0x80;                     /* set continue bit */
+                  if (--in < buf) {                /* this cannot happen ;-) */
+                    croak ("Cannot compress integer");
+                  }
+                  adouble = next;
+                } while (floor(adouble)>0);        /* floor() not necessary? */
+                buf[msize-1] &= 0x7f;              /* clear continue bit */
+                sv_catpvn(cat, (char*) in+1, buf+msize-in-1);
+              }
+            }
+            break;
 	case 'i':
 	    while (len-- > 0) {
 		fromstr = NEXTFROM;
diff --git a/t/op/pack.t b/t/op/pack.t
index ee228d922c..f15a7033ab 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
 
-print "1..9\n";
+print "1..16\n";
 
 $format = "c2x5CCxsdila6";
 # Need the expression in here to force ary[5] to be numeric.  This avoids
@@ -44,3 +44,34 @@ print $sum == $longway =~ tr/1/1/ ? "ok 8\n" : "not ok 8\n";
 
 print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF
 	? "ok 9\n" : "not ok 9 $x\n";
+
+# check 'w'
+my $test=10;
+my @x = (5,130,256,560,32000,3097152,268435455,2**30+20, 2**56+4711);
+my $x = pack('w*', @x);
+my $y = pack 'C*', 5,129,2,130,0,132,48,129,250,0,129,189,132,64,255,255,255,
+                   127,132,128,128,128,20,129,128,128,128,128,128,128,164,96;
+
+print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++;
+
+@y = unpack('w*', $y);
+my $a = join ':', @x;
+my $b = join ':', @y;
+
+print $a eq $b ? "ok $test\n" : "not ok $test\n"; $test++;
+
+@y = unpack('w2', $x);
+
+print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++;
+print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++;
+
+# test exections
+eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
+print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
+
+eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff};
+print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
+
+eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
+print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
+