=head1 NAME
DOCSIS::ConfigFile::Encode - Encode functions for a DOCSIS config-file.
=head1 SYNOPSIS
@uchar = snmp_object({
value => { oid => $str, type => $str, value => $str },
});
@uchar = bigint({ value => $bigint });
@uchar = int({ value => $int });
@uchar = uint({ value => $uint });
@uchar = ushort({ value => $ushort });
@uchar = uchar({ value => $char });
@uchar = vendorspec({
value => '0x001337', # vendors ID
nested => [
{
type => $int, # vendor specific type
value => $int, # vendor specific value
},
],
});
@uchar = ip({ value => '1.2.3.4' });
@uchar = ether({ value => '0x0123456789abcdef' });
@uchar = ether({ value => $uint });
@uchar = string({ value => '0x0123456789abcdef' });
@uchar = string({ value => 'string containing percent: %25' });
@uchar = hexstr({ value => '0x0123456789abcdef' });
() = mic({ value => $any });
=head1 DESCRIPTION
This module has functions which is used to encode "human" data
into list of unsigned characters (0-255) (refered to as "bytes")
later in the pod. This list can then be encoded into binary data
using:
$bytestr = pack 'C*', @uchar;
=cut
use strict;
use Carp qw/confess/;
use bytes;
use Socket;
our %SNMP_TYPE = (
INTEGER => [ 0x02, \&int ],
STRING => [ 0x04, \&string ],
NULLOBJ => [ 0x05, sub {} ],
IPADDRESS => [ 0x40, \&ip ],
COUNTER => [ 0x41, \&uint ],
UNSIGNED => [ 0x42, \&uint ],
TIMETICKS => [ 0x43, \&uint ],
OPAQUE => [ 0x44, \&uint ],
COUNTER64 => [ 0x46, \&bigint ],
);
=head1 FUNCTIONS
=head2 snmp_object
This function encodes a human-readable SNMP oid into a list of bytes:
@bytes = (
#-type---length---------value-----type---
0x30, $total_length, # object
0x06, int(@oid), @oid, # oid
$type, int(@value), @value, # value
);
=cut
sub snmp_object {
my $obj = _test_value(snmp_object => $_[0]);
my $type = $SNMP_TYPE{$obj->{'type'}} or confess 'Usage: snmp_object({ value => { type => ... })';
my @value = $type->[1]->({ value => $obj->{'value'}, snmp => 1 });
my @oid = _snmp_oid($obj->{'oid'});
unless(@value) {
confess 'Failed to decode SNMP value: ' .$obj->{'value'};
}
my @oid_length = _snmp_length(0 + @oid);
my @value_length = _snmp_length(0 + @value);
my @total_length = _snmp_length(3 + @value + @oid + @value_length);
return (
#-type--------length----------value-----type---
0x30, @total_length, # object
0x06, @oid_length, @oid, # oid
$type->[0], @value_length, @value, # value
);
}
sub _snmp_length {
my $length = $_[0];
my @bytes;
if($length < 0x80) {
return $length;
}
elsif($length < 0xff) {
return 0x81, $length;
}
elsif($length < 0xffff) {
while($length) {
unshift @bytes, $length & 0xff;
$length >>= 8;
}
return 0x82, @bytes;
}
confess "Too long snmp length: ($length)";
}
sub _snmp_oid {
my $string = $_[0] or confess 'Usage: _snmp_oid($str)';
my @input_oid = split /\./, $string;
my $subid = 0;
my @encoded_oid;
# the first two sub-id are in the first id
{
my $first = shift @input_oid;
my $second = shift @input_oid;
push @encoded_oid, $first * 40 + $second;
}
SUB_OID:
for my $id (@input_oid) {
if($id <= 0x7f) {
push @encoded_oid, $id;
}
else {
my @suboid;
while($id) {
unshift @suboid, 0x80 | ($id & 0x7f);
$id >>= 7;
}
$suboid[-1] &= 0x7f;
push @encoded_oid, @suboid;
}
}
return @encoded_oid;
}
=head2 bigint
Returns a list of bytes representing the C<$bigint>. This can be any
number (negative or positive) which can be representing using 64 bits.
=cut
sub bigint {
my $value = _test_value(bigint => $_[0]);
my $int64 = Math::BigInt->new($value);
$int64->is_nan and confess "$value is not a number";
my $negative = $int64 < 0;
my @bytes = $negative ? (0x80) : ();
while($int64) {
my $value = $int64 & 0xff;
$int64 >>= 8;
$value ^= 0xff if($negative);
unshift @bytes, $value;
}
return @bytes ? @bytes : (0); # 0 is also a number ;-)
}
=head2 int
Returns a list of bytes representing the C<$int>. This can be any
number (negative or positive) which can be representing using 32 bits.
=cut
sub int {
my $obj = $_[0];
my $int = _test_value(int => $obj, qr{^[+-]?\d{1,10}$});
my $negative = $int < 0;
my @bytes;
while($int) {
my $value = $int & 0xff;
$int >>= 8;
$value ^= 0xff if($negative);
unshift @bytes, $value;
}
if(!$obj->{'snmp'}) {
$bytes[0] |= 0x80 if($negative);
unshift @bytes, 0 for(1..4-@bytes);
}
if(@bytes == 0) {
@bytes = (0);
}
if($obj->{'snmp'}) {
unshift @bytes, 0 if(!$negative and $bytes[0] > 0x79);
}
return @bytes;
}
=head2 uint
Returns a list of bytes representing the C<$uint>. This can be any
positive number which can be representing using 32 bits.
=cut
sub uint {
my $obj = $_[0];
my $uint = _test_value(uint => $obj, qr{^\+?\d{1,10}$});
my @bytes;
while($uint) {
my $value = $uint & 0xff;
$uint >>= 8;
unshift @bytes, $value;
}
if(!$obj->{'snmp'}) {
unshift @bytes, 0 for(1..4-@bytes);
}
if(@bytes == 0) {
@bytes = (0);
}
if($obj->{'snmp'}) {
unshift @bytes, 0 if($bytes[0] > 0x79);
}
return @bytes;
}
=head2 ushort
Returns a list of bytes representing the C<$ushort>. This can be any
positive number which can be representing using 16 bits.
=cut
sub ushort {
my $obj = $_[0];
my $ushort = _test_value(ushort => $obj, qr{^\+?\d{1,5}$});
my @bytes;
if($obj->{'snmp'}) {
unshift @bytes, 0 if($ushort > 0x79);
}
while($ushort) {
my $value = $ushort & 0xff;
$ushort >>= 8;
unshift @bytes, $value;
}
if(!$obj->{'snmp'}) {
unshift @bytes, 0 for(1..2-@bytes);
}
if(@bytes == 0) {
@bytes = (0);
}
return @bytes;
}
=head2 uchar
Returns a list with one byte representing the C<$uchar>. This can be any
positive number which can be representing using 8 bits.
=cut
sub uchar {
return _test_value(uchar => $_[0], qr{\+?\d{1,3}$});
}
=head2 vendorspec
Will byte-encode a complex vendorspec datastructure.
=cut
sub vendorspec {
my $obj = $_[0];
my(@vendor, @bytes);
unless(ref $obj->{'nested'} eq 'ARRAY') {
confess "vendor({ nested => ... }) is not an array ref";
}
@vendor = ether($obj); # will extract value=>$hexstr. might confess
@bytes = (8, CORE::int(@vendor), @vendor);
TLV:
for my $tlv (@{ $obj->{'nested'} }) {
my @value = hexstr($tlv); # will extract value=>$hexstr. might confess
push @bytes, uchar({ value => $tlv->{'type'} });
push @bytes, CORE::int(@value);
push @bytes, @value;
}
return @bytes;
}
=head2 ip
Returns a list of four bytes representing the C<$ip>. The C<$ip> must
be in in the format "1.2.3.4".
=cut
sub ip {
return split /\./, _test_value(ip => $_[0], qr{^(?:\d{1,3}\.){3}\d{1,3}$});
}
=head2 ether
This function use either L</uint> or L</hexstr> to encode the
input value. It will figure out the function to use by checking
the input for either integer value or a string looking like
a hex-string.
=cut
sub ether {
my $string = _test_value(ether => $_[0]);
if($string =~ qr{^\+?[0-4294967295]$}) { # numeric
return uint({ value => $string });
}
elsif($string =~ /^(?:0x)?([0-9a-f]+)$/i) { # hex
return hexstr({ value => $1 });
}
confess "ether({ value => $string }) is invalid";
}
=head2 string
Returns a list of bytes representing the C<$str>. Will use
L</hexstr> to decode it if it looks like a hex string (a
string starting with leading "0x"). In other cases, it will
decode it itself. The input string might also be encoded
with a simple uri-encode format: "%20" will be translated
to a space, and "%25" will be translated into "%", before
encoded using C<ord()>.
=cut
sub string {
my $string = _test_value(string => $_[0]);
if($string =~ /^0x[a-f0-9]+$/i) {
return hexstr(@_);
}
else {
$string =~ s/%(\w\w)/{ chr hex $1 }/ge;
return map { ord $_ } split //, $string;
}
}
=head2 hexstr
Will encode any hex encoded string into a list of bytes. The string
can have an optional leading "0x".
=cut
sub hexstr {
my $string = _test_value(hexstr => $_[0], qr{(?:0x)?([a-f0-9]+)}i);
my @bytes;
$string =~ s/^(?:0x)//;
while($string =~ s/(\w{1,2})$//) {
unshift @bytes, hex $1;
}
if($string) {
confess "hexstr({ value => ... }) is left with ($string) after decoding";
}
return @bytes;
}
=head2 mic
Cannot encode CM/CMTS mic without complete information about
the config file, so this function returns an empty list.
=cut
sub mic {}
=head2 no_value
This method will return an empty list. It is used by DOCSIS types, which
has zero length.
=cut
sub no_value {}
sub _test_value {
my($name, $obj, $test) = @_;
if(!defined $obj->{'value'}) {
confess "$name({ value => ... }) received undefined value";
}
if($test and not $obj->{'value'} =~ $test) {
confess "$name({ value => " .$obj->{'value'} ." }) does not match $test";
}
return $obj->{'value'};
}
=head1 AUTHOR
=head1 BUGS
=head1 SUPPORT
=head1 ACKNOWLEDGEMENTS
=head1 COPYRIGHT & LICENSE
See L<DOCSIS::ConfigFile>
=cut
1;