lib/CWMP/Methods.pm

package CWMP::Methods;

use strict;
use warnings;


use base qw/Class::Accessor/;
__PACKAGE__->mk_accessors( qw/debug/ );

use XML::Generator;
use Carp qw/confess/;
use Data::Dump qw/dump/;

=head1 NAME

CWMP::Methods - generate SOAP meesages for CPE

=head1 METHODS

=head2 new

  my $method = CWMP::Methods->new({ debug => 1 });

=cut

sub new {
        my $class = shift;
        my $self = $class->SUPER::new( @_ );

        warn "created XML::Generator object\n" if $self->debug;

        return $self;
}

=head2 xml

Used to implement methods which modify just body of soap message.
For examples, see source of this module.

=cut

my $cwmp = [ cwmp => 'urn:dslforum-org:cwmp-1-0' ];
my $soap = [ soap => 'http://schemas.xmlsoap.org/soap/envelope/' ];
my $xsd  = [ xsd  => 'http://www.w3.org/2001/XMLSchema-instance' ];

sub xml {
        my $self = shift;

        my ( $state, $closure ) = @_;

        confess "no state?" unless ($state);
        confess "no body closure" unless ( $closure );

        confess "no ID in state ", dump( $state ) unless ( $state->{ID} );

        #warn "state used to generate xml = ", dump( $state ) if $self->debug;

        my $X = XML::Generator->new(':pretty');

        return $X->Envelope( $soap, { 'soap:encodingStyle' => "http://schemas.xmlsoap.org/soap/encoding/" },
                $X->Header( $soap,
                        $X->ID( $cwmp, { mustUnderstand => 1 }, $state->{ID} ),
                        $X->NoMoreRequests( $cwmp, $state->{NoMoreRequests} || 0 ),
                ),
                $X->Body( $soap, $closure->( $X, $state ) ),
        );
}

=head1 CPE methods

=head2 GetRPCMethods

  $method->GetRPCMethods( $state );

=cut

sub GetRPCMethods {
        my ( $self, $state ) = @_;
        $self->xml( $state, sub {
                my ( $X, $state ) = @_;
                $X->GetRPCMethods();
        });
};

=head2 SetParameterValues

  $method->SetParameterValues( $state,
        param1 => 'value1',
        param2 => 'value2',
        ...
  );

It doesn't support base64 encoding of values yet.

To preserve data, it does support repeatable parametar names.
Behaviour on this is not defined in protocol.

=cut

sub SetParameterValues {
        my $self = shift;
        my $state = shift;

        confess "SetParameterValues needs parameters" unless @_;

        my @params = @_;

        my ( @names, @values );

        while ( @_ ) {
                push @names, shift @_;
                push @values, shift @_;
        }

        confess "can't convert params ", dump( @params ), " to name/value pairs" unless $#names == $#values;

        warn "# SetParameterValues", dump( @params ), "\n" if $self->debug;

        $self->xml( $state, sub {
                my ( $X, $state ) = @_;

                $X->SetParameterValues( $cwmp,
                        $X->ParameterList( $cwmp,
                                $X->ParameterNames( $cwmp,
                                        map {
                                                $X->ParameterValueStruct( $cwmp,
                                                        $X->Name( $cwmp, $_ ),
                                                        $X->Value( $cwmp, shift @values )
                                                )
                                        } @names
                                )
                        )
                );
        });
}


=head2 GetParameterValues

  $method->GetParameterValues( $state, $ParameterNames );

=cut

sub GetParameterValues {
        my $self = shift;
        my $state = shift;
        my @ParameterNames = @_;
        confess "GetParameterValues need ParameterNames" unless @ParameterNames;
        warn "# GetParameterValues", dump( @ParameterNames ), "\n" if $self->debug;

        $self->xml( $state, sub {
                my ( $X, $state ) = @_;

                $X->GetParameterValues( $cwmp,
                        $X->ParameterNames( $cwmp,
                                map {
                                        $X->string( $xsd, $_ )
                                } @ParameterNames
                        )
                );
        });
}

=head2 GetParameterNames

  $method->GetParameterNames( $state, $ParameterPath, $NextLevel );

=cut

sub GetParameterNames {
        my ( $self, $state, $ParameterPath, $NextLevel ) = @_;
        $ParameterPath ||= '';  # all
        $NextLevel ||= 0;               # all
        warn "# GetParameterNames( '$ParameterPath', $NextLevel )\n" if $self->debug;
        $self->xml( $state, sub {
                my ( $X, $state ) = @_;

                $X->GetParameterNames( $cwmp,
                        $X->ParameterPath( $cwmp, $ParameterPath ),
                        $X->NextLevel( $cwmp, $NextLevel ),
                );
        });
}

=head2 Reboot

  $method->Reboot( $state );

=cut

sub Reboot {
        my ( $self, $state ) = @_;
        $self->xml( $state, sub {
                my ( $X, $state ) = @_;
                $X->Reboot();
        });
}


=head1 Server methods


=head2 InformResponse

  $method->InformResponse( $state );

=cut

sub InformResponse {
        my ( $self, $state ) = @_;
        $self->xml( $state, sub {
                my ( $X, $state ) = @_;
                $X->InformResponse( $cwmp,
                        $X->MaxEnvelopes( $cwmp, 1 )
                );
        });
}

=head1 BUGS

All other methods are unimplemented.

=cut

1;
1	dpavlin	173	package CWMP::Methods;
2	dpavlin	31
3			use strict;
4			use warnings;
5
6	dpavlin	106
7	dpavlin	32	use base qw/Class::Accessor/;
8	dpavlin	106	__PACKAGE__->mk_accessors( qw/debug/ );
9	dpavlin	31
10	dpavlin	38	use XML::Generator;
11			use Carp qw/confess/;
12			use Data::Dump qw/dump/;
13
14	dpavlin	32	=head1 NAME
15	dpavlin	31
16	dpavlin	173	CWMP::Methods - generate SOAP meesages for CPE
17	dpavlin	31
18	dpavlin	174	=head1 METHODS
19	dpavlin	32
20			=head2 new
21
22	dpavlin	174	my $method = CWMP::Methods->new({ debug => 1 });
23	dpavlin	32
24			=cut
25
26			sub new {
27			my $class = shift;
28			my $self = $class->SUPER::new( @_ );
29
30	dpavlin	71	warn "created XML::Generator object\n" if $self->debug;
31	dpavlin	32
32			return $self;
33			}
34
35	dpavlin	174	=head2 xml
36	dpavlin	32
37	dpavlin	174	Used to implement methods which modify just body of soap message.
38			For examples, see source of this module.
39
40			=cut
41
42	dpavlin	31	my $cwmp = [ cwmp => 'urn:dslforum-org:cwmp-1-0' ];
43	dpavlin	172	my $soap = [ soap => 'http://schemas.xmlsoap.org/soap/envelope/' ];
44			my $xsd = [ xsd => 'http://www.w3.org/2001/XMLSchema-instance' ];
45	dpavlin	31
46	dpavlin	174	sub xml {
47			my $self = shift;
48	dpavlin	31
49	dpavlin	174	my ( $state, $closure ) = @_;
50	dpavlin	32
51	dpavlin	174	confess "no state?" unless ($state);
52			confess "no body closure" unless ( $closure );
53	dpavlin	32
54	dpavlin	174	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	dpavlin	46	}
68
69	dpavlin	174	=head1 CPE methods
70
71	dpavlin	46	=head2 GetRPCMethods
72
73	dpavlin	174	$method->GetRPCMethods( $state );
74	dpavlin	46
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	dpavlin	174	=head2 SetParameterValues
86	dpavlin	53
87	dpavlin	178	$method->SetParameterValues( $state,
88			param1 => 'value1',
89			param2 => 'value2',
90			...
91			);
92	dpavlin	53
93	dpavlin	178	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 = @_;
107
108			my ( @names, @values );
109
110			while ( @_ ) {
111			push @names, shift @_;
112			push @values, shift @_;
113			}
114
115			confess "can't convert params ", dump( @params ), " to name/value pairs" unless $#names == $#values;
116
117			warn "# SetParameterValues", dump( @params ), "\n" if $self->debug;
118
119			$self->xml( $state, sub {
120			my ( $X, $state ) = @_;
121
122			$X->SetParameterValues( $cwmp,
123			$X->ParameterList( $cwmp,
124			$X->ParameterNames( $cwmp,
125			map {
126			$X->ParameterValueStruct( $cwmp,
127			$X->Name( $cwmp, $_ ),
128			$X->Value( $cwmp, shift @values )
129			)
130			} @names
131			)
132			)
133			);
134			});
135			}
136
137
138	dpavlin	174	=head2 GetParameterValues
139
140			$method->GetParameterValues( $state, $ParameterNames );
141
142	dpavlin	53	=cut
143
144	dpavlin	174	sub GetParameterValues {
145			my $self = shift;
146			my $state = shift;
147			my @ParameterNames = @_;
148	dpavlin	178	confess "GetParameterValues need ParameterNames" unless @ParameterNames;
149	dpavlin	174	warn "# GetParameterValues", dump( @ParameterNames ), "\n" if $self->debug;
150
151	dpavlin	53	$self->xml( $state, sub {
152			my ( $X, $state ) = @_;
153	dpavlin	174
154			$X->GetParameterValues( $cwmp,
155			$X->ParameterNames( $cwmp,
156			map {
157			$X->string( $xsd, $_ )
158			} @ParameterNames
159			)
160			);
161	dpavlin	53	});
162			}
163
164	dpavlin	166	=head2 GetParameterNames
165	dpavlin	59
166	dpavlin	174	$method->GetParameterNames( $state, $ParameterPath, $NextLevel );
167	dpavlin	59
168			=cut
169
170			sub GetParameterNames {
171	dpavlin	64	my ( $self, $state, $ParameterPath, $NextLevel ) = @_;
172			$ParameterPath \|\|= ''; # all
173			$NextLevel \|\|= 0; # all
174			warn "# GetParameterNames( '$ParameterPath', $NextLevel )\n" if $self->debug;
175	dpavlin	59	$self->xml( $state, sub {
176			my ( $X, $state ) = @_;
177	dpavlin	64
178	dpavlin	59	$X->GetParameterNames( $cwmp,
179	dpavlin	64	$X->ParameterPath( $cwmp, $ParameterPath ),
180			$X->NextLevel( $cwmp, $NextLevel ),
181	dpavlin	59	);
182			});
183			}
184	dpavlin	61
185	dpavlin	174	=head2 Reboot
186	oleide	141
187	dpavlin	174	$method->Reboot( $state );
188	oleide	141
189			=cut
190
191	dpavlin	174	sub Reboot {
192			my ( $self, $state ) = @_;
193	oleide	141	$self->xml( $state, sub {
194			my ( $X, $state ) = @_;
195	dpavlin	174	$X->Reboot();
196	oleide	141	});
197			}
198
199	dpavlin	48
200	dpavlin	174	=head1 Server methods
201	dpavlin	48
202
203	dpavlin	174	=head2 InformResponse
204	dpavlin	32
205	dpavlin	174	$method->InformResponse( $state );
206	dpavlin	38
207	dpavlin	174	=cut
208	dpavlin	46
209	dpavlin	174	sub InformResponse {
210			my ( $self, $state ) = @_;
211			$self->xml( $state, sub {
212			my ( $X, $state ) = @_;
213			$X->InformResponse( $cwmp,
214			$X->MaxEnvelopes( $cwmp, 1 )
215			);
216			});
217			}
218	dpavlin	38
219	dpavlin	174	=head1 BUGS
220	dpavlin	50
221	dpavlin	174	All other methods are unimplemented.
222	dpavlin	32
223	dpavlin	174	=cut
224	dpavlin	32
225			1;