libnet-server-perl 0.99-3 / usr / share / perl5 / Net / Server.pm

# -*- perl -*-
#
#  Net::Server - Extensible Perl internet server
#
#  $Id: Server.pm,v 1.127 2010/07/09 14:55:31 rhandom Exp $
#
#  Copyright (C) 2001-2010
#
#    Paul Seamons
#    paul@seamons.com
#    http://seamons.com/
#
#    Rob Brown bbb@cpan,org
#
#  This package may be distributed under the terms of either the
#  GNU General Public License
#    or the
#  Perl Artistic License
#
#  All rights reserved.
#
################################################################

package Net::Server;

use strict;
use vars qw($VERSION);
use Socket qw(unpack_sockaddr_in sockaddr_family AF_INET AF_INET6 AF_UNIX SOCK_DGRAM SOCK_STREAM);
use Socket6 qw(inet_ntop inet_pton unpack_sockaddr_in6);
use IO::Socket ();
use IO::Select ();
use POSIX ();
use Fcntl ();
use FileHandle;
use Net::Server::Proto ();
use Net::Server::Daemonize qw(check_pid_file create_pid_file
                              get_uid get_gid set_uid set_gid
                              safe_fork
                              );

$VERSION = '0.99';

###----------------------------------------------------------------###

sub new {
  my $class = shift || die "Missing class";
  my $args  = @_ == 1 ? shift : {@_};
  my $self  = bless {server => { %$args }}, $class;
  return $self;
}

sub _initialize {
  my $self = shift;

  ### need a place to store properties
  $self->{server} = {} unless defined($self->{server}) && ref($self->{server});

  ### save for a HUP
  $self->commandline($self->_get_commandline)
      if ! eval { $self->commandline };

  ### prepare to cache configuration parameters
  $self->{server}->{conf_file_args} = undef;
  $self->{server}->{configure_args} = undef;

  $self->configure_hook;      # user customizable hook

  $self->configure(@_);       # allow for reading of commandline,
                              # program, and configuration file parameters

  ### allow yet another way to pass defaults
  my $defaults = $self->default_values || {};
  foreach my $key (keys %$defaults) {
    next if ! exists $self->{server}->{$key};
    if (ref $self->{server}->{$key} eq 'ARRAY') {
      if (! @{ $self->{server}->{$key} }) { # was empty
        my $val = $defaults->{$key};
        $self->{server}->{$key} = ref($val) ? $val : [$val];
      }
    } elsif (! defined $self->{server}->{$key}) {
      $self->{server}->{$key} = $defaults->{$key};
    }
  }

  ### get rid of cached config parameters
  delete $self->{server}->{conf_file_args};
  delete $self->{server}->{configure_args};

}

###----------------------------------------------------------------###

### program flow
sub run {

  ### pass package or object
  my $self = ref($_[0]) ? shift() : shift->new;

  $self->_initialize(@_ == 1 ? %{$_[0]} : @_);     # configure all parameters

  $self->post_configure;      # verification of passed parameters

  $self->post_configure_hook; # user customizable hook

  $self->pre_bind;            # finalize ports to be bound

  $self->bind;                # connect to port(s)
                              # setup selection handle for multi port

  $self->post_bind_hook;      # user customizable hook

  $self->post_bind;           # allow for chrooting,
                              # becoming a different user and group

  $self->pre_loop_hook;       # user customizable hook

  $self->loop;                # repeat accept/process cycle

  ### routines inside a standard $self->loop
  # $self->accept             # wait for client connection
  # $self->run_client_connection # process client
  # $self->done               # indicate if connection is done

  $self->server_close;        # close the server and release the port
                              # this will run pre_server_close_hook
                              #               close_children
                              #               post_child_cleanup_hook
                              #               shutdown_sockets
                              # and either exit or run restart_close_hook
}

### standard connection flow
sub run_client_connection {
  my $self = shift;

  $self->post_accept;         # prepare client for processing

  $self->get_client_info;     # determines information about peer and local

  $self->post_accept_hook;    # user customizable hook

  if( $self->allow_deny             # do allow/deny check on client info
      && $self->allow_deny_hook ){  # user customizable hook

    $self->process_request;   # This is where the core functionality
                              # of a Net::Server should be.  This is the
                              # only method necessary to override.
  }else{

    $self->request_denied_hook;     # user customizable hook

  }

  $self->post_process_request_hook; # user customizable hook

  $self->post_process_request;      # clean up client connection, etc

  $self->post_client_connection_hook; # one last hook
}

###----------------------------------------------------------------###

sub _get_commandline {
  my $self = shift;
  my $prop = $self->{server};

  ### see if we can find the full command line
  if (open _CMDLINE, "/proc/$$/cmdline") { # unix specific
    my $line = do { local $/ = undef; <_CMDLINE> };
    close _CMDLINE;
    if ($line =~ /^(.+)$/) { # need to untaint to allow for later hup
      return [split /\0/, $1];
    }
  }

  my $script = $0;
  $script = $ENV{'PWD'} .'/'. $script if $script =~ m|^[^/]+/| && $ENV{'PWD'}; # add absolute to relative
  $script =~ /^(.+)$/; # untaint for later use in hup
  return [ $1, @ARGV ]
}

sub commandline {
    my $self = shift;
    if (@_) { # allow for set
      $self->{server}->{commandline} = ref($_[0]) ? shift : \@_;
    }
    return $self->{server}->{commandline} || die "commandline was not set during initialization";
}

###----------------------------------------------------------------###

### any values to set if no configuration could be found
sub default_values { {} }

### any pre-initialization stuff
sub configure_hook {}


### set up the object a little bit better
sub configure {
  my $self = shift;
  my $prop = $self->{server};
  my $template = undef;
  local @_ = @_; # fix some issues under old perls on alpha systems

  ### allow for a template to be passed
  if( $_[0] && ref($_[0]) ){
    $template = shift;
  }

  ### do command line
  $self->process_args( \@ARGV, $template ) if defined @ARGV;

  ### do startup file args
  ### cache a reference for multiple calls later
  my $args = undef;
  if( $prop->{configure_args} && ref($prop->{configure_args}) ){
    $args = $prop->{configure_args};
  }else{
    $args = $prop->{configure_args} = \@_;
  }
  $self->process_args( $args, $template ) if defined $args;

  ### do a config file
  if( defined $prop->{conf_file} ){
    $self->process_conf( $prop->{conf_file}, $template );
  } else {
    ### look for a default conf_file
    my $def = $self->default_values || {};
    if ($def->{conf_file}) {
        $self->process_conf( $def->{conf_file}, $template );
    }
  }

}


### make sure it has been configured properly
sub post_configure {
  my $self = shift;
  my $prop = $self->{server};

  ### set the log level
  if( !defined $prop->{log_level} || $prop->{log_level} !~ /^\d+$/ ){
    $prop->{log_level} = 2;
  }
  $prop->{log_level} = 4 if $prop->{log_level} > 4;


  ### log to STDERR
  if( ! defined($prop->{log_file}) ){
    $prop->{log_file} = '';

  ### log to syslog
  }elsif( $prop->{log_file} eq 'Sys::Syslog' ){

    $self->open_syslog;

  ### open a logging file
  }elsif( $prop->{log_file} && $prop->{log_file} ne 'Sys::Syslog' ){

    die "Unsecure filename \"$prop->{log_file}\""
      unless $prop->{log_file} =~ m|^([\w\.\-/\\]+)$|;
    $prop->{log_file} = $1;
    open(_SERVER_LOG, ">>$prop->{log_file}")
      or die "Couldn't open log file \"$prop->{log_file}\" [$!].";
    _SERVER_LOG->autoflush(1);
    $prop->{chown_log_file} = 1;

  }

  ### see if a daemon is already running
  if( defined $prop->{pid_file} ){
    if( ! eval{ check_pid_file( $prop->{pid_file} ) } ){
      if (! $ENV{BOUND_SOCKETS}) {
        warn $@;
      }
      $self->fatal( $@ );
    }
  }

  ### completetly daemonize by closing STDIN, STDOUT (should be done before fork)
  if( ! $prop->{_is_inet} ){
    if( $prop->{setsid} || length($prop->{log_file}) ){
      open(STDIN,  '</dev/null') || die "Can't read /dev/null  [$!]";
      open(STDOUT, '>/dev/null') || die "Can't write /dev/null [$!]";
    }
  }

  if (! $ENV{BOUND_SOCKETS}) {
    ### background the process - unless we are hup'ing
    if( $prop->{setsid} || defined($prop->{background}) ){
      my $pid = eval{ safe_fork() };
      if( not defined $pid ){ $self->fatal( $@ ); }
      exit(0) if $pid;
      $self->log(2,"Process Backgrounded");
    }

    ### completely remove myself from parent process - unless we are hup'ing
    if( $prop->{setsid} ){
      POSIX::setsid();
    }
  }

  ### completetly daemonize by closing STDERR (should be done after fork)
  if( length($prop->{log_file}) && $prop->{log_file} ne 'Sys::Syslog' ){
    open STDERR, '>&_SERVER_LOG' || die "Can't open STDERR to _SERVER_LOG [$!]";
  }elsif( $prop->{setsid} ){
    open STDERR, '>&STDOUT' || die "Can't open STDERR to STDOUT [$!]";
  }

  ### allow for a pid file (must be done after backgrounding and chrooting)
  ### Remove of this pid may fail after a chroot to another location...
  ### however it doesn't interfere either.
  if( defined $prop->{pid_file} ){
    if( eval{ create_pid_file( $prop->{pid_file} ) } ){
      $prop->{pid_file_unlink} = 1;
    }else{
      $self->fatal( $@ );
    }
  }

  ### make sure that allow and deny look like array refs
  $prop->{allow} = [] unless defined($prop->{allow}) && ref($prop->{allow});
  $prop->{deny}  = [] unless defined($prop->{deny})  && ref($prop->{deny} );
  $prop->{cidr_allow} = [] unless defined($prop->{cidr_allow}) && ref($prop->{cidr_allow});
  $prop->{cidr_deny}  = [] unless defined($prop->{cidr_deny})  && ref($prop->{cidr_deny} );

}


### user customizable hook
sub post_configure_hook {}


### make sure we have good port parameters
sub pre_bind {
  my $self = shift;
  my $prop = $self->{server};

  my $super = do { no strict 'refs'; ${ref($self)."::ISA"}[0] };
  $super = "$super -> MultiType -> $Net::Server::MultiType::ISA[0]" if $self->isa('Net::Server::MultiType');
  $super = (! $super || ref($self) eq $super) ? '' : " (type $super)";
  $self->log(2,$self->log_time ." ". ref($self) .$super. " starting! pid($$)");

  ### set a default port, host, and proto
  $prop->{port} = [$prop->{port}] if defined($prop->{port}) && ! ref($prop->{port});
  if (! defined($prop->{port}) || ! @{ $prop->{port} }) {
    my $port = ($self->can('default_port') && $self->default_port) || 20203;
    $port = [$port] if ! ref $port;
    $self->log(2,"Port Not Defined.  Defaulting to '@$port'\n");
    $prop->{port}  = $port;
  }

  $prop->{host} = []              if ! defined $prop->{host};
  $prop->{host} = [$prop->{host}] if ! ref     $prop->{host};
  push @{ $prop->{host} }, (($prop->{host}->[-1]) x (@{ $prop->{port} } - @{ $prop->{host}})); # augment hosts with as many as port
  foreach my $host (@{ $prop->{host} }) {
    $host = '*' if ! defined $host || ! length $host;;
    $host = ($host =~ /^([\[\]\:\w\.\-\*\/]+)$/) ? $1 : $self->fatal("Unsecure host \"$host\"");
  }

  $prop->{proto} = []               if ! defined $prop->{proto};
  $prop->{proto} = [$prop->{proto}] if ! ref     $prop->{proto};
  push @{ $prop->{proto} }, (($prop->{proto}->[-1]) x (@{ $prop->{port} } - @{ $prop->{proto}})); # augment hosts with as many as port
  foreach my $proto (@{ $prop->{proto} }) {
      $proto ||= 'tcp';
      $proto = ($proto =~ /^(\w+)$/) ? $1 : $self->fatal("Unsecure proto \"$proto\"");
  }

  ### loop through the passed ports
  ### set up parallel arrays of hosts, ports, and protos
  ### port can be any of many types (tcp,udp,unix, etc)
  ### see perldoc Net::Server::Proto for more information
  my %bound;
  foreach (my $i = 0 ; $i < @{ $prop->{port} } ; $i++) {
    my $port  = $prop->{port}->[$i];
    my $host  = $prop->{host}->[$i];
    my $proto = $prop->{proto}->[$i];
    if ($port ne 0 && $bound{"$host/$port/$proto"}++) {
      $self->log(2, "Duplicate configuration (".(uc $proto)." port $port on host $host - skipping");
      next;
    }
    my $obj = $self->proto_object($host, $port, $proto) || next;
    push @{ $prop->{sock} }, $obj;
  }
  if (! @{ $prop->{sock} }) {
    $self->fatal("No valid socket parameters found");
  }

  if (! defined($prop->{listen}) || $prop->{listen} !~ /^\d+$/) {
    my $max = Socket::SOMAXCONN();
    $max = 128 if $max < 10; # some invalid Solaris contants ?
    $prop->{listen} = $max;
    $self->log(2, "Using default listen value of $max");
  }

}

### method for invoking procol specific bindings
sub proto_object {
  my $self = shift;
  my ($host,$port,$proto) = @_;
  return Net::Server::Proto->object($host,$port,$proto,$self);
}

### bind to the port (This should serve all but INET)
sub bind {
  my $self = shift;
  my $prop = $self->{server};

  ### connect to previously bound ports
  if( exists $ENV{BOUND_SOCKETS} ){

    $self->restart_open_hook();

    $self->log(2, "Binding open file descriptors");

    ### loop through the past information and match things up
    foreach my $info (split /\n/, $ENV{BOUND_SOCKETS}) {
      my ($fd, $hup_string) = split /\|/, $info, 2;
      $fd = ($fd =~ /^(\d+)$/) ? $1 : $self->fatal("Bad file descriptor");
      foreach my $sock ( @{ $prop->{sock} } ){
        if ($hup_string eq $sock->hup_string) {
          $sock->log_connect($self);
          $sock->reconnect($fd, $self);
          last;
        }
      }
    }
    delete $ENV{BOUND_SOCKETS};

  ### connect to fresh ports
  }else{

    foreach my $sock ( @{ $prop->{sock} } ){
      $sock->log_connect($self);
      $sock->connect( $self );
    }

  }

  ### if more than one port we'll need to select on it
  if( @{ $prop->{port} } > 1 || $prop->{multi_port} ){
    $prop->{multi_port} = 1;
    $prop->{select} = IO::Select->new();
    foreach ( @{ $prop->{sock} } ){
      $prop->{select}->add( $_ );
    }
  }else{
    $prop->{multi_port} = undef;
    $prop->{select}     = undef;
  }

}


### user customizable hook
sub post_bind_hook {}


### secure the process and background it
sub post_bind {
  my $self = shift;
  my $prop = $self->{server};


  ### figure out the group(s) to run as
  if( ! defined $prop->{group} ){
    $self->log(1,"Group Not Defined.  Defaulting to EGID '$)'\n");
    $prop->{group}  = $);
  }else{
    if( $prop->{group} =~ /^([\w-]+( [\w-]+)*)$/ ){
      $prop->{group} = eval{ get_gid( $1 ) };
      $self->fatal( $@ ) if $@;
    }else{
      $self->fatal("Invalid group \"$prop->{group}\"");
    }
  }


  ### figure out the user to run as
  if( ! defined $prop->{user} ){
    $self->log(1,"User Not Defined.  Defaulting to EUID '$>'\n");
    $prop->{user}  = $>;
  }else{
    if( $prop->{user} =~ /^([\w-]+)$/ ){
      $prop->{user} = eval{ get_uid( $1 ) };
      $self->fatal( $@ ) if $@;
    }else{
      $self->fatal("Invalid user \"$prop->{user}\"");
    }
  }


  ### chown any files or sockets that we need to
  if( $prop->{group} ne $) || $prop->{user} ne $> ){
    my @chown_files = ();
    foreach my $sock ( @{ $prop->{sock} } ){
      push @chown_files, $sock->NS_unix_path
        if $sock->NS_proto eq 'UNIX';
    }
    if( $prop->{pid_file_unlink} ){
      push @chown_files, $prop->{pid_file};
    }
    if( $prop->{lock_file_unlink} ){
      push @chown_files, $prop->{lock_file};
    }
    if( $prop->{chown_log_file} ){
      delete $prop->{chown_log_file};
      push @chown_files, $prop->{log_file};
    }
    my $uid = $prop->{user};
    my $gid = (split(/\ /,$prop->{group}))[0];
    foreach my $file (@chown_files){
      chown($uid,$gid,$file)
        or $self->fatal("Couldn't chown \"$file\" [$!]\n");
    }
  }


  ### perform the chroot operation
  if( defined $prop->{chroot} ){
    if( ! -d $prop->{chroot} ){
      $self->fatal("Specified chroot \"$prop->{chroot}\" doesn't exist.\n");
    }else{
      $self->log(2,"Chrooting to $prop->{chroot}\n");
      chroot( $prop->{chroot} )
        or $self->fatal("Couldn't chroot to \"$prop->{chroot}\": $!");
    }
  }


  ### drop privileges
  eval{
    if( $prop->{group} ne $) ){
      $self->log(2,"Setting gid to \"$prop->{group}\"");
      set_gid( $prop->{group} );
    }
    if( $prop->{user} ne $> ){
      $self->log(2,"Setting uid to \"$prop->{user}\"");
      set_uid( $prop->{user} );
    }
  };
  if( $@ ){
    if( $> == 0 ){
      $self->fatal( $@ );
    } elsif( $< == 0){
      $self->log(2,"NOTICE: Effective UID changed, but Real UID is 0: $@");
    }else{
      $self->log(2,$@);
    }
  }

  ### record number of request
  $prop->{requests} = 0;

  ### set some sigs
  $SIG{INT} = $SIG{TERM} = $SIG{QUIT} = sub { $self->server_close; };

  ### most cases, a closed pipe will take care of itself
  $SIG{PIPE} = 'IGNORE';

  ### catch children (mainly for Fork and PreFork but works for any chld)
  $SIG{CHLD} = \&sig_chld;

  ### catch sighup
  $SIG{HUP} = sub { $self->sig_hup; }

}

### routine to avoid zombie children
sub sig_chld {
  1 while (waitpid(-1, POSIX::WNOHANG()) > 0);
  $SIG{CHLD} = \&sig_chld;
}


### user customizable hook
sub pre_loop_hook {}


### receive requests
sub loop {
  my $self = shift;

  while( $self->accept ){

    $self->run_client_connection;

    last if $self->done;

  }
}


### wait for the connection
sub accept {
  my $self = shift;
  my $prop = $self->{server};
  my $sock = undef;
  my $retries = 30;

  ### try awhile to get a defined client handle
  ### normally a good handle should occur every time
  while( $retries-- ){

    ### with more than one port, use select to get the next one
    if( defined $prop->{multi_port} ){

      return 0 if defined $prop->{_HUP};

      ### anything server type specific
      $sock = $self->accept_multi_port;
      next unless $sock; # keep trying for the rest of retries

      return 0 if defined $prop->{_HUP};

      if ($self->can_read_hook($sock)) {
        $retries ++;
        next;
      }

    ### single port is bound - just accept
    }else{

      $sock = $prop->{sock}->[0];

    }

    ### make sure we got a good sock
    if( not defined $sock ){
      $self->fatal("Received a bad sock!");
    }

    ### receive a udp packet
    if( SOCK_DGRAM == $sock->getsockopt(Socket::SOL_SOCKET(),Socket::SO_TYPE()) ){
      $prop->{client}   = $sock;
      $prop->{udp_true} = 1;
      $prop->{udp_peer} = $sock->recv($prop->{udp_data},
                                      $sock->NS_recv_len,
                                      $sock->NS_recv_flags,
                                      );

    ### blocking accept per proto
    }else{
      delete $prop->{udp_true};
      $prop->{client} = $sock->accept();

    }

    ### last one if HUPed
    return 0 if defined $prop->{_HUP};

    ### success
    return 1 if defined $prop->{client};

    $self->log(2,"Accept failed with $retries tries left: $!");

    ### try again in a second
    sleep(1);

  }
  $self->log(1,"Ran out of accept retries!");

  return undef;
}


### server specific hook for multi port applications
### this actually applies to all but INET
sub accept_multi_port {
  my $self = shift;
  my $prop = $self->{server};

  if( not exists $prop->{select} ){
    $self->fatal("No select property during multi_port execution.");
  }

  ### this will block until a client arrives
  my @waiting = $prop->{select}->can_read();

  ### if no sockets, return failure
  return undef unless @waiting;

  ### choose a socket
  return $waiting[ rand(@waiting) ];

}

### this occurs after a socket becomes readible on an accept_multi_port call.
### It is passed $self and the $sock that is readible.  A return value
### of true indicates to not pass the handle on to the process_request method and
### to return to accepting
sub can_read_hook {}


### this occurs after the request has been processed
### this is server type specific (actually applies to all by INET)
sub post_accept {
  my $self = shift;
  my $prop = $self->{server};

  ### keep track of the requests
  $prop->{requests} ++;

  return if $prop->{udp_true}; # no need to do STDIN/STDOUT in UDP

  ### duplicate some handles and flush them
  ### maybe we should save these somewhere - maybe not
  if (defined(my $client = $prop->{client})) {
    if (! $prop->{no_client_stdout}) {
      close STDIN;
      close STDOUT;
      if ($prop->{'tie_client_stdout'} || ($client->can('tie_stdout') && $client->tie_stdout)) {
          open STDIN,  "<", "/dev/null" or die "Couldn't open STDIN to the client socket: $!";
          open STDOUT, ">", "/dev/null" or die "Couldn't open STDOUT to the client socket: $!";
          tie *STDOUT, 'Net::Server::TiedHandle', $client, $prop->{'tied_stdout_callback'} or die "Couldn't tie STDOUT: $!";
          tie *STDIN,  'Net::Server::TiedHandle', $client, $prop->{'tied_stdin_callback'}  or die "Couldn't tie STDIN: $!";
      } elsif (defined(my $fileno = fileno $prop->{client})) {
          open STDIN,  "<&$fileno" or die "Couldn't open STDIN to the client socket: $!";
          open STDOUT, ">&$fileno" or die "Couldn't open STDOUT to the client socket: $!";
      } else {
          *STDIN  = \*{ $prop->{client} };
          *STDOUT = \*{ $prop->{client} };
      }
      STDIN->autoflush(1);
      STDOUT->autoflush(1);
      select(STDOUT);
    }
  }else{
    $self->log(1,"Client socket information could not be determined!");
  }

}

### read information about the client connection
sub get_client_info {
  my $self = shift;
  my $prop = $self->{server};
  my $sock = $prop->{client};

  ### handle unix style connections
  if( UNIVERSAL::can($sock,'NS_proto') && $sock->NS_proto eq 'UNIX' ){
    my $path = $sock->NS_unix_path;
    $self->log(3,$self->log_time
               ." CONNECT UNIX Socket: \"$path\"\n");

    return;
  } elsif ($self->isa('Net::Server::INET')) {
    $prop->{sockaddr} = $ENV{'REMOTE_HOST'} || '0.0.0.0';
    $prop->{peeraddr} = '0.0.0.0';
    $prop->{sockhost} = $prop->{peerhost} = 'inetd.server';
    $prop->{sockport} = $prop->{peerport} = 0;
    return;
  }

  ### read information about this connection
  my $sockname = getsockname( $sock );
  if( $sockname ){
    $prop->{sockfamily} = sockaddr_family( $sockname );
    ($prop->{sockport}, $prop->{sockaddr})
      = ($prop->{sockfamily} == AF_INET6) ? unpack_sockaddr_in6( $sockname ) : unpack_sockaddr_in( $sockname );
    $prop->{sockaddr} = inet_ntop( $prop->{sockfamily}, $prop->{sockaddr} );

  }else{
    ### does this only happen from command line?
    $prop->{sockfamily} = AF_INET;
    $prop->{sockaddr} = $ENV{'REMOTE_HOST'} || '0.0.0.0';
    $prop->{sockhost} = 'inet.test';
    $prop->{sockport} = 0;
  }

  ### try to get some info about the remote host
  my $proto_type = 'TCP';
  if( $prop->{udp_true} ){
    $proto_type = 'UDP';
    ($prop->{peerport} ,$prop->{peeraddr})
      = ($prop->{sockfamily} == AF_INET6) ? unpack_sockaddr_in6( $prop->{udp_peer} ) : unpack_sockaddr_in( $prop->{udp_peer} );
  }elsif( $prop->{peername} = getpeername( $sock ) ){
    ($prop->{peerport}, $prop->{peeraddr})
      = ($prop->{sockfamily} == AF_INET6) ? unpack_sockaddr_in6( $prop->{peername} ) : unpack_sockaddr_in( $prop->{peername} );
  }

  if( $prop->{peername} || $prop->{udp_true} ){
    $prop->{peeraddr} = inet_ntop( $prop->{sockfamily}, $prop->{peeraddr} );

    if( defined $prop->{reverse_lookups} ){
      $prop->{peerhost} = gethostbyaddr( inet_pton($prop->{sockfamily}, $prop->{peeraddr}), $prop->{sockfamily} );
    }
    $prop->{peerhost} = '' unless defined $prop->{peerhost};

  }else{
    ### does this only happen from command line?
    $prop->{peeraddr} = '0.0.0.0';
    $prop->{peerhost} = 'inet.test';
    $prop->{peerport} = 0;
  }

  $self->log(3,$self->log_time
             ." CONNECT $proto_type Peer: \"$prop->{peeraddr}:$prop->{peerport}\""
             ." Local: \"$prop->{sockaddr}:$prop->{sockport}\"\n");

}

### user customizable hook
sub post_accept_hook {}

### perform basic allow/deny service
sub allow_deny {
  my $self = shift;
  my $prop = $self->{server};
  my $sock = $prop->{client};

  ### unix sockets are immune to this check
  if( UNIVERSAL::can($sock,'NS_proto') && $sock->NS_proto eq 'UNIX' ){
    return 1;
  }

  ### if no allow or deny parameters are set, allow all
  return 1 if
       $#{ $prop->{allow} } == -1
    && $#{ $prop->{deny} }  == -1
    && $#{ $prop->{cidr_allow} } == -1
    && $#{ $prop->{cidr_deny} }  == -1;

  ### work around Net::CIDR::cidrlookup() croaking,
  ### if first parameter is an IPv4 address in IPv6 notation.
  my $peeraddr = ($prop->{peeraddr} =~ /^\s*::ffff:([0-9.]+\s*)$/) ? $1 : $prop->{peeraddr};

  ### if the addr or host matches a deny, reject it immediately
  foreach ( @{ $prop->{deny} } ){
    return 0 if $prop->{peerhost} =~ /^$_$/ && defined($prop->{reverse_lookups});
    return 0 if $peeraddr =~ /^$_$/;
  }
  if ($#{ $prop->{cidr_deny} } != -1) {
    require Net::CIDR;
    return 0 if Net::CIDR::cidrlookup($peeraddr, @{ $prop->{cidr_deny} });
  }


  ### if the addr or host isn't blocked yet, allow it if it is allowed
  foreach ( @{ $prop->{allow} } ){
    return 1 if $prop->{peerhost} =~ /^$_$/ && defined($prop->{reverse_lookups});
    return 1 if $peeraddr =~ /^$_$/;
  }
  if ($#{ $prop->{cidr_allow} } != -1) {
    require Net::CIDR;
    return 1 if Net::CIDR::cidrlookup($peeraddr, @{ $prop->{cidr_allow} });
  }

  return 0;
}


### user customizable hook
### if this hook returns 1 the request is processed
### if this hook returns 0 the request is denied
sub allow_deny_hook { 1 }


### user customizable hook
sub request_denied_hook {}


### this is the main method to override
### this is where most of the work will occur
### A sample server is shown below.
sub process_request {
  my $self = shift;
  my $prop = $self->{server};

  ### handle udp packets (udp echo server)
  if( $prop->{udp_true} ){
    if( $prop->{udp_data} =~ /dump/ ){
      require Data::Dumper;
      $prop->{client}->send( Data::Dumper::Dumper( $self ) , 0);
    }else{
      $prop->{client}->send("You said \"$prop->{udp_data}\"", 0 );
    }
    return;
  }


  ### handle tcp connections (tcp echo server)
  print "Welcome to \"".ref($self)."\" ($$)\r\n";

  ### eval block needed to prevent DoS by using timeout
  my $timeout = 30; # give the user 30 seconds to type a line
  my $previous_alarm = alarm($timeout);
  eval {

    local $SIG{ALRM} = sub { die "Timed Out!\n" };

    while( <STDIN> ){

      s/\r?\n$//;

      print ref($self),":$$: You said \"$_\"\r\n";
      $self->log(5,$_); # very verbose log

      if( /get (\w+)/ ){
        print "$1: $self->{server}->{$1}\r\n";
      }

      if( /dump/ ){
        require Data::Dumper;
        print Data::Dumper::Dumper( $self );
      }

      if( /quit/ ){ last }

      if( /exit/ ){ $self->server_close }

      alarm($timeout);
    }

  };
  alarm($previous_alarm);


  if ($@ eq "Timed Out!\n") {
    print STDOUT "Timed Out.\r\n";
    return;
  }

}


### user customizable hook
sub post_process_request_hook {}

sub post_client_connection_hook {}

### this is server type specific functions after the process
sub post_process_request {
  my $self = shift;
  my $prop = $self->{server};

  ### don't do anything for udp
  return if $prop->{udp_true};

  ### close the client socket handle
  if( ! $prop->{no_client_stdout} ){
    # close handles - but leave fd's around to prevent spurious messages (Rob Mueller)
    #close STDIN;
    #close STDOUT;
    untie *STDOUT if tied *STDOUT;
    untie *STDIN  if tied *STDIN;
    open(STDIN,  '</dev/null') || die "Can't read /dev/null  [$!]";
    open(STDOUT, '>/dev/null') || die "Can't write /dev/null [$!]";
  }
  $prop->{client}->close;

}


### determine if I am done with a request
### in the base type, we are never done until a SIG occurs
sub done {
  my $self = shift;
  $self->{server}->{done} = shift if @_;
  return $self->{server}->{done};
}


### fork off a child process to handle dequeuing
sub run_dequeue {
  my $self = shift;
  my $pid  = fork;

  ### trouble
  if( not defined $pid ){
    $self->fatal("Bad fork [$!]");

  ### parent
  }elsif( $pid ){
    $self->{server}->{children}->{$pid}->{status} = 'dequeue';

  ### child
  }else{
    $self->dequeue();
    exit;
  }
}

### sub process which could be implemented to
### perform tasks such as clearing a mail queue.
### currently only supported in PreFork
sub dequeue {}


### user customizable hook
sub pre_server_close_hook {}

### this happens when the server reaches the end
sub server_close {
  my $self     = shift;
  my $exit_val = shift || 0;
  my $prop = $self->{server};

  $SIG{INT} = 'DEFAULT';

  ### if this is a child process, signal the parent and close
  ### normally the child shouldn't, but if they do...
  ### otherwise the parent continues with the shutdown
  ### this is safe for non standard forked child processes
  ### as they will not have server_close as a handler
  if (defined($prop->{ppid})
      && $prop->{ppid} != $$
      && ! defined($prop->{no_close_by_child})) {
    $self->close_parent;
    exit;
  }

  ### allow for customizable closing
  $self->pre_server_close_hook;

  $self->log(2,$self->log_time . " Server closing!");

  if (defined($prop->{_HUP}) && $prop->{leave_children_open_on_hup}) {
      $self->hup_children;

  } else {
      ### shut down children if any
      if( defined $prop->{children} ){
          $self->close_children();
      }

      ### allow for additional cleanup phase
      $self->post_child_cleanup_hook();
  }

  ### remove files
  if( defined($prop->{lock_file})
      && -e $prop->{lock_file}
      && defined($prop->{lock_file_unlink}) ){
    unlink($prop->{lock_file}) || $self->log(1, "Couldn't unlink \"$prop->{lock_file}\" [$!]");
  }
  if( defined($prop->{pid_file})
      && -e $prop->{pid_file}
      && !defined($prop->{_HUP})
      && defined($prop->{pid_file_unlink}) ){
    unlink($prop->{pid_file}) || $self->log(1, "Couldn't unlink \"$prop->{pid_file}\" [$!]");
  }

  ### HUP process
  if( defined $prop->{_HUP} ){

    $self->restart_close_hook();

    $self->hup_server; # execs at the end
  }

  ### we don't need the ports - close everything down
  $self->shutdown_sockets;

  ### all done - exit
  $self->server_exit($exit_val);
}

### called at end once the server has exited
sub server_exit {
  my $self = shift;
  my $exit_val = shift || 0;
  exit($exit_val);
}

### allow for fully shutting down the bound sockets
sub shutdown_sockets {
  my $self = shift;
  my $prop = $self->{server};

  ### unlink remaining socket files (if any)
  foreach my $sock ( @{ $prop->{sock} } ){
    $sock->shutdown(2); # close sockets - nobody should be reading/writing still

    unlink $sock->NS_unix_path
      if $sock->NS_proto eq 'UNIX';
  }

  ### delete the sock objects
  $prop->{sock} = [];

  return 1;
}

### Allow children to send INT signal to parent (or use another method)
### This method is only used by forking servers
sub close_parent {
  my $self = shift;
  my $prop = $self->{server};
  die "Missing parent pid (ppid)" if ! $prop->{ppid};
  kill 2, $prop->{ppid};
}

### SIG INT the children
### This method is only used by forking servers (ie Fork, PreFork)
sub close_children {
  my $self = shift;
  my $prop = $self->{server};

  return unless defined $prop->{children} && scalar keys %{ $prop->{children} };

  foreach my $pid (keys %{ $prop->{children} }) {
    ### if it is killable, kill it
    if( ! defined($pid) || kill(15,$pid) || ! kill(0,$pid) ){
      $self->delete_child( $pid );
    }

  }

  ### need to wait off the children
  ### eventually this should probably use &check_sigs
  1 while waitpid(-1, POSIX::WNOHANG()) > 0;

}


sub is_prefork { 0 }

sub hup_children {
  my $self = shift;
  my $prop = $self->{server};

  return unless defined $prop->{children} && scalar keys %{ $prop->{children} };
  return if ! $self->is_prefork;
  $self->log(2, "Sending children hup signal during HUP on prefork server\n");

  foreach my $pid (keys %{ $prop->{children} }) {
      kill(1,$pid); # try to hup it
  }
}

sub post_child_cleanup_hook {}

### handle sig hup
### this will prepare the server for a restart via exec
sub sig_hup {
  my $self = shift;
  my $prop = $self->{server};

  ### prepare for exec
  my $i  = 0;
  my @fd = ();
  $prop->{_HUP} = [];
  foreach my $sock ( @{ $prop->{sock} } ){

    ### duplicate the sock
    my $fd = POSIX::dup($sock->fileno)
      or $self->fatal("Can't dup socket [$!]");

    ### hold on to the socket copy until exec
    $prop->{_HUP}->[$i] = IO::Socket::INET6->new();
    $prop->{_HUP}->[$i]->fdopen($fd, 'w')
      or $self->fatal("Can't open to file descriptor [$!]");

    ### turn off the FD_CLOEXEC bit to allow reuse on exec
    $prop->{_HUP}->[$i]->fcntl( Fcntl::F_SETFD(), my $flags = "" );

    ### save host,port,proto, and file descriptor
    push @fd, $fd .'|'. $sock->hup_string;

    ### remove anything that may be blocking
    $sock->close();

    $i++;
  }

  ### remove any blocking obstacle
  if( defined $prop->{select} ){
    delete $prop->{select};
  }

  $ENV{BOUND_SOCKETS} = join("\n", @fd);

  if ($prop->{leave_children_open_on_hup} && scalar keys %{ $prop->{children} }) {
      $ENV{HUP_CHILDREN} = join("\n", map {"$_\t$prop->{children}->{$_}->{status}"} sort keys %{ $prop->{children} });
  }
}

### restart the server using prebound sockets
sub hup_server {
  my $self = shift;

  $self->log(0,$self->log_time()." HUP'ing server");

  delete $ENV{$_} for $self->hup_delete_env_keys;

  exec @{ $self->commandline };
}

sub hup_delete_env_keys { return qw(PATH) }

### this hook occurs if a server has been HUP'ed
### it occurs just before opening to the fileno's
sub restart_open_hook {}

### this hook occurs if a server has been HUP'ed
### it occurs just before exec'ing the server
sub restart_close_hook {}

###----------------------------------------------------------###

### what to do when all else fails
sub fatal {
  my $self = shift;
  my $error = shift;
  my ($package,$file,$line) = caller;
  $self->fatal_hook($error, $package, $file, $line);

  $self->log(0, $self->log_time ." ". $error
             ."\n  at line $line in file $file");

  $self->server_close(1);
}


### user customizable hook
sub fatal_hook {}

###----------------------------------------------------------###

### handle opening syslog
sub open_syslog {
  my $self = shift;
  my $prop = $self->{server};

  require Sys::Syslog;

  if (ref($prop->{syslog_logsock}) eq 'ARRAY') {
    # do nothing - assume they have what they want
  } else {
    if (! defined $prop->{syslog_logsock}) {
      $prop->{syslog_logsock} = ($Sys::Syslog::VERSION < 0.15) ? 'unix' : '';
    }
    if ($prop->{syslog_logsock} =~ /^(|native|tcp|udp|unix|inet|stream|console)$/) {
      $prop->{syslog_logsock} = $1;
    } else {
      $prop->{syslog_logsock} = ($Sys::Syslog::VERSION < 0.15) ? 'unix' : '';
    }
  }

  my $ident = defined($prop->{syslog_ident})
    ? $prop->{syslog_ident} : 'net_server';
  $prop->{syslog_ident} = ($ident =~ /^([\ -~]+)$/)
    ? $1 : 'net_server';


  my $opt = defined($prop->{syslog_logopt})
    ? $prop->{syslog_logopt} : $Sys::Syslog::VERSION ge '0.15' ? 'pid,nofatal' : 'pid';
  $prop->{syslog_logopt} = ($opt =~ /^( (?: (?:cons|ndelay|nowait|pid|nofatal) (?:$|[,|]) )* )/x)
    ? $1 : 'pid';

  my $fac = defined($prop->{syslog_facility})
    ? $prop->{syslog_facility} : 'daemon';
  $prop->{syslog_facility} = ($fac =~ /^((\w+)($|\|))*/)
    ? $1 : 'daemon';

  if ($prop->{syslog_logsock}) {
    Sys::Syslog::setlogsock($prop->{syslog_logsock}) || die "Syslog err [$!]";
  }
  if( ! Sys::Syslog::openlog($prop->{syslog_ident},
                             $prop->{syslog_logopt},
                             $prop->{syslog_facility}) ){
    die "Couldn't open syslog [$!]" if $prop->{syslog_logopt} ne 'ndelay';
  }
}

### how internal levels map to syslog levels
$Net::Server::syslog_map = {0 => 'err',
                            1 => 'warning',
                            2 => 'notice',
                            3 => 'info',
                            4 => 'debug'};

### record output
sub log {
  my ($self, $level, $msg, @therest) = @_;
  my $prop = $self->{server};

  return if ! $prop->{log_level};

  # if multiple arguments are passed, assume that the first is a format string
  $msg = sprintf($msg, @therest) if @therest;

  ### log only to syslog if setup to do syslog
  if (defined($prop->{log_file}) && $prop->{log_file} eq 'Sys::Syslog') {
    if ($level =~ /^\d+$/) {
        return if $level > $prop->{log_level};
        $level = $Net::Server::syslog_map->{$level} || $level;
    }

    if (! eval { Sys::Syslog::syslog($level, '%s', $msg); 1 }) {
        my $err = $@;
        $self->handle_syslog_error($err, [$level, $msg]);
    }

    return;
  } else {
    return if $level !~ /^\d+$/ || $level > $prop->{log_level};
  }

  $self->write_to_log_hook($level, $msg);
}

### allow catching syslog errors
sub handle_syslog_error {
  my ($self, $error) = @_;
  die $error;
}

### standard log routine, this could very easily be
### overridden with a syslog call
sub write_to_log_hook {
  my ($self, $level, $msg) = @_;
  my $prop = $self->{server};
  chomp $msg;
  $msg =~ s/([^\n\ -\~])/sprintf("%%%02X",ord($1))/eg;

  if( $prop->{log_file} ){
    print _SERVER_LOG $msg, "\n";
  }elsif( $prop->{setsid} ){
    # do nothing
  }else{
    my $old = select(STDERR);
    print $msg. "\n";
    select($old);
  }

}


### default time format
sub log_time {
  my ($sec,$min,$hour,$day,$mon,$year) = localtime;
  return sprintf("%04d/%02d/%02d-%02d:%02d:%02d",
                 $year+1900, $mon+1, $day, $hour, $min, $sec);
}

###----------------------------------------------------------###

### set up default structure
sub options {
  my $self = shift;
  my $prop = $self->{server};
  my $ref  = shift;

  foreach ( qw(port host proto allow deny cidr_allow cidr_deny) ){
    if (! defined $prop->{$_}) {
      $prop->{$_} = [];
    } elsif (! ref $prop->{$_}) {
      $prop->{$_} = [$prop->{$_}]; # nicely turn us into an arrayref if we aren't one already
    }
    $ref->{$_} = $prop->{$_};
  }

  foreach ( qw(conf_file
               user group chroot log_level
               log_file pid_file background setsid
               listen reverse_lookups
               syslog_logsock syslog_ident
               syslog_logopt syslog_facility
               no_close_by_child
               no_client_stdout tie_client_stdout tied_stdout_callback tied_stdin_callback
               leave_children_open_on_hup
               ) ){
    $ref->{$_} = \$prop->{$_};
  }

}


### routine for parsing commandline, module, and conf file
### possibly should use Getopt::Long but this
### method has the benefit of leaving unused arguments in @ARGV
sub process_args {
  my $self = shift;
  my $ref  = shift;
  my $template = shift; # allow for custom passed in template

  ### if no template is passed, obtain our own
  if (! $template || ! ref($template)) {
    $template = {};
    $self->options( $template );
  }

  ### we want subsequent calls to not overwrite or add to
  ### previously set values so that command line arguments win
  my %previously_set;

  foreach (my $i=0 ; $i < @$ref ; $i++) {

    if ($ref->[$i] =~ /^(?:--)?(\w+)([=\ ](\S+))?$/
        && exists $template->{$1}) {
      my ($key,$val) = ($1,$3);
      splice( @$ref, $i, 1 );
      if (not defined($val)) {
        if ($i > $#$ref
            || ($ref->[$i] && $ref->[$i] =~ /^--\w+/)) {
          $val = 1; # allow for options such as --setsid
        } else {
          $val = splice( @$ref, $i, 1 );
          if (ref($val) && $key !~ /_callback$/) {
            die "Found an invalid configuration value for \"$key\" ($val)" if ref($val) ne 'ARRAY';
            $val = $val->[0] if @$val == 1;
          }
        }
      }
      $i--;
      $val =~ s/%([A-F0-9])/chr(hex $1)/eig if ! ref $val;;

      if (ref $template->{$key} eq 'ARRAY') {
        if (! defined $previously_set{$key}) {
          $previously_set{$key} = scalar @{ $template->{$key} };
        }
        next if $previously_set{$key};
        push @{ $template->{$key} }, ref($val) ? @$val : $val;
      } else {
        if (! defined $previously_set{$key}) {
          $previously_set{$key} = defined(${ $template->{$key} }) ? 1 : 0;
        }
        next if $previously_set{$key};
        die "Found multiple values on the configuration item \"$key\" which expects only one value" if ref($val) && $key !~ /_callback$/;
        ${ $template->{$key} } = $val;
      }
    }

  }

}


### routine for loading conf file parameters
### cache the args temporarily to handle multiple calls
sub process_conf {
  my $self = shift;
  my $file = shift;
  my $template = shift;
  $template = undef if ! $template || ! ref($template);
  my @args = ();

  if( ! $self->{server}->{conf_file_args} ){
    $file = ($file =~ m|^([\w\.\-\/\\\:]+)$|)
      ? $1 : $self->fatal("Unsecure filename \"$file\"");

    if( not open(_CONF,"<$file") ){
      if (! $ENV{BOUND_SOCKETS}) {
        warn "Couldn't open conf \"$file\" [$!]\n";
      }
      $self->fatal("Couldn't open conf \"$file\" [$!]");
    }

    while(<_CONF>){
      push( @args, "$1=$2") if m/^\s*((?:--)?\w+)(?:\s*[=:]\s*|\s+)(\S+)/;
    }

    close(_CONF);

    $self->{server}->{conf_file_args} = \@args;
  }

  $self->process_args( $self->{server}->{conf_file_args}, $template );
}

### User-customizable hook to handle child dying
sub other_child_died_hook {}

### remove a child from the children hash. Not to be called by user.
### if UNIX sockets are in use the socket is removed from the select object.
sub delete_child {
  my $self = shift;
  my $pid  = shift;
  my $prop = $self->{server};

  ### don't remove children that don't belong to me (Christian Mock, Luca Filipozzi)
  if (! exists $prop->{children}->{$pid}) {
      $self->other_child_died_hook($pid);
      return;
  }

  ### prefork server check to clear child communication
  if( $prop->{child_communication} ){
    if ($prop->{children}->{$pid}->{sock}) {
      $prop->{child_select}->remove( $prop->{children}->{$pid}->{sock} );
      $prop->{children}->{$pid}->{sock}->close;
    }
  }

  delete $prop->{children}->{$pid};
}

###----------------------------------------------------------###
sub get_property {
  my $self = shift;
  my $key  = shift;
  $self->{server} = {} unless defined $self->{server};
  return $self->{server}->{$key} if exists $self->{server}->{$key};
  return undef;
}

sub set_property {
  my $self = shift;
  my $key  = shift;
  $self->{server} = {} unless defined $self->{server};
  $self->{server}->{$key}  = shift;
}

###----------------------------------------------------------------###

package Net::Server::TiedHandle;
sub TIEHANDLE { my $pkg = shift; return bless [@_], $pkg }
sub READLINE { my $s = shift; $s->[1] ? $s->[1]->($s->[0], 'getline',  @_) : $s->[0]->getline }
sub SAY      { my $s = shift; $s->[1] ? $s->[1]->($s->[0], 'say',      @_) : $s->[0]->say(@_) }
sub PRINT    { my $s = shift; $s->[1] ? $s->[1]->($s->[0], 'print',    @_) : $s->[0]->print(@_) }
sub PRINTF   { my $s = shift; $s->[1] ? $s->[1]->($s->[0], 'printf',   @_) : $s->[0]->printf(@_) }
sub READ     { my $s = shift; $s->[1] ? $s->[1]->($s->[0], 'read',     @_) : $s->[0]->read(@_) }
sub WRITE    { my $s = shift; $s->[1] ? $s->[1]->($s->[0], 'write',    @_) : $s->[0]->write(@_) }
sub SYSREAD  { my $s = shift; $s->[1] ? $s->[1]->($s->[0], 'sysread',  @_) : $s->[0]->sysread(@_) }
sub SYSWRITE { my $s = shift; $s->[1] ? $s->[1]->($s->[0], 'syswrite', @_) : $s->[0]->syswrite(@_) }

1;

### The documentation is in Net/Server.pod