1 # Dobrica Pavlinusic, <dpavlin@rot13.org> 06/22/07 14:35:38 CEST
7 use base qw/Class::Accessor/;
8 __PACKAGE__->mk_accessors( qw/
22 use Data::Dump qw/dump/;
25 use File::Path qw/mkpath/;
30 CWMP::Server - description
36 my $server = CWMP::Server->new({
53 hash with key C<module> with value C<DBMDeep> if L<CWMP::Store::DBMDeep>
54 is used. Other parametars are optional.
62 my $self = $class->SUPER::new( @_ );
64 warn "created ", __PACKAGE__, "(", dump( @_ ), ") object\n" if $self->debug;
66 warn "ACS waiting for request on port ", $self->port, "\n";
68 $self->debug( 0 ) unless $self->debug;
69 warn "## debug level: ", $self->debug, "\n" if $self->debug;
81 my $server = IO::Socket::INET->new(
83 LocalPort => $self->port,
86 ) || die "can't start server on ", $self->port, ": $!";
88 warn "listen on ", $server->sockhost, ":", $server->sockport, "\n";
91 my $client = $server->accept() || next; # ALARM trickle us
93 my $session = CWMP::Session->new( $self->session ) || confess "can't create sessision";
95 while ( $self->sock_session( $client, $session ) ) {
96 warn "# another one\n";
99 warn "# connection to ", $client->peerhost, " closed\n";
107 my ( $self, $sock, $session ) = @_;
109 my $request = <$sock>;
110 return unless $request;
111 my $ip = $sock->peerhost;
115 while ( my $header = <$sock> ) {
118 last if $header =~ m{^\s*$};
119 my ( $n, $v ) = split(/:\s*/, $header);
121 $headers->{ lc $n } = $v;
124 warn "<<<< $ip START\n$request\n";
126 return $sock->connected unless $headers;
128 warn "missing $_ header\n" foreach grep { ! defined $headers->{ lc $_ } } ( 'SOAPAction' );
131 if ( my $len = $headers->{'content-length'} ) {
132 read( $sock, $body, $len );
133 } elsif ( $headers->{'transfer-encoding'} =~ m/^chunked/i ) {
134 while ( my $len = <$sock> ) {
135 $len =~ s/[\r\n]+$//;
138 read( $sock, my $chunk, $len );
140 my $padding = <$sock>;
143 warn "empty request\n";
146 warn "$body\n<<<< $ip END\n";
148 my $response = $session->process_request( $ip, $body );
150 my $dump_nr = $dump_by_ip->{$ip}++;
152 if ( $self->create_dump ) {
153 mkpath "dump/$ip" unless -e "dump/$ip";
154 write_file( sprintf("dump/%s/%04d.request", $ip, $dump_nr), "$request\r\n$body" );
155 write_file( sprintf("dump/%s/%04d.response", $ip, $dump_nr ), $response );
158 warn ">>>> $ip START\n$response\n>>>> $ip END\n";
159 print $sock $response;
161 return $sock->connected;