use strict;
use warnings;

use Test::More tests => 2 * ( 2 + 6 + 6 );

use Carp qw( croak );

sub avoid_utf8 {
   my ($s) = @_;
   utf8::downgrade($s, 1)
      or croak("Input not a string of bytes");
   return $s;
}

sub use_utf8 {
   my ($s) = @_;
   utf8::upgrade($s);
   return $s;
}

diag("Perl $]");

for (
   [ "bj\x{f6}rk",    5, 'hibit' ],
   [ "b" x 1000,   1000, 'long'  ],
) {
   my ($s, $length, $test_name) = @$_;


   # length

   my %length;
   $length{'0'} = length avoid_utf8 $s;
   $length{'1'} = length use_utf8   $s;

   for my $enc (qw( 0 1 )) {
      is($length{$enc}, $length, "length $test_name $enc");
   }


   # pack 'V/a*'

   my $expected = pack('V', $length) . $s;

   my %packed;
   $packed{'?0'}  =           pack "V/a*", avoid_utf8 $s;
   $packed{'?1'}  =           pack "V/a*", use_utf8   $s;
   $packed{'00'} = avoid_utf8 pack "V/a*", avoid_utf8 $s;
   $packed{'01'} = avoid_utf8 pack "V/a*", use_utf8   $s;
   $packed{'10'} = use_utf8   pack "V/a*", avoid_utf8 $s;
   $packed{'11'} = use_utf8   pack "V/a*", use_utf8   $s;

   for my $enc (qw( ?0 ?1 00 01 10 11 )) {
      ok($packed{$enc} eq $expected, "pack $test_name $enc");
   }


   # print

   for my $enc (qw( ?0 ?1 00 01 10 11 )) {
      my $buf = '';
      {
         open(my $fh, '>', \$buf);
         binmode $fh;  # No mucking with crlf
         print $fh $packed{$enc};
      }
      ok($buf eq $expected, "print $test_name $enc");
   }
}

##</code><code>##

>c:\progs\perl588\bin\perl test.pl
1..28
# Perl 5.008008
ok 1 - length hibit 0
ok 2 - length hibit 1
ok 3 - pack hibit ?0
not ok 4 - pack hibit ?1
#   Failed test 'pack hibit ?1'
#   at test.pl line 54.
ok 5 - pack hibit 00
not ok 6 - pack hibit 01
#   Failed test 'pack hibit 01'
#   at test.pl line 54.
ok 7 - pack hibit 10
not ok 8 - pack hibit 11
#   Failed test 'pack hibit 11'
#   at test.pl line 54.
ok 9 - print hibit ?0
not ok 10 - print hibit ?1
#   Failed test 'print hibit ?1'
#   at test.pl line 67.
ok 11 - print hibit 00
not ok 12 - print hibit 01
#   Failed test 'print hibit 01'
#   at test.pl line 67.
ok 13 - print hibit 10
not ok 14 - print hibit 11
#   Failed test 'print hibit 11'
#   at test.pl line 67.
ok 15 - length long 0
ok 16 - length long 1
ok 17 - pack long ?0
ok 18 - pack long ?1
ok 19 - pack long 00
ok 20 - pack long 01
ok 21 - pack long 10
ok 22 - pack long 11
ok 23 - print long ?0
ok 24 - print long ?1
ok 25 - print long 00
ok 26 - print long 01
ok 27 - print long 10
ok 28 - print long 11
# Looks like you failed 6 tests of 28.

##</code><code>##

>c:\progs\perl5100\bin\perl test.pl
1..28
# Perl 5.010000
ok 1 - length hibit 0
ok 2 - length hibit 1
ok 3 - pack hibit ?0
ok 4 - pack hibit ?1
ok 5 - pack hibit 00
ok 6 - pack hibit 01
ok 7 - pack hibit 10
ok 8 - pack hibit 11
ok 9 - print hibit ?0
ok 10 - print hibit ?1
ok 11 - print hibit 00
ok 12 - print hibit 01
ok 13 - print hibit 10
ok 14 - print hibit 11
ok 15 - length long 0
ok 16 - length long 1
ok 17 - pack long ?0
ok 18 - pack long ?1
ok 19 - pack long 00
ok 20 - pack long 01
ok 21 - pack long 10
ok 22 - pack long 11
ok 23 - print long ?0
ok 24 - print long ?1
ok 25 - print long 00
ok 26 - print long 01
ok 27 - print long 10
ok 28 - print long 11