view release on metacpan or  search on metacpan

lib/Convert/ASN1/asn1c.pm  view on Meta::CPAN

			$offset = $current_offset;
			#count number of bytes in $value
			$value_length = () = $value =~ /&#x..;/g; 
			#replace this line with the corrected values
			$lines[$_] = "<P O=\"$offset\" T=\"$tag\" TL=\"$tag_length\" V=\"$value_length\"$rest)>$value</P>";
			$current_offset += $tag_length;
			$current_offset += $value_length;
		}
		if ($lines[$_] =~ m/<C O="(\d+)" T="(.+?)" TL="(\d+)" V="(\d+)"(.*?)>/) {
			my $offset = $1;
			my $tag = $2;
			my $tag_length = $3;
			my $value_length = $4;
			my $rest = $5;
			$offset = $current_offset;
			#replace this line with the corrected values
			$lines[$_] = "<C O=\"$offset\" T=\"$tag\" TL=\"$tag_length\" V=\"$value_length\"$rest)>";
			$current_offset += $tag_length;
			# put this line number on the stack, so that we can jump back here and fill in the value length once we know it
			push @stack, $_;
		}
		if ($lines[$_] =~ m/<\/C O=\"(\d+)\" T=\"(.+?)\"(.+?)L=\"(\d+)\">/) {
			my $offset = $1;
			my $tag = $2;
			my $rest = $3;
			my $length = $4;
			$offset = $current_offset;

			my $opening_line = pop @stack;
			if ($lines[$opening_line] =~ m/<C O="(\d+)" T="(.+?)" TL="(\d+)" V="(\d+)"(.*?)>/) {
				my $op_offset = $1;
				my $op_tag = $2;
				my $op_tag_length = $3;
				my $op_value_length = $4;
				my $op_rest = $5;
				$op_value_length = $current_offset - $op_offset - $op_tag_length;
				$length =  $current_offset - $op_offset;
				$lines[$opening_line] = "<C O=\"$op_offset\" T=\"$op_tag\" TL=\"$op_tag_length\" V=\"$op_value_length\"$op_rest)>";
			}
			else {
				die "Internal error, file bug report!\n";
			}

			#replace this line with the corrected values
			$lines[$_] = "</C O=\"$current_offset\" T=\"$tag\"$rest L=\"$length\">";
		}
	}

	$text = join("\n", @lines);

	return $text;
}



=head2 $values = decode('pduname', $pdu);

The decode function takes the name of a template (the directory where to find
those templates can be modified with set_templatedir($dir)) and a binary pdu.

It will match the variables in the template against the decoded binary pdu and
return a reference to a hash which contains these values.

For each variable $myvalue the hash will contain four keys:

=head3 $values->{'myvalue'}

The decoded value if we could "guess" myvalues type because it was
specified as i.e. INTEGER or BIT STRING in the asn1 pdu.

=head3 $values->{'myvalue_orig'}

The original value as it was found in the unber -p output. Note that these
values are still xml-encoded. To decode them you can use this modules
decode_-functions or write your own decoders if the provided ones are not
sufficient.

=head3 $values->{'myvalue_length'}

The length of $myvalue as it was encoded in the asn1 pdu. This value is
needed for some _decode routines and can also be usefull if you write your own
decoder functions.

=head3 $values->{'myvalue_type'} 

If the type of $myvalue is specified in the pdu, for example as INTEGER, this
key contains the value.

=cut



sub decode {

	my ($self, $pduname, $pdu) = @_;

	my @stack;
	my @varpos;

	# try to find the packet description
	my @lines = read_file(File::Spec->catfile($self->{'_templatedir'}, $pduname));

	# we will parse the packet description
	# to find out which "nodes" in the tag tree are interesting for us
	# and we will construct a list of those interesting nodes (and how to "reach" them,
	# i.e. which parent nodes they are located under. In the second step we will
	# iterate over the decoded ASN data, if we are in an inetersting leaf we will decode it's value.
	
	foreach (@lines) {
		if (m/<C .*?T=\"(.*?)\"/) { push @stack, $1; }
		if (m/<\/C /) { pop @stack; }
		if (m/<P .*?T=\"(.*?)\"/) { push @stack, $1; }
		while (m/(\$.+?)("|<| |>)/gc) {
			my $varname = $1;
			if ($varname !~ m/_length$/) {
				push(@varpos, $varname . ":" . join('|', @stack));
			}
		}
		if (m/<\/P>/) { pop @stack; }
	}

	my @unber = qw( unber -p - );
	my $text;
	my $h = start \@unber, \$pdu, \$text;
	pump $h while length $pdu;
	finish $h or croak "unber returned $?";

	@lines = qw();
	@stack = qw();
	@lines = split(/\n/, $text);
	my %results;

	foreach (@lines) {
		my $line = $_;
		if ($line =~ m/<C .*?T=\"(.*?)\"/) {
			push @stack, $1;
		}
		if ($line =~ m/<\/C /) {
			pop @stack;
		}
		if ($line =~ m/<P .*?T=\"(.*?)\"/) {
			#check if this node is "interesting" - is there a entry in @varpos which matches the current stack
			push @stack, $1;
			my $current = join('|', @stack);
			foreach (0 .. scalar(@varpos)-1) {
				croak "Internal Parser error!\n" unless ($varpos[$_] =~ m/^\$(.*?):(.*?)$/);
				my $varname = $1;
				my $varposition = $2;
				if ($varposition eq $current) {
					# we are in an interesting node! 
					my $value = undef;
					my $value_len = undef;
					my $value_type = undef;
					if ($line =~ m/ V=\"(.*?)\".*?>(.*?)</) {
						$value_len = $1;
						$value = $2;
						if ($line =~ m/A=\"(.*?)\"/) {	$value_type = $1; }
						else { $value_type = 'UNDEFINED';  }
						$results{$varname . '_length'} = $value_len;
						$results{$varname . '_type'} = $value_type;
						$results{$varname} = $value;
						$results{$varname . '_orig'} = $value;
						# remove the filled varpos entry
						$varpos[$_] .= '--matched--';
						last;
					}
				}

lib/Convert/ASN1/asn1c.pm  view on Meta::CPAN

		}
	}
	
	# now we have all interesting values in the results hash, together with
	# their type (BE CAREFULL - "Siemens Bitstrings" have the type UNDEFINED)
	# and length.

	foreach (keys %results) {
		my $key = $_;
		if ($key !~ m/(_length$|_type$|_orig$)/) {
			my $value = $results{$key};
			my $type = $results{$key . '_type'};
			my $length = $results{$key . '_length'};
			if ($type eq 'OCTET STRING') {
				$results{$key} = decode_octet_string($self, $value, $length);
			}
			if ($type eq 'INTEGER') {
				$results{$key} = decode_integer($self, $value, $length);
			}
			if ($type =~ m/(BIT STRING)/) {
				$results{$key} = decode_bitstring($self, $value, $length);
			}
			if ($type eq "GeneralizedTime") {
				$results{$key} = decode_timestamp($self, $value, $length);
			}
			if ($type eq "ENUMERATED") {
				# of course not all enumerated types are int's but
				# in our context it seems to be a good guess
				$results{$key} = decode_integer($self, $value, $length);
			}
		}
	}

	return \%results;
}

=head2 $values = sdecode($xml_template, $pdu);

The sdecode function takes a template and a binary pdu. It works the same way
as the decode function, but it directly takes the template as it's first
argument instead of a filename.

=cut



sub sdecode {

	my ($self, $xml_template, $pdu) = @_;

	my @stack;
	my @varpos;

	# try to find the packet description
	my @lines = split(/\n/, $xml_template);

	# we will parse the packet description
	# to find out which "nodes" in the tag tree are interesting for us
	# and we will construct a list of those interesting nodes (and how to "reach" them,
	# i.e. which parent nodes they are located under. In the second step we will
	# iterate over the decoded ASN data, if we are in an inetersting leaf we will decode it's value.
	
	foreach (@lines) {
		if (m/<C .*?T=\"(.*?)\"/) { push @stack, $1; }
		if (m/<\/C /) { pop @stack; }
		if (m/<P .*?T=\"(.*?)\"/) { push @stack, $1; }
		while (m/(\$.+?)("|<| |>)/gc) {
			my $varname = $1;
			if ($varname !~ m/_length$/) {
				push(@varpos, $varname . ":" . join('|', @stack));
			}
		}
		if (m/<\/P>/) { pop @stack; }
	}

	my @unber = qw( unber -p - );
	my $text;
	my $h = start \@unber, \$pdu, \$text;
	pump $h while length $pdu;
	finish $h or croak "unber returned $?";

	@lines = qw();
	@stack = qw();
	@lines = split(/\n/, $text);
	my %results;

	foreach (@lines) {
		my $line = $_;
		if ($line =~ m/<C .*?T=\"(.*?)\"/) {
			push @stack, $1;
		}
		if ($line =~ m/<\/C /) {
			pop @stack;
		}
		if ($line =~ m/<P .*?T=\"(.*?)\"/) {
			#check if this node is "interesting" - is there a entry in @varpos which matches the current stack
			push @stack, $1;
			my $current = join('|', @stack);
			foreach (0 .. scalar(@varpos)-1) {
				croak "Internal Parser error!\n" unless ($varpos[$_] =~ m/^\$(.*?):(.*?)$/);
				my $varname = $1;
				my $varposition = $2;
				if ($varposition eq $current) {
					# we are in an interesting node! 
					my $value = undef;
					my $value_len = undef;
					my $value_type = undef;
					if ($line =~ m/ V=\"(.*?)\".*?>(.*?)</) {
						$value_len = $1;
						$value = $2;
						if ($line =~ m/A=\"(.*?)\"/) {	$value_type = $1; }
						else { $value_type = 'UNDEFINED';  }
						$results{$varname . '_length'} = $value_len;
						$results{$varname . '_type'} = $value_type;
						$results{$varname} = $value;
						$results{$varname . '_orig'} = $value;
						# remove the filled varpos entry
						$varpos[$_] .= '--matched--';
						last;
					}
				}