lib/CWMP/Server.pm

   1 # Dobrica Pavlinusic, <dpavlin@rot13.org> 06/22/07 14:35:38 CEST
   2 package CWMP::Server;
   3
   4 use strict;
   5 use warnings;
   6
   7 use base qw/Class::Accessor/;
   8 __PACKAGE__->mk_accessors( qw/
   9 port
  10 store
  11 default_queue
  12 background
  13 debug
  14
  15 server
  16 / );
  17
  18 use CWMP::Session;
  19
  20 use Carp qw/confess/;
  21 use Data::Dump qw/dump/;
  22
  23 =head1 NAME
  24
  25 CWMP::Server - description
  26
  27 =head1 METHODS
  28
  29 =head2 new
  30
  31   my $server = CWMP::Server->new({
  32         port => 3333,
  33         store => {
  34                 module => 'DBMDeep',
  35                 path => 'var/',
  36         },
  37         default_queue => [ qw/GetRPCMethods GetParameterNames/ ],
  38         background => 1,
  39         debug => 1
  40   });
  41
  42 Options:
  43
  44 =over 4
  45
  46 =item port
  47
  48 port to listen on
  49
  50 =item store
  51
  52 hash with key C<module> with value C<DBMDeep> if L<CWMP::Store::DBMDeep>
  53 is used. Other parametars are optional.
  54
  55 =item default_queue
  56
  57 commands which will be issued to every CPE on connect
  58
  59 =back
  60
  61 =cut
  62
  63 sub new {
  64         my $class = shift;
  65         my $self = $class->SUPER::new( @_ );
  66
  67         warn "created ", __PACKAGE__, "(", dump( @_ ), ") object\n" if $self->debug;
  68
  69         warn "ACS waiting for request on port ", $self->port, "\n";
  70
  71         $self->debug( 0 ) unless $self->debug;
  72         warn "## debug level: ", $self->debug, "\n" if $self->debug;
  73
  74         $self->server(
  75                 CWMP::Server::Helper->new({
  76                         proto => 'tcp',
  77                         port => $self->port,
  78                         default_queue => $self->default_queue,
  79                         store => $self->store,
  80                         debug => $self->debug,
  81                         background => $self->background,
  82                 })
  83         );
  84
  85         return $self;
  86 }
  87
  88 =head2 run
  89
  90 =cut
  91
  92 sub run {
  93         my $self = shift;
  94
  95         $self->server->run;
  96 }
  97
  98 package CWMP::Server::Helper;
  99
 100 use warnings;
 101 use strict;
 102
 103 use base qw/Net::Server/;
 104 use Carp qw/confess/;
 105 use Data::Dump qw/dump/;
 106
 107 sub options {
 108         my $self     = shift;
 109         my $prop     = $self->{'server'};
 110         my $template = shift;
 111
 112         ### setup options in the parent classes
 113         $self->SUPER::options($template);
 114
 115         # new single-value options
 116         foreach my $p ( qw/ store debug / ) {
 117                 $prop->{ $p } ||= undef;
 118                 $template->{ $p } = \$prop->{ $p };
 119         }
 120
 121         # new multi-value options
 122         foreach my $p ( qw/ default_queue / ) {
 123                 $prop->{ $p } ||= [];
 124                 $template->{ $p } = $prop->{ $p };
 125         }
 126 }
 127
 128
 129 =head2 process_request
 130
 131 =cut
 132
 133 sub process_request {
 134         my $self = shift;
 135
 136         my $prop = $self->{server};
 137         confess "no server in ", ref( $self ) unless $prop;
 138         my $sock = $prop->{client};
 139         confess "no sock in ", ref( $self ) unless $sock;
 140
 141         warn "default CPE queue ", dump( $prop->{default_queue} ), "\n" if defined($prop->{default_queue});
 142
 143         eval  {
 144                 my $session = CWMP::Session->new({
 145                         sock => $sock,
 146                         queue => $prop->{default_queue},
 147                         store => $prop->{store},
 148                         debug => $prop->{debug},
 149                 }) || confess "can't create session";
 150
 151                 while ( $session->process_request ) {
 152                         warn "...waiting for next request from CPE...\n";
 153                 }
 154         };
 155
 156         if ($@) {
 157                 warn $@;
 158         }
 159
 160         warn "...returning to accepting new connections\n";
 161
 162 }
 163
 164 1;