File Coverage

blib/lib/NNML/Server.pm

Criterion	Covered	Total	%
statement	21	68	30.8
branch	0	14	0.0
condition	0	3	0.0
subroutine	7	8	87.5
pod	0	1	0.0
total	28	94	29.7

#                              -*- Mode: Perl -*-
# Server.pm --
# ITIID           : $ITI$ $Header $__Header$
# Author          : Ulrich Pfeifer
# Created On      : Sat Sep 28 13:53:36 1996
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Tue Apr  1 13:23:28 1997
# Language        : CPerl
# Update Count    : 154
# Status          : Unknown, Use with caution!
#
# (C) Copyright 1996, Universität Dortmund, all rights reserved.
#

package NNML::Server;
use vars qw($VERSION @ISA @EXPORT);
use NNML::Connection;
use NNML::Config qw($Config);
use IO::Socket;
use IO::Select;
use NNML::Handle;
use strict;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(server unspool);

$VERSION = do{my @r=(q$Revision: 1.13 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};

sub server {
  my %opt  = @_;
  my $port = $opt{port} || $Config->port;

  if (exists $opt{base}) {
    $Config->base($opt{base});
  }
  NNML::Auth::_update;          # just for the message
  my $lsn  = new NNML::Handle(Reuse     => 1,
                              Listen    => 5,
                              LocalPort => $port,
                              Proto     => 'tcp');
  die "Could not connect to port $port: $!\n" unless defined $lsn;

  my $SEL  = new IO::Select( $lsn );
  my %CON;
  my $fh;
  my @ready;

  print STDERR "listening on port $port\n";

  while(1) {
    @ready = $SEL->can_read;
  REQUEST:
    foreach $fh (@ready) {
      if($fh == $lsn) {
        my $new = $lsn->accept; # Create a new socket
        $CON{$new} = new NNML::Connection $new, $VERSION;
        $SEL->add($new);
      } else {
        my ($cmd, $func, @args);
        my $fno = fileno($fh);

        $cmd = $fh->getline();
        ($func, @args) = split ' ', $cmd;
        unless (fileno($fh)) {
          # client has closed connection without sending 'quitt'
          printf STDERR "Shuttig down $fh(%d)\n", $fno;
          delete $CON{$fh};
          $SEL->remove($fno);
          next REQUEST;
        }
        $func = lc($func);
        if ($func eq 'shut') {  # shut down the server
          if (NNML::Auth::perm($CON{$fh}, $func)) {
            my $fx;
            print STDERR "Going down\n";
            for $fx (keys %CON) {
              $CON{$fx}->msg(400);
              $CON{$fx}->close;
              delete $CON{$fx};
            }
            $SEL->remove($lsn);
            $lsn->close();
            return;
          } else {
            $CON{$fh}->msg(480);
            next REQUEST;
          }
        } else {
          $func = $CON{$fh}->dispatch($func, @args);
          if ($func eq 'quit') {
            print STDERR "closed\n";
            $SEL->remove($fh);
            $CON{$fh}->close;
            delete $CON{$fh};
          }
        }
      }
    }
  }
}

1;

__END__