Encoding-BER
view release on metacpan or search on metacpan
lib/Encoding/BER.pm view on Meta::CPAN
# -*- perl -*-
# Copyright (c) 2007 by Jeff Weisberg
# Author: Jeff Weisberg <jaw+pause @ tcp4me.com>
# Created: 2007-Jan-28 16:03 (EST)
# Function: BER encoding/decoding (also: CER and DER)
#
# $Id: BER.pm,v 1.11 2008/05/31 18:43:11 jaw Exp $
# references: ITU-T x.680 07/2002 - ASN.1
# references: ITU-T x.690 07/2002 - BER
package Encoding::BER;
use vars qw($VERSION);
$VERSION = '1.02';
use Carp;
use strict;
# loaded on demand if needed:
# POSIX
# used if already loaded:
# Math::BigInt
=head1 NAME
Encoding::BER - Perl module for encoding/decoding data using ASN.1 Basic Encoding Rules (BER)
=head1 SYNOPSIS
use Encoding::BER;
my $enc = Encoding::BER->new();
my $ber = $enc->encode( $data );
my $xyz = $enc->decode( $ber );
=head1 DESCRIPTION
Unlike many other BER encoder/decoders, this module uses tree structured data
as the interface to/from the encoder/decoder.
The decoder does not require any form of template or description of the
data to be decoded. Given arbitrary BER encoded data, the decoder produces
a tree shaped perl data structure from it.
The encoder takes a perl data structure and produces a BER encoding from it.
=head1 METHODS
=over 4
=cut
;
################################################################
my %CLASS =
(
universal => { v => 0, },
application => { v => 0x40, },
context => { v => 0x80, },
private => { v => 0xC0, },
);
my %TYPE =
(
primitive => { v => 0, },
constructed => { v => 0x20, },
);
my %TAG =
(
universal => {
content_end => { v => 0, },
boolean => { v => 1, e => \&encode_bool, d => \&decode_bool },
integer => { v => 2, e => \&encode_int, d => \&decode_int },
bit_string => { v => 3, e => \&encode_bits, d => \&decode_bits, dc => \&reass_string, rule => 1 },
octet_string => { v => 4, e => \&encode_string, d => \&decode_string, dc => \&reass_string, rule => 1 },
null => { v => 5, e => \&encode_null, d => \&decode_null },
oid => { v => 6, e => \&encode_oid, d => \&decode_oid },
object_descriptor => { v => 7, implicit => 'octet_string' },
external => { v => 8, type => ['constructed'] },
real => { v => 9, e => \&encode_real, d => \&decode_real },
enumerated => { v => 0xA, implicit => 'integer' },
embedded_pdv => { v => 0xB, e => \&encode_string, d => \&decode_string, dc => \&reass_string },
utf8_string => { v => 0xC, implicit => 'octet_string' },
relative_oid => { v => 0xD, e => \&encode_roid, d => \&decode_roid },
# reserved
# reserved
sequence => { v => 0x10, type => ['constructed'] },
set => { v => 0x11, type => ['constructed'] },
numeric_string => { v => 0x12, implicit => 'octet_string' },
printable_string => { v => 0x13, implicit => 'octet_string' },
teletex_string => { v => 0x14, implicit => 'octet_string' },
videotex_string => { v => 0x15, implicit => 'octet_string' },
ia5_string => { v => 0x16, implicit => 'octet_string' },
universal_time => { v => 0x17, implicit => 'octet_string' },
generalized_time => { v => 0x18, implicit => 'octet_string' },
graphic_string => { v => 0x19, implicit => 'octet_string' },
visible_string => { v => 0x1a, implicit => 'octet_string' },
general_string => { v => 0x1b, implicit => 'octet_string' },
universal_string => { v => 0x1c, implicit => 'octet_string' },
character_string => { v => 0x1d, implicit => 'octet_string' },
lib/Encoding/BER.pm view on Meta::CPAN
roid => 'relative_oid',
float => 'real',
enum => 'enumerated',
sequence_of => 'sequence',
set_of => 'set',
t61_string => 'teletex_string',
iso646_string => 'visible_string',
int32 => 'integer32',
unsigned_integer => 'unsigned_int',
uint => 'unsigned_int',
uint32 => 'unsigned_int32',
# ...
);
# insert name into above data
my %ALLTAG;
my %REVTAG;
# insert name + class into above data
# build reverse map, etc.
init_tag_lookups( \%TAG, \%ALLTAG, \%REVTAG );
my %REVCLASS = map {
( $CLASS{$_}{v} => $_ )
} keys %CLASS;
my %REVTYPE = map {
( $TYPE{$_}{v} => $_ )
} keys %TYPE;
################################################################
=item new(option => value, ...)
constructor.
example:
my $enc = Encoding::BER->new( error => sub{ die "$_[1]\n" } );
the following options are available:
=over 4
=item error
coderef called if there is an error. will be called with 2 parameters,
the Encoding::BER object, and the error message.
# example: die on error
error => sub{ die "oops! $_[1]\n" }
=item warn
coderef called if there is something to warn about. will be called with 2 parameters,
the Encoding::BER object, and the error message.
# example: warn for warnings
warn => sub{ warn "how odd! $_[1]\n" }
=item decoded_callback
coderef called for every element decoded. will be called with 2 parameters,
the Encoding::BER object, and the decoded data. [see DECODED DATA]
# example: bless decoded results into a useful class
decoded_callback => sub{ bless $_[1], MyBER::Result }
=item debug
boolean. if true, large amounts of useless gibberish will be sent to stderr regarding
the encoding or decoding process.
# example: enable gibberish output
debug => 1
=back
=cut
;
sub new {
my $cl = shift;
my $me = bless { @_ }, $cl;
$me;
}
sub error {
my $me = shift;
my $msg = shift;
if( my $f = $me->{error} ){
$f->($me, $msg);
}else{
croak ((ref $me) . ": $msg\n");
}
undef;
}
sub warn {
my $me = shift;
my $msg = shift;
if( my $f = $me->{warn} ){
$f->($me, $msg);
}else{
carp ((ref $me) . ": $msg\n");
}
undef;
}
sub debug {
my $me = shift;
my $msg = shift;
return unless $me->{debug};
print STDERR " " x $me->{level}, $msg, "\n";
undef;
}
################################################################
sub add_tag_hash {
my $me = shift;
my $class = shift;
my $type = shift;
lib/Encoding/BER.pm view on Meta::CPAN
my($v, $t) = $me->decode_items( substr($data, $doff), 1, $levl );
$me->{level} = $levl;
$tlen += $t;
$tlen += 2; # eoc
$vals = $v;
}
if( $decfnc ){
# constructed decode func: reassemble
$result = $decfnc->( $me, $vals, $typdat );
}else{
$result = {
value => $vals,
};
}
}else{
# primitive
my $ndat;
if( defined $datlen ){
# definite
$me->debug("decode item: primitive definite [@$typdat($tagnum)]");
$ndat = substr($data, $doff, $datlen);
}else{
# indefinite encoding of a primitive is a violation of x.690 8.1.3.2(a)
# warn + parse it anyway
$me->debug("decode item: primitive indefinite [@$typdat($tagnum)]");
$me->warn("protocol violation - indefinite encoding of primitive. see x.690 8.1.3.2(a)");
my $i = index($data, "\0\0", $doff);
if( $i == -1 ){
# invalid encoding.
# no eoc found.
# go back to protocol school.
$me->error("corrupt data - content terminator not found. see x.690 8.1.3.6, 8.1.5, et al. ");
return (undef, $tlen);
}
my $dl = $i - $doff;
$tlen += $dl;
$tlen += 2; # eoc
$ndat = substr($data, $doff, $dl);
}
unless( $typval || $typmore ){
# universal-primitive-tag(0) => end-of-content
return ( { }, $tlen );
}
# decode it
$decfnc ||= \&decode_unknown;
my $val = $decfnc->( $me, $ndat, $typdat );
# format value in a special pretty way?
if( $pretty ){
$val = $pretty->( $me, $val ) || $val;
}
$result = $val;
}
$result->{type} = $typdat;
$result->{tagnum} = $tagnum;
$result->{identval} = $typval;
if( my $c = $me->{decoded_callback} ){
$result = $c->( $me, $result ) || $result; # make sure the brain hasn't fallen out
}
return( $result, $tlen );
}
sub app_tag_data_bynumber {
my $me = shift;
my $class = shift;
my $tnum = shift;
my $name = $me->{revtags}{$class}{$tnum};
return unless $name;
$me->{tags}{$name};
}
# override me in subclass
sub subclass_tag_data_bynumber {
my $me = shift;
my $class = shift;
my $tnum = shift;
undef;
}
sub univ_tag_data_bynumber {
my $me = shift;
my $class = shift;
my $tnum = shift;
$TAG{$class}{ $REVTAG{$class}{$tnum} };
}
sub tag_data_bynumber {
my $me = shift;
my $class = shift;
my $tnum = shift;
my $th;
# application specific tag name
$th = $me->app_tag_data_bynumber($class, $tnum);
# subclass specific tag name
$th = $me->subclass_tag_data_bynumber($class, $tnum) unless $th;
# from universal
$th = $me->univ_tag_data_bynumber($class, $tnum) unless $th;
$th;
}
sub ident_descr_and_dfuncs {
my $me = shift;
my $tval = shift;
my $more = shift;
my $tag = $more || ($tval & 0x1f) || 0;
my $cl = $tval & 0xC0;
my $ty = $tval & 0x20;
my $class = $REVCLASS{$cl};
( run in 1.483 second using v1.01-cache-2.11-cpan-e1769b4cff6 )