1# -*- perl -*- 2# 3# $Id: Daemon.pm,v 1.3 1999/09/26 14:50:12 joe Exp $ 4# 5# Net::Daemon - Base class for implementing TCP/IP daemons 6# 7# Copyright (C) 1998, Jochen Wiedmann 8# Am Eisteich 9 9# 72555 Metzingen 10# Germany 11# 12# Phone: +49 7123 14887 13# Email: joe@ispsoft.de 14# 15# All rights reserved. 16# 17# You may distribute this package under the terms of either the GNU 18# General Public License or the Artistic License, as specified in the 19# Perl README file. 20# 21############################################################################ 22 23require 5.004; 24use strict; 25 26use Getopt::Long (); 27use Symbol (); 28use IO::Socket (); 29use Config (); 30use Net::Daemon::Log (); 31use POSIX (); 32 33 34package Net::Daemon; 35 36$Net::Daemon::VERSION = '0.48'; 37 38# Dummy share() in case we're >= 5.10. If we are, require/import of 39# threads::shared will replace it appropriately. 40my $this_is_510 = $^V ge v5.10.0; 41if ($this_is_510) { 42 eval { require threads; }; 43 eval { require threads::shared; }; 44} 45 46 47@Net::Daemon::ISA = qw(Net::Daemon::Log); 48 49# 50# Regexps aren't thread safe, as of 5.00502 :-( (See the test script 51# regexp-threads.) 52# 53$Net::Daemon::RegExpLock = 1; 54threads::shared::share(\$Net::Daemon::RegExpLock) if $this_is_510; 55 56use vars qw($exit); 57 58############################################################################ 59# 60# Name: Options (Class method) 61# 62# Purpose: Returns a hash ref of command line options 63# 64# Inputs: $class - This class 65# 66# Result: Options array; any option is represented by a hash ref; 67# used keys are 'template', a string suitable for describing 68# the option to Getopt::Long::GetOptions and 'description', 69# a string for the Usage message 70# 71############################################################################ 72 73sub Options ($) { 74 { 'catchint' => { 'template' => 'catchint!', 75 'description' => '--nocatchint ' 76 . "Try to catch interrupts when calling system\n" 77 . ' ' 78 . 'functions like bind(), recv()), ...' 79 }, 80 'childs' => { 'template' => 'childs=i', 81 'description' => '--childs <num> ' 82 . 'Set number of preforked childs, implies mode=single.' }, 83 'chroot' => { 'template' => 'chroot=s', 84 'description' => '--chroot <dir> ' 85 . 'Change rootdir to given after binding to port.' }, 86 'configfile' => { 'template' => 'configfile=s', 87 'description' => '--configfile <file> ' 88 . 'Read options from config file <file>.' }, 89 'debug' => { 'template' => 'debug', 90 'description' => '--debug ' 91 . 'Turn debugging mode on'}, 92 'facility' => { 'template' => 'facility=s', 93 'description' => '--facility <facility> ' 94 . 'Syslog facility; defaults to \'daemon\'' }, 95 'group' => { 'template' => 'group=s', 96 'description' => '--group <gid> ' 97 . 'Change gid to given group after binding to port.' }, 98 'help' => { 'template' => 'help', 99 'description' => '--help ' 100 . 'Print this help message' }, 101 'localaddr' => { 'template' => 'localaddr=s', 102 'description' => '--localaddr <ip> ' 103 . 'IP number to bind to; defaults to INADDR_ANY' }, 104 'localpath' => { 'template' => 'localpath=s', 105 'description' => '--localpath <path> ' 106 . 'UNIX socket domain path to bind to' }, 107 'localport' => { 'template' => 'localport=s', 108 'description' => '--localport <port> ' 109 . 'Port number to bind to' }, 110 'logfile' => { 'template' => 'logfile=s', 111 'description' => '--logfile <file> ' 112 . 'Force logging to <file>' }, 113 'loop-child' => { 'template' => 'loop-child', 114 'description' => '--loop-child ' 115 . 'Create a child process for loops' }, 116 'loop-timeout' => { 'template' => 'loop-timeout=f', 117 'description' => '--loop-timeout <secs> ' 118 . 'Looping mode, <secs> seconds per loop' }, 119 'mode' => { 'template' => 'mode=s', 120 'description' => '--mode <mode> ' 121 . 'Operation mode (threads, fork or single)' }, 122 'pidfile' => { 'template' => 'pidfile=s', 123 'description' => '--pidfile <file> ' 124 . 'Use <file> as PID file' }, 125 'proto' => { 'template' => 'proto=s', 126 'description' => '--proto <protocol> ' 127 . 'transport layer protocol: tcp (default) or unix' }, 128 'user' => { 'template' => 'user=s', 129 'description' => '--user <user> ' 130 . 'Change uid to given user after binding to port.' }, 131 'version' => { 'template' => 'version', 132 'description' => '--version ' 133 . 'Print version number and exit' } } 134} 135 136 137############################################################################ 138# 139# Name: Version (Class method) 140# 141# Purpose: Returns version string 142# 143# Inputs: $class - This class 144# 145# Result: Version string; suitable for printed by "--version" 146# 147############################################################################ 148 149sub Version ($) { 150 "Net::Daemon server, Copyright (C) 1998, Jochen Wiedmann"; 151} 152 153 154############################################################################ 155# 156# Name: Usage (Class method) 157# 158# Purpose: Prints usage message 159# 160# Inputs: $class - This class 161# 162# Result: Nothing; aborts with error status 163# 164############################################################################ 165 166sub Usage ($) { 167 my($class) = shift; 168 my($options) = $class->Options(); 169 my(@options) = sort (keys %$options); 170 171 print STDERR "Usage: $0 <options>\n\nPossible options are:\n\n"; 172 my($key); 173 foreach $key (sort (keys %$options)) { 174 my($o) = $options->{$key}; 175 print STDERR " ", $o->{'description'}, "\n" if $o->{'description'}; 176 } 177 print STDERR "\n", $class->Version(), "\n"; 178 exit(1); 179} 180 181 182 183############################################################################ 184# 185# Name: ReadConfigFile (Instance method) 186# 187# Purpose: Reads the config file. 188# 189# Inputs: $self - Instance 190# $file - config file name 191# $options - Hash of command line options; these are not 192# really for being processed by this method. We pass 193# it just in case. The new() method will process them 194# at a later time. 195# $args - Array ref of other command line options. 196# 197############################################################################ 198 199sub ReadConfigFile { 200 my($self, $file, $options, $args) = @_; 201 if (! -f $file) { 202 $self->Fatal("No such config file: $file"); 203 } 204 my $copts = do $file; 205 if ($@) { 206 $self->Fatal("Error while processing config file $file: $@"); 207 } 208 if (!$copts || ref($copts) ne 'HASH') { 209 $self->Fatal("Config file $file did not return a hash ref."); 210 } 211 # Override current configuration with config file options. 212 while (my($var, $val) = each %$copts) { 213 $self->{$var} = $val; 214 } 215} 216 217 218############################################################################ 219# 220# Name: new (Class method) 221# 222# Purpose: Constructor 223# 224# Inputs: $class - This class 225# $attr - Hash ref of attributes 226# $args - Array ref of command line arguments 227# 228# Result: Server object for success, error message otherwise 229# 230############################################################################ 231 232sub new ($$;$) { 233 my($class, $attr, $args) = @_; 234 my($self) = $attr ? \%$attr : {}; 235 bless($self, (ref($class) || $class)); 236 237 my $options = ($self->{'options'} ||= {}); 238 $self->{'args'} ||= []; 239 if ($args) { 240 my @optList = map { $_->{'template'} } values(%{$class->Options()}); 241 242 local @ARGV = @$args; 243 if (!Getopt::Long::GetOptions($options, @optList)) { 244 $self->Usage(); 245 } 246 @{$self->{'args'}} = @ARGV; 247 248 if ($options->{'help'}) { 249 $self->Usage(); 250 } 251 if ($options->{'version'}) { 252 print STDERR $self->Version(), "\n"; 253 exit 1; 254 } 255 } 256 257 my $file = $options->{'configfile'} || $self->{'configfile'}; 258 if ($file) { 259 $self->ReadConfigFile($file, $options, $args); 260 } 261 while (my($var, $val) = each %$options) { 262 $self->{$var} = $val; 263 } 264 265 if ($self->{'childs'}) { 266 $self->{'mode'} = 'single'; 267 } elsif (!defined($self->{'mode'})) { 268 if (eval { require threads }) { 269 $self->{'mode'} = 'ithreads'; 270 } elsif (eval { require Thread }) { 271 $self->{'mode'} = 'threads'; 272 } else { 273 my $fork = 0; 274 if ($^O ne "MSWin32") { 275 my $pid = eval { fork() }; 276 if (defined($pid)) { 277 if (!$pid) { exit; } # Child 278 $fork = 1; 279 wait; 280 } 281 } 282 if ($fork) { 283 $self->{'mode'} = 'fork'; 284 } else { 285 $self->{'mode'} = 'single'; 286 } 287 } 288 } 289 290 if ($self->{'mode'} eq 'ithreads') { 291 no warnings 'redefine'; 292 require threads; 293 use warnings 'redefine'; 294 } elsif ($self->{'mode'} eq 'threads') { 295 require Thread; 296 } elsif ($self->{'mode'} eq 'fork') { 297 # Initialize forking mode ... 298 } elsif ($self->{'mode'} eq 'single') { 299 # Initialize single mode ... 300 } else { 301 $self->Fatal("Unknown operation mode: $self->{'mode'}"); 302 } 303 $self->{'catchint'} = 1 unless exists($self->{'catchint'}); 304 $self->Debug("Server starting in operation mode $self->{'mode'}"); 305 if ($self->{'childs'}) { 306 $self->Debug("Preforking $self->{'childs'} child processes ..."); 307 } 308 309 $self; 310} 311 312sub Clone ($$) { 313 my($proto, $client) = @_; 314 my $self = { %$proto }; 315 $self->{'socket'} = $client; 316 $self->{'parent'} = $proto; 317 bless($self, ref($proto)); 318 $self; 319} 320 321 322############################################################################ 323# 324# Name: Accept (Instance method) 325# 326# Purpose: Called for authentication purposes 327# 328# Inputs: $self - Server instance 329# 330# Result: TRUE, if the client has successfully authorized, FALSE 331# otherwise. 332# 333############################################################################ 334 335sub Accept ($) { 336 my $self = shift; 337 my $socket = $self->{'socket'}; 338 my $clients = $self->{'clients'}; 339 my $from = $self->{'proto'} eq 'unix' ? 340 "Unix socket" : sprintf("%s, port %s", 341 $socket->peerhost(), $socket->peerport()); 342 343 # Host based authorization 344 if ($self->{'clients'}) { 345 my ($name, $aliases, $addrtype, $length, @addrs); 346 if ($self->{'proto'} eq 'unix') { 347 ($name, $aliases, $addrtype, $length, @addrs) = 348 ('localhost', '', Socket::AF_INET(), 349 length(Socket::IN_ADDR_ANY()), 350 Socket::inet_aton('127.0.0.1')); 351 } else { 352 ($name, $aliases, $addrtype, $length, @addrs) = 353 gethostbyaddr($socket->peeraddr(), Socket::AF_INET()); 354 } 355 my @patterns = @addrs ? 356 map { Socket::inet_ntoa($_) } @addrs : 357 $socket->peerhost(); 358 push(@patterns, $name) if ($name); 359 push(@patterns, split(/ /, $aliases)) if $aliases; 360 361 my $found; 362 OUTER: foreach my $client (@$clients) { 363 if (!$client->{'mask'}) { 364 $found = $client; 365 last; 366 } 367 my $masks = ref($client->{'mask'}) ? 368 $client->{'mask'} : [ $client->{'mask'} ]; 369 370 # 371 # Regular expressions aren't thread safe, as of 372 # 5.00502 :-( 373 # 374 my $lock; 375 $lock = lock($Net::Daemon::RegExpLock) 376 if ($self->{'mode'} eq 'threads'); 377 foreach my $mask (@$masks) { 378 foreach my $alias (@patterns) { 379 if ($alias =~ /$mask/) { 380 $found = $client; 381 last OUTER; 382 } 383 } 384 } 385 } 386 387 if (!$found || !$found->{'accept'}) { 388 $self->Error("Access not permitted from $from"); 389 return 0; 390 } 391 $self->{'client'} = $found; 392 } 393 394 $self->Debug("Accepting client from $from"); 395 1; 396} 397 398 399############################################################################ 400# 401# Name: Run (Instance method) 402# 403# Purpose: Does the real work 404# 405# Inputs: $self - Server instance 406# 407# Result: Nothing; returning will make the connection to be closed 408# 409############################################################################ 410 411sub Run ($) { 412} 413 414 415############################################################################ 416# 417# Name: Done (Instance method) 418# 419# Purpose: Called by the server before doing an accept(); a TRUE 420# value makes the server terminate. 421# 422# Inputs: $self - Server instance 423# 424# Result: TRUE or FALSE 425# 426# Bugs: Doesn't work in forking mode. 427# 428############################################################################ 429 430sub Done ($;$) { 431 my $self = shift; 432 $self->{'done'} = shift if @_; 433 $self->{'done'} 434} 435 436 437############################################################################ 438# 439# Name: Loop (Instance method) 440# 441# Purpose: If $self->{'loop-timeout'} option is set, then this method 442# will be called every "loop-timeout" seconds. 443# 444# Inputs: $self - Server instance 445# 446# Result: Nothing; aborts in case of trouble. Note, that this is *not* 447# trapped and forces the server to exit. 448# 449############################################################################ 450 451sub Loop { 452} 453 454 455############################################################################ 456# 457# Name: ChildFunc (Instance method) 458# 459# Purpose: If possible, spawn a child process which calls a given 460# method. In server mode single the method is called 461# directly. 462# 463# Inputs: $self - Instance 464# $method - Method name 465# @args - Method arguments 466# 467# Returns: Nothing; aborts in case of problems. 468# 469############################################################################ 470 471sub ChildFunc { 472 my($self, $method, @args) = @_; 473 if ($self->{'mode'} eq 'single') { 474 $self->$method(@args); 475 } elsif ($self->{'mode'} eq 'threads') { 476 my $startfunc = sub { 477 my $self = shift; 478 my $method = shift; 479 $self->$method(@_) 480 }; 481 Thread->new($startfunc, $self, $method, @args) 482 or die "Failed to create a new thread: $!"; 483 } elsif ($self->{'mode'} eq 'ithreads') { 484 my $startfunc = sub { 485 my $self = shift; 486 my $method = shift; 487 $self->$method(@_) 488 }; 489 threads->new($startfunc, $self, $method, @args) 490 or die "Failed to create a new thread: $!"; 491 } else { 492 my $pid = fork(); 493 die "Cannot fork: $!" unless defined $pid; 494 return if $pid; # Parent 495 $self->$method(@args); # Child 496 exit(0); 497 } 498} 499 500 501############################################################################ 502# 503# Name: Bind (Instance method) 504# 505# Purpose: Binds to a port; if successfull, it never returns. Instead 506# it accepts connections. For any connection a new thread is 507# created and the Accept method is executed. 508# 509# Inputs: $self - Server instance 510# 511# Result: Error message in case of failure 512# 513############################################################################ 514 515sub HandleChild { 516 my $self = shift; 517 $self->Debug("New child starting ($self)."); 518 eval { 519 if (!$self->Accept()) { 520 $self->Error('Refusing client'); 521 } else { 522 $self->Debug('Accepting client'); 523 $self->Run(); 524 } 525 }; 526 $self->Error("Child died: $@") if $@; 527 $self->Debug("Child terminating."); 528 $self->Close(); 529}; 530 531sub SigChildHandler { 532 my $self = shift; my $ref = shift; 533 return 'IGNORE' if $self->{'mode'} eq 'fork' || $self->{'childs'}; 534 return undef; # Don't care for childs. 535} 536 537sub Bind ($) { 538 my $self = shift; 539 my $fh; 540 my $child_pid; 541 542 my $reaper = $self->SigChildHandler(\$child_pid); 543 $SIG{'CHLD'} = $reaper if $reaper; 544 545 if (!$self->{'socket'}) { 546 $self->{'proto'} ||= ($self->{'localpath'}) ? 'unix' : 'tcp'; 547 548 if ($self->{'proto'} eq 'unix') { 549 my $path = $self->{'localpath'} 550 or $self->Fatal('Missing option: localpath'); 551 unlink $path; 552 $self->Fatal("Can't remove stale Unix socket ($path): $!") 553 if -e $path; 554 my $old_umask = umask 0; 555 $self->{'socket'} = 556 IO::Socket::UNIX->new('Local' => $path, 557 'Listen' => $self->{'listen'} || 10) 558 or $self->Fatal("Cannot create Unix socket $path: $!"); 559 umask $old_umask; 560 } else { 561 $self->{'socket'} = IO::Socket::INET->new 562 ( 'LocalAddr' => $self->{'localaddr'}, 563 'LocalPort' => $self->{'localport'}, 564 'Proto' => $self->{'proto'} || 'tcp', 565 'Listen' => $self->{'listen'} || 10, 566 'Reuse' => 1) 567 or $self->Fatal("Cannot create socket: $!"); 568 } 569 } 570 $self->Log('notice', "Server starting"); 571 572 if ((my $pidfile = ($self->{'pidfile'} || '')) ne 'none') { 573 $self->Debug("Writing PID to $pidfile"); 574 my $fh = Symbol::gensym(); 575 $self->Fatal("Cannot write to $pidfile: $!") 576 unless (open (OUT, ">$pidfile") 577 and (print OUT "$$\n") 578 and close(OUT)); 579 } 580 581 if (my $dir = $self->{'chroot'}) { 582 $self->Debug("Changing root directory to $dir"); 583 if (!chroot($dir)) { 584 $self->Fatal("Cannot change root directory to $dir: $!"); 585 } 586 } 587 if (my $group = $self->{'group'}) { 588 $self->Debug("Changing GID to $group"); 589 my $gid; 590 if ($group !~ /^\d+$/) { 591 if (defined(my $gid = getgrnam($group))) { 592 $group = $gid; 593 } else { 594 $self->Fatal("Cannot determine gid of $group: $!"); 595 } 596 } 597 $( = ($) = $group); 598 } 599 if (my $user = $self->{'user'}) { 600 $self->Debug("Changing UID to $user"); 601 my $uid; 602 if ($user !~ /^\d+$/) { 603 if (defined(my $uid = getpwnam($user))) { 604 $user = $uid; 605 } else { 606 $self->Fatal("Cannot determine uid of $user: $!"); 607 } 608 } 609 $< = ($> = $user); 610 } 611 612 if ($self->{'childs'}) { 613 my $pid; 614 615 my $childpids = $self->{'childpids'} = {}; 616 for (my $n = 0; $n < $self->{'childs'}; $n++) { 617 $pid = fork(); 618 die "Cannot fork: $!" unless defined $pid; 619 if (!$pid) { #Child 620 $self->{'mode'} = 'single'; 621 last; 622 } 623 # Parent 624 $childpids->{$pid} = 1; 625 } 626 if ($pid) { 627 # Parent waits for childs in a loop, then exits ... 628 # We could also terminate the parent process, but 629 # if the parent is still running we can kill the 630 # whole group by killing the childs. 631 my $childpid; 632 $exit = 0; 633 $SIG{'TERM'} = sub { die }; 634 $SIG{'INT'} = sub { die }; 635 eval { 636 do { 637 $childpid = wait; 638 delete $childpids->{$childpid}; 639 $self->Debug("Child $childpid has exited"); 640 } until ($childpid <= 0 || $exit || keys(%$childpids) == 0); 641 }; 642 my @pids = keys %{$self -> {'childpids'}}; 643 if (@pids) { 644 $self->Debug("kill TERM childs: " . join(",", @pids)); 645 kill 'TERM', @pids if @pids ; # send a TERM to all childs 646 } 647 exit (0); 648 } 649 } 650 651 my $time = $self->{'loop-timeout'} ? 652 (time() + $self->{'loop-timeout'}) : 0; 653 654 my $client; 655 while (!$self->Done()) { 656 undef $child_pid; 657 my $rin = ''; 658 vec($rin,$self->{'socket'}->fileno(),1) = 1; 659 my($rout, $t); 660 if ($time) { 661 my $tm = time(); 662 $t = $time - $tm; 663 $t = 0 if $t < 0; 664 $self->Debug("Loop time: time=$time now=$tm, t=$t"); 665 } 666 my($nfound) = select($rout=$rin, undef, undef, $t); 667 if ($nfound < 0) { 668 if (!$child_pid and 669 ($! != POSIX::EINTR() or !$self->{'catchint'})) { 670 $self->Fatal("%s server failed to select(): %s", 671 ref($self), $self->{'socket'}->error() || $!); 672 } 673 } elsif ($nfound) { 674 my $client = $self->{'socket'}->accept(); 675 if (!$client) { 676 if (!$child_pid and 677 ($! != POSIX::EINTR() or !$self->{'catchint'})) { 678 $self->Error("%s server failed to accept: %s", 679 ref($self), $self->{'socket'}->error() || $!); 680 } 681 } else { 682 if ($self->{'debug'}) { 683 my $from = $self->{'proto'} eq 'unix' ? 684 'Unix socket' : 685 sprintf('%s, port %s', 686 # SE 19990917: display client data!! 687 $client->peerhost(), 688 $client->peerport()); 689 $self->Debug("Connection from $from"); 690 } 691 my $sth = $self->Clone($client); 692 $self->Debug("Child clone: $sth\n"); 693 $sth->ChildFunc('HandleChild') if $sth; 694 if ($self->{'mode'} eq 'fork') { 695 $self->ServClose($client); 696 } 697 } 698 } 699 if ($time) { 700 my $t = time(); 701 if ($t >= $time) { 702 $time = $t; 703 if ($self->{'loop-child'}) { 704 $self->ChildFunc('Loop'); 705 } else { 706 $self->Loop(); 707 } 708 $time += $self->{'loop-timeout'}; 709 } 710 } 711 } 712 $self->Log('notice', "%s server terminating", ref($self)); 713} 714 715sub Close { 716 my $socket = shift->{'socket'}; 717 $socket->close() if $socket; 718} 719 720sub ServClose { 721 my $self = shift; 722 my $socket = shift; 723 $socket->close() if $socket; 724} 725 726 7271; 728 729__END__ 730 731=head1 NAME 732 733Net::Daemon - Perl extension for portable daemons 734 735 736=head1 SYNOPSIS 737 738 # Create a subclass of Net::Daemon 739 require Net::Daemon; 740 package MyDaemon; 741 @MyDaemon::ISA = qw(Net::Daemon); 742 743 sub Run ($) { 744 # This function does the real work; it is invoked whenever a 745 # new connection is made. 746 } 747 748 749=head1 DESCRIPTION 750 751Net::Daemon is an abstract base class for implementing portable server 752applications in a very simple way. The module is designed for Perl 5.005 753and threads, but can work with fork() and Perl 5.004. 754 755The Net::Daemon class offers methods for the most common tasks a daemon 756needs: Starting up, logging, accepting clients, authorization, restricting 757its own environment for security and doing the true work. You only have to 758override those methods that aren't appropriate for you, but typically 759inheriting will safe you a lot of work anyways. 760 761 762=head2 Constructors 763 764 $server = Net::Daemon->new($attr, $options); 765 766 $connection = $server->Clone($socket); 767 768Two constructors are available: The B<new> method is called upon startup 769and creates an object that will basically act as an anchor over the 770complete program. It supports command line parsing via L<Getopt::Long (3)>. 771 772Arguments of B<new> are I<$attr>, an hash ref of attributes (see below) 773and I<$options> an array ref of options, typically command line arguments 774(for example B<\@ARGV>) that will be passed to B<Getopt::Long::GetOptions>. 775 776The second constructor is B<Clone>: It is called whenever a client 777connects. It receives the main server object as input and returns a 778new object. This new object will be passed to the methods that finally 779do the true work of communicating with the client. Communication occurs 780over the socket B<$socket>, B<Clone>'s argument. 781 782Possible object attributes and the corresponding command line 783arguments are: 784 785=over 4 786 787=item I<catchint> (B<--nocatchint>) 788 789On some systems, in particular Solaris, the functions accept(), 790read() and so on are not safe against interrupts by signals. For 791example, if the user raises a USR1 signal (as typically used to 792reread config files), then the function returns an error EINTR. 793If the I<catchint> option is on (by default it is, use 794B<--nocatchint> to turn this off), then the package will ignore 795EINTR errors whereever possible. 796 797=item I<chroot> (B<--chroot=dir>) 798 799(UNIX only) After doing a bind(), change root directory to the given 800directory by doing a chroot(). This is usefull for security operations, 801but it restricts programming a lot. For example, you typically have to 802load external Perl extensions before doing a chroot(), or you need to 803create hard links to Unix sockets. This is typically done in the config 804file, see the --configfile option. See also the --group and --user 805options. 806 807If you don't know chroot(), think of an FTP server where you can see a 808certain directory tree only after logging in. 809 810=item I<clients> 811 812An array ref with a list of clients. Clients are hash refs, the attributes 813I<accept> (0 for denying access and 1 for permitting) and I<mask>, a Perl 814regular expression for the clients IP number or its host name. See 815L<"Access control"> below. 816 817=item I<configfile> (B<--configfile=file>) 818 819Net::Daemon supports the use of config files. These files are assumed 820to contain a single hash ref that overrides the arguments of the new 821method. However, command line arguments in turn take precedence over 822the config file. See the L<"Config File"> section below for details 823on the config file. 824 825=item I<debug> (B<--debug>) 826 827Turn debugging mode on. Mainly this asserts that logging messages of 828level "debug" are created. 829 830=item I<facility> (B<--facility=mode>) 831 832(UNIX only) Facility to use for L<Sys::Syslog (3)>. The default is 833B<daemon>. 834 835=item I<group> (B<--group=gid>) 836 837After doing a bind(), change the real and effective GID to the given. 838This is usefull, if you want your server to bind to a privileged port 839(<1024), but don't want the server to execute as root. See also 840the --user option. 841 842GID's can be passed as group names or numeric values. 843 844=item I<localaddr> (B<--localaddr=ip>) 845 846By default a daemon is listening to any IP number that a machine 847has. This attribute allows to restrict the server to the given 848IP number. 849 850=item I<localpath> (B<--localpath=path>) 851 852If you want to restrict your server to local services only, you'll 853prefer using Unix sockets, if available. In that case you can use 854this option for setting the path of the Unix socket being created. 855This option implies B<--proto=unix>. 856 857=item I<localport> (B<--localport=port>) 858 859This attribute sets the port on which the daemon is listening. It 860must be given somehow, as there's no default. 861 862=item I<logfile> (B<--logfile=file>) 863 864By default logging messages will be written to the syslog (Unix) or 865to the event log (Windows NT). On other operating systems you need to 866specify a log file. The special value "STDERR" forces logging to 867stderr. 868 869=item I<loop-child> (B<--loop-child>) 870 871This option forces creation of a new child for loops. (See the 872I<loop-timeout> option.) By default the loops are serialized. 873 874=item I<loop-timeout> (B<--loop-timeout=secs>) 875 876Some servers need to take an action from time to time. For example the 877Net::Daemon::Spooler attempts to empty its spooling queue every 5 878minutes. If this option is set to a positive value (zero being the 879default), then the server will call its Loop method every "loop-timeout" 880seconds. 881 882Don't trust too much on the precision of the interval: It depends on 883a number of factors, in particular the execution time of the Loop() 884method. The loop is implemented by using the I<select> function. If 885you need an exact interval, you should better try to use the alarm() 886function and a signal handler. (And don't forget to look at the 887I<catchint> option!) 888 889It is recommended to use the I<loop-child> option in conjunction with 890I<loop-timeout>. 891 892=item I<mode> (B<--mode=modename>) 893 894The Net::Daemon server can run in three different modes, depending on 895the environment. 896 897If you are running Perl 5.005 and did compile it for threads, then 898the server will create a new thread for each connection. The thread 899will execute the server's Run() method and then terminate. This mode 900is the default, you can force it with "--mode=ithreads" or 901"--mode=threads". 902 903If threads are not available, but you have a working fork(), then the 904server will behave similar by creating a new process for each connection. 905This mode will be used automatically in the absence of threads or if 906you use the "--mode=fork" option. 907 908Finally there's a single-connection mode: If the server has accepted a 909connection, he will enter the Run() method. No other connections are 910accepted until the Run() method returns. This operation mode is useful 911if you have neither threads nor fork(), for example on the Macintosh. 912For debugging purposes you can force this mode with "--mode=single". 913 914When running in mode single, you can still handle multiple clients at 915a time by preforking multiple child processes. The number of childs 916is configured with the option "--childs". 917 918=item I<childs> 919 920Use this parameter to let Net::Daemon run in prefork mode, which means 921it forks the number of childs processes you give with this parameter, 922and all child handle connections concurrently. The difference to 923fork mode is, that the child processes continue to run after a 924connection has terminated and are able to accept a new connection. 925This is useful for caching inside the childs process (e.g. 926DBI::ProxyServer connect_cached attribute) 927 928=item I<options> 929 930Array ref of Command line options that have been passed to the server object 931via the B<new> method. 932 933=item I<parent> 934 935When creating an object with B<Clone> the original object becomes 936the parent of the new object. Objects created with B<new> usually 937don't have a parent, thus this attribute is not set. 938 939=item I<pidfile> (B<--pidfile=file>) 940 941(UNIX only) If this option is present, a PID file will be created at the 942given location. 943 944=item I<proto> (B<--proto=proto>) 945 946The transport layer to use, by default I<tcp> or I<unix> for a Unix 947socket. It is not yet possible to combine both. 948 949=item I<socket> 950 951The socket that is connected to the client; passed as B<$client> argument 952to the B<Clone> method. If the server object was created with B<new>, 953this attribute can be undef, as long as the B<Bind> method isn't called. 954Sockets are assumed to be IO::Socket objects. 955 956=item I<user> (B<--user=uid>) 957 958After doing a bind(), change the real and effective UID to the given. 959This is usefull, if you want your server to bind to a privileged port 960(<1024), but don't want the server to execute as root. See also 961the --group and the --chroot options. 962 963UID's can be passed as group names or numeric values. 964 965=item I<version> (B<--version>) 966 967Supresses startup of the server; instead the version string will 968be printed and the program exits immediately. 969 970=back 971 972Note that most of these attributes (facility, mode, localaddr, localport, 973pidfile, version) are meaningfull only at startup. If you set them later, 974they will be simply ignored. As almost all attributes have appropriate 975defaults, you will typically use the B<localport> attribute only. 976 977 978=head2 Command Line Parsing 979 980 my $optionsAvailable = Net::Daemon->Options(); 981 982 print Net::Daemon->Version(), "\n"; 983 984 Net::Daemon->Usage(); 985 986The B<Options> method returns a hash ref of possible command line options. 987The keys are option names, the values are again hash refs with the 988following keys: 989 990=over 4 991 992=item template 993 994An option template that can be passed to B<Getopt::Long::GetOptions>. 995 996=item description 997 998A description of this option, as used in B<Usage> 999 1000=back 1001 1002The B<Usage> method prints a list of all possible options and returns. 1003It uses the B<Version> method for printing program name and version. 1004 1005 1006=head2 Config File 1007 1008If the config file option is set in the command line options or in the 1009in the "new" args, then the method 1010 1011 $server->ReadConfigFile($file, $options, $args) 1012 1013is invoked. By default the config file is expected to contain Perl source 1014that returns a hash ref of options. These options override the "new" 1015args and will in turn be overwritten by the command line options, as 1016present in the $options hash ref. 1017 1018A typical config file might look as follows, we use the DBI::ProxyServer 1019as an example: 1020 1021 # Load external modules; this is not required unless you use 1022 # the chroot() option. 1023 #require DBD::mysql; 1024 #require DBD::CSV; 1025 1026 { 1027 # 'chroot' => '/var/dbiproxy', 1028 'facility' => 'daemon', 1029 'pidfile' => '/var/dbiproxy/dbiproxy.pid', 1030 'user' => 'nobody', 1031 'group' => 'nobody', 1032 'localport' => '1003', 1033 'mode' => 'fork' 1034 1035 # Access control 1036 'clients' => [ 1037 # Accept the local 1038 { 1039 'mask' => '^192\.168\.1\.\d+$', 1040 'accept' => 1 1041 }, 1042 # Accept myhost.company.com 1043 { 1044 'mask' => '^myhost\.company\.com$', 1045 'accept' => 1 1046 } 1047 # Deny everything else 1048 { 1049 'mask' => '.*', 1050 'accept' => 0 1051 } 1052 ] 1053 } 1054 1055 1056=head2 Access control 1057 1058The Net::Daemon package supports a host based access control scheme. By 1059default access is open for anyone. However, if you create an attribute 1060$self->{'clients'}, typically in the config file, then access control 1061is disabled by default. For any connection the client list is processed: 1062The clients attribute is an array ref to a list of hash refs. Any of the 1063hash refs may contain arbitrary attributes, including the following: 1064 1065=over 8 1066 1067=item mask 1068 1069A Perl regular expression that has to match the clients IP number or 1070its host name. The list is processed from the left to the right, whenever 1071a 'mask' attribute matches, then the related hash ref is choosen as 1072client and processing the client list stops. 1073 1074=item accept 1075 1076This may be set to true or false (default when omitting the attribute), 1077the former means accepting the client. 1078 1079=back 1080 1081 1082=head2 Event logging 1083 1084 $server->Log($level, $format, @args); 1085 $server->Debug($format, @args); 1086 $server->Error($format, @args); 1087 $server->Fatal($format, @args); 1088 1089The B<Log> method is an interface to L<Sys::Syslog (3)> or 1090L<Win32::EventLog (3)>. It's arguments are I<$level>, a syslog 1091level like B<debug>, B<notice> or B<err>, a format string in the 1092style of printf and the format strings arguments. 1093 1094The B<Debug> and B<Error> methods are shorthands for calling 1095B<Log> with a level of debug and err, respectively. The B<Fatal> 1096method is like B<Error>, except it additionally throws the given 1097message as exception. 1098 1099See L<Net::Daemon::Log(3)> for details. 1100 1101 1102=head2 Flow of control 1103 1104 $server->Bind(); 1105 # The following inside Bind(): 1106 if ($connection->Accept()) { 1107 $connection->Run(); 1108 } else { 1109 $connection->Log('err', 'Connection refused'); 1110 } 1111 1112The B<Bind> method is called by the application when the server should 1113start. Typically this can be done right after creating the server object 1114B<$server>. B<Bind> usually never returns, except in case of errors. 1115 1116When a client connects, the server uses B<Clone> to derive a connection 1117object B<$connection> from the server object. A new thread or process 1118is created that uses the connection object to call your classes 1119B<Accept> method. This method is intended for host authorization and 1120should return either FALSE (refuse the client) or TRUE (accept the client). 1121 1122If the client is accepted, the B<Run> method is called which does the 1123true work. The connection is closed when B<Run> returns and the corresponding 1124thread or process exits. 1125 1126 1127=head2 Error Handling 1128 1129All methods are supposed to throw Perl exceptions in case of errors. 1130 1131 1132=head1 MULTITHREADING CONSIDERATIONS 1133 1134All methods are working with lexically scoped data and handle data 1135only, the exception being the OpenLog method which is invoked before 1136threading starts. Thus you are safe as long as you don't share 1137handles between threads. I strongly recommend that your application 1138behaves similar. (This doesn't apply to mode 'ithreads'.) 1139 1140 1141 1142=head1 EXAMPLE 1143 1144As an example we'll write a simple calculator server. After connecting 1145to this server you may type expressions, one per line. The server 1146evaluates the expressions and prints the result. (Note this is an example, 1147in real life we'd never implement such a security hole. :-) 1148 1149For the purpose of example we add a command line option I<--base> that 1150takes 'hex', 'oct' or 'dec' as values: The servers output will use the 1151given base. 1152 1153 # -*- perl -*- 1154 # 1155 # Calculator server 1156 # 1157 require 5.004; 1158 use strict; 1159 1160 require Net::Daemon; 1161 1162 1163 package Calculator; 1164 1165 use vars qw($VERSION @ISA); 1166 $VERSION = '0.01'; 1167 @ISA = qw(Net::Daemon); # to inherit from Net::Daemon 1168 1169 sub Version ($) { 'Calculator Example Server, 0.01'; } 1170 1171 # Add a command line option "--base" 1172 sub Options ($) { 1173 my($self) = @_; 1174 my($options) = $self->SUPER::Options(); 1175 $options->{'base'} = { 'template' => 'base=s', 1176 'description' => '--base ' 1177 . 'dec (default), hex or oct' 1178 }; 1179 $options; 1180 } 1181 1182 # Treat command line option in the constructor 1183 sub new ($$;$) { 1184 my($class, $attr, $args) = @_; 1185 my($self) = $class->SUPER::new($attr, $args); 1186 if ($self->{'parent'}) { 1187 # Called via Clone() 1188 $self->{'base'} = $self->{'parent'}->{'base'}; 1189 } else { 1190 # Initial call 1191 if ($self->{'options'} && $self->{'options'}->{'base'}) { 1192 $self->{'base'} = $self->{'options'}->{'base'} 1193 } 1194 } 1195 if (!$self->{'base'}) { 1196 $self->{'base'} = 'dec'; 1197 } 1198 $self; 1199 } 1200 1201 sub Run ($) { 1202 my($self) = @_; 1203 my($line, $sock); 1204 $sock = $self->{'socket'}; 1205 while (1) { 1206 if (!defined($line = $sock->getline())) { 1207 if ($sock->error()) { 1208 $self->Error("Client connection error %s", 1209 $sock->error()); 1210 } 1211 $sock->close(); 1212 return; 1213 } 1214 $line =~ s/\s+$//; # Remove CRLF 1215 my($result) = eval $line; 1216 my($rc); 1217 if ($self->{'base'} eq 'hex') { 1218 $rc = printf $sock ("%x\n", $result); 1219 } elsif ($self->{'base'} eq 'oct') { 1220 $rc = printf $sock ("%o\n", $result); 1221 } else { 1222 $rc = printf $sock ("%d\n", $result); 1223 } 1224 if (!$rc) { 1225 $self->Error("Client connection error %s", 1226 $sock->error()); 1227 $sock->close(); 1228 return; 1229 } 1230 } 1231 } 1232 1233 package main; 1234 1235 my $server = Calculator->new({'pidfile' => 'none', 1236 'localport' => 2000}, \@ARGV); 1237 $server->Bind(); 1238 1239 1240=head1 KNOWN PROBLEMS 1241 1242Most, or even any, known problems are related to the Sys::Syslog module 1243which is by default used for logging events under Unix. I'll quote some 1244examples: 1245 1246=over 1247 1248=item Usage: Sys::Syslog::_PATH_LOG at ... 1249 1250This problem is treated in perl bug 20000712.003. A workaround is 1251changing line 277 of Syslog.pm to 1252 1253 my $syslog = &_PATH_LOG() || croak "_PATH_LOG not found in syslog.ph"; 1254 1255=back 1256 1257 1258=head1 AUTHOR AND COPYRIGHT 1259 1260 Net::Daemon is Copyright (C) 1998, Jochen Wiedmann 1261 Am Eisteich 9 1262 72555 Metzingen 1263 Germany 1264 1265 Phone: +49 7123 14887 1266 Email: joe@ispsoft.de 1267 1268 All rights reserved. 1269 1270 You may distribute this package under the terms of either the GNU 1271 General Public License or the Artistic License, as specified in the 1272 Perl README file. 1273 1274 1275=head1 SEE ALSO 1276 1277L<RPC::pServer(3)>, L<Netserver::Generic(3)>, L<Net::Daemon::Log(3)>, 1278L<Net::Daemon::Test(3)> 1279 1280=cut 1281 1282