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/;

=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;
                do {
                        $len = <STDIN>;
                        $len =~ s/[\n\r]*$//s;
                        $len = hex( $len );

                        #warn "getting chunk of $len bytes\n";

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

                } while ( $len > 0 );
        }

        warn "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::Server->new({ debug => $self->debug });

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

        print $response->Inform;
        
};

1;

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