lib/CWMP/Session.pm

# Dobrica Pavlinusic, <dpavlin@rot13.org> 06/18/07 10:19:50 CEST
package CWMP::Server;

use strict;
use warnings;

use base qw/HTTP::Server::Simple::CGI Class::Accessor/;
__PACKAGE__->mk_accessors( qw/
debug
/ );

use Data::Dump qw/dump/;
use CWMP::Request;
use CWMP::Response;

=head1 NAME

CWMP::Server - implement logic of CWMP protocol

=head1 METHODS

=head2 handler

We override L<HTTP::Server::Simple::CGI/handler> so that we can support
chunked transfer encoding.

=cut

sub handler {
    my $self = shift;

    my $chunk;

        my $transfer_encoding = $self->header('Transfer-Encoding');

        if ( $transfer_encoding && $transfer_encoding =~ qr/^chunked/i ) {

                my $len = 0;
                my $hex;
                do {
                        $hex = <STDIN>;         # get chunk length
                        $hex =~ s/[\n\r]*$//s;
                        $len = hex( $hex );

                        warn "getting chunk of 0x$hex $len bytes\n" if $self->debug;

                        while( $len > 0 ) {
                                my $line = <STDIN>;
                                $chunk .= $line;
                                $len -= length( $line );
                        }

                } while ( hex( $hex ) != 0 );
        }

        warn "handler got ", length($chunk), " bytes\n" if $self->debug;

    my $cgi  = new CGI( $chunk );

    eval { $self->handle_request($cgi) };
    if ($@) {
        my $error = $@;
        warn $error;
    }
}

=head2 handle_request

Implementation of dispatch logic

=cut

sub handle_request {
        my ($self, $cgi) = @_;
                                                                    
        #... do something, print output to default
        # selected filehandle...

        warn ">> " . localtime() . " " . $ENV{REMOTE_ADDR} . "\n";

        warn "not SOAP request" unless defined ( $cgi->header('SOAPAction') );

        if ( my $payload = $cgi->param('POSTDATA') ) {
                warn "request payload:\n$payload\n" if $self->debug;

                my $state = CWMP::Request->parse( $payload );

                warn "acquired state = ", dump( $state );
        
        }

        my $response = CWMP::Response->new({ debug => $self->debug });

        print "Content-Type: text/xml\r\n\r\n";

        print $response->Inform;
        
};

1;

1	# Dobrica Pavlinusic, <dpavlin@rot13.org> 06/18/07 10:19:50 CEST
2	package CWMP::Server;
3
4	use strict;
5	use warnings;
6
7	use base qw/HTTP::Server::Simple::CGI Class::Accessor/;
8	__PACKAGE__->mk_accessors( qw/
9	debug
10	/ );
11
12	use Data::Dump qw/dump/;
13	use CWMP::Request;
14	use CWMP::Response;
15
16	=head1 NAME
17
18	CWMP::Server - implement logic of CWMP protocol
19
20	=head1 METHODS
21
22	=head2 handler
23
24	We override L<HTTP::Server::Simple::CGI/handler> so that we can support
25	chunked transfer encoding.
26
27	=cut
28
29	sub handler {
30	my $self = shift;
31
32	my $chunk;
33
34	my $transfer_encoding = $self->header('Transfer-Encoding');
35
36	if ( $transfer_encoding && $transfer_encoding =~ qr/^chunked/i ) {
37
38	my $len = 0;
39	my $hex;
40	do {
41	$hex = <STDIN>; # get chunk length
42	$hex =~ s/[\n\r]*$//s;
43	$len = hex( $hex );
44
45	warn "getting chunk of 0x$hex $len bytes\n" if $self->debug;
46
47	while( $len > 0 ) {
48	my $line = <STDIN>;
49	$chunk .= $line;
50	$len -= length( $line );
51	}
52
53	} while ( hex( $hex ) != 0 );
54	}
55
56	warn "handler got ", length($chunk), " bytes\n" if $self->debug;
57
58	my $cgi = new CGI( $chunk );
59
60	eval { $self->handle_request($cgi) };
61	if ($@) {
62	my $error = $@;
63	warn $error;
64	}
65	}
66
67	=head2 handle_request
68
69	Implementation of dispatch logic
70
71	=cut
72
73	sub handle_request {
74	my ($self, $cgi) = @_;
75
76	#... do something, print output to default
77	# selected filehandle...
78
79	warn ">> " . localtime() . " " . $ENV{REMOTE_ADDR} . "\n";
80
81	warn "not SOAP request" unless defined ( $cgi->header('SOAPAction') );
82
83	if ( my $payload = $cgi->param('POSTDATA') ) {
84	warn "request payload:\n$payload\n" if $self->debug;
85
86	my $state = CWMP::Request->parse( $payload );
87
88	warn "acquired state = ", dump( $state );
89
90	}
91
92	my $response = CWMP::Response->new({ debug => $self->debug });
93
94	print "Content-Type: text/xml\r\n\r\n";
95
96	print $response->Inform;
97
98	};
99
100	1;
101