From 0fca2f8691bab533b5e087ff9cf8b7bdc97bfa27 Mon Sep 17 00:00:00 2001 From: "deepin-community-bot[bot]" <156989552+deepin-community-bot[bot]@users.noreply.github.com> Date: Fri, 26 Dec 2025 01:56:09 +0000 Subject: [PATCH] feat: update libnet-server-perl to 2.014-1 --- .gitignore | 1 - Changes | 35 ++ MANIFEST | 41 +- MANIFEST.SKIP | 1 + META.json | 11 +- META.yml | 4 +- MYMETA.json | 53 +++ MYMETA.yml | 26 ++ Makefile.PL | 2 +- README | 8 +- bin/net-server | 4 +- debian/changelog | 52 +++ debian/control | 8 +- debian/copyright | 10 +- .../patches/Net-Server-2.009-rt130107.patch | 36 -- debian/patches/another-manpage-error.patch | 15 - .../fix-manpage-has-errors-from-pod2man.patch | 16 - debian/patches/series | 5 - debian/patches/spelling-error.patch | 424 ------------------ .../update-certs-to-use-2048-bits-key.patch | 244 ---------- debian/upstream/metadata | 3 +- debian/watch | 2 +- lib/Net/Server.pm | 107 +++-- lib/Net/Server.pod | 141 +++++- lib/Net/Server/Daemonize.pm | 22 +- lib/Net/Server/Fork.pm | 5 +- lib/Net/Server/HTTP.pm | 245 +++++++--- lib/Net/Server/INET.pm | 2 +- lib/Net/Server/Log/Log/Log4perl.pm | 4 +- lib/Net/Server/Log/Sys/Syslog.pm | 9 +- lib/Net/Server/MultiType.pm | 4 +- lib/Net/Server/Multiplex.pm | 6 +- lib/Net/Server/PSGI.pm | 29 +- lib/Net/Server/PreFork.pm | 10 +- lib/Net/Server/PreForkSimple.pm | 17 +- lib/Net/Server/Proto.pm | 49 +- lib/Net/Server/Proto/SSL.pm | 36 +- lib/Net/Server/Proto/SSLEAY.pm | 35 +- lib/Net/Server/Proto/TCP.pm | 15 +- lib/Net/Server/Proto/UDP.pm | 12 +- lib/Net/Server/Proto/UNIX.pm | 20 +- lib/Net/Server/Proto/UNIXDGRAM.pm | 8 +- lib/Net/Server/SIG.pm | 8 +- lib/Net/Server/Single.pm | 2 +- lib/Net/Server/Thread.pm | 244 ++++++++++ t/NetServerTest.pm | 23 +- t/Options.t | 2 + t/Port_Configuration.t | 14 +- t/SSLEAY_test.t | 56 +-- t/SSL_test.t | 96 ++-- t/Server_BASE.t | 10 +- t/Server_Fork.t | 6 +- t/Server_INET.t | 6 +- t/Server_MultiType.t | 10 +- t/Server_Multiplex.t | 8 +- t/Server_PreFork.t | 6 +- t/Server_PreForkSimple.t | 6 +- t/Server_Single.t | 2 +- t/Server_Thread.t | 55 +++ t/Server_http.t | 20 +- t/Server_psgi.t | 6 +- t/UDP_test.t | 6 +- t/UNIX_test.t | 28 +- t/self_signed.crt | 20 + t/self_signed.key | 28 ++ 65 files changed, 1295 insertions(+), 1144 deletions(-) delete mode 100644 .gitignore create mode 100644 MYMETA.json create mode 100644 MYMETA.yml delete mode 100644 debian/patches/Net-Server-2.009-rt130107.patch delete mode 100644 debian/patches/another-manpage-error.patch delete mode 100644 debian/patches/fix-manpage-has-errors-from-pod2man.patch delete mode 100644 debian/patches/spelling-error.patch delete mode 100644 debian/patches/update-certs-to-use-2048-bits-key.patch create mode 100644 lib/Net/Server/Thread.pm create mode 100644 t/Server_Thread.t create mode 100644 t/self_signed.crt create mode 100644 t/self_signed.key diff --git a/.gitignore b/.gitignore deleted file mode 100644 index 224e7f0..0000000 --- a/.gitignore +++ /dev/null @@ -1 +0,0 @@ -.pc/ diff --git a/Changes b/Changes index f97bbb9..0156233 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,40 @@ Revision history for Perl extension Net::Server. +2.014 Mar 14 2023 + - Apply patch to Fork for UDP + - Fix tests on perls without threads + +2.013 Dec 03 2022 + - Update MANIFEST for missing file + +2.012 Dec 02 2022 + - More code/documentation typo fixes + - Add /simple routes to HTTP and PSGI echo handlers for doing static request samples. + - Fix PSGI header handling that was broken in 2.011 + +2.011 Dec 01 2022 + - Default to IO::Socket::IP with continued fallback to IO::Socket::INET6 + - Add double_reverse_lookups configuration and code + - Cleanup hostname lookup under both IO::Socket::IP and IO::Socket::INET6 + - Change SSL to use IO::Socket::SSL SSL_startHandshake + - Fix semaphore release + - Update various POD issues + - Finally add register_child method called if a child process is started. + - Bugfix Net::Server::PSGI + - Allow groups to be separated by , + - Allow . in usernames and groups + - Allow space in config file values + - Retro-actively acknowlege that 2.008 changed default Net::Server::HTTP type to PreFork (and update docs) + - Fix Location bounce with other status set + - Return status 400 under request_denied_hook in Net::Server::HTTP + +2.010 Mar 22 2021 + - Add SSL_verify_callback + - Fix SSLEAY connect spinloop + - Various pod typos + - Allow for logging to STDOUT for HTTP + - Add PATCH verb to HTTP + 2.009 Aug 09 2017 - Several long awaited fixes - Log when a child exits abnormally. RT #86815 diff --git a/MANIFEST b/MANIFEST index 9fadd74..4bb30ab 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,21 +1,13 @@ -# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.008. -Changes -INSTALL -LICENSE -MANIFEST -MANIFEST.SKIP -META.json -META.yml -Makefile.PL -README bin/net-server +Changes dist.ini -examples/LoadTester.pl examples/connection_test.pl examples/httpd +examples/LoadTester.pl examples/samplechat.pl examples/sigtest.pl examples/udp_server.pl +INSTALL lib/Net/Server.pm lib/Net/Server.pod lib/Net/Server/Daemonize.pm @@ -24,9 +16,8 @@ lib/Net/Server/HTTP.pm lib/Net/Server/INET.pm lib/Net/Server/Log/Log/Log4perl.pm lib/Net/Server/Log/Sys/Syslog.pm -lib/Net/Server/MultiType.pm lib/Net/Server/Multiplex.pm -lib/Net/Server/PSGI.pm +lib/Net/Server/MultiType.pm lib/Net/Server/PreFork.pm lib/Net/Server/PreForkSimple.pm lib/Net/Server/Proto.pm @@ -36,23 +27,37 @@ lib/Net/Server/Proto/TCP.pm lib/Net/Server/Proto/UDP.pm lib/Net/Server/Proto/UNIX.pm lib/Net/Server/Proto/UNIXDGRAM.pm +lib/Net/Server/PSGI.pm lib/Net/Server/SIG.pm lib/Net/Server/Single.pm +lib/Net/Server/Thread.pm +LICENSE +Makefile.PL +MANIFEST +MANIFEST.SKIP +META.json +META.yml +MYMETA.json +MYMETA.yml +README t/NetServerTest.pm t/Options.t t/Options.t.conf t/Port_Configuration.t -t/SSLEAY_test.t -t/SSL_test.t +t/self_signed.crt +t/self_signed.key t/Server_BASE.t t/Server_Fork.t +t/Server_http.t t/Server_INET.t -t/Server_MultiType.t t/Server_Multiplex.t +t/Server_MultiType.t t/Server_PreFork.t t/Server_PreForkSimple.t -t/Server_Single.t -t/Server_http.t t/Server_psgi.t +t/Server_Single.t +t/Server_Thread.t +t/SSL_test.t +t/SSLEAY_test.t t/UDP_test.t t/UNIX_test.t diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index f2b4200..e3feb41 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -13,3 +13,4 @@ blib .cvsignore .gitignore .build +.git/ \ No newline at end of file diff --git a/META.json b/META.json index 4a0979a..56aee3e 100644 --- a/META.json +++ b/META.json @@ -4,13 +4,13 @@ "Paul Seamons and Rob Brown " ], "dynamic_config" : 1, - "generated_by" : "ExtUtils::MakeMaker version 7.1002, CPAN::Meta::Converter version 2.150005", + "generated_by" : "ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", - "version" : "2" + "version" : 2 }, "name" : "Net-Server", "no_index" : { @@ -36,9 +36,12 @@ "Socket" : "0", "Time::HiRes" : "0" } + }, + "test" : { + "requires" : {} } }, "release_status" : "stable", - "version" : "2.009", - "x_serialization_backend" : "JSON::PP version 2.27300_01" + "version" : "2.014", + "x_serialization_backend" : "JSON::PP version 4.06" } diff --git a/META.yml b/META.yml index c8905f9..9204243 100644 --- a/META.yml +++ b/META.yml @@ -6,7 +6,7 @@ build_requires: {} configure_requires: ExtUtils::MakeMaker: '6.30' dynamic_config: 1 -generated_by: 'ExtUtils::MakeMaker version 7.1002, CPAN::Meta::Converter version 2.150005' +generated_by: 'ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -22,5 +22,5 @@ requires: POSIX: '0' Socket: '0' Time::HiRes: '0' -version: '2.009' +version: '2.014' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/MYMETA.json b/MYMETA.json new file mode 100644 index 0000000..3d9233a --- /dev/null +++ b/MYMETA.json @@ -0,0 +1,53 @@ +{ + "abstract" : "Extensible Perl internet server", + "author" : [ + "Paul Seamons and Rob Brown " + ], + "dynamic_config" : 0, + "generated_by" : "Dist::Zilla version 5.008, CPAN::Meta::Converter version 2.133380, CPAN::Meta::Converter version 2.150010", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Net-Server", + "prereqs" : { + "build" : { + "requires" : {} + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "6.30" + } + }, + "runtime" : { + "requires" : { + "File::Temp" : "0", + "IO::Socket" : "0", + "POSIX" : "0", + "Socket" : "0", + "Time::HiRes" : "0" + } + }, + "test" : { + "requires" : {} + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "mailto" : "bug-project@rt.cpan.org", + "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Server" + }, + "homepage" : "https://github.com/rhandom/perl-net-server", + "repository" : { + "type" : "git", + "url" : "git://github.com/rhandom/perl-net-server.git", + "web" : "https://github.com/rhandom/perl-net-server" + } + }, + "version" : "2.013", + "x_serialization_backend" : "JSON::PP version 4.06" +} diff --git a/MYMETA.yml b/MYMETA.yml new file mode 100644 index 0000000..2d26813 --- /dev/null +++ b/MYMETA.yml @@ -0,0 +1,26 @@ +--- +abstract: 'Extensible Perl internet server' +author: + - 'Paul Seamons and Rob Brown ' +build_requires: {} +configure_requires: + ExtUtils::MakeMaker: '6.30' +dynamic_config: 0 +generated_by: 'Dist::Zilla version 5.008, CPAN::Meta::Converter version 2.133380, 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-Server +requires: + File::Temp: '0' + IO::Socket: '0' + POSIX: '0' + Socket: '0' + Time::HiRes: '0' +resources: + bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Server + homepage: https://github.com/rhandom/perl-net-server + repository: git://github.com/rhandom/perl-net-server.git +version: '2.013' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/Makefile.PL b/Makefile.PL index 7790c2d..a35680d 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -29,7 +29,7 @@ my %WriteMakefileArgs = ( "Time::HiRes" => 0 }, "TEST_REQUIRES" => {}, - "VERSION" => "2.009", + "VERSION" => "2.014", "test" => { "TESTS" => "t/*.t" } diff --git a/README b/README index f1d4e31..20525dc 100644 --- a/README +++ b/README @@ -807,12 +807,12 @@ DEFAULT ARGUMENTS FOR Net::Server server is still running as root. Defaults to undef. user - Userid or username to become after the bind process has occured. + Userid or username to become after the bind process has occurred. Defaults to "nobody." If you would like the server to run as root, you will have to specify "user" equal to "root". group - Groupid or groupname to become after the bind process has occured. + Groupid or groupname to become after the bind process has occurred. Defaults to "nobody." If you would like the server to run as root, you will have to specify "group" equal to "root". @@ -1239,7 +1239,7 @@ HOOKS "$self->pre_loop_hook()" This hook occurs after chroot, change of user, and change of group - has occured. It allows for preparation before looping begins. + has occurred. It allows for preparation before looping begins. "$self->can_read_hook()" This hook occurs after a socket becomes readible on an @@ -1365,7 +1365,7 @@ OTHER METHODS Called when log_file is set to 'Sys::Syslog' and an error occurs while writing to the syslog. It is passed two arguments, the value of $@, and an arrayref containing the arguments that were passed to - the log method when the error occured. + the log method when the error occurred. "$self->log" Parameters are a log_level and a message. diff --git a/bin/net-server b/bin/net-server index ce01d28..26c94d6 100755 --- a/bin/net-server +++ b/bin/net-server @@ -1,4 +1,4 @@ -#!/usr/bin/env perl +#!/usr/bin/perl package net_server; @@ -62,7 +62,7 @@ net-server - Base Net::Server starting module The net-server program gives a simple way to test out code and try port connection parameters. Though the running server can be robust -enough for full tim use, it is anticipated that this binary will just +enough for production, it is anticipated that this binary will just be used for basic testing of net-server ports, acting as a simple echo server, or for running development scripts as CGI. diff --git a/debian/changelog b/debian/changelog index b9c9a2b..5c415c8 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,55 @@ +libnet-server-perl (2.014-1) unstable; urgency=medium + + * Import upstream version 2.014. + * Drop udp_fork.patch, merged upstream. + + -- gregor herrmann Sun, 11 Jun 2023 17:38:10 +0200 + +libnet-server-perl (2.013-2) unstable; urgency=medium + + * Update debian/upstream/metadata. + * Update standards version to 4.6.2, no changes needed. + * Add patch to fix UDP receiving in Fork server. + Thanks to Dominique Fournier for the bug report. (Closes: #1031712) + * Update years of packaging copyright. + + -- gregor herrmann Tue, 21 Feb 2023 16:47:29 +0100 + +libnet-server-perl (2.013-1) unstable; urgency=medium + + * Import upstream version 2.013. + 2.011 adds 'double_reverse_lookups' configuration and code as a fix for + "CVE-2013-1841: Improper reverse DNS matching check for the given + hostname". + This can be enabled by setting 'reverse_lookups=double' or + 'double_reverse_lookups=1'. Cf. Net::Server(3pm) and CPAN RT#83909. + (Closes: #702914) + * debian/watch: use uscan macros. + * Drop patches applied upstream. + * Update years of upstream copyright. + * Refresh test and runtime dependencies. + + -- gregor herrmann Sat, 03 Dec 2022 15:52:00 +0100 + +libnet-server-perl (2.010-1) unstable; urgency=medium + + [ gregor herrmann ] + * Import upstream version 2.010. + * Drop update-certs-to-use-2048-bits-key.patch, fixed upstream. + * Refresh spelling-error.patch (one mistake was fixed). + * Drop another-manpage-error.patch, merged upstream. + * Bump debhelper-compat to 13. + + [ Debian Janitor ] + * Update standards version to 4.6.0, no changes needed. + + [ gregor herrmann ] + * Update years of packaging copyright. + * Declare compliance with Debian Policy 4.6.1. + * Add another typo fix to spelling-error.patch. + + -- gregor herrmann Sat, 20 Aug 2022 18:22:55 +0200 + libnet-server-perl (2.009-2) unstable; urgency=medium [ Salvatore Bonaccorso ] diff --git a/debian/control b/debian/control index fbeda38..b4d9543 100644 --- a/debian/control +++ b/debian/control @@ -6,15 +6,17 @@ Uploaders: Alexander Wirt , Section: perl Testsuite: autopkgtest-pkg-perl Priority: optional -Build-Depends: debhelper-compat (= 12) +Build-Depends: debhelper-compat (= 13) Build-Depends-Indep: libcgi-pm-perl , libio-multiplex-perl , libio-socket-inet6-perl , + libio-socket-ip-perl , libio-socket-ssl-perl , libnet-ssleay-perl , + libsocket-perl , libsocket6-perl , perl -Standards-Version: 4.5.0 +Standards-Version: 4.6.2 Vcs-Browser: https://salsa.debian.org/perl-team/modules/packages/libnet-server-perl Vcs-Git: https://salsa.debian.org/perl-team/modules/packages/libnet-server-perl.git Homepage: https://metacpan.org/release/Net-Server @@ -27,9 +29,11 @@ Depends: ${misc:Depends}, libcgi-pm-perl, libio-multiplex-perl, libio-socket-inet6-perl, + libio-socket-ip-perl, libio-socket-ssl-perl, libnet-cidr-perl, libnet-ssleay-perl, + libsocket-perl, libsocket6-perl Suggests: liblog-log4perl-perl Description: extensible, general perl server engine diff --git a/debian/copyright b/debian/copyright index 1e0a64f..be6e2fc 100644 --- a/debian/copyright +++ b/debian/copyright @@ -4,19 +4,19 @@ Upstream-Contact: Paul Seamons (paul@seamons.com) and Rob Brown (bbb@cpan.org) Source: https://metacpan.org/release/Net-Server Files: * -Copyright: 2001-2017, Paul T Seamons - 2001-2017, Rob Brown +Copyright: 2001-2022, Paul T Seamons + 2001-2022, Rob Brown License: Artistic or GPL-1+ Files: lib/Net/Server/Daemonize.pm -Copyright: 2001-2017, Paul T Seamons - 2001-2017, Jeremy Howard +Copyright: 2001-2022, Paul T Seamons + 2001-2022, Jeremy Howard License: Artistic or GPL-1+ Files: debian/* Copyright: 2002-2003, Luca Filipozzi 2004-2011, Carsten Wolff - 2011-2020, gregor herrmann + 2011-2023, gregor herrmann 2012, Daniel Kahn Gillmor 2012, intrigeri 2013-2018, Xavier Guimard diff --git a/debian/patches/Net-Server-2.009-rt130107.patch b/debian/patches/Net-Server-2.009-rt130107.patch deleted file mode 100644 index e0ac2cf..0000000 --- a/debian/patches/Net-Server-2.009-rt130107.patch +++ /dev/null @@ -1,36 +0,0 @@ -Description: Fix warning about Sys::Syslog version. -Origin: CPAN RT -Bug: https://rt.cpan.org/Public/Bug/Display.html?id=130107 -Forwarded: https://rt.cpan.org/Public/Bug/Display.html?id=130107 -Bug-Debian: https://bugs.debian.org/922765 -Author: twata_1@yahoo.co.jp -Reviewed-by: gregor herrmann -Last-Update: 2020-04-03 - ---- a/lib/Net/Server/Log/Sys/Syslog.pm -+++ b/lib/Net/Server/Log/Sys/Syslog.pm -@@ -25,6 +25,9 @@ - my ($class, $server) = @_; - my $prop = $server->{'server'}; - -+ my $syslog_version = $Sys::Syslog::VERSION; -+ $syslog_version =~ s/_.*//; -+ - $server->configure({ - syslog_logsock => \$prop->{'syslog_logsock'}, - syslog_ident => \$prop->{'syslog_ident'}, -@@ -36,12 +39,12 @@ - # do nothing - assume they have what they want - } else { - if (! defined $prop->{'syslog_logsock'}) { -- $prop->{'syslog_logsock'} = ($Sys::Syslog::VERSION < 0.15) ? 'unix' : ''; -+ $prop->{'syslog_logsock'} = ($syslog_version < 0.15) ? 'unix' : ''; - } - if ($prop->{'syslog_logsock'} =~ /^(|native|tcp|udp|unix|inet|stream|console)$/) { - $prop->{'syslog_logsock'} = $1; - } else { -- $prop->{'syslog_logsock'} = ($Sys::Syslog::VERSION < 0.15) ? 'unix' : ''; -+ $prop->{'syslog_logsock'} = ($syslog_version < 0.15) ? 'unix' : ''; - } - } - diff --git a/debian/patches/another-manpage-error.patch b/debian/patches/another-manpage-error.patch deleted file mode 100644 index 92a5e93..0000000 --- a/debian/patches/another-manpage-error.patch +++ /dev/null @@ -1,15 +0,0 @@ -Description: Missing blank line in POD -Author: Xavier Guimard -Forwarded: https://github.com/rhandom/perl-net-server/pull/11 -Last-Update: 2017-10-26 - ---- libnet-server-perl-2.009.orig/lib/Net/Server/PreFork.pm -+++ libnet-server-perl-2.009/lib/Net/Server/PreFork.pm -@@ -678,6 +678,7 @@ This hook is called when a dead child is - A child is considered dead when the pid does no longer exist. - This hook could be used to cleanup possible temporary files - or locks left over by a dead child. -+ - =back - - =head1 HOT DEPLOY diff --git a/debian/patches/fix-manpage-has-errors-from-pod2man.patch b/debian/patches/fix-manpage-has-errors-from-pod2man.patch deleted file mode 100644 index 3b05a38..0000000 --- a/debian/patches/fix-manpage-has-errors-from-pod2man.patch +++ /dev/null @@ -1,16 +0,0 @@ -Description: Fix errors in manpage from pod2man -Origin: vendor -Bug: https://rt.cpan.org/Public/Bug/Display.html?id=95773 -Forwarded: https://rt.cpan.org/Public/Ticket/Attachment/1364688/724527/fix-manpage-has-errors-from-pod2man.patch -Author: Salvatore Bonaccorso -Last-Update: 2014-05-18 - -=================================================================== ---- a/lib/Net/Server.pod -+++ b/lib/Net/Server.pod -@@ -1,3 +1,5 @@ -+=encoding utf8 -+ - =head1 NAME - - Net::Server - Extensible, general Perl server engine diff --git a/debian/patches/series b/debian/patches/series index f89ae78..de786c4 100644 --- a/debian/patches/series +++ b/debian/patches/series @@ -1,6 +1 @@ -update-certs-to-use-2048-bits-key.patch -spelling-error.patch correct-SIG-confusion.patch -fix-manpage-has-errors-from-pod2man.patch -another-manpage-error.patch -Net-Server-2.009-rt130107.patch diff --git a/debian/patches/spelling-error.patch b/debian/patches/spelling-error.patch deleted file mode 100644 index 6c3ec5f..0000000 --- a/debian/patches/spelling-error.patch +++ /dev/null @@ -1,424 +0,0 @@ -Description: fix errors in POD -Bug: https://rt.cpan.org/Ticket/Display.html?id=85052 -Forwarded: https://rt.cpan.org/Ticket/Display.html?id=85052 [not latest version] -Author: intrigeri -Reviewed-By: Xavier Guimard - gregor herrmann -Last-Update: 2017-10-26 - ---- a/lib/Net/Server.pod -+++ b/lib/Net/Server.pod -@@ -194,7 +194,7 @@ - waiting for connections. Once a connection is received, the - Net::Server will accept on the socket and will store the result (the - client connection) in $self-E{server}-E{client}. This --property is a Socket blessed into the the IO::Socket classes. UDP -+property is a Socket blessed into the IO::Socket classes. UDP - servers are slightly different in that they will perform a B - instead of an B. - -@@ -374,7 +374,7 @@ - validation. - - Some emails have asked why we use this "template" method. The idea is --that you are creating the the data structure to store the values in, -+that you are creating the data structure to store the values in, - and you are also creating a way to get the values into the data - structure. The template is the way to get the values to the servers - data structure. One of the possibilities (that probably isn't used -@@ -633,7 +633,7 @@ - L. See L. Configuration passed to new - or run may be either a scalar containing a single host or an arrayref - of hosts - if the hosts array is shorter than the ports array, the --last host entry will be used to augment the hosts arrary to the size -+last host entry will be used to augment the hosts array to the size - of the ports array. - - If an IPv4 address is passed, an IPv4 socket will be created. If an -@@ -664,7 +664,7 @@ - host => '*/IPv*', # same (any IPv6 or IPv4) - - ipv => 4, -- host => '*', # any local IPv4 interfaces interfaces -+ host => '*', # any local IPv4 interfaces - - - =item proto -@@ -677,7 +677,7 @@ - passed to new or run may be either a scalar containing a single proto - or an arrayref of protos - if the protos array is shorter than the - ports array, the last proto entry will be used to augment the protos --arrary to the size of the ports array. -+array to the size of the ports array. - - Additionally the proto may also contain the ipv specification. - -@@ -845,13 +845,13 @@ - - =item user - --Userid or username to become after the bind process has occured. -+Userid or username to become after the bind process has occurred. - Defaults to "nobody." If you would like the server to run as root, - you will have to specify C equal to "root". - - =item group - --Groupid or groupname to become after the bind process has occured. -+Groupid or groupname to become after the bind process has occurred. - Defaults to "nobody." If you would like the server to run as root, - you will have to specify C equal to "root". - -@@ -894,7 +894,7 @@ - - Boolean. Default undef (not set). If set, the parent will not - attempt to close child processes if the parent receives a SIG HUP. --The parent will rebind the the open port and begin tracking a fresh -+The parent will rebind the open port and begin tracking a fresh - set of children. - - Children of a Fork server will exit after their current request. -@@ -1158,12 +1158,12 @@ - - =item C<$self-Ebind> - --This method actually binds to the inialized sockets (or rebinds if the -+This method actually binds to the initialized sockets (or rebinds if the - server has been HUPed). - - =item C<$self-Epost_bind> - --During this method priveleges are dropped. The INT, TERM, and QUIT -+During this method privileges are dropped. The INT, TERM, and QUIT - signals are set to run server_close. Sig PIPE is set to IGNORE. Sig - CHLD is set to sig_chld. And sig HUP is set to call sig_hup. - -@@ -1323,11 +1323,11 @@ - =item C<$self-Epre_loop_hook()> - - This hook occurs after chroot, change of user, and change of group has --occured. It allows for preparation before looping begins. -+occurred. It allows for preparation before looping begins. - - =item C<$self-Ecan_read_hook()> - --This hook occurs after a socket becomes readible on an -+This hook occurs after a socket becomes readable on an - accept_multi_port request (accept_multi_port is used if there are - multiple bound ports to accept on, or if the "multi_port" - configuration parameter is set to true). This hook is intended to -@@ -1337,7 +1337,7 @@ - handles or adding them to the IO::Socket. Care must be used in how - much occurs during the can_read_hook as a long response time will - result in the server being susceptible to DOS attacks. A return value --of true indicates that the Server should not pass the readible handle -+of true indicates that the Server should not pass the readable handle - on to the post_accept and process_request phases. - - It is generally suggested that other avenues be pursued for sending -@@ -1470,7 +1470,7 @@ - Called when log_file is set to 'Sys::Syslog' and an error occurs while - writing to the syslog. It is passed two arguments, the value of $@, - and an arrayref containing the arguments that were passed to the log --method when the error occured. -+method when the error occurred. - - =item C<$self-Elog> - -@@ -1657,7 +1657,7 @@ - - Thanks to Carl Lewis for suggesting "-" in user names. - --Thanks to Slaven Rezic for suggesing Reuse => 1 in Proto::UDP. -+Thanks to Slaven Rezic for suggesting Reuse => 1 in Proto::UDP. - - Thanks to Tim Watt for adding udp_broadcast to Proto::UDP. - -@@ -1697,7 +1697,7 @@ - systems supporting flock. Rob also suggested not closing STDIN/STDOUT - but instead reopening them to /dev/null to prevent spurious warnings. - Also suggested short circuit in post_accept if in UDP. Also for --cleaning up some of the child managment code of PreFork. -+cleaning up some of the child management code of PreFork. - - Thanks to Mark Martinec for suggesting additional log messages for - failure during accept. -@@ -1717,7 +1717,7 @@ - Thanks to Steven Lembark for pointing out that no_client_stdout wasn't - working with the Multiplex server. - --Thanks to Peter Beckman for suggesting allowing Sys::SysLog keyworks -+Thanks to Peter Beckman for suggesting allowing Sys::SysLog keywords - be passed through the ->log method and for suggesting we allow more - types of characters through in syslog_ident. Also to Peter Beckman - for pointing out that a poorly setup localhost will cause tests to -@@ -1782,7 +1782,7 @@ - IPv6 going. - - Thanks to the munin developers and Nicolai Langfeldt for hosting the --development verion of Net::Server for so long and for fixes to the -+development version of Net::Server for so long and for fixes to the - allow_deny checking for IPv6 addresses. - - Thanks to Tatsuhiko Miyagawa for feedback, and for suggesting adding ---- a/lib/Net/Server/PSGI.pm -+++ b/lib/Net/Server/PSGI.pm -@@ -202,7 +202,7 @@ - Net::Server::PSGI takes Net::Server::HTTP one level farther. It - begins with base type MultiType defaulting to Net::Server::Fork. It - is easy to change it to any of the other Net::Server flavors by --passing server_type => $other_flavor in the server configurtation. -+passing server_type => $other_flavor in the server configuration. - The port has also been defaulted to port 80 - but could easily be - changed to another through the server configuration. You can also - very easily add ssl by including, proto=>"ssl" and provide a ---- a/lib/Net/Server/PreFork.pm -+++ b/lib/Net/Server/PreFork.pm -@@ -636,7 +636,7 @@ - - Process flow follows Net::Server until the loop phase. At this point - C are forked and wait for connections. When a child --accepts a connection, finishs processing a client, or exits, it relays -+accepts a connection, finishes processing a client, or exits, it relays - that information to the parent, which keeps track and makes sure there - are enough children to fulfill C, C, - C, and C. -@@ -652,7 +652,7 @@ - - This hook occurs at the top of run_n_children which is called each - time the server goes to start more child processes. This gives the --parent to do a little of its own accountting (as desired). Idea for -+parent to do a little of its own accounting (as desired). Idea for - this hook came from James FitzGibbon. - - =item C<$self-Eparent_read_hook()> ---- a/lib/Net/Server/Daemonize.pm -+++ b/lib/Net/Server/Daemonize.pm -@@ -309,7 +309,7 @@ - - =item check_pid_file - --Arguments are pid_file (full path to pid_file). Checks for existance -+Arguments are pid_file (full path to pid_file). Checks for existence - of pid_file. If file exists, open it and determine if the process - that created it is still running. This is done first by checking for - a /proc file system and second using a "ps" command (BSD syntax). (If ---- a/lib/Net/Server/Proto.pm -+++ b/lib/Net/Server/Proto.pm -@@ -411,7 +411,7 @@ - - In addition to being able to specify IPV as a separate parameter, ipv may - also be passed as a part of the host, as part of the port, as part of the protocol --or may be specified via $ENV{'IPV'}. The order of precidence is as follows: -+or may be specified via $ENV{'IPV'}. The order of precedence is as follows: - - 1) Explicit IPv4 or IPv6 address - wins - 2) ipv specified in port ---- a/lib/Net/Server/HTTP.pm -+++ b/lib/Net/Server/HTTP.pm -@@ -660,7 +660,7 @@ - Net::Server::HTTP begins with base type MultiType defaulting to - Net::Server::Fork. It is easy to change it to any of the other - Net::Server flavors by passing server_type => $other_flavor in the --server configurtation. The port has also been defaulted to port 80 - -+server configuration. The port has also been defaulted to port 80 - - but could easily be changed to another through the server - configuration. You can also very easily add ssl by including, - proto=>"ssl" and provide a SSL_cert_file and SSL_key_file. -@@ -745,7 +745,7 @@ - =item c - - Called at the end of post_process_request. The default method looks --for the default access_log_format and checks if logging was initilized -+for the default access_log_format and checks if logging was initialized - during _init_access_log. If both of these exist, the http_request_info - is formatted using http_log_format and the result is logged. - ---- a/lib/Net/Server/PreForkSimple.pm -+++ b/lib/Net/Server/PreForkSimple.pm -@@ -435,16 +435,16 @@ - IPC::Semaphore (thanks to Bennett Todd) for giving some sample code. - The pipe option reads on a pipe to choose the next. the flock option - should be the most bulletproof while the pipe option should be the --most portable. (Flock is able to reliquish the block if the process -+most portable. (Flock is able to relinquish the block if the process - dies between accept on the socket and reading of the client connection - - semaphore and pipe do not). An option of none will not perform - any serialization. If "none" is passed and there are multiple ports --then a the default serialization will be used insted of "none." -+then a the default serialization will be used instead of "none." - - =item lock_file - - Filename to use in flock serialized accept in order to serialize the --accept sequece between the children. This will default to a generated -+accept sequence between the children. This will default to a generated - temporary filename. If default value is used the lock_file will be - removed when the server closes. - -@@ -513,7 +513,7 @@ - - Process flow follows Net::Server until the loop phase. At this point - C are forked and wait for connections. When a child --accepts a connection, finishs processing a client, or exits, it relays -+accepts a connection, finishes processing a client, or exits, it relays - that information to the parent, which keeps track and makes sure there - are always C running. - -@@ -528,14 +528,14 @@ - - This hook occurs at the top of run_n_children which is called each - time the server goes to start more child processes. This gives the --parent to do a little of its own accountting (as desired). Idea for -+parent to do a little of its own accounting (as desired). Idea for - this hook came from James FitzGibbon. - - =item C<$self-Echild_init_hook()> - --This hook takes place immeditately after the child process forks from -+This hook takes place immediately after the child process forks from - the parent and before the child begins accepting connections. It is --intended for any addiotional chrooting or other security measures. It -+intended for any additional chrooting or other security measures. It - is suggested that all perl modules be used by this point, so that the - most shared memory possible is used. - ---- a/lib/Net/Server/SIG.pm -+++ b/lib/Net/Server/SIG.pm -@@ -133,7 +133,7 @@ - signal will short circuit the select. Using this concept, - Net::Server::SIG does the least work possible (changing one bit from 0 - to 1). And depends upon the actual processing of the signals to take --place immediately after the the select call via the "check_sigs" -+place immediately after the select call via the "check_sigs" - function. See the example shown above and also see the sigtest.pl - script located in the examples directory of this distribution. - -@@ -157,9 +157,9 @@ - - =item C - --Checks to see if any registered signals have occured. If so, it will -+Checks to see if any registered signals have occurred. If so, it will - play the registered code ref for that signal. Return value is array --containing any SIGNAL names that had occured. -+containing any SIGNAL names that had occurred. - - =item C - ---- a/lib/Net/Server/Log/Log/Log4perl.pm -+++ b/lib/Net/Server/Log/Log/Log4perl.pm -@@ -97,7 +97,7 @@ - - =item log4perl_poll - --If set to a value, will initialise with Log::Log4perl::init_and_watch -+If set to a value, will initialize with Log::Log4perl::init_and_watch - with this polling value. This can also be the string "HUP" to re-read - the log4perl_conf when a HUP signal is received. If set to 0, no - polling is done. See L for more details. ---- a/lib/Net/Server/Proto/TCP.pm -+++ b/lib/Net/Server/Proto/TCP.pm -@@ -184,7 +184,7 @@ - =item C - - Returns an object with parameters suitable for eventual creation of --a IO::Socket::INET object listining on UDP. -+a IO::Socket::INET object listening on UDP. - - =item C - ---- a/lib/Net/Server/Proto/UNIX.pm -+++ b/lib/Net/Server/Proto/UNIX.pm -@@ -132,11 +132,11 @@ - SOCK_STREAM socket type. See L. - - Any sockets created during startup will be chown'ed to the user and --group specified in the starup arguments. -+group specified in the startup arguments. - - =head1 PARAMETERS - --The following paramaters may be specified in addition to normal -+The following parameters may be specified in addition to normal - command line parameters for a Net::Server. See L for - more information on reading arguments. - ---- a/lib/Net/Server/Proto/SSL.pm -+++ b/lib/Net/Server/Proto/SSL.pm -@@ -235,7 +235,7 @@ - - =head1 SYNOPSIS - --Until this release, it was preferrable to use the Net::Server::Proto::SSLEAY -+Until this release, it was preferable to use the Net::Server::Proto::SSLEAY - module. Recent versions include code that overcomes original limitations. - - See L. -@@ -299,7 +299,7 @@ - If you know that your server will only need IPv4 (which is the default - for Net::Server), you can load IO::Socket::SSL in inet4 mode which - will prevent it from using Socket6 and IO::Socket::INET6 since they --would represent additional and unsued overhead. -+would represent additional and unused overhead. - - use IO::Socket::SSL qw(inet4); - use base qw(Net::Server::Fork); ---- a/lib/Net/Server/Proto/SSLEAY.pm -+++ b/lib/Net/Server/Proto/SSLEAY.pm -@@ -519,7 +519,7 @@ - - This module has reliably been used in situations receiving millions of - hits on a single box per day. If anybody has any successes or ideas --for improvment under SSLEAY, please email . -+for improvement under SSLEAY, please email . - - Protocol module for Net::Server. This module implements a secure - socket layer over tcp (also known as SSL). See L. ---- a/lib/Net/Server/Proto/UNIXDGRAM.pm -+++ b/lib/Net/Server/Proto/UNIXDGRAM.pm -@@ -88,11 +88,11 @@ - SOCK_DGRAM socket type. See L. - - Any sockets created during startup will be chown'ed to the user and --group specified in the starup arguments. -+group specified in the startup arguments. - - =head1 PARAMETERS - --The following paramaters may be specified in addition to normal -+The following parameters may be specified in addition to normal - command line parameters for a Net::Server. See L for - more information on reading arguments. - ---- a/lib/Net/Server/Proto/UDP.pm -+++ b/lib/Net/Server/Proto/UDP.pm -@@ -117,7 +117,7 @@ - - =head1 PARAMETERS - --The following paramaters may be specified in addition to -+The following parameters may be specified in addition to - normal command line parameters for a Net::Server. See - L for more information on reading arguments. - -@@ -155,7 +155,7 @@ - =item C - - Returns an object with parameters suitable for eventual creation of --a IO::Socket::INET object listining on UDP. -+a IO::Socket::INET object listening on UDP. - - =item C - ---- a/lib/Net/Server/Multiplex.pm -+++ b/lib/Net/Server/Multiplex.pm -@@ -311,7 +311,7 @@ - deamonization and pid tracking, and restartability -SIGHUP) and some - nice features of IO::Multiplex (automatic buffered IO and - per-file-handle objects) and combines them for an easy-to-use --interace. -+interface. - - See examples/samplechat.pl distributed with Net::Server for a simple - chat server that uses several of these features. diff --git a/debian/patches/update-certs-to-use-2048-bits-key.patch b/debian/patches/update-certs-to-use-2048-bits-key.patch deleted file mode 100644 index a4c202d..0000000 --- a/debian/patches/update-certs-to-use-2048-bits-key.patch +++ /dev/null @@ -1,244 +0,0 @@ -Description: Update certificates to use 2048 bits key - The small key size was causing a FTBFS in Ubuntu, where this error has been - reported: SSL_CTX_use_certificate:ee key too small. -Forwarded: no -Author: Lucas Kanashiro -Reviewed-by: gregor herrmann -Last-Update: 2020-04-03 - ---- a/t/SSL_test.t -+++ b/t/SSL_test.t -@@ -16,34 +16,88 @@ - - my $pem = << 'PEM'; # this certificate is invalid, please only use for testing - -----BEGIN CERTIFICATE----- --MIICKTCCAZICCQDFxHnOjdmTTjANBgkqhkiG9w0BAQUFADBZMQswCQYDVQQGEwJB --VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0 --cyBQdHkgTHRkMRIwEAYDVQQDDAlsb2NhbGhvc3QwHhcNMTIwMTE0MTgzMjMwWhcN --NzUxMTE0MTIwNDE0WjBZMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0 --ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMRIwEAYDVQQDDAls --b2NhbGhvc3QwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBAKLGfQantHdi/0cd --eoOHRbWKChpI/g84hU8SnwmrSMZR0x76vDLKMDYohISoKxRPx6j2M2x3P4K+kEJm --C5H9iGdD9p9ljGnRdkGp5yYeuwWfePRb4AOwP5qgQtEb0OctFIMjcAIIAw/lsnUs --hGnom0+uA9W2H63PgO0o4qiVAn7NAgMBAAEwDQYJKoZIhvcNAQEFBQADgYEATDGA --dYRl5wpsYcpLgNzu0M4SENV0DAE2wNTZ4LIR1wxHbcxdgzMhjp0wwfVQBTJFNqWu --DbeIFt4ghPMsUQKmMc4+og2Zyll8qev8oNgWQneKjDAEKKpzdvUoRZyGx1ZocGzi --S4LDiMd4qhD+GGePcHwmR8x/okoq58xZO/+Qygc= -+MIIFazCCA1OgAwIBAgIUA8Xm/EUFCN3yY1jqQqfivcJPAxcwDQYJKoZIhvcNAQEL -+BQAwRTELMAkGA1UEBhMCQVUxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoM -+GEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDAeFw0yMDA0MDExMzA5MDRaFw00NzA4 -+MTgxMzA5MDRaMEUxCzAJBgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEw -+HwYDVQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQwggIiMA0GCSqGSIb3DQEB -+AQUAA4ICDwAwggIKAoICAQDH7zYyow2nvRQeqa8dPtJCi65OcDvWUmL4Fazxas56 -+kYHv3gdEAVcxrW1AFhziDNvrsLiWE9WfFoav9xEPtXvDsY9+2rsNoiTUzPgvYaFG -+5Uz43sz4gqxbndxWTtMbpFA0zrhXnAHm4EUM2ykU04KQXHMGFTAHb+c7ARKMg7+B -+H6j4XiSEZenWRqh9bE71wIMs2gvsRuVzTZrobzYHSrHJYyhjBoEmWahm9PFAfkvF -+tZl9hmaz0jPYDmHdzqusMT3lNvZucGn76Z+8KCFmnMb8lGmfMBbumHpjiJ53DLGK -+KEhR7kK/86t9lnAdvcIPlDTJPk/xHoxXhbHcKtEnnKat1a3/THSTrGT96OYlpjm/ -+JwjbLoFGjT9D06oajWY/lt/CeAQy76qRHqJVJyZ2j9TXw3tEQvawTxPMPIE+iKfs -+78OG4d/j9M1R4tkPQdwD8VCVJB7e6+2HlbPai/djMUqkj2stMZ3sgv5ehHae0xth -+BM29I/TdOLfgP8S3EGqVVYcyRAWKYvGYwgGEvocmiUgXjowOsOt1h5a+CD/Qfodg -+6qfilPpD2aZYqcPSn5Htqp+pkjMpWC1aMflxQbxvXcJFTzGbc4HslqJhbLXe/fwR -+2scOg8ZEt8Y94sF/7Y+GLDaJnV8ObmdMttzx7HWdQMtPkFvo4/h7fseG/bA4/SoX -+xQIDAQABo1MwUTAdBgNVHQ4EFgQUntWE93uYLQ+bbKqFswQyG0aqZkowHwYDVR0j -+BBgwFoAUntWE93uYLQ+bbKqFswQyG0aqZkowDwYDVR0TAQH/BAUwAwEB/zANBgkq -+hkiG9w0BAQsFAAOCAgEAt2+PAKmobIRb4+5vGgfhLzPW97yCi03szpfe9mUwmeFN -+EcLXRl1t2lyLc/Ucn8pSUTfEv1WT96JYbTurUkM1iLi+y5jJeS8qAA59Me1HcPvF -+vMy7MG/Fam0wU/wEC0wzWwPDDIUG5PM9rk9vkBmZ44TltE//i2wbh8Zo7z1nNUDy -+ms6K8pQjoG7SJefHbCjyqYrm17pb2/ClIZuZWs8rvot/9zslKiDKNK4ewdY0iONy -+q861PZ+TqdTpxm8ouBkpQA2ggIZNcfwO/KVr6nqBVp072dXlaSRiBD+z4CNnGb4b -+Gz931Iev0zTKY3m9uL8jNO36BRB4paIaDexeYxK01L2mFHkCZOukhYOB4qli8+4y -+/vlOaMuuhVeQNdjjq2t1k1wP1+1QjHdyimenDYFnvzTnu7hBr5Wgs0/sxCBug9aJ -+/v6rW/kItPbLmgoo6Q9sJWEzJBjUzacaus/7HYa2XMQ6qq+dP+HMcaCtDCzbKgyJ -+w1EMMd4f/uZeinE5BDljhSuJLl6vVP0WyBR3CYQdbpQlc1Koansr/j97OyZtwTmY -+6+xIh1WATcvrzSVJiLJb9zTcOg8SXtAHpAkpEGQk1kDiJUP+3AN2uOT3KrlxSjCg -+skbx0I2wRdK4UvTr3WAakSjdmxMoHzAyoZ1OqBiz9ndGWWY8i5acAlcgFIfa730= - -----END CERTIFICATE----- -------BEGIN RSA PRIVATE KEY----- --MIICXAIBAAKBgQCixn0Gp7R3Yv9HHXqDh0W1igoaSP4POIVPEp8Jq0jGUdMe+rwy --yjA2KISEqCsUT8eo9jNsdz+CvpBCZguR/YhnQ/afZYxp0XZBqecmHrsFn3j0W+AD --sD+aoELRG9DnLRSDI3ACCAMP5bJ1LIRp6JtPrgPVth+tz4DtKOKolQJ+zQIDAQAB --AoGASXDmvhbyfJ8k8HAjc66XzBWxAzUFs9Zbh1aufM1UM259o8+bFAtXf0f+ql+5 --uBtaySf0Aa8374SNT/f8pmzOmpiXMvYRz8Z5Gc6JYpYd/PrCoSCGtP+NdCvk7Y5c --eUmmpiEto4+fgCAKrtqc5jm8eBWn/yNhQNDBVJ9qX+kXQOECQQDVBLvBZaECSMTm --djKuPlZ93cmyI7g+TURTl2N08fz4xQVVbo5+AV0GsEZupBpTgrHpLTk8gKP/nfdR --9KWZldbZAkEAw55+SqrVTv4cI0fMvC0t8Wl46zTkY9tK65TGnbO1DbTQh9qs+NwH --+v3uu47ef5w/73xLtDjQouz//0z5rgF3FQJAfrmOKQOYwY8g9CmlBNu5ALAM6Zku --ZoH4//G0DUJYyHYNMkHPK08MVIpRnEisELpTtPBeeIvfBJapJ2xvh+sIIQJASeY4 --I5EB4EOS8akQKQ6QSqDjs0dZ+HdBiFm95pmbDkB+frQXoDPPN/xyEZzZZS/r31b/ --amgEOWh7FUFJGXkoOQJBALfOgsiss0lASlOXAg1rwO4m2OaDiaEde01PLcSjIaKl --Qfbzc7ZYF+fGDsHHlD5Kgj1CGaWCVVHqCv4UHSrA/gM= -------END RSA PRIVATE KEY----- -+-----BEGIN PRIVATE KEY----- -+MIIJQwIBADANBgkqhkiG9w0BAQEFAASCCS0wggkpAgEAAoICAQDH7zYyow2nvRQe -+qa8dPtJCi65OcDvWUmL4Fazxas56kYHv3gdEAVcxrW1AFhziDNvrsLiWE9WfFoav -+9xEPtXvDsY9+2rsNoiTUzPgvYaFG5Uz43sz4gqxbndxWTtMbpFA0zrhXnAHm4EUM -+2ykU04KQXHMGFTAHb+c7ARKMg7+BH6j4XiSEZenWRqh9bE71wIMs2gvsRuVzTZro -+bzYHSrHJYyhjBoEmWahm9PFAfkvFtZl9hmaz0jPYDmHdzqusMT3lNvZucGn76Z+8 -+KCFmnMb8lGmfMBbumHpjiJ53DLGKKEhR7kK/86t9lnAdvcIPlDTJPk/xHoxXhbHc -+KtEnnKat1a3/THSTrGT96OYlpjm/JwjbLoFGjT9D06oajWY/lt/CeAQy76qRHqJV -+JyZ2j9TXw3tEQvawTxPMPIE+iKfs78OG4d/j9M1R4tkPQdwD8VCVJB7e6+2HlbPa -+i/djMUqkj2stMZ3sgv5ehHae0xthBM29I/TdOLfgP8S3EGqVVYcyRAWKYvGYwgGE -+vocmiUgXjowOsOt1h5a+CD/Qfodg6qfilPpD2aZYqcPSn5Htqp+pkjMpWC1aMflx -+QbxvXcJFTzGbc4HslqJhbLXe/fwR2scOg8ZEt8Y94sF/7Y+GLDaJnV8ObmdMttzx -+7HWdQMtPkFvo4/h7fseG/bA4/SoXxQIDAQABAoICAAbYhf6N3rXTn5C9NqXFtOVa -+awl8hk/8Wi8sbtOFWLSRruVLsOv/L8EfsxHyr+J9ljonvupEm5fq6Ym05/yltisp -+NUSesLDy0FgI/KaCrUcEKvKKjnIj50rryNObt1bG9YgZW+6EBPymyTZ7epif9WSE -+Bdw7dX2Ls1st2ji9eh0tvFdkwdNWuf8ARFynDL0VbmhmvunEM68TBS7YP/1X7WZ7 -+4rIhUuLBRybfVDNlH6sRYMQPigy2MdhABdHWdcJbnUbv7tgxOS/K/BExPpOI4rdb -+TZKJzv80cVxfHS3uXVXhszg69EYmTcTrFcOu76og5P3PCGW1KhEFHuXvAWJd1scl -+cPPztRlnE3/2gpedbnl2X6bGBjRRnW8qT5A253I03fHT9wYJuoTkoz4wjLAZjojG -+ytjRn0ZN9zWfBIb1Tz2M5uiIepye9hZrRNWWegAJlUkHyJ4xMTx3A7m2ZPDj+JqD -+01rXZ0MmEJTs1Y0LGzGFT55GzZVUJDWunrNGmhoZkWg6TJpfF73nIHUJNjK8qPTo -+Q3Y2r2eHGZvbzdd+mhd+i+1ol8CW3+yqBge6EWDkYR/01rBfoNdiJBWkzT/qnQvi -+UIvsC6I++kXK0KIhtO7+5q9vpx8IZBtggFUtRvNaYRrvunalW4rSyxzHd6lX7N9F -+C8P1on/atUxUDlv3gF8xAoIBAQD2lbpwQPAzAYhjowowdmzTN0wKba5RTLj++Wvp -+is//gliX/MauUBdXzkVxWgpODr4znsuAH8eQXKADw1wI1iCozBbapQp934r3c6JJ -+LwFRKRUalYWMwckp7IAo7k7Vu2u8Y8k/T61uKLWdgIClo2zYBYpfdYpCOPV6SIMF -+L1dS5M8pac9CkM2NbcEMbZcXykjZmrZidIrDkI3kTPqUjSN+pguUxoJg+I+gUEzQ -+FQj1VJR5SViJk49GMDs0vo+frOAW2kc2RdvvPnuPpplyEySjcMqZtx+vDmVsRAjK -+AFXaPSy5liGCg9j2N9Ab9R6w9JkB3QXM4XFBvQHar6rdP4l/AoIBAQDPkX5IO0T+ -+iIgALd+tpyfKywoohzwTlzAM9qsqDmr+BX28Vphu7DOZLhd9zFlKmZHhlj3XXRP0 -+Y7Y8JbO+ir2okYNDkA6s7EAl5C/m7RDRvj8d4huPm1rptBq3J0dcwgwOI2Dk1QdC -+CrWEkYLzfObiRUd7gDjBYt9/KsK52Q04iYphs2ItXtrZf6rdFQC+MIJcX35ko9dQ -+cYs+rY3DdwjfEVwwcMTShE/jRMcN4PKnX5QwVzIyZeJPU4DJlNYs3Iaa292GwQ0p -+YnDrYqv0Dy2Tx5/TaEdQdbRX8wGtz+pZresrRMacPN8t8WM7O38Qug5ouwH19DBu -+pjzh5aEUA1i7AoIBABE9aqmKgMCwLL76mS3GOdmSlihsfrGEcbKx8Y+EewJcNKF7 -+tNBfHSKwcz53kxzd/wJQ6d1tW2CGeVGKCRc9EU975WUoANHIHUkrtn7zYF4yRx1y -+ssGiktPxiwxRjQV4cxHa0CkzAucexYPbhiMOh/+ac5A1AZObs932z+I+6xYKlUlJ -+8omu4hAvSj36M4QgSnOcU4ASsdj2dFUv5J0aOQ8TwN+H+XmaJ0CIHLa3oca1QSQx -+spT70hqQKLOJVzVMuuYeILh0renOLoleln/ZQsiCjEeu+/IbSZAGOa8V0urNOCFJ -+k9IyMasVP+GUg67PixsMPumSIX79HfISMhoB5TUCggEBAMVULBm/Pvg8FA8XjW4p -+W0sPe7jL1/FH6gZo+pAg5NZZog9Kw9+v7d3SU8LkYn7pQCaWDnSPqEjOApFrxlV+ -+0I9QxtmUOl9quhFLvb5r4XGEy7w9GLaNmwBSmJNGZDFqyMsoFxV08FF4nNhK/ZM9 -+SsIR2sMuQsaWmKLso/LKxibZmxUG1G8NnkDnfihvryUgOM5YenBy0l9HknkjxYHt -+yCFI/7uNeZAo+Um2OQaYtBcqZlcOjkobUerYF7eMJ5C+lbjjDNbu8PRHAdLFG3QK -+eenj/a2dlS6It8pk21PCNajMDqYz3BzsQcALm6rUBRiByPEH1/VbEDAhGgAnrdq4 -+08ECggEBAIO+7DW3vfitCetSYk5oJAVNN+9OMs4SR8/2cbuMc9a/Chc6O/rj58EP -+yH4wSifpnesoZzCah3Ryy+RTYXEwNV65Xopd+J/ANt9MjP8c4j0hY3n/BzpI4aN3 -+dpQyXWBbsECZAl0B0LKA2mLMAo72SQYXK9F62Zl6LVoT27wfsADYTqM9GcFagp6/ -+fzKQWdLgRps34ysE8PSYkXaIfq/Q0uv1xvDMdW5GpNxcfkikZXQJnuUlxKvdf7Zi -+bdoZvJJ6MPNNoCZBOM+WSitRculiJHfeEMU5VQXpXJby0YEt+Gc4q3Zs1tv3aOqF -+k+WUbp8EAMRqFNRRLcPzcux5vlLvOtw= -+-----END PRIVATE KEY----- - PEM - - my ($pem_fh, $pem_filename) = ---- a/t/SSLEAY_test.t -+++ b/t/SSLEAY_test.t -@@ -21,34 +21,88 @@ - - my $pem = << 'PEM'; # this certificate is invalid, please only use for testing - -----BEGIN CERTIFICATE----- --MIICKTCCAZICCQDFxHnOjdmTTjANBgkqhkiG9w0BAQUFADBZMQswCQYDVQQGEwJB --VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0 --cyBQdHkgTHRkMRIwEAYDVQQDDAlsb2NhbGhvc3QwHhcNMTIwMTE0MTgzMjMwWhcN --NzUxMTE0MTIwNDE0WjBZMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0 --ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMRIwEAYDVQQDDAls --b2NhbGhvc3QwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBAKLGfQantHdi/0cd --eoOHRbWKChpI/g84hU8SnwmrSMZR0x76vDLKMDYohISoKxRPx6j2M2x3P4K+kEJm --C5H9iGdD9p9ljGnRdkGp5yYeuwWfePRb4AOwP5qgQtEb0OctFIMjcAIIAw/lsnUs --hGnom0+uA9W2H63PgO0o4qiVAn7NAgMBAAEwDQYJKoZIhvcNAQEFBQADgYEATDGA --dYRl5wpsYcpLgNzu0M4SENV0DAE2wNTZ4LIR1wxHbcxdgzMhjp0wwfVQBTJFNqWu --DbeIFt4ghPMsUQKmMc4+og2Zyll8qev8oNgWQneKjDAEKKpzdvUoRZyGx1ZocGzi --S4LDiMd4qhD+GGePcHwmR8x/okoq58xZO/+Qygc= -+MIIFazCCA1OgAwIBAgIUA8Xm/EUFCN3yY1jqQqfivcJPAxcwDQYJKoZIhvcNAQEL -+BQAwRTELMAkGA1UEBhMCQVUxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoM -+GEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDAeFw0yMDA0MDExMzA5MDRaFw00NzA4 -+MTgxMzA5MDRaMEUxCzAJBgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEw -+HwYDVQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQwggIiMA0GCSqGSIb3DQEB -+AQUAA4ICDwAwggIKAoICAQDH7zYyow2nvRQeqa8dPtJCi65OcDvWUmL4Fazxas56 -+kYHv3gdEAVcxrW1AFhziDNvrsLiWE9WfFoav9xEPtXvDsY9+2rsNoiTUzPgvYaFG -+5Uz43sz4gqxbndxWTtMbpFA0zrhXnAHm4EUM2ykU04KQXHMGFTAHb+c7ARKMg7+B -+H6j4XiSEZenWRqh9bE71wIMs2gvsRuVzTZrobzYHSrHJYyhjBoEmWahm9PFAfkvF -+tZl9hmaz0jPYDmHdzqusMT3lNvZucGn76Z+8KCFmnMb8lGmfMBbumHpjiJ53DLGK -+KEhR7kK/86t9lnAdvcIPlDTJPk/xHoxXhbHcKtEnnKat1a3/THSTrGT96OYlpjm/ -+JwjbLoFGjT9D06oajWY/lt/CeAQy76qRHqJVJyZ2j9TXw3tEQvawTxPMPIE+iKfs -+78OG4d/j9M1R4tkPQdwD8VCVJB7e6+2HlbPai/djMUqkj2stMZ3sgv5ehHae0xth -+BM29I/TdOLfgP8S3EGqVVYcyRAWKYvGYwgGEvocmiUgXjowOsOt1h5a+CD/Qfodg -+6qfilPpD2aZYqcPSn5Htqp+pkjMpWC1aMflxQbxvXcJFTzGbc4HslqJhbLXe/fwR -+2scOg8ZEt8Y94sF/7Y+GLDaJnV8ObmdMttzx7HWdQMtPkFvo4/h7fseG/bA4/SoX -+xQIDAQABo1MwUTAdBgNVHQ4EFgQUntWE93uYLQ+bbKqFswQyG0aqZkowHwYDVR0j -+BBgwFoAUntWE93uYLQ+bbKqFswQyG0aqZkowDwYDVR0TAQH/BAUwAwEB/zANBgkq -+hkiG9w0BAQsFAAOCAgEAt2+PAKmobIRb4+5vGgfhLzPW97yCi03szpfe9mUwmeFN -+EcLXRl1t2lyLc/Ucn8pSUTfEv1WT96JYbTurUkM1iLi+y5jJeS8qAA59Me1HcPvF -+vMy7MG/Fam0wU/wEC0wzWwPDDIUG5PM9rk9vkBmZ44TltE//i2wbh8Zo7z1nNUDy -+ms6K8pQjoG7SJefHbCjyqYrm17pb2/ClIZuZWs8rvot/9zslKiDKNK4ewdY0iONy -+q861PZ+TqdTpxm8ouBkpQA2ggIZNcfwO/KVr6nqBVp072dXlaSRiBD+z4CNnGb4b -+Gz931Iev0zTKY3m9uL8jNO36BRB4paIaDexeYxK01L2mFHkCZOukhYOB4qli8+4y -+/vlOaMuuhVeQNdjjq2t1k1wP1+1QjHdyimenDYFnvzTnu7hBr5Wgs0/sxCBug9aJ -+/v6rW/kItPbLmgoo6Q9sJWEzJBjUzacaus/7HYa2XMQ6qq+dP+HMcaCtDCzbKgyJ -+w1EMMd4f/uZeinE5BDljhSuJLl6vVP0WyBR3CYQdbpQlc1Koansr/j97OyZtwTmY -+6+xIh1WATcvrzSVJiLJb9zTcOg8SXtAHpAkpEGQk1kDiJUP+3AN2uOT3KrlxSjCg -+skbx0I2wRdK4UvTr3WAakSjdmxMoHzAyoZ1OqBiz9ndGWWY8i5acAlcgFIfa730= - -----END CERTIFICATE----- -------BEGIN RSA PRIVATE KEY----- --MIICXAIBAAKBgQCixn0Gp7R3Yv9HHXqDh0W1igoaSP4POIVPEp8Jq0jGUdMe+rwy --yjA2KISEqCsUT8eo9jNsdz+CvpBCZguR/YhnQ/afZYxp0XZBqecmHrsFn3j0W+AD --sD+aoELRG9DnLRSDI3ACCAMP5bJ1LIRp6JtPrgPVth+tz4DtKOKolQJ+zQIDAQAB --AoGASXDmvhbyfJ8k8HAjc66XzBWxAzUFs9Zbh1aufM1UM259o8+bFAtXf0f+ql+5 --uBtaySf0Aa8374SNT/f8pmzOmpiXMvYRz8Z5Gc6JYpYd/PrCoSCGtP+NdCvk7Y5c --eUmmpiEto4+fgCAKrtqc5jm8eBWn/yNhQNDBVJ9qX+kXQOECQQDVBLvBZaECSMTm --djKuPlZ93cmyI7g+TURTl2N08fz4xQVVbo5+AV0GsEZupBpTgrHpLTk8gKP/nfdR --9KWZldbZAkEAw55+SqrVTv4cI0fMvC0t8Wl46zTkY9tK65TGnbO1DbTQh9qs+NwH --+v3uu47ef5w/73xLtDjQouz//0z5rgF3FQJAfrmOKQOYwY8g9CmlBNu5ALAM6Zku --ZoH4//G0DUJYyHYNMkHPK08MVIpRnEisELpTtPBeeIvfBJapJ2xvh+sIIQJASeY4 --I5EB4EOS8akQKQ6QSqDjs0dZ+HdBiFm95pmbDkB+frQXoDPPN/xyEZzZZS/r31b/ --amgEOWh7FUFJGXkoOQJBALfOgsiss0lASlOXAg1rwO4m2OaDiaEde01PLcSjIaKl --Qfbzc7ZYF+fGDsHHlD5Kgj1CGaWCVVHqCv4UHSrA/gM= -------END RSA PRIVATE KEY----- -+-----BEGIN PRIVATE KEY----- -+MIIJQwIBADANBgkqhkiG9w0BAQEFAASCCS0wggkpAgEAAoICAQDH7zYyow2nvRQe -+qa8dPtJCi65OcDvWUmL4Fazxas56kYHv3gdEAVcxrW1AFhziDNvrsLiWE9WfFoav -+9xEPtXvDsY9+2rsNoiTUzPgvYaFG5Uz43sz4gqxbndxWTtMbpFA0zrhXnAHm4EUM -+2ykU04KQXHMGFTAHb+c7ARKMg7+BH6j4XiSEZenWRqh9bE71wIMs2gvsRuVzTZro -+bzYHSrHJYyhjBoEmWahm9PFAfkvFtZl9hmaz0jPYDmHdzqusMT3lNvZucGn76Z+8 -+KCFmnMb8lGmfMBbumHpjiJ53DLGKKEhR7kK/86t9lnAdvcIPlDTJPk/xHoxXhbHc -+KtEnnKat1a3/THSTrGT96OYlpjm/JwjbLoFGjT9D06oajWY/lt/CeAQy76qRHqJV -+JyZ2j9TXw3tEQvawTxPMPIE+iKfs78OG4d/j9M1R4tkPQdwD8VCVJB7e6+2HlbPa -+i/djMUqkj2stMZ3sgv5ehHae0xthBM29I/TdOLfgP8S3EGqVVYcyRAWKYvGYwgGE -+vocmiUgXjowOsOt1h5a+CD/Qfodg6qfilPpD2aZYqcPSn5Htqp+pkjMpWC1aMflx -+QbxvXcJFTzGbc4HslqJhbLXe/fwR2scOg8ZEt8Y94sF/7Y+GLDaJnV8ObmdMttzx -+7HWdQMtPkFvo4/h7fseG/bA4/SoXxQIDAQABAoICAAbYhf6N3rXTn5C9NqXFtOVa -+awl8hk/8Wi8sbtOFWLSRruVLsOv/L8EfsxHyr+J9ljonvupEm5fq6Ym05/yltisp -+NUSesLDy0FgI/KaCrUcEKvKKjnIj50rryNObt1bG9YgZW+6EBPymyTZ7epif9WSE -+Bdw7dX2Ls1st2ji9eh0tvFdkwdNWuf8ARFynDL0VbmhmvunEM68TBS7YP/1X7WZ7 -+4rIhUuLBRybfVDNlH6sRYMQPigy2MdhABdHWdcJbnUbv7tgxOS/K/BExPpOI4rdb -+TZKJzv80cVxfHS3uXVXhszg69EYmTcTrFcOu76og5P3PCGW1KhEFHuXvAWJd1scl -+cPPztRlnE3/2gpedbnl2X6bGBjRRnW8qT5A253I03fHT9wYJuoTkoz4wjLAZjojG -+ytjRn0ZN9zWfBIb1Tz2M5uiIepye9hZrRNWWegAJlUkHyJ4xMTx3A7m2ZPDj+JqD -+01rXZ0MmEJTs1Y0LGzGFT55GzZVUJDWunrNGmhoZkWg6TJpfF73nIHUJNjK8qPTo -+Q3Y2r2eHGZvbzdd+mhd+i+1ol8CW3+yqBge6EWDkYR/01rBfoNdiJBWkzT/qnQvi -+UIvsC6I++kXK0KIhtO7+5q9vpx8IZBtggFUtRvNaYRrvunalW4rSyxzHd6lX7N9F -+C8P1on/atUxUDlv3gF8xAoIBAQD2lbpwQPAzAYhjowowdmzTN0wKba5RTLj++Wvp -+is//gliX/MauUBdXzkVxWgpODr4znsuAH8eQXKADw1wI1iCozBbapQp934r3c6JJ -+LwFRKRUalYWMwckp7IAo7k7Vu2u8Y8k/T61uKLWdgIClo2zYBYpfdYpCOPV6SIMF -+L1dS5M8pac9CkM2NbcEMbZcXykjZmrZidIrDkI3kTPqUjSN+pguUxoJg+I+gUEzQ -+FQj1VJR5SViJk49GMDs0vo+frOAW2kc2RdvvPnuPpplyEySjcMqZtx+vDmVsRAjK -+AFXaPSy5liGCg9j2N9Ab9R6w9JkB3QXM4XFBvQHar6rdP4l/AoIBAQDPkX5IO0T+ -+iIgALd+tpyfKywoohzwTlzAM9qsqDmr+BX28Vphu7DOZLhd9zFlKmZHhlj3XXRP0 -+Y7Y8JbO+ir2okYNDkA6s7EAl5C/m7RDRvj8d4huPm1rptBq3J0dcwgwOI2Dk1QdC -+CrWEkYLzfObiRUd7gDjBYt9/KsK52Q04iYphs2ItXtrZf6rdFQC+MIJcX35ko9dQ -+cYs+rY3DdwjfEVwwcMTShE/jRMcN4PKnX5QwVzIyZeJPU4DJlNYs3Iaa292GwQ0p -+YnDrYqv0Dy2Tx5/TaEdQdbRX8wGtz+pZresrRMacPN8t8WM7O38Qug5ouwH19DBu -+pjzh5aEUA1i7AoIBABE9aqmKgMCwLL76mS3GOdmSlihsfrGEcbKx8Y+EewJcNKF7 -+tNBfHSKwcz53kxzd/wJQ6d1tW2CGeVGKCRc9EU975WUoANHIHUkrtn7zYF4yRx1y -+ssGiktPxiwxRjQV4cxHa0CkzAucexYPbhiMOh/+ac5A1AZObs932z+I+6xYKlUlJ -+8omu4hAvSj36M4QgSnOcU4ASsdj2dFUv5J0aOQ8TwN+H+XmaJ0CIHLa3oca1QSQx -+spT70hqQKLOJVzVMuuYeILh0renOLoleln/ZQsiCjEeu+/IbSZAGOa8V0urNOCFJ -+k9IyMasVP+GUg67PixsMPumSIX79HfISMhoB5TUCggEBAMVULBm/Pvg8FA8XjW4p -+W0sPe7jL1/FH6gZo+pAg5NZZog9Kw9+v7d3SU8LkYn7pQCaWDnSPqEjOApFrxlV+ -+0I9QxtmUOl9quhFLvb5r4XGEy7w9GLaNmwBSmJNGZDFqyMsoFxV08FF4nNhK/ZM9 -+SsIR2sMuQsaWmKLso/LKxibZmxUG1G8NnkDnfihvryUgOM5YenBy0l9HknkjxYHt -+yCFI/7uNeZAo+Um2OQaYtBcqZlcOjkobUerYF7eMJ5C+lbjjDNbu8PRHAdLFG3QK -+eenj/a2dlS6It8pk21PCNajMDqYz3BzsQcALm6rUBRiByPEH1/VbEDAhGgAnrdq4 -+08ECggEBAIO+7DW3vfitCetSYk5oJAVNN+9OMs4SR8/2cbuMc9a/Chc6O/rj58EP -+yH4wSifpnesoZzCah3Ryy+RTYXEwNV65Xopd+J/ANt9MjP8c4j0hY3n/BzpI4aN3 -+dpQyXWBbsECZAl0B0LKA2mLMAo72SQYXK9F62Zl6LVoT27wfsADYTqM9GcFagp6/ -+fzKQWdLgRps34ysE8PSYkXaIfq/Q0uv1xvDMdW5GpNxcfkikZXQJnuUlxKvdf7Zi -+bdoZvJJ6MPNNoCZBOM+WSitRculiJHfeEMU5VQXpXJby0YEt+Gc4q3Zs1tv3aOqF -+k+WUbp8EAMRqFNRRLcPzcux5vlLvOtw= -+-----END PRIVATE KEY----- - PEM - - my ($pem_fh, $pem_filename) = diff --git a/debian/upstream/metadata b/debian/upstream/metadata index bc1c251..b60b6a6 100644 --- a/debian/upstream/metadata +++ b/debian/upstream/metadata @@ -1,5 +1,6 @@ --- Archive: CPAN +Bug-Database: https://github.com/rhandom/perl-net-server/issues +Bug-Submit: https://github.com/rhandom/perl-net-server/issues/new Repository: https://github.com/rhandom/perl-net-server.git -Bug-Database: https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Server Repository-Browse: https://github.com/rhandom/perl-net-server diff --git a/debian/watch b/debian/watch index 17dfbea..b3a9583 100644 --- a/debian/watch +++ b/debian/watch @@ -1,2 +1,2 @@ version=4 -https://metacpan.org/release/Net-Server .*Net-Server-([\d\.]+)\.(?:tar\.gz|tar|tgz)$ +https://metacpan.org/release/Net-Server .*/Net-Server-v?@ANY_VERSION@@ARCHIVE_EXT@$ diff --git a/lib/Net/Server.pm b/lib/Net/Server.pm index 9a3f614..72c3cd4 100644 --- a/lib/Net/Server.pm +++ b/lib/Net/Server.pm @@ -3,7 +3,7 @@ # Net::Server # ABSTRACT: Extensible Perl internet server # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -29,7 +29,7 @@ use Net::Server::Proto (); use Net::Server::Daemonize qw(check_pid_file create_pid_file safe_fork get_uid get_gid set_uid set_gid); -our $VERSION = '2.009'; +our $VERSION = '2.014'; sub new { my $class = shift || die "Missing class"; @@ -86,7 +86,7 @@ sub _initialize { my $self = shift; my $prop = $self->{'server'} ||= {}; - $self->commandline($self->_get_commandline) if ! eval { $self->commandline }; # save for a HUP + $self->commandline($self->_get_commandline) if ! eval { local $SIG{__DIE__}; $self->commandline }; # save for a HUP $self->configure_hook; # user customizable hook $self->configure; # allow for reading of commandline, program, and configuration file parameters @@ -143,7 +143,7 @@ sub post_configure { } } - if (! $prop->{'_is_inet'}) { # completetly daemonize by closing STDIN, STDOUT (should be done before fork) + if (! $prop->{'_is_inet'}) { # completetely daemonize by closing STDIN, STDOUT (should be done before fork) if ($prop->{'setsid'} || length($prop->{'log_file'})) { open(STDIN, '<', '/dev/null') || die "Cannot read /dev/null [$!]"; open(STDOUT, '>', '/dev/null') || die "Cannot write /dev/null [$!]"; @@ -180,6 +180,10 @@ sub post_configure { # make sure that allow and deny look like array refs $prop->{$_} = [] for grep {! ref $prop->{$_}} qw(allow deny cidr_allow cidr_deny); + + $prop->{'reverse_lookups'} ||= 1 if $prop->{'double_reverse_lookups'}; + $prop->{'double_reverse_lookups'} = $1 || $prop->{'double_reverse_lookups'} || 1 + if $prop->{'reverse_lookups'} && $prop->{'reverse_lookups'} =~ /^(?:double|2)(.*)$/i; } sub initialize_logging { @@ -191,7 +195,15 @@ sub initialize_logging { } # pluggable logging - if ($prop->{'log_file'} =~ /^([a-zA-Z]\w*(?:::[a-zA-Z]\w*)*)$/) { + if (my $code = $prop->{'log_function'}) { + if (ref $code ne 'CODE') { + require Scalar::Util; + die "Passed log_function $code was not a valid method of server, or was not a code object\n" if ! $self->can($code); + my $copy = $self; + $prop->{'log_function'} = sub { $copy->$code(@_) }; + Scalar::Util::weaken($copy); + } + } elsif ($prop->{'log_file'} =~ /^([a-zA-Z]\w*(?:::[a-zA-Z]\w*)*)$/) { my $pkg = "Net::Server::Log::$prop->{'log_file'}"; (my $file = "$pkg.pm") =~ s|::|/|g; if (eval { require $file }) { @@ -338,8 +350,8 @@ sub post_bind { # secure the process and background it if (! defined $prop->{'group'}) { $self->log(1, "Group Not Defined. Defaulting to EGID '$)'"); $prop->{'group'} = $); - } elsif ($prop->{'group'} =~ /^([\w-]+(?: [\w-]+)*)$/) { - $prop->{'group'} = eval { get_gid($1) }; + } elsif ($prop->{'group'} =~ /^([\w.-]+(?:[ ,][\w.-]+)*)$/) { + $prop->{'group'} = eval { get_gid($1) }; $self->fatal(my $e = $@) if $@; } else { $self->fatal("Invalid group \"$prop->{'group'}\""); @@ -348,7 +360,7 @@ sub post_bind { # secure the process and background it if (! defined $prop->{'user'}) { $self->log(1, "User Not Defined. Defaulting to EUID '$>'"); $prop->{'user'} = $>; - } elsif ($prop->{'user'} =~ /^([\w-]+)$/) { + } elsif ($prop->{'user'} =~ /^([\w.-]+)$/) { $prop->{'user'} = eval { get_uid($1) }; $self->fatal(my $e = $@) if $@; } else { @@ -510,7 +522,7 @@ sub get_client_info { my $client = shift || $prop->{'client'}; if ($client->NS_proto =~ /^UNIX/) { - delete @$prop{qw(sockaddr sockport peeraddr peerport peerhost)}; + delete @$prop{qw(sockaddr sockport peeraddr peerport peerhost peerhost_rev)}; $self->log(3, $self->log_time." CONNECT ".$client->NS_proto." Socket: \"".$client->NS_port."\"") if $prop->{'log_level'} && 3 <= $prop->{'log_level'}; return; } @@ -541,18 +553,24 @@ sub get_client_info { @{ $prop }{qw(peeraddr peerhost peerport)} = ('0.0.0.0', 'inet.test', 0); # commandline } - if ($addr && defined $prop->{'reverse_lookups'}) { - if ($INC{'Socket6.pm'} && Socket6->can('getnameinfo')) { - my @res = Socket6::getnameinfo($addr, 0); + delete @$prop{qw(peerhost peerhost_rev)}; + if ($addr && $prop->{'reverse_lookups'}) { + if ($client->can('peerhostname')) { + $prop->{'peerhost'} = $client->peerhostname; + } elsif ($INC{'Socket6.pm'} && Socket6->can('getnameinfo')) { + my @res = Socket6::getnameinfo($client->peername, 0); $prop->{'peerhost'} = $res[0] if @res > 1; - }else{ + } else { $prop->{'peerhost'} = gethostbyaddr($addr, AF_INET); } + if ($prop->{'peerhost'} && $prop->{'double_reverse_lookups'}) { + $prop->{'peerhost_rev'} = {map {$_->[0] => 1} Net::Server::Proto->get_addr_info($prop->{'peerhost'})}; + } } $self->log(3, $self->log_time ." CONNECT ".$client->NS_proto - ." Peer: \"[$prop->{'peeraddr'}]:$prop->{'peerport'}\"" + ." Peer: \"[$prop->{'peeraddr'}]:$prop->{'peerport'}\"".($prop->{'peerhost'} ? " ($prop->{'peerhost'}) " : '') ." Local: \"[$prop->{'sockaddr'}]:$prop->{'sockport'}\"") if $prop->{'log_level'} && 3 <= $prop->{'log_level'}; } @@ -566,16 +584,20 @@ sub allow_deny { # unix sockets are immune to this check return 1 if $sock && $sock->NS_proto =~ /^UNIX/; + # work around Net::CIDR::cidrlookup() croaking, + # if first parameter is an IPv4 address in IPv6 notation. + my $peeraddr = ($prop->{'peeraddr'} =~ /^\s*::ffff:(\d+(?:\.\d+){3})$/) ? $1 : $prop->{'peeraddr'}; + + if ($prop->{'double_reverse_lookups'}) { + return 0 if ! $self->double_reverse_lookup($peeraddr, $prop->{'peerhost'}, $prop->{'peerhost_rev'}, $prop->{'peeraddr'}) + } + # if no allow or deny parameters are set, allow all return 1 if ! @{ $prop->{'allow'} } && ! @{ $prop->{'deny'} } && ! @{ $prop->{'cidr_allow'} } && ! @{ $prop->{'cidr_deny'} }; - # work around Net::CIDR::cidrlookup() croaking, - # if first parameter is an IPv4 address in IPv6 notation. - my $peeraddr = ($prop->{'peeraddr'} =~ /^\s*::ffff:([0-9.]+\s*)$/) ? $1 : $prop->{'peeraddr'}; - # if the addr or host matches a deny, reject it immediately foreach (@{ $prop->{'deny'} }) { return 0 if $prop->{'reverse_lookups'} @@ -601,6 +623,30 @@ sub allow_deny { return 0; } +sub double_reverse_lookup { + my ($self, $addr, $host, $rev_addrs, $orig_addr) = @_; + my $cfg = $self->{'server'}->{'double_reverse_lookups'} || ''; + if (! $host) { + $self->log(3, $self->log_time ." Double reverse missing host from addr $addr"); + return 0; + } elsif (! $rev_addrs) { + $self->log(3, $self->log_time ." Double reverse missing reverse addrs from host $host ($addr)"); + return 0; + } + my $extra = ($orig_addr && $orig_addr ne $addr) ? ", orig_addr: $orig_addr" : ''; + if (! $rev_addrs->{$addr} && ! $rev_addrs->{$orig_addr}) { + $self->log(3, $self->log_time ." Double reverse did not match: addr: $addr, host: $host" + .($cfg =~ /detail/i ? ", addrs: (".join(' ', sort keys %$rev_addrs).")$extra" : '')); + return 0; + } elsif ($cfg =~ /autofail/i) { + $self->log(3, $self->log_time ." Double reverse autofail: addr: $addr, host: $host, addrs: (".join(' ', sort keys %$rev_addrs).")$extra"); + return 0; + } elsif ($cfg =~ /debug/) { + $self->log(3, $self->log_time ." Double reverse debug: addr: $addr, host: $host, addrs: (".join(' ', sort keys %$rev_addrs).")$extra"); + } + return 1; +} + sub allow_deny_hook { 1 } # false to deny request sub request_denied_hook {} @@ -668,6 +714,7 @@ sub done { } sub pre_fork_hook {} +sub register_child {} sub child_init_hook {} sub child_finish_hook {} @@ -691,6 +738,7 @@ sub run_dequeue { # fork off a child process to handle dequeuing $self->{'server'}->{'children'}->{$pid}->{'status'} = 'dequeue' if $self->{'server'}->{'children'}; + $self->register_child($pid, 'dequeue'); } sub default_port { 20203 } @@ -708,7 +756,7 @@ sub server_close { ### if this is a child process, signal the parent and close ### normally the child shouldn't, but if they do... ### otherwise the parent continues with the shutdown - ### this is safe for non standard forked child processes + ### this is safe for nonstandard forked child processes ### as they will not have server_close as a handler if (defined($prop->{'ppid'}) && $prop->{'ppid'} != $$ @@ -752,6 +800,9 @@ sub server_close { && defined($prop->{'pid_file_unlink'})) { unlink($prop->{'pid_file'}) || $self->log(1, "Couldn't unlink \"$prop->{'pid_file'}\" [$!]"); } + if (defined($prop->{'sem'})) { + $prop->{'sem'}->remove(); + } if ($prop->{'_HUP'}) { $self->restart_close_hook(); @@ -787,7 +838,7 @@ sub close_parent { my $self = shift; my $prop = $self->{'server'}; die "Missing parent pid (ppid)" if ! $prop->{'ppid'}; - kill 2, $prop->{'ppid'}; + kill 'INT', $prop->{'ppid'}; } ### SIG INT the children @@ -799,7 +850,7 @@ sub close_children { foreach my $pid (keys %{ $prop->{'children'} }) { $self->log(4, "Kill TERM pid $pid"); - if (kill(15, $pid) || ! kill(0, $pid)) { # if it is killable, kill it + if (kill('TERM', $pid) || ! kill(0, $pid)) { # if it is killable, kill it $self->delete_child($pid); } } @@ -819,7 +870,7 @@ sub hup_children { for my $pid (keys %{ $prop->{'children'} }) { $self->log(4, "Kill HUP pid $pid"); - kill(1, $pid) or $self->log(2, "Failed to kill pid $pid: $!"); + kill('HUP', $pid) or $self->log(2, "Failed to kill pid $pid: $!"); } } @@ -841,7 +892,7 @@ sub sig_hup { # hold on to the socket copy until exec; # just temporary: any socket domain will do, - # forked process will decide to use IO::Socket::INET6 if necessary + # forked process will decide to use IO::Socket::IP or IO::Socket::INET6 if necessary $prop->{'_HUP'}->[$i] = IO::Socket::INET->new; $prop->{'_HUP'}->[$i]->fdopen($fd, 'w') || $self->fatal("Cannot open to file descriptor [$!]"); @@ -956,8 +1007,8 @@ sub options { foreach (qw(conf_file user group chroot log_level - log_file pid_file background setsid - listen reverse_lookups + log_file log_function pid_file background setsid + listen ipv6_package reverse_lookups double_reverse_lookups no_close_by_child no_client_stdout tie_client_stdout tied_stdout_callback tied_stdin_callback leave_children_open_on_hup @@ -1023,7 +1074,9 @@ sub _read_conf { warn "Couldn't open conf \"$file\" [$!]\n"; }; while (defined(my $line = <$fh>)) { - push @args, $1, $2 if $line =~ m/^\s* ((?:--)?\w+) (?:\s*[=:]\s*|\s+) (\S+)/x; + $line = $1 if $line =~ /(.*?)(?{'children'}->{$pid}->{'sock'}->close; } } - + $self->delete_child_hook($pid); # user customizable hook delete $prop->{'children'}->{$pid}; diff --git a/lib/Net/Server.pod b/lib/Net/Server.pod index 3ca13bc..d0de86e 100644 --- a/lib/Net/Server.pod +++ b/lib/Net/Server.pod @@ -1,3 +1,5 @@ +=encoding utf8 + =head1 NAME Net::Server - Extensible, general Perl server engine @@ -194,7 +196,7 @@ Once started, the Net::Server will take care of binding to port and waiting for connections. Once a connection is received, the Net::Server will accept on the socket and will store the result (the client connection) in $self-E{server}-E{client}. This -property is a Socket blessed into the the IO::Socket classes. UDP +property is a Socket blessed into the IO::Socket classes. UDP servers are slightly different in that they will perform a B instead of an B. @@ -374,7 +376,7 @@ been parsed. The post_configure_hook is a good place to do your validation. Some emails have asked why we use this "template" method. The idea is -that you are creating the the data structure to store the values in, +that you are creating the data structure to store the values in, and you are also creating a way to get the values into the data structure. The template is the way to get the values to the servers data structure. One of the possibilities (that probably isn't used @@ -431,12 +433,15 @@ base class.) log_level 0-4 2 log_file (filename|Sys::Syslog |Log::Log4perl) undef + log_function undef port \d+ 20203 host "host" "*" ipv (4|6|*) * proto (tcp|udp|unix) "tcp" listen \d+ SOMAXCONN + ipv6_package (IO::Socket::INET6 IO::Socket::IP + |IO::Socket::IP) ## syslog parameters (if log_file eq Sys::Syslog) syslog_logsock (native|unix|inet|udp @@ -445,7 +450,8 @@ base class.) syslog_logopt (cons|ndelay|nowait|pid) pid syslog_facility \w+ daemon - reverse_lookups 1 undef + reverse_lookups (1|double|double-debug) undef + double_reverse_lookups (1|debug|autofail) undef allow /regex/ none deny /regex/ none cidr_allow CIDR none @@ -542,6 +548,15 @@ If a C is given or if C is set, STDIN and STDOUT will automatically be opened to /dev/null and STDERR will be opened to STDOUT. This will prevent any output from ending up at the terminal. +=item log_function + +Can take a coderef or method name to call when a log event occurs. +Will be passed the level of the log message and the log message. + +Note that functions depending upon stdout will not function +during process_request in situations where the tie_stdout is set +(such as during Net::Server::HTTP). + =item pid_file Filename to store pid of parent process. Generally applies only to @@ -633,7 +648,7 @@ if the C argument omits a host specification. See L. See L. Configuration passed to new or run may be either a scalar containing a single host or an arrayref of hosts - if the hosts array is shorter than the ports array, the -last host entry will be used to augment the hosts arrary to the size +last host entry will be used to augment the hosts array to the size of the ports array. If an IPv4 address is passed, an IPv4 socket will be created. If an @@ -664,7 +679,7 @@ specification can be passed as part of the hostname. host => '*/IPv*', # same (any IPv6 or IPv4) ipv => 4, - host => '*', # any local IPv4 interfaces interfaces + host => '*', # any local IPv4 interfaces =item proto @@ -677,7 +692,7 @@ extending the Net::Server::Proto class may be used). Configuration passed to new or run may be either a scalar containing a single proto or an arrayref of protos - if the protos array is shorter than the ports array, the last proto entry will be used to augment the protos -arrary to the size of the ports array. +array to the size of the ports array. Additionally the proto may also contain the ipv specification. @@ -738,7 +753,8 @@ For versions 2.000 through 2.004, the previous default of IPv4 was used. We have attempted to make it easy to set IPv4, IPv6, or IPv*. If you do not want or need IPv6, simply set ipv to 4, pass IPv4 along in the port specification, set $ENV{'IPV'}=4; before running the -server, or uninstall IO::Socket::INET6. +server, set $ENV{'NO_IPV6'}, or uninstall IO::Socket::IP and/or +IO::Socket::INET6. On my local box the following command results in the following output: @@ -817,12 +833,65 @@ Socket6::AF_INET6 or Socket::AF_UNSPEC, and it is short. See L. Not used with udp protocol (or UNIX SOCK_DGRAM). +=item ipv6_package + +Net::Server::Proto will try to determine the appropriate socket +class to use if a v6 socket is needed. It will default to +trying IO::Socket::IP first, and then IO::Socket::INET6. Specifying +this package allows for a specific package to be used (note that +IO::Socket::SSL used by Proto::SSL does its own ipv6 socket package +determination). + =item reverse_lookups Specify whether to lookup the hostname of the connected IP. Information is cached in server object under C property. Default is to not use reverse_lookups (undef). +Can be set to the values "double", "double-detail", "double-autofail", +or "double-debug" to set double_reverse_lookups. + +=item double_reverse_lookups + +If set, also sets reverse_lookups. + +Same as setting reverse_lookups to "double". Looks up the IPs +that the hostname resolves to to make sure the connection ip is one +of those ips. + +Sets peerhost_rev as a hashref of ip addresses the name resolved to +during get_client_info. + +If double_reverse_lookups is set, the double_reverse_lookup method +is called during the allow_deny method. The +double_reverse_lookup method is passed: + + addr - the IPv4 or IPv6 address + host - the hostname the addr resolved to + addrs - the hashref of ip addresses the host resolved to + orig - the original unfiltered addr + +Makes allow_deny return false if there is no hostname, no reverse ips, +or if one of the ip addrs does not match the connection ip addr. +Sends a log level 3 message. + +Can set double_reverse_lookups to one of the following to adjust logging: + + detail - add addrs to the failure messages + autofail - fail on every connection and log + debug - log address information (but not fail) for successful connections + +The following one liners can help with debugging: + + net-server HTTP --reverse_lookups=double-debug --log_level=3 + # curl localhost:8080 in other window + + 2022/11/30-22:16:45 CONNECT TCP Peer: "[::ffff:127.0.0.1]:44766" (localhost) Local: "[::ffff:127.0.0.1]:8080" + 2022/11/30-22:16:45 Double reverse debug: addr: 127.0.0.1, host: localhost, addrs: (127.0.0.1), orig_addr: ::ffff:127.0.0.1 + +The double_reverse_lookup is called before running any allow/deny +rules. + =item allow/deny May be specified multiple times. Contains regex to compare to @@ -845,13 +914,13 @@ server is still running as root. Defaults to undef. =item user -Userid or username to become after the bind process has occured. +Userid or username to become after the bind process has occurred. Defaults to "nobody." If you would like the server to run as root, you will have to specify C equal to "root". =item group -Groupid or groupname to become after the bind process has occured. +Groupid or groupname to become after the bind process has occurred. Defaults to "nobody." If you would like the server to run as root, you will have to specify C equal to "root". @@ -894,7 +963,7 @@ property that is tied to the already open STDIN and STDOUT. Boolean. Default undef (not set). If set, the parent will not attempt to close child processes if the parent receives a SIG HUP. -The parent will rebind the the open port and begin tracking a fresh +The parent will rebind the open port and begin tracking a fresh set of children. Children of a Fork server will exit after their current request. @@ -1094,6 +1163,9 @@ represents the program flow: $self->post_client_connection_hook; +The allow_deny method calls $self->double_reverse_lookup if +double_reverse_lookups are enabled. + The process then loops and waits for the next connection. For a more in depth discussion, please read the code. @@ -1158,12 +1230,12 @@ the server. =item C<$self-Ebind> -This method actually binds to the inialized sockets (or rebinds if the +This method actually binds to the initialized sockets (or rebinds if the server has been HUPed). =item C<$self-Epost_bind> -During this method priveleges are dropped. The INT, TERM, and QUIT +During this method privileges are dropped. The INT, TERM, and QUIT signals are set to run server_close. Sig PIPE is set to IGNORE. Sig CHLD is set to sig_chld. And sig HUP is set to call sig_hup. @@ -1246,11 +1318,28 @@ directly to and read directly from the client socket. This method looks up information about the client connection such as ip address, socket type, and hostname (as needed). +Sets the following in $self->{'server'} (note that these names +do not necessarily correspond to the names of the IO::Socket:: libraries): + + sockaddr - Human IP address that was connected to + sockport - Local port that was connected to + peeraddr - Human IP address of the remote source (either IPv6 or IPv4) + peerport - Source port of the connection + peerhost - IP Address resolved to hostname (if possible) + peerhost_rev - Hashref of ips of the reverse lookup of the peerhost - only set if double_reverse_lookups + =item C<$self-Eallow_deny> This method uses the rules defined in the allow and deny configuration parameters to determine if the ip address should be accepted. +=item C<$self-Edouble_reverse_lookup> + +Called if the double_reverse_lookups value is set or reverse_lookups +is set to "double". Uses peerhost_rev hashref ips to verify that the +connection ip is valid for the hostname. See the +double_reverse_lookups configuration. + =item C<$self-Eprocess_request> This method is intended to handle all of the client communication. At @@ -1323,11 +1412,11 @@ the process will still be running as the user who started the server. =item C<$self-Epre_loop_hook()> This hook occurs after chroot, change of user, and change of group has -occured. It allows for preparation before looping begins. +occurred. It allows for preparation before looping begins. =item C<$self-Ecan_read_hook()> -This hook occurs after a socket becomes readible on an +This hook occurs after a socket becomes readable on an accept_multi_port request (accept_multi_port is used if there are multiple bound ports to accept on, or if the "multi_port" configuration parameter is set to true). This hook is intended to @@ -1337,7 +1426,7 @@ post_bind_hook. No internal support is added for processing these handles or adding them to the IO::Socket. Care must be used in how much occurs during the can_read_hook as a long response time will result in the server being susceptible to DOS attacks. A return value -of true indicates that the Server should not pass the readible handle +of true indicates that the Server should not pass the readable handle on to the post_accept and process_request phases. It is generally suggested that other avenues be pursued for sending @@ -1441,6 +1530,12 @@ maintain the same random seed unless changed). Similar to the child_init_hook, but occurs just before the fork. +=item C<$self-Eregister_child($pid, $type)> + +Called by parent process when a child has been forked. Type +will be one of dequeue, fork, prefork, or preforksimple depending +on where the child was created. + =item C<$self-Echild_finish_hook()> Similar to the child_init_hook, but ran when the forked process is @@ -1470,7 +1565,7 @@ Should return a hashref. Called when log_file is set to 'Sys::Syslog' and an error occurs while writing to the syslog. It is passed two arguments, the value of $@, and an arrayref containing the arguments that were passed to the log -method when the error occured. +method when the error occurred. =item C<$self-Elog> @@ -1657,7 +1752,7 @@ parent/child communication on PreFork.pm. Thanks to Carl Lewis for suggesting "-" in user names. -Thanks to Slaven Rezic for suggesing Reuse => 1 in Proto::UDP. +Thanks to Slaven Rezic for suggesting Reuse => 1 in Proto::UDP. Thanks to Tim Watt for adding udp_broadcast to Proto::UDP. @@ -1697,7 +1792,7 @@ lock_file once during parent call. This patch should be portable on systems supporting flock. Rob also suggested not closing STDIN/STDOUT but instead reopening them to /dev/null to prevent spurious warnings. Also suggested short circuit in post_accept if in UDP. Also for -cleaning up some of the child managment code of PreFork. +cleaning up some of the child management code of PreFork. Thanks to Mark Martinec for suggesting additional log messages for failure during accept. @@ -1705,7 +1800,7 @@ failure during accept. Thanks to Bill Nesbitt and Carlos Velasco for pointing out double decrement bug in PreFork.pm (rt #21271) -Thanks to John W. Krahn for pointing out glaring precended with +Thanks to John W. Krahn for pointing out glaring precedence with non-parened open and ||. Thanks to Ricardo Signes for pointing out setuid bug for perl 5.6.1 @@ -1717,7 +1812,7 @@ And for additional fixes later. Thanks to Steven Lembark for pointing out that no_client_stdout wasn't working with the Multiplex server. -Thanks to Peter Beckman for suggesting allowing Sys::SysLog keyworks +Thanks to Peter Beckman for suggesting allowing Sys::SysLog keywords be passed through the ->log method and for suggesting we allow more types of characters through in syslog_ident. Also to Peter Beckman for pointing out that a poorly setup localhost will cause tests to @@ -1782,7 +1877,7 @@ Thanks to Mark Martinec for much of the initial work towards getting IPv6 going. Thanks to the munin developers and Nicolai Langfeldt for hosting the -development verion of Net::Server for so long and for fixes to the +development version of Net::Server for so long and for fixes to the allow_deny checking for IPv6 addresses. Thanks to Tatsuhiko Miyagawa for feedback, and for suggesting adding @@ -1794,6 +1889,10 @@ Thanks to Miko O'Sullivan for fixes to HTTP to correct tainting issues and passing initial log fixes, and for patches to fix CLOSE on tied stdout and various other HTTP issues. +Thanks to Emanuele for a small patch releasing semaphores. + +Thanks to Rob for daemonization fixes with zero pid file. + =head1 SEE ALSO Please see also diff --git a/lib/Net/Server/Daemonize.pm b/lib/Net/Server/Daemonize.pm index c7475fc..ff14180 100644 --- a/lib/Net/Server/Daemonize.pm +++ b/lib/Net/Server/Daemonize.pm @@ -2,7 +2,7 @@ # # Net::Server::Daemonize - Daemonization utilities. # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Jeremy Howard # j+daemonize@howard.fm @@ -32,16 +32,16 @@ our @EXPORT_OK = qw(check_pid_file create_pid_file unlink_pid_file ###----------------------------------------------------------------### -### check for existance of pid_file +### check for existence of pid_file ### if the file exists, check for a running process sub check_pid_file ($) { my $pid_file = shift; - return 1 if ! -e $pid_file; + return 1 if ! -e $pid_file or ! -s $pid_file && -M _ > 0.01; - open my $fh, '<', $pid_file or die "Couldn't open existant pid_file \"$pid_file\" [$!]\n"; - my $current_pid = <$fh>; + open my $fh, '<', $pid_file or die "$pid_file: Couldn't open existent pid_file [$!]\n"; + my $current_pid = <$fh> || ""; close $fh; - $current_pid = ($current_pid =~ /^(\d{1,10})/) ? $1 : die "Couldn't find pid in existing pid_file"; + $current_pid = ($current_pid =~ /^(\d{1,10})/) ? $1 : die "$pid_file: Couldn't find pid in existent pid_file"; my $exists; if ($$ == $current_pid) { @@ -82,7 +82,7 @@ sub unlink_pid_file ($) { my $pid_file = shift; return 1 if ! -e $pid_file; # no pid_file = return success - open my $fh, '<', $pid_file or die "Couldn't open existant pid_file \"$pid_file\" [$!]\n"; # slight race + open my $fh, '<', $pid_file or die "$pid_file: Couldn't open existent pid_file [$!]\n"; # slight race my $current_pid = <$fh>; close $fh; chomp $current_pid; @@ -90,7 +90,7 @@ sub unlink_pid_file ($) { die "Process $$ doesn't own pid_file \"$pid_file\". Can't remove it.\n" if $current_pid ne $$; - unlink($pid_file) || die "Couldn't unlink pid_file \"$pid_file\" [$!]\n"; + unlink($pid_file) || die "$pid_file: Couldn't unlink pid_file [$!]\n"; return 1; } @@ -124,7 +124,7 @@ sub get_gid { } die "No group found in arguments.\n" unless @gid; - return join(" ",$gid[0],@gid); + return join(" ", $gid[0], @gid); } ### change the process to run as this uid @@ -194,7 +194,7 @@ sub daemonize ($$$) { my $uid = get_uid($user); my $gid = get_gid($group); # returns list of groups - $gid = (split /\s+/, $gid)[0]; + $gid = (split /[\s,]+/, $gid)[0]; my $pid = safe_fork(); @@ -309,7 +309,7 @@ Determine if the process is running as root. Returns 1 or undef. =item check_pid_file -Arguments are pid_file (full path to pid_file). Checks for existance +Arguments are pid_file (full path to pid_file). Checks for existence of pid_file. If file exists, open it and determine if the process that created it is still running. This is done first by checking for a /proc file system and second using a "ps" command (BSD syntax). (If diff --git a/lib/Net/Server/Fork.pm b/lib/Net/Server/Fork.pm index f5d7cfd..5fa87e2 100644 --- a/lib/Net/Server/Fork.pm +++ b/lib/Net/Server/Fork.pm @@ -2,7 +2,7 @@ # # Net::Server::Fork - Net::Server personality # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -144,6 +144,7 @@ sub loop { # parent close($prop->{'client'}) if !$prop->{'udp_true'}; $prop->{'children'}->{$pid}->{'status'} = 'processing'; + $self->register_child($pid, 'fork'); } } @@ -164,7 +165,7 @@ sub accept { return undef if ! defined $sock; # check if this is UDP - if (SOCK_DGRAM == $sock->getsockopt(SOL_SOCKET,SO_TYPE)) { + if (SOCK_DGRAM == $sock->getsockopt(SOL_SOCKET, SO_TYPE)) { $prop->{'udp_true'} = 1; $prop->{'client'} = $sock; $prop->{'udp_peer'} = $sock->recv($prop->{'udp_data'}, $sock->NS_recv_len, $sock->NS_recv_flags); diff --git a/lib/Net/Server/HTTP.pm b/lib/Net/Server/HTTP.pm index 16c1419..d186e06 100644 --- a/lib/Net/Server/HTTP.pm +++ b/lib/Net/Server/HTTP.pm @@ -2,7 +2,7 @@ # # Net::Server::HTTP - Extensible Perl HTTP base server # -# Copyright (C) 2010-2017 +# Copyright (C) 2010-2022 # # Paul Seamons # @@ -32,7 +32,8 @@ sub options { my $ref = $self->SUPER::options(@_); my $prop = $self->{'server'}; $ref->{$_} = \$prop->{$_} for qw(timeout_header timeout_idle server_revision max_header_size - access_log_format access_log_file enable_dispatch); + access_log_format access_log_file access_log_function enable_dispatch + default_content_type allow_body_on_all_statuses); return $ref; } @@ -45,6 +46,19 @@ sub default_port { 80 } sub default_server_type { 'PreFork' } +sub initialize_logging { + my $self = shift; + $self->SUPER::initialize_logging(@_); + my $prop = $self->{'server'}; + + my $d = { + access_log_format => '%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-Agent}i\"', + }; + $prop->{$_} = $d->{$_} foreach grep {!defined($prop->{$_})} keys %$d; + + $self->_init_access_log; +} + sub post_configure { my $self = shift; $self->SUPER::post_configure(@_); @@ -56,12 +70,9 @@ sub post_configure { timeout_idle => 60, server_revision => __PACKAGE__."/$Net::Server::VERSION", max_header_size => 100_000, - access_log_format => '%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-Agent}i\"', }; $prop->{$_} = $d->{$_} foreach grep {!defined($prop->{$_})} keys %$d; - $self->_init_access_log; - $self->_tie_client_stdout; } @@ -76,10 +87,21 @@ sub _init_access_log { my $self = shift; my $prop = $self->{'server'}; my $log = $prop->{'access_log_file'}; - return if ! $log || $log eq '/dev/null'; + return if (! $log || $log eq '/dev/null') && ! $prop->{'access_log_function'}; return if ! $prop->{'access_log_format'}; $prop->{'access_log_format'} =~ s/\\([\\\"nt])/$1 eq 'n' ? "\n" : $1 eq 't' ? "\t" : $1/eg; - if ($log eq 'STDERR') { + if (my $code = $prop->{'access_log_function'}) { + if (ref $code ne 'CODE') { + die "Passed access_log_function $code was not a valid method of server, or was not a code object\n" if ! $self->can($code); + my $copy = $self; + $prop->{'access_log_function'} = sub { $copy->$code(@_) }; + weaken $copy; + } + } elsif ($log eq 'STDOUT' || $log eq '/dev/stdout') { + open my $fh, '>&', \*STDOUT or die "Could not dup STDOUT: $!"; + $fh->autoflush(1); + $prop->{'access_log_function'} = sub { print $fh @_,"\n" }; + } elsif ($log eq 'STDERR' || $log eq '/dev/stderr') { $prop->{'access_log_function'} = sub { print STDERR @_,"\n" }; } else { open my $fh, '>>', $log or die "Could not open access_log_file \"$log\": $!"; @@ -129,44 +151,38 @@ sub _tie_client_stdout { die "All headers must only be sent via print ($method)\n" if $method ne 'print'; - my $headers = ${*$client}{'headers'} ||= {unparsed => '', parsed => ''}; - $headers->{'unparsed'} .= join('', @_); - while ($headers->{'unparsed'} =~ s/^(.*?)\015?\012//) { + my $headers = ${*$client}{'headers'} ||= {buffer => '', status => undef, msg => undef, headers => []}; + $headers->{'buffer'} .= join('', @_); + while ($headers->{'buffer'} =~ s/^(.*?)\015?\012//) { my $line = $1; - if (!$headers->{'parsed'} && $line =~ m{^HTTP/(1.[01]) \s+ (\d+) (?: | \s+ .+)$ }x) { - $headers->{'status'} = []; - $headers->{'parsed'} .= "$line\015\012"; - $prop->{'request_info'}->{'http_version'} = $1; - $prop->{'request_info'}->{'response_status'} = $2; + if ($line =~ m{^HTTP/(1.[01]) \s+ (\d+) (?: | \s+ (.+?)) \s* $ }x) { + die "Found HTTP/ line after other headers were sent\n" if @{ $headers->{'headers'} }; + @$headers{qw(version status msg)} = ($1, $2, $3); } elsif (! length $line) { - my $s = $headers->{'status'} || die "Premature end of script headers\n"; + if (! $headers->{'status'} && ! @{ $headers->{'headers'} }) { + die "Premature end of script headers\n"; + } delete ${*$client}{'headers'}; - $copy->send_status(@$s) if @$s; - $client->print($headers->{'parsed'}."\015\012"); - $request_info->{'headers_sent'} = 1; - $request_info->{'response_header_size'} += length($headers->{'parsed'})+2; - $request_info->{'response_size'} = length($headers->{'unparsed'}); - return $client->print($headers->{'unparsed'}); + $copy->send_status($headers); + if (my $n = length $headers->{'buffer'}) { + $request_info->{'response_size'} = $n; + $client->print($headers->{'buffer'}); + } + return; } elsif ($line !~ s/^(\w+(?:-(?:\w+))*):\s*//) { my $invalid = ($line =~ /(.{0,120})/) ? "$1..." : ''; $invalid =~ s/\n"; } else { - my $key = "\u\L$1"; - $key =~ y/_/-/; + my $key = $1; push @{ $request_info->{'response_headers'} }, [$key, $line]; - if ($key eq 'Status' && $line =~ /^(\d+) (?:|\s+(.+?))$/ix) { - $headers->{'status'} = [$1, $2 || '-']; - } - elsif ($key eq 'Location') { - $headers->{'status'} = [302, 'bouncing']; - } - elsif ($key eq 'Content-type') { - $headers->{'status'} ||= [200, 'OK']; + if (lc($key) eq 'status' && $line =~ /^(\d+) (?:|\s+(.+?))$/ix) { + @$headers{qw(status msg)} = ($1, $2) if ! $headers->{'status'}; + # not sure if it should also still be setting a header } - $headers->{'parsed'} .= "$key: $line\015\012"; + push @{ $headers->{'headers'} }, [$key, $line]; } } }; @@ -232,37 +248,89 @@ sub http_base_headers { ]; } +sub default_content_type { shift->{'server'}->{'default_content_type'} || 'text/html' } + +our %status_msg = ( + 200 => 'OK', + 201 => 'Created', + 202 => 'Accepted', + 204 => 'No Content', + 301 => 'Moved Permanently', + 302 => 'Found', + 304 => 'Not Modified', + 400 => 'Bad Request', + 401 => 'Unauthorized', + 403 => 'Forbidden', + 404 => 'Not Found', + 418 => "I'm a teapot", + 500 => 'Internal Server Error', + 501 => 'Not Implemented', + 503 => 'Service Unavailable', +); + sub send_status { - my ($self, $status, $msg, $body) = @_; - $msg ||= ($status == 200) ? 'OK' : '-'; - my $request_info = $self->{'request_info'}; + my ($self, $status, $msg, $body, $gen_body) = @_; + + my ($version, $headers); + if (ref($status) eq 'HASH') { + ($version, $status, $msg, $headers) = @$status{qw(version status msg headers)}; + } + $version ||= '1.0'; + + my @hdrs = @{ $self->http_base_headers }; + push @hdrs, @$headers if $headers; + foreach my $hdr (@hdrs) { + $hdr->[0] =~ y/_/-/; + $hdr->[0] = ucfirst lc $hdr->[0]; + if (! $status) { + if ($hdr->[0] eq 'Content-type') { + $status = 200; + } elsif ($hdr->[0] eq 'Location') { + $status = 302; + } + } + } + $status ||= 500; + $msg ||= $status_msg{$status} || '-'; + if (! $body && $gen_body) { + my $_msg = ($msg eq '-') ? "Status $status" : $msg; + $gen_body = [] if ref $gen_body ne 'ARRAY'; + for ($_msg, @$gen_body) { s//</g; s/&/&alt;/g } + $body = "\n\n

$_msg

".join("\n", map {"

$_

"} @$gen_body)."\n\n"; + } - my $out = "HTTP/1.0 $status $msg\015\012"; - foreach my $row (@{ $self->http_base_headers }) { - $out .= "$row->[0]: $row->[1]\015\012"; - push @{ $request_info->{'response_headers'} }, $row; + my $out = "HTTP/$version $status $msg\015\012"; + my $no_body; + if (($status == 204 || $status == 304 || ($status >= 100 && $status <= 199)) + && ! $self->{'server'}->{'allow_body_on_all_statuses'}) { + # no content-type and or body + $no_body = 1; + } else { + my $ct = (grep { lc($_->[0]) eq 'content-type' } @hdrs)[0]; + push @hdrs, $ct = ['Content-type', $self->default_content_type] if ! $ct; + } + + my $request_info = $self->{'request_info'}; + foreach my $hdr (@hdrs) { + $out .= "$hdr->[0]: $hdr->[1]\015\012"; + push @{ $request_info->{'response_headers'} }, $hdr; } + $out .= "\015\012"; + $self->{'server'}->{'client'}->print($out); - $request_info->{'http_version'} = '1.0'; - $request_info->{'response_status'} = $status; - $request_info->{'response_header_size'} += length $out; - - if ($body) { - push @{ $request_info->{'response_headers'} }, ['Content-type', 'text/html']; - $out = "Content-type: text/html\015\012\015\012"; - $request_info->{'response_header_size'} += length $out; - $self->{'server'}->{'client'}->print($out); - $request_info->{'headers_sent'} = 1; + @$request_info{qw(http_version response_status response_header_size headers_sent)} + = ($version, $status, length($out), 1); + + if ($no_body) { + # no content-type and or body + } elsif (defined($body) && length($body)) { $self->{'server'}->{'client'}->print($body); $request_info->{'response_size'} += length $body; } } -sub send_500 { - my ($self, $err) = @_; - $self->send_status(500, 'Internal Server Error', - "

Internal Server Error

$err

"); -} +sub send_400 { my ($self, @err) = @_; $self->send_status(400, undef, undef, \@err) } +sub send_500 { my ($self, @err) = @_; $self->send_status(500, undef, undef, \@err) } ###----------------------------------------------------------------### @@ -308,6 +376,11 @@ sub process_request { } } +sub request_denied_hook { + my ($self, $client) = @_; + $self->send_400(); +} + sub script_name { shift->{'script_name'} || '' } sub process_headers { @@ -318,6 +391,7 @@ sub process_headers { $ENV{'REMOTE_ADDR'} = $self->{'server'}->{'peeraddr'}; $ENV{'SERVER_PORT'} = $self->{'server'}->{'sockport'}; $ENV{'SERVER_ADDR'} = $self->{'server'}->{'sockaddr'}; + $ENV{$_} =~ s/^::ffff:(?=\d+(?:\.\d+){3}$)// for qw(REMOTE_ADDR SERVER_ADDR); $ENV{'HTTPS'} = 'on' if $self->{'server'}->{'client'}->NS_proto =~ /SSL/; my ($ok, $headers) = $client->read_until($self->max_header_size, qr{\n\r?\n}); @@ -332,7 +406,7 @@ sub process_headers { ($req, my @lines) = split /\r?\n/, $headers; die "Missing request\n" if ! defined $req; - if (!defined($req) || $req !~ m{ ^\s*(GET|POST|PUT|DELETE|PUSH|HEAD|OPTIONS)\s+(.+)\s+(HTTP/1\.[01])\s*$ }ix) { + if (!defined($req) || $req !~ m{ ^\s*(GET|POST|PUT|PATCH|DELETE|PUSH|HEAD|OPTIONS)\s+(.+)\s+(HTTP/1\.[01])\s*$ }ix) { die "Invalid request\n"; } $ENV{'REQUEST_METHOD'} = uc $1; @@ -343,7 +417,7 @@ sub process_headers { foreach my $l (@lines) { my ($key, $val) = split /\s*:\s*/, $l, 2; - push @parsed, [$key, $val]; + push @parsed, ["\u\L$key", $val]; $key = uc($key); $key = 'COOKIE' if $key eq 'COOKIES'; $key =~ y/-/_/; @@ -422,6 +496,10 @@ sub process_http_request { sub http_echo { my $self = shift; print "Content-type: text/html\n\n"; + if ($ENV{'PATH_INFO'} && $ENV{'PATH_INFO'} eq '/simple') { + print "Simple"; + return; + } print "
\n"; if (eval { require Data::Dumper }) { local $Data::Dumper::Sortkeys = 1; @@ -518,6 +596,7 @@ sub http_log_cookie { } sub http_log_header_in { my ($self, $info, $var) = @_; + $var = "\u\L$var"; return join ', ', map {$_->[1]} grep {$_->[0] eq $var} @{ $info->{'request_headers'} || [] }; } sub http_log_note { @@ -526,6 +605,7 @@ sub http_log_note { } sub http_log_header_out { my ($self, $info, $var) = @_; + $var = "\u\L$var"; return join ', ', map {$_->[1]} grep {$_->[0] eq $var} @{ $info->{'response_headers'} || [] }; } sub http_log_pid { $_[1]->{'pid'} || $$ } # we do not support tid yet @@ -658,9 +738,9 @@ the other Net::Server flavors, handling HTTP requests is an often requested feature and is a standard and simple protocol. Net::Server::HTTP begins with base type MultiType defaulting to -Net::Server::Fork. It is easy to change it to any of the other +Net::Server::PreFork. It is easy to change it to any of the other Net::Server flavors by passing server_type => $other_flavor in the -server configurtation. The port has also been defaulted to port 80 - +server configuration. The port has also been defaulted to port 80 - but could easily be changed to another through the server configuration. You can also very easily add ssl by including, proto=>"ssl" and provide a SSL_cert_file and SSL_key_file. @@ -720,6 +800,12 @@ the environment and sets up request alarms and handles dying failures. It calls process_http_request once the request is ready and headers have been parsed. +=item C + +This method has been overridden to call send_400. This is +new behavior. To get the previous behavior (where the client +was closed without any indication), simply provide + =item C Used to read in the incoming headers and set the ENV. @@ -736,7 +822,17 @@ This information will be used for logging later on. =item C -Takes an HTTP status and a message. Sends out the correct headers. +Takes an HTTP status, an optional message, optional body, and +optional generate_body flag. Sends out the correct headers. + + $self->send_status(500); + $self->send_status(500, 'Internal Server Error'); + $self->send_status(500, 'Internal Server Error', "

Internal Server Error

Msg

"); + $self->send_status(500, undef, undef, ['Msg']); + +=item C + +Calls send_status with 400 and the passed arguments as generate_body. =item C @@ -745,7 +841,7 @@ Calls send_status with 500 and the argument passed to send_500. =item c Called at the end of post_process_request. The default method looks -for the default access_log_format and checks if logging was initilized +for the default access_log_format and checks if logging was initialized during _init_access_log. If both of these exist, the http_request_info is formatted using http_log_format and the result is logged. @@ -958,8 +1054,20 @@ request is closed. Defaults to undef. If true, this represents the location of where the access log should be written to. If a special value of STDERR -is passed, the access log entry will be writing to the same location -as the ERROR log. +or F is passed, the access log entry will be written to +the same location as the ERROR log. If a special value of STDOUT or +F is passed, the access log entry will be written to +standard out. + +=item access_log_function + +Can take a coderef or method name to call when an log_http_request +method is called. Will be passed the formatted log access log +message. + +Note that functions depending upon stdout will not function +during Net::Server::HTTP process_request because stdout is always +tied for the client (and not restored after running). =item access_log_format @@ -1041,6 +1149,17 @@ module. '/bar' => '/path/to/some.cgi', ]); +=item default_content_type + +Default is text/html. Set on any responses that have not +yet passed a content-type + +=item allow_body_on_all_statuses + +By default content-type and printing a body are not allowed on 204, +304, or 1xx statuses. Set this flag to automatically send a +content-type on those statuses as well. + =back =head1 TODO diff --git a/lib/Net/Server/INET.pm b/lib/Net/Server/INET.pm index 86cc944..65cf283 100644 --- a/lib/Net/Server/INET.pm +++ b/lib/Net/Server/INET.pm @@ -2,7 +2,7 @@ # # Net::Server::INET - Net::Server personality # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # diff --git a/lib/Net/Server/Log/Log/Log4perl.pm b/lib/Net/Server/Log/Log/Log4perl.pm index aae297c..04d1cb2 100644 --- a/lib/Net/Server/Log/Log/Log4perl.pm +++ b/lib/Net/Server/Log/Log/Log4perl.pm @@ -2,7 +2,7 @@ # # Net::Server::Log::Log::Log4perl - Net::Server Logging module # -# Copyright (C) 2012-2017 +# Copyright (C) 2012-2022 # # Paul Seamons # @@ -97,7 +97,7 @@ is not readable, will die. =item log4perl_poll -If set to a value, will initialise with Log::Log4perl::init_and_watch +If set to a value, will initialize with Log::Log4perl::init_and_watch with this polling value. This can also be the string "HUP" to re-read the log4perl_conf when a HUP signal is received. If set to 0, no polling is done. See L for more details. diff --git a/lib/Net/Server/Log/Sys/Syslog.pm b/lib/Net/Server/Log/Sys/Syslog.pm index 3c7cd26..64cabe9 100644 --- a/lib/Net/Server/Log/Sys/Syslog.pm +++ b/lib/Net/Server/Log/Sys/Syslog.pm @@ -2,7 +2,7 @@ # # Net::Server::Log::Sys::Syslog - Net::Server Logging module # -# Copyright (C) 2012-2017 +# Copyright (C) 2012-2022 # # Paul Seamons # @@ -25,6 +25,9 @@ sub initialize { my ($class, $server) = @_; my $prop = $server->{'server'}; + my $syslog_version = $Sys::Syslog::VERSION; + $syslog_version =~ s/_.*//; + $server->configure({ syslog_logsock => \$prop->{'syslog_logsock'}, syslog_ident => \$prop->{'syslog_ident'}, @@ -36,12 +39,12 @@ sub initialize { # do nothing - assume they have what they want } else { if (! defined $prop->{'syslog_logsock'}) { - $prop->{'syslog_logsock'} = ($Sys::Syslog::VERSION < 0.15) ? 'unix' : ''; + $prop->{'syslog_logsock'} = ($syslog_version < 0.15) ? 'unix' : ''; } if ($prop->{'syslog_logsock'} =~ /^(|native|tcp|udp|unix|inet|stream|console)$/) { $prop->{'syslog_logsock'} = $1; } else { - $prop->{'syslog_logsock'} = ($Sys::Syslog::VERSION < 0.15) ? 'unix' : ''; + $prop->{'syslog_logsock'} = ($syslog_version < 0.15) ? 'unix' : ''; } } diff --git a/lib/Net/Server/MultiType.pm b/lib/Net/Server/MultiType.pm index 6c81a26..e6e70c1 100644 --- a/lib/Net/Server/MultiType.pm +++ b/lib/Net/Server/MultiType.pm @@ -2,7 +2,7 @@ # # Net::Server::MultiType - Net::Server personality # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -67,7 +67,7 @@ sub run { @{"${pkg}::ISA"} = ($_pkg); } - # cludgy - doesn't allow multiple Net::Server::MultiType servers within same process + # kludgy - doesn't allow multiple Net::Server::MultiType servers within same process # but it is probably better than modifying our child's class for it @Net::Server::MultiType::ISA = ($pkg); last; diff --git a/lib/Net/Server/Multiplex.pm b/lib/Net/Server/Multiplex.pm index c422c14..036e9a8 100644 --- a/lib/Net/Server/Multiplex.pm +++ b/lib/Net/Server/Multiplex.pm @@ -4,7 +4,7 @@ # # $Id$ # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Rob Brown # @@ -158,7 +158,7 @@ our @ISA = qw(Net::Server::Multiplex); sub init { my $package = shift; my $net_server= shift; - # On-the-fly runtime molymorphism hack + # On-the-fly runtime polymorphism hack # to ISA the same type of thing passed. @ISA = (ref $net_server); my $self = bless { @@ -311,7 +311,7 @@ convenient inet style STDIN/STDOUT handling, logging features, deamonization and pid tracking, and restartability -SIGHUP) and some nice features of IO::Multiplex (automatic buffered IO and per-file-handle objects) and combines them for an easy-to-use -interace. +interface. See examples/samplechat.pl distributed with Net::Server for a simple chat server that uses several of these features. diff --git a/lib/Net/Server/PSGI.pm b/lib/Net/Server/PSGI.pm index 2d0fe05..9cdda38 100644 --- a/lib/Net/Server/PSGI.pm +++ b/lib/Net/Server/PSGI.pm @@ -2,7 +2,7 @@ # # Net::Server::PSGI - Extensible Perl HTTP PSGI base server # -# Copyright (C) 2011-2017 +# Copyright (C) 2011-2022 # # Paul Seamons # @@ -17,6 +17,7 @@ package Net::Server::PSGI; use strict; use base qw(Net::Server::HTTP); +use Scalar::Util qw(blessed); sub net_server_type { __PACKAGE__ } @@ -50,7 +51,7 @@ sub process_request { $self->process_headers; alarm($self->timeout_idle); - my $env = \%ENV; + my $env = { %ENV }; $env->{'psgi.version'} = [1, 0]; $env->{'psgi.url_scheme'} = ($ENV{'HTTPS'} && $ENV{'HTTPS'} eq 'on') ? 'https' : 'http'; $env->{'psgi.input'} = $self->{'server'}->{'client'}; @@ -102,20 +103,11 @@ sub app { sub print_psgi_headers { my ($self, $status, $headers) = @_; - $self->send_status($status); - my $request_info = $self->{'request_info'}; - my $out = ''; - for my $i (0 .. @{ $headers || [] } / 2 - 1) { - my $key = "\u\L$headers->[$i*2]"; - my $val = $headers->[$i*2 + 1]; - $key =~ y/_/-/; - $out .= "$key: $val\015\012"; - push @{ $request_info->{'response_headers'} }, [$key, $val]; - } - $out .= "\015\012"; - $request_info->{'response_header_size'} += length $out; - $self->{'server'}->{'client'}->print($out); - $request_info->{'headers_sent'} = 1; + $headers ||= []; + $self->send_status({ + status => $status, + headers => [map {[@$headers[$_*2, $_*2+1]]} 0 .. $#$headers / 2], + }); } sub print_psgi_body { @@ -142,6 +134,9 @@ sub print_psgi_body { sub psgi_echo_handler { my $env = shift; + if ($env->{'PATH_INFO'} && $env->{'PATH_INFO'} eq '/simple') { + return [200, [content_type => 'text/html'], ['Simple']]; + } my $txt = qq{
\n}; if (eval { require Data::Dumper }) { local $Data::Dumper::Sortkeys = 1; @@ -202,7 +197,7 @@ rudimentary, then Net::Server::PSGI may be good for you. Net::Server::PSGI takes Net::Server::HTTP one level farther. It begins with base type MultiType defaulting to Net::Server::Fork. It is easy to change it to any of the other Net::Server flavors by -passing server_type => $other_flavor in the server configurtation. +passing server_type => $other_flavor in the server configuration. The port has also been defaulted to port 80 - but could easily be changed to another through the server configuration. You can also very easily add ssl by including, proto=>"ssl" and provide a diff --git a/lib/Net/Server/PreFork.pm b/lib/Net/Server/PreFork.pm index 52fc608..262c1da 100644 --- a/lib/Net/Server/PreFork.pm +++ b/lib/Net/Server/PreFork.pm @@ -2,7 +2,7 @@ # # Net::Server::PreFork - Net::Server personality # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -174,7 +174,8 @@ sub run_n_children { } $prop->{'children'}->{$pid}->{'status'} = 'waiting'; - $prop->{'tally'}->{'waiting'} ++; + $prop->{'tally'}->{'waiting'}++; + $self->register_child($pid, 'prefork'); } else { # child if ($prop->{'child_communication'}) { @@ -636,7 +637,7 @@ value pairs. Comments and white space are ignored. Process flow follows Net::Server until the loop phase. At this point C are forked and wait for connections. When a child -accepts a connection, finishs processing a client, or exits, it relays +accepts a connection, finishes processing a client, or exits, it relays that information to the parent, which keeps track and makes sure there are enough children to fulfill C, C, C, and C. @@ -652,7 +653,7 @@ provided by PreForkSimple. See L. This hook occurs at the top of run_n_children which is called each time the server goes to start more child processes. This gives the -parent to do a little of its own accountting (as desired). Idea for +parent to do a little of its own accounting (as desired). Idea for this hook came from James FitzGibbon. =item C<$self-Eparent_read_hook()> @@ -678,6 +679,7 @@ This hook is called when a dead child is detected. A child is considered dead when the pid does no longer exist. This hook could be used to cleanup possible temporary files or locks left over by a dead child. + =back =head1 HOT DEPLOY diff --git a/lib/Net/Server/PreForkSimple.pm b/lib/Net/Server/PreForkSimple.pm index 4609992..9afce1f 100644 --- a/lib/Net/Server/PreForkSimple.pm +++ b/lib/Net/Server/PreForkSimple.pm @@ -2,7 +2,7 @@ # # Net::Server::PreForkSimple - Net::Server personality # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -146,6 +146,7 @@ sub run_n_children { if ($pid) { $prop->{'children'}->{$pid}->{'status'} = 'processing'; + $self->register_child($pid, 'preforksimple'); } else { $self->run_child; } @@ -435,16 +436,16 @@ specified in I (see below). The semaphore option uses IPC::Semaphore (thanks to Bennett Todd) for giving some sample code. The pipe option reads on a pipe to choose the next. the flock option should be the most bulletproof while the pipe option should be the -most portable. (Flock is able to reliquish the block if the process +most portable. (Flock is able to relinquish the block if the process dies between accept on the socket and reading of the client connection - semaphore and pipe do not). An option of none will not perform any serialization. If "none" is passed and there are multiple ports -then a the default serialization will be used insted of "none." +then a the default serialization will be used instead of "none." =item lock_file Filename to use in flock serialized accept in order to serialize the -accept sequece between the children. This will default to a generated +accept sequence between the children. This will default to a generated temporary filename. If default value is used the lock_file will be removed when the server closes. @@ -513,7 +514,7 @@ value pairs. Comments and white space are ignored. Process flow follows Net::Server until the loop phase. At this point C are forked and wait for connections. When a child -accepts a connection, finishs processing a client, or exits, it relays +accepts a connection, finishes processing a client, or exits, it relays that information to the parent, which keeps track and makes sure there are always C running. @@ -528,14 +529,14 @@ hooks provided by the Net::Server base class. See L This hook occurs at the top of run_n_children which is called each time the server goes to start more child processes. This gives the -parent to do a little of its own accountting (as desired). Idea for +parent to do a little of its own accounting (as desired). Idea for this hook came from James FitzGibbon. =item C<$self-Echild_init_hook()> -This hook takes place immeditately after the child process forks from +This hook takes place immediately after the child process forks from the parent and before the child begins accepting connections. It is -intended for any addiotional chrooting or other security measures. It +intended for any additional chrooting or other security measures. It is suggested that all perl modules be used by this point, so that the most shared memory possible is used. diff --git a/lib/Net/Server/Proto.pm b/lib/Net/Server/Proto.pm index 8cc7dce..1b92edd 100644 --- a/lib/Net/Server/Proto.pm +++ b/lib/Net/Server/Proto.pm @@ -2,7 +2,7 @@ # # Net::Server::Proto - Net::Server Protocol compatibility layer # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -22,6 +22,7 @@ use warnings; use Socket (); my $requires_ipv6 = 0; +my $ipv6_package; sub parse_info { my ($class, $port, $host, $proto, $ipv, $server) = @_; @@ -79,7 +80,7 @@ sub parse_info { foreach my $row (@rows) { my ($host, $port, $ipv, $warn) = @$row; push @_info, {host => $host, port => $port, ipv => $ipv, proto => $info->{'proto'}, $warn ? (warn => $warn) : ()}; - $requires_ipv6++ if $ipv ne '4' && $proto ne 'ssl'; # we need to know if Proto::TCP needs to reparent as a child of IO::Socket::INET6 + $requires_ipv6++ if $ipv ne '4' && $proto ne 'ssl'; # we need to know if Proto::TCP needs to reparent as a child of an IPv6 compatible socket library } if (@rows > 1 && $rows[0]->[1] == 0) { $server->log(2, "Determining auto-assigned port (0) for host $info->{'host'} (prebind)"); @@ -115,7 +116,7 @@ sub get_addr_info { if ($host =~ /^\d+(?:\.\d+){3}$/) { my $addr = Socket::inet_aton($host) or die "Unresolveable host [$host]:$port: invalid ip\n"; push @info, [Socket::inet_ntoa($addr), $port, 4] - } elsif (!$ENV{'NO_IPV6'} && eval { require Socket6; require IO::Socket::INET6 }) { + } elsif (!$ENV{'NO_IPV6'} && eval { require Socket6 } && (eval { require IO::Socket::IP } || eval { require IO::Socket::INET6 })) { my $proto_id = getprotobyname(lc($proto) eq 'udp' ? 'udp' : 'tcp'); my $socktype = lc($proto) eq 'udp' ? Socket::SOCK_DGRAM() : Socket::SOCK_STREAM(); my @res = Socket6::getaddrinfo($host eq '*' ? '' : $host, $port, Socket::AF_UNSPEC(), $socktype, $proto_id, Socket6::AI_PASSIVE()); @@ -195,17 +196,34 @@ sub object { return $proto_class->object($info, $server); } -sub requires_ipv6 { - my ($class, $server) = @_; - return if ! $requires_ipv6; +sub requires_ipv6 { $requires_ipv6 ? 1 : undef } - if (! $INC{'IO/Socket/INET6.pm'}) { - eval { - require Socket6; - require IO::Socket::INET6; - } or $server->fatal("Port configuration using IPv6 could not be started becauses of Socket6 library issues: $@"); +sub ipv6_package { + my ($class, $server) = @_; + return $ipv6_package if $ipv6_package; + + eval { require Socket6 } + or $server->fatal("Port configuration using IPv6 could not be started becauses of Socket6 library issues: $@"); + + my $pkg = $server->{'server'}->{'ipv6_package'}; + if ($pkg) { + (my $file = "$pkg.pm") =~ s|::|/|g; + eval { require $file } or $server->fatal("Could not load ipv6_package $pkg: $@"); + } elsif ($INC{'IO/Socket/IP.pm'}) { # already loaded + $pkg = 'IO::Socket::IP'; + } elsif ($INC{'IO/Socket/INET6.pm'}) { + $pkg = 'IO::Socket::INET6'; + } elsif (eval { require IO::Socket::IP }) { + $pkg = 'IO::Socket::IP'; + } else { + my $err = $@; + if (eval { require IO::Socket::INET6 }) { + $pkg = 'IO::Socket::INET6'; + } else { + $server->fatal("Port ocnfiguration using IPv6 could not be started. Could not find or load IO::Socket::IP or IO::Socket::INET6:\n $err $@") + } } - return 1; + return $ipv6_package = $pkg; } 1; @@ -225,6 +243,11 @@ Net::Server::Proto - Net::Server Protocol compatibility layer configuration in any of the half dozen ways we let you specify it. + NOTE: For IPv6 Net::Server will first try and use the module + listed in server config ipv6_package, then + $Net::Server::ipv6_package, then IO::Socket::IP, then + IO::Socket::INET6 (which is deprecated). + # Net::Server::Proto and its accompanying modules are not # intended to be used outside the scope of Net::Server. @@ -411,7 +434,7 @@ a bare hostname, or a hostname with IPv* specifications. In addition to being able to specify IPV as a separate parameter, ipv may also be passed as a part of the host, as part of the port, as part of the protocol -or may be specified via $ENV{'IPV'}. The order of precidence is as follows: +or may be specified via $ENV{'IPV'}. The order of precedence is as follows: 1) Explicit IPv4 or IPv6 address - wins 2) ipv specified in port diff --git a/lib/Net/Server/Proto/SSL.pm b/lib/Net/Server/Proto/SSL.pm index d975296..7377b7c 100644 --- a/lib/Net/Server/Proto/SSL.pm +++ b/lib/Net/Server/Proto/SSL.pm @@ -2,7 +2,7 @@ # # Net::Server::Proto::SSL - Net::Server Protocol module # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -21,7 +21,7 @@ use strict; use warnings; BEGIN { - # IO::Socket::SSL will automatically become IO::Socket::INET6 if it is available. + # IO::Socket::SSL will automatically become IO::Socket::IP if it is available. # This is different from Net::Server::Proto::SSLEAY that only does it if IPv6 is requested. if (! eval { require IO::Socket::SSL }) { die "Module IO::Socket::SSL is required for SSL - you may alternately try SSLEAY. $@"; @@ -42,6 +42,8 @@ my @ssl_args = qw( SSL_passwd_cb SSL_max_getline_length SSL_error_callback + SSL_verify_callback + SSL_version ); sub NS_proto { 'SSL' } @@ -101,9 +103,11 @@ sub connect { ReuseAddr => 1, Reuse => 1, (($host ne '*') ? (LocalAddr => $host) : ()), # * is all - ($sock->isa('IO::Socket::INET6') ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()), + (($sock->isa('IO::Socket::IP') || $sock->isa('IO::Socket::INET6')) + ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()), (map {$_ => $sock->$_();} grep {/^SSL_/} keys %{*$sock}), SSL_server => 1, + SSL_startHandshake => 0, }) or $server->fatal("Cannot connect to SSL port $port on $host [$!]"); if ($port eq '0' and $port = $sock->sockport) { @@ -124,10 +128,11 @@ sub reconnect { # after a sig HUP $sock->configure_SSL({ (map {$_ => $sock->$_();} grep {/^SSL_/} keys %{*$sock}), SSL_server => 1, + SSL_startHandshake => 0, }); $sock->IO::Socket::INET::fdopen($fd, 'w') or $server->fatal("Error opening to file descriptor ($fd) [$!]"); - if ($sock->isa("IO::Socket::INET6")) { + if ($sock->isa("IO::Socket::IP") || $sock->isa("IO::Socket::INET6")) { my $ipv = $sock->NS_ipv; ${*$sock}{'io_socket_domain'} = ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC(); } @@ -142,11 +147,20 @@ sub reconnect { # after a sig HUP sub accept { my ($sock, $class) = @_; my ($client, $peername); - my $code = $sock->isa('IO::Socket::INET6') ? 'IO::Socket::INET6'->can('accept') : 'IO::Socket::INET'->can('accept'); # TODO - cache this lookup - if (wantarray) { - ($client, $peername) = $code->($sock, $class || ref($sock)); + # SSL_startHandshake = 0 introduced in 1.994 makes accept not call accept_SSL + if ($IO::Socket::SSL::VERSION < 1.994) { + my $code = $sock->isa('IO::Socket::IP') ? 'IO::Socket::IP'->can('accept') + : $sock->isa('IO::Socket::INET6') ? 'IO::Socket::INET6'->can('accept') + : 'IO::Socket::INET'->can('accept'); # TODO - cache this lookup + if (wantarray) { + ($client, $peername) = $code->($sock, $class || ref($sock)); + } else { + $client = $code->($sock, $class || ref($sock)); + } + } elsif (wantarray) { + ($client, $peername) = $sock->SUPER::accept($class || ref($sock)); } else { - $client = $code->($sock, $class || ref($sock)); + $client = $sock->SUPER::accept($class || ref($sock)); } ${*$client}{'_parent_sock'} = $sock; @@ -235,7 +249,7 @@ Net::Server::Proto::SSL - Net::Server SSL protocol. =head1 SYNOPSIS -Until this release, it was preferrable to use the Net::Server::Proto::SSLEAY +Until this release, it was preferable to use the Net::Server::Proto::SSLEAY module. Recent versions include code that overcomes original limitations. See L. @@ -298,8 +312,8 @@ Net::SSLeay. See L. If you know that your server will only need IPv4 (which is the default for Net::Server), you can load IO::Socket::SSL in inet4 mode which -will prevent it from using Socket6 and IO::Socket::INET6 since they -would represent additional and unsued overhead. +will prevent it from using Socket6, IO::Socket::IP, or IO::Socket::INET6 since they +would represent additional and unused overhead. use IO::Socket::SSL qw(inet4); use base qw(Net::Server::Fork); diff --git a/lib/Net/Server/Proto/SSLEAY.pm b/lib/Net/Server/Proto/SSLEAY.pm index 4274f71..61631c1 100644 --- a/lib/Net/Server/Proto/SSLEAY.pm +++ b/lib/Net/Server/Proto/SSLEAY.pm @@ -2,7 +2,7 @@ # # Net::Server::Proto::SSLEAY - Net::Server Protocol module # -# Copyright (C) 2010-2017 +# Copyright (C) 2010-2022 # # Paul Seamons # @@ -65,7 +65,8 @@ sub object { }; # we cannot do this at compile time because we have not yet read the configuration then - @ISA = qw(IO::Socket::INET6) if $ISA[0] eq 'IO::Socket::INET' && Net::Server::Proto->requires_ipv6($server); + $ISA[0] = Net::Server::Proto->ipv6_package($server) + if $ISA[0] eq 'IO::Socket::INET' && Net::Server::Proto->requires_ipv6($server); my @sock = $class->SUPER::new(); foreach my $sock (@sock) { @@ -100,6 +101,7 @@ sub connect { # connect the first time my $port = $sock->NS_port; my $ipv = $sock->NS_ipv; my $lstn = $sock->NS_listen; + my $isa_v6 = Net::Server::Proto->requires_ipv6($server) ? $sock->isa(Net::Server::Proto->ipv6_package($server)) : undef; $sock->SUPER::configure({ LocalPort => $port, @@ -108,7 +110,7 @@ sub connect { # connect the first time ReuseAddr => 1, Reuse => 1, (($host ne '*') ? (LocalAddr => $host) : ()), # * is all - ($sock->isa("IO::Socket::INET6") ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()), + ($isa_v6 ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()), }) || $server->fatal("Can't connect to SSLEAY port $port on $host [$!]"); if ($port eq '0' and $port = $sock->sockport) { @@ -129,7 +131,8 @@ sub reconnect { # connect on a sig -HUP $server->log(3,"Reassociating file descriptor $fd with ".$sock->NS_proto." on [".$sock->NS_host."]:".$sock->NS_port.", using IPv".$sock->NS_ipv); my $resp = $sock->fdopen( $fd, 'w' ) or $server->fatal("Error opening to file descriptor ($fd) [$!]"); - if ($sock->isa("IO::Socket::INET6")) { + my $isa_v6 = Net::Server::Proto->requires_ipv6($server) ? $sock->isa(Net::Server::Proto->ipv6_package($server)) : undef; + if ($isa_v6) { my $ipv = $sock->NS_ipv; ${*$sock}{'io_socket_domain'} = ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC(); } @@ -269,21 +272,30 @@ sub read_until { last; } - # this select appears to only cause read issues - in some cases the underlying select of Net::SSLeay enters into a spinloop - #vec(my $vec = '', $client->fileno, 1) = 1; - #select($vec, undef, undef, undef); + # 'select' prevents spinloops waiting for new data on the socket, and are necessary for non-blocking filehandles. + vec(my $vec = '', $client->fileno, 1) = 1; + select($vec, undef, undef, undef); my $n_empty = 0; while (1) { # 16384 is the maximum amount read() can return my $n = 16384; $n -= ($bytes - length($content)) if $non_greedy && ($bytes - length($content)) < $n; - my $buf = Net::SSLeay::read($ssl, 16384); # read the most we can - continue reading until the buffer won't read any more + my ($buf, $rv) = Net::SSLeay::read($ssl, 16384); # read the most we can - continue reading until the buffer won't read any more if ($client->SSLeay_check_error('SSLeay read_until read')) { last OUTER; } - die "SSLeay read_until: $!\n" if ! defined($buf) && !$!{EAGAIN} && !$!{EINTR} && !$!{ENOBUFS}; - last if ! defined($buf); + + if (! defined($buf)) { + # Preserved from Net/Server/Proto/SSLEAY's version + last if $!{'EAGAIN'} || $!{'EINTR'} || $!{'ENOBUFS'}; + + # Treat these renegotiation errors like EAGAIN - select will handle it and the next SSL_read will resolve it. + last if $rv && ($rv == Net::SSLeay::ERROR_WANT_READ() || $rv == Net::SSLeay::ERROR_WANT_WRITE()); + + die "SSLeay read_until: $!\n"; + } + if (!length($buf)) { last OUTER if !length($buf) && $n_empty++; } @@ -302,6 +314,7 @@ sub read_until { sub read { my ($client, $buf, $size, $offset) = @_; my ($ok, $read) = $client->read_until($size, undef, 1); + defined($_[1]) or $_[1] = ''; substr($_[1], $offset || 0, defined($buf) ? length($buf) : 0, $read); return length $read; } @@ -519,7 +532,7 @@ See L. This module has reliably been used in situations receiving millions of hits on a single box per day. If anybody has any successes or ideas -for improvment under SSLEAY, please email . +for improvement under SSLEAY, please email . Protocol module for Net::Server. This module implements a secure socket layer over tcp (also known as SSL). See L. diff --git a/lib/Net/Server/Proto/TCP.pm b/lib/Net/Server/Proto/TCP.pm index 7120d43..fd33134 100644 --- a/lib/Net/Server/Proto/TCP.pm +++ b/lib/Net/Server/Proto/TCP.pm @@ -2,7 +2,7 @@ # # Net::Server::Proto::TCP - Net::Server Protocol module # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -22,7 +22,7 @@ use warnings; use IO::Socket::INET; use Net::Server::Proto; -our @ISA = qw(IO::Socket::INET); # we may dynamically change this to INET6 based upon our server configuration +our @ISA = qw(IO::Socket::INET); # we may dynamically change this to a v6 compatible class based upon our server configuration sub NS_proto { 'TCP' } sub NS_port { my $sock = shift; ${*$sock}{'NS_port'} = shift if @_; return ${*$sock}{'NS_port'} } @@ -34,7 +34,8 @@ sub object { my ($class, $info, $server) = @_; # we cannot do this at compile time because we have not yet read the configuration then - @ISA = qw(IO::Socket::INET6) if $ISA[0] eq 'IO::Socket::INET' && Net::Server::Proto->requires_ipv6($server); + $ISA[0] = Net::Server::Proto->ipv6_package($server) + if $ISA[0] eq 'IO::Socket::INET' && Net::Server::Proto->requires_ipv6($server); my @sock = $class->SUPER::new(); foreach my $sock (@sock) { @@ -60,6 +61,7 @@ sub connect { my $port = $sock->NS_port; my $ipv = $sock->NS_ipv; my $lstn = $sock->NS_listen; + my $isa_v6 = Net::Server::Proto->requires_ipv6($server) ? $sock->isa(Net::Server::Proto->ipv6_package($server)) : undef; $sock->SUPER::configure({ LocalPort => $port, @@ -68,7 +70,7 @@ sub connect { ReuseAddr => 1, Reuse => 1, (($host ne '*') ? (LocalAddr => $host) : ()), # * is all - ($sock->isa("IO::Socket::INET6") ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()), + ($isa_v6 ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()), }) || $server->fatal("Can't connect to TCP port $port on $host [$!]"); if ($port eq '0' and $port = $sock->sockport) { @@ -87,7 +89,8 @@ sub reconnect { # after a sig HUP $server->log(3,"Reassociating file descriptor $fd with ".$sock->NS_proto." on [".$sock->NS_host."]:".$sock->NS_port.", using IPv".$sock->NS_ipv); $sock->fdopen($fd, 'w') or $server->fatal("Error opening to file descriptor ($fd) [$!]"); - if ($sock->isa("IO::Socket::INET6")) { + my $isa_v6 = Net::Server::Proto->requires_ipv6($server) ? $sock->isa(Net::Server::Proto->ipv6_package($server)) : undef; + if ($isa_v6) { my $ipv = $sock->NS_ipv; ${*$sock}{'io_socket_domain'} = ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC(); } @@ -184,7 +187,7 @@ See L for more information on reading arguments. =item C Returns an object with parameters suitable for eventual creation of -a IO::Socket::INET object listining on UDP. +a IO::Socket::INET object listening on UDP. =item C diff --git a/lib/Net/Server/Proto/UDP.pm b/lib/Net/Server/Proto/UDP.pm index c5f2ffa..835c2c1 100644 --- a/lib/Net/Server/Proto/UDP.pm +++ b/lib/Net/Server/Proto/UDP.pm @@ -2,7 +2,7 @@ # # Net::Server::Proto::UDP - Net::Server Protocol module # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -39,7 +39,8 @@ sub object { # we cannot do this at compile time because we have not yet read the configuration then # (this is the height of rudeness changing another's class on their behalf) - @Net::Server::Proto::TCP::ISA = qw(IO::Socket::INET6) if $Net::Server::Proto::TCP::ISA[0] eq 'IO::Socket::INET' && Net::Server::Proto->requires_ipv6($server); + $Net::Server::Proto::TCP::ISA[0] = Net::Server::Proto->ipv6_package($server) + if $Net::Server::Proto::TCP::ISA[0] eq 'IO::Socket::INET' && Net::Server::Proto->requires_ipv6($server); my $udp = $server->{'server'}->{'udp_args'} ||= do { my %temp = map {$_ => undef} @udp_args; @@ -75,6 +76,7 @@ sub connect { my $host = $sock->NS_host; my $port = $sock->NS_port; my $ipv = $sock->NS_ipv; + my $isa_v6 = Net::Server::Proto->requires_ipv6($server) ? $sock->isa(Net::Server::Proto->ipv6_package($server)) : undef; $sock->SUPER::configure({ LocalPort => $port, @@ -82,7 +84,7 @@ sub connect { ReuseAddr => 1, Reuse => 1, # may not be needed on UDP (($host ne '*') ? (LocalAddr => $host) : ()), # * is all - ($sock->isa("IO::Socket::INET6") ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()), + ($isa_v6 ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()), ($sock->NS_broadcast ? (Broadcast => 1) : ()), }) or $server->fatal("Cannot bind to UDP port $port on $host [$!]"); @@ -117,7 +119,7 @@ See L. =head1 PARAMETERS -The following paramaters may be specified in addition to +The following parameters may be specified in addition to normal command line parameters for a Net::Server. See L for more information on reading arguments. @@ -155,7 +157,7 @@ Default is undef. =item C Returns an object with parameters suitable for eventual creation of -a IO::Socket::INET object listining on UDP. +a IO::Socket::INET object listening on UDP. =item C diff --git a/lib/Net/Server/Proto/UNIX.pm b/lib/Net/Server/Proto/UNIX.pm index 191f8ff..b293cd3 100755 --- a/lib/Net/Server/Proto/UNIX.pm +++ b/lib/Net/Server/Proto/UNIX.pm @@ -2,7 +2,7 @@ # # Net::Server::Proto::UNIX - Net::Server Protocol module # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -80,6 +80,20 @@ sub reconnect { # connect on a sig -HUP $sock->fdopen($fd, 'w') or $server->fatal("Error opening to file descriptor ($fd) [$!]"); } +sub accept { + my ($sock, $class) = (@_); + my ($client, $peername); + if (wantarray) { + ($client, $peername) = $sock->SUPER::accept($class); + } else { + $client = $sock->SUPER::accept($class); + } + if (defined $client) { + $client->NS_port($sock->NS_port); + } + return wantarray ? ($client, $peername) : $client; +} + # a string containing any information necessary for restarting the server # via a -HUP signal # a newline is not allowed @@ -132,11 +146,11 @@ Protocol module for Net::Server. This module implements the UNIX SOCK_STREAM socket type. See L. Any sockets created during startup will be chown'ed to the user and -group specified in the starup arguments. +group specified in the startup arguments. =head1 PARAMETERS -The following paramaters may be specified in addition to normal +The following parameters may be specified in addition to normal command line parameters for a Net::Server. See L for more information on reading arguments. diff --git a/lib/Net/Server/Proto/UNIXDGRAM.pm b/lib/Net/Server/Proto/UNIXDGRAM.pm index 2ffa77f..53c73e8 100644 --- a/lib/Net/Server/Proto/UNIXDGRAM.pm +++ b/lib/Net/Server/Proto/UNIXDGRAM.pm @@ -2,7 +2,7 @@ # # Net::Server::Proto::UNIXDGRAM - Net::Server Protocol module # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -25,7 +25,7 @@ my @udp_args = qw( udp_recv_len udp_recv_flags udp_broadcast -); # we do broadcast just for cacheing parallelism with UDP.pm +); # we do broadcast just for caching parallelism with UDP.pm sub NS_proto { 'UNIXDGRAM' } sub NS_recv_len { my $sock = shift; ${*$sock}{'NS_recv_len'} = shift if @_; return ${*$sock}{'NS_recv_len'} } @@ -88,11 +88,11 @@ Protocol module for Net::Server. This module implements the UNIX SOCK_DGRAM socket type. See L. Any sockets created during startup will be chown'ed to the user and -group specified in the starup arguments. +group specified in the startup arguments. =head1 PARAMETERS -The following paramaters may be specified in addition to normal +The following parameters may be specified in addition to normal command line parameters for a Net::Server. See L for more information on reading arguments. diff --git a/lib/Net/Server/SIG.pm b/lib/Net/Server/SIG.pm index 06ed6bd..417923a 100644 --- a/lib/Net/Server/SIG.pm +++ b/lib/Net/Server/SIG.pm @@ -2,7 +2,7 @@ # # Net::Server::SIG - Safer signals # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # @@ -133,7 +133,7 @@ to fix the unsafe problem. If a process is blocking on select() any signal will short circuit the select. Using this concept, Net::Server::SIG does the least work possible (changing one bit from 0 to 1). And depends upon the actual processing of the signals to take -place immediately after the the select call via the "check_sigs" +place immediately after the select call via the "check_sigs" function. See the example shown above and also see the sigtest.pl script located in the examples directory of this distribution. @@ -157,9 +157,9 @@ register_sig(SIG,'DEFAULT') =item C -Checks to see if any registered signals have occured. If so, it will +Checks to see if any registered signals have occurred. If so, it will play the registered code ref for that signal. Return value is array -containing any SIGNAL names that had occured. +containing any SIGNAL names that had occurred. =item C diff --git a/lib/Net/Server/Single.pm b/lib/Net/Server/Single.pm index ca6021c..a3383a1 100644 --- a/lib/Net/Server/Single.pm +++ b/lib/Net/Server/Single.pm @@ -2,7 +2,7 @@ # # Net::Server::Single - Net::Server personality # -# Copyright (C) 2001-2017 +# Copyright (C) 2001-2022 # # Paul Seamons # diff --git a/lib/Net/Server/Thread.pm b/lib/Net/Server/Thread.pm new file mode 100644 index 0000000..89e940c --- /dev/null +++ b/lib/Net/Server/Thread.pm @@ -0,0 +1,244 @@ +# -*- perl -*- +# +# Net::Server::Thread - Net::Server personality +# +# Copyright (C) 2010-2022 +# +# Paul Seamons +# +# This package may be distributed under the terms of either the +# GNU General Public License +# or the +# Perl Artistic License +# +# All rights reserved. +# +################################################################ + +package Net::Server::Thread; + +use strict; +use base qw(Net::Server::Fork); +use Net::Server::SIG qw(register_sig check_sigs); +use Socket qw(SO_TYPE SOL_SOCKET SOCK_DGRAM); +eval { require threads }; +$@ && die "threads are required to run a server of type Net::Server::Thread"; + +sub net_server_type { __PACKAGE__ } + +sub options { + my $self = shift; + my $ref = $self->SUPER::options(@_); + my $prop = $self->{'server'}; + $ref->{$_} = \$prop->{$_} for qw(max_servers); + return $ref; +} + +sub loop { + my $self = shift; + my $prop = $self->{'server'}; + + $self->register_sig_pass; + + # register some of the signals for safe handling + register_sig(PIPE => 'IGNORE', + INT => sub { $self->server_close() }, + TERM => sub { $self->server_close() }, + QUIT => sub { $self->server_close() }, + HUP => sub { $self->sig_hup() }, + ); + + while (1) { + + threads->yield(); + + while (threads->list() > $prop->{'max_servers'}){ + select undef, undef, undef, .5; # block for a moment (don't look too often) + check_sigs(); + threads->yield(); + } + + $self->pre_accept_hook; + + if (! $self->accept()) { + last if $prop->{'_HUP'}; + last if $prop->{'done'}; + next; + } + + $self->pre_thread_hook; + + threads->new(sub { $self->run_client_connection })->detach; + + # parent + delete($prop->{'client'}) if !$prop->{'udp_true'}; + } +} + +sub close_children { + my $self = shift; + my $prop = $self->{'server'}; + + return unless $prop->{'children'} && scalar keys %{ $prop->{'children'} }; + + foreach my $thr (threads->list) { + $thr->detach if ! $thr->is_detached; + $thr->kill(15) if $thr->is_running; + } + + check_sigs(); # since we have captured signals - make sure we handle them + + register_sig(PIPE => 'DEFAULT', + INT => 'DEFAULT', + TERM => 'DEFAULT', + QUIT => 'DEFAULT', + HUP => 'DEFAULT', + CHLD => 'DEFAULT', + ); +} + +sub pre_accept_hook {}; + +sub accept { + my $self = shift; + my $prop = $self->{'server'}; + + # block on trying to get a handle (select created because we specified multi_port) + my @socks = $prop->{'select'}->can_read(2); + if (check_sigs()) { + return undef if $prop->{'_HUP'}; + return undef if ! @socks; # don't continue unless we have a connection + } + + my $sock = $socks[rand @socks]; + return undef if ! defined $sock; + + # check if this is UDP + if (SOCK_DGRAM == $sock->getsockopt(SOL_SOCKET,SO_TYPE)) { + $prop->{'udp_true'} = 1; + $prop->{'client'} = $sock; + $prop->{'udp_peer'} = $sock->recv($prop->{'udp_data'}, $sock->NS_recv_len, $sock->NS_recv_flags); + + # Receive a SOCK_STREAM (TCP or UNIX) packet + } else { + delete $prop->{'udp_true'}; + $prop->{'client'} = $sock->accept() || return; + } +} + +sub run_client_connection { + my $self = shift; + + $SIG{'INT'} = $SIG{'TERM'} = $SIG{'QUIT'} = sub { threads->exit(0) }; + $SIG{'HUP'} = $SIG{'CHLD'} = 'DEFAULT'; + $SIG{'PIPE'} = 'IGNORE'; + + $self->SUPER::run_client_connection; +} + +sub run_dequeue { die "run_dequeue: virtual method not defined" } + +sub pre_thread_hook {} + +1; + +__END__ + +=head1 NAME + +Net::Server::Thread - Net::Server personality + +=head1 SYNOPSIS + + use base qw(Net::Server::Thread); + + sub process_request { + #...code... + } + + __PACKAGE__->run(); + +=head1 DESCRIPTION + +Please read the pod on Net::Server first. This module is a +personality, or extension, or sub class, of the Net::Server module. + +This personality binds to one or more ports and then waits for a +client connection. When a connection is received, the server spawns a +new thread. The thread handles the request and then closes. + +Because this Net::Server flavor spawns and destroys a thread for each +request, it really should only be used where the processing of each +request may be lengthy or involved. If short and light request are +used, perl may not voluntarily give back the used memory. This is +highly system dependent. + +=head1 ARGUMENTS + +=over 4 + +=item check_for_dead + +Number of seconds to wait before looking for dead children. This only +takes place if the maximum number of child processes (max_servers) has +been reached. Default is 60 seconds. + +=item max_servers + +The maximum number of children to fork. The server will not accept +connections until there are free children. Default is 256 children. + +=back + +=head1 CONFIGURATION FILE + +See L. + +=head1 PROCESS FLOW + +Process flow follows Net::Server until the post_accept phase. At this +point a child is forked. The parent is immediately able to wait for +another request. The child handles the request and then exits. + +=head1 HOOKS + +The Fork server has the following hooks in addition to the hooks +provided by the Net::Server base class. See L + +=over 4 + +=item C<$self-Epre_accept_hook()> + +This hook occurs just before the accept is called. + +=item C<$self-Epre_thread_hook()> + +This hook occurs just after accept but before the fork. + +=item C<$self-Epost_accept_hook()> + +This hook occurs in the child after the accept and fork. + +=back + +=head1 TO DO + +See L + +=head1 AUTHOR + +Paul Seamons + +=head1 SEE ALSO + +Please see also +L, +L, +L, +L, +L, +L +L + +=cut + diff --git a/t/NetServerTest.pm b/t/NetServerTest.pm index 5a6af52..996243a 100644 --- a/t/NetServerTest.pm +++ b/t/NetServerTest.pm @@ -4,7 +4,7 @@ use strict; use IO::Socket; use Exporter; @NetServerTest::ISA = qw(Exporter); -@NetServerTest::EXPORT_OK = qw(prepare_test client_connect ok is like use_ok skip diag); +@NetServerTest::EXPORT_OK = qw(prepare_test client_connect ok is like use_ok skip note diag); my %env; use constant debug => $ENV{'NS_DEBUG'} ? 1 : 0; @@ -16,8 +16,9 @@ END { sub client_connect { shift if $_[0] && $_[0] eq __PACKAGE__; if ($env{'ipv'} && $env{'ipv'} ne 4) { - require IO::Socket::INET6; - return IO::Socket::INET6->new(@_); + return IO::Socket::IP->new(@_) if eval { require IO::Socket::IP }; + return IO::Socket::INET6->new(@_) if eval { require IO::Socket::INET6 }; + die "Could not load IO::Socket::IP or IO::Socket::INET6: $@"; } else { return IO::Socket::INET->new(@_); } @@ -52,7 +53,12 @@ sub prepare_test { if ($args->{'threads'}) { warn "# Checking can_thread\n" if debug; - ok(can_thread(), "Can thread on this platform".($@ ? " ($@)" : '')) || do { SKIP: { skip("Threads don't work on this platform", $N - 1) }; exit; }; + if (can_thread()) { + ok(1, "Can thread on this platform".($@ ? " ($@)" : '')); + } else { + SKIP: { skip("Threads don't work on this platform", $N) }; + exit; + } warn "# Checked can_thread\n" if debug; } else { warn "# Checking can_fork\n" if debug; @@ -189,11 +195,18 @@ sub skip { last SKIP; } -sub diag { +sub note { for my $line (@_) { chomp $line; print "# $line\n"; } } +sub diag { + for my $line (@_) { + chomp $line; + warn "# $line\n"; + } +} + 1; diff --git a/t/Options.t b/t/Options.t index 0d46ff4..b5962fa 100644 --- a/t/Options.t +++ b/t/Options.t @@ -64,6 +64,7 @@ my $obj = eval { FooServer->new }; ok($obj, "Got an object ($@)"); my $server = eval { FooServer->run }; + ok($server, "Got a server ($@)"); my $prop = eval { $server->{'server'} } || {}; is($prop->{'log_level'}, 2, "Correct default log_level"); @@ -82,6 +83,7 @@ if ($sock->NS_ipv == 4) { is(eval { $sock->NS_port }, 20203, "Right port"); is(eval { $sock->NS_proto }, 'TCP', "Right proto"); + ###----------------------------------------------------------------### $prop = eval { FooServer->run(port => 2201)->{'server'} }; diff --git a/t/Port_Configuration.t b/t/Port_Configuration.t index 8624b16..15b54b3 100644 --- a/t/Port_Configuration.t +++ b/t/Port_Configuration.t @@ -11,7 +11,7 @@ package FooServer; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok is use_ok diag skip); +use NetServerTest qw(prepare_test ok is use_ok note skip); prepare_test({ n_tests => 51, plan_only => 1, @@ -52,7 +52,7 @@ sub p_c { # port check my ($pkg, $file, $line) = caller; my ($args, $hash, $args_to_new) = @_; my $prop = eval { ($args_to_new ? FooServer->new(@$args)->run : FooServer->run(@$args))->{'server'} } - || do { diag "$@ at line $line"; {} }; + || do { note "$@ at line $line"; {} }; # use CGI::Ex::Dump qw(debug); # debug $prop; my $got = {bind => $prop->{'_bind'}}; @@ -68,7 +68,7 @@ sub p_c { # port check if ($result eq $test && $str !~ /\|\|/) { ok(1, "$str"); } else { - diag "Failed at line $line"; + note "Failed at line $line"; is($result, $test, "$str"); exit; } @@ -357,10 +357,10 @@ if (!eval { require IO::Socket::SSL }) { if (!eval { require Socket6; - require IO::Socket::INET6; - IO::Socket::INET6->new->configure({LocalPort => 20203, Proto => 'tcp', Listen => 1, ReuseAddr => 1, Domain => Socket6::AF_INET6()}) or die; - IO::Socket::INET6->new->configure({LocalAddr => '::1', LocalPort => 20203, Proto => 'tcp', Listen => 1, ReuseAddr => 1, Domain => Socket6::AF_INET6()}) or die; - IO::Socket::INET6->new->configure({LocalAddr => 'localhost', LocalPort => 20203, Proto => 'tcp', Listen => 1, ReuseAddr => 1, Domain => Socket6::AF_INET6()}) or die; + my $pkg = eval { require IO::Socket::IP } ? 'IO::Socket::IP' : eval { require IO::Socket::INET6 } ? 'IO::Socket::INET6' : die "Could not load IO::Socket::IP or IO::Socket::INET6: $@"; + $pkg->new->configure({LocalPort => 20203, Proto => 'tcp', Listen => 1, ReuseAddr => 1, Domain => Socket6::AF_INET6()}) or die; + $pkg->new->configure({LocalAddr => '::1', LocalPort => 20203, Proto => 'tcp', Listen => 1, ReuseAddr => 1, Domain => Socket6::AF_INET6()}) or die; + $pkg->new->configure({LocalAddr => 'localhost', LocalPort => 20203, Proto => 'tcp', Listen => 1, ReuseAddr => 1, Domain => Socket6::AF_INET6()}) or die; }) { chomp(my $err = $@); SKIP: { diff --git a/t/SSLEAY_test.t b/t/SSLEAY_test.t index a1e33c6..700157a 100644 --- a/t/SSLEAY_test.t +++ b/t/SSLEAY_test.t @@ -4,58 +4,20 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag skip); +use NetServerTest qw(prepare_test ok use_ok note skip); my $env = prepare_test({n_tests => 4, start_port => 20200, n_ports => 2}); # runs three of its own tests -if (! eval { require File::Temp } - || ! eval { require Net::SSLeay } +if (! eval { require Net::SSLeay } ) { SKIP: { skip("Cannot load Net::SSleay libraries to test Socket SSL server: $@", 1); }; exit; } if (! eval { require Net::Server::Proto::SSLEAY }) { - diag "Cannot load SSLEAY library on this platform: $@"; + note "Cannot load SSLEAY library on this platform: $@"; SKIP: { skip("Skipping tests on this platform", 1); }; exit; } -my $pem = << 'PEM'; # this certificate is invalid, please only use for testing ------BEGIN CERTIFICATE----- -MIICKTCCAZICCQDFxHnOjdmTTjANBgkqhkiG9w0BAQUFADBZMQswCQYDVQQGEwJB -VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0 -cyBQdHkgTHRkMRIwEAYDVQQDDAlsb2NhbGhvc3QwHhcNMTIwMTE0MTgzMjMwWhcN -NzUxMTE0MTIwNDE0WjBZMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0 -ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMRIwEAYDVQQDDAls -b2NhbGhvc3QwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBAKLGfQantHdi/0cd -eoOHRbWKChpI/g84hU8SnwmrSMZR0x76vDLKMDYohISoKxRPx6j2M2x3P4K+kEJm -C5H9iGdD9p9ljGnRdkGp5yYeuwWfePRb4AOwP5qgQtEb0OctFIMjcAIIAw/lsnUs -hGnom0+uA9W2H63PgO0o4qiVAn7NAgMBAAEwDQYJKoZIhvcNAQEFBQADgYEATDGA -dYRl5wpsYcpLgNzu0M4SENV0DAE2wNTZ4LIR1wxHbcxdgzMhjp0wwfVQBTJFNqWu -DbeIFt4ghPMsUQKmMc4+og2Zyll8qev8oNgWQneKjDAEKKpzdvUoRZyGx1ZocGzi -S4LDiMd4qhD+GGePcHwmR8x/okoq58xZO/+Qygc= ------END CERTIFICATE----- ------BEGIN RSA PRIVATE KEY----- -MIICXAIBAAKBgQCixn0Gp7R3Yv9HHXqDh0W1igoaSP4POIVPEp8Jq0jGUdMe+rwy -yjA2KISEqCsUT8eo9jNsdz+CvpBCZguR/YhnQ/afZYxp0XZBqecmHrsFn3j0W+AD -sD+aoELRG9DnLRSDI3ACCAMP5bJ1LIRp6JtPrgPVth+tz4DtKOKolQJ+zQIDAQAB -AoGASXDmvhbyfJ8k8HAjc66XzBWxAzUFs9Zbh1aufM1UM259o8+bFAtXf0f+ql+5 -uBtaySf0Aa8374SNT/f8pmzOmpiXMvYRz8Z5Gc6JYpYd/PrCoSCGtP+NdCvk7Y5c -eUmmpiEto4+fgCAKrtqc5jm8eBWn/yNhQNDBVJ9qX+kXQOECQQDVBLvBZaECSMTm -djKuPlZ93cmyI7g+TURTl2N08fz4xQVVbo5+AV0GsEZupBpTgrHpLTk8gKP/nfdR -9KWZldbZAkEAw55+SqrVTv4cI0fMvC0t8Wl46zTkY9tK65TGnbO1DbTQh9qs+NwH -+v3uu47ef5w/73xLtDjQouz//0z5rgF3FQJAfrmOKQOYwY8g9CmlBNu5ALAM6Zku -ZoH4//G0DUJYyHYNMkHPK08MVIpRnEisELpTtPBeeIvfBJapJ2xvh+sIIQJASeY4 -I5EB4EOS8akQKQ6QSqDjs0dZ+HdBiFm95pmbDkB+frQXoDPPN/xyEZzZZS/r31b/ -amgEOWh7FUFJGXkoOQJBALfOgsiss0lASlOXAg1rwO4m2OaDiaEde01PLcSjIaKl -Qfbzc7ZYF+fGDsHHlD5Kgj1CGaWCVVHqCv4UHSrA/gM= ------END RSA PRIVATE KEY----- -PEM - -my ($pem_fh, $pem_filename) = - File::Temp::tempfile(SUFFIX => '.pem', UNLINK => 1); -print $pem_fh $pem; -$pem_fh->close; - require Net::Server; @Net::Server::Test::ISA = qw(Net::Server); @@ -113,10 +75,10 @@ my $ok = eval { Net::SSLeay::connect($ssl); my $line = Net::SSLeay::read($ssl); die "Didn't get the type of line we were expecting: ($line)" if $line !~ /Net::Server/; - diag $line; + note $line; Net::SSLeay::write($ssl, "quit\n"); my $line2 = Net::SSLeay::read($ssl); - diag $line2; + note $line2; $remote = NetServerTest::client_connect(PeerAddr => $env->{'hostname'}, PeerPort => $env->{'ports'}->[0]) || die "Couldn't open child to sock: $!"; @@ -147,11 +109,11 @@ my $ok = eval { proto => 'ssleay', background => 0, setsid => 0, - SSL_cert_file => $pem_filename, - SSL_key_file => $pem_filename, + SSL_cert_file => "$Bin/self_signed.crt", + SSL_key_file => "$Bin/self_signed.key", ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -159,4 +121,4 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/SSL_test.t b/t/SSL_test.t index 9aef205..a6afd44 100644 --- a/t/SSL_test.t +++ b/t/SSL_test.t @@ -4,11 +4,10 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag skip); +use NetServerTest qw(prepare_test ok use_ok note skip); my $env = prepare_test({n_tests => 5, start_port => 20200, n_ports => 1}); # runs three of its own tests -if (! eval { require File::Temp } - || ! eval { require IO::Socket::SSL } +if (! eval { require IO::Socket::SSL } ) { SKIP: { skip("Cannot load IO::Socket::SSL libraries to test Socket SSL server: $@", 2); }; exit; @@ -16,41 +15,56 @@ if (! eval { require File::Temp } my $pem = << 'PEM'; # this certificate is invalid, please only use for testing -----BEGIN CERTIFICATE----- -MIICKTCCAZICCQDFxHnOjdmTTjANBgkqhkiG9w0BAQUFADBZMQswCQYDVQQGEwJB -VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0 -cyBQdHkgTHRkMRIwEAYDVQQDDAlsb2NhbGhvc3QwHhcNMTIwMTE0MTgzMjMwWhcN -NzUxMTE0MTIwNDE0WjBZMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0 -ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMRIwEAYDVQQDDAls -b2NhbGhvc3QwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBAKLGfQantHdi/0cd -eoOHRbWKChpI/g84hU8SnwmrSMZR0x76vDLKMDYohISoKxRPx6j2M2x3P4K+kEJm -C5H9iGdD9p9ljGnRdkGp5yYeuwWfePRb4AOwP5qgQtEb0OctFIMjcAIIAw/lsnUs -hGnom0+uA9W2H63PgO0o4qiVAn7NAgMBAAEwDQYJKoZIhvcNAQEFBQADgYEATDGA -dYRl5wpsYcpLgNzu0M4SENV0DAE2wNTZ4LIR1wxHbcxdgzMhjp0wwfVQBTJFNqWu -DbeIFt4ghPMsUQKmMc4+og2Zyll8qev8oNgWQneKjDAEKKpzdvUoRZyGx1ZocGzi -S4LDiMd4qhD+GGePcHwmR8x/okoq58xZO/+Qygc= +MIIDYjCCAkqgAwIBAgIJAP1GPpBIeA7QMA0GCSqGSIb3DQEBCwUAMEUxCzAJBgNV +BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX +aWRnaXRzIFB0eSBMdGQwIBcNMjAwNTI0MDUyMzQwWhgPMjI5NDAzMDgwNTIzNDBa +MEUxCzAJBgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJ +bnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAw +ggEKAoIBAQDlVci9G9HPwKYhr0kSFT15FcQ1FDNxcn5aMP41ETieM6HASyPFfZ/H +TnxE1kX3V2fGpaQVpkfrMqAfiGQ0nntXoQDosP3QYO4X0SfYNsWGDa0KKg1xQB9N +8Xe348Gxm9/ncGzuBdYpasohrcBhBQqJvor0FVV9IlIDpBvXjl9FsleKj9vlxdUZ +sgHB01lTi+5cIUQiy2fkHhMt6R9PUXmeBOjEzNe0o3uftdruBSDsMoRAJZ27yDOq +TfpBWhHAF+6PGN0hyVvdePUSX6CeG8CsgzZorHPr5WBzZ1IlRoT3TdFqtZyEfGfV +rND9wdoAiz50CPWXWHlokhlIeBCc2vLPAgMBAAGjUzBRMB0GA1UdDgQWBBTme3pQ +NkZAqxlFzr+TcwCsJ9WJyjAfBgNVHSMEGDAWgBTme3pQNkZAqxlFzr+TcwCsJ9WJ +yjAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQDTQ+KNgySd+Kd2 +oET16XapSvGvA3OkdcNq481HSvpOIwDQp38z4/IhAPo2IvANeGLhw60fmE2uLW88 +ewa+/qIGHu3xVuSv0g+UJ0QZLkdWBiF4cEsu49ZnwfBVUXpzNZNamF1Nk1yAWhQF ++DYxZYklllTdtwo7ImMozSPC0DzEQKF2VBj6Dtig2VDRGArl4iZ6MX8+WGK3C+05 +9doZ+2pdqyCZf074Gs7oqjm1T3llvEJBlpxYGSsjcRCkKazBE3IcjSu+6/wkzZLR +ckaRuEQeE7e4IK/c1R8njOygzl07VFnFNprC9M0DVvuYI7ZIFXS+YEedvuxKvyva +GcEBq7Ms -----END CERTIFICATE----- ------BEGIN RSA PRIVATE KEY----- -MIICXAIBAAKBgQCixn0Gp7R3Yv9HHXqDh0W1igoaSP4POIVPEp8Jq0jGUdMe+rwy -yjA2KISEqCsUT8eo9jNsdz+CvpBCZguR/YhnQ/afZYxp0XZBqecmHrsFn3j0W+AD -sD+aoELRG9DnLRSDI3ACCAMP5bJ1LIRp6JtPrgPVth+tz4DtKOKolQJ+zQIDAQAB -AoGASXDmvhbyfJ8k8HAjc66XzBWxAzUFs9Zbh1aufM1UM259o8+bFAtXf0f+ql+5 -uBtaySf0Aa8374SNT/f8pmzOmpiXMvYRz8Z5Gc6JYpYd/PrCoSCGtP+NdCvk7Y5c -eUmmpiEto4+fgCAKrtqc5jm8eBWn/yNhQNDBVJ9qX+kXQOECQQDVBLvBZaECSMTm -djKuPlZ93cmyI7g+TURTl2N08fz4xQVVbo5+AV0GsEZupBpTgrHpLTk8gKP/nfdR -9KWZldbZAkEAw55+SqrVTv4cI0fMvC0t8Wl46zTkY9tK65TGnbO1DbTQh9qs+NwH -+v3uu47ef5w/73xLtDjQouz//0z5rgF3FQJAfrmOKQOYwY8g9CmlBNu5ALAM6Zku -ZoH4//G0DUJYyHYNMkHPK08MVIpRnEisELpTtPBeeIvfBJapJ2xvh+sIIQJASeY4 -I5EB4EOS8akQKQ6QSqDjs0dZ+HdBiFm95pmbDkB+frQXoDPPN/xyEZzZZS/r31b/ -amgEOWh7FUFJGXkoOQJBALfOgsiss0lASlOXAg1rwO4m2OaDiaEde01PLcSjIaKl -Qfbzc7ZYF+fGDsHHlD5Kgj1CGaWCVVHqCv4UHSrA/gM= ------END RSA PRIVATE KEY----- +-----BEGIN PRIVATE KEY----- +MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQDlVci9G9HPwKYh +r0kSFT15FcQ1FDNxcn5aMP41ETieM6HASyPFfZ/HTnxE1kX3V2fGpaQVpkfrMqAf +iGQ0nntXoQDosP3QYO4X0SfYNsWGDa0KKg1xQB9N8Xe348Gxm9/ncGzuBdYpasoh +rcBhBQqJvor0FVV9IlIDpBvXjl9FsleKj9vlxdUZsgHB01lTi+5cIUQiy2fkHhMt +6R9PUXmeBOjEzNe0o3uftdruBSDsMoRAJZ27yDOqTfpBWhHAF+6PGN0hyVvdePUS +X6CeG8CsgzZorHPr5WBzZ1IlRoT3TdFqtZyEfGfVrND9wdoAiz50CPWXWHlokhlI +eBCc2vLPAgMBAAECggEBAIOMzqYzhAnQ7zsZSif2SRng83ijCtNDotjni5ozM7AD +2//q2i0Z34I7MitmYiH8YEnhkBrfFBgFJTaRTTGlywi8EUJo7F8QiuLclid/W5SG +2cCf2LAi4RIbtdmk6uGPkUM4CTQL4wpE+IeTHGxKsP3Mb/aNGkm6WyM9ir7+KwZV +rZtNl5wiHRbzwSoMmHT80DKrkrbNr5nkAgd+F2oofAIMwAbex4TQZ5Vi0NTAPGSX +yQ7jOYFnsaAfJymrjTXYGOlP+p/lEFAC27SGEECtI5uCWh731GY5DPNwUb3Qct05 +LRORiMxrymKjwNy3uSNkNwUczawWGPaFzCRk9JB85LkCgYEA+yET0GmgIgUd3NaM +ntqwEmeKad1XRxP5652exfrydKunYApbMlcd9GE5UyiqN+C7QhfQEWwGQji008Dc +T+2sKA0EpJIcmNlLjLyP0+anlJlYqAoljvwXMCcifFMV2YpX/AKeF9wmdn94Lawf +rkfM8v/jIHKqid/Yewik40bhsA0CgYEA6ch+Q/QYubL0a4msYZ726cam7YpYbhfi +iTud59KOmtxBczZEd5z5wv6YKbebEHRCpELuZc/ENekXR3gheocW0XuR0GnQifhl +MfhbG9yT+oy8E6ljHPsZi2OVbz6UfxGnjZzkBubU9AYPdcBev4bw5vdk0xLoUMmA +ViqgGqIXG0sCgYEAvXtqwOFBwwmLS7rSpXWqTmizhkdM+EN5Wi82wnkjgaaXBp8p +ymTzJBZLs5RGQx0dDbR7+PlCC6tPvUqSsPhK4nlYHHhmfWnPWGRaPW+W2EeQHlJx +nl5VfK66lYX3QYnh8zNiZ+xjVRu+6O8rhEuGt38dt7jtNlSgucx+5UHxPe0CgYA4 +9RcGOU9Y1ufD13v/ILqphDOhRgZ7dChGJRc4ps0Fn8n2Zu9RcRZM0riB2XDXFmwy +Fvh8J513QP3h9Lu7XXRKv19sNouPQcxt20NfS2NmNKmR5L/4DJlRo4aB3u5Q8x0u +XF4V7GFPvrY/iwnKgfbpXrba0g11uVIiLCprsrgMdwKBgHvebXxV8hmROAoUd1F3 +wm9heCTdZNVD3ci/AYW3/n04weZqkAfdmaev64jFBPnXdTZDC12qXprOWYpeal3A +eHjpRZRphXwOCJ6me14qnRL6ir6J1o/DzJIATszpf7GTnlqDUlBQNTT9SOmbgIYq +YftRX/a/t18CpitrzViVgQ+l +-----END PRIVATE KEY----- PEM -my ($pem_fh, $pem_filename) = - File::Temp::tempfile(SUFFIX => '.pem', UNLINK => 1); -print $pem_fh $pem; -$pem_fh->close; - use_ok qw(Net::Server::Proto::SSL) or exit; require Net::Server; @Net::Server::Test::ISA = qw(Net::Server); @@ -84,10 +98,10 @@ my $ok = eval { my $line = <$remote>; die "Didn't get the type of line we were expecting: ($line)" if $line !~ /Net::Server/; - diag $line; + note $line; print $remote "exit\n"; my $line2 = <$remote>; - diag $line2; + note $line2; return 1; ### child does the server @@ -100,13 +114,13 @@ my $ok = eval { port => $env->{'ports'}->[0], proto => 'ssl', ipv => '*', # $env->{'ipv'}, # IO::Socket::SSL always tries INET6 if it is available so we should listen on 6 if it is available - SSL_cert_file => $pem_filename, - SSL_key_file => $pem_filename, + SSL_cert_file => "$Bin/self_signed.crt", + SSL_key_file => "$Bin/self_signed.key", background => 0, setsid => 0, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -114,4 +128,4 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/Server_BASE.t b/t/Server_BASE.t index 527c1ab..b9666ea 100644 --- a/t/Server_BASE.t +++ b/t/Server_BASE.t @@ -4,7 +4,7 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag); +use NetServerTest qw(prepare_test ok use_ok note); my $env = prepare_test({n_tests => 6, start_port => 20100, n_ports => 3}); # runs three of its own tests use_ok('Net::Server'); @@ -44,13 +44,13 @@ my $ok = eval { background => 0, setsid => 0, ); - } || diag("Trouble running server: $@"); + } || note("Trouble running server: $@"); exit; } alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); ### start up a multiport server and connect to it @@ -91,7 +91,7 @@ $ok = eval { setsid => 0, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -99,4 +99,4 @@ $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the multiport server") || diag("Error: $@"); +ok($ok, "Got the correct output from the multiport server") || note("Error: $@"); diff --git a/t/Server_Fork.t b/t/Server_Fork.t index 7d2bf5a..f931c1b 100644 --- a/t/Server_Fork.t +++ b/t/Server_Fork.t @@ -4,7 +4,7 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag); +use NetServerTest qw(prepare_test ok use_ok note); my $env = prepare_test({n_tests => 5, start_port => 20200, n_ports => 1}); # runs three of its own tests use_ok('Net::Server::Fork'); @@ -49,7 +49,7 @@ my $ok = eval { setsid => 0, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -57,5 +57,5 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/Server_INET.t b/t/Server_INET.t index e448229..772057f 100644 --- a/t/Server_INET.t +++ b/t/Server_INET.t @@ -4,7 +4,7 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag); +use NetServerTest qw(prepare_test ok use_ok note); my $env = prepare_test({n_tests => 5, start_port => 20300, n_ports => 1}); # runs three of its own tests use_ok('Net::Server::INET'); @@ -52,7 +52,7 @@ my $ok = eval { setsid => 0, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -60,4 +60,4 @@ my $ok = eval { alarm 0; }; alarm 0; -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/Server_MultiType.t b/t/Server_MultiType.t index 5f37bff..a45b77b 100644 --- a/t/Server_MultiType.t +++ b/t/Server_MultiType.t @@ -4,7 +4,7 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag); +use NetServerTest qw(prepare_test ok use_ok note); my $env = prepare_test({n_tests => 5, start_port => 20400, n_ports => 1}); # runs three of its own tests use_ok('Net::Server::MultiType'); @@ -13,7 +13,7 @@ use_ok('Net::Server::MultiType'); sub accept { $env->{'signal_ready_to_test'}->(); - diag("Net::Server::MultiType::ISA: (".join(",",@Net::Server::MultiType::ISA).")"); + note("Net::Server::MultiType::ISA: (".join(",",@Net::Server::MultiType::ISA).")"); return shift->SUPER::accept(@_); } @@ -30,7 +30,7 @@ my $ok = eval { my $remote = NetServerTest::client_connect(PeerAddr => $env->{'hostname'}, PeerPort => $env->{'ports'}->[0]) || die "Couldn't open child to sock: $!"; my $line = <$remote>; - diag($line); + note($line); die "Didn't get the type of line we were expecting: ($line)" if $line !~ /Net::Server/; print $remote "exit\n"; return 1; @@ -49,7 +49,7 @@ my $ok = eval { server_type => 'Single', ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -57,4 +57,4 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/Server_Multiplex.t b/t/Server_Multiplex.t index 1fbd377..1a05601 100644 --- a/t/Server_Multiplex.t +++ b/t/Server_Multiplex.t @@ -4,11 +4,11 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag skip); +use NetServerTest qw(prepare_test ok use_ok note skip); my $env = prepare_test({n_tests => 5, start_port => 20200, n_ports => 1}); if (! eval{ require IO::Multiplex; }) { - diag("Error loading IO::Multiplex: $@"); + note("Error loading IO::Multiplex: $@"); SKIP: { skip("No IO::Multiplex installed\n", 2) }; exit; } @@ -79,7 +79,7 @@ my $ok = eval { setsid => 0, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -87,5 +87,5 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/Server_PreFork.t b/t/Server_PreFork.t index 175ee93..9e49a5c 100644 --- a/t/Server_PreFork.t +++ b/t/Server_PreFork.t @@ -4,7 +4,7 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag); +use NetServerTest qw(prepare_test ok use_ok note); my $env = prepare_test({n_tests => 5, start_port => 20600, n_ports => 2}); # runs three of its own tests use_ok('Net::Server::PreFork'); @@ -61,7 +61,7 @@ my $ok = eval { setsid => 0, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -69,4 +69,4 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/Server_PreForkSimple.t b/t/Server_PreForkSimple.t index 4184617..c8b817e 100644 --- a/t/Server_PreForkSimple.t +++ b/t/Server_PreForkSimple.t @@ -4,7 +4,7 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag); +use NetServerTest qw(prepare_test ok use_ok note); my $env = prepare_test({n_tests => 5, start_port => 20500, n_ports => 2}); # runs three of its own tests use_ok('Net::Server::PreForkSimple'); @@ -59,7 +59,7 @@ my $ok = eval { setsid => 0, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -67,4 +67,4 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/Server_Single.t b/t/Server_Single.t index fa972e5..4c93392 100644 --- a/t/Server_Single.t +++ b/t/Server_Single.t @@ -3,7 +3,7 @@ use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag); +use NetServerTest qw(prepare_test ok use_ok note); prepare_test({n_tests => 1, plan_only => 1}); use_ok('Net::Server::Single'); diff --git a/t/Server_Thread.t b/t/Server_Thread.t new file mode 100644 index 0000000..c27d928 --- /dev/null +++ b/t/Server_Thread.t @@ -0,0 +1,55 @@ +#!/usr/bin/env perl + +package Net::Server::Test; +use strict; +use FindBin qw($Bin); +use lib $Bin; +use NetServerTest qw(prepare_test ok use_ok note); +my $env = prepare_test({n_tests => 5, start_port => 20200, n_ports => 1, threads => 1}); # runs four of its own tests + +use_ok('Net::Server::Thread'); +@Net::Server::Test::ISA = qw(Net::Server::Thread); + +sub accept { + my $self = shift; + exit if $^O eq 'MSWin32' && $self->{'__one_accept_only'}++; + $env->{'signal_ready_to_test'}->(); + return $self->SUPER::accept(@_); +} + +my $ok = eval { + local $SIG{'ALRM'} = sub { die "Timeout\n" }; + alarm $env->{'timeout'}; + + ### child does the server + threads->create(sub { + eval { + alarm $env->{'timeout'}; + close STDERR; + Net::Server::Test->run( + port => $env->{'ports'}->[0], + host => $env->{'hostname'}, + ipv => $env->{'ipv'}, + background => 0, + setsid => 0, + ); + } || do { + note("Trouble running server: $@"); + ok(0, "Failed during run of server"); + exit; + }; + threads->exit(0); + })->detach; + + # parent is the client + $env->{'block_until_ready_to_test'}->(); + + my $remote = NetServerTest::client_connect(PeerAddr => $env->{'hostname'}, PeerPort => $env->{'ports'}->[0]) || die "Couldn't open child to sock: $!"; + my $line = <$remote>; + die "Didn't get the type of line we were expecting: ($line)" if $line !~ /Net::Server/; + print $remote "exit\n"; + alarm(0); + return 1; +}; +alarm(0); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/Server_http.t b/t/Server_http.t index 5bdefc9..d57a120 100644 --- a/t/Server_http.t +++ b/t/Server_http.t @@ -4,7 +4,7 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag); +use NetServerTest qw(prepare_test ok use_ok note); my $env = prepare_test({n_tests => 5, start_port => 20200, n_ports => 1}); # runs three of its own tests use_ok('Net::Server::HTTP'); @@ -33,7 +33,7 @@ my $ok = eval { my $remote = NetServerTest::client_connect(PeerAddr => $env->{'hostname'}, PeerPort => $env->{'ports'}->[0]) || die "Couldn't open child to sock: $!"; - print $remote "GET / HTTP/1.0\nFoo: bar\n\n"; + print $remote "GET / HTTP/1.0\nFoo: bar\nUser-Agent: perl-socket/1.0\nReferer: file:///Server_http.t\n\n"; ### sample a line my @lines = <$remote>; @@ -45,7 +45,8 @@ my $ok = eval { } else { eval { alarm $env->{'timeout'}; - close STDERR; + open(my $fh, ">&=", STDOUT) or die "Could not clone STDOUT: $!"; + Net::Server::Test->run( port => $env->{'ports'}->[0], host => $env->{'hostname'}, @@ -53,9 +54,18 @@ my $ok = eval { server_type => 'Single', background => 0, setsid => 0, + log_function => sub { + my ($level, $msg) = @_; + note "LOG:$level: $msg" + if $ENV{'DEBUG_LOG'}; + }, + access_log_function => sub { + select $fh; + note "ACCESS: $_[0]"; + }, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; alarm(0); @@ -64,4 +74,4 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/Server_psgi.t b/t/Server_psgi.t index d1e68e3..300e844 100644 --- a/t/Server_psgi.t +++ b/t/Server_psgi.t @@ -4,7 +4,7 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag); +use NetServerTest qw(prepare_test ok use_ok note); my $env = prepare_test({n_tests => 5, start_port => 20208, n_ports => 1}); # runs three of its own tests use_ok('Net::Server::PSGI'); @@ -55,7 +55,7 @@ my $ok = eval { setsid => 0, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; alarm(0); @@ -64,4 +64,4 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/UDP_test.t b/t/UDP_test.t index c9a9129..71c59da 100644 --- a/t/UDP_test.t +++ b/t/UDP_test.t @@ -4,7 +4,7 @@ package Net::Server::Test; use strict; use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag); +use NetServerTest qw(prepare_test ok use_ok note); my $env = prepare_test({n_tests => 5, start_port => 20700, n_ports => 2}); # runs three of its own tests use_ok('Net::Server'); @@ -63,7 +63,7 @@ my $ok = eval { setsid => 0, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -71,4 +71,4 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/UNIX_test.t b/t/UNIX_test.t index 74dbaca..5aecc07 100644 --- a/t/UNIX_test.t +++ b/t/UNIX_test.t @@ -7,7 +7,7 @@ use File::Spec::Functions qw(catfile); use English qw($UID $GID); use FindBin qw($Bin); use lib $Bin; -use NetServerTest qw(prepare_test ok use_ok diag skip); +use NetServerTest qw(prepare_test ok use_ok note skip); my $env = prepare_test({n_tests => 5, start_port => 20800, n_ports => 1}); # runs three of its own tests if ($^O eq 'MSWin32') { @@ -25,6 +25,24 @@ sub accept { my $socket_dir = tempdir(CLEANUP => 1); my $socket_file = catfile($socket_dir, 'socket'); # must do before fork + +sub allow_deny_hook { + my ($server, $client) = @_; + + ### check the properties of the client socket + if($client->NS_proto eq 'UNIX') { + return $client->NS_port eq $socket_file; + } else { + return $client->NS_port == $env->{'ports'}->[0]; + } +} + +sub process_request { + my ($self, $client) = @_; + print $client "NS_port: ".$client->NS_port."\n"; + return $self->SUPER::process_request($client); +} + my $ok = eval { local $SIG{'ALRM'} = sub { die "Timeout\n" }; alarm $env->{'timeout'}; @@ -40,6 +58,8 @@ my $ok = eval { my $remote = IO::Socket::UNIX->new(Peer => $socket_file); die "No socket returned [$!]" if ! defined $remote; my $line = <$remote>; + note "# unix port - $line"; + $line = <$remote>; die "Didn't get the type of line we were expecting: ($line)" if $line !~ /Net::Server/; print $remote "quite\n"; @@ -49,6 +69,8 @@ my $ok = eval { PeerPort => $env->{'ports'}->[0], Proto => 'tcp') || die "Couldn't open to sock: $!"; + $line = <$remote>; + note "# tcp port - $line"; $line = <$remote>; die "Didn't get the type of line we were expecting: ($line)" if $line !~ /Net::Server/; print $remote "exit\n"; @@ -69,7 +91,7 @@ my $ok = eval { setsid => 0, ); } || do { - diag("Trouble running server: $@"); + note("Trouble running server: $@"); kill(9, $ppid) && ok(0, "Failed during run of server"); }; exit; @@ -77,4 +99,4 @@ my $ok = eval { alarm(0); }; alarm(0); -ok($ok, "Got the correct output from the server") || diag("Error: $@"); +ok($ok, "Got the correct output from the server") || note("Error: $@"); diff --git a/t/self_signed.crt b/t/self_signed.crt new file mode 100644 index 0000000..e8f878a --- /dev/null +++ b/t/self_signed.crt @@ -0,0 +1,20 @@ +-----BEGIN CERTIFICATE----- +MIIDPzCCAiegAwIBAgIUSFiFOj2VU0JLtIZFpjk04YpT71MwDQYJKoZIhvcNAQEL +BQAwLzELMAkGA1UEBhMCVVMxCzAJBgNVBAgMAlVUMRMwEQYDVQQKDApOZXQtU2Vy +dmVyMB4XDTIyMTIwMTA1MjgwNloXDTQ3MTIyMDA1MjgwNlowLzELMAkGA1UEBhMC +VVMxCzAJBgNVBAgMAlVUMRMwEQYDVQQKDApOZXQtU2VydmVyMIIBIjANBgkqhkiG +9w0BAQEFAAOCAQ8AMIIBCgKCAQEAsR1ZoL9cUMDaSLP4Fu72HjoPnioB/wAErAGu +NdR0eZi1m9nKVaXv919XRDQi7CZTMF0/4fjrvcQsLbXSk7hGgejwQKzNwkz9gw28 +qQTLGNYmj2r1MEKTDGL5OphpKso+Zak7x7dL2DzT4Xd3pF7rulho2gJ0fBEK/ecu +vthu4I/LO39JJPqnogLVd0+w01iui1SCtz+EA5zT/jZZVlU7+hhefFYIBNfGpBWH +9h+bwEBYl68mOCH9NAEFXZiUgpnAT69ckAarLO3LIcDEjkSBQQa5TYS4zMMM1fE0 +Zcz/qmg0FMCJZMLgo+kx0tESuzn8RMhEDwgz5HtXjCFrPih6bQIDAQABo1MwUTAd +BgNVHQ4EFgQUc/Opex3jj14cXzDWm3II9WO5ANUwHwYDVR0jBBgwFoAUc/Opex3j +j14cXzDWm3II9WO5ANUwDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAAOC +AQEAl1chj1hbVHMd5iboIhjHhgtPx1Lut8Oyg1Px9sQKib8SNXVPe0QX7LHtBimJ +P+wNR2esK/0IF1OQ4pJli8R/LMDrCrTKXhn1mxDM6/2qBlwWPAn+wZuy20r+j1iy +shWXSOqamvPZT1kKEoQBWyQHiWtlb/irwsCCyJglNuLDHCjXz4J09Qf/67yt927J +qv9WKAmC62DPIWRRi+M7uVBQwsSCVoBqrulMdnWRLEiv1CmfuDYdShzh5WaQgpNE +tho7nbuvYO9axhx6bfzD+3exgFLOnf2MBzqspqzUbaqv2aZ5f65yFAxHZfzMoF3d +CmbFC39zM6+dTF8bsfPv56Kw6g== +-----END CERTIFICATE----- diff --git a/t/self_signed.key b/t/self_signed.key new file mode 100644 index 0000000..3119a24 --- /dev/null +++ b/t/self_signed.key @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQCxHVmgv1xQwNpI +s/gW7vYeOg+eKgH/AASsAa411HR5mLWb2cpVpe/3X1dENCLsJlMwXT/h+Ou9xCwt +tdKTuEaB6PBArM3CTP2DDbypBMsY1iaPavUwQpMMYvk6mGkqyj5lqTvHt0vYPNPh +d3ekXuu6WGjaAnR8EQr95y6+2G7gj8s7f0kk+qeiAtV3T7DTWK6LVIK3P4QDnNP+ +NllWVTv6GF58VggE18akFYf2H5vAQFiXryY4If00AQVdmJSCmcBPr1yQBqss7csh +wMSORIFBBrlNhLjMwwzV8TRlzP+qaDQUwIlkwuCj6THS0RK7OfxEyEQPCDPke1eM +IWs+KHptAgMBAAECggEAHV5vzIk2wlg8SfZ3wrvEuX3otZIjKxjibXBI5jmwx7IE +GVALrliZ+kPHuXJIwS5YuIoZ6/tmAd1b8wd1n9Occ3HAFwVgiCHSns7iFAfMsrVe +BwWWGzbK4fCugaIgvDz1jE9773HMRJLPkpFIGEw6G/gJiO8DyEfeMfyKApDqj9dY ++ENTg5j4FdN3Wv8xiQyhh+LiHpvZYobibjjP2I12iZxgLA+Q9/lZ6SwVvz9+4Apo +qA5NaQtEMHn36nDz7/+fYYT+YpeXD7LSSvdo+bCRxpMef34Js3ymOwl675I3GEi2 +1ka3yLrEGHgohhDM8QnmHA1ccn8VYuRMrshIjkV0wQKBgQDz0yeOo5eYljHoYvoy +EO4bdtipduHz2Ut87L3V/ziymRFdTems2L4/x7pnHt3XQdmsK/KLMFoKXjicny/H +zKAcgo916Pz09QcTeRHW4nKST8yb4AG+SYGgG9epC7LQdqyJ3nRAttBsUmdyz2IL +p6mU2adGHvuhomaLCIPf0hnsLQKBgQC59W4ziAlL3QlbyVhNtsHvEFn/P8P4ttpB +Jt3ZDL8YeXC7zrMY4EAXpELLuLQgyg88rE64AldSp0cPY2Tf1xzRt2hycxhlXqlD +ZHIU/cqhqn5gJoEJVFnmtmt/9f/C4w4F9IODDJMO9vQcF/xGfWRQQ1j/rywfcRpB +p8U06FxvQQKBgDV+75/pHrq4wWx2QuS3ODbIZZMQ5VRmKZzYKHKKU7tDwD6TeKCW +0W8W+Dvl1tCCvyp6XfXR/v9lWtBqUMZqi/qVXrqFCvMHy6ynFJXsCy002vScOmWw +pQMm+LM7QNliIEsDhsgoFCSgE9hpzd42xAtHkd7dr2HwSsVYce6qn0tlAoGBAIhW +UdqEJVSylPbvksc/c8ZDdcg3RwXlgfT8evB0cPKPrsBzFknpt/PdYX+dRqs3mZ5B +MmGkjcMyk13L4JxgSWfUkUY/7iX8Fhsr3JxZSiPnLUpvUHG3n0YQfpZNlJuc/p4N +HBKLuJHjKywhxbskmdRi3DBxjObsdHSofWSB66tBAoGASKtnyA7VYKqjIByFJTSb +IG13XBD0vZUORDGqzGl1F9M662LilGyWtq6jcZK3GiBerOBqICSv/GQOMCzHe9bT +vEN9ZFtW6cx6ZeX87/nK8k7yGa1kzZKR3T78eGAHWsOevR0ZabTZ7sD8y1AQ7HlM +ZDyjwT/20xHzh1/WKJ6VDzM= +-----END PRIVATE KEY-----