Net-Daemon-0.52/000755 000765 000024 00000000000 15164622705 015123 5ustar00todd.rinaldostaff000000 000000 Net-Daemon-0.52/ChangeLog000644 000765 000024 00000027444 15164622424 016706 0ustar00todd.rinaldostaff000000 000000 2026-04-05 Todd Rinaldo (0.52) Bug fixes: * Fix dead $RegExpLock that was never acquired in ithreads mode. The lock variable existed but was never actually locked before regexp compilation, leaving ithreads unprotected. Also fix share() call to pass explicit ref for runtime-loaded prototype. PR #33 * Fix ithreads auto-detection to gate on Perl 5.10+ and exclude Windows. On Perl 5.8.x threads::shared is never loaded, making lock() a no-op. On Windows, DuplicateHandle() corrupts Winsock sockets — WSADuplicateSocket() is required instead. GH #19, GH #30, GH #34, PR #35, PR #50 * Correct $eventId hash key typo in Log.pm that prevented event IDs from being logged. PR #36 * Fix Done() call in test server Loop method — was called without arguments, preventing proper server shutdown. PR #38 * Clean up stale test artifacts (log, ndtest.cnt). PR #40 * Harden ReadConfigFile against $@ contamination and $! errors. PR #44 * Skip pidfile write when pidfile option is not set, preventing spurious empty pidfile creation. PR #45 * Close cloned listening socket in ithreads handler threads. Perl ithreads dup every open handle into new threads; on Windows closing these at thread exit invalidated the parent's handle. Also re-add Windows skip with root-cause documentation. GH #19, GH #30, PR #46 * Address CPAN testers failures in t/reap.t and t/fork.t. PR #48 * Skip ithread-detach.t on Perl < 5.10. PR #49 * Verify privilege drop succeeded in Bind(). Assigning to $>/$) silently fails without permission — the daemon would continue running as root. PR #51 * Use POSIX::setuid/setgid for permanent privilege drop in Bind(). The previous $< = ($> = $user) left saved-set-user-ID as root, allowing a compromised process to regain privileges. PR #55 Improvements: * Modernize open() calls to 3-arg form with lexical filehandles throughout the codebase. PR #41 Maintenance: * Fix POD typos and remove outdated alpha warning. PR #37 * Fix stale --mode=threads references and config example syntax in documentation. PR #39 * Update ancient FSF address in Net::Daemon::Test copyright. PR #35 * Convert server tests from raw TAP to Test::More. PR #42 * Convert ithreads tests to Test::More and fix Test.pm fd leak. PR #43 * Convert remaining tests (loop.t, loop-child.t, unix_clients.t, forkm.t) to Test::More. PR #47 2026-03-22 Todd Rinaldo (0.51) Bug fixes: * Fix Socket::INADDR_ANY constant for unix socket client auth. GH #1, PR #27 * Fix post_clone() hook - Clone() never called new(), so the $self->{'parent'} check in new() was dead code. Added post_clone() method that Clone() calls after creating the new object. GH #2, PR #26 * Open logfile when filename string is provided via --logfile. OpenLog() previously returned the logfile value as-is when it was a defined string, causing Log() to fall through to STDERR. GH #3, PR #25 (rt.cpan.org #76133) * Reap forked child processes to prevent zombie accumulation. SigChildHandler now uses a proper waitpid reaper instead of returning 'IGNORE', fixing zombie buildup on Windows/Strawberry Perl after ~64 connections. GH #5, PR #23 * Fix ReadConfigFile implementation traversing @INC. GH #8 (rt.cpan.org #123213) * Detach threads in ChildFunc to prevent memory leaks. Thread objects were never joined or detached, causing leftover thread mappings to accumulate. GH #12, PR #22 * Only load threads if forks hasn't already been loaded and threads exists. GH #16 Improvements: * Add post_clone() hook for per-connection initialization. Subclasses can override to perform per-connection setup. GH #2, PR #26 * Add --listen option to Options() to allow overriding the default listen backlog of 10. GH #4, PR #24 Maintenance: * Modernize Makefile.PL metadata: add LICENSE, MIN_PERL_VERSION, TEST_REQUIRES, upgrade META_MERGE to meta-spec v2, update GitHub URLs. PR #28 * Modernize CI workflow: upgrade actions/checkout to v4, use perldocker/perl-tester images, dynamic Perl version matrix covering 5.8 through devel, add disttest job. PR #29 * Disable t/ithreadm.t for Windows. GH #19 * Improve skip messages and detection of ithreads/forks in tests. * Convert t/base.t to Test::More. * Apply consistent perltidy formatting. * Add strict/warnings, replace 'use vars' with 'our'. * Remove perl 4-ish subroutine calls. 2020-09-22 Todd Rinaldo (0.49) * Perl 5.6 is the minimum required version now. * RIP Thread.pm it has not been relevant since 5.6 2011-03-09 Malcolm Nooning (0.48) * t/forkm.t Patched perl Leon Timmermans http://rt.perl.org/rt3/Public/Bug/Display.html?id=83646 2011-03-01 Malcolm Nooning (0.47) * lib/Net/Daemon.pm Patched per bug 32887 "ithreads not detected due to a typo" 2011-02-22 Malcolm Nooning (0.46) * lib/Net/Daemon.pm Fixed "Subroutine import redefined" problem that perl 5.8.8 CPAN testers was getting. It was due to more than one "require threads" being run. * distribution. Bumped up the version number first. 2011-02-18 Malcolm Nooning (0.45) * lib/Net/Daemon.pm Used "make dist" to create the uploaded * distribution. Bumped up the version number first. 2011-02-17 Malcolm Nooning (0.44) * lib/Net/Daemon.pm Added ServClose patch by Gaspar Chilingarov * t/thread.t Added patches by Daniel Macks and Joe McMahon, and added Test::More and skip_all for Windows < 5.10 2009-03-12 Joe McMahon (0.44) * Added necessary thread sharing to work with 5.10 threads model: regexp-threads, * Bumped minimum required perl to 5.10 for t/threads.t tests 2007-06-17 Malcolm Nooning (0.43) * lib/Net/Daemon.pm Needed to up the VERSION number 2007-06-16 Malcolm Nooning (0.42) * t/forkm.t: Added a wait so that the parent will not loop around and make another child until the previous child has been destroyed. 2007-05-23 Malcolm Nooning (0.41) * t/forkm.t: When all ten childs are exited, sub CatchChild will now exit. 2007-05-16 Malcolm Nooning (0.40) * t/threadm.t: The tests are now skipped with a passing indication when usethreads is defined, which would mean that the ithreadm tests are the ones that matter. Test.pm: A patch from todd.e.rinaldo was used. I do not remember what the issues were. 2006-02-15 Jochen Wiedmann (0.39) * t/forkm.t: Hopefully, I finally got rid of the problem with the forking tests. It seems, that the perlipc manual got updated in the past years, most possibly for the same reason: A child handler must be written to catch childs in a loop. 2003-11-10 Jochen Wiedmann (0.38) * lib/Net/Daemon.pm: It is now possible to specify user/group root (aka 0). (rgreab@fx.ro) * Added mode 'ithreads'. (Bill Jackson, ) * lib/Net/Daemon.pm (Bind): The parent process is now explicitly closing the client socket in fork mode. (Thought this would happen automatically due to garbage collection, but possibly it doesn't.) Tulsi Ram Mayala, 2002-08-20 Jochen Wiedmann (0.37) * lib/Net/Daemon.pm (Bind): The server died, if accepting a connection failed. Fixed. Nathan Mueller 2001-11-12 Jochen Wiedmann (0.36) * For whatever reason, Thread->self returns undef under ActivePerl. This is now handled properly in Net::Daemon::Log. 2001-04-08 Jochen Wiedmann (0.35) * Added preforked childs to mode 'single'. (Gerald Richter, ) * t/server (Run): Child process is now waiting one second in forking mode. Helps the script t/forkm.t to run fine. (Radu Greab ) 2000-12-22 Jochen Wiedmann (0.34) * Changed "kill 1" to "kill 'TERM'" when working with fork. Thanks to Torsten Foertsch (torsten.foertsch@gmx.net), in particular for his explanations on the rationale behind SIGHUP. 2000-11-07 Jochen Wiedmann (0.32) * lib/Net/Daemon.pm: SigChildHandler is now always returning undef or IGNORE. 2000-06-26 Jochen Wiedmann (0.31) * lib/Net/Daemon/Log.pm (OpenLog): Same thing for FreeBSD. Thanks to Kurt Jaeger . 2000-10-05 Jochen Wiedmann (0.30) * lib/Net/Daemon.pm: Fixed problem with setlogsock on Solaris. My thanks to Wolfgang Friebel . 1999-11-14 Jochen Wiedmann (0.29) * lib/Net/Daemon/Log.pm (Fatal): Now displaying the callers error line and file, rather than that of the Fatal() method. 1999-09-26 Jochen Wiedmann (0.28) * lib/Net/Daemon/Log.pm: Added LogTime method. Stefan Engel * lib/Net/Daemon.pm: Fixed use of $socket->sockhost() instead of $socket->peerhost() when logging the clients IP address. Stefan Engel * lib/Net/Daemon.pm: Made 'IGNORE' the default for $SIG{'CHLD'} on Solaris. Stefan Engel 1999-08-11 Jochen Wiedmann (0.27) * lib/Net/Daemon.pm (Bind): Under Linux the CHLD signal is now ignored, due to a suggestion of Gaal Yahas . Required because zombies have been created under heavy load. 1999-08-11 Jochen Wiedmann (0.26) * lib/Net/Daemon/Test.pm (Child): Fixed handling of "." in directory names. Thanks to Tom Lowery, . * t/threadm.t (MyChild): Use of alarm() now depends on a working alarm() function. (Not working under Win32.) Thanks to Tom Lowery, 1999-07-24 Jochen Wiedmann (0.25) * lib/Net/Daemon.pm: Added the Loop method and the loop-timeout option. 1999-07-12 Jochen Wiedmann (0.24) * lib/Net/Daemon.pm (Bind): Moved PID file creation before chroot. Benjamin Ritcey * lib/Net/Daemon.pm (Bind): Added use of the Proc::Daemon::Init module, if present. 1999-07-02 Jochen Wiedmann (0.23) * lib/Net/Daemon.pm (new): Fixed automatic mode detection. Benjamin Ritcey 1999-07-01 Jochen Wiedmann (0.22) * lib/Net/Daemon.pm (Bind): Made --pidfile working. (Joshua Pincus ) 1999-06-27 Jochen Wiedmann (0.21) * lib/Net/Daemon.pm (Bind): Under Solaris the accept() call can fail with a value of EINTR if a SIGCHLD was catched. This is trapped now. Thanks to Brady Montz . 1999-03-20 Liraz Siri (0.20) * skipped to 0.2 since I've independantly made modifications, and I'd like to avoid conflict. * unix domain support. * minor bug fixes jochen made in 0.16 and 0.17. 1998-12-06 Jochen Wiedmann (0.15) * Added regexp lock. * Fixed the example server in the man page. 1998-10-30 Jochen Wiedmann (0.14) * lib/Net/Daemon.pm (Bind): Made server quiet without '--debug'. 1998-10-28 Jochen Wiedmann (0.13) * lib/Net/Daemon.pm: Some minor modifications for the DBI Proxy. 1998-10-25 Jochen Wiedmann (0.12) * Moved OpenLog, Log, Debug, Error and Fatal to Net::Daemon::Log. 1998-10-17 Jochen Wiedmann (0.11) * Daemon.pm: Added --configfile. * Daemon.pm: Removed --forking and --single in favour of --mode. * Daemon.pm: Removed --stderr in favour of --logfile=stderr. * Daemon.pm: Added $self->{'clients'}, recognizes 'mask' and 'accept' attributes. Net-Daemon-0.52/MANIFEST000644 000765 000024 00000002500 15164622705 016251 0ustar00todd.rinaldostaff000000 000000 AI_POLICY.md ChangeLog Module history lib/Net/Daemon.pm Net::Daemon module lib/Net/Daemon/Log.pm Support class for logging lib/Net/Daemon/Test.pm Support class for writing tests Makefile.PL Makefile generator MANIFEST This file MANIFEST.SKIP Files to ignore while generating the dist archive README.md t/base.t Base test t/clone.t Test of post_clone() hook for per-connection init t/config.t Test of config file handling and access control t/fork.t Test of a forking server t/forkm.t Test of a forking server with multiple clients t/ithread-detach.t Test that ChildFunc detaches threads t/ithread.t Test of a multithreaded server (ithreads) t/ithreadm.t Test of a multithreaded server with multiple clients t/listen.t Test the --listen option t/logfile.t Test logfile string handling in Net::Daemon::Log t/loop-child.t Same with loop-child set t/loop.t Test the loop-timeout option t/mode.t Test mode auto-detection and explicit selection t/privdrop.t t/reap.t t/server Script used by the server tests t/single.t Test of a single-mode server t/unix.t Test for Unix sockets t/unix_clients.t Test for Unix sockets with clients defined META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Net-Daemon-0.52/AI_POLICY.md000644 000765 000024 00000013036 15164621533 017016 0ustar00todd.rinaldostaff000000 000000 # AI Policy > **TL;DR** — AI tools assist our workflow at every stage. Humans remain in control of every decision, every review, and every release. --- ## Overview This document describes how artificial intelligence tools are used in the maintenance and development of this project. It is intended to be transparent with our contributors, users, and the broader open-source community about the role AI plays — and, equally importantly, the role it does **not** play. We believe in honest, clear communication about AI-assisted workflows. This policy will be updated as our practices evolve. --- ## Our Guiding Principle **AI assists. Humans decide.** The maintainers who have been stewarding this project for years remain fully responsible for every line of code that ships. AI tools extend our capacity to review, research, and improve — they do not replace human judgment, expertise, or accountability. --- ## How AI Is Used in This Project ### 1. Code and Issue Analysis AI tools help us process and understand incoming issues, pull requests, and code changes at scale. This includes: - Summarising issue reports and identifying patterns across similar bugs - Analysing code diffs for potential problems, regressions, or style inconsistencies - Surfacing relevant context from the codebase, documentation, and prior discussions - Flagging potential security concerns for human review This analysis is **always** used as input to human decision-making, never as a substitute for it. ### 2. Draft Pull Requests AI may generate draft pull requests as a starting point for a fix, a refactor, or an improvement. These drafts: - Are clearly labelled as AI-generated when created - Represent a first pass only — they are never considered complete or correct without human review - May be substantially reworked, rejected, or replaced entirely by maintainers Think of these drafts the way you would think of a junior contributor's first attempt: useful raw material that still needs experienced eyes. ### 3. Human Review of Every Pull Request **Every pull request — whether AI-drafted or human-authored — is reviewed by a human maintainer before it can be merged.** During review, maintainers actively use AI as a tool to assist their own thinking: - Asking AI to explain or justify specific implementation choices - Challenging AI-generated code and requesting alternative approaches - Using AI to research edge cases, relevant standards, or upstream behaviour - Requesting targeted rewrites of individual sections based on review feedback The maintainer's judgment always takes precedence. AI answers are treated as input to be verified, not conclusions to be accepted. ### 4. Test Coverage and Defect Detection AI helps us improve the quality and completeness of our test suite by: - Suggesting test cases for edge conditions and failure modes - Identifying gaps in existing test coverage - Proposing tests that target known classes of defects or security issues - Helping reproduce and characterise reported bugs All suggested tests are reviewed and validated by maintainers before being committed. ### 5. Security Review AI tools assist in identifying potential security issues, including: - Common vulnerability patterns (injection, insecure defaults, deprecated APIs, etc.) - Dependencies with known CVEs - Code paths that may warrant closer scrutiny Security findings from AI are **always** verified by a human maintainer. We do not act on AI-flagged security issues without independent assessment. --- ## What AI Does Not Do To be explicit about the limits of AI involvement in this project: | ❌ AI does not… | ✅ A human maintainer does… | |---|---| | Approve or merge pull requests | Review and decide on every PR | | Make architectural decisions | Own all design and direction choices | | Triage and close issues autonomously | Assess and respond to all issues | | Publish releases | Tag, build, and release manually | | Represent the project publicly | Communicate on behalf of the project | --- ## Releases Releases are performed manually by the same long-standing maintainers as always. The release process — including changelog review, version tagging, and publication — uses standard Perl ecosystem tooling (e.g. ExtUtils::MakeMaker, Dist::Zilla, Module::Build) but involves no AI-driven automation. Every release is initiated, supervised, and published by a human maintainer. AI may assist in drafting changelogs or release notes, but these are always reviewed and edited before publication. --- ## Attribution and Transparency Where AI has played a material role in generating code or content within a pull request, we aim to note this in the PR description (e.g. via a `Generated-By` or `AI-Assisted` label or note). We do not consider AI the author of any contribution — the maintainer who reviewed and approved the work takes responsibility for it. --- ## Why We Do This Open-source software is built on trust. Our users and downstream dependants trust us to ship correct, secure, and well-considered code. AI tools help us do that work better — but they do not change who is responsible for the outcome. We use AI because it makes our maintainers more effective, not because it replaces them. --- ## Questions and Feedback If you have questions about our use of AI, or concerns about a specific pull request or change, please open an issue or start a discussion. We are committed to being open about our process. --- *Last updated: 2026-03-23* *This policy is maintained by the project maintainers and subject to revision as AI tooling and community norms evolve.* Net-Daemon-0.52/t/000755 000765 000024 00000000000 15164622705 015366 5ustar00todd.rinaldostaff000000 000000 Net-Daemon-0.52/README.md000644 000765 000024 00000046446 15164622462 016420 0ustar00todd.rinaldostaff000000 000000 [![testsuite](https://github.com/cpan-authors/Net-Daemon/actions/workflows/testsuite.yml/badge.svg)](https://github.com/cpan-authors/Net-Daemon/actions/workflows/testsuite.yml) # NAME Net::Daemon - Perl extension for portable daemons # SYNOPSIS # Create a subclass of Net::Daemon require Net::Daemon; package MyDaemon; @MyDaemon::ISA = qw(Net::Daemon); sub Run ($) { # This function does the real work; it is invoked whenever a # new connection is made. } # DESCRIPTION Net::Daemon is an abstract base class for implementing portable server applications in a very simple way. The module is designed for Perl 5.006 and ithreads, but can work with fork() as well. The Net::Daemon class offers methods for the most common tasks a daemon needs: Starting up, logging, accepting clients, authorization, restricting its own environment for security and doing the true work. You only have to override those methods that aren't appropriate for you, but typically inheriting will safe you a lot of work anyways. ## Constructors $server = Net::Daemon->new($attr, $options); $connection = $server->Clone($socket); Two constructors are available: The **new** method is called upon startup and creates an object that will basically act as an anchor over the complete program. It supports command line parsing via [Getopt::Long (3)](http://man.he.net/man3/Getopt::Long ). Arguments of **new** are _$attr_, an hash ref of attributes (see below) and _$options_ an array ref of options, typically command line arguments (for example **\\@ARGV**) that will be passed to **Getopt::Long::GetOptions**. The second constructor is **Clone**: It is called whenever a client connects. It receives the main server object as input and returns a new object. This new object will be passed to the methods that finally do the true work of communicating with the client. Communication occurs over the socket **$socket**, **Clone**'s argument. Note that **Clone** does _not_ call **new**; it creates a shallow copy of the server object. If your subclass needs to initialize per-connection state, override the **post\_clone** method rather than checking for `$self->{'parent'}` inside **new**. **post\_clone** is called by **Clone** after the new object is created and blessed. The default implementation is a no-op. Possible object attributes and the corresponding command line arguments are: - _catchint_ (**--nocatchint**) On some systems, in particular Solaris, the functions accept(), read() and so on are not safe against interrupts by signals. For example, if the user raises a USR1 signal (as typically used to reread config files), then the function returns an error EINTR. If the _catchint_ option is on (by default it is, use **--nocatchint** to turn this off), then the package will ignore EINTR errors wherever possible. - _chroot_ (**--chroot=dir**) (UNIX only) After doing a bind(), change root directory to the given directory by doing a chroot(). This is useful for security operations, but it restricts programming a lot. For example, you typically have to load external Perl extensions before doing a chroot(), or you need to create hard links to Unix sockets. This is typically done in the config file, see the --configfile option. See also the --group and --user options. If you don't know chroot(), think of an FTP server where you can see a certain directory tree only after logging in. - _clients_ An array ref with a list of clients. Clients are hash refs, the attributes _accept_ (0 for denying access and 1 for permitting) and _mask_, a Perl regular expression for the clients IP number or its host name. See ["Access control"](#access-control) below. - _configfile_ (**--configfile=file**) Net::Daemon supports the use of config files. These files are assumed to contain a single hash ref that overrides the arguments of the new method. However, command line arguments in turn take precedence over the config file. See the ["Config File"](#config-file) section below for details on the config file. - _debug_ (**--debug**) Turn debugging mode on. Mainly this asserts that logging messages of level "debug" are created. - _facility_ (**--facility=mode**) (UNIX only) Facility to use for [Sys::Syslog (3)](http://man.he.net/man3/Sys::Syslog ). The default is **daemon**. - _group_ (**--group=gid**) After doing a bind(), change the real and effective GID to the given. This is useful, if you want your server to bind to a privileged port (<1024), but don't want the server to execute as root. See also the --user option. GID's can be passed as group names or numeric values. - _localaddr_ (**--localaddr=ip**) By default a daemon is listening to any IP number that a machine has. This attribute allows to restrict the server to the given IP number. - _localpath_ (**--localpath=path**) If you want to restrict your server to local services only, you'll prefer using Unix sockets, if available. In that case you can use this option for setting the path of the Unix socket being created. This option implies **--proto=unix**. - _localport_ (**--localport=port**) This attribute sets the port on which the daemon is listening. It must be given somehow, as there's no default. - _logfile_ (**--logfile=file**) By default logging messages will be written to the syslog (Unix) or to the event log (Windows NT). On other operating systems you need to specify a log file. The special value "STDERR" forces logging to stderr. - _loop-child_ (**--loop-child**) This option forces creation of a new child for loops. (See the _loop-timeout_ option.) By default the loops are serialized. - _loop-timeout_ (**--loop-timeout=secs**) Some servers need to take an action from time to time. For example the Net::Daemon::Spooler attempts to empty its spooling queue every 5 minutes. If this option is set to a positive value (zero being the default), then the server will call its Loop method every "loop-timeout" seconds. Don't trust too much on the precision of the interval: It depends on a number of factors, in particular the execution time of the Loop() method. The loop is implemented by using the _select_ function. If you need an exact interval, you should better try to use the alarm() function and a signal handler. (And don't forget to look at the _catchint_ option!) It is recommended to use the _loop-child_ option in conjunction with _loop-timeout_. - _mode_ (**--mode=modename**) The Net::Daemon server can run in three different modes, depending on the environment. If you are running Perl 5.10 or later with ithreads support on a non-Windows platform, the server will create a new thread for each connection. The thread will execute the server's Run() method and then terminate. This mode is the default on Unix-like systems; you can force it with "--mode=ithreads". **Note:** Ithreads mode is not auto-detected on Windows because Perl uses `DuplicateHandle()` to clone socket file descriptors into new threads, whereas Winsock requires `WSADuplicateSocket()`. The duplicated client sockets become corrupted, causing I/O errors. You may still pass `--mode=ithreads` explicitly, but expect failures under concurrent load. See [https://github.com/cpan-authors/Net-Daemon/issues/19](https://github.com/cpan-authors/Net-Daemon/issues/19). If threads are not available, but you have a working fork(), then the server will behave similar by creating a new process for each connection. This mode will be used automatically in the absence of threads or if you use the "--mode=fork" option. Finally there's a single-connection mode: If the server has accepted a connection, he will enter the Run() method. No other connections are accepted until the Run() method returns. This operation mode is useful if you have neither threads nor fork(), for example on Windows. For debugging purposes you can force this mode with "--mode=single". When running in mode single, you can still handle multiple clients at a time by preforking multiple child processes. The number of childs is configured with the option "--childs". - _childs_ Use this parameter to let Net::Daemon run in prefork mode, which means it forks the number of childs processes you give with this parameter, and all child handle connections concurrently. The difference to fork mode is, that the child processes continue to run after a connection has terminated and are able to accept a new connection. This is useful for caching inside the childs process (e.g. DBI::ProxyServer connect\_cached attribute) - _options_ Array ref of Command line options that have been passed to the server object via the **new** method. - _parent_ When creating an object with **Clone** the original object becomes the parent of the new object. Objects created with **new** usually don't have a parent, thus this attribute is not set. - _pidfile_ (**--pidfile=file**) (UNIX only) If this option is present, a PID file will be created at the given location. - _proto_ (**--proto=proto**) The transport layer to use, by default _tcp_ or _unix_ for a Unix socket. It is not yet possible to combine both. - _socket_ The socket that is connected to the client; passed as **$client** argument to the **Clone** method. If the server object was created with **new**, this attribute can be undef, as long as the **Bind** method isn't called. Sockets are assumed to be IO::Socket objects. - _user_ (**--user=uid**) After doing a bind(), change the real and effective UID to the given. This is useful, if you want your server to bind to a privileged port (<1024), but don't want the server to execute as root. See also the --group and the --chroot options. UID's can be passed as group names or numeric values. - _version_ (**--version**) Supresses startup of the server; instead the version string will be printed and the program exits immediately. Note that most of these attributes (facility, mode, localaddr, localport, pidfile, version) are meaningfull only at startup. If you set them later, they will be simply ignored. As almost all attributes have appropriate defaults, you will typically use the **localport** attribute only. ## Command Line Parsing my $optionsAvailable = Net::Daemon->Options(); print Net::Daemon->Version(), "\n"; Net::Daemon->Usage(); The **Options** method returns a hash ref of possible command line options. The keys are option names, the values are again hash refs with the following keys: - template An option template that can be passed to **Getopt::Long::GetOptions**. - description A description of this option, as used in **Usage** The **Usage** method prints a list of all possible options and returns. It uses the **Version** method for printing program name and version. ## Config File If the config file option is set in the command line options or in the in the "new" args, then the method $server->ReadConfigFile($file, $options, $args) is invoked. By default the config file is expected to contain Perl source that returns a hash ref of options. These options override the "new" args and will in turn be overwritten by the command line options, as present in the $options hash ref. A typical config file might look as follows, we use the DBI::ProxyServer as an example: # Load external modules; this is not required unless you use # the chroot() option. #require DBD::mysql; #require DBD::CSV; { # 'chroot' => '/var/dbiproxy', 'facility' => 'daemon', 'pidfile' => '/var/dbiproxy/dbiproxy.pid', 'user' => 'nobody', 'group' => 'nobody', 'localport' => '1003', 'mode' => 'fork', # Access control 'clients' => [ # Accept the local { 'mask' => '^192\.168\.1\.\d+$', 'accept' => 1 }, # Accept myhost.company.com { 'mask' => '^myhost\.company\.com$', 'accept' => 1 }, # Deny everything else { 'mask' => '.*', 'accept' => 0 } ] } ## Access control The Net::Daemon package supports a host based access control scheme. By default access is open for anyone. However, if you create an attribute $self->{'clients'}, typically in the config file, then access control is disabled by default. For any connection the client list is processed: The clients attribute is an array ref to a list of hash refs. Any of the hash refs may contain arbitrary attributes, including the following: - mask A Perl regular expression that has to match the clients IP number or its host name. The list is processed from the left to the right, whenever a 'mask' attribute matches, then the related hash ref is chosen as client and processing the client list stops. - accept This may be set to true or false (default when omitting the attribute), the former means accepting the client. ## Event logging $server->Log($level, $format, @args); $server->Debug($format, @args); $server->Error($format, @args); $server->Fatal($format, @args); The **Log** method is an interface to [Sys::Syslog (3)](http://man.he.net/man3/Sys::Syslog ) or [Win32::EventLog (3)](http://man.he.net/man3/Win32::EventLog ). It's arguments are _$level_, a syslog level like **debug**, **notice** or **err**, a format string in the style of printf and the format strings arguments. The **Debug** and **Error** methods are shorthands for calling **Log** with a level of debug and err, respectively. The **Fatal** method is like **Error**, except it additionally throws the given message as exception. See [Net::Daemon::Log(3)](http://man.he.net/man3/Net::Daemon::Log) for details. ## Flow of control $server->Bind(); # The following inside Bind(): if ($connection->Accept()) { $connection->Run(); } else { $connection->Log('err', 'Connection refused'); } The **Bind** method is called by the application when the server should start. Typically this can be done right after creating the server object **$server**. **Bind** usually never returns, except in case of errors. When a client connects, the server uses **Clone** to derive a connection object **$connection** from the server object. A new thread or process is created that uses the connection object to call your classes **Accept** method. This method is intended for host authorization and should return either FALSE (refuse the client) or TRUE (accept the client). If the client is accepted, the **Run** method is called which does the true work. The connection is closed when **Run** returns and the corresponding thread or process exits. ## Error Handling All methods are supposed to throw Perl exceptions in case of errors. # MULTITHREADING CONSIDERATIONS All methods are working with lexically scoped data and handle data only, the exception being the OpenLog method which is invoked before threading starts. Thus you are safe as long as you don't share handles between threads. I strongly recommend that your application behaves similar. (This doesn't apply to mode 'ithreads'.) # EXAMPLE As an example we'll write a simple calculator server. After connecting to this server you may type expressions, one per line. The server evaluates the expressions and prints the result. (Note this is an example, in real life we'd never implement such a security hole. :-) For the purpose of example we add a command line option _--base_ that takes 'hex', 'oct' or 'dec' as values: The servers output will use the given base. # -*- perl -*- # # Calculator server # use strict; require Net::Daemon; package Calculator; our $VERSION = '0.52'; our @ISA = qw(Net::Daemon); # to inherit from Net::Daemon sub Version ($) { 'Calculator Example Server, 0.01'; } # Add a command line option "--base" sub Options ($) { my($self) = @_; my($options) = $self->SUPER::Options(); $options->{'base'} = { 'template' => 'base=s', 'description' => '--base ' . 'dec (default), hex or oct' }; $options; } # Treat command line option in the constructor sub new ($$;$) { my($class, $attr, $args) = @_; my($self) = $class->SUPER::new($attr, $args); if ($self->{'options'} && $self->{'options'}->{'base'}) { $self->{'base'} = $self->{'options'}->{'base'} } if (!$self->{'base'}) { $self->{'base'} = 'dec'; } $self; } # Initialize per-connection state after Clone() sub post_clone ($) { my($self) = @_; $self->{'base'} = $self->{'parent'}->{'base'}; } sub Run ($) { my($self) = @_; my($line, $sock); $sock = $self->{'socket'}; while (1) { if (!defined($line = $sock->getline())) { if ($sock->error()) { $self->Error("Client connection error %s", $sock->error()); } $sock->close(); return; } $line =~ s/\s+$//; # Remove CRLF my($result) = eval $line; my($rc); if ($self->{'base'} eq 'hex') { $rc = printf $sock ("%x\n", $result); } elsif ($self->{'base'} eq 'oct') { $rc = printf $sock ("%o\n", $result); } else { $rc = printf $sock ("%d\n", $result); } if (!$rc) { $self->Error("Client connection error %s", $sock->error()); $sock->close(); return; } } } package main; my $server = Calculator->new({'pidfile' => 'none', 'localport' => 2000}, \@ARGV); $server->Bind(); # KNOWN PROBLEMS Most, or even any, known problems are related to the Sys::Syslog module which is by default used for logging events under Unix. I'll quote some examples: - Usage: Sys::Syslog::\_PATH\_LOG at ... This problem is treated in perl bug 20000712.003. A workaround is changing line 277 of Syslog.pm to my $syslog = &_PATH_LOG() || croak "_PATH_LOG not found in syslog.ph"; # AUTHOR AND COPYRIGHT Net::Daemon is Copyright (C) 1998, Jochen Wiedmann Am Eisteich 9 72555 Metzingen Germany Phone: +49 7123 14887 Email: joe@ispsoft.de All rights reserved. You may distribute this package under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. # SEE ALSO [RPC::pServer(3)](http://man.he.net/man3/RPC::pServer), [Netserver::Generic(3)](http://man.he.net/man3/Netserver::Generic), [Net::Daemon::Log(3)](http://man.he.net/man3/Net::Daemon::Log), [Net::Daemon::Test(3)](http://man.he.net/man3/Net::Daemon::Test) Net-Daemon-0.52/MANIFEST.SKIP000644 000765 000024 00000000242 15160065745 017020 0ustar00todd.rinaldostaff000000 000000 ^blib/ ~$ ^Makefile$ ^log$ ^pm_to_blib$ ^t/config$ \bCVS\b ^Net-Daemon-\d+\.\d+/ ^.github/ ^cpanfile$ ^\.gitignore$ ^\.git/ ^MANIFEST.bak ^MYMETA\. ^\.perltidyrc$Net-Daemon-0.52/META.yml000644 000765 000024 00000001410 15164622705 016370 0ustar00todd.rinaldostaff000000 000000 --- abstract: 'Perl extension for portable daemons' author: - 'Jochen Wiedmann ' build_requires: ExtUtils::MakeMaker: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-Daemon no_index: directory: - t - inc requires: Sys::Syslog: '0.29' perl: '5.006' resources: bugtracker: https://github.com/cpan-authors/Net-Daemon/issues license: http://dev.perl.org/licenses/ repository: https://github.com/cpan-authors/Net-Daemon.git version: '0.52' x_serialization_backend: 'CPAN::Meta::YAML version 0.020' Net-Daemon-0.52/lib/000755 000765 000024 00000000000 15164622705 015671 5ustar00todd.rinaldostaff000000 000000 Net-Daemon-0.52/Makefile.PL000644 000765 000024 00000002324 15164621540 017072 0ustar00todd.rinaldostaff000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; my %opts = ( 'NAME' => 'Net::Daemon', 'ABSTRACT_FROM' => 'lib/Net/Daemon.pm', 'AUTHOR' => 'Jochen Wiedmann ', 'VERSION_FROM' => 'lib/Net/Daemon.pm', # finds $VERSION 'LICENSE' => 'perl_5', 'MIN_PERL_VERSION' => '5.006', 'PREREQ_PM' => { 'Sys::Syslog' => '0.29', }, 'TEST_REQUIRES' => { 'Test::More' => '0', }, 'dist' => { 'DIST_DEFAULT' => q[all tardist], 'COMPRESS' => q[gzip -9vf], 'SUFFIX' => q[.gz] }, 'realclean' => { 'FILES' => 't/config ndtest.prt ndtest.cnt log' }, 'META_MERGE' => { 'meta-spec' => { version => 2 }, 'resources' => { license => ['http://dev.perl.org/licenses/'], bugtracker => { web => 'https://github.com/cpan-authors/Net-Daemon/issues', }, repository => { type => 'git', url => 'https://github.com/cpan-authors/Net-Daemon.git', web => 'https://github.com/cpan-authors/Net-Daemon', }, }, }, ); WriteMakefile(%opts); Net-Daemon-0.52/META.json000644 000765 000024 00000002642 15164622705 016550 0ustar00todd.rinaldostaff000000 000000 { "abstract" : "Perl extension for portable daemons", "author" : [ "Jochen Wiedmann " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.76, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Net-Daemon", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Sys::Syslog" : "0.29", "perl" : "5.006" } }, "test" : { "requires" : { "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/cpan-authors/Net-Daemon/issues" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/cpan-authors/Net-Daemon.git", "web" : "https://github.com/cpan-authors/Net-Daemon" } }, "version" : "0.52", "x_serialization_backend" : "JSON::PP version 4.16" } Net-Daemon-0.52/lib/Net/000755 000765 000024 00000000000 15164622705 016417 5ustar00todd.rinaldostaff000000 000000 Net-Daemon-0.52/lib/Net/Daemon/000755 000765 000024 00000000000 15164622705 017622 5ustar00todd.rinaldostaff000000 000000 Net-Daemon-0.52/lib/Net/Daemon.pm000644 000765 000024 00000125553 15164622434 020172 0ustar00todd.rinaldostaff000000 000000 ############################################################################ # # Net::Daemon - Base class for implementing TCP/IP daemons # # Copyright (C) 1998, Jochen Wiedmann # Am Eisteich 9 # 72555 Metzingen # Germany # # Phone: +49 7123 14887 # Email: joe@ispsoft.de # # All rights reserved. # # You may distribute this package under the terms of either the GNU # General Public License or the Artistic License, as specified in the # Perl README file. # ############################################################################ package Net::Daemon; use strict; use warnings; use Config; use Getopt::Long (); use Symbol (); use IO::Socket (); use Net::Daemon::Log (); use POSIX (); use File::Spec (); our $VERSION = '0.52'; our @ISA = qw(Net::Daemon::Log); our $RegExpLock = 1; # Share $RegExpLock for thread safety when ithreads are available. # Uses explicit \$ref because the prototype isn't visible after require. my $use_ithreads = ( $^V ge v5.10.0 && $Config{'useithreads'} && !$INC{'forks.pm'} ) ? 1 : 0; if ($use_ithreads) { eval { require threads; }; eval { require threads::shared; }; threads::shared::share( \$RegExpLock ); } our $exit; ############################################################################ # # Name: Options (Class method) # # Purpose: Returns a hash ref of command line options # # Inputs: $class - This class # # Result: Options array; any option is represented by a hash ref; # used keys are 'template', a string suitable for describing # the option to Getopt::Long::GetOptions and 'description', # a string for the Usage message # ############################################################################ sub Options ($) { { 'catchint' => { 'template' => 'catchint!', 'description' => '--nocatchint ' . "Try to catch interrupts when calling system\n" . ' ' . 'functions like bind(), recv()), ...' }, 'childs' => { 'template' => 'childs=i', 'description' => '--childs ' . 'Set number of preforked childs, implies mode=single.' }, 'chroot' => { 'template' => 'chroot=s', 'description' => '--chroot ' . 'Change rootdir to given after binding to port.' }, 'configfile' => { 'template' => 'configfile=s', 'description' => '--configfile ' . 'Read options from config file .' }, 'debug' => { 'template' => 'debug', 'description' => '--debug ' . 'Turn debugging mode on' }, 'facility' => { 'template' => 'facility=s', 'description' => '--facility ' . 'Syslog facility; defaults to \'daemon\'' }, 'group' => { 'template' => 'group=s', 'description' => '--group ' . 'Change gid to given group after binding to port.' }, 'help' => { 'template' => 'help', 'description' => '--help ' . 'Print this help message' }, 'listen' => { 'template' => 'listen=i', 'description' => '--listen ' . 'Size of the listen queue (backlog); defaults to 10' }, 'localaddr' => { 'template' => 'localaddr=s', 'description' => '--localaddr ' . 'IP number to bind to; defaults to INADDR_ANY' }, 'localpath' => { 'template' => 'localpath=s', 'description' => '--localpath ' . 'UNIX socket domain path to bind to' }, 'localport' => { 'template' => 'localport=s', 'description' => '--localport ' . 'Port number to bind to' }, 'logfile' => { 'template' => 'logfile=s', 'description' => '--logfile ' . 'Force logging to ' }, 'loop-child' => { 'template' => 'loop-child', 'description' => '--loop-child ' . 'Create a child process for loops' }, 'loop-timeout' => { 'template' => 'loop-timeout=f', 'description' => '--loop-timeout ' . 'Looping mode, seconds per loop' }, 'mode' => { 'template' => 'mode=s', 'description' => '--mode ' . 'Operation mode (ithreads, fork or single)' }, 'pidfile' => { 'template' => 'pidfile=s', 'description' => '--pidfile ' . 'Use as PID file' }, 'proto' => { 'template' => 'proto=s', 'description' => '--proto ' . 'transport layer protocol: tcp (default) or unix' }, 'user' => { 'template' => 'user=s', 'description' => '--user ' . 'Change uid to given user after binding to port.' }, 'version' => { 'template' => 'version', 'description' => '--version ' . 'Print version number and exit' } } } ############################################################################ # # Name: Version (Class method) # # Purpose: Returns version string # # Inputs: $class - This class # # Result: Version string; suitable for printed by "--version" # ############################################################################ sub Version ($) { "Net::Daemon server, Copyright (C) 1998, Jochen Wiedmann"; } ############################################################################ # # Name: Usage (Class method) # # Purpose: Prints usage message # # Inputs: $class - This class # # Result: Nothing; aborts with error status # ############################################################################ sub Usage ($) { my ($class) = shift; my ($options) = $class->Options(); my (@options) = sort ( keys %$options ); print STDERR "Usage: $0 \n\nPossible options are:\n\n"; my ($key); foreach $key ( sort ( keys %$options ) ) { my ($o) = $options->{$key}; print STDERR " ", $o->{'description'}, "\n" if $o->{'description'}; } print STDERR "\n", $class->Version(), "\n"; exit(1); } ############################################################################ # # Name: ReadConfigFile (Instance method) # # Purpose: Reads the config file. # # Inputs: $self - Instance # $file - config file name # $options - Hash of command line options; these are not # really for being processed by this method. We pass # it just in case. The new() method will process them # at a later time. # $args - Array ref of other command line options. # ############################################################################ sub ReadConfigFile { my ( $self, $file, $options, $args ) = @_; if ( !-f $file ) { $self->Fatal("No such config file: $file"); } $@ = ''; my $copts = do File::Spec->rel2abs($file); if ($@) { $self->Fatal("Error while processing config file $file: $@"); } if ( !defined($copts) && $! ) { $self->Fatal("Cannot read config file $file: $!"); } if ( !$copts || ref($copts) ne 'HASH' ) { $self->Fatal("Config file $file did not return a hash ref."); } # Override current configuration with config file options. while ( my ( $var, $val ) = each %$copts ) { $self->{$var} = $val; } } ############################################################################ # # Name: new (Class method) # # Purpose: Constructor # # Inputs: $class - This class # $attr - Hash ref of attributes # $args - Array ref of command line arguments # # Result: Server object for success, error message otherwise # ############################################################################ sub new ($$;$) { my ( $class, $attr, $args ) = @_; my ($self) = $attr ? \%$attr : {}; bless( $self, ( ref($class) || $class ) ); my $options = ( $self->{'options'} ||= {} ); $self->{'args'} ||= []; if ($args) { my @optList = map { $_->{'template'} } values( %{ $class->Options() } ); local @ARGV = @$args; if ( !Getopt::Long::GetOptions( $options, @optList ) ) { $self->Usage(); } @{ $self->{'args'} } = @ARGV; if ( $options->{'help'} ) { $self->Usage(); } if ( $options->{'version'} ) { print STDERR $self->Version(), "\n"; exit 1; } } my $file = $options->{'configfile'} || $self->{'configfile'}; if ($file) { $self->ReadConfigFile( $file, $options, $args ); } while ( my ( $var, $val ) = each %$options ) { $self->{$var} = $val; } if ( $self->{'childs'} ) { $self->{'mode'} = 'single'; } elsif ( !defined( $self->{'mode'} ) ) { if ( $^O ne 'MSWin32' && $^V ge v5.10.0 && eval { require threads } ) { $self->{'mode'} = 'ithreads'; } else { my $fork = 0; if ( $^O ne "MSWin32" ) { my $pid = eval { fork() }; if ( defined($pid) ) { if ( !$pid ) { exit; } # Child $fork = 1; wait; } } if ($fork) { $self->{'mode'} = 'fork'; } else { $self->{'mode'} = 'single'; } } } if ( $self->{'mode'} eq 'ithreads' ) { no warnings 'redefine'; require threads; use warnings 'redefine'; } elsif ( $self->{'mode'} eq 'fork' ) { # Initialize forking mode ... } elsif ( $self->{'mode'} eq 'single' ) { # Initialize single mode ... } else { $self->Fatal("Unknown operation mode: $self->{'mode'}"); } $self->{'catchint'} = 1 unless exists( $self->{'catchint'} ); $self->Debug("Server starting in operation mode $self->{'mode'}"); if ( $self->{'childs'} ) { $self->Debug("Preforking $self->{'childs'} child processes ..."); } $self; } sub Clone ($$) { my ( $proto, $client ) = @_; my $self = {%$proto}; $self->{'socket'} = $client; $self->{'parent'} = $proto; bless( $self, ref($proto) ); $self->post_clone(); $self; } sub post_clone ($) { # Override in subclasses to initialize cloned (per-connection) instances. # Called by Clone() after the new object is created. The parent server # object is available as $self->{'parent'}. } ############################################################################ # # Name: Accept (Instance method) # # Purpose: Called for authentication purposes # # Inputs: $self - Server instance # # Result: TRUE, if the client has successfully authorized, FALSE # otherwise. # ############################################################################ sub Accept ($) { my $self = shift; my $socket = $self->{'socket'}; my $clients = $self->{'clients'}; my $from = $self->{'proto'} eq 'unix' ? "Unix socket" : sprintf( "%s, port %s", $socket->peerhost(), $socket->peerport() ); # Host based authorization if ( $self->{'clients'} ) { my ( $name, $aliases, $addrtype, $length, @addrs ); if ( $self->{'proto'} eq 'unix' ) { ( $name, $aliases, $addrtype, $length, @addrs ) = ( 'localhost', '', Socket::AF_INET(), length( Socket::INADDR_ANY ), Socket::inet_aton('127.0.0.1') ); } else { ( $name, $aliases, $addrtype, $length, @addrs ) = gethostbyaddr( $socket->peeraddr(), Socket::AF_INET() ); } my @patterns = @addrs ? map { Socket::inet_ntoa($_) } @addrs : $socket->peerhost(); push( @patterns, $name ) if ($name); push( @patterns, split( / /, $aliases ) ) if $aliases; my $found; OUTER: foreach my $client (@$clients) { if ( !$client->{'mask'} ) { $found = $client; last; } my $masks = ref( $client->{'mask'} ) ? $client->{'mask'} : [ $client->{'mask'} ]; # Lock regex operations for thread safety. Modern Perl # (5.10+) has thread-safe regex, but subclasses may rely # on $RegExpLock for their own synchronization. # my $lock; $lock = lock($RegExpLock) if ( $self->{'mode'} eq 'ithreads' ); foreach my $mask (@$masks) { foreach my $alias (@patterns) { if ( $alias =~ /$mask/ ) { $found = $client; last OUTER; } } } } if ( !$found || !$found->{'accept'} ) { $self->Error("Access not permitted from $from"); return 0; } $self->{'client'} = $found; } $self->Debug("Accepting client from $from"); 1; } ############################################################################ # # Name: Run (Instance method) # # Purpose: Does the real work # # Inputs: $self - Server instance # # Result: Nothing; returning will make the connection to be closed # ############################################################################ sub Run ($) { } ############################################################################ # # Name: Done (Instance method) # # Purpose: Called by the server before doing an accept(); a TRUE # value makes the server terminate. # # Inputs: $self - Server instance # # Result: TRUE or FALSE # # Bugs: Doesn't work in forking mode. # ############################################################################ sub Done ($;$) { my $self = shift; $self->{'done'} = shift if @_; $self->{'done'}; } ############################################################################ # # Name: Loop (Instance method) # # Purpose: If $self->{'loop-timeout'} option is set, then this method # will be called every "loop-timeout" seconds. # # Inputs: $self - Server instance # # Result: Nothing; aborts in case of trouble. Note, that this is *not* # trapped and forces the server to exit. # ############################################################################ sub Loop { } ############################################################################ # # Name: ChildFunc (Instance method) # # Purpose: If possible, spawn a child process which calls a given # method. In server mode single the method is called # directly. # # Inputs: $self - Instance # $method - Method name # @args - Method arguments # # Returns: Nothing; aborts in case of problems. # ############################################################################ sub ChildFunc { my ( $self, $method, @args ) = @_; if ( $self->{'mode'} eq 'single' ) { $self->$method(@args); } elsif ( $self->{'mode'} eq 'ithreads' ) { my $startfunc = sub { my $self = shift; my $method = shift; # Close the cloned listening socket inherited from the # parent interpreter. Perl ithreads clone the entire # interpreter state, so every open handle — including the # server's listening socket — gets dup'd into the thread. # On Windows, closing these duplicated Winsock handles at # thread exit can invalidate the original handle in the # parent, breaking subsequent accept() calls. Closing # the clone immediately at thread start avoids this. if ( my $parent = delete $self->{'parent'} ) { $parent->{'socket'}->close() if $parent->{'socket'}; } $self->$method(@_); }; my $thr = threads->new( $startfunc, $self, $method, @args ) or die "Failed to create a new thread: $!"; $thr->detach(); } else { my $pid = fork(); die "Cannot fork: $!" unless defined $pid; return if $pid; # Parent $self->$method(@args); # Child exit(0); } } ############################################################################ # # Name: Bind (Instance method) # # Purpose: Binds to a port; if successful, it never returns. Instead # it accepts connections. For any connection a new thread is # created and the Accept method is executed. # # Inputs: $self - Server instance # # Result: Error message in case of failure # ############################################################################ sub HandleChild { my $self = shift; $self->Debug("New child starting ($self)."); eval { if ( !$self->Accept() ) { $self->Error('Refusing client'); } else { $self->Debug('Accepting client'); $self->Run(); } }; $self->Error("Child died: $@") if $@; $self->Debug("Child terminating."); $self->Close(); } sub SigChildHandler { my $self = shift; my $ref = shift; if ( $self->{'mode'} eq 'fork' || $self->{'childs'} ) { return sub { while ( ( my $pid = waitpid( -1, POSIX::WNOHANG() ) ) > 0 ) { $$ref = $pid if $ref; } }; } return undef; # Don't care for childs. } sub Bind ($) { my $self = shift; my $fh; my $child_pid; my $reaper = $self->SigChildHandler( \$child_pid ); $SIG{'CHLD'} = $reaper if $reaper; if ( !$self->{'socket'} ) { $self->{'proto'} ||= ( $self->{'localpath'} ) ? 'unix' : 'tcp'; if ( $self->{'proto'} eq 'unix' ) { my $path = $self->{'localpath'} or $self->Fatal('Missing option: localpath'); unlink $path; $self->Fatal("Can't remove stale Unix socket ($path): $!") if -e $path; my $old_umask = umask 0; $self->{'socket'} = IO::Socket::UNIX->new( 'Local' => $path, 'Listen' => $self->{'listen'} || 10 ) or $self->Fatal("Cannot create Unix socket $path: $!"); umask $old_umask; } else { $self->{'socket'} = IO::Socket::INET->new( 'LocalAddr' => $self->{'localaddr'}, 'LocalPort' => $self->{'localport'}, 'Proto' => $self->{'proto'} || 'tcp', 'Listen' => $self->{'listen'} || 10, 'Reuse' => 1 ) or $self->Fatal("Cannot create socket: $!"); } } $self->Log( 'notice', "Server starting" ); my $pidfile = $self->{'pidfile'}; if ( $pidfile && $pidfile ne 'none' ) { $self->Debug("Writing PID to $pidfile"); my $fh = Symbol::gensym(); $self->Fatal("Cannot write to $pidfile: $!") unless ( open( $fh, '>', $pidfile ) and ( print $fh "$$\n" ) and close($fh) ); } if ( my $dir = $self->{'chroot'} ) { $self->Debug("Changing root directory to $dir"); if ( !chroot($dir) ) { $self->Fatal("Cannot change root directory to $dir: $!"); } } if ( my $group = $self->{'group'} ) { $self->Debug("Changing GID to $group"); if ( $group !~ /^\d+$/ ) { if ( defined( my $gid = getgrnam($group) ) ) { $group = $gid; } else { $self->Fatal("Cannot determine gid of $group: $!"); } } $) = $group; # Set effective GID and supplementary groups # Use POSIX::setgid() to also set saved-set-group-ID, preventing # the process from regaining the original group via $) = 0. POSIX::setgid($group) or $self->Fatal("Failed to set GID to $group: $!"); if ( (split(' ', $)))[0] != $group ) { $self->Fatal("Failed to change effective GID to $group"); } } if ( my $user = $self->{'user'} ) { $self->Debug("Changing UID to $user"); if ( $user !~ /^\d+$/ ) { if ( defined( my $uid = getpwnam($user) ) ) { $user = $uid; } else { $self->Fatal("Cannot determine uid of $user: $!"); } } # Use POSIX::setuid() instead of $< = ($> = $user) to also set # saved-set-user-ID, preventing the process from regaining root # via $> = 0. POSIX::setuid($user) or $self->Fatal("Failed to set UID to $user: $!"); if ( $> != $user ) { $self->Fatal("Failed to change effective UID to $user"); } } if ( $self->{'childs'} ) { my $pid; my $childpids = $self->{'childpids'} = {}; for ( my $n = 0; $n < $self->{'childs'}; $n++ ) { $pid = fork(); die "Cannot fork: $!" unless defined $pid; if ( !$pid ) { #Child $self->{'mode'} = 'single'; last; } # Parent $childpids->{$pid} = 1; } if ($pid) { # Parent waits for childs in a loop, then exits ... # We could also terminate the parent process, but # if the parent is still running we can kill the # whole group by killing the childs. my $childpid; $exit = 0; $SIG{'TERM'} = sub { die }; $SIG{'INT'} = sub { die }; eval { do { $childpid = wait; delete $childpids->{$childpid}; $self->Debug("Child $childpid has exited"); } until ( $childpid <= 0 || $exit || keys(%$childpids) == 0 ); }; my @pids = keys %{ $self->{'childpids'} }; if (@pids) { $self->Debug( "kill TERM childs: " . join( ",", @pids ) ); kill 'TERM', @pids if @pids; # send a TERM to all childs } exit(0); } } my $time = $self->{'loop-timeout'} ? ( time() + $self->{'loop-timeout'} ) : 0; my $client; while ( !$self->Done() ) { undef $child_pid; my $rin = ''; vec( $rin, $self->{'socket'}->fileno(), 1 ) = 1; my ( $rout, $t ); if ($time) { my $tm = time(); $t = $time - $tm; $t = 0 if $t < 0; $self->Debug("Loop time: time=$time now=$tm, t=$t"); } my ($nfound) = select( $rout = $rin, undef, undef, $t ); if ( $nfound < 0 ) { if ( !$child_pid and ( $! != POSIX::EINTR() or !$self->{'catchint'} ) ) { $self->Fatal( "%s server failed to select(): %s", ref($self), $self->{'socket'}->error() || $! ); } } elsif ($nfound) { my $client = $self->{'socket'}->accept(); if ( !$client ) { if ( !$child_pid and ( $! != POSIX::EINTR() or !$self->{'catchint'} ) ) { $self->Error( "%s server failed to accept: %s", ref($self), $self->{'socket'}->error() || $! ); } } else { if ( $self->{'debug'} ) { my $from = $self->{'proto'} eq 'unix' ? 'Unix socket' : sprintf( '%s, port %s', # SE 19990917: display client data!! $client->peerhost(), $client->peerport() ); $self->Debug("Connection from $from"); } my $sth = $self->Clone($client); $self->Debug("Child clone: $sth\n"); $sth->ChildFunc('HandleChild') if $sth; if ( $self->{'mode'} ne 'single' ) { $self->ServClose($client); } } } if ($time) { my $t = time(); if ( $t >= $time ) { $time = $t; if ( $self->{'loop-child'} ) { $self->ChildFunc('Loop'); } else { $self->Loop(); } $time += $self->{'loop-timeout'}; } } } $self->Log( 'notice', "%s server terminating", ref($self) ); } sub Close { my $socket = shift->{'socket'}; $socket->close() if $socket; } sub ServClose { my $self = shift; my $socket = shift; $socket->close() if $socket; } 1; __END__ =for markdown [![testsuite](https://github.com/cpan-authors/Net-Daemon/actions/workflows/testsuite.yml/badge.svg)](https://github.com/cpan-authors/Net-Daemon/actions/workflows/testsuite.yml) =head1 NAME Net::Daemon - Perl extension for portable daemons =head1 SYNOPSIS # Create a subclass of Net::Daemon require Net::Daemon; package MyDaemon; @MyDaemon::ISA = qw(Net::Daemon); sub Run ($) { # This function does the real work; it is invoked whenever a # new connection is made. } =head1 DESCRIPTION Net::Daemon is an abstract base class for implementing portable server applications in a very simple way. The module is designed for Perl 5.006 and ithreads, but can work with fork() as well. The Net::Daemon class offers methods for the most common tasks a daemon needs: Starting up, logging, accepting clients, authorization, restricting its own environment for security and doing the true work. You only have to override those methods that aren't appropriate for you, but typically inheriting will safe you a lot of work anyways. =head2 Constructors $server = Net::Daemon->new($attr, $options); $connection = $server->Clone($socket); Two constructors are available: The B method is called upon startup and creates an object that will basically act as an anchor over the complete program. It supports command line parsing via L. Arguments of B are I<$attr>, an hash ref of attributes (see below) and I<$options> an array ref of options, typically command line arguments (for example B<\@ARGV>) that will be passed to B. The second constructor is B: It is called whenever a client connects. It receives the main server object as input and returns a new object. This new object will be passed to the methods that finally do the true work of communicating with the client. Communication occurs over the socket B<$socket>, B's argument. Note that B does I call B; it creates a shallow copy of the server object. If your subclass needs to initialize per-connection state, override the B method rather than checking for C<$self-E{'parent'}> inside B. B is called by B after the new object is created and blessed. The default implementation is a no-op. Possible object attributes and the corresponding command line arguments are: =over 4 =item I (B<--nocatchint>) On some systems, in particular Solaris, the functions accept(), read() and so on are not safe against interrupts by signals. For example, if the user raises a USR1 signal (as typically used to reread config files), then the function returns an error EINTR. If the I option is on (by default it is, use B<--nocatchint> to turn this off), then the package will ignore EINTR errors wherever possible. =item I (B<--chroot=dir>) (UNIX only) After doing a bind(), change root directory to the given directory by doing a chroot(). This is useful for security operations, but it restricts programming a lot. For example, you typically have to load external Perl extensions before doing a chroot(), or you need to create hard links to Unix sockets. This is typically done in the config file, see the --configfile option. See also the --group and --user options. If you don't know chroot(), think of an FTP server where you can see a certain directory tree only after logging in. =item I An array ref with a list of clients. Clients are hash refs, the attributes I (0 for denying access and 1 for permitting) and I, a Perl regular expression for the clients IP number or its host name. See L<"Access control"> below. =item I (B<--configfile=file>) Net::Daemon supports the use of config files. These files are assumed to contain a single hash ref that overrides the arguments of the new method. However, command line arguments in turn take precedence over the config file. See the L<"Config File"> section below for details on the config file. =item I (B<--debug>) Turn debugging mode on. Mainly this asserts that logging messages of level "debug" are created. =item I (B<--facility=mode>) (UNIX only) Facility to use for L. The default is B. =item I (B<--group=gid>) After doing a bind(), change the real and effective GID to the given. This is useful, if you want your server to bind to a privileged port (<1024), but don't want the server to execute as root. See also the --user option. GID's can be passed as group names or numeric values. =item I (B<--localaddr=ip>) By default a daemon is listening to any IP number that a machine has. This attribute allows to restrict the server to the given IP number. =item I (B<--localpath=path>) If you want to restrict your server to local services only, you'll prefer using Unix sockets, if available. In that case you can use this option for setting the path of the Unix socket being created. This option implies B<--proto=unix>. =item I (B<--localport=port>) This attribute sets the port on which the daemon is listening. It must be given somehow, as there's no default. =item I (B<--logfile=file>) By default logging messages will be written to the syslog (Unix) or to the event log (Windows NT). On other operating systems you need to specify a log file. The special value "STDERR" forces logging to stderr. =item I (B<--loop-child>) This option forces creation of a new child for loops. (See the I option.) By default the loops are serialized. =item I (B<--loop-timeout=secs>) Some servers need to take an action from time to time. For example the Net::Daemon::Spooler attempts to empty its spooling queue every 5 minutes. If this option is set to a positive value (zero being the default), then the server will call its Loop method every "loop-timeout" seconds. Don't trust too much on the precision of the interval: It depends on a number of factors, in particular the execution time of the Loop() method. The loop is implemented by using the I