Santa needed to implement a server to collect naughty/nice lists from all over the world. The IT elves needed a quick solution that allowed Naughty Montoring Service offices in far flung corners across the globe to report their extensive child behavioral data to HQ for analysis.
In the end the North Pole settled on Net::Server, a comprehensive, flexible, and robust framework used by numerous other packages such as Catalyst::Engine::Server and Starman. It handles the gritty details of listening on one or more sockets, forking and daemonising, buffering, logging and even more. In some cases it takes more control of things than you might want (like signal handling), but before you give-up and roll your own, ask yourself: Do you really need your server to be an ornament polish and a gingerbread house spackle?
Net::Server has extensive documentation, but our example script below should hopefully provide a comparatively short introduction.
1 # Run the server, unless this code is being loaded as a module 2 Xmas::NMS::Server->run() unless caller(); 3 4 package Xmas::NMS::Server; 5 use base qw(Net::Server::PreFork); 6 use Carp; 7 use Scalar::Util qw(blessed); 8 use File::Basename qw(dirname); 9 use File::Spec::Functions qw(catdir); 10 11 # Net::Server can take options from the command line, a 12 # config file, or as parameters to new() or run(). Using 13 # this method, you can override and add options that 14 # Net::Server will then recognize from any of those places 15 sub options { 16 my ( $self, $template ) = @_; # template is a hashref 17 my $props = $self->{server}; # server properties 18 19 # load the base class' options into the template 20 $self->SUPER::options( $template ); 21 22 # create a property entry for the new option 23 $props->{nms_authkey} ||= undef; 24 25 # put a reference to that entry into the template 26 $template->{nms_authkey} = \$props->{nms_authkey}; 27 28 # when the options are processed by Net::Server, 29 # their values will be stored in the referenced 30 # server property entries 31 32 # use an arrayref for multi-valued options 33 $props->{nms_regions} ||= []; 34 $template->{nms_regions} = $props->{nms_regions}; 35 36 # you can do each type in one line, if you like... 37 $template->{"nms_$_"} = \$props->{"nms_$_"} 38 for ( qw( data_dir client_timeout) ); 39 40 $template->{nms_data_types} = $props->{nms_data_types} ||= []; 41 } 42 43 # If you want to set some defaults differently or in 44 # addition to those already used by Net::Server, put 45 # them in a hash returned by this method. 46 sub default_values { 47 return { 48 port => 8765, 49 nms_client_timeout => 30, 50 51 # types of data collected by the agency 52 nms_data_types => [qw(observations hearsay gift_lists)], 53 54 # where to look for the data files 55 nms_data_dir => catdir( dirname( $0 ), 'data' ), 56 }; 57 } 58 59 # use this method to validate the values of your options 60 sub post_configure_hook { 61 my ( $self ) = @_; 62 my $props = $self->{server}; 63 64 @{ $props->{nms_regions} } 65 || croak "Please specify one or more values for nms_regions"; 66 67 $props->{nms_authkey} 68 || croak "Please specify a value for nms_authkey"; 69 } 70 71 # if you want to use authorization more involved than 72 # checking the client's IP address, use this hook 73 sub allow_deny_hook { 74 my ( $self ) = @_; 75 my $props = $self->{server}; 76 77 # prompt 78 $self->sendtext( "auth: " ); 79 80 my $line = $self->getline_timeout || return; 81 82 # authorized? return truth 83 return 1 if $line eq $props->{nms_authkey}; 84 85 # not authorized? return false 86 my $client_ip = $props->{peeraddr} || 'unknown'; 87 $self->sendlines( 88 "AUTHORIZATION FAILED FROM IP [$client_ip]", 89 "YOU ARE NOW ON THE NAUGHTY LIST", 90 ); 91 92 return; 93 } 94 95 # continuation of authorized connections 96 sub process_request { 97 my ( $self ) = @_; 98 99 my $props = $self->{server}; 100 my $client_fh = $props->{client}; 101 102 $self->sendlines( 103 "", 104 "Welcome to the NMS server for the following regions:", 105 ( map {"\t$_"} @{ $props->{nms_regions} } ), 106 "", 107 "Enter the name of a snot-nosed brat or QUIT to logout.", 108 "NOTE: children actually named 'QUIT' have a tough life", 109 "already and automatically get a pony EVERY YEAR", 110 "", 111 ); 112 113 while ( $self->sendtext( "name: " ) 114 and defined( my $name = $self->getline_timeout ) ) 115 { 116 return if $name eq 'QUIT'; 117 $self->sendlines( "\t$name is a rotten little kid", "" ); 118 } 119 120 } 121 122 # this isn't a Net::Server hook, it's just a helper 123 # to get a line from the client within a timeout 124 sub getline_timeout { 125 my ( $self, $client_fh, $timeout ) = @_; 126 127 $client_fh ||= $self->{server}{client}; 128 $timeout ||= $self->{server}{nms_client_timeout}; 129 130 # attempt to get a line from the client within the timeout 131 my $line = eval { 132 133 # set an alarm to throw an exception... 134 local $SIG{'ALRM'} = sub { die "Timed Out!\n" }; 135 my $previous_alarm = alarm( $timeout ); 136 137 my $line = $client_fh->getline; 138 139 # restore the old alarm value 140 alarm( $previous_alarm ); 141 142 # return the line from the eval 143 $line; 144 }; 145 146 # if the alarm went off, catch the exception 147 if ( $@ =~ /timed out/i ) { 148 $self->sendlines( 149 $client_fh, 150 "Timed Out - You were too slow-ho-ho!" 151 ); 152 return; 153 } 154 155 # getline can return undef... 156 return unless defined $line; 157 158 # strip out any end-of-line chars 159 $line =~ s/\r?\n$//; 160 return $line; 161 } 162 163 164 # another helper method to make decorate text with newlines 165 sub sendlines { 166 my $self = shift; 167 my ($client_fh, @lines) = $self->_client_fh_from_args( @_ ); 168 $self->sendtext( $client_fh, map { "$_\r\n" } @lines ); 169 } 170 171 # concatenate text and send to client undecorated 172 sub sendtext { 173 my ( $self ) = shift; 174 175 my ($client_fh, @lines) = $self->_client_fh_from_args( @_ ); 176 177 $client_fh->print( map { defined( $_ ) ? $_ : "" } @lines ) 178 or croak "Error sending data to the client!"; 179 } 180 181 # find out if the first argument is a filehandle. if so, use that. 182 # if not, use the client filehandle. 183 sub _client_fh_from_args { 184 my $self = shift; 185 my $client_fh 186 = ( blessed( $_[0] ) && $_[0]->can( 'print' ) ) ? 187 shift : $self->{server}{client}; 188 return ( $client_fh, @_ ); 189 } 190 191 1;