From: Dobrica Pavlinusic Date: Sun, 7 Mar 2010 19:26:59 +0000 (+0000) Subject: fix dependencies, bump version [0.20] X-Git-Url: http://git.rot13.org/?p=perl-cwmp.git;a=commitdiff_plain;h=6dcc570ef56f4d00cd8997498a42bbaeedf32bf6 fix dependencies, bump version [0.20] git-svn-id: https://perl-cwmp.googlecode.com/svn/trunk@266 836a5e1a-633d-0410-964b-294494ad4392 --- diff --git a/Makefile.PL b/Makefile.PL index 7a86a9f..aa858ea 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -3,9 +3,9 @@ use lib './lib'; use inc::Module::Install; name 'CWMP'; -version '0.14'; +version '0.20'; license 'GPL'; -requires 'XML::Rules'; +requires 'XML::Bare'; requires 'XML::Generator'; requires 'Data::Dump'; requires 'Carp'; diff --git a/README b/README index 8d331ea..ece95c7 100644 --- a/README +++ b/README @@ -21,3 +21,8 @@ Currently implemented: - 3.4.5 Digest Authentication + 3.4.6 Additional HTTP Requirements + +INSTALLATION + +Idea is to be as lightweight as possible, but some perl modules might be installed +directly from CPAN diff --git a/lib/CWMP/Parser.pm b/lib/CWMP/Parser.pm index fd6ba4c..7be91c3 100644 --- a/lib/CWMP/Parser.pm +++ b/lib/CWMP/Parser.pm @@ -14,7 +14,8 @@ CWMP::Parser - parse SOAP request XML =head1 DESCRIPTION Design is based on my expirience with L, but show-stopper -was it's inability to parse invalid XML returned by some devices. +was it's inability to parse invalid XML returned by some devices, so +in this version we depend on L =cut diff --git a/lib/CWMP/Request.pm b/lib/CWMP/Request.pm deleted file mode 100644 index 07b93f4..0000000 --- a/lib/CWMP/Request.pm +++ /dev/null @@ -1,219 +0,0 @@ -package CWMP::Request; - -use warnings; -use strict; - -use XML::Rules; -use Data::Dump qw/dump/; -use Carp qw/confess cluck/; -use Class::Trigger; - -#use Devel::LeakTrace::Fast; - -=head1 NAME - -CWMP::Request - parse SOAP request metods - -=head1 CPE metods - -All methods described below call triggers with same name - -=cut - -our $state; # FIXME check this! - -our $rules = [ - #_default => 'content trim', - x_default => sub { - my ($tag_name, $tag_hash, $context, $parent_data) = @_; - warn dump( $tag_name, $tag_hash, $context ); - }, - 'ID' => sub { - my ($tag_name, $tag_hash, $context, $parent_data) = @_; - $state->{ID} = $tag_hash->{_content}; - chomp( $state->{ID} ); - }, - - 'DeviceId' => sub { - my ($tag_name, $tag_hash, $context, $parent_data) = @_; - foreach my $name ( keys %$tag_hash ) { - next if $name eq '_content'; - my $key = $name; - $key =~ s/^\w+://; # stip namespace - $state->{DeviceId}->{ $key } = _tag( $tag_hash, $name, '_content' ); - } - }, - 'EventStruct' => sub { - my ($tag_name, $tag_hash, $context, $parent_data) = @_; - push @{ $state->{EventStruct} }, $tag_hash->{EventCode}->{_content}; - }, - qr/(MaxEnvelopes|CurrentTime|RetryCount)/ => sub { - my ($tag_name, $tag_hash, $context, $parent_data) = @_; - $state->{$tag_name} = $tag_hash->{_content}; - }, - 'ParameterValueStruct' => sub { - my ($tag_name, $tag_hash, $context, $parent_data) = @_; - # Name/Value tags must be case insnesitive - my $value = (grep( /value/i, keys %$tag_hash ))[0]; - $state->{Parameter}->{ _tag($tag_hash, 'Name', '_content') } = _tag($tag_hash, 'Value', '_content' ); - $state->{_trigger} = 'ParameterValue'; - }, - -]; - -=head2 Inform - -Generate InformResponse to CPE - -=cut - -push @$rules, - 'Inform' => sub { - $state->{_dispatch} = 'InformResponse'; # what reponse to call - $state->{_trigger} = 'Inform'; - }; - -=head2 GetRPCMethodsResponse - -=cut - -push @$rules, - qr/^(?:^\w+:)*string$/ => 'content array', - 'MethodList' => sub { - my ($tag_name, $tag_hash, $context, $parent_data) = @_; - $state->{MethodList} = _tag( $tag_hash, 'string' ); - $state->{_trigger} = 'GetRPCMethodsResponse'; - }; - -=head2 GetParameterNamesResponse - -=cut - -push @$rules, - 'ParameterInfoStruct' => sub { - my ($tag_name, $tag_hash, $context, $parent_data) = @_; - my $name = _tag($tag_hash, 'Name', '_content'); - my $writable = _tag($tag_hash, 'Writable', '_content' ); - - confess "need state" unless ( $state ); # don't remove! - - $state->{ParameterInfo}->{$name} = $writable; - - #warn "## state = dump( $state ), "\n"; - - $state->{_trigger} = 'GetParameterNamesResponse'; - }; - -=head2 GetParameterAttributesResponse - -=cut - -push @$rules, - 'ParameterAttributeStruct' => sub { - my ($tag_name, $tag_hash, $context, $parent_data) = @_; - warn dump( $tag_name, $tag_hash, $context ); - - confess "need state" unless ( $state ); # don't remove! - - my $name = _tag($tag_hash, 'Name', '_content'); - - - $state->{ParameterAttribute}->{$name} = { - Notification => _tag($tag_hash, 'Notification', '_content' ), - AccessList => _tag($tag_hash, 'AccessList', 'string' ), - }; - - $state->{_trigger} = 'GetParameterAttributesResponse'; - }; - -=head2 Fault - -=cut - -push @$rules, - 'Fault' => sub { - my ($tag_name, $tag_hash, $context, $parent_data) = @_; - $state->{Fault} = { - FaultCode => _tag( $tag_hash, 'FaultCode', '_content' ), - FaultString => _tag( $tag_hash, 'FaultString', '_content' ), - }; - warn "FAULT: ", $state->{Fault}->{FaultCode}, " ", $state->{Fault}->{FaultString}, "\n"; - $state->{_trigger} = 'Fault'; - }; - -=head1 METHODS - -=head2 parse - - my $state = CWMP::Request->parse( "request" ); - -=cut - -sub parse { - my $self = shift; - - my $xml = shift || confess "no xml?"; - - $state = {}; - - my $parser = XML::Rules->new( -# start_rules => [ -# '^division_name,fax' => 'skip', -# ], - namespaces => { - 'http://schemas.xmlsoap.org/soap/envelope/' => 'soapenv', - 'http://schemas.xmlsoap.org/soap/encoding/' => 'soap', - 'http://www.w3.org/2001/XMLSchema' => 'xsd', - 'http://www.w3.org/2001/XMLSchema-instance' => 'xsi', - 'urn:dslforum-org:cwmp-1-0' => '', - }, - rules => $rules, - ); - -# warn "## created $parser\n"; - - $parser->parsestring( $xml ); - - undef $parser; - - if ( my $trigger = $state->{_trigger} ) { - warn "### call_trigger( $trigger )\n"; - $self->call_trigger( $trigger, $state ); - } - # XXX propagate _trigger (useful for symlinks) - - return $state; -} - -=head2 _tag - -Get value of tag. Tag name is case insensitive (don't ask why), -we ignore namespaces and can take optional C -(usually C<_content>). - - _tag( $tag_hash, $name, $sub_key ) - -=cut - -sub _tag { - my ( $tag_hash, $name, $sub_key ) = @_; - confess "need hash as first argument" unless ( ref $tag_hash eq 'HASH' ); - $name = (grep { m/^(?:\w+:)*$name$/i } keys %$tag_hash )[0]; -# $name =~ s/^\w+://; - if ( defined $tag_hash->{$name} ) { - if ( ! defined $sub_key ) { - return $tag_hash->{$name}; - } elsif ( defined $tag_hash->{$name}->{$sub_key} ) { - return $tag_hash->{$name}->{$sub_key}; - } else { - return if ( $name =~ m/^value$/i ); - warn "can't find '$name/$sub_key' in ", dump( $tag_hash ); - return; - } - } else { - warn "can't find '$name' in ", dump( $tag_hash ); - return; - } -} - -1;