lib/CWMP/Methods.pm

   1 package CWMP::Methods;
   2
   3 use strict;
   4 use warnings;
   5
   6
   7 use base qw/Class::Accessor/;
   8 __PACKAGE__->mk_accessors( qw/debug/ );
   9
  10 use XML::Generator;
  11 use Carp qw/confess/;
  12 use Data::Dump qw/dump/;
  13
  14 =head1 NAME
  15
  16 CWMP::Methods - generate SOAP meesages for CPE
  17
  18 =head1 METHODS
  19
  20 =head2 new
  21
  22   my $method = CWMP::Methods->new({ debug => 1 });
  23
  24 =cut
  25
  26 sub new {
  27         my $class = shift;
  28         my $self = $class->SUPER::new( @_ );
  29
  30         warn "created XML::Generator object\n" if $self->debug;
  31
  32         return $self;
  33 }
  34
  35 =head2 xml
  36
  37 Used to implement methods which modify just body of soap message.
  38 For examples, see source of this module.
  39
  40 =cut
  41
  42 my $cwmp = [ cwmp => 'urn:dslforum-org:cwmp-1-0' ];
  43 my $soap = [ soap => 'http://schemas.xmlsoap.org/soap/envelope/' ];
  44 my $xsd  = [ xsd  => 'http://www.w3.org/2001/XMLSchema-instance' ];
  45
  46 sub xml {
  47         my $self = shift;
  48
  49         my ( $state, $closure ) = @_;
  50
  51         confess "no state?" unless ($state);
  52         confess "no body closure" unless ( $closure );
  53
  54         #warn "state used to generate xml = ", dump( $state ) if $self->debug;
  55
  56         my $X = XML::Generator->new(':pretty');
  57
  58         my @header;
  59         push( @header, $X->ID( $cwmp, { mustUnderstand => 1 }, $state->{ID} )) if $state->{ID};
  60         push( @header, $X->NoMoreRequests( $cwmp, $state->{NoMoreRequests} || 0 ));
  61
  62         return $X->Envelope( $soap, { 'soap:encodingStyle' => "http://schemas.xmlsoap.org/soap/encoding/" },
  63                 $X->Header( $soap, @header ),
  64                 $X->Body( $soap, $closure->( $X, $state ) ),
  65         );
  66 }
  67
  68 =head1 CPE methods
  69
  70 =head2 GetRPCMethods
  71
  72   $method->GetRPCMethods( $state );
  73
  74 =cut
  75
  76 sub GetRPCMethods {
  77         my ( $self, $state ) = @_;
  78         $self->xml( $state, sub {
  79                 my ( $X, $state ) = @_;
  80                 $X->GetRPCMethods( $cwmp, '' );
  81         });
  82 };
  83
  84 =head2 SetParameterValues
  85
  86   $method->SetParameterValues( $state, {
  87         param1 => 'value1',
  88         param2 => 'value2',
  89         ...
  90   });
  91
  92 It doesn't support base64 encoding of values yet.
  93
  94 To preserve data, it does support repeatable parametar names.
  95 Behaviour on this is not defined in protocol.
  96
  97 =cut
  98
  99 sub SetParameterValues {
 100         my $self = shift;
 101         my $state = shift;
 102
 103         confess "SetParameterValues needs parameters" unless @_;
 104
 105         my $params = shift || return;
 106
 107         warn "# SetParameterValues = ", dump( $params ), "\n" if $self->debug;
 108
 109         $self->xml( $state, sub {
 110                 my ( $X, $state ) = @_;
 111
 112                 $X->SetParameterValues( $cwmp,
 113                         $X->ParameterList( [],
 114                                 map {
 115                                         $X->ParameterValueStruct( [],
 116                                                 $X->Name( [], $_ ),
 117                                                 $X->Value( [], $params->{$_} )
 118                                         )
 119                                 } sort keys %$params
 120                         ),
 121                         $X->ParameterKey( '' ),
 122                 );
 123         });
 124 }
 125
 126
 127 =head2 GetParameterValues
 128
 129   $method->GetParameterValues( $state, [ 'ParameterName', ... ] );
 130
 131 =cut
 132
 133 sub _array_param {
 134         my $v = shift;
 135         confess "array_mandatory(",dump($v),") isn't ARRAY" unless ref($v) eq 'ARRAY';
 136         return @$v;
 137 }
 138
 139 sub GetParameterValues {
 140         my $self = shift;
 141         my $state = shift;
 142         my @ParameterNames = _array_param(shift);
 143         warn "# GetParameterValues", dump( @ParameterNames ), "\n" if $self->debug;
 144
 145         $self->xml( $state, sub {
 146                 my ( $X, $state ) = @_;
 147
 148                 $X->GetParameterValues( $cwmp,
 149                         $X->ParameterNames( $cwmp,
 150                                 map {
 151                                         $X->string( $xsd, $_ )
 152                                 } @ParameterNames
 153                         )
 154                 );
 155         });
 156 }
 157
 158 =head2 GetParameterNames
 159
 160   $method->GetParameterNames( $state, [ $ParameterPath, $NextLevel ] );
 161
 162 =cut
 163
 164 sub GetParameterNames {
 165         my ( $self, $state, $param ) = @_;
 166         # default: all, all
 167         my ( $ParameterPath, $NextLevel ) = _array_param( $param );
 168         $ParameterPath ||= '';
 169         $NextLevel ||= 0;
 170         warn "# GetParameterNames( '$ParameterPath', $NextLevel )\n" if $self->debug;
 171         $self->xml( $state, sub {
 172                 my ( $X, $state ) = @_;
 173
 174                 $X->GetParameterNames( $cwmp,
 175                         $X->ParameterPath( $cwmp, $ParameterPath ),
 176                         $X->NextLevel( $cwmp, $NextLevel ),
 177                 );
 178         });
 179 }
 180
 181 =head2 GetParameterAttributes
 182
 183         $method->GetParameterAttributes( $state, [ $ParametarNames, ... ] );
 184
 185 =cut
 186
 187 sub GetParameterAttributes {
 188         my ( $self, $state, $param ) = @_;
 189         my @ParameterNames = _array_param($param);
 190
 191         warn "# GetParameterAttributes", dump( @ParameterNames ), "\n" if $self->debug;
 192
 193         $self->xml( $state, sub {
 194                 my ( $X, $state ) = @_;
 195
 196                 $X->GetParameterAttributes( $cwmp,
 197                         $X->ParameterNames( $cwmp,
 198                                 map {
 199                                         $X->string( $xsd, $_ )
 200                                 } @ParameterNames
 201                         )
 202                 );
 203         });
 204 }
 205
 206 =head2 Reboot
 207
 208   $method->Reboot( $state );
 209
 210 =cut
 211
 212 sub Reboot {
 213         my ( $self, $state ) = @_;
 214         $self->xml( $state, sub {
 215                 my ( $X, $state ) = @_;
 216                 $X->Reboot();
 217         });
 218 }
 219
 220 =head2 FactoryReset
 221
 222   $method->FactoryReset( $state );
 223
 224 =cut
 225
 226 sub FactoryReset {
 227         my ( $self, $state ) = @_;
 228         $self->xml( $state, sub {
 229                 my ( $X, $state ) = @_;
 230                 $X->FactoryReset();
 231         });
 232 }
 233
 234
 235 =head1 Server methods
 236
 237
 238 =head2 InformResponse
 239
 240   $method->InformResponse( $state );
 241
 242 =cut
 243
 244 sub InformResponse {
 245         my ( $self, $state ) = @_;
 246         $self->xml( $state, sub {
 247                 my ( $X, $state ) = @_;
 248                 $X->InformResponse( $cwmp,
 249                         $X->MaxEnvelopes( $cwmp, 1 )
 250                 );
 251         });
 252 }
 253
 254 =head1 BUGS
 255
 256 All other methods are unimplemented.
 257
 258 =cut
 259
 260 1;