#!/usr/local/bin/perl

#
# Test that high tag values (greater than 30) work
#


use lib "/l/dbi";

use Convert::BER 1.31 qw(/BER/ ber_tag);


print "1..213\n";

$tcount = $test = 1;

sub test (&) {
    my $sub = shift;
    eval { $sub->() };
    ## print "# $@" if $@;

    print "not ok ",$test++," # skipped\n"
        while($test < $tcount);

    warn "count mismatch test=$test tcount=$tcount"
	unless $test == $tcount;

    $tcount = $test;
}




##
## IMPLICIT TAG, inline
##

@TAGS = (# Value                          Bytes in tag
         ###################################################
         [ber_tag(0,38),                  0x1f, 0x26],
         [ber_tag(BER_CONTEXT,39),        0x9f, 0x27],
         [ber_tag(BER_APPLICATION,40),    0x5f, 0x28],
         [ber_tag(BER_UNIVERSAL,41),      0x1f, 0x29],
         [ber_tag(BER_PRIVATE,42),        0xdf, 0x2a],
         [ber_tag(BER_PRIMITIVE,43),      0x1f, 0x2b], 
         [ber_tag(BER_CONSTRUCTOR,44),    0x3f, 0x2c], 
         
         [ber_tag(0,0x138),               0x1f, 0x82, 0x38],
         [ber_tag(BER_CONTEXT,0x139),     0x9f, 0x82, 0x39],
         [ber_tag(BER_APPLICATION,0x140), 0x5f, 0x82, 0x40],
         [ber_tag(BER_UNIVERSAL,0x141),   0x1f, 0x82, 0x41],
         [ber_tag(BER_PRIVATE,0x142),     0xdf, 0x82, 0x42],
         [ber_tag(BER_PRIMITIVE,0x143),   0x1f, 0x82, 0x43],
         [ber_tag(BER_CONSTRUCTOR,0x144), 0x3f, 0x82, 0x44],
         
         [ber_tag(BER_CONTEXT | BER_CONSTRUCTOR, 1), 0xa1],
         );

# [type, value, length and value bytes].
@VALUES = ([STRING => "A string",
            0x08, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67],
           
           [SEQUENCE => [INTEGER => 1, BOOLEAN => 0, STRING => "A string",],
            0x10, # length
            0x02, 0x01, 0x01, # integer 
            0x01, 0x01, 0x00, # boolean
            0x04, 0x08, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67 # string
            ],
           );

foreach $tagref (@TAGS) {
    my ($tag, @tag) = @$tagref;

    foreach $valref (@VALUES) {
        my ($type, $val, @result) = @$valref;
        printf "# [$type => 0x%x] => %s\n", $tag, (ref $val) ? "@$val" : $val;
        
        $tcount += 6;
        
        test {
            my $ber = Convert::BER->new->encode([$type=>$tag] => $val) or die;

                print "ok ",$test++,"\n";

            die "Bad tag value" unless $ber->tag() == $tag;

                print "ok ",$test++,"\n";

            my $result = pack("C*", @tag, @result);
            die "Bad result" unless $ber->buffer eq $result;

	        print "ok ",$test++,"\n";

            if ("STRING" eq $type) {
                my $str = undef;
                $ber->decode( [ $type => $tag ] => \$str) or die;

                    print "ok ",$test++,"\n";

                die "Defined" unless defined($str);

                    print "ok ",$test++,"\n";

                die "Equal" unless ($str eq $val);

                    print "ok ",$test++,"\n";
            }
            elsif ("SEQUENCE" eq $type) {
                my ($int, $bool, $str) = (undef, undef, undef);
                $ber->decode(
                    [ $type => $tag ] => [
                        INTEGER => \$int,
                        BOOLEAN => \$bool,
                        STRING  => \$str,
                
                    ] 
                ) or die;

                    print "ok ",$test++,"\n";

                die "Defined"
                    unless defined($str) && defined($int) && defined($bool);

                    print "ok ",$test++,"\n";

                die "Equal" 
                    unless ($str eq "A string") && ($int==1) && ($bool==0);

                    print "ok ",$test++,"\n";
            }
        }
    }
}

##
## IMPLICIT TAG, subclass
##

package Test::BER;

use Convert::BER qw(/BER_/ /^\$/ ber_tag);

@ISA = qw(Convert::BER);

Test::BER->define(

  # Name          Type          Tag
  ########################################

  [ SUB_STRING => $STRING,
   ber_tag(BER_CONTEXT | BER_PRIMITIVE, 0x101) ],

  [ SUB_SEQ    => $SEQUENCE,    
   ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, 0x300) ],

  [ SUB_SEQ_OF => $SEQUENCE_OF, 
   ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, 0x36) ],
                  
);


package main;

##
## SUB_STRING
##

my %STRING = (
    ""		=> pack("C*",   0x9F, 0x82, 0x01, 0x00),
    "A string"	=> pack("CCCCa*", 0x9F, 0x82, 0x01, 0x08, "A string"),
);

while(($val,$result) = each %STRING) {
    print "# SUB_STRING '$val'\n";

    $tcount += 5;
    test {
        my $ber = Test::BER->new->encode( SUB_STRING => $val) or die;

	    print "ok ",$test++,"\n";

	die unless $ber->buffer eq $result;

	    print "ok ",$test++,"\n";

	my $str = undef;

	die unless $ber->decode( SUB_STRING => \$str);

	    print "ok ",$test++,"\n";

	die unless defined($str);

	    print "ok ",$test++,"\n";

	die unless ($str eq $val);

	    print "ok ",$test++,"\n";
    }
}

##
## SUB_SEQ
##

print "# SUB_SEQ\n";

$tcount += 6;
test {
    my $ber = Test::BER->new->encode(
	SUB_SEQ => [
	    INTEGER => 1,
	    BOOLEAN => 0,
	    STRING => "A string"
	]
    ) or die;

    my $data = $ber->buffer;

	print "ok ",$test++,"\n";

    my $result = pack("C*", 0x7F, 0x86, 0x00, # tag
                      0x10, # length
                      0x02, 0x01, 0x01, # integer 
                      0x01, 0x01, 0x00, # boolean
                      0x04, 0x08, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 
                      0x6E, 0x67
    );

    die unless $ber->buffer eq $result;

	print "ok ",$test++,"\n";

    my $seq = undef;
    die unless $ber->decode(SUB_SEQ => \$seq) && $seq;

	print "ok ",$test++,"\n";

    die unless substr($result,4) eq $seq->buffer;

	print "ok ",$test++,"\n";

    $ber = new Test::BER($data) or die;

	print "ok ",$test++,"\n";

    my($int,$bool,$str);

    $ber->decode(
	SUB_SEQ => [
	    INTEGER => \$int,
	    BOOLEAN => \$bool,
	    STRING  => \$str,
	]
    ) && ($int == 1) && !$bool && ($str eq "A string")
	or die;

	print "ok ",$test++,"\n";
};


##
## SUB_SEQ_OF
##

$tcount += 5;
print "# SUB_SEQ_OF\n";

test {
    my $ber = Test::BER->new->encode(
	    SUB_SEQ_OF => [ 4,
		INTEGER => 1
	    ]) or die;

	print "ok ",$test++,"\n";

    $result = pack("C*", 0x7F, 0x36, # tag
                   0x0C, # length
                   0x02, 0x01, 0x01, 0x02, 0x01, 0x01,
                   0x02, 0x01, 0x01, 0x02, 0x01, 0x01);

    die unless $ber->buffer eq $result;

	print "ok ",$test++,"\n";

    my $i;
    my $count;

    $ber->decode(
	SUB_SEQ_OF => [ \$count,
	    INTEGER => \$i
	]
    ) or die;

	print "ok ",$test++,"\n";

    die unless $i == 1;

	print "ok ",$test++,"\n";

    die unless $count == 4;

	print "ok ",$test++,"\n";
};



##
## EXPLICIT TAG
##


@ETAGS = (
          ber_tag(BER_CONTEXT | BER_CONSTRUCTOR, 40), 
          ber_tag(BER_CONTEXT | BER_CONSTRUCTOR, 140), 
          ber_tag(BER_CONTEXT | BER_CONSTRUCTOR, 1140), 
          ber_tag(BER_CONTEXT | BER_CONSTRUCTOR, 11140), 
          );

foreach $tag (@ETAGS) {
    printf "# EXTENDED TAG 0x%x\n", $tag;

    $tcount += 3;
    test {
        my $ber = Convert::BER->new->encode(
                      SEQUENCE => [
                          [ SEQUENCE => $tag ] => [ INTEGER => 10 ],
                            INTEGER => 11,
                          ] 
                  ) or die;

            print "ok ", $test++, "\n";

        my ($i1, $i2) = (undef, undef);
        $ber->decode(SEQUENCE => [ 
                          [SEQUENCE => $tag]  => [INTEGER => \$i1],
                           INTEGER => \$i2
                     ]) 
            or die;

            print "ok ", $test++, "\n";

        die unless $i1 == 10 && $i2 == 11;
        
            print "ok ", $test++, "\n";
    }
}