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         confess "no ID in state ", dump( $state ) unless ( $state->{ID} );
  55
  56         #warn "state used to generate xml = ", dump( $state ) if $self->debug;
  57
  58         my $X = XML::Generator->new(':pretty');
  59
  60         return $X->Envelope( $soap, { 'soap:encodingStyle' => "http://schemas.xmlsoap.org/soap/encoding/" },
  61                 $X->Header( $soap,
  62                         $X->ID( $cwmp, { mustUnderstand => 1 }, $state->{ID} ),
  63                         $X->NoMoreRequests( $cwmp, $state->{NoMoreRequests} || 0 ),
  64                 ),
  65                 $X->Body( $soap, $closure->( $X, $state ) ),
  66         );
  67 }
  68
  69 =head1 CPE methods
  70
  71 =head2 GetRPCMethods
  72
  73   $method->GetRPCMethods( $state );
  74
  75 =cut
  76
  77 sub GetRPCMethods {
  78         my ( $self, $state ) = @_;
  79         $self->xml( $state, sub {
  80                 my ( $X, $state ) = @_;
  81                 $X->GetRPCMethods();
  82         });
  83 };
  84
  85 =head2 SetParameterValues
  86
  87   $method->SetParameterValues( $state, {
  88         param1 => 'value1',
  89         param2 => 'value2',
  90         ...
  91   });
  92
  93 It doesn't support base64 encoding of values yet.
  94
  95 To preserve data, it does support repeatable parametar names.
  96 Behaviour on this is not defined in protocol.
  97
  98 =cut
  99
 100 sub SetParameterValues {
 101         my $self = shift;
 102         my $state = shift;
 103
 104         confess "SetParameterValues needs parameters" unless @_;
 105
 106         my $params = shift || return;
 107
 108         warn "# SetParameterValues = ", dump( $params ), "\n" if $self->debug;
 109
 110         $self->xml( $state, sub {
 111                 my ( $X, $state ) = @_;
 112
 113                 $X->SetParameterValues( $cwmp,
 114                         $X->ParameterList( $cwmp,
 115                                 $X->ParameterNames( $cwmp,
 116                                         map {
 117                                                 $X->ParameterValueStruct( $cwmp,
 118                                                         $X->Name( $cwmp, $_ ),
 119                                                         $X->Value( $cwmp, $params->{$_} )
 120                                                 )
 121                                         } sort keys %$params
 122                                 )
 123                         )
 124                 );
 125         });
 126 }
 127
 128
 129 =head2 GetParameterValues
 130
 131   $method->GetParameterValues( $state, [ 'ParameterName', ... ] );
 132
 133 =cut
 134
 135 sub _array_param {
 136         my $v = shift;
 137         confess "array_mandatory(",dump($v),") isn't ARRAY" unless ref($v) eq 'ARRAY';
 138         return @$v;
 139 }
 140
 141 sub GetParameterValues {
 142         my $self = shift;
 143         my $state = shift;
 144         my @ParameterNames = _array_param(shift);
 145         warn "# GetParameterValues", dump( @ParameterNames ), "\n" if $self->debug;
 146
 147         $self->xml( $state, sub {
 148                 my ( $X, $state ) = @_;
 149
 150                 $X->GetParameterValues( $cwmp,
 151                         $X->ParameterNames( $cwmp,
 152                                 map {
 153                                         $X->string( $xsd, $_ )
 154                                 } @ParameterNames
 155                         )
 156                 );
 157         });
 158 }
 159
 160 =head2 GetParameterNames
 161
 162   $method->GetParameterNames( $state, [ $ParameterPath, $NextLevel ] );
 163
 164 =cut
 165
 166 sub GetParameterNames {
 167         my ( $self, $state, $param ) = @_;
 168         # default: all, all
 169         my ( $ParameterPath, $NextLevel ) = _array_param( $param );
 170         $ParameterPath ||= '';
 171         $NextLevel ||= 0;
 172         warn "# GetParameterNames( '$ParameterPath', $NextLevel )\n" if $self->debug;
 173         $self->xml( $state, sub {
 174                 my ( $X, $state ) = @_;
 175
 176                 $X->GetParameterNames( $cwmp,
 177                         $X->ParameterPath( $cwmp, $ParameterPath ),
 178                         $X->NextLevel( $cwmp, $NextLevel ),
 179                 );
 180         });
 181 }
 182
 183 =head2 GetParameterAttributes
 184
 185         $method->GetParameterAttributes( $state, [ $ParametarNames, ... ] );
 186
 187 =cut
 188
 189 sub GetParameterAttributes {
 190         my ( $self, $state, $param ) = @_;
 191         my @ParameterNames = _array_param($param);
 192
 193         warn "# GetParameterAttributes", dump( @ParameterNames ), "\n" if $self->debug;
 194
 195         $self->xml( $state, sub {
 196                 my ( $X, $state ) = @_;
 197
 198                 $X->GetParameterAttributes( $cwmp,
 199                         $X->ParameterNames( $cwmp,
 200                                 map {
 201                                         $X->string( $xsd, $_ )
 202                                 } @ParameterNames
 203                         )
 204                 );
 205         });
 206 }
 207
 208 =head2 Reboot
 209
 210   $method->Reboot( $state );
 211
 212 =cut
 213
 214 sub Reboot {
 215         my ( $self, $state ) = @_;
 216         $self->xml( $state, sub {
 217                 my ( $X, $state ) = @_;
 218                 $X->Reboot();
 219         });
 220 }
 221
 222 =head2 FactoryReset
 223
 224   $method->FactoryReset( $state );
 225
 226 =cut
 227
 228 sub FactoryReset {
 229         my ( $self, $state ) = @_;
 230         $self->xml( $state, sub {
 231                 my ( $X, $state ) = @_;
 232                 $X->FactoryReset();
 233         });
 234 }
 235
 236
 237 =head1 Server methods
 238
 239
 240 =head2 InformResponse
 241
 242   $method->InformResponse( $state );
 243
 244 =cut
 245
 246 sub InformResponse {
 247         my ( $self, $state ) = @_;
 248         $self->xml( $state, sub {
 249                 my ( $X, $state ) = @_;
 250                 $X->InformResponse( $cwmp,
 251                         $X->MaxEnvelopes( $cwmp, 1 )
 252                 );
 253         });
 254 }
 255
 256 =head1 BUGS
 257
 258 All other methods are unimplemented.
 259
 260 =cut
 261
 262 1;