t/op/pack.t

   1 #!./perl
   2
   3 # $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
   4
   5 print "1..60\n";
   6
   7 $format = "c2 x5 C C x s d i l a6";
   8 # Need the expression in here to force ary[5] to be numeric.  This avoids
   9 # test2 failing because ary2 goes str->numeric->str and ary doesn't.
  10 @ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef");
  11 $foo = pack($format,@ary);
  12 @ary2 = unpack($format,$foo);
  13
  14 print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n");
  15
  16 $out1=join(':',@ary);
  17 $out2=join(':',@ary2);
  18 print ($out1 eq $out2 ? "ok 2\n" : "not ok 2\n");
  19
  20 print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n");
  21
  22 # How about counting bits?
  23
  24 print +($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16
  25         ? "ok 4\n" : "not ok 4 $x\n";
  26
  27 print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12
  28         ? "ok 5\n" : "not ok 5 $x\n";
  29
  30 print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9
  31         ? "ok 6\n" : "not ok 6 $x\n";
  32
  33 my $sum = 129; # ASCII
  34 $sum = 103 if ($^O eq 'os390'); # An EBCDIC variant.
  35
  36 print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum
  37         ? "ok 7\n" : "not ok 7 $x\n";
  38
  39 open(BIN, "./perl") || open(BIN, "./perl.exe")
  40     || die "Can't open ../perl or ../perl.exe: $!\n";
  41 sysread BIN, $foo, 8192;
  42 close BIN;
  43
  44 $sum = unpack("%32b*", $foo);
  45 $longway = unpack("b*", $foo);
  46 print $sum == $longway =~ tr/1/1/ ? "ok 8\n" : "not ok 8\n";
  47
  48 print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF
  49         ? "ok 9\n" : "not ok 9 $x\n";
  50
  51 # check 'w'
  52 my $test=10;
  53 my @x = (5,130,256,560,32000,3097152,268435455,1073741844,
  54          '4503599627365785','23728385234614992549757750638446');
  55 my $x = pack('w*', @x);
  56 my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';
  57
  58 print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++;
  59
  60 @y = unpack('w*', $y);
  61 my $a;
  62 while ($a = pop @x) {
  63   my $b = pop @y;
  64   print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++;
  65 }
  66
  67 @y = unpack('w2', $x);
  68
  69 print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++;
  70 print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++;
  71
  72 # test exeptions
  73 eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
  74 print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
  75
  76 eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff};
  77 print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
  78
  79 eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
  80 print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
  81
  82 #
  83 # test the "p" template
  84
  85 # literals
  86 print((unpack("p",pack("p","foo")) eq "foo" ? "ok " : "not ok "),$test++,"\n");
  87
  88 # scalars
  89 print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n");
  90
  91 # temps
  92 sub foo { my $a = "a"; return $a . $a++ . $a++ }
  93 {
  94   local $^W = 1;
  95   my $last = $test;
  96   local $SIG{__WARN__} = sub {
  97         print "ok ",$test++,"\n" if $_[0] =~ /temporary val/
  98   };
  99   my $junk = pack("p", &foo);
 100   print "not ok ", $test++, "\n" if $last == $test;
 101 }
 102
 103 # undef should give null pointer
 104 print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n");
 105
 106 # Check for optimizer bug (e.g.  Digital Unix GEM cc with -O4 on DU V4.0B gives
 107 #                                4294967295 instead of -1)
 108 #                                see #ifdef __osf__ in pp.c pp_unpack
 109 # Test 30:
 110 print( ((unpack("i",pack("i",-1))) == -1 ? "ok " : "not ok "),$test++,"\n");
 111
 112 # 31..36: test the pack lengths of s S i I l L
 113 print "not " unless length(pack("s", 0)) == 2;
 114 print "ok ", $test++, "\n";
 115
 116 print "not " unless length(pack("S", 0)) == 2;
 117 print "ok ", $test++, "\n";
 118
 119 print "not " unless length(pack("i", 0)) >= 4;
 120 print "ok ", $test++, "\n";
 121
 122 print "not " unless length(pack("I", 0)) >= 4;
 123 print "ok ", $test++, "\n";
 124
 125 print "not " unless length(pack("l", 0)) == 4;
 126 print "ok ", $test++, "\n";
 127
 128 print "not " unless length(pack("L", 0)) == 4;
 129 print "ok ", $test++, "\n";
 130
 131 # 37..40: test the pack lengths of n N v V
 132
 133 print "not " unless length(pack("n", 0)) == 2;
 134 print "ok ", $test++, "\n";
 135
 136 print "not " unless length(pack("N", 0)) == 4;
 137 print "ok ", $test++, "\n";
 138
 139 print "not " unless length(pack("v", 0)) == 2;
 140 print "ok ", $test++, "\n";
 141
 142 print "not " unless length(pack("V", 0)) == 4;
 143 print "ok ", $test++, "\n";
 144
 145 # 41..56: test unpack-pack lengths
 146
 147 my @templates = qw(c C i I s S l L n N v V f d);
 148
 149 # quads not supported everywhere: if not, retest floats/doubles
 150 # to preserve the test count...
 151 eval { my $q = pack("q",0) };
 152 push @templates, $@ !~ /Invalid type in pack/ ? qw(q Q) : qw(f d);
 153
 154 foreach my $t (@templates) {
 155     my @t = unpack("$t*", pack("$t*", 12, 34));
 156     print "not "
 157       unless @t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i));
 158     print "ok ", $test++, "\n";
 159 }
 160
 161 # 57..60: uuencode/decode
 162
 163 $in = pack 'C*', 0 .. 255;
 164
 165 # just to be anal, we do some random tr/`/ /
 166 $uu = <<'EOUU';
 167 M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL
 168 M+2XO,#$R,S0U-C<X.3H[/#T^/T!!0D-$149'2$E*2TQ-3D]045)35%565UA9
 169 M6EM<75Y?8&%B8V1E9F=H:6IK;&UN;W!Q<G-T=79W>'EZ>WQ]?G^`@8*#A(6&
 170 MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S
 171 MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R<K+S,W.S]#1TM/4U=;7V-G:V]S=WM_@
 172 ?X>+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P `
 173 EOUU
 174
 175 $_ = $uu;
 176 tr/ /`/;
 177 print "not " unless pack('u', $in) eq $_;
 178 print "ok ", $test++, "\n";
 179
 180 print "not " unless unpack('u', $uu) eq $in;
 181 print "ok ", $test++, "\n";
 182
 183 $in = "\x1f\x8b\x08\x08\x58\xdc\xc4\x35\x02\x03\x4a\x41\x50\x55\x00\xf3\x2a\x2d\x2e\x51\x48\xcc\xcb\x2f\xc9\x48\x2d\x52\x08\x48\x2d\xca\x51\x28\x2d\x4d\xce\x4f\x49\x2d\xe2\x02\x00\x64\x66\x60\x5c\x1a\x00\x00\x00";
 184 $uu = <<'EOUU';
 185 M'XL("%C<Q#4"`TI!4%4`\RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>("`&1F
 186 &8%P:````
 187 EOUU
 188
 189 print "not " unless unpack('u', $uu) eq $in;
 190 print "ok ", $test++, "\n";
 191
 192 # 60 identical to 59 except that backquotes have been changed to spaces
 193
 194 $uu = <<'EOUU';
 195 M'XL("%C<Q#4" TI!4%4 \RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>(" &1F
 196 &8%P:
 197 EOUU
 198
 199 print "not " unless unpack('u', $uu) eq $in;
 200 print "ok ", $test++, "\n";
 201
 202 # Note that first uuencoding known 'text' data and then checking the
 203 # binary values of the uuencoded version would not be portable between
 204 # character sets.  Uuencoding is meant for encoding binary data, not
 205 # text data.