package DOCSIS::ConfigFile;
=head1 NAME
DOCSIS::ConfigFile - Decodes and encodes DOCSIS config-files
=head1 VERSION
0.63
=head1 SYNOPSIS
use DOCSIS::ConfigFile;
use JSON;
my $obj = DOCSIS::ConfigFile->new(
shared_secret => '', # default
advanced_output => 0, # default
);
$obj->shared_secret("foobar");
my $encoded = $obj->encode([ {...}, {...}, ... ]);
my $decoded = $obj->decode($filename);
$obj->advanced_output(1);
my $dec_adv = $obj->decode(\$encoded);
# see simple config in JSON format
print JSON->new->pretty->decode($decoded);
# see advanced config in JSON format
print JSON->new->pretty->decode($dec_adv);
=head1 DESCRIPTION
An instance from this class can be used to encode or decode
L<DOCSIS|http://www.cablelabs.com> (Data over Cable Service Interface
Specifications) config files. These files are usually served using a
L<TFTP server|POE::Component::TFTPd>, after a
L<cable modem|http://en.wikipedia.org/wiki/Cable_modem> or MTA
(Multimedia Terminal Adapter) has recevied an IP address from a
L<DHCP|Net::ISC::DHCPd> server. These files are
L<binary encode|DOCSIS::ConfigFile::Encode> using a variety of
functions, but all the data in the file are constructed by TLVs
(type-length-value) blocks. These can be nested and concatenated.
This module is used as a layer between any human readable data and
the binary structure. The config file in human readable format can
look something like this:
[
{ name => NetworkAccess => value => 1 },
{ name => GlobalPrivacyEnable => value => 1 },
{ name => MaxCPE => value => 10 },
{ name => BaselinePrivacy =>
nested => [
{ name => AuthTimeout => value => 10 },
{ name => ReAuthTimeout => value => 10 },
{ name => AuthGraceTime => value => 600 },
{ name => OperTimeout => value => 1 },
{ name => ReKeyTimeout => value => 1 },
{ name => TEKGraceTime => value => 600 },
{ name => AuthRejectTimeout => value => 60 },
{ name => SAMapWaitTimeout => value => 1 },
{ name => SAMapMaxRetries => value => 4 }
]
},
]
There is also an optional L</advanced_output> flag which can include
more information, but this is what is required/default: An array-ref
of hash-refs, containing a C<name> and a C<value> (or C<nested> for
nested data structures). The rest will this module figure out.
=head1 FAULT HANDLING
As for version C<0.60>, this module has changed from holding errors
in an attribute to actively reporting errors, using C<confess()>,
C<carp()> and the module L<autodie> for reporting system errors from
C<open()> and friends. Constructing the object, and changing attribute
values are still safe to do, but L</encode> and L</decode> might die.
=cut
use strict;
use warnings;
use autodie;
use Carp qw/ carp confess /;
use Digest::MD5;
use Digest::HMAC_MD5;
use Digest::SHA1 qw(sha1_hex);
use DOCSIS::ConfigFile::Syminfo;
use DOCSIS::ConfigFile::Decode;
use DOCSIS::ConfigFile::Encode;
use constant Syminfo => "DOCSIS::ConfigFile::Syminfo";
use constant Decode => "DOCSIS::ConfigFile::Decode";
use constant Encode => "DOCSIS::ConfigFile::Encode";
our $VERSION = eval '0.63';
our $TRACE = 0;
=head1 ATTRIBUTES
=head2 shared_secret
Sets or gets the shared secret.
=cut
sub shared_secret {
my $self = shift;
$self->{'shared_secret'} = $_[0] if(@_);
return $self->{'shared_secret'} ||= q();
}
=head2 advanced_output
Sets weither advanced output should be enabled. Takes 0 or 1 as argument.
Advanced output is off (0) by default.
=cut
sub advanced_output {
my $self = shift;
$self->{'advanced_output'} = $_[0] if(@_);
return $self->{'advanced_output'} || 0;
}
=head1 METHODS
=head2 new
$self = $class->new(\%args);
Arguments can be:
shared_secret => Shared secret in encoded cm config file
advanced_output => Advanced decoded config format
mibs => will set $ENV{MIBS} to load custom mibs
=cut
sub new {
my $class = shift;
my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};
my $self = bless $args, $class;
return $self;
}
=head2 decode
$array_ref = $self->decode($path_to_file);
$array_ref = $self->decode(\$binary_string);
$array_ref = $self->decode($FH);
This method decodes a binary config file stored in either a file on disk,
a binary string, or a filehandle. It returns an array-ref of hashes,
containing the config as a perl data structure.
=cut
sub decode {
no warnings 'newline'; # don't shout on invalid filename
my $self = shift;
my $input = shift || '__undefined_input__';
my $FH;
if(ref $input eq 'SCALAR') { # binary string
open $FH, '<', $input;
}
elsif(ref $input eq 'GLOB') { # input is filehandle
$FH = $input;
}
elsif(-f $input) { # input is filename
open $FH, '<', $input;
}
else {
confess 'Usage: $self->decode( ScalarRef|GlobRef|Filename )';
}
binmode $FH;
$self->{'decode_fh'} = $FH;
return $self->_decode_loop;
}
sub _decode_loop {
my $self = shift;
my $tlength = shift || 0xffffffff;
my $p_code = shift || 0;
my $FH = $self->{'decode_fh'};
my $cfg = [];
CODE:
while($tlength > 0) {
my $code = $self->_read_code($FH) or last CODE;
my $syminfo = Syminfo->from_code($code, $p_code);
my $length = $self->_read_length($FH, $syminfo->length);
my($value, $nested);
$tlength -= $length + 2;
if(!defined $syminfo->func) {
#carp sprintf 'PCODE/CODE (%s/%s) gets skipped: No function to decode', $p_code, $code;
next CODE;
}
elsif($syminfo->func eq 'nested') {
$nested = $self->_decode_loop($length, $syminfo->code);
}
elsif(my $decoder = Decode->can($syminfo->func)) {
($value, $nested) = $decoder->( $self->_read_value($FH, $length) );
}
else {
$self->_read_value($FH, $length);
carp sprintf 'Unknown decode method for PCODE/CODE (%s/%s). (%s) bytes are thrown away', $p_code, $code, $length;
next CODE;
}
if(defined $value or defined $nested) {
push @$cfg, $self->_value_to_cfg($syminfo, $length, $value, $nested);
next CODE;
}
carp sprintf 'Could not decode PCODE/CODE (%s/%s) using function (%s)', $p_code, $code, $syminfo->func;
}
return $cfg;
}
sub _read_code {
my($self, $FH) = @_;
my $bytes = read $FH, my($data), 1;
return $bytes ? unpack 'C', $data : '';
}
sub _read_length {
my $self = shift;
my $read = read $_[0], my($length), $_[1];
# Document: PKT-SP-PROV1.5-I03-070412
# Chapter: 9.1 MTA Configuration File
return $read == 0 ? 0
: $read == 1 ? unpack('C', $length)
: $read == 2 ? unpack('n', $length)
: 0xffffffff # weird way to enforce error later on...
;
}
sub _read_value {
my($self, $FH, $length) = @_;
my $bytes = read $FH, my($data), $length;
if($bytes != $length) {
confess sprintf 'Expected to read (%s) bytes. Read (%s) bytes', $length, $bytes;
}
return $data;
}
sub _value_to_cfg {
my $self = shift;
my $syminfo = shift;
my $length = shift;
my $value = shift;
my $nested = shift;
if($self->advanced_output) {
return {
name => $syminfo->id,
code => $syminfo->code,
pcode => $syminfo->pcode,
func => $syminfo->func,
llimit => $syminfo->l_limit,
ulimit => $syminfo->u_limit,
length => $length,
(defined $value ? (value => $value ) : ()),
(defined $nested ? (nested => $nested) : ()),
};
}
else {
return {
name => $syminfo->id,
(defined $value ? (value => $value ) : ()),
(defined $nested ? (nested => $nested) : ()),
};
}
}
=head2 encode
$binary_str = $self->encode([ { ... }, ... ]);
Encodes an array of hashes, containing the DOCSIS config-file settings and
returns a binary encoded string. See L</DESCRIPTION> and the unit tests for
example input. For other structures, see the table generated by
L<DOCSIS::ConfigFile::Syminfo/dump_symbol_tree>.
When enconding MTA config files another arugment is accepted:
$binary_str = $self->encode([ { ... }, ... ], 'md5|sha1');
As 'pktcMtaDevProvConfigHash' does not need to be included in the config at all
times this param is optional. Only two variants are accpted - MD5, or SHA1
The algorithm will then be used to define value for 'pktcMtaDevProvConfigHash'
and this line will be added just above 'MtaConfigDelimiter' closing tag resulting in
MtaConfigDelimiter 1;
...
SnmpMibObject enterprises.4491.2.2.1.1.2.7.0 HexString 0x1a2b3c4d5e6f... ;
MtaConfigDelimiter 255;
=cut
sub encode {
my $self = shift;
my $config = shift || '__undefined_input__';
my $algo = shift;
if(ref $config ne 'ARRAY') {
confess 'Usage: $self->encode( ArrayRef[HashRef] )';
}
if ($algo and $algo !~ /^(?:md5|sha1)$/i) {
confess "Usage: $self->encode( ArrayRef[HashRef], 'md5|sha1' )";
}
$algo = lc $algo if $algo;
$self->{'cmts_mic'} = {};
$self->{'binstring'} = $self->_encode_loop($config) || q();
if(grep { $_->{'name'} eq 'MtaConfigDelimiter' } @$config) {
$self->{'_MtaConfigDelimiter'} = 1; # for internal usage
if ($self->{binstring} and $algo)
{
my $hash = $algo eq 'md5'
? md5_hex $self->{binstring}
: sha1_hex $self->{binstring};
if ($hash)
{
splice @$config, $#{$config}, 0,
{ name => 'SnmpMibObject', value => { oid => '1.3.6.1.4.1.4491.2.2.1.1.2.7.0', type => 'STRING', value => "0x${hash}" }};
$self->{binstring} = $self->_encode_loop ($config) || q();
}
}
}
else {
$self->{'_DefaultConfigDelimiter'} = 1; # for internal usage
my $cm_mic = $self->_calculate_cm_mic;
my $cmts_mic = $self->_calculate_cmts_mic;
my $eod_pad = $self->_calculate_eod_and_pad;
$self->{'binstring'} .= "$cm_mic$cmts_mic$eod_pad";
}
return $self->{'binstring'};
}
sub _encode_loop {
my $self = shift;
my $config = shift || '__undefined_input__';
my $level = shift || 0;
my $i = shift || 0;
my $binstring = q();
if(ref $config ne 'ARRAY') {
confess sprintf 'Input is not an array ref: %s', $config;
}
TLV:
for my $tlv (@$config) {
confess sprintf 'Invalid TLV#%s: %s', $i, $tlv || '__undefined_tlv__' unless(ref $tlv eq 'HASH');
confess sprintf 'Missing name in TLV#%s: %s', $i, join(',', keys %$tlv) unless($tlv->{'name'});
my $name = $tlv->{'name'};
my $syminfo = Syminfo->from_id($name);
my($type, $length, $value);
if(!defined $syminfo->func) {
#carp sprintf 'TLV#%s/%s is skipped: No function to encode', $i, $name;
next TLV;
}
elsif($syminfo->func eq 'nested') {
$value = $self->_encode_loop($tlv->{'nested'}, $level+1, $i);
}
elsif(my $encoder = Encode->can($syminfo->func)) {
$value = pack 'C*', $encoder->($tlv) or next TLV;
}
else {
carp sprintf 'Unknown encode method for TLV#%s/%s', $i, $name;
next TLV;
}
$syminfo = $self->_syminfo_from_syminfo_siblings($syminfo, \$value);
$type = $syminfo->code;
$length = ($syminfo->length == 2) ? pack('n', length $value) : pack('C', length $value);
#carp 'name=%s type=%i, length=%i', $name, $type, length($value);
$type = pack "C", $type;
$binstring .= "$type$length$value";
$self->_calculate_cmts_mic($name, "$type$length$value");
}
continue {
$i++;
}
return $binstring;
}
sub _syminfo_from_syminfo_siblings {
my($self, $syminfo, $value) = @_;
my @error;
SIBLING:
for my $sibling (@{ $syminfo->siblings }) {
unless($sibling->l_limit or $sibling->u_limit) {
next SIBLING;
}
my $length = $$value =~ /^\d+$/ ? $$value : length $$value;
if($length > $sibling->u_limit) {
push @error, sprintf '%s/%s: %s > %s', $sibling->pcode, $sibling->code, $length, $sibling->u_limit;
}
elsif($length < $sibling->l_limit) {
push @error, sprintf '%s/%s: %s < %s', $sibling->pcode, $sibling->code, $length, $sibling->l_limit;
}
else {
return $sibling;
}
}
confess sprintf 'Invalid value for %s: %s', $syminfo->id, join(', ', @error) if(@error);
return $syminfo;
}
sub _calculate_eod_and_pad {
my $self = shift;
my $length = length $self->{'binstring'};
my $pads = 4 - (1 + $length) % 4;
return pack("C", 255) .("\0" x $pads);
}
sub _calculate_cm_mic {
my $self = shift;
my $cm_mic = pack("C*", 6, 16) .Digest::MD5::md5($self->{'binstring'});
$self->_calculate_cmts_mic("CmMic", $cm_mic);
return $cm_mic;
}
sub _calculate_cmts_mic {
my $self = shift;
my $cmts_mic = $self->{'cmts_mic'};
my $data;
if(@_ == 2) {
my $name = shift;
my $val = shift;
return $cmts_mic->{ $name } .= $val;
}
else {
for my $code (Syminfo->cmts_mic_codes) {
$data .= $cmts_mic->{$code} || '';
}
return(join "",
pack("C*", 7, 16),
Digest::HMAC_MD5::hmac_md5($data, $self->shared_secret),
);
}
}
=head1 CONSTANTS
=head2 Decode
Returns L<DOCSIS::ConfigFile::Decode>.
=head2 Encode
Returns L<DOCSIS::ConfigFile::Encode>.
=head2 Syminfo
Returns L<DOCSIS::ConfigFile::Syminfo>.
=cut
=head1 AUTHOR
Jan Henning Thorsen, C<< <pm at flodhest.net> >>
=head1 BUGS
Please report any bugs or feature requests to
C<bug-docsis-perl at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DOCSIS-ConfigFile>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc DOCSIS::ConfigFile
You can also look for information at
L<http://search.cpan.org/dist/DOCSIS-ConfigFile>
=head1 ACKNOWLEDGEMENTS
=head1 COPYRIGHT & LICENSE
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
Copyright (c) 2007 Jan Henning Thorsen
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
DOCSIS is a registered trademark of Cablelabs, http://www.cablelabs.com
This module got its inspiration from the program docsis, http://docsis.sf.net.
=cut
1;